diff options
1462 files changed, 23139 insertions, 23738 deletions
diff --git a/.gitignore b/.gitignore index 0466eac85..b50bca3cf 100644 --- a/.gitignore +++ b/.gitignore @@ -98,6 +98,8 @@ doc/RecTutorial/RecTutorial.html doc/RecTutorial/RecTutorial.pdf doc/RecTutorial/RecTutorial.ps dev/doc/naming-conventions.pdf +dev/ocamldoc/*.html +dev/ocamldoc/*.css # .mll files @@ -105,8 +107,6 @@ dev/ocamlweb-doc/lex.ml ide/coq_lex.ml ide/config_lexer.ml ide/utf8_convert.ml -ide/highlight.ml -plugins/dp/dp_zenon.ml tools/gallina_lexer.ml tools/coqwc.ml tools/coqdep_lexer.ml @@ -119,29 +119,17 @@ lib/xml_lexer.ml g_*.ml ide/project_file.ml -lib/pp.ml parsing/compat.ml grammar/q_util.ml grammar/q_constr.ml -grammar/q_coqast.ml grammar/tacextend.ml grammar/vernacextend.ml grammar/argextend.ml -parsing/pcoq.ml parsing/lexer.ml -plugins/setoid_ring/newring.ml -plugins/field/field.ml -plugins/nsatz/nsatz.ml -tactics/tauto.ml -tactics/eauto.ml tactics/hipattern.ml -tactics/class_tactics.ml -tactics/coretactics.ml -tactics/rewrite.ml -tactics/eqdecide.ml -tactics/extratactics.ml -tactics/extraargs.ml -toplevel/whelp.ml +ltac/coretactics.ml +ltac/extratactics.ml +ltac/extraargs.ml ide/coqide_main.ml # other auto-generated files @@ -1,4 +1,60 @@ -Changes from V8.5beta2 to ... +Changes beyond V8.5 +=================== + +Tactics + +- Flag "Bracketing Last Introduction Pattern" is now on by default. +- New flag "Shrink Abstract" that minimalizes proofs generated by the abstract + tactical w.r.t. variables appearing in the body of the proof. +- Serious bugs are fixed in tactic "double induction" (source of + incompatibilities as soon as the inductive types have dependencies in + the type of their constructors; "double induction" remains however + deprecated). +- In introduction patterns of the form (pat1,...,patn), n should match + the exact number of hypotheses introduced (except for local definitions + for which pattern can be omitted, as in regular pattern-matching). +- Tactic scopes in Ltac like constr: and ltac: now require parentheses around + their argument. +- Every generic argument type declares a tactic scope of the form "name:(...)" + where name is the name of the argument. This generalizes the constr: and ltac: + instances. + +Program + +- The "Shrink Obligations" flag now applies to all obligations, not only those + solved by the automatic tactic. + +Changes from V8.5beta3 to V8.5 +============================== + +Tools + +- Flag "-compat 8.4" now loads Coq.Compat.Coq84. The standard way of + putting Coq in v8.4 compatibility mode is to pass the command line flag + "-compat 8.4". It can be followed by "-require Coq.Compat.AdmitAxiom" + if the 8.4 behavior of admit is needed, in which case it uses an axiom. + +Specification language + +- Syntax "$(tactic)$" changed to "ltac:(tactic)". + +Tactics + +- Syntax "destruct !hyp" changed to "destruct (hyp)", and similarly + for induction (rare source of incompatibilities easily solvable by + removing parentheses around "hyp" when not for the purpose of keeping + the hypothesis). +- Syntax "p/c" for on-the-fly application of a lemma c before + introducing along pattern p changed to p%c1..%cn. The feature and + syntax are in experimental stage. +- "Proof using" does not clear unused section variables. +- Tactic "refine" has been changed back to the 8.4 behavior of shelving subgoals + that occur in other subgoals. The "refine" tactic of 8.5beta3 has been + renamed "simple refine"; it does not shelve any subgoal. +- New tactical "unshelve tac" which grab existential variables put on + the tactic shelve by the execution of "tac". + +Changes from V8.5beta2 to V8.5beta3 =================================== Vernacular commands @@ -8,6 +64,8 @@ Vernacular commands - 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. +- Option "Virtual Machine" removed. Tactics @@ -42,7 +100,8 @@ solved by the automatic tactic. 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 @@ -72,6 +131,14 @@ Tools - 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. +- The -vm command-line option has been removed. + +Standard Library + + - There is now a Coq.Compat.Coq84 library, which sets the various compatibility + options and does a few redefinitions to make Coq behave more like Coq v8.4. + The standard way of putting Coq in v8.4 compatibility mode is to pass the command + line flags "-require Coq.Compat.Coq84 -compat 8.4". Changes from V8.5beta1 to V8.5beta2 =================================== @@ -81,6 +148,10 @@ Logic - The VM now supports inductive types with up to 8388851 non-constant constructors and up to 8388607 constant ones. +Specification language + +- Syntax "$(tactic)$" changed to "ltac: tactic". + Tactics - A script using the admit tactic can no longer be concluded by either @@ -105,8 +176,6 @@ 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 ============================== @@ -402,6 +471,9 @@ Program - "Solve Obligations using" changed to "Solve Obligations with", consistent with "Proof with". - Program Lemma, Definition now respect automatic introduction. +- Program Lemma, Definition, etc.. now interpret "->" like Lemma and + Definition as a non-dependent arrow (potential source of + incompatibility). - Add/document "Set Hide Obligations" (to hide obligations in the final term inside an implicit argument) and "Set Shrink Obligations" (to minimize dependencies of obligations defined by tactics). @@ -458,11 +530,9 @@ Interfaces documentation of OCaml's Str module for the supported syntax. - Many CoqIDE windows, including the query one, are now detachable to improve usability on multi screen work stations. - - 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. - - Third party user interfaces can install their main loop in $COQLIB/toploop and call coqtop with the -toploop flag to select it. @@ -60,10 +60,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 765880058..2472d2b2a 100644 --- a/INSTALL.doc +++ b/INSTALL.doc @@ -22,8 +22,8 @@ To produce all the documents, the following tools are needed: - dvips - bibtex - makeindex - - fig2dev - - convert + - fig2dev (transfig) + - convert (ImageMagick) - hevea - hacha diff --git a/INSTALL.ide b/INSTALL.ide index 6e41b2d05..b651e77db 100644 --- a/INSTALL.ide +++ b/INSTALL.ide @@ -39,7 +39,7 @@ COMPILATION REQUIREMENTS install GTK+ 2.x, should you need to force it for one reason or another.) - The OCaml bindings for GTK+ 2.x, lablgtk2 with support for gtksourceview2. - You need at least version 2.14.2. + You need at least version 2.16. Your distribution may contain precompiled packages. For example, for Debian, run diff --git a/Makefile.build b/Makefile.build index 957592640..190a62d00 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 @@ -132,10 +132,11 @@ SYSMOD:=str unix dynlink threads SYSCMA:=$(addsuffix .cma,$(SYSMOD)) SYSCMXA:=$(addsuffix .cmxa,$(SYSMOD)) +# We do not repeat the dependencies already in SYSMOD here ifeq ($(CAMLP4),camlp5) P4CMA:=gramlib.cma else -P4CMA:=dynlink.cma camlp4lib.cma +P4CMA:=camlp4lib.cma endif @@ -294,9 +295,10 @@ checker/check.cmxa: | md5chk checker/check.mllib.d # Csdp to micromega special targets ########################################################################### -plugins/micromega/csdpcert$(EXE): $(CSDPCERTCMO:.cmo=$(BESTOBJ)) +plugins/micromega/csdpcert$(EXE): $(CSDPCERTCMO:.cmo=$(BESTOBJ)) \ + $(addsuffix $(BESTLIB), lib/clib) $(SHOW)'OCAMLBEST -o $@' - $(HIDE)$(call bestocaml,,nums unix) + $(HIDE)$(call bestocaml,,nums unix clib) ########################################################################### # CoqIde special targets @@ -494,14 +496,14 @@ check: validate test-suite test-suite: world $(ALLSTDLIB).v $(MAKE) $(MAKE_TSOPTS) clean $(MAKE) $(MAKE_TSOPTS) all - $(HIDE)if grep -F 'Error!' test-suite/summary.log ; then false; fi + $(MAKE) $(MAKE_TSOPTS) report ################################################################## # partial targets: 1) core ML parts ################################################################## .PHONY: lib kernel byterun library proofs tactics interp parsing pretyping -.PHONY: engine highparsing stm toplevel hightactics +.PHONY: engine highparsing stm toplevel ltac lib: lib/clib.cma lib/lib.cma kernel: kernel/kernel.cma @@ -516,7 +518,7 @@ pretyping: pretyping/pretyping.cma highparsing: parsing/highparsing.cma stm: stm/stm.cma toplevel: toplevel/toplevel.cma -hightactics: tactics/hightactics.cma +ltac: ltac/ltac.cma ########################################################################### # 2) theories and plugins files @@ -554,7 +556,6 @@ program: $(PROGRAMVO) structures: $(STRUCTURESVO) vectors: $(VECTORSVO) msets: $(MSETSVO) -mmaps: $(MMAPSVO) compat: $(COMPATVO) noreal: unicode logic arith bool zarith qarith lists sets fsets \ @@ -587,9 +588,9 @@ pluginsbyte: $(PLUGINS) ########################################################################### theories/Init/%.vo theories/Init/%.glob: theories/Init/%.v $(VO_TOOLS_DEP) | theories/Init/%.v.d - $(SHOW)'COQC -noinit $<' + $(SHOW)'COQC $(COQ_XML) -noinit $<' $(HIDE)rm -f theories/Init/$*.glob - $(HIDE)$(BOOTCOQC) $< -noinit -R theories Coq + $(HIDE)$(BOOTCOQC) $< $(COQ_XML) -noinit -R theories Coq theories/Numbers/Natural/BigN/NMake_gen.v: theories/Numbers/Natural/BigN/NMake_gen.ml $(OCAML) $< $(TOTARGET) @@ -827,12 +828,18 @@ install-latex: source-doc: mli-doc $(OCAMLDOCDIR)/coq.pdf $(OCAMLDOCDIR)/coq.tex: $(DOCMLIS:.mli=.cmi) - $(OCAMLFIND) ocamldoc -latex -rectypes -I $(MYCAMLP4LIB) $(MLINCLUDES)\ - $(DOCMLIS) -t "Coq mlis documentation" \ - -intro $(OCAMLDOCDIR)/docintro -o $@ + $(SHOW)'OCAMLDOC -latex -o $@' + $(HIDE)$(OCAMLFIND) ocamldoc -latex -rectypes -I $(MYCAMLP4LIB) $(MLINCLUDES)\ + $(DOCMLIS) -noheader -t "Coq mlis documentation" \ + -intro $(OCAMLDOCDIR)/docintro -o $@.tmp + $(SHOW)'OCAMLDOC utf8 fix' + $(HIDE)$(OCAMLDOCDIR)/fix-ocamldoc-utf8 $@.tmp + $(HIDE)cat $(OCAMLDOCDIR)/header.tex $@.tmp > $@ + rm $@.tmp mli-doc: $(DOCMLIS:.mli=.cmi) - $(OCAMLFIND) ocamldoc -html -rectypes -I +threads -I $(MYCAMLP4LIB) $(MLINCLUDES) \ + $(SHOW)'OCAMLDOC -html' + $(HIDE)$(OCAMLFIND) ocamldoc -charset utf-8 -html -rectypes -I +threads -I $(MYCAMLP4LIB) $(MLINCLUDES) \ $(DOCMLIS) -d $(OCAMLDOCDIR)/html -colorize-code \ -t "Coq mlis documentation" -intro $(OCAMLDOCDIR)/docintro \ -css-style style.css @@ -854,7 +861,7 @@ OCAMLDOC_MLLIBD = $(OCAMLFIND) ocamldoc -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) - $(OCAMLDOC_MLLIBD) ml-doc: - $(OCAMLFIND) ocamldoc -html -rectypes -I +threads $(MLINCLUDES) $(COQIDEFLAGS) -d $(OCAMLDOCDIR) $(MLSTATICFILES) + $(OCAMLFIND) ocamldoc -charset utf-8 -html -rectypes -I +threads $(MLINCLUDES) $(COQIDEFLAGS) -d $(OCAMLDOCDIR) $(MLSTATICFILES) parsing/parsing.dot : | parsing/parsing.mllib.d parsing/highparsing.mllib.d $(OCAMLDOC_MLLIBD) @@ -862,14 +869,16 @@ parsing/parsing.dot : | parsing/parsing.mllib.d parsing/highparsing.mllib.d grammar/grammar.dot : | grammar/grammar.mllib.d $(OCAMLDOC_MLLIBD) -tactics/tactics.dot: | tactics/tactics.mllib.d tactics/hightactics.mllib.d +tactics/tactics.dot: | tactics/tactics.mllib.d ltac/ltac.mllib.d $(OCAMLDOC_MLLIBD) %.dot: %.mli $(OCAMLFIND) ocamldoc -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -o $@ $< $(OCAMLDOCDIR)/%.pdf: $(OCAMLDOCDIR)/%.tex - (cd $(OCAMLDOCDIR) ; pdflatex $*.tex && pdflatex $*.tex) + $(SHOW)'PDFLATEX $*.tex' + $(HIDE)(cd $(OCAMLDOCDIR) ; pdflatex -interaction=batchmode $*.tex && pdflatex -interaction=batchmode $*.tex) + $(HIDE)(cd doc/tools/; show_latex_messages -no-overfull ../../$(OCAMLDOCDIR)/$*.log) ########################################################################### ### Special rules @@ -880,7 +889,7 @@ dev/printers.cma: | dev/printers.mllib.d $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) -thread $(SYSCMA) $(P4CMA) $^ -o test-printer @rm -f test-printer $(SHOW)'OCAMLC -a $@' - $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) -thread $(SYSCMA) $^ -linkall -a -o $@ + $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) -thread $(SYSCMA) $(P4CMA) $^ -linkall -a -o $@ grammar/grammar.cma: | grammar/grammar.mllib.d $(SHOW)'Testing $@' diff --git a/Makefile.common b/Makefile.common index 1bc09b9ba..3e2bfcb3a 100644 --- a/Makefile.common +++ b/Makefile.common @@ -63,7 +63,7 @@ CSDPCERT:=plugins/micromega/csdpcert$(EXE) CORESRCDIRS:=\ config lib kernel kernel/byterun library \ proofs tactics pretyping interp stm \ - toplevel parsing printing grammar intf engine + toplevel parsing printing grammar intf engine ltac PLUGINS:=\ omega romega micromega quote \ @@ -161,14 +161,14 @@ BYTERUN:=$(addprefix kernel/byterun/, \ coq_fix_code.o coq_memory.o coq_values.o coq_interp.o ) # LINK ORDER: -# Beware that highparsing.cma should appear before hightactics.cma +# Beware that highparsing.cma should appear before ltac.cma # respecting this order is useful for developers that want to load or link # the libraries directly CORECMA:=lib/clib.cma lib/lib.cma kernel/kernel.cma library/library.cma \ engine/engine.cma pretyping/pretyping.cma interp/interp.cma proofs/proofs.cma \ parsing/parsing.cma printing/printing.cma tactics/tactics.cma \ - stm/stm.cma toplevel/toplevel.cma parsing/highparsing.cma tactics/hightactics.cma + stm/stm.cma toplevel/toplevel.cma parsing/highparsing.cma ltac/ltac.cma TOPLOOPCMA:=stm/proofworkertop.cma stm/tacworkertop.cma stm/queryworkertop.cma @@ -293,7 +293,6 @@ STRINGSVO:=$(call cat_vo_itarget, theories/Strings) SETSVO:=$(call cat_vo_itarget, theories/Sets) FSETSVO:=$(call cat_vo_itarget, theories/FSets) MSETSVO:=$(call cat_vo_itarget, theories/MSets) -MMAPSVO:=$(call cat_vo_itarget, theories/MMaps) RELATIONSVO:=$(call cat_vo_itarget, theories/Relations) WELLFOUNDEDVO:=$(call cat_vo_itarget, theories/Wellfounded) REALSVO:=$(call cat_vo_itarget, theories/Reals) @@ -310,7 +309,7 @@ THEORIESVO:=\ $(RELATIONSVO) $(WELLFOUNDEDVO) $(SETOIDSVO) \ $(LISTSVO) $(STRINGSVO) \ $(PARITHVO) $(NARITHVO) $(ZARITHVO) \ - $(SETSVO) $(FSETSVO) $(MSETSVO) $(MMAPSVO) \ + $(SETSVO) $(FSETSVO) $(MSETSVO) \ $(REALSVO) $(SORTINGVO) $(QARITHVO) \ $(NUMBERSVO) $(STRUCTURESVO) $(VECTORSVO) \ $(COMPATVO) @@ -380,7 +379,7 @@ OCAMLDOCDIR=dev/ocamldoc DOCMLIS=$(wildcard ./lib/*.mli ./intf/*.mli ./kernel/*.mli ./library/*.mli \ ./engine/*.mli ./pretyping/*.mli ./interp/*.mli printing/*.mli \ ./parsing/*.mli ./proofs/*.mli \ - ./tactics/*.mli ./stm/*.mli ./toplevel/*.mli) + ./tactics/*.mli ./stm/*.mli ./toplevel/*.mli ./ltac/*.mli) # Defining options to generate dependencies graphs DOT=dot diff --git a/README b/README deleted file mode 100644 index 293ee4c8f..000000000 --- a/README +++ /dev/null @@ -1,66 +0,0 @@ - - THE COQ V8 SYSTEM - ================= - -INSTALLATION. -============= - - See the file INSTALL for installation procedure. - - -DOCUMENTATION. -============== - - The documentation is part of the archive in directory doc. The - documentation of the last released version is available on the Coq - web site at http://coq.inria.fr/doc. - - -CHANGES. -======== - - There is a file named CHANGES that explains the differences and the - incompatibilities since last versions. If you upgrade Coq, please read - it carefully. - - -AVAILABILITY. -============= - - Coq is available from http://coq.inria.fr. - - -THE COQ CLUB. -============= - - The Coq Club moderated mailing list is meant to be a standard way - to discuss questions about the Coq system and related topics. The - subscription link can be found at http://coq.inria.fr/community. - - The topics to be discussed in the club should include: - - * technical problems; - - * questions about proof developments; - - * suggestions and questions about the implementation; - - * announcements of proofs; - - * theoretical questions about typed lambda-calculi which are - closely related to Coq. - - For any questions/suggestions about the Coq Club, please write to - coq-club-request@inria.fr. - - -BUGS REPORT. -============ - - Send your bug reports by filling a form at - - http://coq.inria.fr/bugs - - To be effective, bug reports should mention the Caml version used - to compile and run Coq, the Coq version (coqtop -v), the configuration - used, and include a complete source example leading to the bug. diff --git a/README.md b/README.md new file mode 100644 index 000000000..a41ee7cc0 --- /dev/null +++ b/README.md @@ -0,0 +1,44 @@ +# Coq +Coq is a formal proof management system. It provides a formal language to write +mathematical definitions, executable algorithms and theorems together with an +environment for semi-interactive development of machine-checked proofs. + +## Installation +See the file `INSTALL` for installation procedure. + +## Documentation +The documentation is part of the archive in directory doc. The +documentation of the last released version is available on the Coq +web site at [coq.inria.fr/doc](http://coq.inria.fr/doc). + +## Changes +There is a file named `CHANGES` that explains the differences and the +incompatibilities since last versions. If you upgrade Coq, please read +it carefully. + +## Availability +Coq is available from [coq.inria.fr](http://coq.inria.fr). + +## The Coq Club +The Coq Club moderated mailing list is meant to be a standard way +to discuss questions about the Coq system and related topics. The +subscription link can be found at [coq.inria.fr/community](http://coq.inria.fr/community). + +The topics to be discussed in the club should include: + +* technical problems; +* questions about proof developments; +* suggestions and questions about the implementation; +* announcements of proofs; +* theoretical questions about typed lambda-calculi which are + closely related to Coq. + +For any questions/suggestions about the Coq Club, please write to +`coq-club-request@inria.fr`. + +## Bugs report +Send your bug reports by filling a form at [coq.inria.fr/bugs](http://coq.inria.fr/bugs). + +To be effective, bug reports should mention the OCaml version used +to compile and run Coq, the Coq version (`coqtop -v`), the configuration +used, and include a complete source example leading to the bug. diff --git a/checker/check.ml b/checker/check.ml index 2bc470aea..3a5c91217 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -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 @@ -347,9 +347,8 @@ let intern_from_file (dir, f) = 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 + 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) = diff --git a/checker/check.mllib b/checker/check.mllib index 246fe64de..900cfe0c8 100644 --- a/checker/check.mllib +++ b/checker/check.mllib @@ -8,6 +8,7 @@ Hashcons CSet CMap Int +Dyn HMap Option Store @@ -17,6 +18,8 @@ Flags Control Pp_control Loc +CList +CString Serialize Stateid Feedback @@ -25,14 +28,12 @@ Segmenttree Unicodetable Unicode CObj -CList -CString CArray CStack Util Ppstyle Errors -Ephemeron +CEphemeron Future CUnix diff --git a/checker/check_stat.ml b/checker/check_stat.ml index d041f1b7e..d031975d7 100644 --- a/checker/check_stat.ml +++ b/checker/check_stat.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/checker/check_stat.mli b/checker/check_stat.mli index 10908f0cc..39e19d10e 100644 --- a/checker/check_stat.mli +++ b/checker/check_stat.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/checker/checker.ml b/checker/checker.ml index d5d9b9e3b..91a207a60 100644 --- a/checker/checker.ml +++ b/checker/checker.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -217,12 +217,6 @@ open Type_errors let anomaly_string () = str "Anomaly: " let report () = (str "." ++ spc () ++ str "Please report.") -let print_loc loc = - if loc = Loc.ghost then - (str"<unknown>") - else - let loc = Loc.unloc loc in - (int (fst loc) ++ str"-" ++ int (snd loc)) let guill s = str "\"" ++ str s ++ str "\"" let where s = @@ -337,8 +331,6 @@ let parse_args argv = | ("-I"|"-include") :: d :: rem -> set_default_include d; parse rem | ("-I"|"-include") :: [] -> usage () - | "-R" :: d :: "-as" :: p :: rem -> set_rec_include d p;parse rem - | "-R" :: d :: "-as" :: [] -> usage () | "-R" :: d :: p :: rem -> set_rec_include d p;parse rem | "-R" :: ([] | [_]) -> usage () diff --git a/checker/cic.mli b/checker/cic.mli index bd75111a2..00ac2f56c 100644 --- a/checker/cic.mli +++ b/checker/cic.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -111,7 +111,8 @@ type cofixpoint = constr pcofixpoint (** {6 Type of assumptions and contexts} *) -type rel_declaration = Name.t * constr option * constr +type rel_declaration = LocalAssum of Name.t * constr (* name, type *) + | LocalDef of Name.t * constr * constr (* name, value, type *) type rel_context = rel_declaration list (** The declarations below in .vo should be outside sections, diff --git a/checker/closure.ml b/checker/closure.ml index c6cc2185d..c2708e97d 100644 --- a/checker/closure.ml +++ b/checker/closure.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -217,10 +217,10 @@ let ref_value_cache info ref = let defined_rels flags env = (* if red_local_const (snd flags) then*) fold_rel_context - (fun (id,b,t) (i,subs) -> - match b with - | None -> (i+1, subs) - | Some body -> (i+1, (i,body) :: subs)) + (fun decl (i,subs) -> + match decl with + | LocalAssum _ -> (i+1, subs) + | LocalDef (_,body,_) -> (i+1, (i,body) :: subs)) (rel_context env) ~init:(0,[]) (* else (0,[])*) diff --git a/checker/closure.mli b/checker/closure.mli index 376e9fef7..8b1f246c2 100644 --- a/checker/closure.mli +++ b/checker/closure.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/checker/declarations.ml b/checker/declarations.ml index 36e6a7cab..3ce312533 100644 --- a/checker/declarations.ml +++ b/checker/declarations.ml @@ -426,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) -> @@ -435,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 @@ -457,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 @@ -515,11 +517,8 @@ let map_decl_arity f g = function | RegularArity a -> RegularArity (f a) | TemplateArity a -> TemplateArity (g a) - -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 - if copt == copt' && t == t' then x else (id,copt',t') +let subst_rel_declaration sub = + Term.map_rel_decl (subst_mps sub) let subst_rel_context sub = List.smartmap (subst_rel_declaration sub) diff --git a/checker/declarations.mli b/checker/declarations.mli index 3c6db6ab7..456df8369 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 f8f5c29b7..7040fdda4 100644 --- a/checker/environ.ml +++ b/checker/environ.ml @@ -80,7 +80,7 @@ let push_rel d env = let push_rel_context ctxt x = fold_rel_context push_rel ctxt ~init:x let push_rec_types (lna,typarray,_) env = - let ctxt = Array.map2_i (fun i na t -> (na, None, lift i t)) lna typarray in + let ctxt = Array.map2_i (fun i na t -> LocalAssum (na, lift i t)) lna typarray in Array.fold_left (fun e assum -> push_rel assum e) env ctxt (* Universe constraints *) diff --git a/checker/indtypes.ml b/checker/indtypes.ml index f02f03dcb..566df673c 100644 --- a/checker/indtypes.ml +++ b/checker/indtypes.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -56,10 +56,10 @@ let is_constructor_head t = let conv_ctxt_prefix env (ctx1:rel_context) ctx2 = let rec chk env rctx1 rctx2 = match rctx1, rctx2 with - (_,None,ty1 as d1)::rctx1', (_,None,ty2)::rctx2' -> + (LocalAssum (_,ty1) as d1)::rctx1', LocalAssum (_,ty2)::rctx2' -> conv env ty1 ty2; chk (push_rel d1 env) rctx1' rctx2' - | (_,Some bd1,ty1 as d1)::rctx1', (_,Some bd2,ty2)::rctx2' -> + | (LocalDef (_,bd1,ty1) as d1)::rctx1', LocalDef (_,bd2,ty2)::rctx2' -> conv env ty1 ty2; conv env bd1 bd2; chk (push_rel d1 env) rctx1' rctx2' @@ -94,10 +94,10 @@ let rec sorts_of_constr_args env t = match t with | Prod (name,c1,c2) -> let varj = infer_type env c1 in - let env1 = push_rel (name,None,c1) env in + let env1 = push_rel (LocalAssum (name,c1)) env in varj :: sorts_of_constr_args env1 c2 | LetIn (name,def,ty,c) -> - let env1 = push_rel (name,Some def,ty) env in + let env1 = push_rel (LocalDef (name,def,ty)) env in sorts_of_constr_args env1 c | _ when is_constructor_head t -> [] | _ -> anomaly ~label:"infos_and_sort" (Pp.str "not a positive constructor") @@ -167,7 +167,7 @@ let typecheck_arity env params inds = full_arity is used as argument or subject to cast, an upper universe will be generated *) let id = ind.mind_typename in - let env_ar' = push_rel (Name id, None, arity) env_ar in + let env_ar' = push_rel (LocalAssum (Name id, arity)) env_ar in env_ar') env inds in @@ -319,7 +319,7 @@ let check_correct_par (env,n,ntypes,_) hyps l largs = let nhyps = List.length hyps in let rec check k index = function | [] -> () - | (_,Some _,_)::hyps -> check k (index+1) hyps + | LocalDef _ :: hyps -> check k (index+1) hyps | _::hyps -> match whd_betadeltaiota env lpar.(k) with | Rel w when w = index -> check (k-1) (index+1) hyps @@ -340,7 +340,7 @@ let check_rec_par (env,n,_,_) hyps nrecp largs = | ([],_) -> () | (_,[]) -> failwith "number of recursive parameters cannot be greater than the number of parameters." - | (lp,(_,Some _,_)::hyps) -> find (index-1) (lp,hyps) + | (lp,LocalDef _ :: hyps) -> find (index-1) (lp,hyps) | (p::lp,_::hyps) -> (match whd_betadeltaiota env p with | Rel w when w = index -> find (index-1) (lp,hyps) @@ -370,14 +370,15 @@ let abstract_mind_lc env ntyps npars lc = [lra] is the list of recursive tree of each variable *) let ienv_push_var (env, n, ntypes, lra) (x,a,ra) = - (push_rel (x,None,a) env, n+1, ntypes, (Norec,ra)::lra) + (push_rel (LocalAssum (x,a)) env, n+1, ntypes, (Norec,ra)::lra) let ienv_push_inductive (env, n, ntypes, ra_env) ((mi,u),lpar) = let auxntyp = 1 in let specif = lookup_mind_specif env mi in let env' = - push_rel (Anonymous,None, - hnf_prod_applist env (type_of_inductive env (specif,u)) lpar) env in + let decl = LocalAssum (Anonymous, + hnf_prod_applist env (type_of_inductive env (specif,u)) lpar) in + push_rel decl env in let ra_env' = (Imbr mi,(Rtree.mk_rec_calls 1).(0)) :: List.map (fun (r,t) -> (r,Rtree.lift 1 t)) ra_env in diff --git a/checker/indtypes.mli b/checker/indtypes.mli index 5188f80d1..071eecbbc 100644 --- a/checker/indtypes.mli +++ b/checker/indtypes.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/checker/inductive.ml b/checker/inductive.ml index 21b80f323..43a32ea24 100644 --- a/checker/inductive.ml +++ b/checker/inductive.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -88,10 +88,10 @@ let instantiate_params full t u args sign = anomaly ~label:"instantiate_params" (Pp.str "type, ctxt and args mismatch") in let (rem_args, subs, ty) = fold_rel_context - (fun (_,copt,_) (largs,subs,ty) -> - match (copt, largs, ty) with - | (None, a::args, Prod(_,_,t)) -> (args, a::subs, t) - | (Some b,_,LetIn(_,_,_,t)) -> + (fun decl (largs,subs,ty) -> + match (decl, largs, ty) with + | (LocalAssum _, a::args, Prod(_,_,t)) -> (args, a::subs, t) + | (LocalDef (_,b,_),_,LetIn(_,_,_,t)) -> (largs, (substl subs (subst_instance_constr u b))::subs, t) | (_,[],_) -> if full then fail() else ([], subs, ty) | _ -> fail ()) @@ -161,7 +161,7 @@ let remember_subst u subst = (* Propagate the new levels in the signature *) let rec make_subst env = let rec make subst = function - | (_,Some _,_)::sign, exp, args -> + | LocalDef _ :: sign, exp, args -> make subst (sign, exp, args) | d::sign, None::exp, args -> let args = match args with _::args -> args | [] -> [] in @@ -174,7 +174,7 @@ let rec make_subst env = (* 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, [] -> + | LocalAssum (na,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 *) @@ -319,8 +319,8 @@ let elim_sorts (_,mip) = mip.mind_kelim let extended_rel_list n hyps = let rec reln l p = function - | (_,None,_) :: hyps -> reln (Rel (n+p) :: l) (p+1) hyps - | (_,Some _,_) :: hyps -> reln l (p+1) hyps + | LocalAssum _ :: hyps -> reln (Rel (n+p) :: l) (p+1) hyps + | LocalDef _ :: hyps -> reln l (p+1) hyps | [] -> l in reln [] 1 hyps @@ -345,12 +345,12 @@ let is_correct_arity env c (p,pj) ind specif params = let rec srec env pt ar = let pt' = whd_betadeltaiota env pt in match pt', ar with - | Prod (na1,a1,t), (_,None,a1')::ar' -> + | Prod (na1,a1,t), LocalAssum (_,a1')::ar' -> (try conv env a1 a1' with NotConvertible -> raise (LocalArity None)); - srec (push_rel (na1,None,a1) env) t ar' + srec (push_rel (LocalAssum (na1,a1)) env) t ar' | Prod (na1,a1,a2), [] -> (* whnf of t was not needed here! *) - let env' = push_rel (na1,None,a1) env in + let env' = push_rel (LocalAssum (na1,a1)) env in let ksort = match (whd_betadeltaiota env' a2) with | Sort s -> family_of_sort s | _ -> raise (LocalArity None) in @@ -362,8 +362,8 @@ let is_correct_arity env c (p,pj) ind specif params = | Sort s', [] -> check_allowed_sort (family_of_sort s') specif; false - | _, (_,Some _,_ as d)::ar' -> - srec (push_rel d env) (lift 1 pt') ar' + | _, (LocalDef _ as d)::ar' -> + srec (push_rel d env) (lift 1 pt') ar' | _ -> raise (LocalArity None) in @@ -527,10 +527,10 @@ type guard_env = let make_renv env recarg tree = { env = env; rel_min = recarg+2; (* recarg = 0 ==> Rel 1 -> recarg; Rel 2 -> fix *) - genv = [Lazy.lazy_from_val(Subterm(Large,tree))] } + genv = [Lazy.from_val(Subterm(Large,tree))] } let push_var renv (x,ty,spec) = - { env = push_rel (x,None,ty) renv.env; + { env = push_rel (LocalAssum (x,ty)) renv.env; rel_min = renv.rel_min+1; genv = spec:: renv.genv } @@ -538,7 +538,7 @@ let assign_var_spec renv (i,spec) = { renv with genv = List.assign renv.genv (i-1) spec } let push_var_renv renv (x,ty) = - push_var renv (x,ty,Lazy.lazy_from_val Not_subterm) + push_var renv (x,ty,Lazy.from_val Not_subterm) (* Fetch recursive information about a variable p *) let subterm_var p renv = @@ -549,13 +549,13 @@ let push_ctxt_renv renv ctxt = let n = rel_context_length ctxt in { env = push_rel_context ctxt renv.env; rel_min = renv.rel_min+n; - genv = iterate (fun ge -> Lazy.lazy_from_val Not_subterm::ge) n renv.genv } + genv = iterate (fun ge -> Lazy.from_val Not_subterm::ge) n renv.genv } let push_fix_renv renv (_,v,_ as recdef) = let n = Array.length v in { env = push_rec_types recdef renv.env; rel_min = renv.rel_min+n; - genv = iterate (fun ge -> Lazy.lazy_from_val Not_subterm::ge) n renv.genv } + genv = iterate (fun ge -> Lazy.from_val Not_subterm::ge) n renv.genv } (* Definition and manipulation of the stack *) @@ -628,14 +628,15 @@ let check_inductive_codomain env p = (* The following functions are almost duplicated from indtypes.ml, except that they carry here a poorer environment (containing less information). *) let ienv_push_var (env, lra) (x,a,ra) = -(push_rel (x,None,a) env, (Norec,ra)::lra) +(push_rel (LocalAssum (x,a)) env, (Norec,ra)::lra) let ienv_push_inductive (env, ra_env) ((mind,u),lpar) = let mib = Environ.lookup_mind mind env in let ntypes = mib.mind_ntypes in let push_ind specif env = - push_rel (Anonymous,None, - hnf_prod_applist env (type_of_inductive env ((mib,specif),u)) lpar) env + let decl = LocalAssum (Anonymous, + hnf_prod_applist env (type_of_inductive env ((mib,specif),u)) lpar) in + push_rel decl env in let env = Array.fold_right push_ind mib.mind_packets env in let rc = Array.mapi (fun j t -> (Imbr (mind,j),t)) (Rtree.mk_rec_calls ntypes) in @@ -861,7 +862,7 @@ and stack_element_specif = function |SArg x -> x and extract_stack renv a = function - | [] -> Lazy.lazy_from_val Not_subterm , [] + | [] -> Lazy.from_val Not_subterm , [] | h::t -> stack_element_specif h, t @@ -902,7 +903,7 @@ let filter_stack_domain env ci p stack = let t = whd_betadeltaiota env ar in match stack, t with | elt :: stack', Prod (n,a,c0) -> - let d = (n,None,a) in + let d = LocalAssum (n,a) in let ty, args = decompose_app (whd_betadeltaiota env a) in let elt = match ty with | Ind ind -> @@ -956,10 +957,10 @@ let check_one_fix renv recpos trees def = end else begin - match pi2 (lookup_rel p renv.env) with - | None -> + match lookup_rel p renv.env with + | LocalAssum _ -> List.iter (check_rec_call renv []) l - | Some c -> + | LocalDef (_,c,_) -> try List.iter (check_rec_call renv []) l with FixGuardError _ -> check_rec_call renv stack (applist(lift p c,l)) @@ -1078,7 +1079,7 @@ let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) = match (whd_betadeltaiota env def) with | Lambda (x,a,b) -> if noccur_with_meta n nbfix a then - let env' = push_rel (x, None, a) env in + let env' = push_rel (LocalAssum (x,a)) env in if n = k+1 then (* get the inductive type of the fixpoint *) let (mind, _) = @@ -1127,7 +1128,7 @@ let rec codomain_is_coind env c = let b = whd_betadeltaiota env c in match b with | Prod (x,a,b) -> - codomain_is_coind (push_rel (x, None, a) env) b + codomain_is_coind (push_rel (LocalAssum (x,a)) env) b | _ -> (try find_coinductive env b with Not_found -> @@ -1168,7 +1169,7 @@ let check_one_cofix env nbfix def deftype = | Lambda (x,a,b) -> assert (args = []); if noccur_with_meta n nbfix a then - let env' = push_rel (x, None, a) env in + let env' = push_rel (LocalAssum (x,a)) env in check_rec_call env' alreadygrd (n+1) tree vlra b else raise (CoFixGuardError (env,RecCallInTypeOfAbstraction a)) diff --git a/checker/inductive.mli b/checker/inductive.mli index 78fb0bdd1..ed3a7b53c 100644 --- a/checker/inductive.mli +++ b/checker/inductive.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/checker/mod_checking.mli b/checker/mod_checking.mli index ae28caed0..5c7b392ff 100644 --- a/checker/mod_checking.mli +++ b/checker/mod_checking.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/checker/modops.ml b/checker/modops.ml index 7f07f8bf8..9f4375262 100644 --- a/checker/modops.ml +++ b/checker/modops.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/checker/modops.mli b/checker/modops.mli index e22c2656c..26a088f32 100644 --- a/checker/modops.mli +++ b/checker/modops.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/checker/print.ml b/checker/print.ml index 7624fd325..9cd8fda5d 100644 --- a/checker/print.ml +++ b/checker/print.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/checker/reduction.ml b/checker/reduction.ml index 384d883ea..f1aa5d919 100644 --- a/checker/reduction.ml +++ b/checker/reduction.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -490,7 +490,7 @@ let dest_prod env = let t = whd_betadeltaiota env c in match t with | Prod (n,a,c0) -> - let d = (n,None,a) in + let d = LocalAssum (n,a) in decrec (push_rel d env) (d::m) c0 | _ -> m,t in @@ -502,10 +502,10 @@ let dest_prod_assum env = let rty = whd_betadeltaiota_nolet env ty in match rty with | Prod (x,t,c) -> - let d = (x,None,t) in + let d = LocalAssum (x,t) in prodec_rec (push_rel d env) (d::l) c | LetIn (x,b,t,c) -> - let d = (x,Some b,t) in + let d = LocalDef (x,b,t) in prodec_rec (push_rel d env) (d::l) c | Cast (c,_,_) -> prodec_rec env l c | _ -> @@ -520,10 +520,10 @@ let dest_lam_assum env = let rty = whd_betadeltaiota_nolet env ty in match rty with | Lambda (x,t,c) -> - let d = (x,None,t) in + let d = LocalAssum (x,t) in lamec_rec (push_rel d env) (d::l) c | LetIn (x,b,t,c) -> - let d = (x,Some b,t) in + let d = LocalDef (x,b,t) in lamec_rec (push_rel d env) (d::l) c | Cast (c,_,_) -> lamec_rec env l c | _ -> l,rty diff --git a/checker/reduction.mli b/checker/reduction.mli index 2e8734698..2f551f4a6 100644 --- a/checker/reduction.mli +++ b/checker/reduction.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/checker/safe_typing.ml b/checker/safe_typing.ml index d3bc8373a..7f9ed92f9 100644 --- a/checker/safe_typing.ml +++ b/checker/safe_typing.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -13,6 +13,8 @@ open Cic open Names open Environ +let pr_dirpath dp = str (DirPath.to_string dp) + (************************************************************************) (* * Global environment @@ -28,7 +30,7 @@ let set_engagement c = let full_add_module dp mb univs digest = let env = !genv in let env = push_context_set ~strict:true mb.mod_constraints env in - let env = add_constraints univs 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 @@ -52,9 +54,9 @@ let check_engagement env (expected_impredicative_set,expected_type_in_type) = let report_clash f caller dir = let msg = - str "compiled library " ++ str(DirPath.to_string caller) ++ + str "compiled library " ++ pr_dirpath caller ++ spc() ++ str "makes inconsistent assumptions over library" ++ spc() ++ - str(DirPath.to_string dir) ++ fnl() in + pr_dirpath dir ++ fnl() in f msg @@ -83,7 +85,7 @@ 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 + (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 e16e64e6a..8724f8e01 100644 --- a/checker/safe_typing.mli +++ b/checker/safe_typing.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -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/subtyping.ml b/checker/subtyping.ml index 372c31424..e41922573 100644 --- a/checker/subtyping.ml +++ b/checker/subtyping.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/checker/subtyping.mli b/checker/subtyping.mli index 03242cbcf..cc66fc538 100644 --- a/checker/subtyping.mli +++ b/checker/subtyping.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/checker/term.ml b/checker/term.ml index 430be4951..56cc9cdc2 100644 --- a/checker/term.ml +++ b/checker/term.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -222,24 +222,29 @@ let rel_context_length = List.length let rel_context_nhyps hyps = let rec nhyps acc = function | [] -> acc - | (_,None,_)::hyps -> nhyps (1+acc) hyps - | (_,Some _,_)::hyps -> nhyps acc hyps in + | LocalAssum _ :: hyps -> nhyps (1+acc) hyps + | LocalDef _ :: hyps -> nhyps acc hyps in nhyps 0 hyps let fold_rel_context f l ~init = List.fold_right f l init -let map_rel_context f l = - let map_decl (n, body_o, typ as decl) = - let body_o' = Option.smartmap f body_o in - let typ' = f typ in - if body_o' == body_o && typ' == typ then decl else - (n, body_o', typ') - in - List.smartmap map_decl l +let map_rel_decl f = function + | LocalAssum (n, typ) as decl -> + let typ' = f typ in + if typ' == typ then decl else + LocalAssum (n, typ') + | LocalDef (n, body, typ) as decl -> + let body' = f body in + let typ' = f typ in + if body' == body && typ' == typ then decl else + LocalDef (n, body', typ') + +let map_rel_context f = + List.smartmap (map_rel_decl f) let extended_rel_list n hyps = let rec reln l p = function - | (_,None,_) :: hyps -> reln (Rel (n+p) :: l) (p+1) hyps - | (_,Some _,_) :: hyps -> reln l (p+1) hyps + | LocalAssum _ :: hyps -> reln (Rel (n+p) :: l) (p+1) hyps + | LocalDef _ :: hyps -> reln l (p+1) hyps | [] -> l in reln [] 1 hyps @@ -272,8 +277,8 @@ let decompose_lam_n_assum n = let rec lamdec_rec l n c = if Int.equal n 0 then l,c else match c with - | Lambda (x,t,c) -> lamdec_rec ((x,None,t) :: l) (n-1) c - | LetIn (x,b,t,c) -> lamdec_rec ((x,Some b,t) :: l) n c + | Lambda (x,t,c) -> lamdec_rec (LocalAssum (x,t) :: l) (n-1) c + | LetIn (x,b,t,c) -> lamdec_rec (LocalDef (x,b,t) :: l) n c | Cast (c,_,_) -> lamdec_rec l n c | c -> error "decompose_lam_n_assum: not enough abstractions" in @@ -282,18 +287,18 @@ let decompose_lam_n_assum n = (* Iterate products, with or without lets *) (* Constructs either [(x:t)c] or [[x=b:t]c] *) -let mkProd_or_LetIn (na,body,t) c = - match body with - | None -> Prod (na, t, c) - | Some b -> LetIn (na, b, t, c) +let mkProd_or_LetIn decl c = + match decl with + | LocalAssum (na,t) -> Prod (na, t, c) + | LocalDef (na,b,t) -> LetIn (na, b, t, c) let it_mkProd_or_LetIn = List.fold_left (fun c d -> mkProd_or_LetIn d c) let decompose_prod_assum = let rec prodec_rec l c = match c with - | Prod (x,t,c) -> prodec_rec ((x,None,t) :: l) c - | LetIn (x,b,t,c) -> prodec_rec ((x,Some b,t) :: l) c + | Prod (x,t,c) -> prodec_rec (LocalAssum (x,t) :: l) c + | LetIn (x,b,t,c) -> prodec_rec (LocalDef (x,b,t) :: l) c | Cast (c,_,_) -> prodec_rec l c | _ -> l,c in @@ -305,8 +310,8 @@ let decompose_prod_n_assum n = let rec prodec_rec l n c = if Int.equal n 0 then l,c else match c with - | Prod (x,t,c) -> prodec_rec ((x,None,t) :: l) (n-1) c - | LetIn (x,b,t,c) -> prodec_rec ((x,Some b,t) :: l) (n-1) c + | Prod (x,t,c) -> prodec_rec (LocalAssum (x,t) :: l) (n-1) c + | LetIn (x,b,t,c) -> prodec_rec (LocalDef (x,b,t) :: l) (n-1) c | Cast (c,_,_) -> prodec_rec l n c | c -> error "decompose_prod_n_assum: not enough assumptions" in @@ -324,8 +329,8 @@ let mkArity (sign,s) = it_mkProd_or_LetIn (Sort s) sign let destArity = let rec prodec_rec l c = match c with - | Prod (x,t,c) -> prodec_rec ((x,None,t)::l) c - | LetIn (x,b,t,c) -> prodec_rec ((x,Some b,t)::l) c + | Prod (x,t,c) -> prodec_rec (LocalAssum (x,t)::l) c + | LetIn (x,b,t,c) -> prodec_rec (LocalDef (x,b,t)::l) c | Cast (c,_,_) -> prodec_rec l c | Sort s -> l,s | _ -> anomaly ~label:"destArity" (Pp.str "not an arity") diff --git a/checker/term.mli b/checker/term.mli index ab488b2b7..0af83e05d 100644 --- a/checker/term.mli +++ b/checker/term.mli @@ -35,12 +35,13 @@ val rel_context_length : rel_context -> int val rel_context_nhyps : rel_context -> int val fold_rel_context : (rel_declaration -> 'a -> 'a) -> rel_context -> init:'a -> 'a +val map_rel_decl : (constr -> constr) -> rel_declaration -> rel_declaration val map_rel_context : (constr -> constr) -> rel_context -> rel_context val extended_rel_list : int -> rel_context -> constr list val compose_lam : (name * constr) list -> constr -> constr val decompose_lam : constr -> (name * constr) list * constr val decompose_lam_n_assum : int -> constr -> rel_context * constr -val mkProd_or_LetIn : name * constr option * constr -> constr -> constr +val mkProd_or_LetIn : rel_declaration -> constr -> constr val it_mkProd_or_LetIn : constr -> rel_context -> constr val decompose_prod_assum : constr -> rel_context * constr val decompose_prod_n_assum : int -> constr -> rel_context * constr diff --git a/checker/type_errors.ml b/checker/type_errors.ml index c4c652865..b7718e02d 100644 --- a/checker/type_errors.ml +++ b/checker/type_errors.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/checker/type_errors.mli b/checker/type_errors.mli index 036ff4546..d9d147958 100644 --- a/checker/type_errors.mli +++ b/checker/type_errors.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/checker/typeops.ml b/checker/typeops.ml index 21819992a..64afd21b2 100644 --- a/checker/typeops.ml +++ b/checker/typeops.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -62,7 +62,7 @@ let judge_of_type u = Sort (Type (Univ.super u)) let judge_of_relative env n = try - let (_,_,typ) = lookup_rel n env in + let LocalAssum (_,typ) | LocalDef (_,_,typ) = lookup_rel n env in lift n typ with Not_found -> error_unbound_rel env n @@ -296,13 +296,13 @@ let rec execute env cstr = | Lambda (name,c1,c2) -> let _ = execute_type env c1 in - let env1 = push_rel (name,None,c1) env in + let env1 = push_rel (LocalAssum (name,c1)) env in let j' = execute env1 c2 in Prod(name,c1,j') | Prod (name,c1,c2) -> let varj = execute_type env c1 in - let env1 = push_rel (name,None,c1) env in + let env1 = push_rel (LocalAssum (name,c1)) env in let varj' = execute_type env1 c2 in Sort (sort_of_product env varj varj') @@ -314,7 +314,7 @@ let rec execute env cstr = let env',c2' = (* refresh_arity env *) env, c2 in let _ = execute_type env' c2' in judge_of_cast env' (c1,j1) DEFAULTcast c2' in - let env1 = push_rel (name,Some c1,c2) env in + let env1 = push_rel (LocalDef (name,c1,c2)) env in let j' = execute env1 c3 in subst1 c1 j' @@ -378,10 +378,10 @@ let infer_type env constr = execute_type env constr let check_ctxt env rels = fold_rel_context (fun d env -> match d with - (_,None,ty) -> + | LocalAssum (_,ty) -> let _ = infer_type env ty in push_rel d env - | (_,Some bd,ty) -> + | LocalDef (_,bd,ty) -> let j1 = infer env bd in let _ = infer env ty in conv_leq env j1 ty; @@ -399,9 +399,9 @@ let check_polymorphic_arity env params par = let pl = par.template_param_levels in let rec check_p env pl params = match pl, params with - Some u::pl, (na,None,ty)::params -> + Some u::pl, LocalAssum (na,ty)::params -> check_kind env ty u; - check_p (push_rel (na,None,ty) env) pl params + check_p (push_rel (LocalAssum (na,ty)) env) pl params | None::pl,d::params -> check_p (push_rel d env) pl params | [], _ -> () | _ -> failwith "check_poly: not the right number of params" in diff --git a/checker/typeops.mli b/checker/typeops.mli index 39d660418..db8e467a3 100644 --- a/checker/typeops.mli +++ b/checker/typeops.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/checker/univ.ml b/checker/univ.ml index 648e47817..96d827013 100644 --- a/checker/univ.ml +++ b/checker/univ.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -33,7 +33,7 @@ module type Hashconsed = sig type t val hash : t -> int - val equal : t -> t -> bool + val eq : t -> t -> bool val hcons : t -> t end @@ -51,7 +51,7 @@ struct type t = _t type u = (M.t -> M.t) let hash = function Nil -> 0 | Cons (_, h, _) -> h - let equal l1 l2 = match l1, l2 with + let eq l1 l2 = match l1, l2 with | Nil, Nil -> true | Cons (x1, _, l1), Cons (x2, _, l2) -> x1 == x2 && l1 == l2 | _ -> false @@ -131,7 +131,7 @@ module HList = struct let rec remove x = function | Nil -> nil | Cons (y, _, l) -> - if H.equal x y then l + if H.eq x y then l else cons y (remove x l) end @@ -229,7 +229,7 @@ module Level = struct type _t = t type t = _t type u = unit - let equal x y = x.hash == y.hash && RawLevel.hequal x.data y.data + let eq x y = x.hash == y.hash && RawLevel.hequal x.data y.data let hash x = x.hash let hashcons () x = let data' = RawLevel.hcons x.data in @@ -320,7 +320,7 @@ struct let hashcons hdir (b,n as x) = let b' = hdir b in if b' == b then x else (b',n) - let equal l1 l2 = + let eq l1 l2 = l1 == l2 || match l1,l2 with | (b,n), (b',n') -> b == b' && n == n' @@ -339,7 +339,7 @@ struct let hcons = Hashcons.simple_hcons H.generate H.hcons Level.hcons let hash = ExprHash.hash - let equal x y = x == y || + let eq x y = x == y || (let (u,n) = x and (v,n') = y in Int.equal n n' && Level.equal u v) @@ -1089,7 +1089,7 @@ struct a end - let equal t1 t2 = + let eq t1 t2 = t1 == t2 || (Int.equal (Array.length t1) (Array.length t2) && let rec aux i = diff --git a/checker/univ.mli b/checker/univ.mli index 02c1bbdb9..7d4c629ab 100644 --- a/checker/univ.mli +++ b/checker/univ.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -130,7 +130,7 @@ 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 LMap : CSig.MapS with type key = universe_level module LSet : CSig.SetS with type elt = universe_level type 'a universe_map = 'a LMap.t diff --git a/checker/validate.ml b/checker/validate.ml index 63180f055..c434ef09d 100644 --- a/checker/validate.ml +++ b/checker/validate.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/checker/values.ml b/checker/values.ml index 34de511c8..19cbb5060 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -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 76312d06933f47498a1981a6261c9f75 checker/cic.mli +MD5 9f7fd499f812b6548a55f7067e6a9d06 checker/cic.mli *) @@ -154,8 +154,8 @@ and v_prec = Tuple ("prec_declaration", and v_fix = Tuple ("pfixpoint", [|Tuple ("fix2",[|Array Int;Int|]);v_prec|]) and v_cofix = Tuple ("pcofixpoint",[|Int;v_prec|]) - -let v_rdecl = v_tuple "rel_declaration" [|v_name;Opt v_constr;v_constr|] +let v_rdecl = v_sum "rel_declaration" 0 [| [|v_name; v_constr|]; (* LocalAssum *) + [|v_name; v_constr; v_constr|] |] (* LocalDef *) let v_rctxt = List v_rdecl let v_section_ctxt = v_enum "emptylist" 1 diff --git a/checker/votour.ml b/checker/votour.ml index 4aecb28f2..79755da4a 100644 --- a/checker/votour.ml +++ b/checker/votour.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -22,6 +22,7 @@ sig val input : in_channel -> obj val repr : obj -> obj repr val size : obj -> int + val oid : obj -> int option end module ReprObj : S = @@ -45,6 +46,7 @@ struct else INT (Obj.magic obj) let size (_, p) = CObj.shared_size_of_pos p + let oid _ = None end module ReprMem : S = @@ -97,6 +99,9 @@ struct let _ = init_size seen obj in obj + let oid = function + | Int _ | Atm _ | Fun _ -> None + | Ptr p -> Some p end module Visit (Repr : S) : @@ -149,9 +154,13 @@ let rec get_details v o = match v, Repr.repr o with |Annot (s,v), _ -> get_details v o |_ -> "" +let get_oid obj = match Repr.oid obj with +| None -> "" +| Some id -> Printf.sprintf " [0x%08x]" id + let node_info (v,o,p) = get_name ~extra:true v ^ get_details v o ^ - " (size "^ string_of_int (Repr.size o)^"w)" + " (size "^ string_of_int (Repr.size o)^"w)" ^ get_oid o (** Children of a block : type, object, position. For lists, we collect all elements of the list at once *) diff --git a/config/coq_config.mli b/config/coq_config.mli index 26f4a148c..a0e1019fa 100644 --- a/config/coq_config.mli +++ b/config/coq_config.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/configure.ml b/configure.ml index 7e0d68eb8..b8bb650b1 100644 --- a/configure.ml +++ b/configure.ml @@ -332,11 +332,11 @@ let args_options = Arg.align [ "-makecmd", Arg.Set_string Prefs.makecmd, "<command> Name of GNU Make command"; "-native-compiler", arg_bool Prefs.nativecompiler, - " (yes|no) Compilation to native code for conversion and normalization"; + "(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 () = @@ -488,7 +488,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 @@ -665,10 +670,18 @@ let operating_system, osdeplibs = (** * lablgtk2 and CoqIDE *) +type source = Manual | OCamlFind | Stdlib + +let get_source = function +| Manual -> "manually provided" +| OCamlFind -> "via ocamlfind" +| Stdlib -> "in OCaml library" + (** Is some location a suitable LablGtk2 installation ? *) -let check_lablgtkdir ?(fatal=false) msg dir = +let check_lablgtkdir ?(fatal=false) src dir = let yell msg = if fatal then die msg else (printf "%s\n" msg; false) in + let msg = get_source src in if not (dir_exists dir) then yell (sprintf "No such directory '%s' (%s)." dir msg) else if not (Sys.file_exists (dir/"gSourceView2.cmi")) then @@ -682,11 +695,11 @@ let check_lablgtkdir ?(fatal=false) msg dir = let get_lablgtkdir () = match !Prefs.lablgtkdir with | Some dir -> - let msg = "manually provided" in + let msg = Manual in if check_lablgtkdir ~fatal:true msg dir then dir, msg - else "", "" + else "", msg | None -> - let msg = "via ocamlfind" in + let msg = OCamlFind in let d1,_ = tryrun "ocamlfind" ["query";"lablgtk2.sourceview2"] in if d1 <> "" && check_lablgtkdir msg d1 then d1, msg else @@ -694,10 +707,34 @@ let get_lablgtkdir () = let d2,_ = tryrun "ocamlfind" ["query";"lablgtk2"] in if d2 <> "" && d2 <> d1 && check_lablgtkdir msg d2 then d2, msg else - let msg = "in OCaml library" in + let msg = Stdlib in let d3 = camllib^"/lablgtk2" in if check_lablgtkdir msg d3 then d3, msg - else "", "" + else "", msg + +(** Detect and/or verify the Lablgtk2 version *) + +let check_lablgtk_version src dir = match src with +| Manual | Stdlib -> + let test accu f = + if accu then + let test = sprintf "grep -q -w %s %S/glib.mli" f dir in + Sys.command test = 0 + else false + in + let heuristics = [ + "convert_with_fallback"; + "wrap_poll_func"; (** Introduced in lablgtk 2.16 *) + ] in + let ans = List.fold_left test true heuristics in + if ans then printf "Warning: could not check the version of lablgtk2.\n"; + (ans, "an unknown version") +| OCamlFind -> + let v, _ = tryrun "ocamlfind" ["query"; "-format"; "%v"; "lablgtk2"] in + try + let vi = List.map s2i (numeric_prefix_list v) in + ([2; 16] <= vi, v) + with _ -> (false, v) let pr_ide = function No -> "no" | Byte -> "only bytecode" | Opt -> "native" @@ -721,9 +758,9 @@ let check_coqide () = if !Prefs.coqide = Some No then set_ide No "CoqIde manually disabled"; let dir, via = get_lablgtkdir () in if dir = "" then set_ide No "LablGtk2 not found"; - let found = sprintf "LablGtk2 found (%s)" via in - let test = sprintf "grep -q -w convert_with_fallback %S/glib.mli" dir in - if Sys.command test <> 0 then set_ide No (found^" but too old"); + let (ok, version) = check_lablgtk_version via dir in + let found = sprintf "LablGtk2 found (%s, %s)" (get_source via) version in + if not ok then set_ide No (found^", but too old (required >= 2.16, found " ^ version ^ ")"); (* We're now sure to produce at least one kind of coqide *) lablgtkdir := shorten_camllib dir; if !Prefs.coqide = Some Byte then set_ide Byte (found^", bytecode requested"); diff --git a/dev/base_include b/dev/base_include index 197528acd..86f34b2ac 100644 --- a/dev/base_include +++ b/dev/base_include @@ -17,6 +17,7 @@ #directory "grammar";; #directory "intf";; #directory "stm";; +#directory "ltac";; #directory "+camlp4";; (* lazy solution: add both of camlp4/5 so that *) #directory "+camlp5";; (* Gramext is found in top_printers.ml *) @@ -149,6 +150,7 @@ open Tactic_debug open Decl_proof_instr open Decl_mode +open Hints open Auto open Autorewrite open Contradiction @@ -1,5 +1,3 @@ -load_printer "gramlib.cma" -load_printer "str.cma" load_printer "printers.cma" install_printer Top_printers.ppfuture diff --git a/dev/db_printers.ml b/dev/db_printers.ml index e843bbc51..500595085 100644 --- a/dev/db_printers.ml +++ b/dev/db_printers.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/dev/doc/README-V1-V5 b/dev/doc/README-V1-V5 deleted file mode 100644 index 2ca62e3d7..000000000 --- a/dev/doc/README-V1-V5 +++ /dev/null @@ -1,293 +0,0 @@ - - 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/README-V1-V5.asciidoc b/dev/doc/README-V1-V5.asciidoc new file mode 100644 index 000000000..631fb92c9 --- /dev/null +++ b/dev/doc/README-V1-V5.asciidoc @@ -0,0 +1,378 @@ +Notes on the prehistory of Coq +============================== +:author: Thierry Coquand, Gérard Huet & Christine Paulin-Mohring +:revdate: September 2015 +:toc: +:toc-placement: preamble +:toclevels: 1 +:showtitle: + + +This document is a copy within the Coq archive of a document written +in September 2015 by Gérard Huet, Thierry Coquand and Christine Paulin +to accompany their public release of the archive of versions 1.10 to 6.2 +of Coq and of its CONSTR ancestor. 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) was a version of ML adapted from the Edinburgh LCF system +and running on a LISP backend. The main improvements from the original +LCF ML were that ML was compiled rather than interpreted (Gérard Huet +building on the original translator by Lockwood Morris), and that it +was 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 (λ) at the level of terms/proofs, in the manner +of Automath. Substitution (λ-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__ <<CH85>>. + +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 – _lambo(f)(n)_ computes 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__ <<CH88>>. + +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__<<CH87>>. + +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__ <<P86>>. 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__ <<H88>>. + +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: + +[source, coq] +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 +Réalisations et Synthèse_. 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 the summer of 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érard 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 in early +users who saw, after a successful proof search, their `QED` followed +by silence, followed by a failure message due to a universe +inconsistency… + +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 first-order predicate calculus matching, with important performance +gain. + +A new representation of the universe hierarchy is then defined by +Gérard 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 of 1989 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 <<C90>>, +- _Inductive definitions in the Calculus of Constructions_, by + Christine Paulin-Mohrin, +- _Extracting Fω's programs from proofs in the Calculus of + Constructions_, by Christine Paulin-Mohring <<P89>>, +- _The Constructive Engine_, by Gérard Huet <<H89>>, + +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__ <<PP90>>. An extension of the calculus +with primitive inductive types appeared in: Th. Coquand and +C. Paulin-Mohring. __Inductively defined types__ <<CP90>>. + +This led 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__ <<P93>>. + +The last version of CONSTR is Version 4.11, which was last distributed +in the spring of 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 École 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. +==== + +[bibliography] +.Bibliographic references + +- [[[CH85]]] 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. + +- [[[CH88]]] 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. + +- [[[CH87]]] 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. + +- [[[P86]]] C. Paulin. _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). + +- [[[H88]]] G. Huet. _Induction Principles Formalized in the Calculus + of Constructions_ in Programming of Future Generation Computers, + Ed. K. Fuchi and M. Nivat, North-Holland, 1988. + +- [[[C90]]] Th. Coquand. _Metamathematical Investigations of a + Calculus of Constructions_, by INRIA Research Report N°1088, + Sept. 1989, published in Logic and Computer Science, + ed. P.G. Odifreddi, Academic Press, 1990. + +- [[[P89]]] C. Paulin. _Extracting F ω's programs from proofs in the + calculus of constructions_. 16th Annual ACM Symposium on Principles + of Programming Languages, Austin. 1989. + +- [[[H89]]] G. Huet. _The constructive engine_. A perspective in + Theoretical Computer Science. Commemorative Volume for Gift + Siromoney. World Scientific Publishing (1989). + +- [[[PP90]]] 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 + +- [[[CP90]]] 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. + +- [[[P93]]] 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. diff --git a/dev/doc/changes.txt b/dev/doc/changes.txt index 2f62be9af..2f631c633 100644 --- a/dev/doc/changes.txt +++ b/dev/doc/changes.txt @@ -1,5 +1,88 @@ ========================================= -= CHANGES BETWEEN COQ V8.4 AND CQQ V8.5 = += CHANGES BETWEEN COQ V8.5 AND COQ V8.6 = +========================================= + +- The interface of the Context module was changed. + Related types and functions were put in separate submodules. + The mapping from old identifiers to new identifiers is the following: + + Context.named_declaration ---> Context.Named.Declaration.t + Context.named_list_declaration ---> Context.NamedList.Declaration.t + Context.rel_declaration ---> Context.Rel.Declaration.t + Context.map_named_declaration ---> Context.Named.Declaration.map_constr + Context.map_named_list_declaration ---> Context.NamedList.Declaration.map + Context.map_rel_declaration ---> Context.Rel.Declaration.map_constr + Context.fold_named_declaration ---> Context.Named.Declaration.fold + Context.fold_rel_declaration ---> Context.Rel.Declaration.fold + Context.exists_named_declaration ---> Context.Named.Declaration.exists + Context.exists_rel_declaration ---> Context.Rel.Declaration.exists + Context.for_all_named_declaration ---> Context.Named.Declaration.for_all + Context.for_all_rel_declaration ---> Context.Rel.Declaration.for_all + Context.eq_named_declaration ---> Context.Named.Declaration.equal + Context.eq_rel_declaration ---> Context.Rel.Declaration.equal + Context.named_context ---> Context.Named.t + Context.named_list_context ---> Context.NamedList.t + Context.rel_context ---> Context.Rel.t + Context.empty_named_context ---> Context.Named.empty + Context.add_named_decl ---> Context.Named.add + Context.vars_of_named_context ---> Context.Named.to_vars + Context.lookup_named ---> Context.Named.lookup + Context.named_context_length ---> Context.Named.length + Context.named_context_equal ---> Context.Named.equal + Context.fold_named_context ---> Context.Named.fold_outside + Context.fold_named_list_context ---> Context.NamedList.fold + Context.fold_named_context_reverse ---> Context.Named.fold_inside + Context.instance_from_named_context ---> Context.Named.to_instance + Context.extended_rel_list ---> Context.Rel.to_extended_list + Context.extended_rel_vect ---> Context.Rel.to_extended_vect + Context.fold_rel_context ---> Context.Rel.fold_outside + Context.fold_rel_context_reverse ---> Context.Rel.fold_inside + Context.map_rel_context ---> Context.Rel.map_constr + Context.map_named_context ---> Context.Named.map_constr + Context.iter_rel_context ---> Context.Rel.iter + Context.iter_named_context ---> Context.Named.iter + Context.empty_rel_context ---> Context.Rel.empty + Context.add_rel_decl ---> Context.Rel.add + Context.lookup_rel ---> Context.Rel.lookup + Context.rel_context_length ---> Context.Rel.length + Context.rel_context_nhyps ---> Context.Rel.nhyps + Context.rel_context_tags ---> Context.Rel.to_tags + +- Originally, rel-context was represented as: + + Context.rel_context = Names.Name.t * Constr.t option * Constr.t + + Now it is represented as: + + Context.Rel.t = LocalAssum of Names.Name.t * Constr.t + | LocalDef of Names.Name.t * Constr.t * Constr.t + +- Originally, named-context was represented as: + + Context.named_context = Names.Id.t * Constr.t option * Constr.t + + Now it is represented as: + + Context.Named.t = LocalAssum of Names.Id.t * Constr.t + | LocalDef of Names.Id.t * Constr.t * Constr.t + +- The various EXTEND macros do not handle specially the Coq-defined entries + anymore. Instead, they just output a name that have to exist in the scope + of the ML code. The parsing rules (VERNAC) ARGUMENT EXTEND will look for + variables "$name" of type Gram.entry, while the parsing rules of + (VERNAC COMMAND | TACTIC) EXTEND, as well as the various TYPED AS clauses will + look for variables "wit_$name" of type Genarg.genarg_type. The small DSL + for constructing compound entries still works over this scheme. Note that in + the case of (VERNAC) ARGUMENT EXTEND, the name of the argument entry is bound + in the parsing rules, so beware of recursive calls. + +- Evarutil was split in two parts. The new Evardefine file exposes functions +define_evar_* mostly used internally in the unification engine. + +- The Refine module was move out of Proofview. + +========================================= += CHANGES BETWEEN COQ V8.4 AND COQ V8.5 = ========================================= ** Refactoring : more mli interfaces and simpler grammar.cma ** diff --git a/dev/doc/coq-src-description.txt b/dev/doc/coq-src-description.txt index fe896d316..00e7f5c53 100644 --- a/dev/doc/coq-src-description.txt +++ b/dev/doc/coq-src-description.txt @@ -19,13 +19,6 @@ highparsing : Files in parsing/ that cannot be linked too early. Contains the grammar rules g_*.ml4 -hightactics : - - Files in tactics/ that cannot be linked too early. - These are the .ml4 files that uses the EXTEND possibilities - provided by grammar.cma, for instance eauto.ml4. - - Special components ------------------ diff --git a/dev/doc/versions-history.tex b/dev/doc/versions-history.tex index 1b1d3500a..492e75a7b 100644 --- a/dev/doc/versions-history.tex +++ b/dev/doc/versions-history.tex @@ -223,6 +223,7 @@ version & date & comments \\ Coq ``V6'' archive & 20 March 1996 & new cvs repository on pauillac.inria.fr with code ported \\ & & to Caml Special Light (to later become Objective Caml)\\ & & has implicit arguments and coercions\\ + & & has coinductive types\\ Coq V6.1beta& released 18 November 1996 & \feature{coercions} [23-5-1996], \feature{user-level implicit arguments} [23-5-1996]\\ & & \feature{omega} [10-9-1996] \\ diff --git a/dev/header b/dev/header index e5184df31..413205179 100644 --- a/dev/header +++ b/dev/header @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/dev/make-macos-dmg.sh b/dev/make-macos-dmg.sh new file mode 100755 index 000000000..b43ada907 --- /dev/null +++ b/dev/make-macos-dmg.sh @@ -0,0 +1,35 @@ +#!/bin/bash + +# Fail on first error +set -e + +# Configuration setup +eval `opam config env` +make distclean +OUTDIR=$PWD/_install +DMGDIR=$PWD/_dmg +./configure -debug -prefix $OUTDIR -native-compiler no +VERSION=$(sed -n -e '/^let coq_version/ s/^[^"]*"\([^"]*\)"$/\1/p' configure.ml) +APP=bin/CoqIDE_${VERSION}.app + +# Create a .app file with CoqIDE +~/.local/bin/jhbuild run make -j -l2 $APP + +# Build Coq and run test-suite +make && make check + +# Add Coq to the .app file +make OLDROOT=$OUTDIR COQINSTALLPREFIX=$APP/Contents/Resources/ install-coq install-ide-toploop + +# Sign the .app file +codesign -f -s - $APP + +# Create the dmg bundle +mkdir -p $DMGDIR +ln -sf /Applications $DMGDIR/Applications +cp -r $APP $DMGDIR + +# Temporary countermeasure to hdiutil error 5341 +head -c9703424 /dev/urandom > $DMGDIR/.padding + +hdiutil create -imagekey zlib-level=9 -volname CoqIDE_$VERSION -srcfolder $DMGDIR -ov -format UDZO CoqIDE_$VERSION.dmg diff --git a/dev/ocamldebug-coq.run b/dev/ocamldebug-coq.run index b00d084ed..f9310e076 100644 --- a/dev/ocamldebug-coq.run +++ b/dev/ocamldebug-coq.run @@ -20,7 +20,7 @@ exec $OCAMLDEBUG \ -I $COQTOP/library -I $COQTOP/engine \ -I $COQTOP/pretyping -I $COQTOP/parsing \ -I $COQTOP/interp -I $COQTOP/proofs -I $COQTOP/tactics -I $COQTOP/stm \ - -I $COQTOP/toplevel -I $COQTOP/dev -I $COQTOP/config \ + -I $COQTOP/toplevel -I $COQTOP/dev -I $COQTOP/config -I $COQTOP/ltac \ -I $COQTOP/plugins/cc -I $COQTOP/plugins/dp \ -I $COQTOP/plugins/extraction -I $COQTOP/plugins/field \ -I $COQTOP/plugins/firstorder -I $COQTOP/plugins/fourier \ diff --git a/dev/ocamldoc/fix-ocamldoc-utf8 b/dev/ocamldoc/fix-ocamldoc-utf8 new file mode 100755 index 000000000..fe2e0c115 --- /dev/null +++ b/dev/ocamldoc/fix-ocamldoc-utf8 @@ -0,0 +1,6 @@ +#!/bin/sh + +# This reverts automatic translation of latin1 accentuated letters by ocamldoc +# Usage: fix-ocamldoc-utf8 file + +sed -i -e 's/\\`a/\d224/g' -e "s/\\\^a/\d226/g" -e "s/\\\'e/\d233/g" -e 's/\\`e/\d232/g' -e "s/\\\^e/\d234/g" -e 's/\\\"e/\d235/g' -e "s/\\\^o/\d244/g" -e 's/\\\"o/\d246/g' -e "s/\\\^i/\d238/g" -e 's/\\\"i/\d239/g' -e 's/\\`u/\d249/g' -e "s/\\\^u/\d251/g" -e "s/\\\c{c}/\d231/g" $1 diff --git a/dev/ocamldoc/header.tex b/dev/ocamldoc/header.tex new file mode 100644 index 000000000..4091f8144 --- /dev/null +++ b/dev/ocamldoc/header.tex @@ -0,0 +1,14 @@ +\documentclass[11pt]{article} +\usepackage[utf8x]{inputenc} +\usepackage[T1]{fontenc} +\usepackage{textcomp} +\usepackage{tipa} +\usepackage{textgreek} +\usepackage{fullpage} +\usepackage{url} +\usepackage{ocamldoc} +\title{Coq mlis documentation} +\begin{document} +\maketitle +\tableofcontents +\vspace{0.2cm} diff --git a/dev/printers.mllib b/dev/printers.mllib index 1a2819feb..9f25ba55e 100644 --- a/dev/printers.mllib +++ b/dev/printers.mllib @@ -8,6 +8,7 @@ Hashcons CSet CMap Int +Dyn HMap Option Store @@ -16,6 +17,9 @@ Backtrace IStream Pp_control Loc +CList +CString +Tok Compat Flags Control @@ -28,15 +32,12 @@ Segmenttree Unicodetable Unicode CObj -CList -CString CArray CStack Util Ppstyle Errors Bigint -Dyn CUnix System Envars @@ -48,7 +49,7 @@ Rtree Heap Genarg Stateid -Ephemeron +CEphemeron Future RemoteCounter Monad @@ -122,14 +123,16 @@ Evd Sigma Glob_ops Redops +Pretype_errors +Evarutil Reductionops Inductiveops Arguments_renaming Nativenorm Retyping Cbv -Pretype_errors -Evarutil + +Evardefine Evarsolve Recordops Evarconv @@ -140,6 +143,9 @@ Find_subterm Tacred Classops Typeclasses_errors +Logic_monad +Proofview_monad +Proofview Typeclasses Detyping Indrec @@ -153,7 +159,6 @@ Library States Genprint -Tok Lexer Ppextend Pputils @@ -163,18 +168,17 @@ Constrarg Constrexpr_ops Genintern Notation_ops -Topconstr Notation Dumpglob +Syntax_def +Smartlocate +Topconstr Reserve Impargs -Syntax_def Implicit_quantifiers -Smartlocate Constrintern Modintern Constrextern -Proof_type Goal Miscprint Logic @@ -182,13 +186,10 @@ Refiner Clenv Evar_refiner Proof_errors -Logic_monad -Proofview_monad -Proofview +Refine Proof Proof_global Pfedit -Tactic_debug Decl_mode Ppconstr Entry @@ -199,7 +200,6 @@ Ppdecl_proof Egramml Egramcoq Tacsubst -Tacenv Trie Dn Btermdn diff --git a/dev/top_printers.ml b/dev/top_printers.ml index b3b1ae0e9..141eab3f3 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -467,12 +467,13 @@ let pp_generic_argument arg = pp(str"<genarg:"++pr_argument_type(genarg_tag arg)++str">") let prgenarginfo arg = - let tpe = pr_argument_type (genarg_tag arg) in - let pr_gtac _ x = Pptactic.pr_glob_tactic (Global.env()) x in - try - let data = Pptactic.pr_top_generic pr_constr pr_lconstr pr_gtac pr_constr_pattern arg in - str "<genarg:" ++ tpe ++ str " := [ " ++ data ++ str " ] >" - with _any -> + let Val.Dyn (tag, _) = arg in + let tpe = Val.repr tag in + (** FIXME *) +(* try *) +(* let data = Pptactic.pr_top_generic (Global.env ()) arg in *) +(* str "<genarg:" ++ tpe ++ str " := [ " ++ data ++ str " ] >" *) +(* with _any -> *) str "<genarg:" ++ tpe ++ str ">" let ppgenarginfo arg = pp (prgenarginfo arg) @@ -509,7 +510,7 @@ let _ = try Vernacinterp.vinterp_add false ("PrintConstr", 0) (function - [c] when genarg_tag c = ConstrArgType && true -> + [c] when genarg_tag c = unquote (topwit wit_constr) && true -> let c = out_gen (rawwit wit_constr) c in (fun () -> in_current_context constr_display c) | _ -> failwith "Vernac extension: cannot occur") @@ -519,14 +520,13 @@ let _ = extend_vernac_command_grammar ("PrintConstr", 0) None [GramTerminal "PrintConstr"; GramNonTerminal - (Loc.ghost,rawwit wit_constr,Aentry (Entry.unsafe_of_name ("constr","constr")), - Some (Names.Id.of_string "c"))] + (Loc.ghost,rawwit wit_constr,Extend.Aentry (Pcoq.name_of_entry Pcoq.Constr.constr))] let _ = try Vernacinterp.vinterp_add false ("PrintPureConstr", 0) (function - [c] when genarg_tag c = ConstrArgType && true -> + [c] when genarg_tag c = unquote (topwit wit_constr) && true -> let c = out_gen (rawwit wit_constr) c in (fun () -> in_current_context print_pure_constr c) | _ -> failwith "Vernac extension: cannot occur") @@ -536,8 +536,7 @@ let _ = extend_vernac_command_grammar ("PrintPureConstr", 0) None [GramTerminal "PrintPureConstr"; GramNonTerminal - (Loc.ghost,rawwit wit_constr,Aentry (Entry.unsafe_of_name ("constr","constr")), - Some (Names.Id.of_string "c"))] + (Loc.ghost,rawwit wit_constr,Extend.Aentry (Pcoq.name_of_entry Pcoq.Constr.constr))] (* Setting printer of unbound global reference *) open Names diff --git a/dev/v8-syntax/syntax-v8.tex b/dev/v8-syntax/syntax-v8.tex index 6630be06a..64431ea16 100644 --- a/dev/v8-syntax/syntax-v8.tex +++ b/dev/v8-syntax/syntax-v8.tex @@ -81,7 +81,7 @@ Parenthesis are used to group regexps. Beware to distinguish this operator $\GR{~}$ from the terminals $\ETERM{( )}$, and $\mid$ from terminal \TERMbar. -Rules are optionaly annotated in the right margin with: +Rules are optionally annotated in the right margin with: \begin{itemize} \item a precedence and associativity (L for left, R for right and N for no associativity), indicating how to solve conflicts; lower levels are tighter; diff --git a/dev/vm_printers.ml b/dev/vm_printers.ml index 802b0f9d8..1c501df80 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 ")" @@ -61,7 +61,8 @@ and ppstack s = and ppatom a = match a with | Aid idk -> 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/common/macros.tex b/doc/common/macros.tex index 0e820008e..077e2f0df 100644 --- a/doc/common/macros.tex +++ b/doc/common/macros.tex @@ -97,8 +97,7 @@ \newcommand{\camlpppp}{\textsc{Camlp4}} \newcommand{\emacs}{\textsc{GNU Emacs}} \newcommand{\ProofGeneral}{\textsc{Proof General}} -\newcommand{\CIC}{\pCIC} -\newcommand{\pCIC}{p\textsc{Cic}} +\newcommand{\CIC}{\textsc{Cic}} \newcommand{\iCIC}{\textsc{Cic}} \newcommand{\FW}{\ensuremath{F_{\omega}}} \newcommand{\Program}{\textsc{Program}} @@ -199,6 +198,7 @@ \newcommand{\pattern}{\nterm{pattern}} % pattern for pattern-matching \newcommand{\orpattern}{\nterm{or\_pattern}} \newcommand{\intropattern}{\nterm{intro\_pattern}} +\newcommand{\intropatternlist}{\nterm{intro\_pattern\_list}} \newcommand{\disjconjintropattern}{\nterm{disj\_conj\_intro\_pattern}} \newcommand{\namingintropattern}{\nterm{naming\_intro\_pattern}} \newcommand{\termpattern}{\nterm{term\_pattern}} % term with holes @@ -258,13 +258,13 @@ \newcommand{\forest}{\mbox{\textsf{forest}}} \newcommand{\from}{\mbox{\textsf{from}}} \newcommand{\hd}{\mbox{\textsf{hd}}} -\newcommand{\Length}{\mbox{\textsf{Length}}} +\newcommand{\haslength}{\mbox{\textsf{has\_length}}} \newcommand{\length}{\mbox{\textsf{length}}} -\newcommand{\LengthA}{\mbox {\textsf{Length\_A}}} -\newcommand{\List}{\mbox{\textsf{List}}} -\newcommand{\ListA}{\mbox{\textsf{List\_A}}} -\newcommand{\LNil}{\mbox{\textsf{Lnil}}} -\newcommand{\LCons}{\mbox{\textsf{Lcons}}} +\newcommand{\haslengthA}{\mbox {\textsf{has\_length~A}}} +\newcommand{\List}{\mbox{\textsf{list}}} +\newcommand{\ListA}{\mbox{\textsf{list}}~\ensuremath{A}} +\newcommand{\nilhl}{\mbox{\textsf{nil\_hl}}} +\newcommand{\conshl}{\mbox{\textsf{cons\_hl}}} \newcommand{\nat}{\mbox{\textsf{nat}}} \newcommand{\nO}{\mbox{\textsf{O}}} \newcommand{\nS}{\mbox{\textsf{S}}} @@ -281,6 +281,13 @@ \newcommand{\Type}{\mbox{\textsf{Type}}} \newcommand{\unfold}{\mbox{\textsf{unfold}}} \newcommand{\zeros}{\mbox{\textsf{zeros}}} +\newcommand{\even}{\mbox{\textsf{even}}} +\newcommand{\odd}{\mbox{\textsf{odd}}} +\newcommand{\evenO}{\mbox{\textsf{even\_O}}} +\newcommand{\evenS}{\mbox{\textsf{even\_S}}} +\newcommand{\oddS}{\mbox{\textsf{odd\_S}}} +\newcommand{\Prod}{\mbox{\textsf{prod}}} +\newcommand{\Pair}{\mbox{\textsf{pair}}} %%%%%%%%% % Misc. % @@ -364,6 +371,7 @@ \newcommand{\myifthenelse}[3]{\kw{if} ~ #1 ~\kw{then} ~ #2 ~ \kw{else} ~ #3} \newcommand{\fun}[2]{\item[]{\tt {#1}}. \quad\\ #2} \newcommand{\WF}[2]{\ensuremath{{\cal W\!F}(#1)[#2]}} +\newcommand{\WFTWOLINES}[2]{\ensuremath{{\cal W\!F}\begin{array}{l}(#1)\\\mbox{}[{#2}]\end{array}}} \newcommand{\WFE}[1]{\WF{E}{#1}} \newcommand{\WT}[4]{\ensuremath{#1[#2] \vdash #3 : #4}} \newcommand{\WTE}[3]{\WT{E}{#1}{#2}{#3}} @@ -393,9 +401,9 @@ \newcommand{\CIPI}[1]{\CIP{#1}{I}{P}} \newcommand{\CIF}[1]{\mbox{$\{#1\}_{f_1.. f_n}$}} %BEGIN LATEX -\newcommand{\NInd}[3]{\mbox{{\sf Ind}$(#1)(\begin{array}[t]{@{}l}#2:=#3 +\newcommand{\NInd}[3]{\mbox{{\sf Ind}$(\begin{array}[t]{@{}l}#2:=#3 \,)\end{array}$}} -\newcommand{\Ind}[4]{\mbox{{\sf Ind}$(#1)[#2](\begin{array}[t]{@{}l@{}}#3:=#4 +\newcommand{\Ind}[4]{\mbox{{\sf Ind}$[#2](\begin{array}[t]{@{}l@{}}#3:=#4 \,)\end{array}$}} %END LATEX %HEVEA \newcommand{\NInd}[3]{\mbox{{\sf Ind}$(#1)(#2:=#3\,)$}} @@ -413,6 +421,7 @@ \newcommand{\Fix}[2]{\mbox{\tt Fix}~#1\{#2\}} \newcommand{\CoFix}[2]{\mbox{\tt CoFix}~#1\{#2\}} \newcommand{\With}[2]{\mbox{\tt ~with~}} +\newcommand{\letin}[3]{\kw{let}~#1:=#2~\kw{in}~#3} \newcommand{\subst}[3]{#1\{#2/#3\}} \newcommand{\substs}[4]{#1\{(#2/#3)_{#4}\}} \newcommand{\Sort}{\mbox{$\cal S$}} diff --git a/doc/common/styles/html/coqremote/cover.html b/doc/common/styles/html/coqremote/cover.html index db8271709..6ec4dc1af 100644 --- a/doc/common/styles/html/coqremote/cover.html +++ b/doc/common/styles/html/coqremote/cover.html @@ -60,7 +60,7 @@ <li>V8.2 © INRIA 2008-2011</li> <li>V8.3 © INRIA 2010-2011</li> <li>V8.4 © INRIA 2012-2014</li> - <li>V8.5 © INRIA 2015</li> + <li>V8.5 © INRIA 2015-2016</li> </ul> <p style="text-indent:0pt">This research was partly supported by IST diff --git a/doc/common/styles/html/simple/cover.html b/doc/common/styles/html/simple/cover.html index 1641a1ed3..328bd68da 100644 --- a/doc/common/styles/html/simple/cover.html +++ b/doc/common/styles/html/simple/cover.html @@ -38,7 +38,7 @@ <li>V8.2 © INRIA 2008-2011</li> <li>V8.3 © INRIA 2010-2011</li> <li>V8.4 © INRIA 2012-2014</li> - <li>V8.5 © INRIA 2015</li> + <li>V8.5 © INRIA 2015-2016</li> </ul> <p style="text-indent:0pt">This research was partly supported by IST diff --git a/doc/common/title.tex b/doc/common/title.tex index 4716c3156..0e072b6b6 100644 --- a/doc/common/title.tex +++ b/doc/common/title.tex @@ -45,7 +45,7 @@ V\coqversion, \today %END LATEX \copyright INRIA 1999-2004 ({\Coq} versions 7.x) -\copyright INRIA 2004-2015 ({\Coq} versions 8.x) +\copyright INRIA 2004-2016 ({\Coq} versions 8.x) #3 \end{flushleft} diff --git a/doc/refman/Cases.tex b/doc/refman/Cases.tex index 4238bf6a5..a95d8114f 100644 --- a/doc/refman/Cases.tex +++ b/doc/refman/Cases.tex @@ -521,6 +521,8 @@ I have a copy of {\tt b} in type {\tt listn 0} resp {\tt listn (S n')}. % \end{coq_example} \paragraph{Patterns in {\tt in}} +\label{match-in-patterns} + If the type of the matched term is more precise than an inductive applied to variables, arguments of the inductive in the {\tt in} branch can be more complicated patterns than a variable. @@ -530,7 +532,7 @@ become impossible branches. In an impossible branch, you can answer anything but {\tt False\_rect unit} has the advantage to be subterm of anything. % ??? -To be concrete: the tail function can be written: +To be concrete: the {\tt tail} function can be written: \begin{coq_example} Definition tail n (v: listn (S n)) := match v in listn (S m) return listn m with diff --git a/doc/refman/Coercion.tex b/doc/refman/Coercion.tex index e4aa69353..16006a6ad 100644 --- a/doc/refman/Coercion.tex +++ b/doc/refman/Coercion.tex @@ -312,12 +312,13 @@ Conversely, to skip the printing of coercions, use {\tt Unset Printing Coercions}. By default, coercions are not printed. -\asubsection{\tt Set Printing Coercion {\qualid}.} -\optindex{Printing Coercion} +\asubsection{\tt Add Printing Coercion {\qualid}.} +\comindex{Add Printing Coercion} +\comindex{Remove Printing Coercion} This command forces coercion denoted by {\qualid} to be printed. To skip the printing of coercion {\qualid}, use - {\tt Unset Printing Coercion {\qualid}}. + {\tt Remove Printing Coercion {\qualid}}. By default, a coercion is never printed. \asection{Classes as Records} diff --git a/doc/refman/Extraction.tex b/doc/refman/Extraction.tex index 74c8374de..a963662f6 100644 --- a/doc/refman/Extraction.tex +++ b/doc/refman/Extraction.tex @@ -198,6 +198,11 @@ this constant is not declared in the generated file. \asubsection{Extra elimination of useless arguments} +The following command provides some extra manual control on the +code elimination performed during extraction, in a way which +is independent but complementary to the main elimination +principles of extraction (logical parts and types). + \begin{description} \item \comindex{Extraction Implicit} {\tt Extraction Implicit} \qualid\ [ \ident$_1$ \dots\ \ident$_n$ ]. @@ -207,12 +212,27 @@ This experimental command allows declaring some arguments of be removed by extraction. Here \qualid\ can be any function or inductive constructor, and \ident$_i$ are the names of the concerned arguments. In fact, an argument can also be referred by a number -indicating its position, starting from 1. When an actual extraction -takes place, an error is raised if the {\tt Extraction Implicit} +indicating its position, starting from 1. +\end{description} + +When an actual extraction takes place, an error is normally raised if the +{\tt Extraction Implicit} declarations cannot be honored, that is if any of the implicited -variables still occurs in the final code. This declaration of useless -arguments is independent but complementary to the main elimination -principles of extraction (logical parts and types). +variables still occurs in the final code. This behavior can be relaxed +via the following option: + +\begin{description} +\item \optindex{Extraction SafeImplicits} {\tt Unset Extraction SafeImplicits.} + +Default is Set. When this option is Unset, a warning is emitted +instead of an error if some implicited variables still occur in the +final code of an extraction. This way, the extracted code may be +obtained nonetheless and reviewed manually to locate the source of the issue +(in the code, some comments mark the location of these remaining +implicited variables). +Note that this extracted code might not compile or run properly, +depending of the use of these remaining implicited variables. + \end{description} \asubsection{Realizing axioms}\label{extraction:axioms} diff --git a/doc/refman/Program.tex b/doc/refman/Program.tex index efcc84ee9..11dd3a051 100644 --- a/doc/refman/Program.tex +++ b/doc/refman/Program.tex @@ -201,7 +201,7 @@ in their context. In this case, the obligations should be transparent recursive calls can be checked by the kernel's type-checker. There is an optimization in the generation of obligations which gets rid of the hypothesis corresponding to the -functionnal when it is not necessary, so that the obligation can be +functional when it is not necessary, so that the obligation can be declared opaque (e.g. using {\tt Qed}). However, as soon as it appears in the context, the proof of the obligation is \emph{required} to be declared transparent. @@ -216,7 +216,7 @@ properties. It will generate obligations, try to solve them automatically and fail if some unsolved obligations remain. In this case, one can first define the lemma's statement using {\tt Program Definition} and use it as the goal afterwards. -Otherwise the proof will be started with the elobarted version as a goal. +Otherwise the proof will be started with the elaborated version as a goal. The {\tt Program} prefix can similarly be used as a prefix for {\tt Variable}, {\tt Hypothesis}, {\tt Axiom} etc... diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index 3fd5ae0b2..1554ee04d 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -1,89 +1,35 @@ \chapter[Calculus of Inductive Constructions]{Calculus of Inductive Constructions \label{Cic} \index{Cic@\textsc{CIC}} -\index{pCic@p\textsc{CIC}} -\index{Calculus of (Co)Inductive Constructions}} +\index{Calculus of Inductive Constructions}} The underlying formal language of {\Coq} is a {\em Calculus of - Constructions} with {\em Inductive Definitions}. It is presented in -this chapter. -For {\Coq} version V7, this Calculus was known as the -{\em Calculus of (Co)Inductive Constructions}\index{Calculus of - (Co)Inductive Constructions} (\iCIC\ in short). -The underlying calculus of {\Coq} version V8.0 and up is a weaker - calculus where the sort \Set{} satisfies predicative rules. -We call this calculus the -{\em Predicative Calculus of (Co)Inductive - Constructions}\index{Predicative Calculus of - (Co)Inductive Constructions} (\pCIC\ in short). -In Section~\ref{impredicativity} we give the extra-rules for \iCIC. A - compiling option of \Coq{} allows type-checking theories in this - extended system. - -In \CIC\, all objects have a {\em type}. There are types for functions (or +Inductive Constructions} (\CIC) whose inference rules are presented in +this chapter. The history of this formalism as well as pointers to related work +are provided in a separate chapter; see {\em Credits}. + +\section[The terms]{The terms\label{Terms}} + +The expressions of the {\CIC} are {\em terms} and all terms have a {\em type}. +There are types for functions (or programs), there are atomic types (especially datatypes)... but also types for proofs and types for the types themselves. Especially, any object handled in the formalism must belong to a -type. For instance, the statement {\it ``for all x, P''} is not -allowed in type theory; you must say instead: {\it ``for all x -belonging to T, P''}. The expression {\it ``x belonging to T''} is -written {\it ``x:T''}. One also says: {\it ``x has type T''}. -The terms of {\CIC} are detailed in Section~\ref{Terms}. - -In \CIC\, there is an internal reduction mechanism. In particular, it -can decide if two programs are {\em intentionally} equal (one -says {\em convertible}). Convertibility is presented in section -\ref{convertibility}. - -The remaining sections are concerned with the type-checking of terms. -The beginner can skip them. - -The reader seeking a background on the Calculus of Inductive -Constructions may read several papers. Giménez and Castéran~\cite{GimCas05} -provide -an introduction to inductive and co-inductive definitions in Coq. In -their book~\cite{CoqArt}, Bertot and Castéran give a precise -description of the \CIC{} based on numerous practical examples. -Barras~\cite{Bar99}, Werner~\cite{Wer94} and -Paulin-Mohring~\cite{Moh97} are the most recent theses dealing with -Inductive Definitions. Coquand-Huet~\cite{CoHu85a,CoHu85b,CoHu86} -introduces the Calculus of Constructions. Coquand-Paulin~\cite{CoPa89} -extended this calculus to inductive definitions. The {\CIC} is a -formulation of type theory including the possibility of inductive -constructions, Barendregt~\cite{Bar91} studies the modern form of type -theory. +type. For instance, universal quantification is relative to a type and +takes the form {\it ``for all x +of type T, P''}. The expression {\it ``x of type T''} is +written {\it ``x:T''}. Informally, {\it ``x:T''} can be thought as +{\it ``x belongs to T''}. -\section[The terms]{The terms\label{Terms}} - -In most type theories, one usually makes a syntactic distinction -between types and terms. This is not the case for \CIC\ which defines -both types and terms in the same syntactical structure. This is -because the type-theory itself forces terms and types to be defined in -a mutual recursive way and also because similar constructions can be -applied to both terms and types and consequently can share the same -syntactic structure. - -Consider for instance the $\ra$ constructor and assume \nat\ is the -type of natural numbers. Then $\ra$ is used both to denote -$\nat\ra\nat$ which is the type of functions from \nat\ to \nat, and -to denote $\nat \ra \Prop$ which is the type of unary predicates over -the natural numbers. Consider abstraction which builds functions. It -serves to build ``ordinary'' functions as $\kw{fun}~x:\nat \Ra ({\tt mult} ~x~x)$ (assuming {\tt mult} is already defined) but may build also -predicates over the natural numbers. For instance $\kw{fun}~x:\nat \Ra -(x=x)$ will -represent a predicate $P$, informally written in mathematics -$P(x)\equiv x=x$. If $P$ has type $\nat \ra \Prop$, $(P~x)$ is a -proposition, furthermore $\kw{forall}~x:\nat,(P~x)$ will represent the type of -functions which associate to each natural number $n$ an object of -type $(P~n)$ and consequently represent proofs of the formula -``$\forall x.P(x)$''. +The types of types are {\em sorts}. Types and sorts are themselves +terms so that terms, types and sorts are all components of a common +syntactic language of terms which is described in +Section~\ref{cic:terms} but, first, we describe sorts. \subsection[Sorts]{Sorts\label{Sorts} \index{Sorts}} -When manipulated as terms, types have themselves a type which is called a sort. - -There is an infinite well-founded typing hierarchy of sorts whose base -sorts are {\Prop} and {\Set}. +All sorts have a type and there is an infinite well-founded +typing hierarchy of sorts whose base sorts are {\Prop} and {\Set}. The sort {\Prop} intends to be the type of logical propositions. If $M$ is a logical proposition then it denotes the class of terms @@ -97,7 +43,7 @@ function types over these data types. {\Prop} and {\Set} themselves can be manipulated as ordinary terms. Consequently they also have a type. Because assuming simply -that {\Set} has type {\Set} leads to an inconsistent theory, the +that {\Set} has type {\Set} leads to an inconsistent theory~\cite{Coq86}, the language of {\CIC} has infinitely many sorts. There are, in addition to {\Set} and {\Prop} a hierarchy of universes {\Type$(i)$} for any integer $i$. @@ -109,242 +55,275 @@ sets, namely the sorts {\Set} and {\Type$(j)$} for $j<i$, and all products, subsets and function types over these sorts. Formally, we call {\Sort} the set of sorts which is defined by: -\[\Sort \equiv \{\Prop,\Set,\Type(i)| i \in \NN\} \] -\index{Type@{\Type}} -\index{Prop@{\Prop}} -\index{Set@{\Set}} - -The sorts enjoy the following properties\footnote{In the Reference - Manual of versions of Coq prior to 8.4, the level of {\Type} typing - {\Prop} and {\Set} was numbered $0$. From Coq 8.4, it started to be - numbered $1$ so as to be able to leave room for re-interpreting - {\Set} in the hierarchy as {\Type$(0)$}. This change also put the - reference manual in accordance with the internal conventions adopted - in the implementation.}: {\Prop:\Type$(1)$}, {\Set:\Type$(1)$} and -{\Type$(i)$:\Type$(i+1)$}. - -The user will never mention explicitly the index $i$ when referring to +\index{Type@{\Type}}% +\index{Prop@{\Prop}}% +\index{Set@{\Set}}% +\[\Sort \equiv \{\Prop,\Set,\Type(i)\;|\; i \in \NN\} \] +Their properties, such as: +{\Prop:\Type$(1)$}, {\Set:\Type$(1)$}, and {\Type$(i)$:\Type$(i+1)$}, +are defined in Section~\ref{subtyping-rules}. + +The user does not have to mention explicitly the index $i$ when referring to the universe \Type$(i)$. One only writes \Type. The system itself generates for each instance of \Type\ a new index for the universe and checks that the constraints between these indexes can be solved. From the user point of view we consequently -have {\sf Type :Type}. - +have {\Type}:{\Type}. We shall make precise in the typing rules the constraints between the indexes. \paragraph{Implementation issues} -In practice, the {\Type} hierarchy is implemented using algebraic -universes. An algebraic universe $u$ is either a variable (a qualified +In practice, the {\Type} hierarchy is implemented using +{\em algebraic universes}\index{algebraic universe}. +An algebraic universe $u$ is either a variable (a qualified identifier with a number) or a successor of an algebraic universe (an expression $u+1$), or an upper bound of algebraic universes (an expression $max(u_1,...,u_n)$), or the base universe (the expression $0$) which corresponds, in the arity of sort-polymorphic inductive -types, to the predicative sort {\Set}. A graph of constraints between +types (see Section \ref{Sort-polymorphism-inductive}), +to the predicative sort {\Set}. A graph of constraints between the universe variables is maintained globally. To ensure the existence of a mapping of the universes to the positive integers, the graph of constraints must remain acyclic. Typing expressions that violate the acyclicity of the graph of constraints results in a \errindex{Universe inconsistency} error (see also Section~\ref{PrintingUniverses}). -\subsection{Constants} -Besides the sorts, the language also contains constants denoting -objects in the environment. These constants may denote previously -defined objects but also objects related to inductive definitions -(either the type itself or one of its constructors or destructors). - -\medskip\noindent {\bf Remark. } In other presentations of \CIC, -the inductive objects are not seen as -external declarations but as first-class terms. Usually the -definitions are also completely ignored. This is a nice theoretical -point of view but not so practical. An inductive definition is -specified by a possibly huge set of declarations, clearly we want to -share this specification among the various inductive objects and not -to duplicate it. So the specification should exist somewhere and the -various objects should refer to it. We choose one more level of -indirection where the objects are just represented as constants and -the environment gives the information on the kind of object the -constant refers to. - -\medskip -Our inductive objects will be manipulated as constants declared in the -environment. This roughly corresponds to the way they are actually -implemented in the \Coq\ system. It is simple to map this presentation -in a theory where inductive objects are represented by terms. +%% HH: This looks to me more like source of confusion than helpful + +%% \subsection{Constants} + +%% Constants refers to +%% objects in the global environment. These constants may denote previously +%% defined objects, but also objects related to inductive definitions +%% (either the type itself or one of its constructors or destructors). + +%% \medskip\noindent {\bf Remark. } In other presentations of \CIC, +%% the inductive objects are not seen as +%% external declarations but as first-class terms. Usually the +%% definitions are also completely ignored. This is a nice theoretical +%% point of view but not so practical. An inductive definition is +%% specified by a possibly huge set of declarations, clearly we want to +%% share this specification among the various inductive objects and not +%% to duplicate it. So the specification should exist somewhere and the +%% various objects should refer to it. We choose one more level of +%% indirection where the objects are just represented as constants and +%% the environment gives the information on the kind of object the +%% constant refers to. + +%% \medskip +%% Our inductive objects will be manipulated as constants declared in the +%% environment. This roughly corresponds to the way they are actually +%% implemented in the \Coq\ system. It is simple to map this presentation +%% in a theory where inductive objects are represented by terms. \subsection{Terms} +\label{cic:terms} -Terms are built from variables, global names, constructors, -abstraction, application, local declarations bindings (``let-in'' -expressions) and product. - +Terms are built from sorts, variables, constants, +%constructors, inductive types, +abstractions, applications, local definitions, +%case analysis, fixpoints, cofixpoints +and products. From a syntactic point of view, types cannot be distinguished from terms, -except that they cannot start by an abstraction, and that if a term is -a sort or a product, it should be a type. - +except that they cannot start by an abstraction or a constructor. More precisely the language of the {\em Calculus of Inductive - Constructions} is built from the following rules: - + Constructions} is built from the following rules. +% \begin{enumerate} -\item the sorts {\sf Set, Prop, Type} are terms. -\item names for global constants of the environment are terms. -\item variables are terms. -\item if $x$ is a variable and $T$, $U$ are terms then $\forall~x:T,U$ - ($\kw{forall}~x:T,U$ in \Coq{} concrete syntax) is a term. If $x$ +\item the sorts {\Set}, {\Prop}, ${\Type(i)}$ are terms. +\item variables, hereafter ranged over by letters $x$, $y$, etc., are terms +\item constants, hereafter ranged over by letters $c$, $d$, etc., are terms. +%\item constructors, hereafter ranged over by letter $C$, are terms. +%\item inductive types, hereafter ranged over by letter $I$, are terms. +\item\index{products} if $x$ is a variable and $T$, $U$ are terms then $\forall~x:T,U$ + ($\kw{forall}~x:T,~U$ in \Coq{} concrete syntax) is a term. If $x$ occurs in $U$, $\forall~x:T,U$ reads as {\it ``for all x of type T, U''}. As $U$ depends on $x$, one says that $\forall~x:T,U$ is a - {\em dependent product}. If $x$ doesn't occurs in $U$ then - $\forall~x:T,U$ reads as {\it ``if T then U''}. A non dependent - product can be written: $T \rightarrow U$. -\item if $x$ is a variable and $T$, $U$ are terms then $\lb x:T \mto U$ - ($\kw{fun}~x:T\Ra U$ in \Coq{} concrete syntax) is a term. This is a + {\em dependent product}. If $x$ does not occur in $U$ then + $\forall~x:T,U$ reads as {\it ``if T then U''}. A {\em non dependent + product} can be written: $T \ra U$. +\item if $x$ is a variable and $T$, $u$ are terms then $\lb x:T \mto u$ + ($\kw{fun}~x:T~ {\tt =>}~ u$ in \Coq{} concrete syntax) is a term. This is a notation for the $\lambda$-abstraction of $\lambda$-calculus\index{lambda-calculus@$\lambda$-calculus} - \cite{Bar81}. The term $\lb x:T \mto U$ is a function which maps - elements of $T$ to $U$. -\item if $T$ and $U$ are terms then $(T\ U)$ is a term - ($T~U$ in \Coq{} concrete syntax). The term $(T\ - U)$ reads as {\it ``T applied to U''}. -\item if $x$ is a variable, and $T$, $U$ are terms then - $\kw{let}~x:=T~\kw{in}~U$ is a - term which denotes the term $U$ where the variable $x$ is locally - bound to $T$. This stands for the common ``let-in'' construction of - functional programs such as ML or Scheme. + \cite{Bar81}. The term $\lb x:T \mto u$ is a function which maps + elements of $T$ to the expression $u$. +\item if $t$ and $u$ are terms then $(t\ u)$ is a term + ($t~u$ in \Coq{} concrete syntax). The term $(t\ + u)$ reads as {\it ``t applied to u''}. +\item if $x$ is a variable, and $t$, $T$ and $u$ are terms then + $\kw{let}~x:=t:T~\kw{in}~u$ is a + term which denotes the term $u$ where the variable $x$ is locally + bound to $t$ of type $T$. This stands for the common ``let-in'' + construction of functional programs such as ML or Scheme. +%\item case ... +%\item fixpoint ... +%\item cofixpoint ... \end{enumerate} -\paragraph{Notations.} Application associates to the left such that -$(t~t_1\ldots t_n)$ represents $(\ldots (t~t_1)\ldots t_n)$. The -products and arrows associate to the right such that $\forall~x:A,B\ra C\ra -D$ represents $\forall~x:A,(B\ra (C\ra D))$. One uses sometimes -$\forall~x~y:A,B$ or -$\lb x~y:A\mto B$ to denote the abstraction or product of several variables -of the same type. The equivalent formulation is $\forall~x:A, \forall y:A,B$ or -$\lb x:A \mto \lb y:A \mto B$ - \paragraph{Free variables.} The notion of free variables is defined as usual. In the expressions $\lb x:T\mto U$ and $\forall x:T, U$ the occurrences of $x$ in $U$ -are bound. They are represented by de Bruijn indexes in the internal -structure of terms. +are bound. \paragraph[Substitution.]{Substitution.\index{Substitution}} The notion of substituting a term $t$ to free occurrences of a variable $x$ in a term $u$ is defined as usual. The resulting term is written $\subst{u}{x}{t}$. - -\section[Typed terms]{Typed terms\label{Typed-terms}} +\paragraph[The logical vs programming readings.]{The logical vs programming readings.} + +The constructions of the {\CIC} can be used to express both logical +and programming notions, accordingly to the Curry-Howard +correspondence between proofs and programs, and between propositions +and types~\cite{Cur58,How80,Bru72}. + +For instance, let us assume that \nat\ is the type of natural numbers +with zero element written $0$ and that ${\tt True}$ is the always true +proposition. Then $\ra$ is used both to denote $\nat\ra\nat$ which is +the type of functions from \nat\ to \nat, to denote ${\tt True}\ra{\tt + True}$ which is an implicative proposition, to denote $\nat \ra +\Prop$ which is the type of unary predicates over the natural numbers, +etc. + +Let us assume that ${\tt mult}$ is a function of type $\nat\ra\nat\ra +\nat$ and ${\tt eqnat}$ a predicate of type $\nat\ra\nat\ra \Prop$. +The $\lambda$-abstraction can serve to build ``ordinary'' functions as +in $\lambda x:\nat.({\tt mult}~x~x)$ (i.e. $\kw{fun}~x:\nat ~{\tt =>}~ +{\tt mult} ~x~x$ in {\Coq} notation) but may build also predicates +over the natural numbers. For instance $\lambda x:\nat.({\tt eqnat}~ +x~0)$ (i.e. $\kw{fun}~x:\nat ~{\tt =>}~ {\tt eqnat}~ x~0$ in {\Coq} +notation) will represent the predicate of one variable $x$ which +asserts the equality of $x$ with $0$. This predicate has type $\nat +\ra \Prop$ and it can be applied to any expression of type ${\nat}$, +say $t$, to give an object $P~t$ of type \Prop, namely a proposition. + +Furthermore $\kw{forall}~x:\nat,\,P\;x$ will represent the type of +functions which associate to each natural number $n$ an object of type +$(P~n)$ and consequently represent the type of proofs of the formula +``$\forall x.\,P(x)$''. + +\section[Typing rules]{Typing rules\label{Typed-terms}} As objects of type theory, terms are subjected to {\em type -discipline}. The well typing of a term depends on an environment which -consists in a global environment (see below) and a local context. - -\paragraph{Local context.} -A {\em local context} (or shortly context) is an ordered list of -declarations of variables. The declaration of some variable $x$ is -either an assumption, written $x:T$ ($T$ is a type) or a definition, -written $x:=t:T$. We use brackets to write contexts. A +discipline}. The well typing of a term depends on +a global environment and a local context. + +\paragraph{Local context.\index{Local context}} +A {\em local context} is an ordered list of +{\em local declarations\index{declaration!local}} of names which we call {\em variables\index{variable}}. +The declaration of some variable $x$ is +either a {\em local assumption\index{assumption!local}}, written $x:T$ ($T$ is a type) or a {\em local definition\index{definition!local}}, +written $x:=t:T$. We use brackets to write local contexts. A typical example is $[x:T;y:=u:U;z:V]$. Notice that the variables -declared in a context must be distinct. If $\Gamma$ declares some $x$, +declared in a local context must be distinct. If $\Gamma$ declares some $x$, we write $x \in \Gamma$. By writing $(x:T) \in \Gamma$ we mean that either $x:T$ is an assumption in $\Gamma$ or that there exists some $t$ such that $x:=t:T$ is a definition in $\Gamma$. If $\Gamma$ defines some -$x:=t:T$, we also write $(x:=t:T) \in \Gamma$. Contexts must be -themselves {\em well formed}. For the rest of the chapter, the -notation $\Gamma::(y:T)$ (resp. $\Gamma::(y:=t:T)$) denotes the context -$\Gamma$ enriched with the declaration $y:T$ (resp. $y:=t:T$). The -notation $[]$ denotes the empty context. \index{Context} +$x:=t:T$, we also write $(x:=t:T) \in \Gamma$. +For the rest of the chapter, the $\Gamma::(y:T)$ denotes the local context +$\Gamma$ enriched with the local assumption $y:T$. +Similarly, $\Gamma::(y:=t:T)$ denotes the local context +$\Gamma$ enriched with the local definition $(y:=t:T)$. +The notation $[]$ denotes the empty local context. +By $\Gamma_1; \Gamma_2$ we mean concatenation of the local context $\Gamma_1$ +and the local context $\Gamma_2$. % Does not seem to be used further... % Si dans l'explication WF(E)[Gamma] concernant les constantes % definies ds un contexte -We define the inclusion of two contexts $\Gamma$ and $\Delta$ (written -as $\Gamma \subset \Delta$) as the property, for all variable $x$, -type $T$ and term $t$, if $(x:T) \in \Gamma$ then $(x:T) \in \Delta$ -and if $(x:=t:T) \in \Gamma$ then $(x:=t:T) \in \Delta$. +%We define the inclusion of two local contexts $\Gamma$ and $\Delta$ (written +%as $\Gamma \subset \Delta$) as the property, for all variable $x$, +%type $T$ and term $t$, if $(x:T) \in \Gamma$ then $(x:T) \in \Delta$ +%and if $(x:=t:T) \in \Gamma$ then $(x:=t:T) \in \Delta$. %We write % $|\Delta|$ for the length of the context $\Delta$, that is for the number % of declarations (assumptions or definitions) in $\Delta$. -A variable $x$ is said to be free in $\Gamma$ if $\Gamma$ contains a -declaration $y:T$ such that $x$ is free in $T$. - -\paragraph[Environment.]{Environment.\index{Environment}} -Because we are manipulating global declarations (constants and global -assumptions), we also need to consider a global environment $E$. - -An environment is an ordered list of declarations of global -names. Declarations are either assumptions or ``standard'' -definitions, that is abbreviations for well-formed terms -but also definitions of inductive objects. In the latter -case, an object in the environment will define one or more constants -(that is types and constructors, see Section~\ref{Cic-inductive-definitions}). - -An assumption will be represented in the environment as -\Assum{\Gamma}{c}{T} which means that $c$ is assumed of some type $T$ -well-defined in some context $\Gamma$. An (ordinary) definition will -be represented in the environment as \Def{\Gamma}{c}{t}{T} which means -that $c$ is a constant which is valid in some context $\Gamma$ whose -value is $t$ and type is $T$. - -The rules for inductive definitions (see section +\paragraph[Global environment.]{Global environment.\index{Global environment}} +%Because we are manipulating global declarations (global constants and global +%assumptions), we also need to consider a global environment $E$. + +A {\em global environment} is an ordered list of {\em global declarations\index{declaration!global}}. +Global declarations are either {\em global assumptions\index{assumption!global}} or {\em global +definitions\index{definition!global}}, but also declarations of inductive objects. Inductive objects themselves declare both inductive or coinductive types and constructors +(see Section~\ref{Cic-inductive-definitions}). + +A {\em global assumption} will be represented in the global environment as +$(c:T)$ which assumes the name $c$ to be of some type $T$. +A {\em global definition} will +be represented in the global environment as $c:=t:T$ which defines +the name $c$ to have value $t$ and type $T$. +We shall call such names {\em constants}. +For the rest of the chapter, the $E;c:T$ denotes the global environment +$E$ enriched with the global assumption $c:T$. +Similarly, $E;c:=t:T$ denotes the global environment +$E$ enriched with the global definition $(c:=t:T)$. + +The rules for inductive definitions (see Section \ref{Cic-inductive-definitions}) have to be considered as assumption rules to which the following definitions apply: if the name $c$ is declared in $E$, we write $c \in E$ and if $c:T$ or $c:=t:T$ is declared in $E$, we write $(c : T) \in E$. \paragraph[Typing rules.]{Typing rules.\label{Typing-rules}\index{Typing rules}} -In the following, we assume $E$ is a valid environment w.r.t. -inductive definitions. We define simultaneously two +In the following, we define simultaneously two judgments. The first one \WTEG{t}{T} means the term $t$ is well-typed -and has type $T$ in the environment $E$ and context $\Gamma$. The -second judgment \WFE{\Gamma} means that the environment $E$ is -well-formed and the context $\Gamma$ is a valid context in this -environment. It also means a third property which makes sure that any -constant in $E$ was defined in an environment which is included in -$\Gamma$ -\footnote{This requirement could be relaxed if we instead introduced - an explicit mechanism for instantiating constants. At the external - level, the Coq engine works accordingly to this view that all the - definitions in the environment were built in a sub-context of the - current context.}. - -A term $t$ is well typed in an environment $E$ iff there exists a -context $\Gamma$ and a term $T$ such that the judgment \WTEG{t}{T} can +and has type $T$ in the global environment $E$ and local context $\Gamma$. The +second judgment \WFE{\Gamma} means that the global environment $E$ is +well-formed and the local context $\Gamma$ is a valid local context in this +global environment. +% HH: This looks to me complicated. I think it would be better to talk +% about ``discharge'' as a transformation of global environments, +% rather than as keeping a local context next to global constants. +% +%% It also means a third property which makes sure that any +%%constant in $E$ was defined in an environment which is included in +%%$\Gamma$ +%%\footnote{This requirement could be relaxed if we instead introduced +%% an explicit mechanism for instantiating constants. At the external +%% level, the Coq engine works accordingly to this view that all the +%% definitions in the environment were built in a local sub-context of the +%% current local context.}. + +A term $t$ is well typed in a global environment $E$ iff there exists a +local context $\Gamma$ and a term $T$ such that the judgment \WTEG{t}{T} can be derived from the following rules. \begin{description} -\item[W-E] \inference{\WF{[]}{[]}} -\item[W-S] % Ce n'est pas vrai : x peut apparaitre plusieurs fois dans Gamma -\inference{\frac{\WTEG{T}{s}~~~~s \in \Sort~~~~x \not\in - \Gamma % \cup E - } - {\WFE{\Gamma::(x:T)}}~~~~~ - \frac{\WTEG{t}{T}~~~~x \not\in - \Gamma % \cup E +\item[W-Empty] \inference{\WF{[]}{}} +\item[W-Local-Assum] % Ce n'est pas vrai : x peut apparaitre plusieurs fois dans Gamma +\inference{\frac{\WTEG{T}{s}~~~~s \in \Sort~~~~x \not\in \Gamma % \cup E + }{\WFE{\Gamma::(x:T)}}} +\item[W-Local-Def] +\inference{\frac{\WTEG{t}{T}~~~~x \not\in \Gamma % \cup E }{\WFE{\Gamma::(x:=t:T)}}} -\item[Def] \inference{\frac{\WTEG{t}{T}~~~c \notin E \cup \Gamma} - {\WF{E;\Def{\Gamma}{c}{t}{T}}{\Gamma}}} -\item[Assum] \inference{\frac{\WTEG{T}{s}~~~~s \in \Sort~~~~c \notin E \cup \Gamma} - {\WF{E;\Assum{\Gamma}{c}{T}}{\Gamma}}} -\item[Ax] \index{Typing rules!Ax} -\inference{\frac{\WFE{\Gamma}}{\WTEG{\Prop}{\Type(p)}}~~~~~ -\frac{\WFE{\Gamma}}{\WTEG{\Set}{\Type(q)}}} -\inference{\frac{\WFE{\Gamma}~~~~i<j}{\WTEG{\Type(i)}{\Type(j)}}} +\item[W-Global-Assum] \inference{\frac{\WTE{}{T}{s}~~~~s \in \Sort~~~~c \notin E} + {\WF{E;c:T}{}}} +\item[W-Global-Def] \inference{\frac{\WTE{}{t}{T}~~~c \notin E} + {\WF{E;c:=t:T}{}}} +\item[Ax-Prop] \index{Typing rules!Ax-Prop} +\inference{\frac{\WFE{\Gamma}}{\WTEG{\Prop}{\Type(1)}}} +\item[Ax-Set] \index{Typing rules!Ax-Set} +\inference{\frac{\WFE{\Gamma}}{\WTEG{\Set}{\Type(1)}}} +\item[Ax-Type] \index{Typing rules!Ax-Type} +\inference{\frac{\WFE{\Gamma}}{\WTEG{\Type(i)}{\Type(i+1)}}} \item[Var]\index{Typing rules!Var} \inference{\frac{ \WFE{\Gamma}~~~~~(x:T) \in \Gamma~~\mbox{or}~~(x:=t:T) \in \Gamma~\mbox{for some $t$}}{\WTEG{x}{T}}} \item[Const] \index{Typing rules!Const} \inference{\frac{\WFE{\Gamma}~~~~(c:T) \in E~~\mbox{or}~~(c:=t:T) \in E~\mbox{for some $t$} }{\WTEG{c}{T}}} -\item[Prod] \index{Typing rules!Prod} +\item[Prod-Prop] \index{Typing rules!Prod-Prop} \inference{\frac{\WTEG{T}{s}~~~~s \in \Sort~~~ \WTE{\Gamma::(x:T)}{U}{\Prop}} { \WTEG{\forall~x:T,U}{\Prop}}} +\item[Prod-Set] \index{Typing rules!Prod-Set} \inference{\frac{\WTEG{T}{s}~~~~s \in\{\Prop, \Set\}~~~~~~ \WTE{\Gamma::(x:T)}{U}{\Set}} { \WTEG{\forall~x:T,U}{\Set}}} -\inference{\frac{\WTEG{T}{\Type(i)}~~~~i\leq k~~~ - \WTE{\Gamma::(x:T)}{U}{\Type(j)}~~~j \leq k} - {\WTEG{\forall~x:T,U}{\Type(k)}}} +\item[Prod-Type] \index{Typing rules!Prod-Type} +\inference{\frac{\WTEG{T}{\Type(i)}~~~~ + \WTE{\Gamma::(x:T)}{U}{\Type(i)}} + {\WTEG{\forall~x:T,U}{\Type(i)}}} \item[Lam]\index{Typing rules!Lam} \inference{\frac{\WTEG{\forall~x:T,U}{s}~~~~ \WTE{\Gamma::(x:T)}{t}{U}} {\WTEG{\lb x:T\mto t}{\forall x:T, U}}} @@ -353,22 +332,34 @@ be derived from the following rules. {\WTEG{(t\ u)}{\subst{T}{x}{u}}}} \item[Let]\index{Typing rules!Let} \inference{\frac{\WTEG{t}{T}~~~~ \WTE{\Gamma::(x:=t:T)}{u}{U}} - {\WTEG{\kw{let}~x:=t~\kw{in}~u}{\subst{U}{x}{t}}}} + {\WTEG{\letin{x}{t:T}{u}}{\subst{U}{x}{t}}}} \end{description} - -\Rem We may have $\kw{let}~x:=t~\kw{in}~u$ + +\Rem Prod$_1$ and Prod$_2$ typing-rules make sense if we consider the semantic +difference between {\Prop} and {\Set}: +\begin{itemize} + \item All values of a type that has a sort {\Set} are extractable. + \item No values of a type that has a sort {\Prop} are extractable. +\end{itemize} + +\Rem We may have $\kw{let}~x:=t:T~\kw{in}~u$ well-typed without having $((\lb x:T\mto u)~t)$ well-typed (where $T$ is a type of $t$). This is because the value $t$ associated to $x$ may be used in a conversion rule (see Section~\ref{conv-rules}). \section[Conversion rules]{Conversion rules\index{Conversion rules} \label{conv-rules}} + +In \CIC, there is an internal reduction mechanism. In particular, it +can decide if two programs are {\em intentionally} equal (one +says {\em convertible}). Convertibility is described in this section. + \paragraph[$\beta$-reduction.]{$\beta$-reduction.\label{beta}\index{beta-reduction@$\beta$-reduction}} We want to be able to identify some terms as we can identify the application of a function to a given argument with its result. For instance the identity function over a given type $T$ can be written -$\lb x:T\mto x$. In any environment $E$ and context $\Gamma$, we want to identify any object $a$ (of type $T$) with the +$\lb x:T\mto x$. In any global environment $E$ and local context $\Gamma$, we want to identify any object $a$ (of type $T$) with the application $((\lb x:T\mto x)~a)$. We define for this a {\em reduction} (or a {\em conversion}) rule we call $\beta$: \[ \WTEGRED{((\lb x:T\mto @@ -385,7 +376,7 @@ refer the interested reader to \cite{Coq85}. \paragraph[$\iota$-reduction.]{$\iota$-reduction.\label{iota}\index{iota-reduction@$\iota$-reduction}} A specific conversion rule is associated to the inductive objects in -the environment. We shall give later on (see Section~\ref{iotared}) the +the global environment. We shall give later on (see Section~\ref{iotared}) the precise rules but it just says that a destructor applied to an object built from a constructor behaves as expected. This reduction is called $\iota$-reduction and is more precisely studied in @@ -394,7 +385,7 @@ called $\iota$-reduction and is more precisely studied in \paragraph[$\delta$-reduction.]{$\delta$-reduction.\label{delta}\index{delta-reduction@$\delta$-reduction}} -We may have defined variables in contexts or constants in the global +We may have variables defined in local contexts or constants defined in the global environment. It is legal to identify such a reference with its value, that is to expand (or unfold) it into its value. This reduction is called $\delta$-reduction and shows as follows. @@ -411,34 +402,57 @@ called $\zeta$-reduction and shows as follows. $$\WTEGRED{\kw{let}~x:=u~\kw{in}~t}{\triangleright_{\zeta}}{\subst{t}{x}{u}}$$ -\paragraph{$\eta$-conversion. -\label{eta} -\index{eta-conversion@$\eta$-conversion} +\paragraph{$\eta$-expansion.% +\label{eta}% +\index{eta-expansion@$\eta$-expansion}% %\index{eta-reduction@$\eta$-reduction} -} -An other important concept is $\eta$-conversion. It is to identify any +}% +Another important concept is $\eta$-expansion. It is legal to identify any term $t$ of functional type $\forall x:T, U$ with its so-called $\eta$-expansion $\lb x:T\mto (t\ x)$ for $x$ an arbitrary variable name fresh in $t$. -The notion of $\eta$-reduction ${\lb x:T\mto (t\ x)}{\triangleright}{t}$ -(for $x$ not occurring in $t$) is not type-sound because of subtyping -(think about $\lb x:\Type(1)\mto (f x)$ of type $\forall -x:\Type(1), \Type(1)$ for $f$ of type $\forall x:\Type(2), -\Type(1)$). On the other side, $\eta$-expansion requires to know $T$ -and hence requires types. Hence, neither $\eta$-expansion nor -$\eta$-reduction can be type-safely considered on terms we do not know -the type. However, $\eta$ can be used as a conversion rule. +\Rem We deliberately do not define $\eta$-reduction: +\begin{latexonly}% + $$\lb x:T\mto (t\ x)\not\triangleright_\eta\hskip.3em t$$ +\end{latexonly}% +\begin{htmlonly} + $$\lb x:T\mto (t\ x)~\not\triangleright_\eta~t$$ +\end{htmlonly} +This is because, in general, the type of $t$ need not to be convertible to the type of $\lb x:T\mto (t\ x)$. +E.g., if we take $f$ such that: +\begin{latexonly}% + $$f\hskip.5em:\hskip.5em\forall x:Type(2),Type(1)$$ +\end{latexonly}% +\begin{htmlonly} + $$f~:~\forall x:Type(2),Type(1)$$ +\end{htmlonly} +then +\begin{latexonly}% + $$\lb x:Type(1),(f\, x)\hskip.5em:\hskip.5em\forall x:Type(1),Type(1)$$ +\end{latexonly}% +\begin{htmlonly} + $$\lb x:Type(1),(f\, x)~:~\forall x:Type(1),Type(1)$$ +\end{htmlonly} +We could not allow +\begin{latexonly}% + $$\lb x:Type(1),(f\,x)\hskip.4em\not\triangleright_\eta\hskip.6em f$$ +\end{latexonly}% +\begin{htmlonly} + $$\lb x:Type(1),(f\,x)~\not\triangleright_\eta~f$$ +\end{htmlonly} +because the type of the reduced term $\forall x:Type(2),Type(1)$ +would not be convertible to the type of the original term $\forall x:Type(1),Type(1)$. \paragraph[Convertibility.]{Convertibility.\label{convertibility} \index{beta-reduction@$\beta$-reduction}\index{iota-reduction@$\iota$-reduction}\index{delta-reduction@$\delta$-reduction}\index{zeta-reduction@$\zeta$-reduction}} -Let us write $\WTEGRED{t}{\triangleright}{u}$ for the contextual closure of the relation $t$ reduces to $u$ in the environment $E$ and context $\Gamma$ with one of the previous reduction $\beta$, $\iota$, $\delta$ or $\zeta$. +Let us write $\WTEGRED{t}{\triangleright}{u}$ for the contextual closure of the relation $t$ reduces to $u$ in the global environment $E$ and local context $\Gamma$ with one of the previous reduction $\beta$, $\iota$, $\delta$ or $\zeta$. We say that two terms $t_1$ and $t_2$ are {\em $\beta\iota\delta\zeta\eta$-convertible}, or simply {\em - convertible}, or {\em equivalent}, in the environment $E$ and -context $\Gamma$ iff there exist terms $u_1$ and $u_2$ such that + convertible}, or {\em equivalent}, in the global environment $E$ and +local context $\Gamma$ iff there exist terms $u_1$ and $u_2$ such that $\WTEGRED{t_1}{\triangleright \ldots \triangleright}{u_1}$ and $\WTEGRED{t_2}{\triangleright \ldots \triangleright}{u_2}$ and either $u_1$ and $u_2$ are identical, or they are convertible up to @@ -451,11 +465,13 @@ The convertibility relation allows introducing a new typing rule which says that two convertible well-formed types have the same inhabitants. +\section[Subtyping rules]{Subtyping rules\index{Subtyping rules} +\label{subtyping-rules}} + At the moment, we did not take into account one rule between universes which says that any term in a universe of index $i$ is also a term in the universe of index $i+1$ (this is the {\em cumulativity} rule of -{\CIC}). This property is included into the -conversion rule by extending the equivalence relation of +{\CIC}). This property extends the equivalence relation of convertibility into a {\em subtyping} relation inductively defined by: \begin{enumerate} \item if $\WTEGCONV{t}{u}$ then $\WTEGLECONV{t}{u}$, @@ -466,7 +482,7 @@ convertibility into a {\em subtyping} relation inductively defined by: \item if $\WTEGCONV{T}{U}$ and $\WTELECONV{\Gamma::(x:T)}{T'}{U'}$ then $\WTEGLECONV{\forall~x:T, T'}{\forall~x:U, U'}$. \end{enumerate} -The conversion rule is now exactly: +The conversion rule up to subtyping is now exactly: \begin{description}\label{Conv} \item[Conv]\index{Typing rules!Conv} @@ -478,7 +494,7 @@ The conversion rule is now exactly: \paragraph[Normal form.]{Normal form.\index{Normal form}\label{Normal-form}\label{Head-normal-form}\index{Head normal form}} A term which cannot be any more reduced is said to be in {\em normal form}. There are several ways (or strategies) to apply the reduction -rule. Among them, we have to mention the {\em head reduction} which +rules. Among them, we have to mention the {\em head reduction} which will play an important role (see Chapter~\ref{Tactics}). Any term can be written as $\lb x_1:T_1\mto \ldots \lb x_k:T_k \mto (t_0\ t_1\ldots t_n)$ where @@ -497,293 +513,122 @@ term is no more an abstraction leads to the {\em $\beta$-head normal where $v$ is not an abstraction (nor an application). Note that the head normal form must not be confused with the normal form since some $u_i$ can be reducible. - +% Similar notions of head-normal forms involving $\delta$, $\iota$ and $\zeta$ reductions or any combination of those can also be defined. -\section{Derived rules for environments} - -From the original rules of the type system, one can derive new rules -which change the context of definition of objects in the environment. -Because these rules correspond to elementary operations in the \Coq\ -engine used in the discharge mechanism at the end of a section, we -state them explicitly. - -\paragraph{Mechanism of substitution.} +\section[Inductive definitions]{Inductive Definitions\label{Cic-inductive-definitions}} -One rule which can be proved valid, is to replace a term $c$ by its -value in the environment. As we defined the substitution of a term for -a variable in a term, one can define the substitution of a term for a -constant. One easily extends this substitution to contexts and -environments. - -\paragraph{Substitution Property:} -\inference{\frac{\WF{E;\Def{\Gamma}{c}{t}{T}; F}{\Delta}} - {\WF{E; \subst{F}{c}{t}}{\subst{\Delta}{c}{t}}}} +% Here we assume that the reader knows what is an inductive definition. +Formally, we can represent any {\em inductive definition\index{definition!inductive}} as \Ind{}{p}{\Gamma_I}{\Gamma_C} where: +\begin{itemize} + \item $\Gamma_I$ determines the names and types of inductive types; + \item $\Gamma_C$ determines the names and types of constructors of these inductive types; + \item $p$ determines the number of parameters of these inductive types. +\end{itemize} +These inductive definitions, together with global assumptions and global definitions, then form the global environment. +% +Additionally, for any $p$ there always exists $\Gamma_P=[a_1:A_1;\dots;a_p:A_p]$ +such that each $(t:T)\in\Gamma_I\cup\Gamma_C$ can be written as: +$\forall\Gamma_P, T^\prime$ where $\Gamma_P$ is called the {\em context of parameters\index{context of parameters}}. -\paragraph{Abstraction.} +\paragraph{Examples} -One can modify the context of definition of a constant $c$ by -abstracting a constant with respect to the last variable $x$ of its -defining context. For doing that, we need to check that the constants -appearing in the body of the declaration do not depend on $x$, we need -also to modify the reference to the constant $c$ in the environment -and context by explicitly applying this constant to the variable $x$. -Because of the rules for building environments and terms we know the -variable $x$ is available at each stage where $c$ is mentioned. - -\paragraph{Abstracting property:} - \inference{\frac{\WF{E; \Def{\Gamma::(x:U)}{c}{t}{T}; - F}{\Delta}~~~~\WFE{\Gamma}} - {\WF{E;\Def{\Gamma}{c}{\lb x:U\mto t}{\forall~x:U,T}; - \subst{F}{c}{(c~x)}}{\subst{\Delta}{c}{(c~x)}}}} - -\paragraph{Pruning the context.} -We said the judgment \WFE{\Gamma} means that the defining contexts of -constants in $E$ are included in $\Gamma$. If one abstracts or -substitutes the constants with the above rules then it may happen -that the context $\Gamma$ is now bigger than the one needed for -defining the constants in $E$. Because defining contexts are growing -in $E$, the minimum context needed for defining the constants in $E$ -is the same as the one for the last constant. One can consequently -derive the following property. - -\paragraph{Pruning property:} -\inference{\frac{\WF{E; \Def{\Delta}{c}{t}{T}}{\Gamma}} - {\WF{E;\Def{\Delta}{c}{t}{T}}{\Delta}}} - - -\section[Inductive Definitions]{Inductive Definitions\label{Cic-inductive-definitions}} - -A (possibly mutual) inductive definition is specified by giving the -names and the type of the inductive sets or families to be -defined and the names and types of the constructors of the inductive -predicates. An inductive declaration in the environment can -consequently be represented with two contexts (one for inductive -definitions, one for constructors). - -Stating the rules for inductive definitions in their general form -needs quite tedious definitions. We shall try to give a concrete -understanding of the rules by precising them on running examples. We -take as examples the type of natural numbers, the type of -parameterized lists over a type $A$, the relation which states that -a list has some given length and the mutual inductive definition of trees and -forests. - -\subsection{Representing an inductive definition} -\subsubsection{Inductive definitions without parameters} -As for constants, inductive definitions can be defined in a non-empty -context. \\ -We write \NInd{\Gamma}{\Gamma_I}{\Gamma_C} an inductive -definition valid in a context $\Gamma$, a -context of definitions $\Gamma_I$ and a context of constructors -$\Gamma_C$. -\paragraph{Examples.} -The inductive declaration for the type of natural numbers will be: -\[\NInd{}{\nat:\Set}{\nO:\nat,\nS:\nat\ra\nat}\] -In a context with a variable $A:\Set$, the lists of elements in $A$ are -represented by: -\[\NInd{A:\Set}{\List:\Set}{\Nil:\List,\cons : A \ra \List \ra - \List}\] - Assuming - $\Gamma_I$ is $[I_1:A_1;\ldots;I_k:A_k]$, and $\Gamma_C$ is - $[c_1:C_1;\ldots;c_n:C_n]$, the general typing rules are, - for $1\leq j\leq k$ and $1\leq i\leq n$: - -\bigskip -\inference{\frac{\NInd{\Gamma}{\Gamma_I}{\Gamma_C} \in E}{(I_j:A_j) \in E}} - -\inference{\frac{\NInd{\Gamma}{\Gamma_I}{\Gamma_C} \in E}{(c_i:C_i) \in E}} - -\subsubsection{Inductive definitions with parameters} - -We have to slightly complicate the representation above in order to handle -the delicate problem of parameters. -Let us explain that on the example of \List. With the above definition, -the type \List\ can only be used in an environment where we -have a variable $A:\Set$. Generally one want to consider lists of -elements in different types. For constants this is easily done by abstracting -the value over the parameter. In the case of inductive definitions we -have to handle the abstraction over several objects. - -One possible way to do that would be to define the type \List\ -inductively as being an inductive family of type $\Set\ra\Set$: -\[\NInd{}{\List:\Set\ra\Set}{\Nil:(\forall A:\Set,\List~A), - \cons : (\forall A:\Set, A \ra \List~A \ra \List~A)}\] -There are drawbacks to this point of view. The -information which says that for any $A$, $(\List~A)$ is an inductively defined -\Set\ has been lost. -So we introduce two important definitions. - -\paragraph{Inductive parameters, real arguments.} -An inductive definition $\NInd{\Gamma}{\Gamma_I}{\Gamma_C}$ admits -$r$ inductive parameters if each type of constructors $(c:C)$ in -$\Gamma_C$ is such that -\[C\equiv \forall -p_1:P_1,\ldots,\forall p_r:P_r,\forall a_1:A_1, \ldots \forall a_n:A_n, -(I~p_1~\ldots p_r~t_1\ldots t_q)\] -with $I$ one of the inductive definitions in $\Gamma_I$. -We say that $q$ is the number of real arguments of the constructor -$c$. -\paragraph{Context of parameters.} -If an inductive definition $\NInd{\Gamma}{\Gamma_I}{\Gamma_C}$ admits -$r$ inductive parameters, then there exists a context $\Gamma_P$ of -size $r$, such that $\Gamma_P=[p_1:P_1;\ldots;p_r:P_r]$ and -if $(t:A) \in \Gamma_I,\Gamma_C$ then $A$ can be written as -$\forall p_1:P_1,\ldots \forall p_r:P_r,A'$. -We call $\Gamma_P$ the context of parameters of the inductive -definition and use the notation $\forall \Gamma_P,A'$ for the term $A$. -\paragraph{Remark.} -If we have a term $t$ in an instance of an -inductive definition $I$ which starts with a constructor $c$, then the -$r$ first arguments of $c$ (the parameters) can be deduced from the -type $T$ of $t$: these are exactly the $r$ first arguments of $I$ in -the head normal form of $T$. -\paragraph{Examples.} -The \List{} definition has $1$ parameter: -\[\NInd{}{\List:\Set\ra\Set}{\Nil:(\forall A:\Set, \List~A), - \cons : (\forall A:\Set, A \ra \List~A \ra \List~A)}\] -This is also the case for this more complex definition where there is -a recursive argument on a different instance of \List: -\[\NInd{}{\List:\Set\ra\Set}{\Nil:(\forall A:\Set, \List~A), - \cons : (\forall A:\Set, A \ra \List~(A \ra A) \ra \List~A)}\] -But the following definition has $0$ parameters: -\[\NInd{}{\List:\Set\ra\Set}{\Nil:(\forall A:\Set, \List~A), - \cons : (\forall A:\Set, A \ra \List~A \ra \List~(A*A))}\] - -%\footnote{ -%The interested reader may compare the above definition with the two -%following ones which have very different logical meaning:\\ -%$\NInd{}{\List:\Set}{\Nil:\List,\cons : (A:\Set)A -% \ra \List \ra \List}$ \\ -%$\NInd{}{\List:\Set\ra\Set}{\Nil:(A:\Set)(\List~A),\cons : (A:\Set)A -% \ra (\List~A\ra A) \ra (\List~A)}$.} -\paragraph{Concrete syntax.} -In the Coq system, the context of parameters is given explicitly -after the name of the inductive definitions and is shared between the -arities and the type of constructors. -% The vernacular declaration of polymorphic trees and forests will be:\\ -% \begin{coq_example*} -% Inductive Tree (A:Set) : Set := -% Node : A -> Forest A -> Tree A -% with Forest (A : Set) : Set := -% Empty : Forest A -% | Cons : Tree A -> Forest A -> Forest A -% \end{coq_example*} -% will correspond in our formalism to: -% \[\NInd{}{{\tt Tree}:\Set\ra\Set;{\tt Forest}:\Set\ra \Set} -% {{\tt Node} : \forall A:\Set, A \ra {\tt Forest}~A \ra {\tt Tree}~A, -% {\tt Empty} : \forall A:\Set, {\tt Forest}~A, -% {\tt Cons} : \forall A:\Set, {\tt Tree}~A \ra {\tt Forest}~A \ra -% {\tt Forest}~A}\] -We keep track in the syntax of the number of -parameters. - -Formally the representation of an inductive declaration -will be -\Ind{\Gamma}{p}{\Gamma_I}{\Gamma_C} for an inductive -definition valid in a context $\Gamma$ with $p$ parameters, a -context of definitions $\Gamma_I$ and a context of constructors -$\Gamma_C$. - -The definition \Ind{\Gamma}{p}{\Gamma_I}{\Gamma_C} will be -well-formed exactly when \NInd{\Gamma}{\Gamma_I}{\Gamma_C} is and -when $p$ is (less or equal than) the number of parameters in -\NInd{\Gamma}{\Gamma_I}{\Gamma_C}. + \newcommand\ind[3]{$\mathsf{Ind}~[#1]\left(\hskip-.4em + \begin{array}{r @{\mathrm{~:=~}} l} + #2 & #3 \\ + \end{array} + \hskip-.4em + \right)$} + \def\colon{@{\hskip.5em:\hskip.5em}} -\paragraph{Examples} The declaration for parameterized lists is: -\[\Ind{}{1}{\List:\Set\ra\Set}{\Nil:(\forall A:\Set,\List~A),\cons : - (\forall A:\Set, A \ra \List~A \ra \List~A)}\] + \vskip.5em -The declaration for the length of lists is: -\[\Ind{}{1}{\Length:\forall A:\Set, (\List~A)\ra \nat\ra\Prop} - {\LNil:\forall A:\Set, \Length~A~(\Nil~A)~\nO,\\ - \LCons :\forall A:\Set,\forall a:A, \forall l:(\List~A),\forall n:\nat, (\Length~A~l~n)\ra (\Length~A~(\cons~A~a~l)~(\nS~n))}\] +\ind{1}{\List:\Set\ra\Set}{\left[\begin{array}{r \colon l} + \Nil & \forall A:\Set,\List~A \\ + \cons & \forall A:\Set, A \ra \List~A \ra \List~A + \end{array}\right]} + \vskip.5em -The declaration for a mutual inductive definition of forests and trees is: -\[\NInd{}{\tree:\Set,\forest:\Set} - {\\~~\node:\forest \ra \tree, - \emptyf:\forest,\consf:\tree \ra \forest \ra \forest\-}\] - -These representations are the ones obtained as the result of the \Coq\ -declaration: +which corresponds to the result of the \Coq\ declaration: \begin{coq_example*} -Inductive nat : Set := - | O : nat - | S : nat -> nat. Inductive list (A:Set) : Set := | nil : list A | cons : A -> list A -> list A. \end{coq_example*} + +The declaration for a mutual inductive definition of forests and trees is: + \vskip.5em +\ind{}{\left[\begin{array}{r \colon l}\tree&\Set\\\forest&\Set\end{array}\right]} + {\left[\begin{array}{r \colon l} + \node & \forest \ra \tree\\ + \emptyf & \forest\\ + \consf & \tree \ra \forest \ra \forest\\ + \end{array}\right]} + \vskip.5em + +which corresponds to the result of the \Coq\ +declaration: \begin{coq_example*} -Inductive Length (A:Set) : list A -> nat -> Prop := - | Lnil : Length A (nil A) O - | Lcons : - forall (a:A) (l:list A) (n:nat), - Length A l n -> Length A (cons A a l) (S n). Inductive tree : Set := node : forest -> tree with forest : Set := | emptyf : forest | consf : tree -> forest -> forest. \end{coq_example*} -% The inductive declaration in \Coq\ is slightly different from the one -% we described theoretically. The difference is that in the type of -% constructors the inductive definition is explicitly applied to the -% parameters variables. -The \Coq\ type-checker verifies that all -parameters are applied in the correct manner in the conclusion of the -type of each constructors: - -In particular, the following definition will not be accepted because -there is an occurrence of \List\ which is not applied to the parameter -variable in the conclusion of the type of {\tt cons'}: -\begin{coq_eval} -Set Printing Depth 50. -\end{coq_eval} -% (********** The following is not correct and should produce **********) -% (********* Error: The 1st argument of list' must be A in ... *********) -\begin{coq_example} -Fail Inductive list' (A:Set) : Set := - | nil' : list' A - | cons' : A -> list' A -> list' (A*A). -\end{coq_example} -Since \Coq{} version 8.1, there is no restriction about parameters in -the types of arguments of constructors. The following definition is -valid: -\begin{coq_example} -Inductive list' (A:Set) : Set := - | nil' : list' A - | cons' : A -> list' (A->A) -> list' A. -\end{coq_example} +The declaration for a mutual inductive definition of even and odd is: + \newcommand\GammaI{\left[\begin{array}{r \colon l} + \even & \nat\ra\Prop \\ + \odd & \nat\ra\Prop + \end{array} + \right]} + \newcommand\GammaC{\left[\begin{array}{r \colon l} + \evenO & \even~\nO \\ + \evenS & \forall n : \nat, \odd~n \ra \even~(\nS~n)\\ + \oddS & \forall n : \nat, \even~n \ra \odd~(\nS~n) + \end{array} + \right]} + \vskip.5em + \ind{1}{\GammaI}{\GammaC} + \vskip.5em +which corresponds to the result of the \Coq\ +declaration: +\begin{coq_example*} +Inductive even : nat -> Prop := + | even_O : even 0 + | even_S : forall n, odd n -> even (S n) +with odd : nat -> Prop := + | odd_S : forall n, even n -> odd (S n). +\end{coq_example*} \subsection{Types of inductive objects} -We have to give the type of constants in an environment $E$ which +We have to give the type of constants in a global environment $E$ which contains an inductive declaration. \begin{description} -\item[Ind-Const] Assuming - $\Gamma_I$ is $[I_1:A_1;\ldots;I_k:A_k]$, and $\Gamma_C$ is - $[c_1:C_1;\ldots;c_n:C_n]$, - -\inference{\frac{\Ind{\Gamma}{p}{\Gamma_I}{\Gamma_C} \in E - ~~j=1\ldots k}{(I_j:A_j) \in E}} - -\inference{\frac{\Ind{\Gamma}{p}{\Gamma_I}{\Gamma_C} \in E - ~~~~i=1.. n} - {(c_i:C_i) \in E}} +\item[Ind] \index{Typing rules!Ind} + \inference{\frac{\WFE{\Gamma}\hskip2em\Ind{}{p}{\Gamma_I}{\Gamma_C} \in E\hskip2em(a:A)\in\Gamma_I}{\WTEG{a}{A}}} +\item[Constr] \index{Typing rules!Constr} + \inference{\frac{\WFE{\Gamma}\hskip2em\Ind{}{p}{\Gamma_I}{\Gamma_C} \in E\hskip2em(c:C)\in\Gamma_C}{\WTEG{c}{C}}} \end{description} +\begin{latexonly}% \paragraph{Example.} -We have $(\List:\Set \ra \Set), (\cons:\forall~A:\Set,A\ra(\List~A)\ra -(\List~A))$, \\ -$(\Length:\forall~A:\Set, (\List~A)\ra\nat\ra\Prop)$, $\tree:\Set$ and $\forest:\Set$. - -From now on, we write $\ListA$ instead of $(\List~A)$ and $\LengthA$ -for $(\Length~A)$. +Provided that our environment $E$ contains inductive definitions we showed before, +these two inference rules above enable us to conclude that: +\vskip.5em +\newcommand\prefix{E[\Gamma]\vdash\hskip.25em} +$\begin{array}{@{} l} + \prefix\even : \nat\ra\Prop\\ + \prefix\odd : \nat\ra\Prop\\ + \prefix\evenO : \even~\nO\\ + \prefix\evenS : \forall~n:\nat, \odd~n \ra \even~(\nS~n)\\ + \prefix\oddS : \forall~n:\nat, \even~n \ra \odd~(\nS~n) + \end{array}$ +\end{latexonly}% %\paragraph{Parameters.} %%The parameters introduce a distortion between the inside specification @@ -793,30 +638,48 @@ for $(\Length~A)$. %%typing rules where the inductive objects are seen as objects %%abstracted with respect to the parameters. -%In the definition of \List\ or \Length\, $A$ is a parameter because -%what is effectively inductively defined is $\ListA$ or $\LengthA$ for +%In the definition of \List\ or \haslength\, $A$ is a parameter because +%what is effectively inductively defined is $\ListA$ or $\haslengthA$ for %a given $A$ which is constant in the type of constructors. But when -%we define $(\LengthA~l~n)$, $l$ and $n$ are not parameters because the +%we define $(\haslengthA~l~n)$, $l$ and $n$ are not parameters because the %constructors manipulate different instances of this family. \subsection{Well-formed inductive definitions} We cannot accept any inductive declaration because some of them lead -to inconsistent systems. We restrict ourselves to definitions which +to inconsistent systems. +We restrict ourselves to definitions which satisfy a syntactic criterion of positivity. Before giving the formal rules, we need a few definitions: -\paragraph[Definitions]{Definitions\index{Positivity}\label{Positivity}} - -A type $T$ is an {\em arity of sort $s$}\index{Arity} if it converts +\paragraph[Definition]{Definition\index{Arity}\label{Arity}} +A type $T$ is an {\em arity of sort $s$} if it converts to the sort $s$ or to a product $\forall~x:T,U$ with $U$ an arity -of sort $s$. (For instance $A\ra \Set$ or $\forall~A:\Prop,A\ra -\Prop$ are arities of sort respectively \Set\ and \Prop). A {\em type - of constructor of $I$}\index{Type of constructor} is either a term -$(I~t_1\ldots ~t_n)$ or $\fa x:T,C$ with $C$ recursively -a {\em type of constructor of $I$}. +of sort $s$. + +\paragraph[Examples]{Examples} +$A\ra \Set$ is an arity of sort $\Set$. +$\forall~A:\Prop,A\ra \Prop$ is an arity of sort \Prop. -\smallskip +\paragraph[Definition]{Definition} +A type $T$ is an {\em arity} if there is a $s\in\Sort$ +such that $T$ is an arity of sort $s$. +\paragraph[Examples]{Examples} +$A\ra \Set$ and $\forall~A:\Prop,A\ra \Prop$ are arities. + +\paragraph[Definition]{Definition\index{type of constructor}} +We say that $T$ is a {\em type of constructor of $I$\index{type of constructor}} +in one of the following two cases: +\begin{itemize} + \item $T$ is $(I~t_1\ldots ~t_n)$ + \item $T$ is $\forall x:U,T^\prime$ where $T^\prime$ is also a type of constructor of $I$ +\end{itemize} + +\paragraph[Examples]{Examples} +$\nat$ and $\nat\ra\nat$ are types of constructors of $\nat$.\\ +$\forall A:\Type,\List~A$ and $\forall A:\Type,A\ra\List~A\ra\List~A$ are constructors of $\List$. + +\paragraph[Definition]{Definition\index{Positivity}\label{Positivity}} The type of constructor $T$ will be said to {\em satisfy the positivity condition} for a constant $X$ in the following cases: @@ -826,10 +689,10 @@ any $t_i$ \item $T=\forall~x:U,V$ and $X$ occurs only strictly positively in $U$ and the type $V$ satisfies the positivity condition for $X$ \end{itemize} - +% The constant $X$ {\em occurs strictly positively} in $T$ in the following cases: - +% \begin{itemize} \item $X$ does not occur in $T$ \item $T$ converts to $(X~t_1 \ldots ~t_n)$ and $X$ does not occur in @@ -850,7 +713,7 @@ following cases: %positively in $T[x:U]u$ if $X$ does not occur in $U$ but occurs %strictly positively in $u$ \end{itemize} - +% The type of constructor $T$ of $I$ {\em satisfies the nested positivity condition} for a constant $X$ in the following cases: @@ -863,40 +726,73 @@ any $u_i$ the type $V$ satisfies the nested positivity condition for $X$ \end{itemize} -\paragraph{Example} - -$X$ occurs strictly positively in $A\ra X$ or $X*A$ or $({\tt list}~ -X)$ but not in $X \ra A$ or $(X \ra A)\ra A$ nor $({\tt neg}~X)$ -assuming the notion of product and lists were already defined and {\tt - neg} is an inductive definition with declaration \Ind{}{A:\Set}{{\tt - neg}:\Set}{{\tt neg}:(A\ra{\tt False}) \ra {\tt neg}}. Assuming -$X$ has arity ${\tt nat \ra Prop}$ and {\tt ex} is the inductively -defined existential quantifier, the occurrence of $X$ in ${\tt (ex~ - nat~ \lb n:nat\mto (X~ n))}$ is also strictly positive. +%% \begin{latexonly}% + \newcommand\vv{\textSFxi} % │ + \newcommand\hh{\textSFx} % ─ + \newcommand\vh{\textSFviii} % ├ + \newcommand\hv{\textSFii} % └ + \newlength\framecharacterwidth + \settowidth\framecharacterwidth{\hh} + \newcommand\ws{\hbox{}\hskip\the\framecharacterwidth} + \newcommand\ruleref[1]{\hskip.25em\dots\hskip.2em{\em (bullet #1)}} +%% \def\captionstrut{\vbox to 1.5em{}} + +%% \begin{figure}[H] +For instance, if one considers the type + +\begin{verbatim} +Inductive tree (A:Type) : Type := + | leaf : list A + | node : A -> (nat -> tree A) -> tree A +\end{verbatim} + +Then every instantiated constructor of $\ListA$ satisfies the nested positivity condition for $\List$ + +\noindent + \ws\ws\ws\ws\vv\\ + \ws\ws\ws\ws\vh\hh\ws concerning type $\ListA$ of constructor $\Nil$:\\ + \ws\ws\ws\ws\vv\ws\ws\ws\ws Type $\ListA$ of constructor $\Nil$ satisfies the positivity condition for $\List$\\ + \ws\ws\ws\ws\vv\ws\ws\ws\ws because $\List$ does not appear in any (real) arguments of the type of that constructor\\ + \ws\ws\ws\ws\vv\ws\ws\ws\ws (primarily because $\List$ does not have any (real) arguments)\ruleref1\\ + \ws\ws\ws\ws\vv\\ + \ws\ws\ws\ws\hv\hh\ws concerning type $\forall~A\ra\ListA\ra\ListA$ of constructor $\cons$:\\ + \ws\ws\ws\ws\ws\ws\ws\ws\ws Type $\forall~A:\Type,A\ra\ListA\ra\ListA$ of constructor $\cons$\\ + \ws\ws\ws\ws\ws\ws\ws\ws\ws satisfies the positivity condition for $\List$ because:\\ + \ws\ws\ws\ws\ws\ws\ws\ws\ws\vv\\ + \ws\ws\ws\ws\ws\ws\ws\ws\ws\vh\hh\ws $\List$ occurs only strictly positively in $\Type$\ruleref3\\ + \ws\ws\ws\ws\ws\ws\ws\ws\ws\vv\\ + \ws\ws\ws\ws\ws\ws\ws\ws\ws\vh\hh\ws $\List$ occurs only strictly positively in $A$\ruleref3\\ + \ws\ws\ws\ws\ws\ws\ws\ws\ws\vv\\ + \ws\ws\ws\ws\ws\ws\ws\ws\ws\vh\hh\ws $\List$ occurs only strictly positively in $\ListA$\ruleref4\\ + \ws\ws\ws\ws\ws\ws\ws\ws\ws\vv\\ + \ws\ws\ws\ws\ws\ws\ws\ws\ws\hv\hh\ws $\List$ satisfies the positivity condition for $\ListA$\ruleref1 +%% \caption{\captionstrut A proof that $X$ occurs strictly positively in $\ListA$} +%% \end{figure} +%% \end{latexonly}% \paragraph{Correctness rules.} We shall now describe the rules allowing the introduction of a new inductive definition. \begin{description} -\item[W-Ind] Let $E$ be an environment and - $\Gamma,\Gamma_P,\Gamma_I,\Gamma_C$ are contexts such that +\item[W-Ind] Let $E$ be a global environment and + $\Gamma_P,\Gamma_I,\Gamma_C$ are contexts such that $\Gamma_I$ is $[I_1:\forall \Gamma_P,A_1;\ldots;I_k:\forall \Gamma_P,A_k]$ and $\Gamma_C$ is $[c_1:\forall \Gamma_P,C_1;\ldots;c_n:\forall \Gamma_P,C_n]$. \inference{ \frac{ - (\WTE{\Gamma;\Gamma_P}{A_j}{s'_j})_{j=1\ldots k} - ~~ (\WTE{\Gamma;\Gamma_I;\Gamma_P}{C_i}{s_{q_i}})_{i=1\ldots n} + (\WTE{\Gamma_P}{A_j}{s'_j})_{j=1\ldots k} + ~~ (\WTE{\Gamma_I;\Gamma_P}{C_i}{s_{q_i}})_{i=1\ldots n} } - {\WF{E;\Ind{\Gamma}{p}{\Gamma_I}{\Gamma_C}}{\Gamma}}} + {\WF{E;\Ind{}{p}{\Gamma_I}{\Gamma_C}}{\Gamma}}} provided that the following side conditions hold: \begin{itemize} \item $k>0$ and all of $I_j$ and $c_i$ are distinct names for $j=1\ldots k$ and $i=1\ldots n$, -\item $p$ is the number of parameters of \NInd{\Gamma}{\Gamma_I}{\Gamma_C} +\item $p$ is the number of parameters of \NInd{}{\Gamma_I}{\Gamma_C} and $\Gamma_P$ is the context of parameters, \item for $j=1\ldots k$ we have that $A_j$ is an arity of sort $s_j$ and $I_j - \notin \Gamma \cup E$, + \notin E$, \item for $i=1\ldots n$ we have that $C_i$ is a type of constructor of $I_{q_i}$ which satisfies the positivity condition for $I_1 \ldots I_k$ and $c_i \notin \Gamma \cup E$. @@ -905,7 +801,7 @@ provided that the following side conditions hold: One can remark that there is a constraint between the sort of the arity of the inductive type and the sort of the type of its constructors which will always be satisfied for the impredicative sort -(\Prop) but may fail to define inductive definition +{\Prop} but may fail to define inductive definition on sort \Set{} and generate constraints between universes for inductive definitions in the {\Type} hierarchy. @@ -938,19 +834,19 @@ Inductive exType (P:Type->Prop) : Type %is recursive or not. We shall write the type $(x:_R T)C$ if it is %a recursive argument and $(x:_P T)C$ if the argument is not recursive. -\paragraph[Sort-polymorphism of inductive families.]{Sort-polymorphism of inductive families.\index{Sort-polymorphism of inductive families}} +\paragraph[Sort-polymorphism of inductive types.]{Sort-polymorphism of inductive types.\index{Sort-polymorphism of inductive types}} +\label{Sort-polymorphism-inductive} -From {\Coq} version 8.1, inductive families declared in {\Type} are +Inductive types declared in {\Type} are polymorphic over their arguments in {\Type}. - -If $A$ is an arity and $s$ a sort, we write $A_{/s}$ for the arity +If $A$ is an arity of some sort and $s$ is a sort, we write $A_{/s}$ for the arity obtained from $A$ by replacing its sort with $s$. Especially, if $A$ -is well-typed in some environment and context, then $A_{/s}$ is typable +is well-typed in some global environment and local context, then $A_{/s}$ is typable by typability of all products in the Calculus of Inductive Constructions. The following typing rule is added to the theory. \begin{description} -\item[Ind-Family] Let $\Ind{\Gamma}{p}{\Gamma_I}{\Gamma_C}$ be an +\item[Ind-Family] Let $\Ind{}{p}{\Gamma_I}{\Gamma_C}$ be an inductive definition. Let $\Gamma_P = [p_1:P_1;\ldots;p_{p}:P_{p}]$ be its context of parameters, $\Gamma_I = [I_1:\forall \Gamma_P,A_1;\ldots;I_k:\forall \Gamma_P,A_k]$ its context of @@ -970,13 +866,13 @@ The following typing rule is added to the theory. \inference{\frac {\left\{\begin{array}{l} -\Ind{\Gamma}{p}{\Gamma_I}{\Gamma_C} \in E\\ -(E[\Gamma] \vdash q_l : P'_l)_{l=1\ldots r}\\ -(\WTEGLECONV{P'_l}{\subst{P_l}{p_u}{q_u}_{u=1\ldots l-1}})_{l=1\ldots r}\\ +\Ind{}{p}{\Gamma_I}{\Gamma_C} \in E\\ +(E[] \vdash q_l : P'_l)_{l=1\ldots r}\\ +(\WTELECONV{}{P'_l}{\subst{P_l}{p_u}{q_u}_{u=1\ldots l-1}})_{l=1\ldots r}\\ 1 \leq j \leq k \end{array} \right.} -{E[\Gamma] \vdash (I_j\,q_1\,\ldots\,q_r:\forall [p_{r+1}:P_{r+1};\ldots;p_{p}:P_{p}], (A_j)_{/s_j})} +{E[] \vdash I_j\,q_1\,\ldots\,q_r:\forall [p_{r+1}:P_{r+1};\ldots;p_{p}:P_{p}], (A_j)_{/s_j}} } provided that the following side conditions hold: @@ -984,26 +880,26 @@ provided that the following side conditions hold: \begin{itemize} \item $\Gamma_{P'}$ is the context obtained from $\Gamma_P$ by replacing each $P_l$ that is an arity with $P'_l$ for $1\leq l \leq r$ (notice that -$P_l$ arity implies $P'_l$ arity since $\WTEGLECONV{P'_l}{ \subst{P_l}{p_u}{q_u}_{u=1\ldots l-1}}$); +$P_l$ arity implies $P'_l$ arity since $\WTELECONV{}{P'_l}{ \subst{P_l}{p_u}{q_u}_{u=1\ldots l-1}}$); \item there are sorts $s_i$, for $1 \leq i \leq k$ such that, for $\Gamma_{I'} = [I_1:\forall \Gamma_{P'},(A_1)_{/s_1};\ldots;I_k:\forall \Gamma_{P'},(A_k)_{/s_k}]$ -we have $(\WTE{\Gamma;\Gamma_{I'};\Gamma_{P'}}{C_i}{s_{q_i}})_{i=1\ldots n}$; -\item the sorts are such that all eliminations, to {\Prop}, {\Set} and - $\Type(j)$, are allowed (see section~\ref{elimdep}). +we have $(\WTE{\Gamma_{I'};\Gamma_{P'}}{C_i}{s_{q_i}})_{i=1\ldots n}$; +\item the sorts $s_i$ are such that all eliminations, to {\Prop}, {\Set} and + $\Type(j)$, are allowed (see Section~\ref{allowedeleminationofsorts}). \end{itemize} \end{description} - +% Notice that if $I_j\,q_1\,\ldots\,q_r$ is typable using the rules {\bf Ind-Const} and {\bf App}, then it is typable using the rule {\bf Ind-Family}. Conversely, the extended theory is not stronger than the theory without {\bf Ind-Family}. We get an equiconsistency result by -mapping each $\Ind{\Gamma}{p}{\Gamma_I}{\Gamma_C}$ occurring into a +mapping each $\Ind{}{p}{\Gamma_I}{\Gamma_C}$ occurring into a given derivation into as many different inductive types and constructors as the number of different (partial) replacements of sorts, needed for this derivation, in the parameters that are arities (this is possible -because $\Ind{\Gamma}{p}{\Gamma_I}{\Gamma_C}$ well-formed implies -that $\Ind{\Gamma}{p}{\Gamma_{I'}}{\Gamma_{C'}}$ is well-formed and +because $\Ind{}{p}{\Gamma_I}{\Gamma_C}$ well-formed implies +that $\Ind{}{p}{\Gamma_{I'}}{\Gamma_{C'}}$ is well-formed and has the same allowed eliminations, where $\Gamma_{I'}$ is defined as above and $\Gamma_{C'} = [c_1:\forall \Gamma_{P'},C_1;\ldots;c_n:\forall \Gamma_{P'},C_n]$). That is, @@ -1013,7 +909,7 @@ sorts among the types of parameters, and to each signature is associated a new inductive definition with fresh names. Conversion is preserved as any (partial) instance $I_j\,q_1\,\ldots\,q_r$ or $C_i\,q_1\,\ldots\,q_r$ is mapped to the names chosen in the specific -instance of $\Ind{\Gamma}{p}{\Gamma_I}{\Gamma_C}$. +instance of $\Ind{}{p}{\Gamma_I}{\Gamma_C}$. \newcommand{\Single}{\mbox{\textsf{Set}}} @@ -1033,23 +929,21 @@ predicative {\Set}. More precisely, an empty or small singleton inductive definition (i.e. an inductive definition of which all inductive types are singleton -- see paragraph~\ref{singleton}) is set in -{\Prop}, a small non-singleton inductive family is set in {\Set} (even +{\Prop}, a small non-singleton inductive type is set in {\Set} (even in case {\Set} is impredicative -- see Section~\ref{impredicativity}), and otherwise in the {\Type} hierarchy. -% TODO: clarify the case of a partial application ?? Note that the side-condition about allowed elimination sorts in the rule~{\bf Ind-Family} is just to avoid to recompute the allowed elimination sorts at each instance of a pattern-matching (see -section~\ref{elimdep}). - +section~\ref{elimdep}). As an example, let us consider the following definition: \begin{coq_example*} Inductive option (A:Type) : Type := | None : option A | Some : A -> option A. \end{coq_example*} - +% As the definition is set in the {\Type} hierarchy, it is used polymorphically over its parameters whose types are arities of a sort in the {\Type} hierarchy. Here, the parameter $A$ has this property, @@ -1057,20 +951,20 @@ hence, if \texttt{option} is applied to a type in {\Set}, the result is in {\Set}. Note that if \texttt{option} is applied to a type in {\Prop}, then, the result is not set in \texttt{Prop} but in \texttt{Set} still. This is because \texttt{option} is not a singleton type (see -section~\ref{singleton}) and it would loose the elimination to {\Set} and +section~\ref{singleton}) and it would lose the elimination to {\Set} and {\Type} if set in {\Prop}. \begin{coq_example} Check (fun A:Set => option A). Check (fun A:Prop => option A). \end{coq_example} - +% Here is another example. - +% \begin{coq_example*} Inductive prod (A B:Type) : Type := pair : A -> B -> prod A B. \end{coq_example*} - +% As \texttt{prod} is a singleton type, it will be in {\Prop} if applied twice to propositions, in {\Set} if applied twice to at least one type in {\Set} and none in {\Type}, and in {\Type} otherwise. In all cases, @@ -1103,7 +997,7 @@ a strongly normalizing reduction, we cannot accept any sort of recursion (even terminating). So the basic idea is to restrict ourselves to primitive recursive functions and functionals. -For instance, assuming a parameter $A:\Set$ exists in the context, we +For instance, assuming a parameter $A:\Set$ exists in the local context, we want to build a function \length\ of type $\ListA\ra \nat$ which computes the length of the list, so such that $(\length~(\Nil~A)) = \nO$ and $(\length~(\cons~A~a~l)) = (\nS~(\length~l))$. We want these @@ -1121,24 +1015,25 @@ In case the inductive definition is effectively a recursive one, we want to capture the extra property that we have built the smallest fixed point of this recursive equation. This says that we are only manipulating finite objects. This analysis provides induction -principles. - -For instance, in order to prove $\forall l:\ListA,(\LengthA~l~(\length~l))$ +principles. +For instance, in order to prove $\forall l:\ListA,(\haslengthA~l~(\length~l))$ it is enough to prove: - -\noindent $(\LengthA~(\Nil~A)~(\length~(\Nil~A)))$ and - -\smallskip -$\forall a:A, \forall l:\ListA, (\LengthA~l~(\length~l)) \ra -(\LengthA~(\cons~A~a~l)~(\length~(\cons~A~a~l)))$. -\smallskip - -\noindent which given the conversion equalities satisfied by \length\ is the +% +\begin{itemize} + \item $(\haslengthA~(\Nil~A)~(\length~(\Nil~A)))$ + \item $\forall a:A, \forall l:\ListA, (\haslengthA~l~(\length~l)) \ra\\ + \ra (\haslengthA~(\cons~A~a~l)~(\length~(\cons~A~a~l)))$ +\end{itemize} +% +which given the conversion equalities satisfied by \length\ is the same as proving: -$(\LengthA~(\Nil~A)~\nO)$ and $\forall a:A, \forall l:\ListA, -(\LengthA~l~(\length~l)) \ra -(\LengthA~(\cons~A~a~l)~(\nS~(\length~l)))$. - +% +\begin{itemize} + \item $(\haslengthA~(\Nil~A)~\nO)$ + \item $\forall a:A, \forall l:\ListA, (\haslengthA~l~(\length~l)) \ra\\ + \ra (\haslengthA~(\cons~A~a~l)~(\nS~(\length~l)))$ +\end{itemize} +% One conceptually simple way to do that, following the basic scheme proposed by Martin-L\"of in his Intuitionistic Type Theory, is to introduce for each inductive definition an elimination operator. At @@ -1147,7 +1042,7 @@ at the computational level it implements a generic operator for doing primitive recursion over the structure. But this operator is rather tedious to implement and use. We choose in -this version of Coq to factorize the operator for primitive recursion +this version of {\Coq} to factorize the operator for primitive recursion into two more primitive operations as was first suggested by Th. Coquand in~\cite{Coq92}. One is the definition by pattern-matching. The second one is a definition by guarded fixpoints. @@ -1158,13 +1053,6 @@ The basic idea of this operator is that we have an object $m$ in an inductive type $I$ and we want to prove a property which possibly depends on $m$. For this, it is enough to prove the property for $m = (c_i~u_1\ldots u_{p_i})$ for each constructor of $I$. - - -The basic idea of this operator is that we have an object -$m$ in an inductive type $I$ and we want to prove a property -which possibly depends on $m$. For this, it is enough to prove the -property for $m = (c_i~u_1\ldots u_{p_i})$ for each constructor of $I$. - The \Coq{} term for this proof will be written: \[\kw{match}~m~\kw{with}~ (c_1~x_{11}~...~x_{1p_1}) \Ra f_1 ~|~\ldots~|~ (c_n~x_{n1}~...~x_{np_n}) \Ra f_n~ \kw{end}\] @@ -1172,7 +1060,7 @@ In this expression, if $m$ eventually happens to evaluate to $(c_i~u_1\ldots u_{p_i})$ then the expression will behave as specified in its $i$-th branch and it will reduce to $f_i$ where the $x_{i1}$\ldots $x_{ip_i}$ are replaced -by the $u_1\ldots u_p$ according to the $\iota$-reduction. +by the $u_1\ldots u_{p_i}$ according to the $\iota$-reduction. Actually, for type-checking a \kw{match\ldots with\ldots end} expression we also need to know the predicate $P$ to be proved by case @@ -1183,7 +1071,7 @@ one corresponds to object $m$. \Coq{} can sometimes infer this predicate but sometimes not. The concrete syntax for describing this predicate uses the \kw{as\ldots in\ldots return} construction. For instance, let us assume that $I$ is an unary predicate with one -parameter. The predicate is made explicit using the syntax: +parameter and one argument. The predicate is made explicit using the syntax: \[\kw{match}~m~\kw{as}~ x~ \kw{in}~ I~\verb!_!~a~ \kw{return}~ P ~\kw{with}~ (c_1~x_{11}~...~x_{1p_1}) \Ra f_1 ~|~\ldots~|~ (c_n~x_{n1}~...~x_{np_n}) \Ra f_n \kw{end}\] @@ -1194,13 +1082,16 @@ The \kw{in} part can be omitted if the result type does not depend on the arguments of $I$. Note that the arguments of $I$ corresponding to parameters \emph{must} be \verb!_!, because the result type is not generalized to -all possible values of the parameters. The other arguments of $I$ -(sometimes called indices in the litterature) have to be variables -($a$ above) and these variables can occur in $P$ and bound in it. +all possible values of the parameters. +The other arguments of $I$ +(sometimes called indices in the literature) +% NOTE: e.g. http://www.qatar.cmu.edu/~sacchini/papers/types08.pdf +have to be variables +($a$ above) and these variables can occur in $P$. The expression after \kw{in} must be seen as an \emph{inductive type pattern}. Notice that expansion of implicit arguments and notations apply to this pattern. - +% For the purpose of presenting the inference rules, we use a more compact notation: \[ \Case{(\lb a x \mto P)}{m}{ \lb x_{11}~...~x_{1p_1} \mto f_1 ~|~\ldots~|~ @@ -1234,19 +1125,15 @@ compact notation: % \mbox{\tt =>}~ \false} \paragraph[Allowed elimination sorts.]{Allowed elimination sorts.\index{Elimination sorts}} +\label{allowedeleminationofsorts} An important question for building the typing rule for \kw{match} is -what can be the type of $P$ with respect to the type of the inductive -definitions. - -We define now a relation \compat{I:A}{B} between an inductive -definition $I$ of type $A$ and an arity $B$. This relation states that -an object in the inductive definition $I$ can be eliminated for -proving a property $P$ of type $B$. - -The case of inductive definitions in sorts \Set\ or \Type{} is simple. -There is no restriction on the sort of the predicate to be -eliminated. +what can be the type of $\lb a x \mto P$ with respect to the type of $m$. If +$m:I$ and +$I:A$ and +$\lb a x \mto P : B$ +then by \compat{I:A}{B} we mean that one can use $\lb a x \mto P$ with $m$ in the above +match-construct. \paragraph{Notations.} The \compat{I:A}{B} is defined as the smallest relation satisfying the @@ -1254,14 +1141,17 @@ following rules: We write \compat{I}{B} for \compat{I:A}{B} where $A$ is the type of $I$. +The case of inductive definitions in sorts \Set\ or \Type{} is simple. +There is no restriction on the sort of the predicate to be +eliminated. +% \begin{description} \item[Prod] \inference{\frac{\compat{(I~x):A'}{B'}} {\compat{I:\forall x:A, A'}{\forall x:A, B'}}} \item[{\Set} \& \Type] \inference{\frac{ - s_1 \in \{\Set,\Type(j)\}, - s_2 \in \Sort}{\compat{I:s_1}{I\ra s_2}}} + s_1 \in \{\Set,\Type(j)\}~~~~~~~~s_2 \in \Sort}{\compat{I:s_1}{I\ra s_2}}} \end{description} - +% The case of Inductive definitions of sort \Prop{} is a bit more complicated, because of our interpretation of this sort. The only harmless allowed elimination, is the one when predicate $P$ is also of @@ -1314,7 +1204,7 @@ a logical property of a computational object. In the same spirit, elimination on $P$ of type $I\ra \Type$ cannot be allowed because it trivially implies the elimination on $P$ of type $I\ra \Set$ by cumulativity. It also implies that there -is two proofs of the same property which are provably different, +are two proofs of the same property which are provably different, contradicting the proof-irrelevance property which is sometimes a useful axiom: \begin{coq_example} @@ -1352,17 +1242,17 @@ eliminations are allowed. definition}~~~s \in \Sort}{\compat{I:\Prop}{I\ra s}} } \end{description} - +% % A {\em singleton definition} has always an informative content, % even if it is a proposition. - +% A {\em singleton definition} has only one constructor and all the arguments of this constructor have type \Prop. In that case, there is a canonical way to interpret the informative extraction on an object in that type, such that the elimination on any sort $s$ is legal. Typical examples are the conjunction of non-informative propositions and the equality. -If there is an hypothesis $h:a=b$ in the context, it can be used for +If there is an hypothesis $h:a=b$ in the local context, it can be used for rewriting not only in logical propositions but also in any type. % In that case, the term \verb!eq_rec! which was defined as an axiom, is % now a term of the calculus. @@ -1375,34 +1265,56 @@ elimination on any sort is allowed. \paragraph{Type of branches.} Let $c$ be a term of type $C$, we assume $C$ is a type of constructor -for an inductive definition $I$. Let $P$ be a term that represents the +for an inductive type $I$. Let $P$ be a term that represents the property to be proved. -We assume $r$ is the number of parameters. +We assume $r$ is the number of parameters and $p$ is the number of arguments. We define a new type \CI{c:C}{P} which represents the type of the branch corresponding to the $c:C$ constructor. \[ \begin{array}{ll} -\CI{c:(I_i~p_1\ldots p_r\ t_1 \ldots t_p)}{P} &\equiv (P~t_1\ldots ~t_p~c) \\[2mm] +\CI{c:(I~p_1\ldots p_r\ t_1 \ldots t_p)}{P} &\equiv (P~t_1\ldots ~t_p~c) \\[2mm] \CI{c:\forall~x:T,C}{P} &\equiv \forall~x:T,\CI{(c~x):C}{P} \end{array} \] We write \CI{c}{P} for \CI{c:C}{P} with $C$ the type of $c$. -\paragraph{Examples.} -For $\ListA$ the type of $P$ will be $\ListA\ra s$ for $s \in \Sort$. \\ -$ \CI{(\cons~A)}{P} \equiv -\forall a:A, \forall l:\ListA,(P~(\cons~A~a~l))$. - -For $\LengthA$, the type of $P$ will be -$\forall l:\ListA,\forall n:\nat, (\LengthA~l~n)\ra \Prop$ and the expression -\CI{(\LCons~A)}{P} is defined as:\\ -$\forall a:A, \forall l:\ListA, \forall n:\nat, \forall -h:(\LengthA~l~n), (P~(\cons~A~a~l)~(\nS~n)~(\LCons~A~a~l~n~l))$.\\ -If $P$ does not depend on its third argument, we find the more natural -expression:\\ -$\forall a:A, \forall l:\ListA, \forall n:\nat, -(\LengthA~l~n)\ra(P~(\cons~A~a~l)~(\nS~n))$. +\paragraph{Example.} +The following term in concrete syntax: +\begin{verbatim} +match t as l return P' with +| nil _ => t1 +| cons _ hd tl => t2 +end +\end{verbatim} +can be represented in abstract syntax as $$\Case{P}{t}{f_1\,|\,f_2}$$ +where +\begin{eqnarray*} + P & = & \lambda~l~.~P^\prime\\ + f_1 & = & t_1\\ + f_2 & = & \lambda~(hd:\nat)~.~\lambda~(tl:\List~\nat)~.~t_2 +\end{eqnarray*} +According to the definition: +\begin{latexonly}\vskip.5em\noindent\end{latexonly}% +\begin{htmlonly} + +\end{htmlonly} +$ \CI{(\Nil~\nat)}{P} \equiv \CI{(\Nil~\nat) : (\List~\nat)}{P} \equiv (P~(\Nil~\nat))$ +\begin{latexonly}\vskip.5em\noindent\end{latexonly}% +\begin{htmlonly} + +\end{htmlonly} +$ \CI{(\cons~\nat)}{P} + \equiv\CI{(\cons~\nat) : (\nat\ra\List~\nat\ra\List~\nat)}{P} \equiv\\ + \equiv\forall n:\nat, \CI{(\cons~\nat~n) : \List~\nat\ra\List~\nat)}{P} \equiv\\ + \equiv\forall n:\nat, \forall l:\List~\nat, \CI{(\cons~\nat~n~l) : \List~\nat)}{P} \equiv\\ +\equiv\forall n:\nat, \forall l:\List~\nat,(P~(\cons~\nat~n~l))$. +\begin{latexonly}\vskip.5em\noindent\end{latexonly}% +\begin{htmlonly} + +\end{htmlonly} +Given some $P$, then \CI{(\Nil~\nat)}{P} represents the expected type of $f_1$, and +\CI{(\cons~\nat)}{P} represents the expected type of $f_2$. \paragraph{Typing rule.} @@ -1428,30 +1340,24 @@ following typing rule (\WTEG{f_i}{\CI{(c_{p_i}~q_1\ldots q_r)}{P}})_{i=1\ldots l}} {\WTEG{\Case{P}{c}{f_1|\ldots |f_l}}{(P\ t_1\ldots t_s\ c)}}}%\\[3mm] -provided $I$ is an inductive type in a declaration -\Ind{\Delta}{r}{\Gamma_I}{\Gamma_C} with +provided $I$ is an inductive type in a definition +\Ind{}{r}{\Gamma_I}{\Gamma_C} with $\Gamma_C = [c_1:C_1;\ldots;c_n:C_n]$ and $c_{p_1}\ldots c_{p_l}$ are the only constructors of $I$. \end{description} \paragraph{Example.} -For \List\ and \Length\ the typing rules for the {\tt match} expression -are (writing just $t:M$ instead of \WTEG{t}{M}, the environment and -context being the same in all the judgments). - -\[\frac{l:\ListA~~P:\ListA\ra s~~~f_1:(P~(\Nil~A))~~ - f_2:\forall a:A, \forall l:\ListA, (P~(\cons~A~a~l))} - {\Case{P}{l}{f_1~|~f_2}:(P~l)}\] - -\[\frac{ - \begin{array}[b]{@{}c@{}} -H:(\LengthA~L~N) \\ P:\forall l:\ListA, \forall n:\nat, (\LengthA~l~n)\ra - \Prop\\ - f_1:(P~(\Nil~A)~\nO~\LNil) \\ - f_2:\forall a:A, \forall l:\ListA, \forall n:\nat, \forall - h:(\LengthA~l~n), (P~(\cons~A~a~n)~(\nS~n)~(\LCons~A~a~l~n~h)) - \end{array}} - {\Case{P}{H}{f_1~|~f_2}:(P~L~N~H)}\] + +Below is a typing rule for the term shown in the previous example: +\inference{ + \frac{% + \WTEG{t}{(\List~\nat)}~~~~% + \WTEG{P}{B}~~~~% + \compat{(\List~\nat)}{B}~~~~% + \WTEG{f_1}{\CI{(\Nil~\nat)}{P}}~~~~% + \WTEG{f_2}{\CI{(\cons~\nat)}{P}}% + } +{\WTEG{\Case{P}{t}{f_1|f_2}}{(P~t)}}} \paragraph[Definition of $\iota$-reduction.]{Definition of $\iota$-reduction.\label{iotared} \index{iota-reduction@$\iota$-reduction}} @@ -1496,17 +1402,17 @@ The typing rule is the expected one for a fixpoint. (\WTE{\Gamma,f_1:A_1,\ldots,f_n:A_n}{t_i}{A_i})_{i=1\ldots n}} {\WTEG{\Fix{f_i}{f_1:A_1:=t_1 \ldots f_n:A_n:=t_n}}{A_i}}} \end{description} - +% Any fixpoint definition cannot be accepted because non-normalizing terms -will lead to proofs of absurdity. - +allow proofs of absurdity. +% The basic scheme of recursion that should be allowed is the one needed for defining primitive recursive functionals. In that case the fixpoint enjoys a special syntactic restriction, namely one of the arguments belongs to an inductive type, the function starts with a case analysis and recursive calls are done on variables coming from patterns and representing subterms. - +% For instance in the case of natural numbers, a proof of the induction principle of type \[\forall P:\nat\ra\Prop, (P~\nO)\ra(\forall n:\nat, (P~n)\ra(P~(\nS~n)))\ra @@ -1519,22 +1425,22 @@ can be represented by the term: p:\nat\mto (g~p~(h~p))}} \end{array} \] - +% Before accepting a fixpoint definition as being correctly typed, we check that the definition is ``guarded''. A precise analysis of this notion can be found in~\cite{Gim94}. - +% The first stage is to precise on which argument the fixpoint will be decreasing. The type of this argument should be an inductive definition. - -For doing this the syntax of fixpoints is extended and becomes +% +For doing this, the syntax of fixpoints is extended and becomes \[\Fix{f_i}{f_1/k_1:A_1:=t_1 \ldots f_n/k_n:A_n:=t_n}\] where $k_i$ are positive integers. +Each $k_i$ represents the index of pararameter of $f_i$, on which $f_i$ is decreasing. Each $A_i$ should be a type (reducible to a term) starting with at least $k_i$ products $\forall y_1:B_1,\ldots \forall y_{k_i}:B_{k_i}, A'_i$ -and $B_{k_i}$ -being an instance of an inductive definition. +and $B_{k_i}$ an is unductive type. Now in the definition $t_i$, if $f_j$ occurs then it should be applied to at least $k_j$ arguments and the $k_j$-th argument should be @@ -1544,23 +1450,22 @@ syntactically recognized as structurally smaller than $y_{k_i}$ The definition of being structurally smaller is a bit technical. One needs first to define the notion of {\em recursive arguments of a constructor}\index{Recursive arguments}. -For an inductive definition \Ind{\Gamma}{r}{\Gamma_I}{\Gamma_C}, -the type of a constructor $c$ has the form +For an inductive definition \Ind{}{r}{\Gamma_I}{\Gamma_C}, +if the type of a constructor $c$ has the form $\forall p_1:P_1,\ldots \forall p_r:P_r, \forall x_1:T_1, \ldots \forall x_r:T_r, (I_j~p_1\ldots -p_r~t_1\ldots t_s)$ the recursive arguments will correspond to $T_i$ in +p_r~t_1\ldots t_s)$, then the recursive arguments will correspond to $T_i$ in which one of the $I_l$ occurs. - The main rules for being structurally smaller are the following:\\ Given a variable $y$ of type an inductive definition in a declaration -\Ind{\Gamma}{r}{\Gamma_I}{\Gamma_C} +\Ind{}{r}{\Gamma_I}{\Gamma_C} where $\Gamma_I$ is $[I_1:A_1;\ldots;I_k:A_k]$, and $\Gamma_C$ is $[c_1:C_1;\ldots;c_n:C_n]$. The terms structurally smaller than $y$ are: \begin{itemize} -\item $(t~u), \lb x:u \mto t$ when $t$ is structurally smaller than $y$ . +\item $(t~u)$ and $\lb x:u \mto t$ when $t$ is structurally smaller than $y$. \item \Case{P}{c}{f_1\ldots f_n} when each $f_i$ is structurally smaller than $y$. \\ If $c$ is $y$ or is structurally smaller than $y$, its type is an inductive @@ -1611,33 +1516,15 @@ a_{k_i}) \triangleright_{\iota} \substs{t_i}{f_k}{\Fix{f_k}{F}}{k=1\ldots n} when $a_{k_i}$ starts with a constructor. This last restriction is needed in order to keep strong normalization and corresponds to the reduction for primitive recursive operators. - -We can illustrate this behavior on examples. -\begin{coq_example} -Goal forall n m:nat, plus (S n) m = S (plus n m). -reflexivity. -Abort. -Goal forall f:forest, sizet (node f) = S (sizef f). -reflexivity. -Abort. -\end{coq_example} -But assuming the definition of a son function from \tree\ to \forest: -\begin{coq_example} -Definition sont (t:tree) : forest - := let (f) := t in f. -\end{coq_example} -The following is not a conversion but can be proved after a case analysis. -% (******************************************************************) -% (** Error: Impossible to unify .... **) -\begin{coq_example} -Goal forall t:tree, sizet t = S (sizef (sont t)). -Fail reflexivity. -destruct t. -reflexivity. -\end{coq_example} -\begin{coq_eval} -Abort. -\end{coq_eval} +% +The following reductions are now possible: +\def\plus{\mathsf{plus}} +\def\tri{\triangleright_\iota} +\begin{eqnarray*} + \plus~(\nS~(\nS~\nO))~(\nS~\nO) & \tri & \nS~(\plus~(\nS~\nO)~(\nS~\nO))\\ + & \tri & \nS~(\nS~(\plus~\nO~(\nS~\nO)))\\ + & \tri & \nS~(\nS~(\nS~\nO))\\ +\end{eqnarray*} % La disparition de Program devrait rendre la construction Match obsolete % \subsubsection{The {\tt Match \ldots with \ldots end} expression} @@ -1677,6 +1564,87 @@ Abort. The principles of mutual induction can be automatically generated using the {\tt Scheme} command described in Section~\ref{Scheme}. +\section{Admissible rules for global environments} + +From the original rules of the type system, one can show the +admissibility of rules which change the local context of definition of +objects in the global environment. We show here the admissible rules +that are used used in the discharge mechanism at the end of a section. + +% This is obsolete: Abstraction over defined constants actually uses a +% let-in since there are let-ins in Coq + +%% \paragraph{Mechanism of substitution.} + +%% One rule which can be proved valid, is to replace a term $c$ by its +%% value in the global environment. As we defined the substitution of a term for +%% a variable in a term, one can define the substitution of a term for a +%% constant. One easily extends this substitution to local contexts and global +%% environments. + +%% \paragraph{Substitution Property:} +%% \inference{\frac{\WF{E;c:=t:T; E'}{\Gamma}} +%% {\WF{E; \subst{E'}{c}{t}}{\subst{\Gamma}{c}{t}}}} + +\paragraph{Abstraction.} + +One can modify a global declaration by generalizing it over a +previously assumed constant $c$. For doing that, we need to modify the +reference to the global declaration in the subsequent global +environment and local context by explicitly applying this constant to +the constant $c'$. + +Below, if $\Gamma$ is a context of the form +$[y_1:A_1;\ldots;y_n:A_n]$, we write $\forall +x:U,\subst{\Gamma}{c}{x}$ to mean +$[y_1:\forall~x:U,\subst{A_1}{c}{x};\ldots;y_n:\forall~x:U,\subst{A_n}{c}{x}]$ +and +$\subst{E}{|\Gamma|}{|\Gamma|c}$. +to mean the parallel substitution +$\subst{\subst{E}{y_1}{(y_1~c)}\ldots}{y_n}{(y_n~c)}$. + +\paragraph{First abstracting property:} + \inference{\frac{\WF{E;c:U;E';c':=t:T;E''}{\Gamma}} + {\WF{E;c:U;E';c':=\lb x:U\mto \subst{t}{c}{x}:\forall~x:U,\subst{T}{c}{x}; + \subst{E''}{c'}{(c'~c)}}{\subst{\Gamma}{c}{(c~c')}}}} + + \inference{\frac{\WF{E;c:U;E';c':T;E''}{\Gamma}} + {\WF{E;c:U;E';c':\forall~x:U,\subst{T}{c}{x}; + \subst{E''}{c'}{(c'~c)}}{\subst{\Gamma}{c}{(c~c')}}}} + + \inference{\frac{\WF{E;c:U;E';\Ind{}{p}{\Gamma_I}{\Gamma_C};E''}{\Gamma}} + {\WFTWOLINES{E;c:U;E';\Ind{}{p+1}{\forall x:U,\subst{\Gamma_I}{c}{x}}{\forall x:U,\subst{\Gamma_C}{c}{x}};\subst{E''}{|\Gamma_I,\Gamma_C|}{|\Gamma_I,\Gamma_C|~c}}{\subst{\Gamma}{|\Gamma_I,\Gamma_C|}{|\Gamma_I,\Gamma_C|~c}}}} +% +One can similarly modify a global declaration by generalizing it over +a previously defined constant~$c'$. Below, if $\Gamma$ is a context +of the form $[y_1:A_1;\ldots;y_n:A_n]$, we write $ +\subst{\Gamma}{c}{u}$ to mean +$[y_1:\subst{A_1}{c}{u};\ldots;y_n:\subst{A_n}{c}{u}]$. + +\paragraph{Second abstracting property:} + \inference{\frac{\WF{E;c:=u:U;E';c':=t:T;E''}{\Gamma}} + {\WF{E;c:=u:U;E';c':=(\letin{x}{u:U}{\subst{t}{c}{x}}):\subst{T}{c}{u};E''}{\Gamma}}} + + \inference{\frac{\WF{E;c:=u:U;E';c':T;E''}{\Gamma}} + {\WF{E;c:=u:U;E';c':\subst{T}{c}{u};E''}{\Gamma}}} + + \inference{\frac{\WF{E;c:=u:U;E';\Ind{}{p}{\Gamma_I}{\Gamma_C};E''}{\Gamma}} + {\WF{E;c:=u:U;E';\Ind{}{p}{\subst{\Gamma_I}{c}{u}}{\subst{\Gamma_C}{c}{u}};E''}{\Gamma}}} + +\paragraph{Pruning the local context.} +If one abstracts or substitutes constants with the above rules then it +may happen that some declared or defined constant does not occur any +more in the subsequent global environment and in the local context. One can +consequently derive the following property. + +\paragraph{First pruning property:} +\inference{\frac{\WF{E;c:U;E'}{\Gamma} \qquad c \mbox{ does not occur in $E'$ and $\Gamma$}} + {\WF{E;E'}{\Gamma}}} + +\paragraph{Second pruning property:} +\inference{\frac{\WF{E;c:=u:U;E'}{\Gamma} \qquad c \mbox{ does not occur in $E'$ and $\Gamma$}} + {\WF{E;E'}{\Gamma}}} + \section{Co-inductive types} The implementation contains also co-inductive definitions, which are types inhabited by infinite objects. @@ -1684,14 +1652,14 @@ More information on co-inductive definitions can be found in~\cite{Gimenez95b,Gim98,GimCas05}. %They are described in Chapter~\ref{Co-inductives}. -\section[\iCIC : the Calculus of Inductive Construction with - impredicative \Set]{\iCIC : the Calculus of Inductive Construction with +\section[The Calculus of Inductive Construction with + impredicative \Set]{The Calculus of Inductive Construction with impredicative \Set\label{impredicativity}} -\Coq{} can be used as a type-checker for \iCIC{}, the original +\Coq{} can be used as a type-checker for the Calculus of Inductive Constructions with an impredicative sort \Set{} by using the compiler option \texttt{-impredicative-set}. - +% For example, using the ordinary \texttt{coqtop} command, the following is rejected. % (** This example should fail ******************************* @@ -1727,8 +1695,6 @@ impredicative system for sort \Set{} become: \{\Type(i)\}} {\compat{I:\Set}{I\ra s}}} \end{description} - - %%% Local Variables: %%% mode: latex diff --git a/doc/refman/RefMan-com.tex b/doc/refman/RefMan-com.tex index 9862abb53..6f8584988 100644 --- a/doc/refman/RefMan-com.tex +++ b/doc/refman/RefMan-com.tex @@ -5,9 +5,9 @@ There are three \Coq~commands: \begin{itemize} -\item {\tt coqtop}: The \Coq\ toplevel (interactive mode) ; -\item {\tt coqc} : The \Coq\ compiler (batch compilation). -\item {\tt coqchk} : The \Coq\ checker (validation of compiled libraries) +\item {\tt coqtop}: the \Coq\ toplevel (interactive mode); +\item {\tt coqc}: the \Coq\ compiler (batch compilation); +\item {\tt coqchk}: the \Coq\ checker (validation of compiled libraries). \end{itemize} The options are (basically) the same for the first two commands, and roughly described below. You can also look at the \verb!man! pages of @@ -39,11 +39,10 @@ The {\tt coqc} command takes a name {\em file} as argument. Then it looks for a vernacular file named {\em file}{\tt .v}, and tries to compile it into a {\em file}{\tt .vo} file (See ~\ref{compiled}). -\Warning The name {\em file} must be a regular {\Coq} identifier, as -defined in the Section~\ref{lexical}. It -must only contain letters, digits or underscores -(\_). Thus it can be \verb+/bar/foo/toto.v+ but cannot be -\verb+/bar/foo/to-to.v+. +\Warning The name {\em file} should be a regular {\Coq} identifier, as +defined in Section~\ref{lexical}. It should contain only letters, digits +or underscores (\_). For instance, \verb+/bar/foo/toto.v+ is valid, but +\verb+/bar/foo/to-to.v+ is invalid. \section[Customization]{Customization at launch time} @@ -64,7 +63,7 @@ directories to the load path of \Coq. It is possible to skip the loading of the resource file with the option \verb:-q:. -\section{By environment variables\label{EnvVariables} +\subsection{By environment variables\label{EnvVariables} \index{Environment variables}\label{envars}} Load path can be specified to the \Coq\ system by setting up @@ -87,20 +86,19 @@ code. The list of highlight tags can be retrieved with the {\tt -list-tags} command-line option of {\tt coqtop}. \subsection{By command line options\index{Options of the command line} -\label{vmoption} \label{coqoptions}} The following command-line options are recognized by the commands {\tt coqc} and {\tt coqtop}, unless stated otherwise: \begin{description} -\item[{\tt -I} {\em directory}, {\tt -include} {\em directory}]\ +\item[{\tt -I} {\em directory}, {\tt -include} {\em directory}]\ % -Add physical path {\em directory} to the {\ocaml} loadpath. + Add physical path {\em directory} to the {\ocaml} loadpath. \SeeAlso Section~\ref{Libraries} and the command {\tt Declare ML Module} Section \ref{compiled}. -\item[\texttt{-Q} \emph{directory} {\dirpath}]\ +\item[{\tt -Q} {\em directory} {\dirpath}]\ % Add physical path \emph{directory} to the list of directories where {\Coq} looks for a file and bind it to the the logical directory @@ -110,152 +108,184 @@ Add physical path {\em directory} to the {\ocaml} loadpath. \SeeAlso Section~\ref{Libraries}. -\item[{\tt -R} {\em directory} {\dirpath}]\ +\item[{\tt -R} {\em directory} {\dirpath}]\ % Do as \texttt{-Q} \emph{directory} {\dirpath} but make the subdirectory structure of \emph{directory} recursively visible so that the recursive contents of physical \emph{directory} is available from {\Coq} using short or partially qualified names. - + \SeeAlso Section~\ref{Libraries}. -\item[{\tt -top} {\dirpath}, {\tt -notop}]\ +\item[{\tt -top} {\dirpath}]\ % + + Set the toplevel module name to {\dirpath} instead of {\tt Top}. Not + valid for {\tt coqc} as the toplevel module name is inferred from the + name of the output file. + +\item[{\tt -notop}]\ % + + Use the empty logical path for the toplevel module name instead of {\tt + Top}. Not valid for {\tt coqc} as the toplevel module name is + inferred from the name of the output file. + +\item[{\tt -exclude-dir} {\em directory}]\ % - This sets the toplevel module name to {\dirpath}/the empty logical path instead - of {\tt Top}. Not valid for {\tt coqc}. + Exclude any subdirectory named {\em directory} while + processing options such as {\tt -R} and {\tt -Q}. By default, only the + conventional version control management directories named {\tt CVS} and + {\tt \_darcs} are excluded. -\item[{\tt -exclude-dir} {\em subdirectory}]\ +\item[{\tt -nois}]\ % - This tells to exclude any subdirectory named {\em subdirectory} - while processing option {\tt -R}. Without this option only the - conventional version control management subdirectories named {\tt - CVS} and {\tt \_darcs} are excluded. + Start from an empty state instead of loading the {\tt Init.Prelude} + module. -\item[{\tt -nois}]\ +\item[{\tt -init-file} {\em file}]\ % - Cause \Coq~to begin with an empty state. + Load {\em file} as the resource file instead of loading the default + resource file from the standard configuration directories. -\item[{\tt -init-file} {\em file}, {\tt -q}]\ +\item[{\tt -q}]\ % - Take {\em file} as the resource file. / - Cause \Coq~not to load the resource file. + Do not to load the default resource file. -\item[{\tt -load-ml-source} {\em file}]\ +\item[{\tt -load-ml-source} {\em file}]\ % Load the {\ocaml} source file {\em file}. -\item[{\tt -load-ml-object} {\em file}]\ +\item[{\tt -load-ml-object} {\em file}]\ % Load the {\ocaml} object file {\em file}. -\item[{\tt -l[v]} {\em file}, {\tt -load-vernac-source[-verbose]} {\em file}]\ +\item[{\tt -l} {\em file}, {\tt -load-vernac-source} {\em file}]\ % + + Load and execute the {\Coq} script from {\em file.v}. + +\item[{\tt -lv} {\em file}, {\tt -load-vernac-source-verbose} {\em + file}]\ % + + Load and execute the {\Coq} script from {\em file.v}. + Output its content on the standard input as it is executed. + +\item[{\tt -load-vernac-object} {\dirpath}]\ % - Load \Coq~file {\em file}{\tt .v} optionally with copy it contents on the - standard input. + Load \Coq~compiled library {\dirpath}. This is equivalent to running + {\tt Require} {\dirpath}. -\item[{\tt -load-vernac-object} {\em path}]\ +\item[{\tt -require} {\dirpath}]\ % - Load \Coq~compiled library {\em path} (equivalent to {\tt Require} {\em path}). + Load \Coq~compiled library {\dirpath} and import it. This is equivalent + to running {\tt Require Import} {\dirpath}. -\item[{\tt -require} {\em path}]\ +\item[{\tt -batch}]\ % - Load \Coq~compiled library {\em path} and import it (equivalent to {\tt - Require Import} {\em path}). + Exit just after argument parsing. Available for {\tt coqtop} only. -\item[{\tt -compile} {\em file.v},{\tt -compile-verbose} {\em file.v}, {\tt -batch}]\ +\item[{\tt -compile} {\em file.v}]\ % - {\tt coqtop} options only used internally by {\tt coqc}. + Compile file {\em file.v} into {\em file.vo}. This options imply {\tt + -batch} (exit just after argument parsing). It is available only + for {\tt coqtop}, as this behavior is the purpose of {\tt coqc}. - This compiles file {\em file.v} into {\em file}{\tt .vo} without/with a - copy of the contents of the file on standard input. This option implies options - {\tt -batch} (exit just after arguments parsing). It is only - available for {\tt coqtop}. +\item[{\tt -compile-verbose} {\em file.v}]\ % -\item[{\tt -verbose}]\ + Same as {\tt -compile} but also output the content of {\em file.v} as + it is compiled. - This option is only for {\tt coqc}. It tells to compile the file with - a copy of its contents on standard input. +\item[{\tt -verbose}]\ % + + Output the content of the input file as it is compiled. This option is + available for {\tt coqc} only; it is the counterpart of {\tt + -compile-verbose}. %Mostly unused in the code -%\item[{\tt -debug}]\ +%\item[{\tt -debug}]\ % % % Switch on the debug flag. -\item[{\tt -with-geoproof} (yes|no)]\ +\item[{\tt -with-geoproof} (yes|no)]\ % - Activate or not special functions for Geoproof within {\CoqIDE} (default is yes). + Enable or not special functions for Geoproof within {\CoqIDE} (default + is yes). -\item[{\tt -color} (on|off|auto)]\ +\item[{\tt -color} (on|off|auto)]\ % - Activate or not the coloring of output of {\tt coqtop}. The default, auto, - means that {\tt coqtop} will dynamically decide whether to activate it - depending if the output channels of {\tt coqtop} can handle ANSI styles. + Enable or not the coloring of output of {\tt coqtop}. Default is auto, + meaning that {\tt coqtop} dynamically decides, depending on whether the + output channel supports ANSI escape sequences. -\item[{\tt -beautify}]\ +\item[{\tt -beautify}]\ % - While compiling {\em file}, pretty prints each command just after having parsing - it in {\em file}{\tt .beautified} in order to get old-fashion - syntax/definitions/notations. + Pretty-print each command to {\em file.beautified} when compiling {\em + file.v}, in order to get old-fashioned syntax/definitions/notations. -\item[{\tt -emacs}, {\tt -ide-slave}]\ +\item[{\tt -emacs}, {\tt -ide-slave}]\ % - Start a special main loop to communicate with ide. + Start a special toplevel to communicate with a specific IDE. -\item[{\tt -impredicative-set}]\ +\item[{\tt -impredicative-set}]\ % Change the logical theory of {\Coq} by declaring the sort {\tt Set} - impredicative; warning: this is known to be inconsistent with + impredicative. Warning: this is known to be inconsistent with some standard axioms of classical mathematics such as the functional - axiom of choice or the principle of description + axiom of choice or the principle of description. -\item[{\tt -type-in-type}]\ +\item[{\tt -type-in-type}]\ % - This collapses the universe hierarchy of {\Coq} making the logic inconsistent. + Collapse the universe hierarchy of {\Coq}. Warning: this makes the + logic inconsistent. -\item[{\tt -compat} {\em version}] \mbox{} +\item[{\tt -compat} {\em version}]\ % - Attempt to maintain some of the incompatible changes in their {\em version} - behavior. + Attempt to maintain some backward-compatibility with a previous version. -\item[{\tt -dump-glob} {\em file}]\ +\item[{\tt -dump-glob} {\em file}]\ % - This dumps references for global names in file {\em file} - (to be used by coqdoc, see~\ref{coqdoc}) + Dump references for global names in file {\em file} (to be used + by {\tt coqdoc}, see~\ref{coqdoc}). By default, if {\em file.v} is being + compiled, {\em file.glob} is used. -\item[{\tt -no-hash-consing}] \mbox{} +\item[{\tt -no-glob}]\ % -\item[{\tt -vm}]\ + Disable the dumping of references for global names. - This activates the use of the bytecode-based conversion algorithm - for the current session (see Section~\ref{SetVirtualMachine}). +%\item[{\tt -no-hash-consing}]\ % -\item[{\tt -image} {\em file}]\ +\item[{\tt -image} {\em file}]\ % - This option sets the binary image to be used by {\tt coqc} to be {\em file} + Set the binary image to be used by {\tt coqc} to be {\em file} instead of the standard one. Not of general use. -\item[{\tt -bindir} {\em directory}]\ +\item[{\tt -bindir} {\em directory}]\ % + + Set the directory containing {\Coq} binaries to be used by {\tt coqc}. + It is equivalent to doing \texttt{export COQBIN=}{\em directory} before + launching {\tt coqc}. + +\item[{\tt -where}]\ % + + Print the location of \Coq's standard library and exit. - Set for {\tt coqc} the directory containing \Coq\ binaries. - It is equivalent to do \texttt{export COQBIN=}{\em directory} - before launching {\tt coqc}. +\item[{\tt -config}]\ % -\item[{\tt -where}, {\tt -config}, {\tt -filteropts}]\ + Print the locations of \Coq's binaries, dependencies, and libraries, then exit. - Print the \Coq's standard library location or \Coq's binaries, dependencies, - libraries locations or the list of command line arguments that {\tt coqtop} has - recognize as options and exit. +\item[{\tt -filteropts}]\ % -\item[{\tt -v}]\ + Print the list of command line arguments that {\tt coqtop} has + recognized as options and exit. - Print the \Coq's version and exit. +\item[{\tt -v}]\ % -\item[{\tt -list-tags}]\ + Print \Coq's version and exit. - Print the highlight tags known by \Coq as well as their currently associated - color. +\item[{\tt -list-tags}]\ % -\item[{\tt -h}, {\tt --help}]\ + Print the highlight tags known by {\Coq} as well as their currently associated + color and exit. + +\item[{\tt -h}, {\tt --help}]\ % Print a short usage and exit. @@ -299,18 +329,21 @@ Command-line options {\tt -I}, {\tt -R}, {\tt -where} and {\tt -impredicative-set} are supported by {\tt coqchk} and have the same meaning as for {\tt coqtop}. Extra options are: \begin{description} -\item[{\tt -norec} $module$]\ +\item[{\tt -norec} {\em module}]\ % + + Check {\em module} but do not check its dependencies. - Check $module$ but do not force check of its dependencies. -\item[{\tt -admit} $module$] \ +\item[{\tt -admit} {\em module}]\ % - Do not check $module$ and any of its dependencies, unless + Do not check {\em module} and any of its dependencies, unless explicitly required. -\item[{\tt -o}]\ + +\item[{\tt -o}]\ % At exit, print a summary about the context. List the names of all assumptions and variables (constants without body). -\item[{\tt -silent}]\ + +\item[{\tt -silent}]\ % Do not write progress information in standard output. \end{description} diff --git a/doc/refman/RefMan-ext.tex b/doc/refman/RefMan-ext.tex index d21c91201..51e881bff 100644 --- a/doc/refman/RefMan-ext.tex +++ b/doc/refman/RefMan-ext.tex @@ -226,6 +226,7 @@ Definition c := {| y := 3; x := 5 |}. This syntax can be disabled globally for printing by \begin{quote} {\tt Unset Printing Records.} +\optindex{Printing Records} \end{quote} For a given type, one can override this using either \begin{quote} @@ -253,6 +254,7 @@ Reset Initial. \Rem An experimental syntax for projections based on a dot notation is available. The command to activate it is +\optindex{Printing Projections} \begin{quote} {\tt Set Printing Projections.} \end{quote} @@ -283,12 +285,15 @@ To deactivate the printing of projections, use {\tt Unset Printing Projections}. \subsection{Primitive Projections} +\optindex{Primitive Projections} +\optindex{Printing Primitive Projection Parameters} +\optindex{Printing Primitive Projection Compatibility} \index{Primitive projections} \label{prim-proj} The option {\tt Set Primitive Projections} turns on the use of primitive projections when defining subsequent records. Primitive projections -extended the calculus of inductive constructions with a new binary term +extended the Calculus of Inductive Constructions with a new binary term constructor {\tt r.(p)} representing a primitive projection p applied to a record object {\tt r} (i.e., primitive projections are always applied). Even if the record type has parameters, these do not appear at @@ -313,6 +318,12 @@ for the usual defined ones. % - [pattern x at n], [rewrite x at n] and in general abstraction and selection % of occurrences may fail due to the disappearance of parameters. +For compatibility, the parameters still appear to the user when printing terms +even though they are absent in the actual AST manipulated by the kernel. This +can be changed by unsetting the {\tt Printing Primitive Projection Parameters} +flag. Further compatibility printing can be deactivated thanks to the +{\tt Printing Primitive Projection Compatibility} option which governs the +printing of pattern-matching over primitive records. \section{Variants and extensions of {\mbox{\tt match}} \label{Extensions-of-match} @@ -1249,7 +1260,7 @@ possible, the correct argument will be automatically generated. \end{ErrMsgs} -\subsection{Declaration of implicit arguments for a constant +\subsection{Declaration of implicit arguments \comindex{Arguments}} \label{ImplicitArguments} @@ -1262,7 +1273,7 @@ a priori and a posteriori. \subsubsection{Implicit Argument Binders} In the first setting, one wants to explicitly give the implicit -arguments of a constant as part of its definition. To do this, one has +arguments of a declared object as part of its definition. To do this, one has to surround the bindings of implicit arguments by curly braces: \begin{coq_eval} Reset Initial. @@ -1299,7 +1310,7 @@ usual implicit arguments disambiguation syntax. \subsubsection{Declaring Implicit Arguments} -To set implicit arguments for a constant a posteriori, one can use the +To set implicit arguments a posteriori, one can use the command: \begin{quote} \tt Arguments {\qualid} \nelist{\possiblybracketedident}{} @@ -1378,7 +1389,7 @@ Check (fun l => map length l = map (list nat) nat length l). \Rem To know which are the implicit arguments of an object, use the command {\tt Print Implicit} (see \ref{PrintImplicit}). -\subsection{Automatic declaration of implicit arguments for a constant} +\subsection{Automatic declaration of implicit arguments} {\Coq} can also automatically detect what are the implicit arguments of a defined object. The command is just @@ -1581,7 +1592,7 @@ Implicit arguments names can be redefined using the following syntax: \end{quote} Without the {\tt rename} flag, {\tt Arguments} can be used to assert -that a given constant has the expected number of arguments and that +that a given object has the expected number of arguments and that these arguments are named as expected. \noindent {\bf Example (continued): } @@ -1997,13 +2008,13 @@ variables, use \end{quote} \subsection{Solving existential variables using tactics} -\ttindex{\textdollar( \ldots )\textdollar} +\ttindex{ltac:( \ldots )} \def\expr{\textrm{\textsl{tacexpr}}} Instead of letting the unification engine try to solve an existential variable by itself, one can also provide an explicit hole together with a tactic to solve -it. Using the syntax {\tt \textdollar(\expr)\textdollar}, the user can put a +it. Using the syntax {\tt ltac:(\expr)}, the user can put a tactic anywhere a term is expected. The order of resolution is not specified and is implementation-dependent. The inner tactic may use any variable defined in its scope, including repeated alternations between variables introduced by term @@ -2011,7 +2022,7 @@ binding as well as those introduced by tactic binding. The expression {\expr} can be any tactic expression as described at section~\ref{TacticLanguage}. \begin{coq_example*} -Definition foo (x : nat) : nat := $( exact x )$. +Definition foo (x : nat) : nat := ltac:(exact x). \end{coq_example*} This construction is useful when one wants to define complicated terms using diff --git a/doc/refman/RefMan-gal.tex b/doc/refman/RefMan-gal.tex index 9b527053c..fcccd9cb4 100644 --- a/doc/refman/RefMan-gal.tex +++ b/doc/refman/RefMan-gal.tex @@ -311,7 +311,7 @@ called \CIC). The formal presentation of {\CIC} is given in Chapter {\annotation} & ::= & {\tt \{ struct} {\ident} {\tt \}} \\ &&\\ {\caseitem} & ::= & {\term} \zeroone{{\tt as} \name} - \zeroone{{\tt in} \pattern} \\ + \zeroone{{\tt in} \qualid \sequence{\pattern}{}} \\ &&\\ {\ifitem} & ::= & \zeroone{{\tt as} {\name}} {\returntype} \\ &&\\ @@ -322,7 +322,7 @@ called \CIC). The formal presentation of {\CIC} is given in Chapter {\multpattern} & ::= & \nelist{\pattern}{\tt ,}\\ &&\\ {\pattern} & ::= & {\qualid} \nelist{\pattern}{} \\ - & $|$ & {\tt @} {\qualid} \sequence{\pattern}{} \\ + & $|$ & {\tt @} {\qualid} \nelist{\pattern}{} \\ & $|$ & {\pattern} {\tt as} {\ident} \\ & $|$ & {\pattern} {\tt \%} {\ident} \\ @@ -468,8 +468,8 @@ proposition $B$ or the functional dependent product from $A$ to $B$ (a construction usually written $\Pi_{x:A}.B$ in set theory). Non dependent product types have a special notation: ``$A$ {\tt ->} -$B$'' stands for ``{\tt forall \_:}$A${\tt ,}~$B$''. The non dependent -product is used both to denote the propositional implication and +$B$'' stands for ``{\tt forall \_:}$A${\tt ,}~$B$''. The {\em non dependent +product} is used both to denote the propositional implication and function types. \subsection{Applications @@ -496,9 +496,8 @@ arguments is used for making explicit the value of implicit arguments The expression ``{\term}~{\tt :}~{\type}'' is a type cast expression. It enforces the type of {\term} to be {\type}. -``{\term}~{\tt <:}~{\type}'' locally sets up the virtual machine (as if option -{\tt Virtual Machine} were on, see \ref{SetVirtualMachine}) for checking that -{\term} has type {\type}. +``{\term}~{\tt <:}~{\type}'' locally sets up the virtual machine for checking +that {\term} has type {\type}. \subsection{Inferable subterms \label{hole} @@ -609,17 +608,20 @@ the type of each branch can depend on the type dependencies specific to the branch and the whole pattern-matching expression has a type determined by the specific dependencies in the type of the term being matched. This dependency of the return type in the annotations of the -inductive type is expressed using a {\tt -``in~I~\_~$\ldots$~\_~\ident$_1$~$\ldots$~\ident$_n$}'' clause, where +inductive type is expressed using a + ``in~I~\_~$\ldots$~\_~\pattern$_1$~$\ldots$~\pattern$_n$'' clause, where \begin{itemize} \item $I$ is the inductive type of the term being matched; -\item the names \ident$_i$'s correspond to the arguments of the -inductive type that carry the annotations: the return type is dependent -on them; - -\item the {\_}'s denote the family parameters of the inductive type: +\item the {\_}'s are matching the parameters of the inductive type: the return type is not dependent on them. + +\item the \pattern$_i$'s are matching the annotations of the inductive + type: the return type is dependent on them + +\item in the basic case which we describe below, each \pattern$_i$ is a + name \ident$_i$; see \ref{match-in-patterns} for the general case + \end{itemize} For instance, in the following example: @@ -971,7 +973,7 @@ are the names of its constructors and {\type$_1$}, {\ldots}, {\type$_n$} their respective types. The types of the constructors have to satisfy a {\em positivity condition} (see Section~\ref{Positivity}) for {\ident}. This condition ensures the soundness of the inductive -definition. If this is the case, the constants {\ident}, +definition. If this is the case, the names {\ident}, {\ident$_1$}, {\ldots}, {\ident$_n$} are added to the environment with their respective types. Accordingly to the universe where the inductive type lives ({\it e.g.} its type {\sort}), {\Coq} provides a @@ -990,7 +992,7 @@ Inductive nat : Set := \end{coq_example} The type {\tt nat} is defined as the least \verb:Set: containing {\tt - O} and closed by the {\tt S} constructor. The constants {\tt nat}, + O} and closed by the {\tt S} constructor. The names {\tt nat}, {\tt O} and {\tt S} are added to the environment. Now let us have a look at the elimination principles. They are three @@ -1101,7 +1103,7 @@ Inductive list (A:Set) : Set := \end{coq_example*} Note that in the type of {\tt nil} and {\tt cons}, we write {\tt - (list A)} and not just {\tt list}.\\ The constants {\tt nil} and + (list A)} and not just {\tt list}.\\ The constructors {\tt nil} and {\tt cons} will have respectively types: \begin{coq_example} diff --git a/doc/refman/RefMan-lib.tex b/doc/refman/RefMan-lib.tex index 7227f4b7b..4ebb484e7 100644 --- a/doc/refman/RefMan-lib.tex +++ b/doc/refman/RefMan-lib.tex @@ -17,10 +17,11 @@ The \Coq\ library is structured into two parts: In addition, user-provided libraries or developments are provided by \Coq\ users' community. These libraries and developments are available -for download at \texttt{http://coq.inria.fr} (see +for download at \url{http://coq.inria.fr} (see Section~\ref{Contributions}). -The chapter briefly reviews the \Coq\ libraries. +The chapter briefly reviews the \Coq\ libraries whose contents can +also be browsed at \url{http://coq.inria.fr/stdlib}. \section[The basic library]{The basic library\label{Prelude}} @@ -799,7 +800,9 @@ At the end, it defines data-types at the {\Type} level. \subsection{Tactics} A few tactics defined at the user level are provided in the initial -state\footnote{This is in module {\tt Tactics.v}}. +state\footnote{This is in module {\tt Tactics.v}}. They are listed at +\url{http://coq.inria.fr/stdlib} (paragraph {\tt Init}, link {\tt + Tactics}). \section{The standard library} @@ -842,7 +845,7 @@ Chapter~\ref{Other-commands}). The different modules of the \Coq\ standard library are described in the additional document \verb!Library.dvi!. They are also accessible on the WWW through the \Coq\ homepage -\footnote{\texttt{http://coq.inria.fr}}. +\footnote{\url{http://coq.inria.fr}}. \subsection[Notations for integer arithmetics]{Notations for integer arithmetics\index{Arithmetical notations}} @@ -1035,7 +1038,7 @@ intros; split_Rmult. \end{itemize} -All this tactics has been written with the tactic language Ltac +These tactics has been written with the tactic language Ltac described in Chapter~\ref{TacticLanguage}. \begin{coq_eval} diff --git a/doc/refman/RefMan-ltac.tex b/doc/refman/RefMan-ltac.tex index 2f07beb72..cc7e6b53b 100644 --- a/doc/refman/RefMan-ltac.tex +++ b/doc/refman/RefMan-ltac.tex @@ -1101,7 +1101,7 @@ using the syntax: {\tt Ltac} {\qualid} {\ident}$_1$ ... {\ident}$_n$ {\tt ::=} {\tacexpr} \end{quote} -A previous definition of \qualid must exist in the environment. +A previous definition of {\qualid} must exist in the environment. The new definition will always be used instead of the old one and it goes accross module boundaries. diff --git a/doc/refman/RefMan-oth.tex b/doc/refman/RefMan-oth.tex index 7c95e4d4a..aea2bae38 100644 --- a/doc/refman/RefMan-oth.tex +++ b/doc/refman/RefMan-oth.tex @@ -1083,26 +1083,6 @@ perform a {\tt Ltac \ident\ := {\rm\sl convtactic}}. \SeeAlso sections \ref{Conversion-tactics} -\subsection{\tt Set Virtual Machine -\label{SetVirtualMachine} -\optindex{Virtual Machine}} - -This activates the bytecode-based conversion algorithm. - -\subsection{\tt Unset Virtual Machine -\optindex{Virtual Machine}} - -This deactivates the bytecode-based conversion algorithm. - -\subsection{\tt Test Virtual Machine -\optindex{Virtual Machine}} - -This tells if the bytecode-based conversion algorithm is -activated. The default behavior is to have the bytecode-based -conversion algorithm deactivated. - -\SeeAlso sections~\ref{vmcompute} and~\ref{vmoption}. - \section{Controlling the locality of commands} \subsection{{\tt Local}, {\tt Global} diff --git a/doc/refman/RefMan-pre.tex b/doc/refman/RefMan-pre.tex index f45072ca4..cb2ab5dc2 100644 --- a/doc/refman/RefMan-pre.tex +++ b/doc/refman/RefMan-pre.tex @@ -956,20 +956,20 @@ Ltac language dependent subgoals, deep backtracking and multiple goal handling, along with miscellaneous features and an improved potential for future modifications. Dependent subgoals allow statements in a goal to mention the proof of another. Proofs of unsolved subgoals -appear as existential variables. Primitive backtracking make it +appear as existential variables. Primitive backtracking makes it possible to write a tactic with several possible outcomes which are tried successively when subsequent tactics fail. Primitives are also available to control the backtracking behavior of tactics. Multiple goal handling paves the way for smarter automation tactics. It is currently used for simple goal manipulation such as goal reordering. -The way Coq processes a document in batch and interactive mode has +The way {\Coq} processes a document in batch and interactive mode has been redesigned by Enrico Tassi with help from Bruno Barras. Opaque proofs, the text between Proof and Qed, can be processed asynchronously, decoupling the checking of definitions and statements from the checking of proofs. It improves the responsiveness of interactive development, since proofs can be processed in the -background. Similarly compilation of a file can be split into two +background. Similarly, compilation of a file can be split into two phases: the first one checking only definitions and statements and the second one checking proofs. A file resulting from the first phase~--~with the .vio extension~--~can be already Required. All .vio @@ -977,13 +977,13 @@ files can be turned into complete .vo files in parallel. The same infrastructure also allows terminating tactics to be run in parallel on a set of goals via the \verb=par:= goal selector. -CoqIDE was modified to cope with asynchronous checking of the -document. Its source code was also made separate from that of Coq, so -that CoqIDE no longer has a special status among user interfaces, -paving the way for decoupling its release cycle from that of Coq in +{\CoqIDE} was modified to cope with asynchronous checking of the +document. Its source code was also made separate from that of {\Coq}, so +that {\CoqIDE} no longer has a special status among user interfaces, +paving the way for decoupling its release cycle from that of {\Coq} in the future. -Carst Tankink developed a Coq back end for user interfaces built on +Carst Tankink developed a {\Coq} back-end for user interfaces built on Makarius Wenzel's Prover IDE framework (PIDE), like PIDE/jEdit (with help from Makarius Wenzel) or PIDE/Coqoon (with help from Alexander Faithfull and Jesper Bengtson). The development of such features was @@ -1017,7 +1017,7 @@ principles such as propositional extensionality and univalence, thanks to Maxime Dénès and Bruno Barras. To ensure compatibility with the univalence axiom, a new flag ``-indices-matter'' has been implemented, taking into account the universe levels of indices when computing the -levels of inductive types. This supports using Coq as a tool to explore +levels of inductive types. This supports using {\Coq} as a tool to explore the relations between homotopy theory and type theory. Maxime Dénès and Benjamin Grégoire developed an implementation of @@ -1025,17 +1025,23 @@ conversion test and normal form computation using the OCaml native compiler. It complements the virtual machine conversion offering much faster computation for expensive functions. -{\Coq} 8.5 also comes with a bunch of many various smaller-scale changes -and improvements regarding the different components of the system. +{\Coq} 8.5 also comes with a bunch of many various smaller-scale +changes and improvements regarding the different components of the +system. We shall only list a few of them. + +Pierre Boutillier developed an improved tactic for simplification of +expressions called {\tt cbn}. -Maxime Dénès maintained the bytecode-based reduction machine. +Maxime Dénès maintained the bytecode-based reduction machine. Pierre +Letouzey maintained the extraction mechanism. Pierre-Marie Pédrot has extended the syntax of terms to, experimentally, allow holes in terms to be solved by a locally specified tactic. Existential variables are referred to by identifiers rather than mere -numbers, thanks to Hugo Herbelin. +numbers, thanks to Hugo Herbelin who also improved the tactic language +here and there. Error messages for universe inconsistencies have been improved by Matthieu Sozeau. Error messages for unification and type inference @@ -1043,14 +1049,42 @@ failures have been improved by Hugo Herbelin, Pierre-Marie Pédrot and Arnaud Spiwack. Pierre Courtieu contributed new features for using {\Coq} through Proof -General and for better interactive experience (bullets, Search etc). - -A distribution channel for Coq packages using the Opam tool has been -developed by Thomas Braibant and Guillaume Claret. +General and for better interactive experience (bullets, Search, etc). + +The efficiency of the whole system has been significantly improved +thanks to contributions from Pierre-Marie Pédrot. + +A distribution channel for {\Coq} packages using the OPAM tool has +been initiated by Thomas Braibant and developed by Guillaume Claret, +with contributions by Enrico Tassi and feedback from Hugo Herbelin. + +Packaging tools were provided by Pierre Letouzey and Enrico Tassi +(Windows), Pierre Boutillier, Matthieu Sozeau and Maxime Dénès (MacOS +X). Maxime Dénès improved significantly the testing and benchmarking +support. + +Many power users helped to improve the design of the new features via +the bug tracker, the coq development mailing list or the coq-club +mailing list. Special thanks are going to the users who contributed +patches and intensive brain-storming, starting with Jason Gross, +Jonathan Leivent, Greg Malecha, Clément Pit-Claudel, Marc Lasson, +Lionel Rieg. It would however be impossible to mention with precision +all names of people who to some extent influenced the development. + +Version 8.5 is one of the most important release of {\Coq}. Its +development spanned over about 3 years and a half with about one year +of beta-testing. General maintenance during part or whole of this +period has been done by Pierre Boutillier, Pierre Courtieu, Maxime +Dénès, Hugo Herbelin, Pierre Letouzey, Guillaume Melquiond, +Pierre-Marie Pédrot, Matthieu Sozeau, Arnaud Spiwack, Enrico Tassi as +well as Bruno Barras, Yves Bertot, Frédéric Besson, Xavier Clerc, +Pierre Corbineau, Jean-Christophe Filliâtre, Julien Forest, Sébastien +Hinderer, Assia Mahboubi, Jean-Marc Notin, Yann Régis-Gianas, François +Ripault, Carst Tankink. Maxime Dénès coordinated the release process. \begin{flushright} -Paris, January 2015\\ -Hugo Herbelin \& Matthieu Sozeau\\ +Paris, January 2015, revised December 2015,\\ +Hugo Herbelin, Matthieu Sozeau and the {\Coq} development team\\ \end{flushright} diff --git a/doc/refman/RefMan-pro.tex b/doc/refman/RefMan-pro.tex index 481afa8f8..c37367de5 100644 --- a/doc/refman/RefMan-pro.tex +++ b/doc/refman/RefMan-pro.tex @@ -186,7 +186,7 @@ in Section~\ref{ProofWith}. \subsubsection{{\tt Proof using} options} \optindex{Default Proof Using} \optindex{Suggest Proof Using} -\optindex{Proof Using Clear Unused} +% \optindex{Proof Using Clear Unused} The following options modify the behavior of {\tt Proof using}. @@ -201,12 +201,12 @@ The following options modify the behavior of {\tt Proof using}. When {\tt Qed} is performed, suggest a {\tt using} annotation if the user did not provide one. -\variant{\tt Unset Proof Using Clear Unused.} - - When {\tt Proof using a} all section variables but for {\tt a} and - the variables used in the type of {\tt a} are cleared. - This option can be used to turn off this behavior. - +% \variant{\tt Unset Proof Using Clear Unused.} +% +% When {\tt Proof using a} all section variables but for {\tt a} and +% the variables used in the type of {\tt a} are cleared. +% This option can be used to turn off this behavior. +% \subsubsection[\tt Collection]{Name a set of section hypotheses for {\tt Proof using}} \comindex{Collection}\label{Collection} @@ -407,6 +407,19 @@ Proof. \end{ErrMsgs} +The bullet behavior can be controlled by the following commands. + +\begin{quote} +Set Bullet Behavior "None". +\end{quote} + +This makes bullets inactive. + +\begin{quote} +Set Bullet Behavior "Strict Subproofs". +\end{quote} + +This makes bullets active (this is the default behavior). \section{Requesting information} diff --git a/doc/refman/RefMan-sch.tex b/doc/refman/RefMan-sch.tex index 571e16d57..53aa6b86a 100644 --- a/doc/refman/RefMan-sch.tex +++ b/doc/refman/RefMan-sch.tex @@ -126,6 +126,8 @@ conclusion is {\tt (n:nat)(even n)->(Q n)}. \optindex{Boolean Equality Schemes} \optindex{Elimination Schemes} \optindex{Nonrecursive Elimination Schemes} +\optindex{Case Analysis Schemes} +\optindex{Decidable Equality Schemes} \label{set-nonrecursive-elimination-schemes} } @@ -139,6 +141,10 @@ and {\tt Record} (see~\ref{Record}) do not have an automatic declaration of the induction principles. It can be activated with the command {\tt Set Nonrecursive Elimination Schemes}. It can be deactivated again with {\tt Unset Nonrecursive Elimination Schemes}. + +In addition, the {\tt Case Analysis Schemes} flag governs the generation of +case analysis lemmas for inductive types, i.e. corresponding to the +pattern-matching term alone and without fixpoint. \\ You can also activate the automatic declaration of those Boolean equalities diff --git a/doc/refman/RefMan-tac.tex b/doc/refman/RefMan-tac.tex index 67ce7e8cd..f5a1bf3b2 100644 --- a/doc/refman/RefMan-tac.tex +++ b/doc/refman/RefMan-tac.tex @@ -219,8 +219,10 @@ difference: the user can leave some holes (denoted by \texttt{\_} or {\tt (\_:\type)}) in the term. {\tt refine} will generate as many subgoals as there are holes in the term. The type of holes must be either synthesized by the system or declared by an -explicit cast like \verb|(_:nat->Prop)|. This low-level -tactic can be useful to advanced users. +explicit cast like \verb|(_:nat->Prop)|. Any subgoal that occurs in other +subgoals is automatically shelved, as if calling {\tt shelve\_unifiable} +(see Section~\ref{shelve}). +This low-level tactic can be useful to advanced users. \Example @@ -256,6 +258,13 @@ Defined. which type cannot be inferred. Put a cast around it. \end{ErrMsgs} +\begin{Variants} +\item {\tt simple refine \term}\tacindex{simple refine} + + This tactic behaves like {\tt refine}, but it does not shelve any + subgoal. It does not perform any beta-reduction either. +\end{Variants} + \subsection{\tt apply \term} \tacindex{apply} \label{apply} @@ -793,7 +802,7 @@ the tactic {\tt intro} applies the tactic {\tt hnf} until the tactic \end{Variants} -\subsection{\tt intros {\intropattern} \mbox{\dots} \intropattern} +\subsection{\tt intros {\intropatternlist}} \label{intros-pattern} \tacindex{intros \intropattern} \index{Introduction patterns} @@ -802,9 +811,11 @@ the tactic {\tt intro} applies the tactic {\tt hnf} until the tactic \index{Disjunctive/conjunctive introduction patterns} \index{Equality introduction patterns} - -This extension of the tactic {\tt intros} combines introduction of -variables or hypotheses and case analysis. An {\em introduction pattern} is +This extension of the tactic {\tt intros} allows to apply tactics on +the fly on the variables or hypotheses which have been introduced. An +{\em introduction pattern list} {\intropatternlist} is a list of +introduction patterns possibly containing the filling introduction +patterns {\tt *} and {\tt **}. An {\em introduction pattern} is either: \begin{itemize} \item a {\em naming introduction pattern}, i.e. either one of: @@ -813,12 +824,12 @@ either: \item the pattern \texttt{?\ident} \item an identifier \end{itemize} -\item a {\em destructing introduction pattern} which itself classifies into: +\item an {\em action introduction pattern} which itself classifies into: \begin{itemize} \item a {\em disjunctive/conjunctive introduction pattern}, i.e. either one of: \begin{itemize} \item a disjunction of lists of patterns: - {\tt [$p_{11}$ \dots\ $p_{1m_1}$ | \dots\ | $p_{11}$ \dots\ $p_{nm_n}$]} + {\tt [$\intropatternlist_1$ | \dots\ | $\intropatternlist_n$]} \item a conjunction of patterns: {\tt ($p_1$ , \dots\ , $p_n$)} \item a list of patterns {\tt ($p_1$ \&\ \dots\ \&\ $p_n$)} for sequence of right-associative binary constructs @@ -828,15 +839,13 @@ either: \item a pattern for decomposing an equality: {\tt [= $p_1$ \dots\ $p_n$]} \item the rewriting orientations: {\tt ->} or {\tt <-} \end{itemize} - \item the on-the-fly application of a lemma: $p${\tt /{\term}} + \item the on-the-fly application of lemmas: $p${\tt \%{\term$_1$}} + \ldots {\tt \%{\term$_n$}} where $p$ itself is not a pattern for + on-the-fly application of lemmas (note: syntax is in experimental stage) \end{itemize} \item the wildcard: {\tt \_} \end{itemize} -Introduction patterns can be combined into lists. An {\em introduction - pattern list} is a list of introduction patterns possibly containing -the filling introduction patterns {\tt *} and {\tt **}. - Assuming a goal of type $Q \to P$ (non-dependent product), or of type $\forall x:T,~P$ (dependent product), the behavior of {\tt intros $p$} is defined inductively over the structure of the @@ -849,20 +858,22 @@ introduction pattern~$p$: \item introduction on \texttt{\ident} behaves as described in Section~\ref{intro}; \item introduction over a disjunction of list of patterns {\tt - [$p_{11}$ \dots\ $p_{1m_1}$ | \dots\ | $p_{11}$ \dots\ $p_{nm_n}$]} - expects the product to be over an inductive type - whose number of constructors is $n$ (or more generally over a type - of conclusion an inductive type built from $n$ constructors, - e.g. {\tt C -> A\textbackslash/B if $n=2$}): it destructs the introduced - hypothesis as {\tt destruct} (see Section~\ref{destruct}) would and - applies on each generated subgoal the corresponding tactic; - \texttt{intros}~$p_{i1}$ {\ldots} $p_{im_i}$; if the disjunctive - pattern is part of a sequence of patterns and is not the last - pattern of the sequence, then {\Coq} completes the pattern so that all - the argument of the constructors of the inductive type are - introduced (for instance, the list of patterns {\tt [$\;$|$\;$] H} - applied on goal {\tt forall x:nat, x=0 -> 0=x} behaves the same as - the list of patterns {\tt [$\,$|$\,$?$\,$] H}); + [$\intropatternlist_{1}$ | \dots\ | $\intropatternlist_n$]} expects + the product to be over an inductive type whose number of + constructors is $n$ (or more generally over a type of conclusion an + inductive type built from $n$ constructors, e.g. {\tt C -> + A\textbackslash/B} with $n=2$ since {\tt A\textbackslash/B} has 2 + constructors): it destructs the introduced hypothesis as {\tt + destruct} (see Section~\ref{destruct}) would and applies on each + generated subgoal the corresponding tactic; + \texttt{intros}~$\intropatternlist_i$. The introduction patterns in + $\intropatternlist_i$ are expected to consume no more than the + number of arguments of the $i^{\mbox{\scriptsize th}}$ + constructor. If it consumes less, then {\Coq} completes the pattern + so that all the arguments of the constructors of the inductive type + are introduced (for instance, the list of patterns {\tt [$\;$|$\;$] + H} applied on goal {\tt forall x:nat, x=0 -> 0=x} behaves the same + as the list of patterns {\tt [$\,$|$\,$?$\,$] H}); \item introduction over a conjunction of patterns {\tt ($p_1$, \ldots, $p_n$)} expects the goal to be a product over an inductive type $I$ with a single constructor that itself has at least $n$ arguments: it @@ -876,10 +887,10 @@ introduction pattern~$p$: {\tt ($p_1$,(\ldots,(\dots,$p_n$)\ldots))}; it expects the hypothesis to be a sequence of right-associative binary inductive constructors such as {\tt conj} or {\tt ex\_intro}; for instance, an - hypothesis with type {\tt A\verb|/\|exists x, B\verb|/\|C\verb|/\|D} can be + hypothesis with type {\tt A\verb|/\|(exists x, B\verb|/\|C\verb|/\|D)} can be introduced via pattern {\tt (a \& x \& b \& c \& d)}; \item if the product is over an equality type, then a pattern of the - form {\tt [=$p_{1}$ \dots\ $p_n$]} applies either {\tt injection} + form {\tt [= $p_{1}$ \dots\ $p_n$]} applies either {\tt injection} (see Section~\ref{injection}) or {\tt discriminate} (see Section~\ref{discriminate}) instead of {\tt destruct}; if {\tt injection} is applicable, the patterns $p_1$, \ldots, $p_n$ are @@ -896,9 +907,10 @@ introduction pattern~$p$: itself is erased; if the term to substitute is a variable, it is substituted also in the context of goal and the variable is removed too; -\item introduction over a pattern $p${\tt /{\term}} first applies - {\term} on the hypothesis to be introduced (as in {\tt apply - }{\term} {\tt in}), prior to the application of the introduction +\item introduction over a pattern $p${\tt \%{\term$_1$}} \ldots {\tt + \%{\term$_n$}} first applies {\term$_1$},\ldots, {\term$_n$} on the + hypothesis to be introduced (as in {\tt apply }{\term}$_1$, \ldots, + {\term}$_n$ {\tt in}) prior to the application of the introduction pattern $p$; \item introduction on the wildcard depends on whether the product is dependent or not: in the non-dependent case, it erases the @@ -913,19 +925,6 @@ introduction pattern~$p$: not any more a quantification or an implication. \end{itemize} -Then, if $p_1$ ... $p_n$ is a list of introduction patterns possibly -containing {\tt *} or {\tt **}, {\tt intros $p_1$ ... $p_n$} -\begin{itemize} -\item introduction over {\tt *} introduces all forthcoming quantified - variables appearing in a row; -\item introduction over {\tt **} introduces all forthcoming quantified - variables or hypotheses until the goal is not any more a - quantification or an implication; -\item introduction over an introduction pattern $p$ introduces the - forthcoming quantified variables or premise of the goal and applies - the introduction pattern $p$ to it. -\end{itemize} - \Example \begin{coq_example} @@ -936,28 +935,38 @@ intros * [a | (_,c)] f. Abort. \end{coq_eval} -\Rem {\tt intros $p_1~\ldots~p_n$} is not fully equivalent to -\texttt{intros $p_1$;\ldots; intros $p_n$} for the following reasons: -\begin{itemize} -\item A wildcard pattern never succeeds when applied isolated on a - dependent product, while it succeeds as part of a list of - introduction patterns if the hypotheses that depends on it are - erased too. -\item A disjunctive or conjunctive pattern followed by an introduction - pattern forces the introduction in the context of all arguments of - the constructors before applying the next pattern while a terminal - disjunctive or conjunctive pattern does not. Here is an example +\Rem {\tt intros $p_1~\ldots~p_n$} is not equivalent to \texttt{intros + $p_1$;\ldots; intros $p_n$} for the following reason: If one of the +$p_i$ is a wildcard pattern, he might succeed in the first case +because the further hypotheses it depends in are eventually erased too +while it might fail in the second case because of dependencies in +hypotheses which are not yet introduced (and a fortiori not yet +erased). + +\Rem In {\tt intros $\intropatternlist$}, if the last introduction +pattern is a disjunctive or conjunctive pattern {\tt + [$\intropatternlist_1$ | \dots\ | $\intropatternlist_n$]}, the +completion of $\intropatternlist_i$ so that all the arguments of the +$i^{\mbox{\scriptsize th}}$ constructors of the corresponding +inductive type are introduced can be controlled with the +following option: +\optindex{Bracketing Last Introduction Pattern} + +\begin{quote} +{\tt Set Bracketing Last Introduction Pattern} +\end{quote} + +Force completion, if needed, when the last introduction pattern is a +disjunctive or conjunctive pattern (this is the default). + +\begin{quote} +{\tt Unset Bracketing Last Introduction Pattern} +\end{quote} + +Deactivate completion when the last introduction pattern is a disjunctive +or conjunctive pattern. -\begin{coq_example} -Goal forall n:nat, n = 0 -> n = 0. -intros [ | ] H. -Show 2. -Undo. -intros [ | ]; intros H. -Show 2. -\end{coq_example} -\end{itemize} \subsection{\tt clear \ident} \tacindex{clear} @@ -1246,18 +1255,9 @@ in the list of subgoals remaining to prove. introduction pattern (in particular, if {\intropattern} is {\ident}, the tactic behaves like \texttt{assert ({\ident} :\ {\form})}). - If {\intropattern} is a disjunctive/conjunctive - introduction pattern, the tactic behaves like \texttt{assert - {\form}} followed by a {\tt destruct} using this introduction pattern. - - If {\intropattern} is a rewriting intropattern pattern, the tactic - behaves like \texttt{assert {\form}} followed by a call to {\tt - subst} on the resulting hypothesis, if applicable, or to {\tt - rewrite} otherwise. - - If {\intropattern} is an injection intropattern pattern, the tactic - behaves like \texttt{assert {\form}} followed by {\tt injection} - using this introduction pattern. + If {\intropattern} is an action introduction pattern, the tactic + behaves like \texttt{assert {\form}} followed by the action done by + this introduction pattern. \item \texttt{assert {\form} as {\intropattern} by {\tac}} @@ -1456,6 +1456,24 @@ a hypothesis or in the body or the type of a local definition. \end{Variants} +\subsection{\tt admit} +\tacindex{admit} +\tacindex{give\_up} +\label{admit} + +The {\tt admit} tactic allows temporarily skipping a subgoal so as to +progress further in the rest of the proof. A proof containing +admitted goals cannot be closed with {\tt Qed} but only with +{\tt Admitted}. + +\begin{Variants} + + \item {\tt give\_up} + + Synonym of {\tt admit}. + +\end{Variants} + \subsection{\tt absurd \term} \tacindex{absurd} \label{absurd} @@ -1528,25 +1546,27 @@ for each possible form of {\term}, i.e. one for each constructor of the inductive or co-inductive type. Unlike {\tt induction}, no induction hypothesis is generated by {\tt destruct}. -If the argument is dependent in either the conclusion or some -hypotheses of the goal, the argument is replaced by the appropriate -constructor form in each of the resulting subgoals, thus performing -case analysis. If non-dependent, the tactic simply exposes the -inductive or co-inductive structure of the argument. - There are special cases: \begin{itemize} \item If {\term} is an identifier {\ident} denoting a quantified -variable of the conclusion of the goal, then {\tt destruct {\ident}} -behaves as {\tt intros until {\ident}; destruct {\ident}}. + variable of the conclusion of the goal, then {\tt destruct {\ident}} + behaves as {\tt intros until {\ident}; destruct {\ident}}. If + {\ident} is not anymore dependent in the goal after application of + {\tt destruct}, it is erased (to avoid erasure, use + parentheses, as in {\tt destruct ({\ident})}). \item If {\term} is a {\num}, then {\tt destruct {\num}} behaves as {\tt intros until {\num}} followed by {\tt destruct} applied to the last introduced hypothesis. Remark: For destruction of a numeral, use syntax {\tt destruct ({\num})} (not very interesting anyway). +\item In case {\term} is an hypothesis {\ident} of the context, + and {\ident} is not anymore dependent in the goal after + application of {\tt destruct}, it is erased (to avoid erasure, use + parentheses, as in {\tt destruct ({\ident})}). + \item The argument {\term} can also be a pattern of which holes are denoted by ``\_''. In this case, the tactic checks that all subterms matching the pattern in the conclusion and the hypotheses are @@ -1623,14 +1643,6 @@ syntax {\tt destruct ({\num})} (not very interesting anyway). They combine the effects of the {\tt with}, {\tt as}, {\tt eqn:}, {\tt using}, and {\tt in} clauses. -\item{\tt destruct !{\ident}} - - This is a case when the destructed term is an hypothesis of the - context. The ``!'' modifier tells to keep the hypothesis in the - context after destruction. - - This applies also to the other form of {\tt destruct} and {\tt edestruct}. - \item{\tt case \term}\label{case}\tacindex{case} The tactic {\tt case} is a more basic tactic to perform case @@ -1696,14 +1708,22 @@ There are particular cases: \begin{itemize} \item If {\term} is an identifier {\ident} denoting a quantified -variable of the conclusion of the goal, then {\tt induction {\ident}} -behaves as {\tt intros until {\ident}; induction {\ident}}. + variable of the conclusion of the goal, then {\tt induction + {\ident}} behaves as {\tt intros until {\ident}; induction + {\ident}}. If {\ident} is not anymore dependent in the goal + after application of {\tt induction}, it is erased (to avoid + erasure, use parentheses, as in {\tt induction ({\ident})}). \item If {\term} is a {\num}, then {\tt induction {\num}} behaves as {\tt intros until {\num}} followed by {\tt induction} applied to the last introduced hypothesis. Remark: For simple induction on a numeral, use syntax {\tt induction ({\num})} (not very interesting anyway). +\item In case {\term} is an hypothesis {\ident} of the context, + and {\ident} is not anymore dependent in the goal after + application of {\tt induction}, it is erased (to avoid erasure, use + parentheses, as in {\tt induction ({\ident})}). + \item The argument {\term} can also be a pattern of which holes are denoted by ``\_''. In this case, the tactic checks that all subterms matching the pattern in the conclusion and the hypotheses are @@ -1818,15 +1838,6 @@ Show 2. einduction}. It combines the effects of the {\tt with}, {\tt as}, %%{\tt eqn:}, {\tt using}, and {\tt in} clauses. -\item{\tt induction !{\ident}} - - This is a case when the term on which to apply induction is an - hypothesis of the context. The ``!'' modifier tells to keep the - hypothesis in the context after induction. - - This applies also to the other form of {\tt induction} and {\tt - einduction}. - \item {\tt elim \term}\label{elim} This is a more basic induction tactic. Again, the type of the @@ -3015,23 +3026,33 @@ variables bound by a let-in construction inside the term itself (use here the {\tt zeta} flag). In any cases, opaque constants are not unfolded (see Section~\ref{Opaque}). -The goal may be normalized with two strategies: {\em lazy} ({\tt lazy} -tactic), or {\em call-by-value} ({\tt cbv} tactic). The lazy strategy -is a call-by-need strategy, with sharing of reductions: the arguments of a -function call are partially evaluated only when necessary, and if an -argument is used several times then it is computed only once. This -reduction is efficient for reducing expressions with dead code. For -instance, the proofs of a proposition {\tt exists~$x$. $P(x)$} reduce to a -pair of a witness $t$, and a proof that $t$ satisfies the predicate -$P$. Most of the time, $t$ may be computed without computing the proof -of $P(t)$, thanks to the lazy strategy. +Normalization according to the flags is done by first evaluating the +head of the expression into a {\em weak-head} normal form, i.e. until +the evaluation is bloked by a variable (or an opaque constant, or an +axiom), as e.g. in {\tt x\;u$_1$\;...\;u$_n$}, or {\tt match x with + ... end}, or {\tt (fix f x \{struct x\} := ...) x}, or is a +constructed form (a $\lambda$-expression, a constructor, a cofixpoint, +an inductive type, a product type, a sort), or is a redex that the +flags prevent to reduce. Once a weak-head normal form is obtained, +subterms are recursively reduced using the same strategy. + +Reduction to weak-head normal form can be done using two strategies: +{\em lazy} ({\tt lazy} tactic), or {\em call-by-value} ({\tt cbv} +tactic). The lazy strategy is a call-by-need strategy, with sharing of +reductions: the arguments of a function call are weakly evaluated only +when necessary, and if an argument is used several times then it is +weakly computed only once. This reduction is efficient for reducing +expressions with dead code. For instance, the proofs of a proposition +{\tt exists~$x$. $P(x)$} reduce to a pair of a witness $t$, and a +proof that $t$ satisfies the predicate $P$. Most of the time, $t$ may +be computed without computing the proof of $P(t)$, thanks to the lazy +strategy. The call-by-value strategy is the one used in ML languages: the -arguments of a function call are evaluated first, using a weak -reduction (no reduction under the $\lambda$-abstractions). Despite the -lazy strategy always performs fewer reductions than the call-by-value -strategy, the latter is generally more efficient for evaluating purely -computational expressions (i.e. with few dead code). +arguments of a function call are systematically weakly evaluated +first. Despite the lazy strategy always performs fewer reductions than +the call-by-value strategy, the latter is generally more efficient for +evaluating purely computational expressions (i.e. with few dead code). \begin{Variants} \item {\tt compute} \tacindex{compute}\\ @@ -3559,7 +3580,7 @@ The hints for \texttt{auto} and \texttt{eauto} are stored in databases. Each database maps head symbols to a list of hints. One can use the command \texttt{Print Hint \ident} to display the hints associated to the head symbol \ident{} (see \ref{PrintHint}). Each -hint has a cost that is an nonnegative integer, and an optional pattern. +hint has a cost that is a nonnegative integer, and an optional pattern. The hints with lower cost are tried first. A hint is tried by \texttt{auto} when the conclusion of the current goal matches its pattern or when it has no pattern. @@ -3627,9 +3648,6 @@ The {\hintdef} is one of the following expressions: the number of subgoals generated by {\tt simple apply {\term}}. %{\tt auto} actually uses a slightly modified variant of {\tt simple apply} with use_metas_eagerly_in_conv_on_closed_terms set to false - The cost of that hint is the number of subgoals generated by that - tactic. - % Is it really needed? %% In case the inferred type of \term\ does not start with a product %% the tactic added in the hint list is {\tt exact {\term}}. In case @@ -3776,7 +3794,7 @@ Hint Extern 4 (~(_ = _)) => discriminate. with hints with a cost less than 4. One can even use some sub-patterns of the pattern in the tactic - script. A sub-pattern is a question mark followed by an ident, like + script. A sub-pattern is a question mark followed by an identifier, like \texttt{?X1} or \texttt{?X2}. Here is an example: % Require EqDecide. @@ -3788,37 +3806,71 @@ Hint Extern 5 ({?X1 = ?X2} + {?X1 <> ?X2}) => generalize X1, X2; decide equality : eqdec. Goal forall a b:list (nat * nat), {a = b} + {a <> b}. -info_auto with eqdec. +Info 1 auto with eqdec. \end{coq_example} \begin{coq_eval} Abort. \end{coq_eval} +\item \texttt{Cut} {\textit{regexp}} +\label{HintCut} +\comindex{Hint Cut} + + \textit{Warning:} these hints currently only apply to typeclass proof search and + the \texttt{typeclasses eauto} tactic. + + This command can be used to cut the proof-search tree according to a + regular expression matching paths to be cut. The grammar for regular + expressions is the following: +\[\begin{array}{lcll} + e & ::= & \ident & \text{ hint or instance identifier } \\ + & & \texttt{*} & \text{ any hint } \\ + & & e | e' & \text{ disjunction } \\ + & & e ; e' & \text{ sequence } \\ + & & ! e & \text{ Kleene star } \\ + & & \texttt{emp} & \text{ empty } \\ + & & \texttt{eps} & \text{ epsilon } \\ + & & \texttt{(} e \texttt{)} & +\end{array}\] + +The \texttt{emp} regexp does not match any search path while +\texttt{eps} matches the empty path. During proof search, the path of +successive successful hints on a search branch is recorded, as a list of +identifiers for the hints (note \texttt{Hint Extern}'s do not have an +associated identifier). Before applying any hint $\ident$ the current +path $p$ extended with $\ident$ is matched against the current cut +expression $c$ associated to the hint database. If matching succeeds, +the hint is \emph{not} applied. The semantics of \texttt{Hint Cut} $e$ +is to set the cut expression to $c | e$, the initial cut expression +being \texttt{emp}. + + +\item \texttt{Mode} {\tt (+ | -)}$^*$ {\qualid} +\label{HintMode} +\comindex{Hint Mode} + +This sets an optional mode of use of the identifier {\qualid}. When +proof-search faces a goal that ends in an application of {\qualid} to +arguments {\tt \term$_1$ \mbox{\dots} \term$_n$}, the mode tells if the +hints associated to qualid can be applied or not. A mode specification +is a list of $n$ {\tt +} or {\tt -} items that specify if an argument is +to be treated as an input {\tt +} or an output {\tt -} of the +identifier. For a mode to match a list of arguments, input terms \emph{must +not} contain existential variables, while outputs can be any term. +Multiple modes can be declared for a single identifier, in that case +only one mode needs to match the arguments for the hints to be applied. + +{\tt Hint Mode} is especially useful for typeclasses, when one does not +want to support default instances and avoid ambiguity in +general. Setting a parameter of a class as an input forces proof-search +to be driven by that index of the class. + \end{itemize} \Rem One can use an \texttt{Extern} hint with no pattern to do pattern-matching on hypotheses using \texttt{match goal with} inside the tactic. -\begin{Variants} -\item {\tt Hint \hintdef} - - No database name is given: the hint is registered in the {\tt core} - database. - -\item {\tt Hint Local {\hintdef} : \ident$_1$ \mbox{\dots} \ident$_n$} - - This is used to declare hints that must not be exported to the other - modules that require and import the current module. Inside a - section, the option {\tt Local} is useless since hints do not - survive anyway to the closure of sections. - -\item {\tt Hint Local \hintdef} - - Idem for the {\tt core} database. - -\end{Variants} - % There are shortcuts that allow to define several goal at once: % \begin{itemize} @@ -4082,6 +4134,7 @@ The tactic {\tt exists (n // m)} did not fail. The hole was solved by \subsection{\tt tauto} \tacindex{tauto} +\tacindex{dtauto} \label{tauto} This tactic implements a decision procedure for intuitionistic propositional @@ -4130,8 +4183,21 @@ Abort. because \verb=(forall x:nat, ~ A -> P x)= cannot be treated as atomic and an instantiation of \verb=x= is necessary. +\begin{Variants} + +\item {\tt dtauto} + + While {\tt tauto} recognizes inductively defined connectives + isomorphic to the standard connective {\tt and}, {\tt prod}, {\tt + or}, {\tt sum}, {\tt False}, {\tt Empty\_set}, {\tt unit}, {\tt + True}, {\tt dtauto} recognizes also all inductive types with + one constructors and no indices, i.e. record-style connectives. + +\end{Variants} + \subsection{\tt intuition \tac} \tacindex{intuition} +\tacindex{dintuition} \label{intuition} The tactic \texttt{intuition} takes advantage of the search-tree built @@ -4164,8 +4230,49 @@ incompatibilities. \item {\tt intuition} Is equivalent to {\tt intuition auto with *}. + +\item {\tt dintuition} + + While {\tt intuition} recognizes inductively defined connectives + isomorphic to the standard connective {\tt and}, {\tt prod}, {\tt + or}, {\tt sum}, {\tt False}, {\tt Empty\_set}, {\tt unit}, {\tt + True}, {\tt dintuition} recognizes also all inductive types with + one constructors and no indices, i.e. record-style connectives. + \end{Variants} +\optindex{Intuition Negation Unfolding} +\optindex{Intuition Iff Unfolding} + +Some aspects of the tactic {\tt intuition} can be +controlled using options. To avoid that inner negations which do not +need to be unfolded are unfolded, use: + +\begin{quote} +{\tt Unset Intuition Negation Unfolding} +\end{quote} + +To do that all negations of the goal are unfolded even inner ones +(this is the default), use: + +\begin{quote} +{\tt Set Intuition Negation Unfolding} +\end{quote} + +To avoid that inner occurrence of {\tt iff} which do not need to be +unfolded are unfolded (this is the default), use: + +\begin{quote} +{\tt Unset Intuition Iff Unfolding} +\end{quote} + +To do that all negations of the goal are unfolded even inner ones +(this is the default), use: + +\begin{quote} +{\tt Set Intuition Iff Unfolding} +\end{quote} + % En attente d'un moyen de valoriser les fichiers de demos %\SeeAlso file \texttt{contrib/Rocq/DEMOS/Demo\_tauto.v} @@ -4641,7 +4748,7 @@ Use \texttt{classical\_right} to prove the right part of the disjunction with th %% procedure for first-order intuitionistic logic implemented in {\em %% NuPRL}\cite{Kre02}. -%% Search may optionnaly be bounded by a multiplicity parameter +%% Search may optionally be bounded by a multiplicity parameter %% indicating how many (at most) copies of a formula may be used in %% the proof process, its absence may lead to non-termination of the tactic. @@ -4933,8 +5040,8 @@ back into focus with the command {\tt Unshelve} (Section~\ref{unshelve}). \begin{Variants} \item \texttt{shelve\_unifiable}\tacindex{shelve\_unifiable} - Shelves only these goals under focused which are mentioned in other goals. - Goals which appear in the type of other goals can be solve by unification. + Shelves only the goals under focus that are mentioned in other goals. + Goals that appear in the type of other goals can be solved by unification. \Example \begin{coq_example} diff --git a/doc/refman/Reference-Manual.tex b/doc/refman/Reference-Manual.tex index ac28e0ba0..dcb98d96b 100644 --- a/doc/refman/Reference-Manual.tex +++ b/doc/refman/Reference-Manual.tex @@ -20,6 +20,11 @@ \usepackage{headers} % in this directory \usepackage{multicol} \usepackage{xspace} +\usepackage{pmboxdraw} +\usepackage{float} + +\floatstyle{boxed} +\restylefloat{figure} % for coqide \ifpdf % si on est pas en pdflatex diff --git a/doc/refman/Universes.tex b/doc/refman/Universes.tex index cd8222269..a08cd1475 100644 --- a/doc/refman/Universes.tex +++ b/doc/refman/Universes.tex @@ -7,14 +7,12 @@ \asection{General Presentation} \begin{flushleft} - \em The status of Universe Polymorphism is experimental. Some features - are not compatible with it (yet): bytecode compilation does not handle - polymorphic definitions, it treats them as opaque constants. + \em The status of Universe Polymorphism is experimental. \end{flushleft} This section describes the universe polymorphic extension of Coq. -Universe polymorphism allows writing generic definitions making use of -universes and reuse them at different and sometimes incompatible levels. +Universe polymorphism makes it possible to write generic definitions making use of +universes and reuse them at different and sometimes incompatible universe levels. A standard example of the difference between universe \emph{polymorphic} and \emph{monomorphic} definitions is given by the identity function: @@ -65,11 +63,11 @@ Now \texttt{pidentity} is used at two different levels: at the head of the application it is instantiated at \texttt{Top.3} while in the argument position it is instantiated at \texttt{Top.4}. This definition is only valid as long as \texttt{Top.4} is strictly smaller than -\texttt{Top.3}, as show by the constraints. Not that this definition is -monomorphic (not universe polymorphic), so in turn the two universes are -actually global levels. +\texttt{Top.3}, as show by the constraints. Note that this definition is +monomorphic (not universe polymorphic), so the two universes +(in this case \texttt{Top.3} and \texttt{Top.4}) are actually global levels. -Inductive types can also be declared universes polymorphic, on universes +Inductive types can also be declared universes polymorphic on universes appearing in their parameters or fields. A typical example is given by monoids: @@ -81,7 +79,7 @@ Print Monoid. The \texttt{Monoid}'s carrier universe is polymorphic, hence it is possible to instantiate it for example with \texttt{Monoid} itself. -First we build the trivial unit monoid, in \texttt{Set}: +First we build the trivial unit monoid in \texttt{Set}: \begin{coq_example} Definition unit_monoid : Monoid := {| mon_car := unit; mon_unit := tt; mon_op x y := tt |}. @@ -119,18 +117,28 @@ producing global universe constraints, one can use the \begin{itemize} \item \texttt{Lemma}, \texttt{Axiom}, and all the other ``definition'' keywords support polymorphism. -\item \texttt{Variables}, \texttt{Context} in a section support polymorphism. - This means that the - variables are discharged polymorphically over definitions that use - them. In other words, two definitions in the section sharing a common - variable will both get parameterized by the universes produced by the - variable declaration. This is in contrast to a ``mononorphic'' variable - which introduces global universes, making the two definitions depend on - the \emph{same} global universes associated to the variable. +\item \texttt{Variables}, \texttt{Context}, \texttt{Universe} and + \texttt{Constraint} in a section support polymorphism. This means + that the universe variables (and associated constraints) are + discharged polymorphically over definitions that use them. In other + words, two definitions in the section sharing a common variable will + both get parameterized by the universes produced by the variable + declaration. This is in contrast to a ``mononorphic'' variable which + introduces global universes and constraints, making the two + definitions depend on the \emph{same} global universes associated to + the variable. \item \texttt{Hint \{Resolve, Rewrite\}} will use the auto/rewrite hint polymorphically, not at a single instance. \end{itemize} +\asection{Global and local universes} + +Each universe is declared in a global or local environment before it can +be used. To ensure compatibility, every \emph{global} universe is set to +be strictly greater than \Set~when it is introduced, while every +\emph{local} (i.e. polymorphically quantified) universe is introduced as +greater or equal to \Set. + \asection{Conversion and unification} The semantics of conversion and unification have to be modified a little @@ -151,6 +159,7 @@ unification can have different unfolding behaviors on the same development with universe polymorphism switched on or off. \asection{Minimization} +\optindex{Universe Minimization ToSet} Universe polymorphism with cumulativity tends to generate many useless inclusion constraints in general. Typically at each application of a @@ -173,23 +182,48 @@ This definition is elaborated by minimizing the universe of id to level generated at the application of id and a constraint that $\Set \le i$. This minimization process is applied only to fresh universe variables. It simply adds an equation between the variable and its lower -bound if it is an atomic universe (i.e. not an algebraic max()). +bound if it is an atomic universe (i.e. not an algebraic \texttt{max()} +universe). -\asection{Explicit Universes} +The option \texttt{Unset Universe Minimization ToSet} disallows +minimization to the sort $\Set$ and only collapses floating universes +between themselves. -\begin{flushleft} - \em The design and implementation of explicit universes is very - experimental and is likely to change in future versions. -\end{flushleft} +\asection{Explicit Universes} The syntax has been extended to allow users to explicitly bind names to -universes and explicitly instantiate polymorphic -definitions. Currently, binding is implicit at the first occurrence of a -universe name. For example, i and j below are introduced by the -annotations attached to Types. +universes and explicitly instantiate polymorphic definitions. + +\subsection{\tt Universe {\ident}. + \comindex{Universe} + \label{UniverseCmd}} + +In the monorphic case, this command declares a new global universe named +{\ident}. It supports the polymorphic flag only in sections, meaning the +universe quantification will be discharged on each section definition +independently. + +\subsection{\tt Constraint {\ident} {\textit{ord}} {\ident}. + \comindex{Constraint} + \label{ConstraintCmd}} + +This command declares a new constraint between named universes. +The order relation can be one of $<$, $\le$ or $=$. If consistent, +the constraint is then enforced in the global environment. Like +\texttt{Universe}, it can be used with the \texttt{Polymorphic} prefix +in sections only to declare constraints discharged at section closing time. + +\begin{ErrMsgs} +\item \errindex{Undeclared universe {\ident}}. +\item \errindex{Universe inconsistency} +\end{ErrMsgs} + +\subsection{Polymorphic definitions} +For polymorphic definitions, the declaration of (all) universe levels +introduced by a definition uses the following syntax: \begin{coq_example*} -Polymorphic Definition le (A : Type@{i}) : Type@{j} := A. +Polymorphic Definition le@{i j} (A : Type@{i}) : Type@{j} := A. \end{coq_example*} \begin{coq_example} Print le. @@ -197,40 +231,32 @@ Print le. During refinement we find that $j$ must be larger or equal than $i$, as we are using $A : Type@{i} <= Type@{j}$, hence the generated -constraint. Note that the names here are not bound in the final -definition, they just allow to specify locally what relations should -hold. In the term and in general in proof mode, universe names -introduced in the types can be referred to in terms. +constraint. At the end of a definition or proof, we check that the only +remaining universes are the ones declared. In the term and in general in +proof mode, introduced universe names can be referred to in +terms. Note that local universe names shadow global universe names. +During a proof, one can use \texttt{Show Universes} to display +the current context of universes. Definitions can also be instantiated explicitly, giving their full instance: \begin{coq_example} Check (pidentity@{Set}). -Check (le@{i j}). +Universes k l. +Check (le@{k l}). \end{coq_example} User-named universes are considered rigid for unification and are never minimized. -Finally, two commands allow to name \emph{global} universes and constraints. - -\subsection{\tt Universe {\ident}. - \comindex{Universe} - \label{UniverseCmd}} - -This command declare a new global universe named {\ident}. +\subsection{\tt Unset Strict Universe Declaration. + \optindex{Strict Universe Declaration} + \label{StrictUniverseDeclaration}} -\subsection{\tt Constraint {\ident} {\textit{ord}} {\ident}. - \comindex{Constraint} - \label{ConstraintCmd}} - -This command declare a new constraint between named universes. -The order relation can be one of $<$, $<=$ or $=$. If consistent, -the constraint is then enforced in the global environment. - -\begin{ErrMsgs} -\item \errindex{Undeclared universe {\ident}}. -\item \errindex{Universe inconsistency} -\end{ErrMsgs} +The command \texttt{Unset Strict Universe Declaration} allows one to +freely use identifiers for universes without declaring them first, with +the semantics that the first use declares it. In this mode, the universe +names are not associated with the definition or proof once it has been +defined. This is meant mainly for debugging purposes. %%% Local Variables: %%% mode: latex diff --git a/doc/refman/biblio.bib b/doc/refman/biblio.bib index d78ce4f2c..70ee1f41f 100644 --- a/doc/refman/biblio.bib +++ b/doc/refman/biblio.bib @@ -288,9 +288,14 @@ s}, @InProceedings{Coquand93, author = {Th. Coquand}, - title = {{Infinite Objects in Type Theory}}, + booktitle = {Types for Proofs and Programs}, + editor = {H. Barendregt and T. Nipokow}, + publisher = SV, + series = LNCS, + title = {{Infinite objects in Type Theory}}, + volume = {806}, year = {1993}, - crossref = {Nijmegen93} + pages = {62-78} } @inproceedings{Corbineau08types, @@ -323,6 +328,15 @@ s}, year = {1994} } +@book{Cur58, + author = {Haskell B. Curry and Robert Feys and William Craig}, + title = {Combinatory Logic}, + volume = 1, + publisher = "North-Holland", + year = 1958, + note = {{\S{9E}}}, +} + @InProceedings{Del99, author = {Delahaye, D.}, title = {Information Retrieval in a Coq Proof Library using @@ -540,6 +554,13 @@ s}, year = {1994} } +@PhDThesis{Gim96, + author = {E. Gim\'enez}, + title = {Un calcul des constructions infinies et son application \'a la v\'erification de syst\`emes communicants}, + school = {\'Ecole Normale Sup\'erieure de Lyon}, + year = {1996} +} + @TechReport{Gim98, author = {E. Gim\'enez}, title = {A Tutorial on Recursive Types in Coq}, @@ -660,6 +681,13 @@ s}, year = {1989} } +@Unpublished{Hue88b, + author = {G. Huet}, + title = {Extending the Calculus of Constructions with Type:Type}, + year = 1988, + note = {Unpublished} +} + @Book{Hue89, editor = {G. Huet}, publisher = {Addison-Wesley}, @@ -1366,4 +1394,4 @@ Languages}, timestamp = {Thu, 17 Nov 2011 13:33:48 +0100}, biburl = {http://dblp.uni-trier.de/rec/bib/conf/cpp/BoespflugDG11}, bibsource = {dblp computer science bibliography, http://dblp.org} -}
\ No newline at end of file +} diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index 866193ffb..a12983ab8 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -59,6 +59,7 @@ through the <tt>Require Import</tt> command.</p> theories/Logic/WeakFan.v theories/Logic/WKL.v theories/Logic/FinFun.v + theories/Logic/PropFacts.v </dd> <dt> <b>Structures</b>: @@ -476,13 +477,6 @@ through the <tt>Require Import</tt> command.</p> theories/MSets/MSetPositive.v theories/MSets/MSetToFiniteSet.v (theories/MSets/MSets.v) - theories/MMaps/MMapAVL.v - theories/MMaps/MMapFacts.v - theories/MMaps/MMapInterface.v - theories/MMaps/MMapList.v - theories/MMaps/MMapPositive.v - theories/MMaps/MMapWeakList.v - (theories/MMaps/MMaps.v) </dd> <dt> <b>FSets</b>: @@ -617,6 +611,7 @@ through the <tt>Require Import</tt> command.</p> Compatibility wrappers for previous versions of Coq </dt> <dd> + theories/Compat/AdmitAxiom.v theories/Compat/Coq84.v theories/Compat/Coq85.v </dd> diff --git a/engine/engine.mllib b/engine/engine.mllib index 7197a2583..70b74edca 100644 --- a/engine/engine.mllib +++ b/engine/engine.mllib @@ -5,3 +5,5 @@ UState Evd Sigma Proofview_monad +Evarutil +Proofview diff --git a/pretyping/evarutil.ml b/engine/evarutil.ml index bc9f08331..2bd67dcdc 100644 --- a/pretyping/evarutil.ml +++ b/engine/evarutil.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -12,14 +12,16 @@ open Pp open Names open Term open Vars -open Context open Termops open Namegen open Pre_env open Environ open Evd -open Reductionops -open Pretype_errors +open Sigma.Notations + +let safe_evar_value sigma ev = + try Some (Evd.existential_value sigma ev) + with NotInstantiatedEvar | Not_found -> None (** Combinators *) @@ -42,7 +44,7 @@ let e_new_global evdref x = evd_comb1 (Evd.fresh_global (Global.env())) evdref x let new_global evd x = - Evd.fresh_global (Global.env()) evd x + Sigma.fresh_global (Global.env()) evd x (****************************************************) (* Expanding/testing/exposing existential variables *) @@ -62,31 +64,41 @@ let rec flush_and_check_evars sigma c = (* let nf_evar_key = Profile.declare_profile "nf_evar" *) (* let nf_evar = Profile.profile2 nf_evar_key Reductionops.nf_evar *) -let nf_evar = Reductionops.nf_evar + +let rec whd_evar sigma c = + match kind_of_term c with + | Evar ev -> + let (evk, args) = ev in + let args = Array.map (fun c -> whd_evar sigma c) args in + (match safe_evar_value sigma (evk, args) with + Some c -> whd_evar sigma c + | None -> c) + | Sort (Type u) -> + let u' = Evd.normalize_universe sigma u in + if u' == u then c else mkSort (Sorts.sort_of_univ u') + | Const (c', u) when not (Univ.Instance.is_empty u) -> + let u' = Evd.normalize_universe_instance sigma u in + if u' == u then c else mkConstU (c', u') + | Ind (i, u) when not (Univ.Instance.is_empty u) -> + let u' = Evd.normalize_universe_instance sigma u in + if u' == u then c else mkIndU (i, u') + | Construct (co, u) when not (Univ.Instance.is_empty u) -> + let u' = Evd.normalize_universe_instance sigma u in + if u' == u then c else mkConstructU (co, u') + | _ -> c + +let rec nf_evar sigma t = Constr.map (fun t -> nf_evar sigma t) (whd_evar sigma t) + let j_nf_evar sigma j = { uj_val = nf_evar sigma j.uj_val; uj_type = nf_evar sigma j.uj_type } -let j_nf_betaiotaevar sigma j = - { uj_val = nf_evar sigma j.uj_val; - uj_type = Reductionops.nf_betaiota sigma j.uj_type } let jl_nf_evar sigma jl = List.map (j_nf_evar sigma) jl -let jv_nf_betaiotaevar sigma jl = - Array.map (j_nf_betaiotaevar sigma) jl let jv_nf_evar sigma = Array.map (j_nf_evar sigma) let tj_nf_evar sigma {utj_val=v;utj_type=t} = {utj_val=nf_evar sigma v;utj_type=t} -let env_nf_evar sigma env = - process_rel_context - (fun d e -> push_rel (map_rel_declaration (nf_evar sigma) d) e) env - -let env_nf_betaiotaevar sigma env = - process_rel_context - (fun d e -> - push_rel (map_rel_declaration (Reductionops.nf_betaiota sigma) d) e) env - let nf_evars_universes evm = - Universes.nf_evars_and_universes_opt_subst (Reductionops.safe_evar_value evm) + Universes.nf_evars_and_universes_opt_subst (safe_evar_value evm) (Evd.universe_subst evm) let nf_evars_and_universes evm = @@ -106,10 +118,10 @@ let nf_evar_map_universes evm = Evd.raw_map (fun _ -> map_evar_info f) evm, f let nf_named_context_evar sigma ctx = - Context.map_named_context (nf_evar sigma) ctx + Context.Named.map (nf_evar sigma) ctx let nf_rel_context_evar sigma ctx = - Context.map_rel_context (nf_evar sigma) ctx + Context.Rel.map (nf_evar sigma) ctx let nf_env_evar sigma env = let nc' = nf_named_context_evar sigma (Environ.named_context env) in @@ -150,11 +162,16 @@ let is_ground_term evd t = not (has_undefined_evars evd t) let is_ground_env evd env = - let is_ground_decl = function - (_,Some b,_) -> is_ground_term evd b + let open Context.Rel.Declaration in + let is_ground_rel_decl = function + | LocalDef (_,b,_) -> is_ground_term evd b + | _ -> true in + let open Context.Named.Declaration in + let is_ground_named_decl = function + | LocalDef (_,b,_) -> is_ground_term evd b | _ -> true in - List.for_all is_ground_decl (rel_context env) && - List.for_all is_ground_decl (named_context env) + List.for_all is_ground_rel_decl (rel_context env) && + List.for_all is_ground_named_decl (named_context env) (* Memoization is safe since evar_map and environ are applicative structures *) @@ -232,10 +249,11 @@ let non_instantiated sigma = (************************) let make_pure_subst evi args = + let open Context.Named.Declaration in snd (List.fold_right - (fun (id,b,c) (args,l) -> + (fun decl (args,l) -> match args with - | a::rest -> (rest, (id,a)::l) + | a::rest -> (rest, (get_id decl, a)::l) | _ -> anomaly (Pp.str "Instance does not match its signature")) (evar_filtered_context evi) (Array.rev_to_list args,[])) @@ -277,17 +295,15 @@ let subst2 subst vsubst c = let push_rel_context_to_named_context env typ = (* compute the instances relative to the named context and rel_context *) - let ids = List.map pi1 (named_context env) in + let open Context.Named.Declaration in + let ids = List.map get_id (named_context env) in let inst_vars = List.map mkVar ids in let inst_rels = List.rev (rel_list 0 (nb_rel env)) in - let replace_var_named_declaration id0 id (id',b,t) = + let replace_var_named_declaration id0 id decl = + let id' = get_id decl in let id' = if Id.equal id0 id' then id else id' in let vsubst = [id0 , mkVar id] in - let b = match b with - | None -> None - | Some c -> Some (replace_vars vsubst c) - in - id', b, replace_vars vsubst t + decl |> set_id id' |> map_constr (replace_vars vsubst) in let replace_var_named_context id0 id env = let nc = Environ.named_context env in @@ -303,8 +319,13 @@ let push_rel_context_to_named_context env typ = (* with vars of the rel context *) (* We do keep the instances corresponding to local definition (see above) *) let (subst, vsubst, _, env) = - Context.fold_rel_context - (fun (na,c,t) (subst, vsubst, avoid, env) -> + Context.Rel.fold_outside + (fun decl (subst, vsubst, avoid, env) -> + let open Context.Rel.Declaration in + let na = get_name decl in + let c = get_value decl in + let t = get_type decl in + let open Context.Named.Declaration in let id = (* ppedrot: we want to infer nicer names for the refine tactic, but keeping at the same time backward compatibility in other code @@ -322,7 +343,10 @@ let push_rel_context_to_named_context env typ = context. Unless [id] is a section variable. *) let subst = List.map (replace_vars [id0,mkVar id]) subst in let vsubst = (id0,mkVar id)::vsubst in - let d = (id0, Option.map (subst2 subst vsubst) c, subst2 subst vsubst t) in + let d = match c with + | None -> LocalAssum (id0, subst2 subst vsubst t) + | Some c -> LocalDef (id0, subst2 subst vsubst c, subst2 subst vsubst t) + in let env = replace_var_named_context id0 id env in (mkVar id0 :: subst, vsubst, id::avoid, push_named d env) | _ -> @@ -330,7 +354,10 @@ let push_rel_context_to_named_context env typ = incorrect. We revert to a less robust behaviour where the new binder has name [id]. Which amounts to the same behaviour than when [id=id0]. *) - let d = (id,Option.map (subst2 subst vsubst) c,subst2 subst vsubst t) in + let d = match c with + | None -> LocalAssum (id, subst2 subst vsubst t) + | Some c -> LocalDef (id, subst2 subst vsubst c, subst2 subst vsubst t) + in (mkVar id :: subst, vsubst, id::avoid, push_named d env) ) (rel_context env) ~init:([], [], ids, env) in @@ -343,23 +370,19 @@ let push_rel_context_to_named_context env typ = let default_source = (Loc.ghost,Evar_kinds.InternalHole) let restrict_evar evd evk filter candidates = + let evd = Sigma.to_evar_map evd in let evd, evk' = Evd.restrict evk filter ?candidates evd in - Evd.declare_future_goal evk' evd, evk' + Sigma.Unsafe.of_pair (evk', Evd.declare_future_goal evk' evd) let new_pure_evar_full evd evi = + let evd = Sigma.to_evar_map evd in let (evd, evk) = Evd.new_evar evd evi in let evd = Evd.declare_future_goal evk evd in - (evd, evk) + Sigma.Unsafe.of_pair (evk, evd) let new_pure_evar sign evd ?(src=default_source) ?(filter = Filter.identity) ?candidates ?(store = Store.empty) ?naming ?(principal=false) typ = - let default_naming = - if principal then - (* waiting for a more principled approach - (unnamed evars, private names?) *) - Misctypes.IntroFresh (Names.Id.of_string "tmp_goal") - else - Misctypes.IntroAnonymous - in + let evd = Sigma.to_evar_map evd in + let default_naming = Misctypes.IntroAnonymous in let naming = Option.default default_naming naming in let evi = { evar_hyps = sign; @@ -375,17 +398,17 @@ let new_pure_evar sign evd ?(src=default_source) ?(filter = Filter.identity) ?ca if principal then Evd.declare_principal_goal newevk evd else Evd.declare_future_goal newevk evd in - (evd,newevk) + Sigma.Unsafe.of_pair (newevk, evd) let new_evar_instance sign evd typ ?src ?filter ?candidates ?store ?naming ?principal instance = assert (not !Flags.debug || List.distinct (ids_of_named_context (named_context_of_val sign))); - let evd,newevk = new_pure_evar sign evd ?src ?filter ?candidates ?store ?naming ?principal typ in - (evd,mkEvar (newevk,Array.of_list instance)) + let Sigma (newevk, evd, p) = new_pure_evar sign evd ?src ?filter ?candidates ?store ?naming ?principal typ in + Sigma (mkEvar (newevk,Array.of_list instance), evd, p) (* [new_evar] declares a new existential in an env env with type typ *) (* Converting the env into the sign of the evar to define *) -let new_evar_unsafe env evd ?src ?filter ?candidates ?store ?naming ?principal typ = +let new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ = let sign,typ',instance,subst,vsubst = push_rel_context_to_named_context env typ in let candidates = Option.map (List.map (subst2 subst vsubst)) candidates in let instance = @@ -394,24 +417,26 @@ let new_evar_unsafe env evd ?src ?filter ?candidates ?store ?naming ?principal t | Some filter -> Filter.filter_list filter instance in new_evar_instance sign evd typ' ?src ?filter ?candidates ?store ?naming ?principal instance -let new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ = - let evd = Sigma.to_evar_map evd in - let (sigma, c) = new_evar_unsafe env evd ?src ?filter ?candidates ?store ?naming ?principal typ in - Sigma.Unsafe.of_pair (c, sigma) +let new_evar_unsafe env evd ?src ?filter ?candidates ?store ?naming ?principal typ = + let evd = Sigma.Unsafe.of_evar_map evd in + let Sigma (evk, evd, _) = new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ in + (Sigma.to_evar_map evd, evk) let new_type_evar env evd ?src ?filter ?naming ?principal rigid = - let evd', s = new_sort_variable rigid evd in - let evd', e = new_evar_unsafe env evd' ?src ?filter ?naming ?principal (mkSort s) in - evd', (e, s) + let Sigma (s, evd', p) = Sigma.new_sort_variable rigid evd in + let Sigma (e, evd', q) = new_evar env evd' ?src ?filter ?naming ?principal (mkSort s) in + Sigma ((e, s), evd', p +> q) let e_new_type_evar env evdref ?src ?filter ?naming ?principal rigid = - let evd', c = new_type_evar env !evdref ?src ?filter ?naming ?principal rigid in - evdref := evd'; + let sigma = Sigma.Unsafe.of_evar_map !evdref in + let Sigma (c, sigma, _) = new_type_evar env sigma ?src ?filter ?naming ?principal rigid in + let sigma = Sigma.to_evar_map sigma in + evdref := sigma; c let new_Type ?(rigid=Evd.univ_flexible) env evd = - let evd', s = new_sort_variable rigid evd in - evd', mkSort s + let Sigma (s, sigma, p) = Sigma.new_sort_variable rigid evd in + Sigma (mkSort s, sigma, p) let e_new_Type ?(rigid=Evd.univ_flexible) env evdref = let evd', s = new_sort_variable rigid !evdref in @@ -478,7 +503,7 @@ let rec check_and_clear_in_constr env evdref err ids c = let ctxt = Evd.evar_filtered_context evi in let (rids,filter) = List.fold_right2 - (fun (rid, ob,c as h) a (ri,filter) -> + (fun h a (ri,filter) -> try (* Check if some id to clear occurs in the instance a of rid in ev and remember the dependency *) @@ -494,7 +519,8 @@ let rec check_and_clear_in_constr env evdref err ids c = let () = Id.Map.iter check ri in (* No dependency at all, we can keep this ev's context hyp *) (ri, true::filter) - with Depends id -> (Id.Map.add rid id ri, false::filter)) + with Depends id -> let open Context.Named.Declaration in + (Id.Map.add (get_id h) id ri, false::filter)) ctxt (Array.to_list l) (Id.Map.empty,[]) in (* Check if some rid to clear in the context of ev has dependencies in the type of ev and adjust the source of the dependency *) @@ -509,7 +535,9 @@ let rec check_and_clear_in_constr env evdref err ids c = else let origfilter = Evd.evar_filter evi in let filter = Evd.Filter.apply_subfilter origfilter filter in - let evd,_ = restrict_evar !evdref evk filter None in + let evd = Sigma.Unsafe.of_evar_map !evdref in + let Sigma (_, evd, _) = restrict_evar evd evk filter None in + let evd = Sigma.to_evar_map evd in evdref := evd; (* spiwack: hacking session to mark the old [evk] as having been "cleared" *) let evi = Evd.find !evdref evk in @@ -529,11 +557,10 @@ let clear_hyps_in_evi_main env evdref hyps terms ids = let terms = List.map (check_and_clear_in_constr env evdref (OccurHypInSimpleClause None) ids) terms in let nhyps = - let check_context ((id,ob,c) as decl) = - let err = OccurHypInSimpleClause (Some id) in - let ob' = Option.smartmap (fun c -> check_and_clear_in_constr env evdref err ids c) ob in - let c' = check_and_clear_in_constr env evdref err ids c in - if ob == ob' && c == c' then decl else (id, ob', c') + let open Context.Named.Declaration in + let check_context decl = + let err = OccurHypInSimpleClause (Some (get_id decl)) in + map_constr (check_and_clear_in_constr env evdref err ids) decl in let check_value vk = match force_lazy_val vk with | None -> vk @@ -571,11 +598,12 @@ let process_dependent_evar q acc evm is_dependent e = (* Queues evars appearing in the types of the goal (conclusion, then hypotheses), they are all dependent. *) queue_term q true evi.evar_concl; - List.iter begin fun (_,b,t) -> - queue_term q true t; - match b with - | None -> () - | Some b -> queue_term q true b + List.iter begin fun decl -> + let open Context.Named.Declaration in + queue_term q true (get_type decl); + match decl with + | LocalAssum _ -> () + | LocalDef (_,b,_) -> queue_term q true b end (Environ.named_context_of_val evi.evar_hyps); match evi.evar_body with | Evar_empty -> @@ -626,11 +654,11 @@ let undefined_evars_of_term evd t = evrec Evar.Set.empty t let undefined_evars_of_named_context evd nc = - List.fold_right (fun (_, b, t) s -> - Option.fold_left (fun s t -> - Evar.Set.union s (undefined_evars_of_term evd t)) - (Evar.Set.union s (undefined_evars_of_term evd t)) b) - nc Evar.Set.empty + let open Context.Named.Declaration in + Context.Named.fold_outside + (fold (fun c s -> Evar.Set.union s (undefined_evars_of_term evd c))) + nc + ~init:Evar.Set.empty let undefined_evars_of_evar_info evd evi = Evar.Set.union (undefined_evars_of_term evd evi.evar_concl) @@ -641,23 +669,6 @@ let undefined_evars_of_evar_info evd evi = (undefined_evars_of_named_context evd (named_context_of_val evi.evar_hyps))) -(* [check_evars] fails if some unresolved evar remains *) - -let check_evars env initial_sigma sigma c = - let rec proc_rec c = - match kind_of_term c with - | Evar (evk,_ as ev) -> - (match existential_opt_value sigma ev with - | Some c -> proc_rec c - | None -> - if not (Evd.mem initial_sigma evk) then - let (loc,k) = evar_source evk sigma in - match k with - | Evar_kinds.ImplicitArg (gr, (i, id), false) -> () - | _ -> error_unsolvable_implicit loc env sigma evk None) - | _ -> iter_constr proc_rec c - in proc_rec c - (* spiwack: this is a more complete version of {!Termops.occur_evar}. The latter does not look recursively into an [evar_map]. If unification only need to check superficially, tactics @@ -670,174 +681,12 @@ let occur_evar_upto sigma n c = in try occur_rec c; false with Occur -> true - -(****************************************) -(* Operations on value/type constraints *) -(****************************************) - -type type_constraint = types option - -type val_constraint = constr option - -(* Old comment... - * Basically, we have the following kind of constraints (in increasing - * strength order): - * (false,(None,None)) -> no constraint at all - * (true,(None,None)) -> we must build a judgement which _TYPE is a kind - * (_,(None,Some ty)) -> we must build a judgement which _TYPE is ty - * (_,(Some v,_)) -> we must build a judgement which _VAL is v - * Maybe a concrete datatype would be easier to understand. - * We differentiate (true,(None,None)) from (_,(None,Some Type)) - * because otherwise Case(s) would be misled, as in - * (n:nat) Case n of bool [_]nat end would infer the predicate Type instead - * of Set. - *) - -(* The empty type constraint *) -let empty_tycon = None - -(* Builds a type constraint *) -let mk_tycon ty = Some ty - -(* Constrains the value of a type *) -let empty_valcon = None - -(* Builds a value constraint *) -let mk_valcon c = Some c - -let idx = Namegen.default_dependent_ident - -(* Refining an evar to a product *) - -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_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 evd2,rng = - let newenv = push_named (id, None, dom) evenv in - let src = evar_source evk evd1 in - let filter = Filter.extend 1 (evar_filter evi) in - if is_prop_sort s then - (* Impredicative product, conclusion must fall in [Prop]. *) - new_evar_unsafe newenv evd1 concl ~src ~filter - else - let evd3, (rng, srng) = - new_type_evar newenv evd1 univ_flexible_alg ~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 - in - let prod = mkProd (Name id, dom, subst_var id rng) in - let evd3 = Evd.define evk prod evd2 in - evd3,prod - -(* Refine an applied evar to a product and returns its instantiation *) - -let define_evar_as_product evd (evk,args) = - let evd,prod = define_pure_evar_as_product evd evk in - (* Quick way to compute the instantiation of evk with args *) - let na,dom,rng = destProd prod in - let evdom = mkEvar (fst (destEvar dom), args) in - let evrngargs = Array.cons (mkRel 1) (Array.map (lift 1) args) in - let evrng = mkEvar (fst (destEvar rng), evrngargs) in - evd,mkProd (na, evdom, evrng) - -(* Refine an evar with an abstraction - - I.e., solve x1..xq |- ?e:T(x1..xq) with e:=λy:A.?e'[x1..xq,y] where: - - either T(x1..xq) = πy:A(x1..xq).B(x1..xq,y) - or T(x1..xq) = ?d[x1..xq] and we define ?d := πy:?A.?B - with x1..xq |- ?A:Type and x1..xq,y |- ?B:Type - - x1..xq,y:A |- ?e':B -*) - -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 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 - | _ -> error_not_product_loc Loc.ghost env evd typ in - let avoid = ids_of_named_context (evar_context evi) in - let id = - next_name_away_with_default_using_types "x" na avoid (whd_evar evd dom) in - let newenv = push_named (id, None, dom) evenv in - let filter = Filter.extend 1 (evar_filter evi) in - let src = evar_source evk evd1 in - let evd2,body = new_evar_unsafe newenv evd1 ~src (subst1 (mkVar id) rng) ~filter in - let lam = mkLambda (Name id, dom, subst_var id body) in - Evd.define evk lam evd2, lam - -let define_evar_as_lambda env evd (evk,args) = - let evd,lam = define_pure_evar_as_lambda env evd evk in - (* Quick way to compute the instantiation of evk with args *) - let na,dom,body = destLambda lam in - let evbodyargs = Array.cons (mkRel 1) (Array.map (lift 1) args) in - let evbody = mkEvar (fst (destEvar body), evbodyargs) in - evd,mkLambda (na, dom, evbody) - -let rec evar_absorb_arguments env evd (evk,args as ev) = function - | [] -> evd,ev - | a::l -> - (* TODO: optimize and avoid introducing intermediate evars *) - let evd,lam = define_pure_evar_as_lambda env evd evk in - let _,_,body = destLambda lam in - let evk = fst (destEvar body) in - evar_absorb_arguments env evd (evk, Array.cons a args) l - -(* Refining an evar to a sort *) - -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)) 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... *) let judge_of_new_Type evd = - let evd', s = new_univ_variable univ_rigid evd in - evd', { uj_val = mkSort (Type s); uj_type = mkSort (Type (Univ.super s)) } - -(* Propagation of constraints through application and abstraction: - Given a type constraint on a functional term, returns the type - constraint on its domain and codomain. If the input constraint is - an evar instantiate it with the product of 2 new evars. *) - -let split_tycon loc env evd tycon = - let rec real_split evd c = - let t = whd_betadeltaiota env evd c in - match kind_of_term t with - | Prod (na,dom,rng) -> evd, (na, dom, rng) - | Evar ev (* ev is undefined because of whd_betadeltaiota *) -> - let (evd',prod) = define_evar_as_product evd ev in - let (_,dom,rng) = destProd prod in - evd',(Anonymous, dom, rng) - | App (c,args) when isEvar c -> - let (evd',lam) = define_evar_as_lambda env evd (destEvar c) in - real_split evd' (mkApp (lam,args)) - | _ -> error_not_product_loc loc env evd c - in - match tycon with - | None -> evd,(Anonymous,None,None) - | Some c -> - let evd', (n, dom, rng) = real_split evd c in - evd', (n, mk_tycon dom, mk_tycon rng) - -let valcon_of_tycon x = x -let lift_tycon n = Option.map (lift n) - -let pr_tycon env = function - None -> str "None" - | Some t -> Termops.print_constr_env env t + let Sigma (s, evd', p) = Sigma.new_univ_variable univ_rigid evd in + Sigma ({ uj_val = mkSort (Type s); uj_type = mkSort (Type (Univ.super s)) }, evd', p) let subterm_source evk (loc,k) = let evk = match k with @@ -848,7 +697,7 @@ let subterm_source evk (loc,k) = (** Term exploration up to instantiation. *) let kind_of_term_upto sigma t = - Constr.kind (Reductionops.whd_evar sigma t) + Constr.kind (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 @@ -858,13 +707,17 @@ let kind_of_term_upto sigma t = 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 = + let fold cstr sigma = + try Some (add_universe_constraints sigma cstr) + with Univ.UniverseInconsistency _ | UniversesDiffer -> None + in + let ans = 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 + (universes sigma2) fold t u sigma2 in - if b then - try let _ = add_universe_constraints sigma2 c in true - with Univ.UniverseInconsistency _ | UniversesDiffer -> false - else false + match ans with None -> false | Some _ -> true + +type type_constraint = types option +type val_constraint = constr option diff --git a/pretyping/evarutil.mli b/engine/evarutil.mli index 96648bb11..ffff2c5dd 100644 --- a/pretyping/evarutil.mli +++ b/engine/evarutil.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,7 +8,6 @@ open Names open Term -open Context open Evd open Environ @@ -28,12 +27,12 @@ val new_evar : ?principal:bool -> types -> (constr, 'r) Sigma.sigma val new_pure_evar : - named_context_val -> evar_map -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> + named_context_val -> 'r Sigma.t -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> ?candidates:constr list -> ?store:Store.t -> ?naming:Misctypes.intro_pattern_naming_expr -> - ?principal:bool -> types -> evar_map * evar + ?principal:bool -> types -> (evar, 'r) Sigma.sigma -val new_pure_evar_full : evar_map -> evar_info -> evar_map * evar +val new_pure_evar_full : 'r Sigma.t -> evar_info -> (evar, 'r) Sigma.sigma (** the same with side-effects *) val e_new_evar : @@ -45,23 +44,23 @@ val e_new_evar : (** Create a new Type existential variable, as we keep track of them during type-checking and unification. *) val new_type_evar : - env -> evar_map -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> + env -> 'r Sigma.t -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> rigid -> - evar_map * (constr * sorts) + (constr * sorts, 'r) Sigma.sigma val e_new_type_evar : env -> evar_map ref -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> rigid -> constr * sorts -val new_Type : ?rigid:rigid -> env -> evar_map -> evar_map * constr +val new_Type : ?rigid:rigid -> env -> 'r Sigma.t -> (constr, 'r) Sigma.sigma val e_new_Type : ?rigid:rigid -> env -> evar_map ref -> constr -val restrict_evar : evar_map -> existential_key -> Filter.t -> - constr list option -> evar_map * existential_key +val restrict_evar : 'r Sigma.t -> existential_key -> Filter.t -> + constr list option -> (existential_key, 'r) Sigma.sigma (** Polymorphic constants *) -val new_global : evar_map -> Globnames.global_reference -> evar_map * constr +val new_global : 'r Sigma.t -> Globnames.global_reference -> (constr, 'r) Sigma.sigma val e_new_global : evar_map ref -> Globnames.global_reference -> constr (** Create a fresh evar in a context different from its definition context: @@ -71,14 +70,16 @@ val e_new_global : evar_map ref -> Globnames.global_reference -> constr of [inst] are typed in the occurrence context and their type (seen as a telescope) is [sign] *) val new_evar_instance : - named_context_val -> evar_map -> types -> - ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> ?candidates:constr list -> + named_context_val -> 'r Sigma.t -> types -> + ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> ?candidates:constr list -> ?store:Store.t -> ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> - constr list -> evar_map * constr + constr list -> (constr, 'r) Sigma.sigma val make_pure_subst : evar_info -> constr array -> (Id.t * constr) list +val safe_evar_value : evar_map -> existential -> constr option + (** {6 Evars/Metas switching...} *) val non_instantiated : evar_map -> evar_info Evar.Map.t @@ -97,20 +98,6 @@ val has_undefined_evars : evar_map -> constr -> bool val is_ground_term : evar_map -> constr -> bool val is_ground_env : evar_map -> env -> bool -(** [check_evars env initial_sigma extended_sigma c] fails if some - new unresolved evar remains in [c] *) -val check_evars : env -> evar_map -> evar_map -> constr -> unit - -val define_evar_as_product : evar_map -> existential -> evar_map * types -val define_evar_as_lambda : env -> evar_map -> existential -> evar_map * types -val define_evar_as_sort : env -> evar_map -> existential -> evar_map * sorts - -(** Instantiate an evar by as many lambda's as needed so that its arguments - are moved to the evar substitution (i.e. turn [?x[vars1:=args1] args] into - [?y[vars1:=args1,vars:=args]] with - [vars1 |- ?x:=\vars.?y[vars1:=vars1,vars:=vars]] *) -val evar_absorb_arguments : env -> evar_map -> existential -> constr list -> - evar_map * existential (** [gather_dependent_evars evm seeds] classifies the evars in [evm] as dependent_evars and goals (these may overlap). A goal is an @@ -129,7 +116,7 @@ val gather_dependent_evars : evar_map -> evar list -> (Evar.Set.t option) Evar.M [nf_evar]. *) val undefined_evars_of_term : evar_map -> constr -> Evar.Set.t -val undefined_evars_of_named_context : evar_map -> named_context -> Evar.Set.t +val undefined_evars_of_named_context : evar_map -> Context.Named.t -> Evar.Set.t val undefined_evars_of_evar_info : evar_map -> evar_info -> Evar.Set.t (** [occur_evar_upto sigma k c] returns [true] if [k] appears in @@ -139,28 +126,14 @@ val occur_evar_upto : evar_map -> Evar.t -> Constr.t -> bool (** {6 Value/Type constraints} *) -val judge_of_new_Type : evar_map -> evar_map * unsafe_judgment - -type type_constraint = types option -type val_constraint = constr option - -val empty_tycon : type_constraint -val mk_tycon : constr -> type_constraint -val empty_valcon : val_constraint -val mk_valcon : constr -> val_constraint - -val split_tycon : - Loc.t -> env -> evar_map -> type_constraint -> - evar_map * (Name.t * type_constraint * type_constraint) - -val valcon_of_tycon : type_constraint -> val_constraint -val lift_tycon : int -> type_constraint -> type_constraint +val judge_of_new_Type : 'r Sigma.t -> (unsafe_judgment, 'r) Sigma.sigma (***********************************************************) (** [flush_and_check_evars] raise [Uninstantiated_evar] if an evar remains uninstantiated; [nf_evar] leaves uninstantiated evars as is *) +val whd_evar : evar_map -> constr -> constr val nf_evar : evar_map -> constr -> constr val j_nf_evar : evar_map -> unsafe_judgment -> unsafe_judgment val jl_nf_evar : @@ -170,20 +143,14 @@ val jv_nf_evar : val tj_nf_evar : evar_map -> unsafe_type_judgment -> unsafe_type_judgment -val nf_named_context_evar : evar_map -> named_context -> named_context -val nf_rel_context_evar : evar_map -> rel_context -> rel_context +val nf_named_context_evar : evar_map -> Context.Named.t -> Context.Named.t +val nf_rel_context_evar : evar_map -> Context.Rel.t -> Context.Rel.t val nf_env_evar : evar_map -> env -> env val nf_evar_info : evar_map -> evar_info -> evar_info val nf_evar_map : evar_map -> evar_map val nf_evar_map_undefined : evar_map -> evar_map -val env_nf_evar : evar_map -> env -> env -val env_nf_betaiotaevar : evar_map -> env -> env - -val j_nf_betaiotaevar : evar_map -> unsafe_judgment -> unsafe_judgment -val jv_nf_betaiotaevar : - evar_map -> unsafe_judgment array -> unsafe_judgment array (** Presenting terms without solved evars *) val nf_evars_universes : evar_map -> constr -> constr @@ -213,11 +180,6 @@ val kind_of_term_upto : evar_map -> constr -> (constr,types) kind_of_term 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 - - (** {6 Removing hyps in evars'context} raise OccurHypInSimpleClause if the removal breaks dependencies *) @@ -252,3 +214,8 @@ val subterm_source : existential_key -> Evar_kinds.t Loc.located -> Evar_kinds.t Loc.located val meta_counter_summary_name : string + +(** Deprecater *) + +type type_constraint = types option +type val_constraint = constr option diff --git a/engine/evd.ml b/engine/evd.ml index 52bfc2d1d..b6849f7ff 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -16,6 +16,7 @@ open Vars open Termops open Environ open Globnames +open Context.Named.Declaration (** Generic filters *) module Filter : @@ -208,15 +209,6 @@ let map_evar_info f evi = evar_concl = f evi.evar_concl; evar_candidates = Option.map (List.map f) evi.evar_candidates } -let evar_ident_info evi = - match evi.evar_source with - | _,Evar_kinds.ImplicitArg (c,(n,Some id),b) -> id - | _,Evar_kinds.VarInstance id -> id - | _,Evar_kinds.GoalEvar -> Id.of_string "Goal" - | _ -> - let env = reset_with_named_context evi.evar_hyps (Global.env()) in - Namegen.id_of_name_using_hdchar env evi.evar_concl Anonymous - (* This exception is raised by *.existential_value *) exception NotInstantiatedEvar @@ -230,20 +222,20 @@ let evar_instance_array test_id info args = else instance_mismatch () | false :: filter, _ :: ctxt -> instrec filter ctxt i - | true :: filter, (id,_,_ as d) :: ctxt -> + | true :: filter, d :: ctxt -> if i < len then let c = Array.unsafe_get args i in if test_id d c then instrec filter ctxt (succ i) - else (id, c) :: instrec filter ctxt (succ i) + else (get_id d, c) :: instrec filter ctxt (succ i) else instance_mismatch () | _ -> instance_mismatch () in match Filter.repr (evar_filter info) with | None -> - let map i (id,_,_ as d) = + let map i d = if (i < len) then let c = Array.unsafe_get args i in - if test_id d c then None else Some (id,c) + if test_id d c then None else Some (get_id d, c) else instance_mismatch () in List.map_filter_i map (evar_context info) @@ -251,7 +243,7 @@ let evar_instance_array test_id info args = instrec filter (evar_context info) 0 let make_evar_instance_array info args = - evar_instance_array (fun (id,_,_) -> isVarId id) info args + evar_instance_array (isVarId % get_id) info args let instantiate_evar_array info c args = let inst = make_evar_instance_array info args in @@ -273,10 +265,8 @@ let evar_universe_context_subst = UState.subst let add_constraints_context = UState.add_constraints let add_universe_constraints_context = UState.add_universe_constraints let constrain_variables = UState.constrain_variables +let evar_universe_context_of_binders = UState.of_binders -(* let addunivconstrkey = Profile.declare_profile "add_universe_constraints_context";; *) -(* let add_universe_constraints_context = *) -(* Profile.profile2 addunivconstrkey add_universe_constraints_context;; *) (*******************************************************************) (* Metamaps *) @@ -365,11 +355,86 @@ type evar_constraint = conv_pb * Environ.env * constr * constr module EvMap = Evar.Map +module EvNames : +sig + +open Misctypes + +type t + +val empty : t +val add_name_newly_undefined : intro_pattern_naming_expr -> Evar.t -> evar_info -> t -> t +val add_name_undefined : intro_pattern_naming_expr -> Evar.t -> evar_info -> t -> t +val remove_name_defined : Evar.t -> t -> t +val rename : Evar.t -> Id.t -> t -> t +val reassign_name_defined : Evar.t -> Evar.t -> t -> t +val ident : Evar.t -> t -> Id.t option +val key : Id.t -> t -> Evar.t + +end = +struct + +type t = Id.t EvMap.t * existential_key Idmap.t + +let empty = (EvMap.empty, Idmap.empty) + +let add_name_newly_undefined naming evk evi (evtoid, idtoev as names) = + let id = match naming with + | Misctypes.IntroAnonymous -> None + | Misctypes.IntroIdentifier id -> + if Idmap.mem id idtoev then + user_err_loc + (Loc.ghost,"",str "Already an existential evar of name " ++ pr_id id); + Some id + | Misctypes.IntroFresh id -> + let id = Namegen.next_ident_away_from id (fun id -> Idmap.mem id idtoev) in + Some id + in + match id with + | None -> names + | Some id -> (EvMap.add evk id evtoid, Idmap.add id evk idtoev) + +let add_name_undefined naming evk evi (evtoid,idtoev as evar_names) = + if EvMap.mem evk evtoid then + evar_names + else + add_name_newly_undefined naming evk evi evar_names + +let remove_name_defined evk (evtoid, idtoev as names) = + let id = try Some (EvMap.find evk evtoid) with Not_found -> None in + match id with + | None -> names + | Some id -> (EvMap.remove evk evtoid, Idmap.remove id idtoev) + +let rename evk id (evtoid, idtoev) = + let id' = try Some (EvMap.find evk evtoid) with Not_found -> None in + match id' with + | None -> (EvMap.add evk id evtoid, Idmap.add id evk idtoev) + | Some id' -> + if Idmap.mem id idtoev then anomaly (str "Evar name already in use"); + (EvMap.update evk id evtoid (* overwrite old name *), Idmap.add id evk (Idmap.remove id' idtoev)) + +let reassign_name_defined evk evk' (evtoid, idtoev as names) = + let id = try Some (EvMap.find evk evtoid) with Not_found -> None in + match id with + | None -> names (** evk' must not be defined *) + | Some id -> + (EvMap.add evk' id (EvMap.remove evk evtoid), + Idmap.add id evk' (Idmap.remove id idtoev)) + +let ident evk (evtoid, _) = + try Some (EvMap.find evk evtoid) with Not_found -> None + +let key id (_, idtoev) = + Idmap.find id idtoev + +end + type evar_map = { (** Existential variables *) defn_evars : evar_info EvMap.t; undf_evars : evar_info EvMap.t; - evar_names : Id.t EvMap.t * existential_key Idmap.t; + evar_names : EvNames.t; (** Universes *) universes : evar_universe_context; (** Conversion problems *) @@ -378,7 +443,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 @@ -394,55 +459,15 @@ type evar_map = { (*** Lifting primitive from Evar.Map. ***) -let add_name_newly_undefined naming evk evi (evtoid,idtoev) = - let id = match naming with - | Misctypes.IntroAnonymous -> - let id = evar_ident_info evi in - Namegen.next_ident_away_from id (fun id -> Idmap.mem id idtoev) - | Misctypes.IntroIdentifier id -> - let id' = - Namegen.next_ident_away_from id (fun id -> Idmap.mem id idtoev) in - if not (Names.Id.equal id id') then - user_err_loc - (Loc.ghost,"",str "Already an existential evar of name " ++ pr_id id); - id' - | Misctypes.IntroFresh id -> - Namegen.next_ident_away_from id (fun id -> Idmap.mem id idtoev) in - (EvMap.add evk id evtoid, Idmap.add id evk idtoev) - -let add_name_undefined naming evk evi (evtoid,idtoev as evar_names) = - if EvMap.mem evk evtoid then - evar_names - else - add_name_newly_undefined naming evk evi evar_names - -let remove_name_defined evk (evtoid,idtoev) = - let id = EvMap.find evk evtoid in - (EvMap.remove evk evtoid, Idmap.remove id idtoev) - -let remove_name_possibly_already_defined evk evar_names = - try remove_name_defined evk evar_names - with Not_found -> evar_names - let rename evk id evd = - let (evtoid,idtoev) = evd.evar_names in - let id' = EvMap.find evk evtoid in - if Idmap.mem id idtoev then anomaly (str "Evar name already in use"); - { evd with evar_names = - (EvMap.add evk id evtoid (* overwrite old name *), - Idmap.add id evk (Idmap.remove id' idtoev)) } - -let reassign_name_defined evk evk' (evtoid,idtoev) = - let id = EvMap.find evk evtoid in - (EvMap.add evk' id (EvMap.remove evk evtoid), - Idmap.add id evk' (Idmap.remove id idtoev)) + { evd with evar_names = EvNames.rename evk id evd.evar_names } let add_with_name ?(naming = Misctypes.IntroAnonymous) d e i = match i.evar_body with | Evar_empty -> - let evar_names = add_name_undefined naming e i d.evar_names in + let evar_names = EvNames.add_name_undefined naming e i d.evar_names in { d with undf_evars = EvMap.add e i d.undf_evars; evar_names } | Evar_defined _ -> - let evar_names = remove_name_possibly_already_defined e d.evar_names in + let evar_names = EvNames.remove_name_defined e d.evar_names in { d with defn_evars = EvMap.add e i d.defn_evars; evar_names } let add d e i = add_with_name d e i @@ -464,7 +489,12 @@ let new_evar evd ?naming evi = let remove d e = let undf_evars = EvMap.remove e d.undf_evars in let defn_evars = EvMap.remove e d.defn_evars in - { d with undf_evars; defn_evars; } + let principal_future_goal = match d.principal_future_goal with + | None -> None + | Some e' -> if Evar.equal e e' then None else d.principal_future_goal + in + let future_goals = List.filter (fun e' -> not (Evar.equal e e')) d.future_goals in + { d with undf_evars; defn_evars; principal_future_goal; future_goals } let find d e = try EvMap.find e d.undf_evars @@ -579,8 +609,8 @@ let empty = { conv_pbs = []; last_mods = Evar.Set.empty; metas = Metamap.empty; - effects = Declareops.no_seff; - evar_names = (EvMap.empty,Idmap.empty); (* id<->key for undefined evars *) + effects = Safe_typing.empty_private_constants; + evar_names = EvNames.empty; (* id<->key for undefined evars *) future_goals = []; principal_future_goal = None; extras = Store.empty; @@ -616,14 +646,8 @@ let add_conv_pb ?(tail=false) pb d = let evar_source evk d = (find d evk).evar_source -let evar_ident evk evd = - try EvMap.find evk (fst evd.evar_names) - with Not_found -> - (* Unnamed (non-dependent) evar *) - add_suffix (Id.of_string "X") (string_of_int (Evar.repr evk)) - -let evar_key id evd = - Idmap.find id (snd evd.evar_names) +let evar_ident evk evd = EvNames.ident evk evd.evar_names +let evar_key id evd = EvNames.key id evd.evar_names let define_aux def undef evk body = let oldinfo = @@ -645,7 +669,7 @@ let define evk body evd = | [] -> evd.last_mods | _ -> Evar.Set.add evk evd.last_mods in - let evar_names = remove_name_defined evk evd.evar_names in + let evar_names = EvNames.remove_name_defined evk evd.evar_names in { evd with defn_evars; undf_evars; last_mods; evar_names } let restrict evk filter ?candidates evd = @@ -655,9 +679,9 @@ let restrict evk filter ?candidates evd = { evar_info with evar_filter = filter; evar_candidates = candidates; evar_extra = Store.empty } in - let evar_names = reassign_name_defined evk evk' evd.evar_names in + let evar_names = EvNames.reassign_name_defined evk evk' evd.evar_names in let ctxt = Filter.filter_list filter (evar_context evar_info) in - let id_inst = Array.map_of_list (fun (id,_,_) -> mkVar id) ctxt in + let id_inst = Array.map_of_list (mkVar % get_id) ctxt in let body = mkEvar(evk',id_inst) in let (defn_evars, undf_evars) = define_aux evd.defn_evars evd.undf_evars evk body in { evd with undf_evars = EvMap.add evk' evar_info' undf_evars; @@ -719,10 +743,10 @@ let evars_of_term c = evrec Evar.Set.empty c let evars_of_named_context nc = - List.fold_right (fun (_, b, t) s -> + List.fold_right (fun decl s -> Option.fold_left (fun s t -> Evar.Set.union s (evars_of_term t)) - (Evar.Set.union s (evars_of_term t)) b) + (Evar.Set.union s (evars_of_term (get_type decl))) (get_value decl)) nc Evar.Set.empty let evars_of_filtered_evar_info evi = @@ -757,25 +781,25 @@ let restrict_universe_context evd vars = let universe_subst evd = UState.subst evd.universes -let merge_context_set ?(sideff=false) rigid evd ctx' = - {evd with universes = UState.merge sideff rigid evd.universes ctx'} +let merge_context_set ?loc ?(sideff=false) rigid evd ctx' = + {evd with universes = UState.merge ?loc sideff rigid evd.universes ctx'} let merge_universe_subst evd subst = {evd with universes = UState.merge_subst evd.universes subst } -let with_context_set rigid d (a, ctx) = - (merge_context_set rigid d ctx, a) +let with_context_set ?loc rigid d (a, ctx) = + (merge_context_set ?loc rigid d ctx, a) -let new_univ_level_variable ?name ?(predicative=true) rigid evd = - let uctx', u = UState.new_univ_variable rigid name evd.universes in +let new_univ_level_variable ?loc ?name ?(predicative=true) rigid evd = + let uctx', u = UState.new_univ_variable ?loc rigid name evd.universes in ({evd with universes = uctx'}, u) -let new_univ_variable ?name ?(predicative=true) rigid evd = - let uctx', u = UState.new_univ_variable rigid name evd.universes in +let new_univ_variable ?loc ?name ?(predicative=true) rigid evd = + let uctx', u = UState.new_univ_variable ?loc rigid name evd.universes in ({evd with universes = uctx'}, Univ.Universe.make u) -let new_sort_variable ?name ?(predicative=true) rigid d = - let (d', u) = new_univ_variable rigid ?name ~predicative d in +let new_sort_variable ?loc ?name ?(predicative=true) rigid d = + let (d', u) = new_univ_variable ?loc rigid ?name ~predicative d in (d', Type u) let add_global_univ d u = @@ -791,27 +815,27 @@ let make_evar_universe_context e l = | Some us -> List.fold_left (fun uctx (loc,id) -> - fst (UState.new_univ_variable univ_rigid (Some (Id.to_string id)) uctx)) + fst (UState.new_univ_variable ~loc univ_rigid (Some (Id.to_string id)) uctx)) uctx us (****************************************) (* Operations on constants *) (****************************************) -let fresh_sort_in_family ?(rigid=univ_flexible) env evd s = - with_context_set rigid evd (Universes.fresh_sort_in_family env s) +let fresh_sort_in_family ?loc ?(rigid=univ_flexible) env evd s = + with_context_set ?loc rigid evd (Universes.fresh_sort_in_family env s) -let fresh_constant_instance env evd c = - with_context_set univ_flexible evd (Universes.fresh_constant_instance env c) +let fresh_constant_instance ?loc env evd c = + with_context_set ?loc univ_flexible evd (Universes.fresh_constant_instance env c) -let fresh_inductive_instance env evd i = - with_context_set univ_flexible evd (Universes.fresh_inductive_instance env i) +let fresh_inductive_instance ?loc env evd i = + with_context_set ?loc univ_flexible evd (Universes.fresh_inductive_instance env i) -let fresh_constructor_instance env evd c = - with_context_set univ_flexible evd (Universes.fresh_constructor_instance env c) +let fresh_constructor_instance ?loc env evd c = + with_context_set ?loc univ_flexible evd (Universes.fresh_constructor_instance env c) -let fresh_global ?(rigid=univ_flexible) ?names env evd gr = - with_context_set rigid evd (Universes.fresh_global_instance ?names env gr) +let fresh_global ?loc ?(rigid=univ_flexible) ?names env evd gr = + with_context_set ?loc rigid evd (Universes.fresh_global_instance ?names env gr) let whd_sort_variable evd t = t @@ -859,12 +883,9 @@ let set_eq_sort env d s1 s2 = d let has_lub evd u1 u2 = - (* let normalize = Universes.normalize_universe_opt_subst (ref univs.uctx_univ_variables) in *) - (* (\* let dref, norm = memo_normalize_universe d in *\) *) - (* let u1 = normalize u1 and u2 = normalize u2 in *) - if Univ.Universe.equal u1 u2 then evd - else add_universe_constraints evd - (Universes.Constraints.singleton (u1,Universes.ULub,u2)) + if Univ.Universe.equal u1 u2 then evd + else add_universe_constraints evd + (Universes.Constraints.singleton (u1,Universes.ULub,u2)) let set_eq_level d u1 u2 = add_constraints d (Univ.enforce_eq_level u1 u2 Univ.Constraint.empty) @@ -882,15 +903,9 @@ let set_leq_sort env evd s1 s2 = match is_eq_sort s1 s2 with | None -> evd | Some (u1, u2) -> - (* if Univ.is_type0_univ u2 then *) - (* if Univ.is_small_univ u1 then evd *) - (* else raise (Univ.UniverseInconsistency (Univ.Le, u1, u2, [])) *) - (* else if Univ.is_type0m_univ u2 then *) - (* raise (Univ.UniverseInconsistency (Univ.Le, u1, u2, [])) *) - (* else *) - if not (type_in_type env) then - add_universe_constraints evd (Universes.Constraints.singleton (u1,Universes.ULe,u2)) - else evd + if not (type_in_type env) then + add_universe_constraints evd (Universes.Constraints.singleton (u1,Universes.ULe,u2)) + else evd let check_eq evd s s' = UGraph.check_eq (UState.ugraph evd.universes) s s' @@ -900,10 +915,6 @@ let check_leq evd s s' = let normalize_evar_universe_context_variables = UState.normalize_variables -(* let normvarsconstrkey = Profile.declare_profile "normalize_evar_universe_context_variables";; *) -(* let normalize_evar_universe_context_variables = *) -(* Profile.profile1 normvarsconstrkey normalize_evar_universe_context_variables;; *) - let abstract_undefined_variables = UState.abstract_undefined_variables let fix_undefined_variables evd = @@ -926,12 +937,6 @@ let nf_constraints evd = let uctx' = normalize_evar_universe_context uctx' in {evd with universes = uctx'} -let nf_constraints = - if Flags.profile then - let nfconstrkey = Profile.declare_profile "nf_constraints" in - Profile.profile1 nfconstrkey nf_constraints - else nf_constraints - let universe_of_name evd s = UState.universe_of_name evd.universes s let add_universe_name evd s l = @@ -939,36 +944,35 @@ let add_universe_name evd s l = let universes evd = UState.ugraph evd.universes +let update_sigma_env evd env = + { evd with universes = UState.update_sigma_env evd.universes env } + (* 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 - full_transparent_state ~evars:(existential_opt_value evd) env - (UState.ugraph evd.universes) t u - | Reduction.CUMUL -> Reduction.trans_conv_leq_universes - full_transparent_state ~evars:(existential_opt_value evd) env - (UState.ugraph evd.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 + Reduction.conv env + ~evars:((existential_opt_value evd), (UState.ugraph evd.universes)) + t u + | Reduction.CUMUL -> Reduction.conv_leq env + ~evars:((existential_opt_value evd), (UState.ugraph evd.universes)) + t u 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 exception UniversesDiffer = UState.UniversesDiffer let eq_constr_univs evd t u = - let b, c = Universes.eq_constr_univs_infer (UState.ugraph evd.universes) t u in - if b then - try let evd' = add_universe_constraints evd c in evd', b - with Univ.UniverseInconsistency _ | UniversesDiffer -> evd, false - else evd, b + let fold cstr sigma = + try Some (add_universe_constraints sigma cstr) + with Univ.UniverseInconsistency _ | UniversesDiffer -> None + in + match Universes.eq_constr_univs_infer (UState.ugraph evd.universes) fold t u evd with + | None -> evd, false + | Some evd -> evd, true let e_eq_constr_univs evdref t u = let evd, b = eq_constr_univs !evdref t u in @@ -978,11 +982,11 @@ let e_eq_constr_univs evdref t u = (* Side effects *) let emit_side_effects eff evd = - { evd with effects = Declareops.union_side_effects eff evd.effects; + { evd with effects = Safe_typing.concat_private eff evd.effects; universes = UState.emit_side_effects eff evd.universes } let drop_side_effects evd = - { evd with effects = Declareops.no_seff; } + { evd with effects = Safe_typing.empty_private_constants; } let eval_side_effects evd = evd.effects @@ -1043,6 +1047,10 @@ let map_metas_fvalue f evd = in set_metas evd (Metamap.smartmap map evd.metas) +let map_metas f evd = + let map cl = map_clb f cl in + set_metas evd (Metamap.smartmap map evd.metas) + let meta_opt_fvalue evd mv = match Metamap.find mv evd.metas with | Clval(_,b,_) -> Some b @@ -1098,9 +1106,12 @@ let meta_name evd mv = let clear_metas evd = {evd with metas = Metamap.empty} -let meta_merge evd1 evd2 = +let meta_merge ?(with_univs = true) evd1 evd2 = let metas = Metamap.fold Metamap.add evd1.metas evd2.metas in - let universes = union_evar_universe_context evd2.universes evd1.universes in + let universes = + if with_univs then union_evar_universe_context evd2.universes evd1.universes + else evd2.universes + in {evd2 with universes; metas; } type metabinding = metavariable * constr * instance_status @@ -1206,7 +1217,34 @@ type unsolvability_explanation = SeveralInstancesFound of int (**********************************************************) (* Pretty-printing *) -let pr_existential_key sigma evk = str "?" ++ pr_id (evar_ident evk sigma) +let pr_evar_suggested_name evk sigma = + let base_id evk' evi = + match evar_ident evk' sigma with + | Some id -> id + | None -> match evi.evar_source with + | _,Evar_kinds.ImplicitArg (c,(n,Some id),b) -> id + | _,Evar_kinds.VarInstance id -> id + | _,Evar_kinds.GoalEvar -> Id.of_string "Goal" + | _ -> + let env = reset_with_named_context evi.evar_hyps (Global.env()) in + Namegen.id_of_name_using_hdchar env evi.evar_concl Anonymous + in + let names = EvMap.mapi base_id sigma.undf_evars in + let id = EvMap.find evk names in + let fold evk' id' (seen, n) = + if seen then (seen, n) + else if Evar.equal evk evk' then (true, n) + else if Id.equal id id' then (seen, succ n) + else (seen, n) + in + let (_, n) = EvMap.fold fold names (false, 0) in + if n = 0 then id else Nameops.add_suffix id (string_of_int (pred n)) + +let pr_existential_key sigma evk = match evar_ident evk sigma with +| None -> + str "?" ++ pr_id (pr_evar_suggested_name evk sigma) +| Some id -> + str "?" ++ pr_id id let pr_instance_status (sc,typ) = begin match sc with @@ -1238,13 +1276,14 @@ let pr_meta_map mmap = in prlist pr_meta_binding (metamap_to_list mmap) -let pr_decl ((id,b,_),ok) = - match b with +let pr_decl (decl,ok) = + let id = get_id decl in + match get_value decl with | None -> if ok then pr_id id else (str "{" ++ pr_id id ++ str "}") | Some c -> str (if ok then "(" else "{") ++ pr_id id ++ str ":=" ++ print_constr c ++ str (if ok then ")" else "}") -let rec pr_evar_source = function +let pr_evar_source = function | Evar_kinds.QuestionMark _ -> str "underscore" | Evar_kinds.CasesType false -> str "pattern-matching return predicate" | Evar_kinds.CasesType true -> @@ -1356,8 +1395,9 @@ let print_env_short env = let pr_body n = function | None -> pr_name n | Some b -> str "(" ++ pr_name n ++ str " := " ++ print_constr b ++ str ")" in - let pr_named_decl (n, b, _) = pr_body (Name n) b in - let pr_rel_decl (n, b, _) = pr_body n b in + let pr_named_decl decl = pr_body (Name (get_id decl)) (get_value decl) in + let pr_rel_decl decl = let open Context.Rel.Declaration in + pr_body (get_name decl) (get_value decl) in let nc = List.rev (named_context env) in let rc = List.rev (rel_context env) in str "[" ++ pr_sequence pr_named_decl nc ++ str "]" ++ spc () ++ @@ -1395,7 +1435,7 @@ let pr_evar_list sigma l = h 0 (str (string_of_existential ev) ++ str "==" ++ pr_evar_info evi ++ (if evi.evar_body == Evar_empty - then str " {" ++ pr_id (evar_ident ev sigma) ++ str "}" + then str " {" ++ pr_existential_key sigma ev ++ str "}" else mt ())) in h 0 (prlist_with_sep fnl pr l) diff --git a/engine/evd.mli b/engine/evd.mli index dc498ed42..3ae6e586c 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -10,7 +10,6 @@ open Util open Loc open Names open Term -open Context open Environ (** {5 Existential variables and unification states} @@ -105,8 +104,8 @@ type evar_info = { val make_evar : named_context_val -> types -> evar_info val evar_concl : evar_info -> constr -val evar_context : evar_info -> named_context -val evar_filtered_context : evar_info -> named_context +val evar_context : evar_info -> Context.Named.t +val evar_filtered_context : evar_info -> Context.Named.t val evar_hyps : evar_info -> named_context_val val evar_filtered_hyps : evar_info -> named_context_val val evar_body : evar_info -> evar_body @@ -223,7 +222,7 @@ val existential_opt_value : evar_map -> existential -> constr option (** Same as {!existential_value} but returns an option instead of raising an exception. *) -val evar_instance_array : (named_declaration -> 'a -> bool) -> evar_info -> +val evar_instance_array : (Context.Named.Declaration.t -> 'a -> bool) -> evar_info -> 'a array -> (Id.t * 'a) list val instantiate_evar_array : evar_info -> constr -> constr array -> constr @@ -247,7 +246,7 @@ val evar_source : existential_key -> evar_map -> Evar_kinds.t located (** Convenience function. Wrapper around {!find} to recover the source of an evar in a given evar map. *) -val evar_ident : existential_key -> evar_map -> Id.t +val evar_ident : existential_key -> evar_map -> Id.t option val rename : existential_key -> Id.t -> evar_map -> evar_map @@ -259,10 +258,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 @@ -423,7 +422,7 @@ val evar_list : constr -> existential list val evars_of_term : constr -> Evar.Set.t (** including evars in instances of evars *) -val evars_of_named_context : named_context -> Evar.Set.t +val evars_of_named_context : Context.Named.t -> Evar.Set.t val evars_of_filtered_evar_info : evar_info -> Evar.Set.t @@ -448,10 +447,11 @@ val meta_reassign : metavariable -> constr * instance_status -> evar_map -> eva val clear_metas : evar_map -> evar_map (** [meta_merge evd1 evd2] returns [evd2] extended with the metas of [evd1] *) -val meta_merge : evar_map -> evar_map -> evar_map +val meta_merge : ?with_univs:bool -> evar_map -> evar_map -> evar_map val undefined_metas : evar_map -> metavariable list val map_metas_fvalue : (constr -> constr) -> evar_map -> evar_map +val map_metas : (constr -> constr) -> evar_map -> evar_map type metabinding = metavariable * constr * instance_status @@ -485,14 +485,15 @@ val evar_universe_context_subst : evar_universe_context -> Universes.universe_op val constrain_variables : Univ.LSet.t -> evar_universe_context -> Univ.constraints +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 -val universes : evar_map -> UGraph.t - val add_constraints_context : evar_universe_context -> Univ.constraints -> evar_universe_context @@ -503,9 +504,9 @@ 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 -> ?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 new_univ_level_variable : ?loc:Loc.t -> ?name:string -> ?predicative:bool -> rigid -> evar_map -> evar_map * Univ.universe_level +val new_univ_variable : ?loc:Loc.t -> ?name:string -> ?predicative:bool -> rigid -> evar_map -> evar_map * Univ.universe +val new_sort_variable : ?loc:Loc.t -> ?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 @@ -514,7 +515,6 @@ val is_sort_variable : evar_map -> sorts -> Univ.universe_level option not a local sort variable declared in [evm] *) val is_flexible_level : evar_map -> Univ.Level.t -> bool -val whd_sort_variable : evar_map -> constr -> constr (* val normalize_universe_level : evar_map -> Univ.universe_level -> Univ.universe_level *) val normalize_universe : evar_map -> Univ.universe -> Univ.universe val normalize_universe_instance : evar_map -> Univ.universe_instance -> Univ.universe_instance @@ -532,7 +532,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 : ?names:(Id.t located) list -> 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 -> UGraph.t @@ -540,10 +541,10 @@ val universes : evar_map -> UGraph.t 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 : ?sideff:bool -> rigid -> evar_map -> Univ.universe_context_set -> evar_map +val merge_context_set : ?loc:Loc.t -> ?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 +val with_context_set : ?loc:Loc.t -> rigid -> evar_map -> 'a Univ.in_universe_context_set -> evar_map * 'a val nf_univ_variables : evar_map -> evar_map * Univ.universe_subst val abstract_undefined_variables : evar_universe_context -> evar_universe_context @@ -554,25 +555,24 @@ 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 -val fresh_constant_instance : env -> evar_map -> constant -> evar_map * pconstant -val fresh_inductive_instance : env -> evar_map -> inductive -> evar_map * pinductive -val fresh_constructor_instance : env -> evar_map -> constructor -> evar_map * pconstructor +val fresh_sort_in_family : ?loc:Loc.t -> ?rigid:rigid -> env -> evar_map -> sorts_family -> evar_map * sorts +val fresh_constant_instance : ?loc:Loc.t -> env -> evar_map -> constant -> evar_map * pconstant +val fresh_inductive_instance : ?loc:Loc.t -> env -> evar_map -> inductive -> evar_map * pinductive +val fresh_constructor_instance : ?loc:Loc.t -> env -> evar_map -> constructor -> evar_map * pconstructor -val fresh_global : ?rigid:rigid -> ?names:Univ.Instance.t -> env -> evar_map -> +val fresh_global : ?loc:Loc.t -> ?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 *) @@ -597,6 +597,8 @@ type unsolvability_explanation = SeveralInstancesFound of int val pr_existential_key : evar_map -> evar -> Pp.std_ppcmds +val pr_evar_suggested_name : existential_key -> evar_map -> Id.t + (** {5 Debug pretty-printers} *) val pr_evar_info : evar_info -> Pp.std_ppcmds diff --git a/engine/logic_monad.ml b/engine/logic_monad.ml index 75134e6f1..4b78bc05d 100644 --- a/engine/logic_monad.ml +++ b/engine/logic_monad.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/engine/logic_monad.mli b/engine/logic_monad.mli index 42a84f830..c5160443b 100644 --- a/engine/logic_monad.mli +++ b/engine/logic_monad.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/engine/namegen.ml b/engine/namegen.ml index a88c2e20e..6b2b58531 100644 --- a/engine/namegen.ml +++ b/engine/namegen.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -22,6 +22,7 @@ open Libnames open Globnames open Environ open Termops +open Context.Rel.Declaration (**********************************************************************) (* Conventional names *) @@ -113,7 +114,7 @@ let hdchar env c = | Rel n -> (if n<=k then "p" (* the initial term is flexible product/function *) else - try match Environ.lookup_rel (n-k) env with + try match Environ.lookup_rel (n-k) env |> to_tuple with | (Name id,_,_) -> lowercase_first_char id | (Anonymous,_,t) -> hdrec 0 (lift (n-k) t) with Not_found -> "y") @@ -142,10 +143,9 @@ let prod_name = mkProd_name let prod_create env (a,b) = mkProd (named_hd env a Anonymous, a, b) let lambda_create env (a,b) = mkLambda (named_hd env a Anonymous, a, b) -let name_assumption env (na,c,t) = - match c with - | None -> (named_hd env t na, None, t) - | Some body -> (named_hd env body na, c, t) +let name_assumption env = function + | LocalAssum (na,t) -> LocalAssum (named_hd env t na, t) + | LocalDef (na,c,t) -> LocalDef (named_hd env c na, c, t) let name_context env hyps = snd @@ -277,11 +277,12 @@ let next_name_away = next_name_away_with_default default_non_dependent_string 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 -> + (fun decl newenv -> + let (na,_,t) = to_tuple decl in 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) + push_rel (set_name (Name id) decl) newenv) env (* 5- Looks for next fresh name outside a list; avoids also to use names that diff --git a/engine/namegen.mli b/engine/namegen.mli index f66bc6d88..a2923fee9 100644 --- a/engine/namegen.mli +++ b/engine/namegen.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,7 +8,6 @@ open Names open Term -open Context open Environ (********************************************************************* @@ -39,13 +38,13 @@ val lambda_name : env -> Name.t * types * constr -> constr val prod_create : env -> types * types -> constr val lambda_create : env -> types * constr -> constr -val name_assumption : env -> rel_declaration -> rel_declaration -val name_context : env -> rel_context -> rel_context +val name_assumption : env -> Context.Rel.Declaration.t -> Context.Rel.Declaration.t +val name_context : env -> Context.Rel.t -> Context.Rel.t -val mkProd_or_LetIn_name : env -> types -> rel_declaration -> types -val mkLambda_or_LetIn_name : env -> constr -> rel_declaration -> constr -val it_mkProd_or_LetIn_name : env -> types -> rel_context -> types -val it_mkLambda_or_LetIn_name : env -> constr -> rel_context -> constr +val mkProd_or_LetIn_name : env -> types -> Context.Rel.Declaration.t -> types +val mkLambda_or_LetIn_name : env -> constr -> Context.Rel.Declaration.t -> constr +val it_mkProd_or_LetIn_name : env -> types -> Context.Rel.t -> types +val it_mkLambda_or_LetIn_name : env -> constr -> Context.Rel.t -> constr (********************************************************************* Fresh names *) diff --git a/proofs/proofview.ml b/engine/proofview.ml index bded518e7..ba664cafa 100644 --- a/proofs/proofview.ml +++ b/engine/proofview.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -17,6 +17,7 @@ open Pp open Util open Proofview_monad open Sigma.Notations +open Context.Named.Declaration (** Main state of tactics *) type proofview = Proofview_monad.proofview @@ -33,7 +34,7 @@ type entry = (Term.constr * Term.types) list let proofview p = p.comb , p.solution -let compact el { comb; solution } = +let compact el ({ solution } as pv) = let nf = Evarutil.nf_evar solution in let size = Evd.fold (fun _ _ i -> i+1) solution 0 in let new_el = List.map (fun (t,ty) -> nf t, nf ty) el in @@ -46,7 +47,7 @@ let compact el { comb; solution } = let new_solution = Evd.raw_map_undefined apply_subst_einfo pruned_solution in let new_size = Evd.fold (fun _ _ i -> i+1) new_solution 0 in msg_info (Pp.str (Printf.sprintf "Evars: %d -> %d\n" size new_size)); - new_el, { comb; solution = new_solution } + new_el, { pv with solution = new_solution; } (** {6 Starting and querying a proof view} *) @@ -55,15 +56,17 @@ type telescope = | TNil of Evd.evar_map | TCons of Environ.env * Evd.evar_map * Term.types * (Evd.evar_map -> Term.constr -> telescope) +let typeclass_resolvable = Evd.Store.field () + let dependent_init = (* Goals are created with a store which marks them as unresolvable for type classes. *) - let store = Typeclasses.set_resolvable Evd.Store.empty false in + let store = Evd.Store.set Evd.Store.empty typeclass_resolvable () in (* Goals don't have a source location. *) let src = (Loc.ghost,Evar_kinds.GoalEvar) in (* Main routine *) let rec aux = function - | TNil sigma -> [], { solution = sigma; comb = []; } + | TNil sigma -> [], { solution = sigma; comb = []; shelf = [] } | TCons (env, sigma, typ, t) -> let sigma = Sigma.Unsafe.of_evar_map sigma in let Sigma (econstr, sigma, _) = Evarutil.new_evar env sigma ~src ~store typ in @@ -71,7 +74,7 @@ let dependent_init = let ret, { solution = sol; comb = comb } = aux (t sigma econstr) in let (gl, _) = Term.destEvar econstr in let entry = (econstr, typ) :: ret in - entry, { solution = sol; comb = gl :: comb; } + entry, { solution = sol; comb = gl :: comb; shelf = [] } in fun t -> let entry, v = aux t in @@ -235,6 +238,9 @@ let apply env t sp = match ans with | Nil (e, info) -> iraise (TacticFailure e, info) | Cons ((r, (state, _), status, info), _) -> + let (status, gaveup) = status in + let status = (status, state.shelf, gaveup) in + let state = { state with shelf = [] } in r, state, status, Trace.to_tree info @@ -350,7 +356,7 @@ exception NoSuchGoals of int (* This hook returns a string to be appended to the usual message. Primarily used to add a suggestion about the right bullet to use to focus the next goal, if applicable. *) -let nosuchgoals_hook:(int -> string option) ref = ref ((fun n -> None)) +let nosuchgoals_hook:(int -> std_ppcmds) ref = ref (fun n -> mt ()) let set_nosuchgoals_hook f = nosuchgoals_hook := f @@ -358,10 +364,9 @@ let set_nosuchgoals_hook f = nosuchgoals_hook := f (* This uses the hook above *) let _ = Errors.register_handler begin function | NoSuchGoals n -> - let suffix:string option = (!nosuchgoals_hook) n in + let suffix = !nosuchgoals_hook n in Errors.errorlabstrm "" - (str "No such " ++ str (String.plural n "goal") ++ str "." - ++ pr_opt str suffix) + (str "No such " ++ str (String.plural n "goal") ++ str "." ++ suffix) | _ -> raise Errors.Unhandled end @@ -387,20 +392,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} *) @@ -578,7 +586,7 @@ let shelve = Comb.get >>= fun initial -> Comb.set [] >> InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve")) >> - Shelf.put initial + Shelf.modify (fun gls -> gls @ initial) (** [contained_in_info e evi] checks whether the evar [e] appears in @@ -617,20 +625,20 @@ let shelve_unifiable = let (u,n) = partition_unifiable initial.solution initial.comb in Comb.set n >> InfoL.leaf (Info.Tactic (fun () -> Pp.str"shelve_unifiable")) >> - Shelf.put u + Shelf.modify (fun gls -> gls @ u) -(** [guard_no_unifiable] fails with error [UnresolvedBindings] if some +(** [guard_no_unifiable] returns the list of unifiable goals if some goals are unifiable (see {!shelve_unifiable}) in the current focus. *) let guard_no_unifiable = let open Proof in Pv.get >>= fun initial -> let (u,n) = partition_unifiable initial.solution initial.comb in match u with - | [] -> tclUNIT () + | [] -> tclUNIT None | gls -> let l = CList.map (fun g -> Evd.dependent_evar_ident g initial.solution) gls in let l = CList.map (fun id -> Names.Name id) l in - tclZERO (Logic.RefinerError (Logic.UnresolvedBindings l)) + tclUNIT (Some l) (** [unshelve l p] adds all the goals in [l] at the end of the focused goals of p *) @@ -639,6 +647,20 @@ let unshelve l p = let l = undefined p.solution l in { p with comb = p.comb@l } +let with_shelf tac = + let open Proof in + Pv.get >>= fun pv -> + let { shelf; solution } = pv in + Pv.set { pv with shelf = []; solution = Evd.reset_future_goals solution } >> + tac >>= fun ans -> + Pv.get >>= fun npv -> + let { shelf = gls; solution = sigma } = npv in + let gls' = Evd.future_goals sigma in + let fgoals = Evd.future_goals solution in + let pgoal = Evd.principal_future_goal solution in + let sigma = Evd.restore_future_goals sigma fgoals pgoal in + Pv.set { npv with shelf; solution = sigma } >> + tclUNIT (CList.rev_append gls' gls, ans) (** [goodmod p m] computes the representative of [p] modulo [m] in the interval [[0,m-1]].*) @@ -731,9 +753,15 @@ module Progress = struct let eq_named_context_val sigma1 sigma2 ctx1 ctx2 = let open Environ in let c1 = named_context_of_val ctx1 and c2 = named_context_of_val ctx2 in - let eq_named_declaration (i1, c1, t1) (i2, c2, t2) = - Names.Id.equal i1 i2 && Option.equal (eq_constr sigma1 sigma2) c1 c2 - && (eq_constr sigma1 sigma2) t1 t2 + let eq_named_declaration d1 d2 = + match d1, d2 with + | LocalAssum (i1,t1), LocalAssum (i2,t2) -> + Names.Id.equal i1 i2 && eq_constr sigma1 sigma2 t1 t2 + | LocalDef (i1,c1,t1), LocalDef (i2,c2,t2) -> + Names.Id.equal i1 i2 && eq_constr sigma1 sigma2 c1 c2 + && eq_constr sigma1 sigma2 t1 t2 + | _ -> + false in List.equal eq_named_declaration c1 c2 let eq_evar_body sigma1 sigma2 b1 b2 = @@ -867,7 +895,7 @@ module Unsafe = struct let tclSETGOALS = Comb.set let tclEVARSADVANCE evd = - Pv.modify (fun ps -> { solution = evd; comb = undefined evd ps.comb }) + Pv.modify (fun ps -> { ps with solution = evd; comb = undefined evd ps.comb }) let tclEVARUNIVCONTEXT ctx = Pv.modify (fun ps -> { ps with solution = Evd.set_universe_context ps.solution ctx }) @@ -875,18 +903,22 @@ module Unsafe = struct let reset_future_goals p = { p with solution = Evd.reset_future_goals p.solution } - let mark_as_goal_evm evd content = + let mark_as_goal evd content = let info = Evd.find evd content in let info = { info with Evd.evar_source = match info.Evd.evar_source with | _, (Evar_kinds.VarInstance _ | Evar_kinds.GoalEvar) as x -> x | loc,_ -> loc,Evar_kinds.GoalEvar } in - let info = Typeclasses.mark_unresolvable info in + let info = match Evd.Store.get info.Evd.evar_extra typeclass_resolvable with + | None -> { info with Evd.evar_extra = Evd.Store.set info.Evd.evar_extra typeclass_resolvable () } + | Some () -> info + in Evd.add evd content info - let mark_as_goal p gl = - { p with solution = mark_as_goal_evm p.solution gl } + let advance = advance + + let typeclass_resolvable = typeclass_resolvable end @@ -898,8 +930,20 @@ let (<+>) t1 t2 = tclOR t1 (fun _ -> t2) (** {6 Goal-dependent tactics} *) -(* To avoid shadowing by the local [Goal] module *) -module GoalV82 = Goal.V82 +let goal_env evars gl = + let evi = Evd.find evars gl in + Evd.evar_filtered_env evi + +let goal_nf_evar sigma gl = + let evi = Evd.find sigma gl in + let evi = Evarutil.nf_evar_info sigma evi in + let sigma = Evd.add sigma gl evi in + (gl, sigma) + +let goal_extra evars gl = + let evi = Evd.find evars gl in + evi.Evd.evar_extra + let catchable_exception = function | Logic_monad.Exception _ -> false @@ -924,7 +968,7 @@ module Goal = struct let sigma { sigma=sigma } = Sigma.Unsafe.of_evar_map sigma let hyps { env=env } = Environ.named_context env let concl { concl=concl } = concl - let extra { sigma=sigma; self=self } = Goal.V82.extra sigma self + let extra { sigma=sigma; self=self } = goal_extra sigma self let raw_concl { concl=concl } = concl @@ -978,7 +1022,7 @@ module Goal = struct end type ('a, 'b) s_enter = - { s_enter : 'r. ('a, 'r) t -> 'r Sigma.t -> ('b, 'r) Sigma.sigma } + { s_enter : 'r. ('a, 'r) t -> ('b, 'r) Sigma.sigma } let s_enter f = InfoL.tag (Info.Dispatch) begin @@ -987,8 +1031,7 @@ module Goal = struct tclEVARMAP >>= fun sigma -> try let gl = gmake env sigma goal in - let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma (tac, sigma, _) = f.s_enter gl sigma in + let Sigma (tac, sigma, _) = f.s_enter gl in let sigma = Sigma.to_evar_map sigma in tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) tac) with e when catchable_exception e -> @@ -1004,8 +1047,7 @@ module Goal = struct tclEVARMAP >>= fun sigma -> try let (gl, sigma) = nf_gmake env sigma goal in - let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma (tac, sigma, _) = f.s_enter gl sigma in + let Sigma (tac, sigma, _) = f.s_enter gl in let sigma = Sigma.to_evar_map sigma in tclTHEN (Unsafe.tclEVARS sigma) (InfoL.tag (Info.DBranch) tac) with e when catchable_exception e -> @@ -1015,7 +1057,6 @@ module Goal = struct end let goals = - Env.get >>= fun env -> Pv.get >>= fun step -> let sigma = step.solution in let map goal = @@ -1023,6 +1064,7 @@ module Goal = struct | None -> None (** ppedrot: Is this check really necessary? *) | Some goal -> let gl = + Env.get >>= fun env -> tclEVARMAP >>= fun sigma -> tclUNIT (gmake env sigma goal) in @@ -1039,90 +1081,6 @@ end -(** {6 The refine tactic} *) - -module Refine = -struct - - let typecheck_evar ev env sigma = - let info = Evd.find sigma ev in - let evdref = ref sigma in - let env = Environ.reset_with_named_context (Evd.evar_hyps info) env in - let _ = Typing.sort_of env evdref (Evd.evar_concl info) in - !evdref - - let typecheck_proof c concl env sigma = - let evdref = ref sigma in - let () = Typing.check env evdref c concl in - !evdref - - let (pr_constrv,pr_constr) = - Hook.make ~default:(fun _env _sigma _c -> Pp.str"<constr>") () - - let refine ?(unsafe = true) f = Goal.enter { Goal.enter = begin fun gl -> - let sigma = Goal.sigma gl in - let sigma = Sigma.to_evar_map sigma in - let env = Goal.env gl in - let concl = Goal.concl gl in - (** Save the [future_goals] state to restore them after the - refinement. *) - let prev_future_goals = Evd.future_goals sigma in - let prev_principal_goal = Evd.principal_future_goal sigma in - (** Create the refinement term *) - let (c, sigma) = Sigma.run (Evd.reset_future_goals sigma) f in - let evs = Evd.future_goals sigma in - let evkmain = Evd.principal_future_goal sigma in - (** Check that the introduced evars are well-typed *) - let fold accu ev = typecheck_evar ev env accu in - let sigma = if unsafe then sigma else CList.fold_left fold sigma evs in - (** Check that the refined term is typesafe *) - let sigma = if unsafe then sigma else typecheck_proof c concl env sigma in - (** Check that the goal itself does not appear in the refined term *) - let _ = - if not (Evarutil.occur_evar_upto sigma gl.Goal.self c) then () - else Pretype_errors.error_occur_check env sigma gl.Goal.self c - in - (** Proceed to the refinement *) - let sigma = match evkmain with - | None -> Evd.define gl.Goal.self c sigma - | Some evk -> - let id = Evd.evar_ident gl.Goal.self sigma in - Evd.rename evk id (Evd.define gl.Goal.self c sigma) - in - (** Restore the [future goals] state. *) - let sigma = Evd.restore_future_goals sigma prev_future_goals prev_principal_goal in - (** Select the goals *) - 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.(hov 2 (str"refine"++spc()++ Hook.get pr_constrv env sigma c)))) >> - Pv.set { solution = sigma; comb; } - end } - - (** Useful definitions *) - - let with_type env evd c t = - let my_type = Retyping.get_type_of env evd c in - let j = Environ.make_judge c my_type in - let (evd,j') = - Coercion.inh_conv_coerce_to true (Loc.ghost) env evd j t - in - evd , j'.Environ.uj_val - - let refine_casted ?unsafe f = Goal.enter { Goal.enter = begin fun gl -> - let concl = Goal.concl gl in - let env = Goal.env gl in - let f = { run = fun h -> - let Sigma (c, h, p) = f.run h in - let sigma, c = with_type env (Sigma.to_evar_map h) c concl in - Sigma (c, Sigma.Unsafe.of_evar_map sigma, p) - } in - refine ?unsafe f - end } -end - - - (** {6 Trace} *) module Trace = struct @@ -1173,13 +1131,13 @@ module V82 = struct in (* Old style tactics expect the goals normalized with respect to evars. *) let (initgoals,initevd) = - Evd.Monad.List.map (fun g s -> GoalV82.nf_evar s g) ps.comb ps.solution + Evd.Monad.List.map (fun g s -> goal_nf_evar s g) ps.comb ps.solution in let (goalss,evd) = Evd.Monad.List.map tac initgoals initevd in let sgs = CList.flatten goalss in let sgs = undefined evd sgs in InfoL.leaf (Info.Tactic (fun () -> Pp.str"<unknown>")) >> - Pv.set { solution = evd; comb = sgs; } + Pv.set { ps with solution = evd; comb = sgs; } with e when catchable_exception e -> let (e, info) = Errors.push e in tclZERO ~info e @@ -1189,9 +1147,9 @@ module V82 = struct solution. *) let nf_evar_goals = Pv.modify begin fun ps -> - let map g s = GoalV82.nf_evar s g in + let map g s = goal_nf_evar s g in let (goals,evd) = Evd.Monad.List.map map ps.comb ps.solution in - { solution = evd; comb = goals; } + { ps with solution = evd; comb = goals; } end let has_unresolved_evar pv = @@ -1220,24 +1178,10 @@ module V82 = struct in CList.flatten (CList.map evars_of_initial initial) - let instantiate_evar n com pv = - let (evk,_) = - let evl = Evarutil.non_instantiated pv.solution in - let evl = Evar.Map.bindings evl in - if (n <= 0) then - Errors.error "incorrect existential variable index" - else if CList.length evl < n then - Errors.error "not so many uninstantiated existential variables" - else - CList.nth evl (n-1) - in - { pv with - solution = Evar_refiner.instantiate_pf_com evk com pv.solution } - let of_tactic t gls = try - let init = { solution = gls.Evd.sigma ; comb = [gls.Evd.it] } in - let (_,final,_,_) = apply (GoalV82.env gls.Evd.sigma gls.Evd.it) t init in + let init = { shelf = []; solution = gls.Evd.sigma ; comb = [gls.Evd.it] } in + let (_,final,_,_) = apply (goal_env gls.Evd.sigma gls.Evd.it) t init in { Evd.sigma = final.solution ; it = final.comb } with Logic_monad.TacticFailure e as src -> let (_, info) = Errors.push src in @@ -1263,5 +1207,5 @@ module Notations = struct type ('a, 'b) enter = ('a, 'b) Goal.enter = { enter : 'r. ('a, 'r) Goal.t -> 'b } type ('a, 'b) s_enter = ('a, 'b) Goal.s_enter = - { s_enter : 'r. ('a, 'r) Goal.t -> 'r Sigma.t -> ('b, 'r) Sigma.sigma } + { s_enter : 'r. ('a, 'r) Goal.t -> ('b, 'r) Sigma.sigma } end diff --git a/proofs/proofview.mli b/engine/proofview.mli index 0b6c147f9..7996b7969 100644 --- a/proofs/proofview.mli +++ b/engine/proofview.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -235,7 +235,7 @@ val tclBREAK : (iexn -> iexn option) -> 'a tactic -> 'a tactic This hook is used to add a suggestion about bullets when applicable. *) exception NoSuchGoals of int -val set_nosuchgoals_hook: (int -> string option) -> unit +val set_nosuchgoals_hook: (int -> Pp.std_ppcmds) -> unit val tclFOCUS : int -> int -> 'a tactic -> 'a tactic @@ -295,14 +295,18 @@ val shelve : unit tactic considered). *) val shelve_unifiable : unit tactic -(** [guard_no_unifiable] fails with error [UnresolvedBindings] if some +(** [guard_no_unifiable] returns the list of unifiable goals if some goals are unifiable (see {!shelve_unifiable}) in the current focus. *) -val guard_no_unifiable : unit tactic +val guard_no_unifiable : Names.Name.t list option tactic (** [unshelve l p] adds all the goals in [l] at the end of the focused goals of p *) val unshelve : Goal.goal list -> proofview -> proofview +(** [with_shelf tac] executes [tac] and returns its result together with the set + of goals shelved by [tac]. The current shelf is unchanged. *) +val with_shelf : 'a tactic -> (Goal.goal list * 'a) tactic + (** If [n] is positive, [cycle n] puts the [n] first goal last. If [n] is negative, then it puts the [n] last goals first.*) val cycle : int -> unit tactic @@ -336,7 +340,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 @@ -402,7 +406,16 @@ module Unsafe : sig (** Give an evar the status of a goal (changes its source location and makes it unresolvable for type classes. *) - val mark_as_goal : proofview -> Evar.t -> proofview + val mark_as_goal : Evd.evar_map -> Evar.t -> Evd.evar_map + + (** [advance sigma g] returns [Some g'] if [g'] is undefined and is + the current avatar of [g] (for instance [g] was changed by [clear] + into [g']). It returns [None] if [g] has been (partially) + solved. *) + val advance : Evd.evar_map -> Evar.t -> Evar.t option + + val typeclass_resolvable : unit Evd.Store.field + end (** This module gives access to the innards of the monad. Its use is @@ -442,7 +455,7 @@ module Goal : sig environment of [gl] (i.e. the global environment and the hypotheses) and the current evar map. *) val concl : ([ `NF ], 'r) t -> Term.constr - val hyps : ([ `NF ], 'r) t -> Context.named_context + val hyps : ([ `NF ], 'r) t -> Context.Named.t val env : ('a, 'r) t -> Environ.env val sigma : ('a, 'r) t -> 'r Sigma.t val extra : ('a, 'r) t -> Evd.Store.t @@ -464,7 +477,7 @@ module Goal : sig val enter : ([ `LZ ], unit tactic) enter -> unit tactic type ('a, 'b) s_enter = - { s_enter : 'r. ('a, 'r) t -> 'r Sigma.t -> ('b, 'r) Sigma.sigma } + { s_enter : 'r. ('a, 'r) t -> ('b, 'r) Sigma.sigma } (** A variant of {!enter} allows to work with a monotonic state. The evarmap returned by the argument is put back into the current state before firing @@ -487,39 +500,6 @@ module Goal : sig end -(** {6 The refine tactic} *) - -module Refine : sig - - (** Printer used to print the constr which refine refines. *) - val pr_constr : - (Environ.env -> Evd.evar_map -> Term.constr -> Pp.std_ppcmds) Hook.t - - (** {7 Refinement primitives} *) - - val refine : ?unsafe:bool -> Constr.t Sigma.run -> unit tactic - (** In [refine ?unsafe t], [t] is a term with holes under some - [evar_map] context. The term [t] is used as a partial solution - for the current goal (refine is a goal-dependent tactic), the - new holes created by [t] become the new subgoals. Exception - raised during the interpretation of [t] are caught and result in - tactic failures. If [unsafe] is [true] (default) [t] is - type-checked beforehand. *) - - (** {7 Helper functions} *) - - val with_type : Environ.env -> Evd.evar_map -> - Term.constr -> Term.types -> Evd.evar_map * Term.constr - (** [with_type env sigma c t] ensures that [c] is of type [t] - inserting a coercion if needed. *) - - val refine_casted : ?unsafe:bool -> Constr.t Sigma.run -> unit tactic - (** Like {!refine} except the refined term is coerced to the conclusion of the - current goal. *) - -end - - (** {6 Trace} *) module Trace : sig @@ -573,9 +553,6 @@ module V82 : sig (* returns the existential variable used to start the proof *) val top_evars : entry -> Evd.evar list - - (* Implements the Existential command *) - val instantiate_evar : int -> Constrexpr.constr_expr -> proofview -> proofview (* Caution: this function loses quite a bit of information. It should be avoided as much as possible. It should work as @@ -608,5 +585,5 @@ module Notations : sig type ('a, 'b) enter = ('a, 'b) Goal.enter = { enter : 'r. ('a, 'r) Goal.t -> 'b } type ('a, 'b) s_enter = ('a, 'b) Goal.s_enter = - { s_enter : 'r. ('a, 'r) Goal.t -> 'r Sigma.t -> ('b, 'r) Sigma.sigma } + { s_enter : 'r. ('a, 'r) Goal.t -> ('b, 'r) Sigma.sigma } end diff --git a/engine/proofview_monad.ml b/engine/proofview_monad.ml index 6e68cd2e4..6f52b3ee9 100644 --- a/engine/proofview_monad.ml +++ b/engine/proofview_monad.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -108,11 +108,6 @@ module Info = struct and compress f = CList.map_filter compress_tree f - let rec is_empty = let open Trace in function - | Seq(Dispatch,brs) -> List.for_all is_empty brs - | Seq(DBranch,br) -> List.for_all is_empty br - | _ -> false - (** [with_sep] is [true] when [Tactic m] must be printed with a trailing semi-colon. *) let rec pr_tree with_sep = let open Trace in function @@ -157,8 +152,11 @@ end (** Type of proof views: current [evar_map] together with the list of focused goals. *) -type proofview = { solution : Evd.evar_map; comb : Goal.goal list } - +type proofview = { + solution : Evd.evar_map; + comb : Evar.t list; + shelf : Evar.t list; +} (** {6 Instantiation of the logic monad} *) @@ -171,10 +169,10 @@ module P = struct type e = bool (** Status (safe/unsafe) * shelved goals * given up *) - type w = bool * Evar.t list * Evar.t list + type w = bool * Evar.t list - let wunit = true , [] , [] - let wprod (b1,s1,g1) (b2,s2,g2) = b1 && b2 , s1@s2 , g1@g2 + let wunit = true , [] + let wprod (b1, g1) (b2, g2) = b1 && b2 , g1@g2 type u = Info.state @@ -226,19 +224,21 @@ module Env : State with type t := Environ.env = struct end module Status : Writer with type t := bool = struct - let put s = Logical.put (s,[],[]) + let put s = Logical.put (s, []) end -module Shelf : Writer with type t = Evar.t list = struct +module Shelf : State with type t = Evar.t list = struct (* spiwack: I don't know why I cannot substitute ([:=]) [t] with a type expression. *) type t = Evar.t list - let put sh = Logical.put (true,sh,[]) + let get = Logical.map (fun {shelf} -> shelf) Pv.get + let set c = Pv.modify (fun pv -> { pv with shelf = c }) + let modify f = Pv.modify (fun pv -> { pv with shelf = f pv.shelf }) end module Giveup : Writer with type t = Evar.t list = struct (* spiwack: I don't know why I cannot substitute ([:=]) [t] with a type expression. *) type t = Evar.t list - let put gs = Logical.put (true,[],gs) + let put gs = Logical.put (true, gs) end (** Lens and utilies pertaining to the info trace *) diff --git a/engine/proofview_monad.mli b/engine/proofview_monad.mli index d2a2e55fb..0aff0a720 100644 --- a/engine/proofview_monad.mli +++ b/engine/proofview_monad.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -68,15 +68,19 @@ end (** Type of proof views: current [evar_map] together with the list of focused goals. *) -type proofview = { solution : Evd.evar_map; comb : Goal.goal list } +type proofview = { + solution : Evd.evar_map; + comb : Evar.t list; + shelf : Evar.t list; +} (** {6 Instantiation of the logic monad} *) module P : sig type s = proofview * Environ.env - (** Status (safe/unsafe) * shelved goals * given up *) - type w = bool * Evar.t list * Evar.t list + (** Status (safe/unsafe) * given up *) + type w = bool * Evar.t list val wunit : w val wprod : w -> w -> w @@ -123,7 +127,7 @@ module Status : Writer with type t := bool (** Lens to the list of goals which have been shelved during the execution of the tactic. *) -module Shelf : Writer with type t = Evar.t list +module Shelf : State with type t = Evar.t list (** Lens to the list of goals which were given up during the execution of the tactic. *) diff --git a/engine/sigma.ml b/engine/sigma.ml index e3e83b602..c7b0bb5a5 100644 --- a/engine/sigma.ml +++ b/engine/sigma.ml @@ -36,12 +36,36 @@ let new_evar sigma ?naming info = let define evk c sigma = Sigma ((), Evd.define evk c sigma, ()) -let fresh_constructor_instance env sigma pc = - let (sigma, c) = Evd.fresh_constructor_instance env sigma pc in +let new_univ_level_variable ?loc ?name ?predicative rigid sigma = + let (sigma, u) = Evd.new_univ_level_variable ?loc ?name ?predicative rigid sigma in + Sigma (u, sigma, ()) + +let new_univ_variable ?loc ?name ?predicative rigid sigma = + let (sigma, u) = Evd.new_univ_variable ?loc ?name ?predicative rigid sigma in + Sigma (u, sigma, ()) + +let new_sort_variable ?loc ?name ?predicative rigid sigma = + let (sigma, u) = Evd.new_sort_variable ?loc ?name ?predicative rigid sigma in + Sigma (u, sigma, ()) + +let fresh_sort_in_family ?loc ?rigid env sigma s = + let (sigma, s) = Evd.fresh_sort_in_family ?loc ?rigid env sigma s in + Sigma (s, sigma, ()) + +let fresh_constant_instance ?loc env sigma cst = + let (sigma, cst) = Evd.fresh_constant_instance ?loc env sigma cst in + Sigma (cst, sigma, ()) + +let fresh_inductive_instance ?loc env sigma ind = + let (sigma, ind) = Evd.fresh_inductive_instance ?loc env sigma ind in + Sigma (ind, sigma, ()) + +let fresh_constructor_instance ?loc env sigma pc = + let (sigma, c) = Evd.fresh_constructor_instance ?loc env sigma pc in Sigma (c, sigma, ()) -let fresh_global ?rigid ?names env sigma r = - let (sigma, c) = Evd.fresh_global ?rigid ?names env sigma r in +let fresh_global ?loc ?rigid ?names env sigma r = + let (sigma, c) = Evd.fresh_global ?loc ?rigid ?names env sigma r in Sigma (c, sigma, ()) (** Run *) diff --git a/engine/sigma.mli b/engine/sigma.mli index 6ac56bb3e..643bea403 100644 --- a/engine/sigma.mli +++ b/engine/sigma.mli @@ -66,10 +66,23 @@ val define : 'r evar -> Constr.t -> 'r t -> (unit, 'r) sigma (** Polymorphic universes *) -val fresh_constructor_instance : Environ.env -> 'r t -> constructor -> +val new_univ_level_variable : ?loc:Loc.t -> ?name:string -> ?predicative:bool -> + Evd.rigid -> 'r t -> (Univ.universe_level, 'r) sigma +val new_univ_variable : ?loc:Loc.t -> ?name:string -> ?predicative:bool -> + Evd.rigid -> 'r t -> (Univ.universe, 'r) sigma +val new_sort_variable : ?loc:Loc.t -> ?name:string -> ?predicative:bool -> + Evd.rigid -> 'r t -> (Sorts.t, 'r) sigma + +val fresh_sort_in_family : ?loc:Loc.t -> ?rigid:Evd.rigid -> Environ.env -> + 'r t -> Term.sorts_family -> (Term.sorts, 'r) sigma +val fresh_constant_instance : + ?loc:Loc.t -> Environ.env -> 'r t -> constant -> (pconstant, 'r) sigma +val fresh_inductive_instance : + ?loc:Loc.t -> Environ.env -> 'r t -> inductive -> (pinductive, 'r) sigma +val fresh_constructor_instance : ?loc:Loc.t -> Environ.env -> 'r t -> constructor -> (pconstructor, 'r) sigma -val fresh_global : ?rigid:Evd.rigid -> ?names:Univ.Instance.t -> Environ.env -> +val fresh_global : ?loc:Loc.t -> ?rigid:Evd.rigid -> ?names:Univ.Instance.t -> Environ.env -> 'r t -> Globnames.global_reference -> (constr, 'r) sigma (** FILLME *) diff --git a/engine/termops.ml b/engine/termops.ml index 5a55d47fd..f698f8151 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -13,9 +13,11 @@ open Names open Nameops open Term open Vars -open Context open Environ +module RelDecl = Context.Rel.Declaration +module NamedDecl = Context.Named.Declaration + (* Sorts and sort family *) let print_sort = function @@ -99,26 +101,28 @@ let print_constr_env t = !term_printer t let print_constr t = !term_printer (Global.env()) t let set_print_constr f = term_printer := f -let pr_var_decl env (id,c,typ) = - let pbody = match c with - | None -> (mt ()) - | Some c -> +let pr_var_decl env decl = + let open NamedDecl in + let pbody = match decl with + | LocalAssum _ -> mt () + | LocalDef (_,c,_) -> (* Force evaluation *) let pb = print_constr_env env c in (str" := " ++ pb ++ cut () ) in - let pt = print_constr_env env typ in + let pt = print_constr_env env (get_type decl) in let ptyp = (str" : " ++ pt) in - (pr_id id ++ hov 0 (pbody ++ ptyp)) + (pr_id (get_id decl) ++ hov 0 (pbody ++ ptyp)) -let pr_rel_decl env (na,c,typ) = - let pbody = match c with - | None -> mt () - | Some c -> +let pr_rel_decl env decl = + let open RelDecl in + let pbody = match decl with + | LocalAssum _ -> mt () + | LocalDef (_,c,_) -> (* Force evaluation *) let pb = print_constr_env env c in (str":=" ++ spc () ++ pb ++ spc ()) in - let ptyp = print_constr_env env typ in - match na with + let ptyp = print_constr_env env (get_type decl) in + match get_name decl with | Anonymous -> hov 0 (str"<>" ++ spc () ++ pbody ++ str":" ++ spc () ++ ptyp) | Name id -> hov 0 (pr_id id ++ spc () ++ pbody ++ str":" ++ spc () ++ ptyp) @@ -158,55 +162,53 @@ let rel_list n m = in reln [] 1 -(* Same as [rel_list] but takes a context as argument and skips let-ins *) -let extended_rel_list n hyps = - let rec reln l p = function - | (_,None,_) :: hyps -> reln (mkRel (n+p) :: l) (p+1) hyps - | (_,Some _,_) :: hyps -> reln l (p+1) hyps - | [] -> l - in - reln [] 1 hyps - -let extended_rel_vect n hyps = Array.of_list (extended_rel_list n hyps) - - - -let push_rel_assum (x,t) env = push_rel (x,None,t) env +let push_rel_assum (x,t) env = + let open RelDecl in + push_rel (LocalAssum (x,t)) env let push_rels_assum assums = - push_rel_context (List.map (fun (x,t) -> (x,None,t)) assums) + let open RelDecl in + push_rel_context (List.map (fun (x,t) -> LocalAssum (x,t)) assums) let push_named_rec_types (lna,typarray,_) env = + let open NamedDecl in let ctxt = Array.map2_i (fun i na t -> match na with - | Name id -> (id, None, lift i t) + | Name id -> LocalAssum (id, lift i t) | Anonymous -> anomaly (Pp.str "Fix declarations must be named")) lna typarray in Array.fold_left (fun e assum -> push_named assum e) env ctxt let lookup_rel_id id sign = + let open RelDecl in let rec lookrec n = function - | [] -> raise Not_found - | (Anonymous, _, _) :: l -> lookrec (n + 1) l - | (Name id', b, t) :: l -> - if Names.Id.equal id' id then (n, b, t) else lookrec (n + 1) l + | [] -> + raise Not_found + | (LocalAssum (Anonymous, _) | LocalDef (Anonymous,_,_)) :: l -> + lookrec (n + 1) l + | LocalAssum (Name id', t) :: l -> + if Names.Id.equal id' id then (n,None,t) else lookrec (n + 1) l + | LocalDef (Name id', b, t) :: l -> + if Names.Id.equal id' id then (n,Some b,t) else lookrec (n + 1) l in lookrec 1 sign (* Constructs either [forall x:t, c] or [let x:=b:t in c] *) -let mkProd_or_LetIn (na,body,t) c = - match body with - | None -> mkProd (na, t, c) - | Some b -> mkLetIn (na, b, t, c) +let mkProd_or_LetIn decl c = + let open RelDecl in + match decl with + | LocalAssum (na,t) -> mkProd (na, t, c) + | LocalDef (na,b,t) -> mkLetIn (na, b, t, c) (* Constructs either [forall x:t, c] or [c] in which [x] is replaced by [b] *) -let mkProd_wo_LetIn (na,body,t) c = - match body with - | None -> mkProd (na, t, c) - | Some b -> subst1 b c +let mkProd_wo_LetIn decl c = + let open RelDecl in + match decl with + | LocalAssum (na,t) -> mkProd (na, t, c) + | LocalDef (_,b,_) -> subst1 b c let it_mkProd init = List.fold_left (fun c (n,t) -> mkProd (n, t, c)) init let it_mkLambda init = List.fold_left (fun c (n,t) -> mkLambda (n, t, c)) init @@ -222,10 +224,11 @@ let it_mkNamedProd_wo_LetIn init = it_named_context_quantifier mkNamedProd_wo_Le let it_mkNamedLambda_or_LetIn init = it_named_context_quantifier mkNamedLambda_or_LetIn ~init let it_mkLambda_or_LetIn_from_no_LetIn c decls = + let open RelDecl in let rec aux k decls c = match decls with | [] -> c - | (na,Some b,t)::decls -> mkLetIn (na,b,t,aux (k-1) decls (liftn 1 k c)) - | (na,None,t)::decls -> mkLambda (na,t,aux (k-1) decls c) + | LocalDef (na,b,t) :: decls -> mkLetIn (na,b,t,aux (k-1) decls (liftn 1 k c)) + | LocalAssum (na,t) :: decls -> mkLambda (na,t,aux (k-1) decls c) in aux (List.length decls) (List.rev decls) c (* *) @@ -316,7 +319,7 @@ let map_constr_with_named_binders g f l c = match kind_of_term c with (co-)fixpoint) *) let fold_rec_types g (lna,typarray,_) e = - let ctxt = Array.map2_i (fun i na t -> (na, None, lift i t)) lna typarray in + let ctxt = Array.map2_i (fun i na t -> RelDecl.LocalAssum (na, lift i t)) lna typarray in Array.fold_left (fun e assum -> g assum e) e ctxt let map_left2 f a g b = @@ -331,7 +334,9 @@ let map_left2 f a g b = r, s end -let map_constr_with_binders_left_to_right g f l c = match kind_of_term c with +let map_constr_with_binders_left_to_right g f l c = + let open RelDecl in + match kind_of_term c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> c | Cast (b,k,t) -> @@ -341,18 +346,18 @@ let map_constr_with_binders_left_to_right g f l c = match kind_of_term c with else mkCast (b',k,t') | Prod (na,t,b) -> let t' = f l t in - let b' = f (g (na,None,t) l) b in + let b' = f (g (LocalAssum (na,t)) l) b in if t' == t && b' == b then c else mkProd (na, t', b') | Lambda (na,t,b) -> let t' = f l t in - let b' = f (g (na,None,t) l) b in + let b' = f (g (LocalAssum (na,t)) l) b in if t' == t && b' == b then c else mkLambda (na, t', b') | LetIn (na,bo,t,b) -> let bo' = f l bo in let t' = f l t in - let b' = f (g (na,Some bo,t) l) b in + let b' = f (g (LocalDef (na,bo,t)) l) b in if bo' == bo && t' == t && b' == b then c else mkLetIn (na, bo', t', b') | App (c,[||]) -> assert false @@ -393,7 +398,9 @@ let map_constr_with_binders_left_to_right g f l c = match kind_of_term c with else mkCoFix (ln,(lna,tl',bl')) (* strong *) -let map_constr_with_full_binders g f l cstr = match kind_of_term cstr with +let map_constr_with_full_binders g f l cstr = + let open RelDecl in + match kind_of_term cstr with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> cstr | Cast (c,k, t) -> @@ -402,16 +409,16 @@ let map_constr_with_full_binders g f l cstr = match kind_of_term cstr with if c==c' && t==t' then cstr else mkCast (c', k, t') | Prod (na,t,c) -> let t' = f l t in - let c' = f (g (na,None,t) l) c in + let c' = f (g (LocalAssum (na,t)) l) c in if t==t' && c==c' then cstr else mkProd (na, t', c') | Lambda (na,t,c) -> let t' = f l t in - let c' = f (g (na,None,t) l) c in + let c' = f (g (LocalAssum (na,t)) l) c in if t==t' && c==c' then cstr else mkLambda (na, t', c') | LetIn (na,b,t,c) -> let b' = f l b in let t' = f l t in - let c' = f (g (na,Some b,t) l) c in + let c' = f (g (LocalDef (na,b,t)) l) c in if b==b' && t==t' && c==c' then cstr else mkLetIn (na, b', t', c') | App (c,al) -> let c' = f l c in @@ -432,7 +439,7 @@ let map_constr_with_full_binders g f l cstr = match kind_of_term cstr with | Fix (ln,(lna,tl,bl)) -> let tl' = Array.map (f l) tl in let l' = - Array.fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in + Array.fold_left2 (fun l na t -> g (LocalAssum (na,t)) l) l lna tl in let bl' = Array.map (f l') bl in if Array.for_all2 (==) tl tl' && Array.for_all2 (==) bl bl' then cstr @@ -440,7 +447,7 @@ let map_constr_with_full_binders g f l cstr = match kind_of_term cstr with | CoFix(ln,(lna,tl,bl)) -> let tl' = Array.map (f l) tl in let l' = - Array.fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in + Array.fold_left2 (fun l na t -> g (LocalAssum (na,t)) l) l lna tl in let bl' = Array.map (f l') bl in if Array.for_all2 (==) tl tl' && Array.for_all2 (==) bl bl' then cstr @@ -453,23 +460,25 @@ 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_full_binders g f n acc c = match kind_of_term c with +let fold_constr_with_full_binders g f n acc c = + let open RelDecl in + 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 (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 + | Prod (na,t,c) -> f (g (LocalAssum (na,t)) n) (f n acc t) c + | Lambda (na,t,c) -> f (g (LocalAssum (na,t)) n) (f n acc t) c + | LetIn (na,b,t,c) -> f (g (LocalDef (na,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' = CArray.fold_left2 (fun c n t -> g (n,None,t) c) n lna tl in + let n' = CArray.fold_left2 (fun c n t -> g (LocalAssum (n,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' = CArray.fold_left2 (fun c n t -> g (n,None,t) c) n lna tl in + let n' = CArray.fold_left2 (fun c n t -> g (LocalAssum (n,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 @@ -481,23 +490,25 @@ let fold_constr_with_binders g f n acc c = each binder traversal; it is not recursive and the order with which subterms are processed is not specified *) -let iter_constr_with_full_binders g f l c = match kind_of_term c with +let iter_constr_with_full_binders g f l c = + let open RelDecl in + match kind_of_term c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> () | Cast (c,_, t) -> f l c; f l t - | Prod (na,t,c) -> f l t; f (g (na,None,t) l) c - | Lambda (na,t,c) -> f l t; f (g (na,None,t) l) c - | LetIn (na,b,t,c) -> f l b; f l t; f (g (na,Some b,t) l) c + | Prod (na,t,c) -> f l t; f (g (LocalAssum (na,t)) l) c + | Lambda (na,t,c) -> f l t; f (g (LocalAssum (na,t)) l) c + | LetIn (na,b,t,c) -> f l b; f l t; f (g (LocalDef (na,b,t)) l) c | App (c,args) -> f l c; Array.iter (f l) args | Proj (p,c) -> f l c | Evar (_,args) -> Array.iter (f l) args | Case (_,p,c,bl) -> f l p; f l c; Array.iter (f l) bl | Fix (_,(lna,tl,bl)) -> - let l' = Array.fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in + let l' = Array.fold_left2 (fun l na t -> g (LocalAssum (na,t)) l) l lna tl in Array.iter (f l) tl; Array.iter (f l') bl | CoFix (_,(lna,tl,bl)) -> - let l' = Array.fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in + let l' = Array.fold_left2 (fun l na t -> g (LocalAssum (na,t)) l) l lna tl in Array.iter (f l) tl; Array.iter (f l') bl @@ -545,10 +556,11 @@ let occur_var env id c = in try occur_rec c; false with Occur -> true -let occur_var_in_decl env hyp (_,c,typ) = - match c with - | None -> occur_var env hyp typ - | Some body -> +let occur_var_in_decl env hyp decl = + let open NamedDecl in + match decl with + | LocalAssum (_,typ) -> occur_var env hyp typ + | LocalDef (_, body, typ) -> occur_var env hyp typ || occur_var env hyp body @@ -607,10 +619,11 @@ let dependent_no_evar = dependent_main true false let dependent_univs = dependent_main false true let dependent_univs_no_evar = dependent_main true true -let dependent_in_decl a (_,c,t) = - match c with - | None -> dependent a t - | Some body -> dependent a body || dependent a t +let dependent_in_decl a decl = + let open NamedDecl in + match decl with + | LocalAssum (_,t) -> dependent a t + | LocalDef (_, body, t) -> dependent a body || dependent a t let count_occurrences m t = let n = ref 0 in @@ -713,10 +726,10 @@ let replace_term = replace_term_gen eq_constr let vars_of_env env = let s = - Context.fold_named_context (fun (id,_,_) s -> Id.Set.add id s) + Context.Named.fold_outside (fun decl s -> Id.Set.add (NamedDecl.get_id decl) s) (named_context env) ~init:Id.Set.empty in - Context.fold_rel_context - (fun (na,_,_) s -> match na with Name id -> Id.Set.add id s | _ -> s) + Context.Rel.fold_outside + (fun decl s -> match RelDecl.get_name decl with Name id -> Id.Set.add id s | _ -> s) (rel_context env) ~init:s let add_vname vars = function @@ -741,12 +754,12 @@ let lookup_rel_of_name id names = let empty_names_context = [] let ids_of_rel_context sign = - Context.fold_rel_context - (fun (na,_,_) l -> match na with Name id -> id::l | Anonymous -> l) + Context.Rel.fold_outside + (fun decl l -> match RelDecl.get_name decl with Name id -> id::l | Anonymous -> l) sign ~init:[] let ids_of_named_context sign = - Context.fold_named_context (fun (id,_,_) idl -> id::idl) sign ~init:[] + Context.Named.fold_outside (fun decl idl -> NamedDecl.get_id decl :: idl) sign ~init:[] let ids_of_context env = (ids_of_rel_context (rel_context env)) @@ -754,7 +767,7 @@ let ids_of_context env = let names_of_rel_context env = - List.map (fun (na,_,_) -> na) (rel_context env) + List.map RelDecl.get_name (rel_context env) let is_section_variable id = try let _ = Global.lookup_named id in true @@ -801,7 +814,7 @@ let split_app c = match kind_of_term c with c::(Array.to_list prev), last | _ -> assert false -type subst = (rel_context*constr) Evar.Map.t +type subst = (Context.Rel.t * constr) Evar.Map.t exception CannotFilter @@ -827,7 +840,7 @@ let filtering env cv_pb c1 c2 = end | Prod (n,t1,c1), Prod (_,t2,c2) -> aux env cv_pb t1 t2; - aux ((n,None,t1)::env) cv_pb c1 c2 + aux (RelDecl.LocalAssum (n,t1) :: env) cv_pb c1 c2 | _, Evar (ev,_) -> define cv_pb env ev c1 | Evar (ev,_), _ -> define cv_pb env ev c2 | _ -> @@ -838,15 +851,43 @@ let filtering env cv_pb c1 c2 = in aux env cv_pb c1 c2; !evm -let decompose_prod_letin : constr -> int * rel_context * constr = +let decompose_prod_letin : constr -> int * Context.Rel.t * constr = let rec prodec_rec i l c = match kind_of_term c with - | Prod (n,t,c) -> prodec_rec (succ i) ((n,None,t)::l) c - | LetIn (n,d,t,c) -> prodec_rec (succ i) ((n,Some d,t)::l) c + | Prod (n,t,c) -> prodec_rec (succ i) (RelDecl.LocalAssum (n,t)::l) c + | LetIn (n,d,t,c) -> prodec_rec (succ i) (RelDecl.LocalDef (n,d,t)::l) c | Cast (c,_,_) -> prodec_rec i l c | _ -> i,l,c in prodec_rec 0 [] -let align_prod_letin c a : rel_context * constr = +(* (nb_lam [na1:T1]...[nan:Tan]c) where c is not an abstraction + * gives n (casts are ignored) *) +let nb_lam = + let rec nbrec n c = match kind_of_term c with + | Lambda (_,_,c) -> nbrec (n+1) c + | Cast (c,_,_) -> nbrec n c + | _ -> n + in + nbrec 0 + +(* similar to nb_lam, but gives the number of products instead *) +let nb_prod = + let rec nbrec n c = match kind_of_term c with + | Prod (_,_,c) -> nbrec (n+1) c + | Cast (c,_,_) -> nbrec n c + | _ -> n + in + nbrec 0 + +let nb_prod_modulo_zeta x = + let rec count n c = + match kind_of_term c with + Prod(_,_,t) -> count (n+1) t + | LetIn(_,a,_,t) -> count n (subst1 a t) + | Cast(c,_,_) -> count n c + | _ -> n + in count 0 x + +let align_prod_letin c a : Context.Rel.t * constr = let (lc,_,_) = decompose_prod_letin c in let (la,l,a) = decompose_prod_letin a in if not (la >= lc) then invalid_arg "align_prod_letin"; @@ -884,20 +925,20 @@ let process_rel_context f env = let sign = named_context_val env in let rels = rel_context env in let env0 = reset_with_named_context sign env in - Context.fold_rel_context f rels ~init:env0 + Context.Rel.fold_outside f rels ~init:env0 let assums_of_rel_context sign = - Context.fold_rel_context - (fun (na,c,t) l -> - match c with - Some _ -> l - | None -> (na, t)::l) + Context.Rel.fold_outside + (fun decl l -> + match decl with + | RelDecl.LocalDef _ -> l + | RelDecl.LocalAssum (na,t) -> (na, t)::l) sign ~init:[] let map_rel_context_in_env f env sign = let rec aux env acc = function | d::sign -> - aux (push_rel d env) (map_rel_declaration (f env) d :: acc) sign + aux (push_rel d env) (RelDecl.map_constr (f env) d :: acc) sign | [] -> acc in @@ -905,10 +946,10 @@ let map_rel_context_in_env f env sign = let map_rel_context_with_binders f sign = let rec aux k = function - | d::sign -> map_rel_declaration (f k) d :: aux (k-1) sign + | d::sign -> RelDecl.map_constr (f k) d :: aux (k-1) sign | [] -> [] in - aux (rel_context_length sign) sign + aux (Context.Rel.length sign) sign let substl_rel_context l = map_rel_context_with_binders (fun k -> substnl l (k-1)) @@ -919,60 +960,54 @@ let lift_rel_context n = let smash_rel_context sign = let rec aux acc = function | [] -> acc - | (_,None,_ as d) :: l -> aux (d::acc) l - | (_,Some b,_) :: l -> + | (RelDecl.LocalAssum _ as d) :: l -> aux (d::acc) l + | RelDecl.LocalDef (_,b,_) :: l -> (* Quadratic in the number of let but there are probably a few of them *) aux (List.rev (substl_rel_context [b] (List.rev acc))) l in List.rev (aux [] sign) -let adjust_subst_to_rel_context sign l = - let rec aux subst sign l = - match sign, l with - | (_,None,_)::sign', a::args' -> aux (a::subst) sign' args' - | (_,Some c,_)::sign', args' -> - aux (substl (List.rev subst) c :: subst) sign' args' - | [], [] -> List.rev subst - | _ -> anomaly (Pp.str "Instance and signature do not match") - in aux [] (List.rev sign) l - let fold_named_context_both_sides f l ~init = List.fold_right_and_left f l init -let rec mem_named_context id = function - | (id',_,_) :: _ when Id.equal id id' -> true +let rec mem_named_context id ctxt = + match ctxt with + | decl :: _ when Id.equal id (NamedDecl.get_id decl) -> true | _ :: sign -> mem_named_context id sign | [] -> false let compact_named_context_reverse sign = - let compact l (i1,c1,t1) = + let compact l decl = + let (i1,c1,t1) = NamedDecl.to_tuple decl in match l with | [] -> [[i1],c1,t1] | (l2,c2,t2)::q -> if Option.equal Constr.equal c1 c2 && Constr.equal t1 t2 then (i1::l2,c2,t2)::q else ([i1],c1,t1)::l - in Context.fold_named_context_reverse compact ~init:[] sign + in Context.Named.fold_inside compact ~init:[] sign let compact_named_context sign = List.rev (compact_named_context_reverse sign) let clear_named_body id env = + let open NamedDecl in let aux _ = function - | (id',Some c,t) when Id.equal id id' -> push_named (id,None,t) + | LocalDef (id',c,t) when Id.equal id id' -> push_named (LocalAssum (id,t)) | d -> push_named d in fold_named_context aux env ~init:(reset_context env) let global_vars env ids = Id.Set.elements (global_vars_set env ids) let global_vars_set_of_decl env = function - | (_,None,t) -> global_vars_set env t - | (_,Some c,t) -> + | NamedDecl.LocalAssum (_,t) -> global_vars_set env t + | NamedDecl.LocalDef (_,c,t) -> Id.Set.union (global_vars_set env t) (global_vars_set env c) let dependency_closure env sign hyps = if Id.Set.is_empty hyps then [] else let (_,lh) = - Context.fold_named_context_reverse - (fun (hs,hl) (x,_,_ as d) -> + Context.Named.fold_inside + (fun (hs,hl) d -> + let x = NamedDecl.get_id d in if Id.Set.mem x hs then (Id.Set.union (global_vars_set_of_decl env d) (Id.Set.remove x hs), x::hl) @@ -987,12 +1022,12 @@ let on_judgment f j = { uj_val = f j.uj_val; uj_type = f j.uj_type } let on_judgment_value f j = { j with uj_val = f j.uj_val } let on_judgment_type f j = { j with uj_type = f j.uj_type } -(* Cut a context ctx in 2 parts (ctx1,ctx2) with ctx1 containing k - variables; skips let-in's *) +(* Cut a context ctx in 2 parts (ctx1,ctx2) with ctx1 containing k non let-in + variables skips let-in's; let-in's in the middle are put in ctx2 *) let context_chop k ctx = let rec chop_aux acc = function | (0, l2) -> (List.rev acc, l2) - | (n, ((_,Some _,_ as h)::t)) -> chop_aux (h::acc) (n, t) + | (n, (RelDecl.LocalDef _ as h)::t) -> chop_aux (h::acc) (n, t) | (n, (h::t)) -> chop_aux (h::acc) (pred n, t) | (_, []) -> anomaly (Pp.str "context_chop") in chop_aux [] (k,ctx) diff --git a/engine/termops.mli b/engine/termops.mli index 6c680005d..c2a4f3323 100644 --- a/engine/termops.mli +++ b/engine/termops.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -9,7 +9,6 @@ open Pp open Names open Term -open Context open Environ (** printers *) @@ -22,7 +21,7 @@ val set_print_constr : (env -> constr -> std_ppcmds) -> unit val print_constr : constr -> std_ppcmds val print_constr_env : env -> constr -> std_ppcmds val print_named_context : env -> std_ppcmds -val pr_rel_decl : env -> rel_declaration -> std_ppcmds +val pr_rel_decl : env -> Context.Rel.Declaration.t -> std_ppcmds val print_rel_context : env -> std_ppcmds val print_env : env -> std_ppcmds @@ -31,35 +30,31 @@ val push_rel_assum : Name.t * types -> env -> env val push_rels_assum : (Name.t * types) list -> env -> env val push_named_rec_types : Name.t array * types array * 'a -> env -> env -val lookup_rel_id : Id.t -> rel_context -> int * constr option * types +val lookup_rel_id : Id.t -> Context.Rel.t -> int * constr option * types (** Associates the contents of an identifier in a [rel_context]. Raise [Not_found] if there is no such identifier. *) (** Functions that build argument lists matching a block of binders or a context. [rel_vect n m] builds [|Rel (n+m);...;Rel(n+1)|] - [extended_rel_vect n ctx] extends the [ctx] context of length [m] - with [n] elements. *) val rel_vect : int -> int -> constr array val rel_list : int -> int -> constr list -val extended_rel_list : int -> rel_context -> constr list -val extended_rel_vect : int -> rel_context -> constr array (** iterators/destructors on terms *) -val mkProd_or_LetIn : rel_declaration -> types -> types -val mkProd_wo_LetIn : rel_declaration -> types -> types +val mkProd_or_LetIn : Context.Rel.Declaration.t -> types -> types +val mkProd_wo_LetIn : Context.Rel.Declaration.t -> types -> types val it_mkProd : types -> (Name.t * types) list -> types val it_mkLambda : constr -> (Name.t * types) list -> constr -val it_mkProd_or_LetIn : types -> rel_context -> types -val it_mkProd_wo_LetIn : types -> rel_context -> types -val it_mkLambda_or_LetIn : constr -> rel_context -> constr -val it_mkNamedProd_or_LetIn : types -> named_context -> types -val it_mkNamedProd_wo_LetIn : types -> named_context -> types -val it_mkNamedLambda_or_LetIn : constr -> named_context -> constr +val it_mkProd_or_LetIn : types -> Context.Rel.t -> types +val it_mkProd_wo_LetIn : types -> Context.Rel.t -> types +val it_mkLambda_or_LetIn : constr -> Context.Rel.t -> constr +val it_mkNamedProd_or_LetIn : types -> Context.Named.t -> types +val it_mkNamedProd_wo_LetIn : types -> Context.Named.t -> types +val it_mkNamedLambda_or_LetIn : constr -> Context.Named.t -> constr (* Ad hoc version reinserting letin, assuming the body is defined in the context where the letins are expanded *) -val it_mkLambda_or_LetIn_from_no_LetIn : constr -> rel_context -> constr +val it_mkLambda_or_LetIn_from_no_LetIn : constr -> Context.Rel.t -> constr (** {6 Generic iterators on constr} *) @@ -67,11 +62,11 @@ val map_constr_with_named_binders : (Name.t -> 'a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr val map_constr_with_binders_left_to_right : - (rel_declaration -> 'a -> 'a) -> + (Context.Rel.Declaration.t -> 'a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr val map_constr_with_full_binders : - (rel_declaration -> 'a -> 'a) -> + (Context.Rel.Declaration.t -> 'a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr (** [fold_constr_with_binders g f n acc c] folds [f n] on the immediate @@ -85,11 +80,11 @@ 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) -> + (Context.Rel.Declaration.t -> 'a -> 'a) -> ('a -> 'b -> constr -> 'b) -> 'a -> 'b -> constr -> 'b val iter_constr_with_full_binders : - (rel_declaration -> 'a -> 'a) -> ('a -> constr -> unit) -> 'a -> + (Context.Rel.Declaration.t -> 'a -> 'a) -> ('a -> constr -> unit) -> 'a -> constr -> unit (**********************************************************************) @@ -106,7 +101,7 @@ val occur_evar : existential_key -> types -> bool val occur_var : env -> Id.t -> types -> bool val occur_var_in_decl : env -> - Id.t -> 'a * types option * types -> bool + Id.t -> Context.Named.Declaration.t -> bool val free_rels : constr -> Int.Set.t (** [dependent m t] tests whether [m] is a subterm of [t] *) @@ -114,7 +109,7 @@ val dependent : constr -> constr -> bool val dependent_no_evar : constr -> constr -> bool val dependent_univs : constr -> constr -> bool val dependent_univs_no_evar : constr -> constr -> bool -val dependent_in_decl : constr -> named_declaration -> bool +val dependent_in_decl : constr -> Context.Named.Declaration.t -> bool val count_occurrences : constr -> constr -> int val collect_metas : constr -> int list val collect_vars : constr -> Id.Set.t (** for visible vars only *) @@ -168,11 +163,21 @@ exception CannotFilter (context,term), or raises [CannotFilter]. Warning: Outer-kernel sort subtyping are taken into account: c1 has to be smaller than c2 wrt. sorts. *) -type subst = (rel_context*constr) Evar.Map.t -val filtering : rel_context -> Reduction.conv_pb -> constr -> constr -> subst +type subst = (Context.Rel.t * constr) Evar.Map.t +val filtering : Context.Rel.t -> Reduction.conv_pb -> constr -> constr -> subst -val decompose_prod_letin : constr -> int * rel_context * constr -val align_prod_letin : constr -> constr -> rel_context * constr +val decompose_prod_letin : constr -> int * Context.Rel.t * constr +val align_prod_letin : constr -> constr -> Context.Rel.t * 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 + +(** Similar to [nb_lam], but gives the number of products instead *) +val nb_prod : constr -> int + +(** Similar to [nb_prod], but zeta-contracts let-in on the way *) +val nb_prod_modulo_zeta : constr -> int (** Get the last arg of a constr intended to be an application *) val last_arg : constr -> constr @@ -191,44 +196,51 @@ val add_name : Name.t -> names_context -> names_context val lookup_name_of_rel : int -> names_context -> Name.t val lookup_rel_of_name : Id.t -> names_context -> int val empty_names_context : names_context -val ids_of_rel_context : rel_context -> Id.t list -val ids_of_named_context : named_context -> Id.t list +val ids_of_rel_context : Context.Rel.t -> Id.t list +val ids_of_named_context : Context.Named.t -> Id.t list val ids_of_context : env -> Id.t list val names_of_rel_context : env -> names_context -val context_chop : int -> rel_context -> rel_context * rel_context -val env_rel_context_chop : int -> env -> env * rel_context +(* [context_chop n Γ] returns (Γ₁,Γ₂) such that [Γ]=[Γ₂Γ₁], [Γ₁] has + [n] hypotheses, excluding local definitions, and [Γ₁], if not empty, + starts with an hypothesis (i.e. [Γ₁] has the form empty or [x:A;Γ₁'] *) +val context_chop : int -> Context.Rel.t -> Context.Rel.t * Context.Rel.t + +(* [env_rel_context_chop n env] extracts out the [n] top declarations + of the rel_context part of [env], counting both local definitions and + hypotheses *) +val env_rel_context_chop : int -> env -> env * Context.Rel.t (** Set of local names *) val vars_of_env: env -> Id.Set.t val add_vname : Id.Set.t -> Name.t -> Id.Set.t (** other signature iterators *) -val process_rel_context : (rel_declaration -> env -> env) -> env -> env -val assums_of_rel_context : rel_context -> (Name.t * constr) list -val lift_rel_context : int -> rel_context -> rel_context -val substl_rel_context : constr list -> rel_context -> rel_context -val smash_rel_context : rel_context -> rel_context (** expand lets in context *) -val adjust_subst_to_rel_context : rel_context -> constr list -> constr list +val process_rel_context : (Context.Rel.Declaration.t -> env -> env) -> env -> env +val assums_of_rel_context : Context.Rel.t -> (Name.t * constr) list +val lift_rel_context : int -> Context.Rel.t -> Context.Rel.t +val substl_rel_context : constr list -> Context.Rel.t -> Context.Rel.t +val smash_rel_context : Context.Rel.t -> Context.Rel.t (** expand lets in context *) + val map_rel_context_in_env : - (env -> constr -> constr) -> env -> rel_context -> rel_context + (env -> constr -> constr) -> env -> Context.Rel.t -> Context.Rel.t val map_rel_context_with_binders : - (int -> constr -> constr) -> rel_context -> rel_context + (int -> constr -> constr) -> Context.Rel.t -> Context.Rel.t val fold_named_context_both_sides : - ('a -> named_declaration -> named_declaration list -> 'a) -> - named_context -> init:'a -> 'a -val mem_named_context : Id.t -> named_context -> bool -val compact_named_context : named_context -> named_list_context -val compact_named_context_reverse : named_context -> named_list_context + ('a -> Context.Named.Declaration.t -> Context.Named.Declaration.t list -> 'a) -> + Context.Named.t -> init:'a -> 'a +val mem_named_context : Id.t -> Context.Named.t -> bool +val compact_named_context : Context.Named.t -> Context.NamedList.t +val compact_named_context_reverse : Context.Named.t -> Context.NamedList.t val clear_named_body : Id.t -> env -> env val global_vars : env -> constr -> Id.t list -val global_vars_set_of_decl : env -> named_declaration -> Id.Set.t +val global_vars_set_of_decl : env -> Context.Named.Declaration.t -> Id.Set.t (** Gives an ordered list of hypotheses, closed by dependencies, containing a given set *) -val dependency_closure : env -> named_context -> Id.Set.t -> Id.t list +val dependency_closure : env -> Context.Named.t -> Id.Set.t -> Id.t list (** Test if an identifier is the basename of a global reference *) val is_section_variable : Id.t -> bool diff --git a/engine/uState.ml b/engine/uState.ml index 227c4ad52..8aa9a61ab 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -25,16 +25,20 @@ module UNameMap = struct | _, _ -> r) s t end +type uinfo = { + uname : string option; + uloc : Loc.t option; +} + (* 2nd part used to check consistency on the fly. *) type t = - { uctx_names : Univ.Level.t UNameMap.t * string Univ.LMap.t; + { uctx_names : Univ.Level.t UNameMap.t * uinfo 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. *) + (** The subset of unification variables that can be instantiated with + algebraic universes as they appear in inferred types only. *) uctx_universes : UGraph.t; (** The current graph extended with the local constraints *) uctx_initial_universes : UGraph.t; (** The graph at the creation of the evar_map *) } @@ -105,13 +109,30 @@ let constrain_variables diff ctx = with Not_found | Option.IsNone -> cstrs) diff Univ.Constraint.empty +let add_uctx_names ?loc s l (names, names_rev) = + (UNameMap.add s l names, Univ.LMap.add l { uname = Some s; uloc = loc } names_rev) + +let add_uctx_loc l loc (names, names_rev) = + match loc with + | None -> (names, names_rev) + | Some _ -> (names, Univ.LMap.add l { uname = None; uloc = loc } names_rev) + +let of_binders b = + let ctx = empty 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 = - v := Univ.LMap.add l (Some b) !v + try v := Univ.LMap.update l (Some b) !v + with Not_found -> assert false exception UniversesDiffer -let process_universe_constraints univs vars alg cstrs = - let vars = ref vars in +let process_universe_constraints ctx cstrs = + let univs = ctx.uctx_universes in + let vars = ref ctx.uctx_univ_variables in let normalize = Universes.normalize_universe_opt_subst vars in let rec unify_universes fo l d r local = let l = normalize l and r = normalize r in @@ -120,7 +141,7 @@ let process_universe_constraints univs vars alg cstrs = let varinfo x = match Univ.Universe.level x with | None -> Inl x - | Some l -> Inr (l, Univ.LMap.mem l !vars, Univ.LSet.mem l alg) + | Some l -> Inr (l, Univ.LMap.mem l !vars, Univ.LSet.mem l ctx.uctx_univ_algebraic) in if d == Universes.ULe then if UGraph.check_leq univs l r then @@ -201,11 +222,7 @@ let add_constraints ctx cstrs = in Universes.Constraints.add cstr' acc) cstrs Universes.Constraints.empty in - let vars, local' = - process_universe_constraints ctx.uctx_universes - ctx.uctx_univ_variables ctx.uctx_univ_algebraic - cstrs' - in + let vars, local' = process_universe_constraints ctx cstrs' in { ctx with uctx_local = (univs, Univ.Constraint.union local local'); uctx_univ_variables = vars; uctx_universes = UGraph.merge_constraints local' ctx.uctx_universes } @@ -215,11 +232,7 @@ let add_constraints ctx cstrs = let add_universe_constraints ctx cstrs = let univs, local = ctx.uctx_local in - let vars, local' = - process_universe_constraints ctx.uctx_universes - ctx.uctx_univ_variables ctx.uctx_univ_algebraic - cstrs - in + let vars, local' = process_universe_constraints ctx cstrs in { ctx with uctx_local = (univs, Univ.Constraint.union local local'); uctx_univ_variables = vars; uctx_universes = UGraph.merge_constraints local' ctx.uctx_universes } @@ -227,34 +240,41 @@ let add_universe_constraints ctx cstrs = 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 -> + try str (Option.get (Univ.LMap.find l map_rev).uname) + with Not_found | Option.IsNone -> Universes.pr_with_global_universes l let universe_context ?names ctx = match names with - | None -> Univ.ContextSet.to_context ctx.uctx_local + | None -> [], Univ.ContextSet.to_context ctx.uctx_local | Some pl -> let levels = Univ.ContextSet.levels ctx.uctx_local in - let newinst, left = + let newinst, map, left = List.fold_right - (fun (loc,id) (newinst, acc) -> + (fun (loc,id) (newinst, map, acc) -> let l = try UNameMap.find (Id.to_string id) (fst ctx.uctx_names) with Not_found -> user_err_loc (loc, "universe_context", str"Universe " ++ Nameops.pr_id id ++ str" is not bound anymore.") - in (l :: newinst, Univ.LSet.remove l acc)) - pl ([], levels) + 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" + let loc = + let get_loc u = try (Univ.LMap.find u (snd ctx.uctx_names)).uloc with Not_found -> None in + try List.find_map get_loc (Univ.LSet.elements left) with Not_found -> Loc.ghost + in + user_err_loc (loc, "universe_context", (str(CString.plural n "Universe") ++ spc () ++ Univ.LSet.pr (pr_uctx_level ctx) left ++ - spc () ++ str (CString.conjugate_verb_to_be n) ++ str" unbound.") - else Univ.UContext.make (Univ.Instance.of_array (Array.of_list newinst), - Univ.ContextSet.constraints ctx.uctx_local) + 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 ctx.uctx_local) + in map, ctx let restrict ctx vars = let uctx' = Universes.restrict_universe_context ctx.uctx_local vars in @@ -268,7 +288,7 @@ let univ_rigid = UnivRigid let univ_flexible = UnivFlexible false let univ_flexible_alg = UnivFlexible true -let merge sideff rigid uctx ctx' = +let merge ?loc sideff rigid uctx ctx' = let open Univ in let levels = ContextSet.levels ctx' in let uctx = if sideff then uctx else @@ -295,36 +315,30 @@ let merge sideff rigid uctx ctx' = with UGraph.AlreadyDeclared when sideff -> g) levels g in + let uctx_names = + let fold u accu = + let modify _ info = match info.uloc with + | None -> { info with uloc = loc } + | Some _ -> info + in + try LMap.modify u modify accu + with Not_found -> LMap.add u { uname = None; uloc = loc } accu + in + (fst uctx.uctx_names, LSet.fold fold levels (snd uctx.uctx_names)) + in let initial = declare uctx.uctx_initial_universes in let univs = declare uctx.uctx_universes in let uctx_universes = UGraph.merge_constraints (ContextSet.constraints ctx') univs in - { uctx with uctx_local; uctx_universes; uctx_initial_universes = initial } + { uctx with uctx_names; uctx_local; uctx_universes; uctx_initial_universes = initial } let merge_subst uctx s = { uctx with uctx_univ_variables = Univ.LMap.subst_union uctx.uctx_univ_variables s } let emit_side_effects eff u = - Declareops.fold_side_effects - (fun acc eff -> - match eff with - | Declarations.SEscheme (l,s) -> - List.fold_left - (fun acc (_,_,cb,c) -> - let acc = match c with - | `Nothing -> acc - | `Opaque (s, ctx) -> merge true univ_rigid acc ctx - in if cb.Declarations.const_polymorphic then acc - else - merge true univ_rigid acc - (Univ.ContextSet.of_context cb.Declarations.const_universes)) - acc l - | Declarations.SEsubproof _ -> acc) - u eff - -let add_uctx_names s l (names, names_rev) = - (UNameMap.add s l names, Univ.LMap.add l s names_rev) - -let new_univ_variable rigid name + let uctxs = Safe_typing.universes_of_private eff in + List.fold_left (merge true univ_rigid) u uctxs + +let new_univ_variable ?loc rigid name ({ 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 @@ -339,8 +353,8 @@ let new_univ_variable rigid name in let names = match name with - | Some n -> add_uctx_names n u uctx.uctx_names - | None -> uctx.uctx_names + | Some n -> add_uctx_names ?loc n u uctx.uctx_names + | None -> add_uctx_loc u loc uctx.uctx_names in let initial = UGraph.add_universe u false uctx.uctx_initial_universes @@ -445,23 +459,21 @@ let refresh_undefined_univ_variables uctx = uctx', subst let normalize uctx = - let rec fixpoint uctx = - let ((vars',algs'), us') = - Universes.normalize_context_set uctx.uctx_local uctx.uctx_univ_variables - uctx.uctx_univ_algebraic + let ((vars',algs'), us') = + Universes.normalize_context_set uctx.uctx_local uctx.uctx_univ_variables + uctx.uctx_univ_algebraic + in + if Univ.ContextSet.equal us' uctx.uctx_local then uctx + else + let us', universes = + Universes.refresh_constraints uctx.uctx_initial_universes us' in - 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' = - { uctx_names = uctx.uctx_names; - uctx_local = us'; - uctx_univ_variables = vars'; - uctx_univ_algebraic = algs'; - uctx_universes = universes; - uctx_initial_universes = uctx.uctx_initial_universes } - in fixpoint uctx' - in fixpoint uctx + { uctx_names = uctx.uctx_names; + uctx_local = us'; + uctx_univ_variables = vars'; + uctx_univ_algebraic = algs'; + uctx_universes = universes; + uctx_initial_universes = uctx.uctx_initial_universes } let universe_of_name uctx s = UNameMap.find s (fst uctx.uctx_names) @@ -469,3 +481,11 @@ let universe_of_name uctx s = let add_universe_name uctx s l = let names' = add_uctx_names s l uctx.uctx_names in { uctx with uctx_names = names' } + +let update_sigma_env uctx env = + let univs = Environ.universes env in + let eunivs = + { uctx with uctx_initial_universes = univs; + uctx_universes = univs } + in + merge true univ_rigid eunivs eunivs.uctx_local diff --git a/engine/uState.mli b/engine/uState.mli index 56e0fe14e..c5c454020 100644 --- a/engine/uState.mli +++ b/engine/uState.mli @@ -28,6 +28,8 @@ val union : t -> t -> t val of_context_set : Univ.universe_context_set -> t +val of_binders : Universes.universe_binders -> t + (** {5 Projections} *) val context_set : t -> Univ.universe_context_set @@ -42,7 +44,7 @@ val ugraph : t -> UGraph.t val algebraics : t -> Univ.LSet.t (** The subset of unification variables that can be instantiated with algebraic - universes as they appear in types and universe instances only. *) + universes as they appear in inferred types only. *) val constraints : t -> Univ.constraints (** Shorthand for {!context_set} composed with {!ContextSet.constraints}. *) @@ -54,12 +56,12 @@ val context : t -> Univ.universe_context val add_constraints : t -> Univ.constraints -> t (** - @raise UniversesDiffer + @raise UniversesDiffer when universes differ *) val add_universe_constraints : t -> Universes.universe_constraints -> t (** - @raise UniversesDiffer + @raise UniversesDiffer when universes differ *) (** {5 Names} *) @@ -82,11 +84,11 @@ val univ_rigid : rigid val univ_flexible : rigid val univ_flexible_alg : rigid -val merge : bool -> rigid -> t -> Univ.universe_context_set -> t +val merge : ?loc:Loc.t -> bool -> rigid -> t -> Univ.universe_context_set -> t val merge_subst : t -> Universes.universe_opt_subst -> t -val emit_side_effects : Declareops.side_effects -> t -> t +val emit_side_effects : Safe_typing.private_constants -> t -> t -val new_univ_variable : rigid -> string option -> t -> t * Univ.Level.t +val new_univ_variable : ?loc:Loc.t -> rigid -> string option -> t -> t * Univ.Level.t val add_global_univ : t -> Univ.Level.t -> t val make_flexible_variable : t -> bool -> Univ.Level.t -> t @@ -106,7 +108,9 @@ val normalize : t -> t (** {5 TODO: Document me} *) -val universe_context : ?names:(Id.t Loc.located) list -> t -> Univ.universe_context +val universe_context : ?names:(Id.t Loc.located) list -> t -> (Id.t * Univ.Level.t) list * Univ.universe_context + +val update_sigma_env : t -> Environ.env -> t (** {5 Pretty-printing} *) diff --git a/grammar/argextend.ml4 b/grammar/argextend.ml4 index 08651de64..adfbd8cfd 100644 --- a/grammar/argextend.ml4 +++ b/grammar/argextend.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,155 +8,42 @@ (*i camlp4deps: "tools/compat5b.cmo" i*) -open Genarg open Q_util -open Egramml open Compat -open Pcoq let loc = CompatLoc.ghost let default_loc = <:expr< Loc.ghost >> -let qualified_name loc s = - let path = CString.split '.' s in - let (name, path) = CList.sep_last path in - qualified_name loc path name - -let mk_extraarg loc s = - try - let name = Genarg.get_name0 s in - qualified_name loc name - with Not_found -> - <:expr< $lid:"wit_"^s$ >> +let mk_extraarg loc s = <:expr< $lid:"wit_"^s$ >> let rec make_wit loc = function - | IntOrVarArgType -> <:expr< Constrarg.wit_int_or_var >> - | IdentArgType -> <:expr< Constrarg.wit_ident >> - | VarArgType -> <:expr< Constrarg.wit_var >> - | QuantHypArgType -> <:expr< Constrarg.wit_quant_hyp >> - | GenArgType -> <:expr< Constrarg.wit_genarg >> - | ConstrArgType -> <:expr< Constrarg.wit_constr >> - | ConstrMayEvalArgType -> <:expr< Constrarg.wit_constr_may_eval >> - | RedExprArgType -> <:expr< Constrarg.wit_red_expr >> - | OpenConstrArgType -> <:expr< Constrarg.wit_open_constr >> - | ConstrWithBindingsArgType -> <:expr< Constrarg.wit_constr_with_bindings >> - | BindingsArgType -> <:expr< Constrarg.wit_bindings >> | ListArgType t -> <:expr< Genarg.wit_list $make_wit loc t$ >> | OptArgType t -> <:expr< Genarg.wit_opt $make_wit loc t$ >> | PairArgType (t1,t2) -> <:expr< Genarg.wit_pair $make_wit loc t1$ $make_wit loc t2$ >> | ExtraArgType s -> mk_extraarg loc s +let is_self s = function +| ExtraArgType s' -> s = s' +| _ -> false + let make_rawwit loc arg = <:expr< Genarg.rawwit $make_wit loc arg$ >> let make_globwit loc arg = <:expr< Genarg.glbwit $make_wit loc arg$ >> let make_topwit loc arg = <:expr< Genarg.topwit $make_wit loc arg$ >> -let has_extraarg l = - let check = function - | GramNonTerminal(_, t, _, _) -> - begin match Genarg.unquote t with - | ExtraArgType _ -> true - | _ -> false - end - | _ -> false - in - List.exists check l - -let rec is_possibly_empty : type s a. (s, a) entry_key -> bool = function -| Aopt _ -> true -| Alist0 _ -> true -| Alist0sep _ -> true -| Amodifiers _ -> true -| Alist1 t -> is_possibly_empty t -| Alist1sep (t, _) -> is_possibly_empty t -| _ -> false - -let rec get_empty_entry : type s a. (s, a) entry_key -> _ = function -| Aopt _ -> <:expr< None >> -| Alist0 _ -> <:expr< [] >> -| Alist0sep _ -> <:expr< [] >> -| Amodifiers _ -> <:expr< [] >> -| Alist1 t -> <:expr< [$get_empty_entry t$] >> -| Alist1sep (t, _) -> <:expr< [$get_empty_entry t$] >> -| _ -> assert false - -let statically_known_possibly_empty s (prods,_) = - List.for_all (function - | GramNonTerminal(_,t,e,_) -> - begin match Genarg.unquote t with - | ExtraArgType s' -> - (* For ExtraArg we don't know (we'll have to test dynamically) *) - (* unless it is a recursive call *) - s <> s' - | _ -> - is_possibly_empty e - end - | GramTerminal _ -> - (* This consumes a token for sure *) false) - prods - -let possibly_empty_subentries loc (prods,act) = - let bind_name p v e = match p with - | None -> e - | Some id -> - let s = Names.Id.to_string id in <:expr< let $lid:s$ = $v$ in $e$ >> in - let rec aux = function - | [] -> <:expr< let loc = $default_loc$ in let _ = loc in $act$ >> - | GramNonTerminal(_,_,e,p) :: tl when is_possibly_empty e -> - bind_name p (get_empty_entry e) (aux tl) - | GramNonTerminal(_,t,_,p) :: tl -> - let t = match Genarg.unquote t with - | ExtraArgType _ as t -> t - | _ -> assert false - in - (* We check at runtime if extraarg s parses "epsilon" *) - let s = match p with None -> "_" | Some id -> Names.Id.to_string id in - <:expr< let $lid:s$ = match Genarg.default_empty_value $make_wit loc t$ with - [ None -> raise Exit - | Some v -> v ] in $aux tl$ >> - | _ -> assert false (* already filtered out *) in - if has_extraarg prods then - (* Needs a dynamic check; catch all exceptions if ever some rhs raises *) - (* an exception rather than returning a value; *) - (* declares loc because some code can refer to it; *) - (* ensures loc is used to avoid "unused variable" warning *) - (true, <:expr< try Some $aux prods$ - with [ Exit -> None ] >>) - else - (* Static optimisation *) - (false, aux prods) - -let make_possibly_empty_subentries loc s cl = - let cl = List.filter (statically_known_possibly_empty s) cl in - if cl = [] then - <:expr< None >> - else - let rec aux = function - | (true, e) :: l -> - <:expr< match $e$ with [ Some v -> Some v | None -> $aux l$ ] >> - | (false, e) :: _ -> - <:expr< Some $e$ >> - | [] -> - <:expr< None >> in - aux (List.map (possibly_empty_subentries loc) cl) - let make_act loc act pil = let rec make = function | [] -> <:expr< (fun loc -> $act$) >> - | GramNonTerminal (_,t,_,Some p) :: tl -> - let t = Genarg.unquote t in - let p = Names.Id.to_string p in - <:expr< - (fun $lid:p$ -> - let _ = Genarg.in_gen $make_rawwit loc t$ $lid:p$ in $make tl$) - >> - | (GramTerminal _ | GramNonTerminal (_,_,_,None)) :: tl -> + | ExtNonTerminal (_, p) :: tl -> <:expr< (fun $lid:p$ -> $make tl$) >> + | ExtTerminal _ :: tl -> <:expr< (fun _ -> $make tl$) >> in make (List.rev pil) let make_prod_item = function - | GramTerminal s -> <:expr< Pcoq.Atoken (Lexer.terminal $mlexpr_of_string s$) >> - | GramNonTerminal (_,_,g,_) -> mlexpr_of_prod_entry_key g + | ExtTerminal s -> <:expr< Extend.Atoken (Lexer.terminal $mlexpr_of_string s$) >> + | ExtNonTerminal (g, _) -> + let base s = <:expr< Pcoq.name_of_entry $lid:s$ >> in + mlexpr_of_prod_entry_key base g let rec make_prod = function | [] -> <:expr< Extend.Stop >> @@ -165,6 +52,27 @@ let rec make_prod = function let make_rule loc (prods,act) = <:expr< Extend.Rule $make_prod (List.rev prods)$ $make_act loc act prods$ >> +let is_ident x = function +| <:expr< $lid:s$ >> -> (s : string) = x +| _ -> false + +let make_extend loc s cl wit = match cl with +| [[ExtNonTerminal (Uentry e, id)], act] when is_ident id act -> + (** Special handling of identity arguments by not redeclaring an entry *) + <:str_item< + value $lid:s$ = + let () = Pcoq.register_grammar $wit$ $lid:e$ in + $lid:e$ + >> +| _ -> + let se = mlexpr_of_string s in + let rules = mlexpr_of_list (make_rule loc) (List.rev cl) in + <:str_item< + value $lid:s$ = + let $lid:s$ = Pcoq.create_generic_entry Pcoq.utactic $se$ (Genarg.rawwit $wit$) in + let () = Pcoq.grammar_extend $lid:s$ None (None, [(None, None, $rules$)]) in + $lid:s$ >> + let declare_tactic_argument loc s (typ, pr, f, g, h) cl = let rawtyp, rawpr, globtyp, globpr = match typ with | `Uniform typ -> @@ -173,87 +81,88 @@ let declare_tactic_argument loc s (typ, pr, f, g, h) cl = in let glob = match g with | None -> - begin match rawtyp with - | Genarg.ExtraArgType s' when CString.equal s s' -> + if is_self s rawtyp then <:expr< fun ist v -> (ist, v) >> - | _ -> + else <:expr< fun ist v -> let ans = out_gen $make_globwit loc rawtyp$ (Tacintern.intern_genarg ist (Genarg.in_gen $make_rawwit loc rawtyp$ v)) in (ist, ans) >> - end | Some f -> <:expr< fun ist v -> (ist, $lid:f$ ist v) >> in let interp = match f with | None -> - begin match globtyp with - | Genarg.ExtraArgType s' when CString.equal s s' -> - <:expr< fun ist gl v -> (gl.Evd.sigma, v) >> - | _ -> - <:expr< fun ist gl x -> - let (sigma,a_interp) = - Tacinterp.interp_genarg ist - (Tacmach.pf_env gl) (Tacmach.project gl) (Tacmach.pf_concl gl) gl.Evd.it - (Genarg.in_gen $make_globwit loc globtyp$ x) - in - (sigma , out_gen $make_topwit loc globtyp$ a_interp)>> - end - | Some f -> <:expr< $lid:f$>> in + if is_self s globtyp then + <:expr< fun ist v -> Ftactic.return v >> + else + <:expr< fun ist x -> + Ftactic.bind + (Tacinterp.interp_genarg ist (Genarg.in_gen $make_globwit loc globtyp$ x)) + (fun v -> Ftactic.return (Tacinterp.Value.cast $make_topwit loc globtyp$ v)) >> + | Some f -> + (** Compatibility layer, TODO: remove me *) + <:expr< + let f = $lid:f$ in + fun ist v -> Ftactic.nf_s_enter { Proofview.Goal.s_enter = fun gl -> + let (sigma, v) = Tacmach.New.of_old (fun gl -> f ist gl v) gl in + Sigma.Unsafe.of_pair (Ftactic.return v, sigma) + } + >> in let subst = match h with | None -> - begin match globtyp with - | Genarg.ExtraArgType s' when CString.equal s s' -> + if is_self s globtyp then <:expr< fun s v -> v >> - | _ -> + else <:expr< fun s x -> out_gen $make_globwit loc globtyp$ (Tacsubst.subst_genarg s (Genarg.in_gen $make_globwit loc globtyp$ x)) >> - end | Some f -> <:expr< $lid:f$>> in + let dyn = match typ with + | `Uniform typ -> + if is_self s typ then <:expr< None >> + else <:expr< Some (Genarg.val_tag $make_topwit loc typ$) >> + | `Specialized _ -> <:expr< None >> + in let se = mlexpr_of_string s in let wit = <:expr< $lid:"wit_"^s$ >> in - let rawwit = <:expr< Genarg.rawwit $wit$ >> in - let rules = mlexpr_of_list (make_rule loc) (List.rev cl) in - let default_value = <:expr< $make_possibly_empty_subentries loc s cl$ >> in declare_str_items loc - [ <:str_item< value ($lid:"wit_"^s$) = Genarg.make0 $default_value$ $se$ >>; + [ <:str_item< + value ($lid:"wit_"^s$) = + let dyn = $dyn$ in + Genarg.make0 ?dyn $se$ >>; <:str_item< Genintern.register_intern0 $wit$ $glob$ >>; <:str_item< Genintern.register_subst0 $wit$ $subst$ >>; <:str_item< Geninterp.register_interp0 $wit$ $interp$ >>; - <:str_item< - value $lid:s$ = Pcoq.create_generic_entry $se$ $rawwit$ >>; + make_extend loc s cl wit; <:str_item< do { - Pcoq.grammar_extend $lid:s$ None (None, [(None, None, $rules$)]); Pptactic.declare_extra_genarg_pprule - $wit$ $lid:rawpr$ $lid:globpr$ $lid:pr$ } - >> ] + $wit$ $lid:rawpr$ $lid:globpr$ $lid:pr$; + Tacentries.create_ltac_quotation $se$ + (fun (loc, v) -> Tacexpr.TacGeneric (Genarg.in_gen (Genarg.rawwit $wit$) v)) + ($lid:s$, None) + } >> ] let declare_vernac_argument loc s pr cl = let se = mlexpr_of_string s in let wit = <:expr< $lid:"wit_"^s$ >> in - let rawwit = <:expr< Genarg.rawwit $wit$ >> in - let rules = mlexpr_of_list (make_rule loc) (List.rev cl) in let pr_rules = match pr with | None -> <:expr< fun _ _ _ _ -> str $str:"[No printer for "^s^"]"$ >> | Some pr -> <:expr< fun _ _ _ -> $lid:pr$ >> in declare_str_items loc [ <:str_item< value ($lid:"wit_"^s$ : Genarg.genarg_type 'a unit unit) = - Genarg.create_arg None $se$ >>; - <:str_item< - value $lid:s$ = Pcoq.create_generic_entry $se$ $rawwit$ >>; + Genarg.create_arg $se$ >>; + make_extend loc s cl wit; <:str_item< do { - Pcoq.grammar_extend $lid:s$ None (None, [(None, None, $rules$)]); Pptactic.declare_extra_genarg_pprule $wit$ $pr_rules$ (fun _ _ _ _ -> Errors.anomaly (Pp.str "vernac argument needs not globwit printer")) (fun _ _ _ _ -> Errors.anomaly (Pp.str "vernac argument needs not wit printer")) } >> ] -open Pcoq open Pcaml open PcamlSig (* necessary for camlp4 *) @@ -296,8 +205,8 @@ EXTEND | e = argtype; LIDENT "option" -> OptArgType e ] | "0" [ e = LIDENT -> - let EntryName (t, _) = interp_entry_name false TgAny e "" in - Genarg.unquote t + let e = parse_user_entry e "" in + type_of_user_symbol e | "("; e = argtype; ")" -> e ] ] ; argrule: @@ -305,15 +214,12 @@ EXTEND ; genarg: [ [ e = LIDENT; "("; s = LIDENT; ")" -> - let EntryName (t, g) = interp_entry_name false TgAny e "" in - GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s)) + let e = parse_user_entry e "" in + ExtNonTerminal (e, s) | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" -> - let EntryName (t, g) = interp_entry_name false TgAny e sep in - GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s)) - | s = STRING -> - if String.length s > 0 && Util.is_letter s.[0] then - Lexer.add_keyword s; - GramTerminal s + let e = parse_user_entry e sep in + ExtNonTerminal (e, s) + | s = STRING -> ExtTerminal s ] ] ; entry_name: diff --git a/grammar/grammar.mllib b/grammar/grammar.mllib index 7e4eea641..9b24c9797 100644 --- a/grammar/grammar.mllib +++ b/grammar/grammar.mllib @@ -1,66 +1,13 @@ Coq_config -Hook -Terminal -Canary -Hashset -Hashcons -CSet -CMap -Int -HMap -Option Store Exninfo -Backtrace -Pp_control -Flags Loc -Serialize -Stateid -Feedback -Pp -CList -CString -CArray -CStack -Util -Ppstyle -Errors -Bigint -Predicate -Segmenttree -Unicodetable -Unicode -Genarg - -Evar -Names - -Libnames - -Redops -Miscops -Locusops - -Stdarg -Constrarg -Constrexpr_ops - -Compat Tok -Lexer -Entry -Pcoq -G_prim -G_tactic -G_ltac -G_constr +Compat Q_util -Q_coqast -Egramml Argextend Tacextend Vernacextend diff --git a/grammar/q_constr.ml4 b/grammar/q_constr.ml4 index 6ae8bea3a..40db81949 100644 --- a/grammar/q_constr.ml4 +++ b/grammar/q_constr.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/grammar/q_coqast.ml4 b/grammar/q_coqast.ml4 deleted file mode 100644 index dd97107f7..000000000 --- a/grammar/q_coqast.ml4 +++ /dev/null @@ -1,597 +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 Names -open Q_util -open Compat - -let is_meta s = String.length s > 0 && s.[0] == '$' - -let purge_str s = - if String.length s == 0 || s.[0] <> '$' then s - else String.sub s 1 (String.length s - 1) - -let anti loc x = - expl_anti loc <:expr< $lid:purge_str x$ >> - -(* We don't give location for tactic quotation! *) -let loc = CompatLoc.ghost - -let dloc = <:expr< Loc.ghost >> - -let mlexpr_of_ident id = - <:expr< Names.Id.of_string $str:Names.Id.to_string id$ >> - -let mlexpr_of_name = function - | Names.Anonymous -> <:expr< Names.Anonymous >> - | Names.Name id -> - <:expr< Names.Name (Names.Id.of_string $str:Names.Id.to_string id$) >> - -let mlexpr_of_dirpath dir = - let l = Names.DirPath.repr dir in - <:expr< Names.DirPath.make $mlexpr_of_list mlexpr_of_ident l$ >> - -let mlexpr_of_qualid qid = - let (dir, id) = Libnames.repr_qualid qid in - <:expr< Libnames.make_qualid $mlexpr_of_dirpath dir$ $mlexpr_of_ident id$ >> - -let mlexpr_of_reference = function - | Libnames.Qualid (loc,qid) -> - let loc = of_coqloc loc in <:expr< Libnames.Qualid $dloc$ $mlexpr_of_qualid qid$ >> - | Libnames.Ident (loc,id) -> - let loc = of_coqloc loc in <:expr< Libnames.Ident $dloc$ $mlexpr_of_ident id$ >> - -let mlexpr_of_union f g = function - | Util.Inl a -> <:expr< Util.Inl $f a$ >> - | Util.Inr b -> <:expr< Util.Inr $g b$ >> - -let mlexpr_of_located f (loc,x) = - let loc = of_coqloc loc in - <:expr< ($dloc$, $f x$) >> - -let mlexpr_of_loc loc = <:expr< $dloc$ >> - -let mlexpr_of_by_notation f = function - | Misctypes.AN x -> <:expr< Misctypes.AN $f x$ >> - | Misctypes.ByNotation (loc,s,sco) -> - let loc = of_coqloc loc in - <:expr< Misctypes.ByNotation $dloc$ $str:s$ $mlexpr_of_option mlexpr_of_string sco$ >> - -let mlexpr_of_global_flag = function - | Tacexpr.TacGlobal -> <:expr<Tacexpr.TacGlobal>> - | Tacexpr.TacLocal -> <:expr<Tacexpr.TacLocal>> - -let mlexpr_of_intro_pattern_disjunctive = function - _ -> failwith "mlexpr_of_intro_pattern_disjunctive: TODO" - -let mlexpr_of_intro_pattern_naming = function - | Misctypes.IntroAnonymous -> <:expr< Misctypes.IntroAnonymous >> - | Misctypes.IntroFresh id -> <:expr< Misctypes.IntroFresh (mlexpr_of_ident $dloc$ id) >> - | Misctypes.IntroIdentifier id -> - <:expr< Misctypes.IntroIdentifier (mlexpr_of_ident $dloc$ id) >> - -let mlexpr_of_intro_pattern = function - | Misctypes.IntroForthcoming b -> <:expr< Misctypes.IntroForthcoming (mlexpr_of_bool $dloc$ b) >> - | Misctypes.IntroNaming pat -> - <:expr< Misctypes.IntroNaming $mlexpr_of_intro_pattern_naming pat$ >> - | Misctypes.IntroAction _ -> - failwith "mlexpr_of_intro_pattern: TODO" - -let mlexpr_of_ident_option = mlexpr_of_option (mlexpr_of_ident) - -let mlexpr_of_quantified_hypothesis = function - | Misctypes.AnonHyp n -> <:expr< Glob_term.AnonHyp $mlexpr_of_int n$ >> - | Misctypes.NamedHyp id -> <:expr< Glob_term.NamedHyp $mlexpr_of_ident id$ >> - -let mlexpr_of_or_var f = function - | Misctypes.ArgArg x -> <:expr< Misctypes.ArgArg $f x$ >> - | Misctypes.ArgVar id -> <:expr< Misctypes.ArgVar $mlexpr_of_located mlexpr_of_ident id$ >> - -let mlexpr_of_hyp = (mlexpr_of_located mlexpr_of_ident) - -let mlexpr_of_occs = function - | Locus.AllOccurrences -> <:expr< Locus.AllOccurrences >> - | Locus.AllOccurrencesBut l -> - <:expr< Locus.AllOccurrencesBut - $mlexpr_of_list (mlexpr_of_or_var mlexpr_of_int) l$ >> - | Locus.NoOccurrences -> <:expr< Locus.NoOccurrences >> - | Locus.OnlyOccurrences l -> - <:expr< Locus.OnlyOccurrences - $mlexpr_of_list (mlexpr_of_or_var mlexpr_of_int) l$ >> - -let mlexpr_of_occurrences f = mlexpr_of_pair mlexpr_of_occs f - -let mlexpr_of_hyp_location = function - | occs, Locus.InHyp -> - <:expr< ($mlexpr_of_occurrences mlexpr_of_hyp occs$, Locus.InHyp) >> - | occs, Locus.InHypTypeOnly -> - <:expr< ($mlexpr_of_occurrences mlexpr_of_hyp occs$, Locus.InHypTypeOnly) >> - | occs, Locus.InHypValueOnly -> - <:expr< ($mlexpr_of_occurrences mlexpr_of_hyp occs$, Locus.InHypValueOnly) >> - -let mlexpr_of_clause cl = - <:expr< {Locus.onhyps= - $mlexpr_of_option (mlexpr_of_list mlexpr_of_hyp_location) - cl.Locus.onhyps$; - Locus.concl_occs= $mlexpr_of_occs cl.Locus.concl_occs$} >> - -let mlexpr_of_red_flags { - Genredexpr.rBeta = bb; - Genredexpr.rIota = bi; - Genredexpr.rZeta = bz; - Genredexpr.rDelta = bd; - Genredexpr.rConst = l -} = <:expr< { - Genredexpr.rBeta = $mlexpr_of_bool bb$; - Genredexpr.rIota = $mlexpr_of_bool bi$; - Genredexpr.rZeta = $mlexpr_of_bool bz$; - Genredexpr.rDelta = $mlexpr_of_bool bd$; - Genredexpr.rConst = $mlexpr_of_list (mlexpr_of_by_notation mlexpr_of_reference) l$ -} >> - -let mlexpr_of_instance c = <:expr< None >> - -let mlexpr_of_explicitation = function - | Constrexpr.ExplByName id -> <:expr< Constrexpr.ExplByName $mlexpr_of_ident id$ >> - | Constrexpr.ExplByPos (n,_id) -> <:expr< Constrexpr.ExplByPos $mlexpr_of_int n$ >> - -let mlexpr_of_binding_kind = function - | Decl_kinds.Implicit -> <:expr< Decl_kinds.Implicit >> - | Decl_kinds.Explicit -> <:expr< Decl_kinds.Explicit >> - -let mlexpr_of_binder_kind = function - | Constrexpr.Default b -> <:expr< Constrexpr.Default $mlexpr_of_binding_kind b$ >> - | Constrexpr.Generalized (b,b',b'') -> - <:expr< Constrexpr.TypeClass $mlexpr_of_binding_kind b$ - $mlexpr_of_binding_kind b'$ $mlexpr_of_bool b''$ >> - -let rec mlexpr_of_constr = function - | Constrexpr.CRef (Libnames.Ident (loc,id),_) when is_meta (Id.to_string id) -> - let loc = of_coqloc loc in - anti loc (Id.to_string id) - | Constrexpr.CRef (r,n) -> <:expr< Constrexpr.CRef $mlexpr_of_reference r$ None >> - | Constrexpr.CFix (loc,_,_) -> failwith "mlexpr_of_constr: TODO" - | Constrexpr.CCoFix (loc,_,_) -> failwith "mlexpr_of_constr: TODO" - | Constrexpr.CProdN (loc,l,a) -> - let loc = of_coqloc loc in - <:expr< Constrexpr.CProdN $dloc$ $mlexpr_of_list - (mlexpr_of_triple (mlexpr_of_list (mlexpr_of_pair (fun _ -> dloc) mlexpr_of_name)) mlexpr_of_binder_kind mlexpr_of_constr) l$ $mlexpr_of_constr a$ >> - | Constrexpr.CLambdaN (loc,l,a) -> - let loc = of_coqloc loc in - <:expr< Constrexpr.CLambdaN $dloc$ $mlexpr_of_list (mlexpr_of_triple (mlexpr_of_list (mlexpr_of_pair (fun _ -> dloc) mlexpr_of_name)) mlexpr_of_binder_kind mlexpr_of_constr) l$ $mlexpr_of_constr a$ >> - | Constrexpr.CLetIn (loc,_,_,_) -> failwith "mlexpr_of_constr: TODO" - | Constrexpr.CAppExpl (loc,(p,r,us),l) -> - let loc = of_coqloc loc in - let a = (p,r,us) in - <:expr< Constrexpr.CAppExpl $dloc$ $mlexpr_of_triple (mlexpr_of_option mlexpr_of_int) mlexpr_of_reference mlexpr_of_instance a$ $mlexpr_of_list mlexpr_of_constr l$ >> - | Constrexpr.CApp (loc,a,l) -> - let loc = of_coqloc loc in - <:expr< Constrexpr.CApp $dloc$ $mlexpr_of_pair (mlexpr_of_option mlexpr_of_int) mlexpr_of_constr a$ $mlexpr_of_list (mlexpr_of_pair mlexpr_of_constr (mlexpr_of_option (mlexpr_of_located mlexpr_of_explicitation))) l$ >> - | Constrexpr.CCases (loc,_,_,_,_) -> failwith "mlexpr_of_constr: TODO" - | Constrexpr.CHole (loc, None, ipat, None) -> - let loc = of_coqloc loc in - <:expr< Constrexpr.CHole $dloc$ None $mlexpr_of_intro_pattern_naming ipat$ None >> - | Constrexpr.CHole (loc,_,_,_) -> failwith "mlexpr_of_constr: TODO CHole (Some _)" - | Constrexpr.CNotation(_,ntn,(subst,substl,[])) -> - <:expr< Constrexpr.CNotation $dloc$ $mlexpr_of_string ntn$ - ($mlexpr_of_list mlexpr_of_constr subst$, - $mlexpr_of_list (mlexpr_of_list mlexpr_of_constr) substl$,[]) >> - | Constrexpr.CPatVar (loc,n) -> - let loc = of_coqloc loc in - <:expr< Constrexpr.CPatVar $dloc$ $mlexpr_of_ident n$ >> - | Constrexpr.CEvar (loc,n,[]) -> - let loc = of_coqloc loc in - <:expr< Constrexpr.CEvar $dloc$ $mlexpr_of_ident n$ [] >> - | _ -> failwith "mlexpr_of_constr: TODO" - -let mlexpr_of_occ_constr = - mlexpr_of_occurrences mlexpr_of_constr - -let mlexpr_of_occ_ref_or_constr = - mlexpr_of_occurrences - (mlexpr_of_union - (mlexpr_of_by_notation mlexpr_of_reference) mlexpr_of_constr) - -let mlexpr_of_red_expr = function - | Genredexpr.Red b -> <:expr< Genredexpr.Red $mlexpr_of_bool b$ >> - | Genredexpr.Hnf -> <:expr< Genredexpr.Hnf >> - | Genredexpr.Simpl (f,o) -> - <:expr< Genredexpr.Simpl $mlexpr_of_red_flags f$ $mlexpr_of_option mlexpr_of_occ_ref_or_constr o$ >> - | Genredexpr.Cbv f -> - <:expr< Genredexpr.Cbv $mlexpr_of_red_flags f$ >> - | Genredexpr.Cbn f -> - <:expr< Genredexpr.Cbn $mlexpr_of_red_flags f$ >> - | Genredexpr.Lazy f -> - <:expr< Genredexpr.Lazy $mlexpr_of_red_flags f$ >> - | Genredexpr.Unfold l -> - let f1 = mlexpr_of_by_notation mlexpr_of_reference in - let f = mlexpr_of_list (mlexpr_of_occurrences f1) in - <:expr< Genredexpr.Unfold $f l$ >> - | Genredexpr.Fold l -> - <:expr< Genredexpr.Fold $mlexpr_of_list mlexpr_of_constr l$ >> - | Genredexpr.Pattern l -> - let f = mlexpr_of_list mlexpr_of_occ_constr in - <:expr< Genredexpr.Pattern $f l$ >> - | Genredexpr.CbvVm o -> <:expr< Genredexpr.CbvVm $mlexpr_of_option mlexpr_of_occ_ref_or_constr o$ >> - | Genredexpr.CbvNative o -> <:expr< Genredexpr.CbvNative $mlexpr_of_option mlexpr_of_occ_ref_or_constr o$ >> - | Genredexpr.ExtraRedExpr s -> - <:expr< Genredexpr.ExtraRedExpr $mlexpr_of_string s$ >> - -let rec mlexpr_of_argtype loc = function - | Genarg.IntOrVarArgType -> <:expr< Genarg.IntOrVarArgType >> - | Genarg.IdentArgType -> <:expr< Genarg.IdentArgType >> - | Genarg.VarArgType -> <:expr< Genarg.VarArgType >> - | Genarg.QuantHypArgType -> <:expr< Genarg.QuantHypArgType >> - | Genarg.OpenConstrArgType -> <:expr< Genarg.OpenConstrArgType >> - | Genarg.ConstrWithBindingsArgType -> <:expr< Genarg.ConstrWithBindingsArgType >> - | Genarg.BindingsArgType -> <:expr< Genarg.BindingsArgType >> - | Genarg.RedExprArgType -> <:expr< Genarg.RedExprArgType >> - | Genarg.GenArgType -> <:expr< Genarg.GenArgType >> - | Genarg.ConstrArgType -> <:expr< Genarg.ConstrArgType >> - | Genarg.ConstrMayEvalArgType -> <:expr< Genarg.ConstrMayEvalArgType >> - | Genarg.ListArgType t -> <:expr< Genarg.ListArgType $mlexpr_of_argtype loc t$ >> - | Genarg.OptArgType t -> <:expr< Genarg.OptArgType $mlexpr_of_argtype loc t$ >> - | Genarg.PairArgType (t1,t2) -> - let t1 = mlexpr_of_argtype loc t1 in - let t2 = mlexpr_of_argtype loc t2 in - <:expr< Genarg.PairArgType $t1$ $t2$ >> - | Genarg.ExtraArgType s -> <:expr< Genarg.ExtraArgType $str:s$ >> - -let mlexpr_of_may_eval f = function - | Genredexpr.ConstrEval (r,c) -> - <:expr< Genredexpr.ConstrEval $mlexpr_of_red_expr r$ $f c$ >> - | Genredexpr.ConstrContext ((loc,id),c) -> - let loc = of_coqloc loc in - let id = mlexpr_of_ident id in - <:expr< Genredexpr.ConstrContext (loc,$id$) $f c$ >> - | Genredexpr.ConstrTypeOf c -> - <:expr< Genredexpr.ConstrTypeOf $mlexpr_of_constr c$ >> - | Genredexpr.ConstrTerm c -> - <:expr< Genredexpr.ConstrTerm $mlexpr_of_constr c$ >> - -let mlexpr_of_binding_kind = function - | Misctypes.ExplicitBindings l -> - let l = mlexpr_of_list (mlexpr_of_triple mlexpr_of_loc mlexpr_of_quantified_hypothesis mlexpr_of_constr) l in - <:expr< Misctypes.ExplicitBindings $l$ >> - | Misctypes.ImplicitBindings l -> - let l = mlexpr_of_list mlexpr_of_constr l in - <:expr< Misctypes.ImplicitBindings $l$ >> - | Misctypes.NoBindings -> - <:expr< Misctypes.NoBindings >> - -let mlexpr_of_binding = mlexpr_of_pair mlexpr_of_binding_kind mlexpr_of_constr - -let mlexpr_of_constr_with_binding = - mlexpr_of_pair mlexpr_of_constr mlexpr_of_binding_kind - -let mlexpr_of_constr_with_binding_arg = - mlexpr_of_pair (mlexpr_of_option mlexpr_of_bool) mlexpr_of_constr_with_binding - -let mlexpr_of_move_location f = function - | Misctypes.MoveAfter id -> <:expr< Misctypes.MoveAfter $f id$ >> - | Misctypes.MoveBefore id -> <:expr< Misctypes.MoveBefore $f id$ >> - | Misctypes.MoveFirst -> <:expr< Misctypes.MoveFirst >> - | Misctypes.MoveLast -> <:expr< Misctypes.MoveLast >> - -let mlexpr_of_induction_arg = function - | Tacexpr.ElimOnConstr c -> - <:expr< Tacexpr.ElimOnConstr $mlexpr_of_constr_with_binding c$ >> - | Tacexpr.ElimOnIdent (_,id) -> - <:expr< Tacexpr.ElimOnIdent $dloc$ $mlexpr_of_ident id$ >> - | Tacexpr.ElimOnAnonHyp n -> - <:expr< Tacexpr.ElimOnAnonHyp $mlexpr_of_int n$ >> - -let mlexpr_of_clause_pattern _ = failwith "mlexpr_of_clause_pattern: TODO" - -let mlexpr_of_pattern_ast = mlexpr_of_constr - -let mlexpr_of_entry_type = function - _ -> failwith "mlexpr_of_entry_type: TODO" - -let mlexpr_of_match_lazy_flag = function - | Tacexpr.General -> <:expr<Tacexpr.General>> - | Tacexpr.Select -> <:expr<Tacexpr.Select>> - | Tacexpr.Once -> <:expr<Tacexpr.Once>> - -let mlexpr_of_match_pattern = function - | Tacexpr.Term t -> <:expr< Tacexpr.Term $mlexpr_of_pattern_ast t$ >> - | Tacexpr.Subterm (b,ido,t) -> - <:expr< Tacexpr.Subterm $mlexpr_of_bool b$ $mlexpr_of_option mlexpr_of_ident ido$ $mlexpr_of_pattern_ast t$ >> - -let mlexpr_of_match_context_hyps = function - | Tacexpr.Hyp (id,l) -> - let f = mlexpr_of_located mlexpr_of_name in - <:expr< Tacexpr.Hyp $f id$ $mlexpr_of_match_pattern l$ >> - | Tacexpr.Def (id,v,l) -> - let f = mlexpr_of_located mlexpr_of_name in - <:expr< Tacexpr.Def $f id$ $mlexpr_of_match_pattern v$ $mlexpr_of_match_pattern l$ >> - -let mlexpr_of_match_rule f = function - | Tacexpr.Pat (l,mp,t) -> <:expr< Tacexpr.Pat $mlexpr_of_list mlexpr_of_match_context_hyps l$ $mlexpr_of_match_pattern mp$ $f t$ >> - | Tacexpr.All t -> <:expr< Tacexpr.All $f t$ >> - -let mlexpr_of_message_token = function - | Tacexpr.MsgString s -> <:expr< Tacexpr.MsgString $str:s$ >> - | Tacexpr.MsgInt n -> <:expr< Tacexpr.MsgInt $mlexpr_of_int n$ >> - | Tacexpr.MsgIdent id -> <:expr< Tacexpr.MsgIdent $mlexpr_of_hyp id$ >> - -let mlexpr_of_debug = function - | Tacexpr.Off -> <:expr< Tacexpr.Off >> - | Tacexpr.Debug -> <:expr< Tacexpr.Debug >> - | Tacexpr.Info -> <:expr< Tacexpr.Info >> - -let rec mlexpr_of_atomic_tactic = function - (* Basic tactics *) - | Tacexpr.TacIntroPattern pl -> - let pl = mlexpr_of_list (mlexpr_of_located mlexpr_of_intro_pattern) pl in - <:expr< Tacexpr.TacIntroPattern $pl$ >> - | Tacexpr.TacIntroMove (idopt,idopt') -> - let idopt = mlexpr_of_ident_option idopt in - let idopt'= mlexpr_of_move_location mlexpr_of_hyp idopt' in - <:expr< Tacexpr.TacIntroMove $idopt$ $idopt'$ >> - | Tacexpr.TacExact c -> - <:expr< Tacexpr.TacExact $mlexpr_of_constr c$ >> - | Tacexpr.TacApply (b,false,cb,None) -> - <:expr< Tacexpr.TacApply $mlexpr_of_bool b$ False $mlexpr_of_list mlexpr_of_constr_with_binding_arg cb$ None >> - | Tacexpr.TacElim (false,cb,cbo) -> - let cb = mlexpr_of_constr_with_binding_arg cb in - let cbo = mlexpr_of_option mlexpr_of_constr_with_binding cbo in - <:expr< Tacexpr.TacElim False $cb$ $cbo$ >> - | Tacexpr.TacCase (false,cb) -> - let cb = mlexpr_of_constr_with_binding_arg cb in - <:expr< Tacexpr.TacCase False $cb$ >> - | Tacexpr.TacFix (ido,n) -> - let ido = mlexpr_of_ident_option ido in - let n = mlexpr_of_int n in - <:expr< Tacexpr.TacFix $ido$ $n$ >> - | Tacexpr.TacMutualFix (id,n,l) -> - let id = mlexpr_of_ident id in - let n = mlexpr_of_int n in - let f =mlexpr_of_triple mlexpr_of_ident mlexpr_of_int mlexpr_of_constr in - let l = mlexpr_of_list f l in - <:expr< Tacexpr.TacMutualFix $id$ $n$ $l$ >> - | Tacexpr.TacCofix ido -> - let ido = mlexpr_of_ident_option ido in - <:expr< Tacexpr.TacCofix $ido$ >> - | Tacexpr.TacMutualCofix (id,l) -> - let id = mlexpr_of_ident id in - let f = mlexpr_of_pair mlexpr_of_ident mlexpr_of_constr in - let l = mlexpr_of_list f l in - <:expr< Tacexpr.TacMutualCofix $id$ $l$ >> - - | Tacexpr.TacAssert (b,t,ipat,c) -> - let ipat = mlexpr_of_option (mlexpr_of_located mlexpr_of_intro_pattern) ipat in - <:expr< Tacexpr.TacAssert $mlexpr_of_bool b$ - $mlexpr_of_option mlexpr_of_tactic t$ $ipat$ - $mlexpr_of_constr c$ >> - | Tacexpr.TacGeneralize cl -> - <:expr< Tacexpr.TacGeneralize - $mlexpr_of_list - (mlexpr_of_pair mlexpr_of_occ_constr mlexpr_of_name) cl$ >> - | Tacexpr.TacGeneralizeDep c -> - <:expr< Tacexpr.TacGeneralizeDep $mlexpr_of_constr c$ >> - | Tacexpr.TacLetTac (na,c,cl,b,e) -> - let na = mlexpr_of_name na in - let cl = mlexpr_of_clause_pattern cl in - <:expr< Tacexpr.TacLetTac $na$ $mlexpr_of_constr c$ $cl$ - $mlexpr_of_bool b$ - (mlexpr_of_option (mlexpr_of_located mlexpr_of_intro_pattern) e) - >> - - (* Derived basic tactics *) - | Tacexpr.TacInductionDestruct (isrec,ev,l) -> - <:expr< Tacexpr.TacInductionDestruct $mlexpr_of_bool isrec$ $mlexpr_of_bool ev$ - $mlexpr_of_pair - (mlexpr_of_list - (mlexpr_of_triple - (mlexpr_of_pair - (mlexpr_of_option mlexpr_of_bool) - mlexpr_of_induction_arg) - (mlexpr_of_pair - (mlexpr_of_option (mlexpr_of_located mlexpr_of_intro_pattern_naming)) - (mlexpr_of_option (mlexpr_of_intro_pattern_disjunctive))) - (mlexpr_of_option mlexpr_of_clause))) - (mlexpr_of_option mlexpr_of_constr_with_binding) - l$ >> - - (* Context management *) - | Tacexpr.TacClear (b,l) -> - let l = mlexpr_of_list (mlexpr_of_hyp) l in - <:expr< Tacexpr.TacClear $mlexpr_of_bool b$ $l$ >> - | Tacexpr.TacClearBody l -> - let l = mlexpr_of_list (mlexpr_of_hyp) l in - <:expr< Tacexpr.TacClearBody $l$ >> - | Tacexpr.TacMove (id1,id2) -> - <:expr< Tacexpr.TacMove - $mlexpr_of_hyp id1$ - $mlexpr_of_move_location mlexpr_of_hyp id2$ >> - - (* Constructors *) - | Tacexpr.TacSplit (ev,l) -> - <:expr< Tacexpr.TacSplit - ($mlexpr_of_bool ev$, $mlexpr_of_list mlexpr_of_binding_kind l$)>> - (* Conversion *) - | Tacexpr.TacReduce (r,cl) -> - let l = mlexpr_of_clause cl in - <:expr< Tacexpr.TacReduce $mlexpr_of_red_expr r$ $l$ >> - | Tacexpr.TacChange (p,c,cl) -> - let l = mlexpr_of_clause cl in - let g = mlexpr_of_option mlexpr_of_constr in - <:expr< Tacexpr.TacChange $g p$ $mlexpr_of_constr c$ $l$ >> - - (* Equivalence relations *) - | Tacexpr.TacSymmetry ido -> <:expr< Tacexpr.TacSymmetry $mlexpr_of_clause ido$ >> - - (* Automation tactics *) - | Tacexpr.TacAuto (debug,n,lems,l) -> - let d = mlexpr_of_debug debug in - let n = mlexpr_of_option (mlexpr_of_or_var mlexpr_of_int) n in - let lems = mlexpr_of_list mlexpr_of_constr lems in - let l = mlexpr_of_option (mlexpr_of_list mlexpr_of_string) l in - <:expr< Tacexpr.TacAuto $d$ $n$ $lems$ $l$ >> - | Tacexpr.TacTrivial (debug,lems,l) -> - let d = mlexpr_of_debug debug in - let l = mlexpr_of_option (mlexpr_of_list mlexpr_of_string) l in - let lems = mlexpr_of_list mlexpr_of_constr lems in - <:expr< Tacexpr.TacTrivial $d$ $lems$ $l$ >> - - | _ -> failwith "Quotation of atomic tactic expressions: TODO" - -and mlexpr_of_tactic : (Tacexpr.raw_tactic_expr -> MLast.expr) = function - | Tacexpr.TacAtom (loc,t) -> - let loc = of_coqloc loc in - <:expr< Tacexpr.TacAtom $dloc$ $mlexpr_of_atomic_tactic t$ >> - | Tacexpr.TacThen (t1,t2) -> - <:expr< Tacexpr.TacThen $mlexpr_of_tactic t1$ $mlexpr_of_tactic t2$>> - | Tacexpr.TacThens (t,tl) -> - <:expr< Tacexpr.TacThens $mlexpr_of_tactic t$ $mlexpr_of_list mlexpr_of_tactic tl$>> - | Tacexpr.TacFirst tl -> - <:expr< Tacexpr.TacFirst $mlexpr_of_list mlexpr_of_tactic tl$ >> - | Tacexpr.TacSolve tl -> - <:expr< Tacexpr.TacSolve $mlexpr_of_list mlexpr_of_tactic tl$ >> - | Tacexpr.TacTry t -> - <:expr< Tacexpr.TacTry $mlexpr_of_tactic t$ >> - | Tacexpr.TacOr (t1,t2) -> - <:expr< Tacexpr.TacOr $mlexpr_of_tactic t1$ $mlexpr_of_tactic t2$ >> - | Tacexpr.TacOrelse (t1,t2) -> - <:expr< Tacexpr.TacOrelse $mlexpr_of_tactic t1$ $mlexpr_of_tactic t2$ >> - | Tacexpr.TacDo (n,t) -> - <:expr< Tacexpr.TacDo $mlexpr_of_or_var mlexpr_of_int n$ $mlexpr_of_tactic t$ >> - | Tacexpr.TacTimeout (n,t) -> - <:expr< Tacexpr.TacTimeout $mlexpr_of_or_var mlexpr_of_int n$ $mlexpr_of_tactic t$ >> - | Tacexpr.TacRepeat t -> - <:expr< Tacexpr.TacRepeat $mlexpr_of_tactic t$ >> - | Tacexpr.TacProgress t -> - <:expr< Tacexpr.TacProgress $mlexpr_of_tactic t$ >> - | Tacexpr.TacShowHyps t -> - <:expr< Tacexpr.TacShowHyps $mlexpr_of_tactic t$ >> - | Tacexpr.TacId l -> - <:expr< Tacexpr.TacId $mlexpr_of_list mlexpr_of_message_token l$ >> - | Tacexpr.TacFail (g,n,l) -> - <:expr< Tacexpr.TacFail $mlexpr_of_global_flag g$ $mlexpr_of_or_var mlexpr_of_int n$ $mlexpr_of_list mlexpr_of_message_token l$ >> -(* - | Tacexpr.TacInfo t -> TacInfo (loc,f t) - - | Tacexpr.TacRec (id,(idl,t)) -> TacRec (loc,(id,(idl,f t))) - | Tacexpr.TacRecIn (l,t) -> TacRecIn(loc,List.map (fun (id,t) -> (id,f t)) l,f t) -*) - | Tacexpr.TacLetIn (isrec,l,t) -> - let f = - mlexpr_of_pair - (mlexpr_of_pair (fun _ -> dloc) mlexpr_of_ident) - mlexpr_of_tactic_arg in - <:expr< Tacexpr.TacLetIn $mlexpr_of_bool isrec$ $mlexpr_of_list f l$ $mlexpr_of_tactic t$ >> - | Tacexpr.TacMatch (lz,t,l) -> - <:expr< Tacexpr.TacMatch - $mlexpr_of_match_lazy_flag lz$ - $mlexpr_of_tactic t$ - $mlexpr_of_list (mlexpr_of_match_rule mlexpr_of_tactic) l$>> - | Tacexpr.TacMatchGoal (lz,lr,l) -> - <:expr< Tacexpr.TacMatchGoal - $mlexpr_of_match_lazy_flag lz$ - $mlexpr_of_bool lr$ - $mlexpr_of_list (mlexpr_of_match_rule mlexpr_of_tactic) l$>> - - | Tacexpr.TacFun (idol,body) -> - <:expr< Tacexpr.TacFun - ($mlexpr_of_list mlexpr_of_ident_option idol$, - $mlexpr_of_tactic body$) >> - | Tacexpr.TacArg (_,Tacexpr.MetaIdArg (_,true,id)) -> anti loc id - | Tacexpr.TacArg (_,t) -> - <:expr< Tacexpr.TacArg $dloc$ $mlexpr_of_tactic_arg t$ >> - | Tacexpr.TacComplete t -> - <:expr< Tacexpr.TacComplete $mlexpr_of_tactic t$ >> - | _ -> failwith "Quotation of tactic expressions: TODO" - -and mlexpr_of_tactic_arg = function - | Tacexpr.MetaIdArg (loc,true,id) -> - let loc = of_coqloc loc in - anti loc id - | Tacexpr.MetaIdArg (loc,false,id) -> - let loc = of_coqloc loc in - <:expr< Tacexpr.ConstrMayEval (Genredexpr.ConstrTerm $anti loc id$) >> - | Tacexpr.TacCall (loc,t,tl) -> - let loc = of_coqloc loc in - <:expr< Tacexpr.TacCall $dloc$ $mlexpr_of_reference t$ $mlexpr_of_list mlexpr_of_tactic_arg tl$>> - | Tacexpr.Tacexp t -> - <:expr< Tacexpr.Tacexp $mlexpr_of_tactic t$ >> - | Tacexpr.ConstrMayEval c -> - <:expr< Tacexpr.ConstrMayEval $mlexpr_of_may_eval mlexpr_of_constr c$ >> - | Tacexpr.Reference r -> - <:expr< Tacexpr.Reference $mlexpr_of_reference r$ >> - | _ -> failwith "mlexpr_of_tactic_arg: TODO" - - -IFDEF CAMLP5 THEN - -let not_impl x = - let desc = - if Obj.is_block (Obj.repr x) then - "tag = " ^ string_of_int (Obj.tag (Obj.repr x)) - else "int_val = " ^ string_of_int (Obj.magic x) - in - failwith ("<Q_coqast.patt_of_expt, not impl: " ^ desc) - -(* The following function is written without quotation - in order to be parsable even by camlp4. The version with - quotation can be found in revision <= 12972 of [q_util.ml4] *) - -open MLast - -let rec patt_of_expr e = - let loc = loc_of_expr e in - match e with - | ExAcc (_, e1, e2) -> PaAcc (loc, patt_of_expr e1, patt_of_expr e2) - | ExApp (_, e1, e2) -> PaApp (loc, patt_of_expr e1, patt_of_expr e2) - | ExLid (_, x) when x = vala "loc" -> PaAny loc - | ExLid (_, s) -> PaLid (loc, s) - | ExUid (_, s) -> PaUid (loc, s) - | ExStr (_, s) -> PaStr (loc, s) - | ExAnt (_, e) -> PaAnt (loc, patt_of_expr e) - | _ -> not_impl e - -let fconstr e = - let ee s = - mlexpr_of_constr (Pcoq.Gram.entry_parse e - (Pcoq.Gram.parsable (Stream.of_string s))) - in - let ep s = patt_of_expr (ee s) in - Quotation.ExAst (ee, ep) - -let ftac e = - let ee s = - mlexpr_of_tactic (Pcoq.Gram.entry_parse e - (Pcoq.Gram.parsable (Stream.of_string s))) - in - let ep s = patt_of_expr (ee s) in - Quotation.ExAst (ee, ep) - -let _ = - Quotation.add "constr" (fconstr Pcoq.Constr.constr_eoi); - Quotation.add "tactic" (ftac Pcoq.Tactic.tactic_eoi); - Quotation.default := "constr" - -ELSE - -open Pcaml - -let expand_constr_quot_expr loc _loc_name_opt contents = - mlexpr_of_constr - (Pcoq.Gram.parse_string Pcoq.Constr.constr_eoi loc contents) - -let expand_tactic_quot_expr loc _loc_name_opt contents = - mlexpr_of_tactic - (Pcoq.Gram.parse_string Pcoq.Tactic.tactic_eoi loc contents) - -let _ = - (* FIXME: for the moment, we add quotations in expressions only, not pattern *) - Quotation.add "constr" Quotation.DynAst.expr_tag expand_constr_quot_expr; - Quotation.add "tactic" Quotation.DynAst.expr_tag expand_tactic_quot_expr; - Quotation.default := "constr" - -END diff --git a/grammar/q_util.ml4 b/grammar/q_util.ml4 index 19f436f92..c529260e9 100644 --- a/grammar/q_util.ml4 +++ b/grammar/q_util.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -10,6 +10,25 @@ open Compat +type argument_type = +| ListArgType of argument_type +| OptArgType of argument_type +| PairArgType of argument_type * argument_type +| ExtraArgType of string + +type user_symbol = +| Ulist1 of user_symbol +| Ulist1sep of user_symbol * string +| Ulist0 of user_symbol +| Ulist0sep of user_symbol * string +| Uopt of user_symbol +| Uentry of string +| Uentryl of string * int + +type extend_token = +| ExtTerminal of string +| ExtNonTerminal of user_symbol * string + let mlexpr_of_list f l = List.fold_right (fun e1 e2 -> @@ -23,16 +42,6 @@ let mlexpr_of_pair m1 m2 (a1,a2) = let loc = CompatLoc.merge (MLast.loc_of_expr e1) (MLast.loc_of_expr e2) in <:expr< ($e1$, $e2$) >> -let mlexpr_of_triple m1 m2 m3 (a1,a2,a3)= - let e1 = m1 a1 and e2 = m2 a2 and e3 = m3 a3 in - let loc = CompatLoc.merge (MLast.loc_of_expr e1) (MLast.loc_of_expr e3) in - <:expr< ($e1$, $e2$, $e3$) >> - -let mlexpr_of_quadruple m1 m2 m3 m4 (a1,a2,a3,a4)= - let e1 = m1 a1 and e2 = m2 a2 and e3 = m3 a3 and e4 = m4 a4 in - let loc = CompatLoc.merge (MLast.loc_of_expr e1) (MLast.loc_of_expr e4) in - <:expr< ($e1$, $e2$, $e3$, $e4$) >> - (* We don't give location for tactic quotation! *) let loc = CompatLoc.ghost @@ -49,35 +58,62 @@ let mlexpr_of_option f = function | None -> <:expr< None >> | Some e -> <:expr< Some $f e$ >> -let mlexpr_of_token = function -| Tok.KEYWORD s -> <:expr< Tok.KEYWORD $mlexpr_of_string s$ >> -| Tok.METAIDENT s -> <:expr< Tok.METAIDENT $mlexpr_of_string s$ >> -| Tok.PATTERNIDENT s -> <:expr< Tok.PATTERNIDENT $mlexpr_of_string s$ >> -| Tok.IDENT s -> <:expr< Tok.IDENT $mlexpr_of_string s$ >> -| Tok.FIELD s -> <:expr< Tok.FIELD $mlexpr_of_string s$ >> -| Tok.INT s -> <:expr< Tok.INT $mlexpr_of_string s$ >> -| Tok.STRING s -> <:expr< Tok.STRING $mlexpr_of_string s$ >> -| Tok.LEFTQMARK -> <:expr< Tok.LEFTQMARK >> -| Tok.BULLET s -> <:expr< Tok.BULLET $mlexpr_of_string s$ >> -| Tok.EOI -> <:expr< Tok.EOI >> - -let rec mlexpr_of_prod_entry_key : type s a. (s, a) Pcoq.entry_key -> _ = function - | Pcoq.Atoken t -> <:expr< Pcoq.Atoken $mlexpr_of_token t$ >> - | Pcoq.Alist1 s -> <:expr< Pcoq.Alist1 $mlexpr_of_prod_entry_key s$ >> - | Pcoq.Alist1sep (s,sep) -> <:expr< Pcoq.Alist1sep $mlexpr_of_prod_entry_key s$ $str:sep$ >> - | Pcoq.Alist0 s -> <:expr< Pcoq.Alist0 $mlexpr_of_prod_entry_key s$ >> - | Pcoq.Alist0sep (s,sep) -> <:expr< Pcoq.Alist0sep $mlexpr_of_prod_entry_key s$ $str:sep$ >> - | Pcoq.Aopt s -> <:expr< Pcoq.Aopt $mlexpr_of_prod_entry_key s$ >> - | Pcoq.Amodifiers s -> <:expr< Pcoq.Amodifiers $mlexpr_of_prod_entry_key s$ >> - | Pcoq.Aself -> <:expr< Pcoq.Aself >> - | Pcoq.Anext -> <:expr< Pcoq.Anext >> - | Pcoq.Aentry e -> - begin match Entry.repr e with - | Entry.Dynamic s -> <:expr< Pcoq.Aentry (Pcoq.name_of_entry $lid:s$) >> - | Entry.Static (u, s) -> <:expr< Pcoq.Aentry (Entry.unsafe_of_name ($str:u$, $str:s$)) >> - end - | Pcoq.Aentryl (e, l) -> - begin match Entry.repr e with - | Entry.Dynamic s -> <:expr< Pcoq.Aentryl (Pcoq.name_of_entry $lid:s$) >> - | Entry.Static (u, s) -> <:expr< Pcoq.Aentryl (Entry.unsafe_of_name ($str:u$, $str:s$)) $mlexpr_of_int l$ >> - end +let mlexpr_of_ident id = + <:expr< Names.Id.of_string $str:id$ >> + +let rec mlexpr_of_prod_entry_key f = function + | Ulist1 s -> <:expr< Extend.Alist1 $mlexpr_of_prod_entry_key f s$ >> + | Ulist1sep (s,sep) -> <:expr< Extend.Alist1sep $mlexpr_of_prod_entry_key f s$ $str:sep$ >> + | Ulist0 s -> <:expr< Extend.Alist0 $mlexpr_of_prod_entry_key f s$ >> + | Ulist0sep (s,sep) -> <:expr< Extend.Alist0sep $mlexpr_of_prod_entry_key f s$ $str:sep$ >> + | Uopt s -> <:expr< Extend.Aopt $mlexpr_of_prod_entry_key f s$ >> + | Uentry e -> <:expr< Extend.Aentry $f e$ >> + | Uentryl (e, l) -> + (** Keep in sync with Pcoq! *) + assert (e = "tactic"); + if l = 5 then <:expr< Extend.Aentry (Pcoq.name_of_entry Pcoq.Tactic.binder_tactic) >> + else <:expr< Extend.Aentryl (Pcoq.name_of_entry Pcoq.Tactic.tactic_expr) $mlexpr_of_int l$ >> + +let rec type_of_user_symbol = function +| Ulist1 s | Ulist1sep (s, _) | Ulist0 s | Ulist0sep (s, _) -> + ListArgType (type_of_user_symbol s) +| Uopt s -> + OptArgType (type_of_user_symbol s) +| Uentry e | Uentryl (e, _) -> ExtraArgType e + +let coincide s pat off = + let len = String.length pat in + let break = ref true in + let i = ref 0 in + while !break && !i < len do + let c = Char.code s.[off + !i] in + let d = Char.code pat.[!i] in + break := Int.equal c d; + incr i + done; + !break + +let rec parse_user_entry s sep = + let l = String.length s in + if l > 8 && coincide s "ne_" 0 && coincide s "_list" (l - 5) then + let entry = parse_user_entry (String.sub s 3 (l-8)) "" in + Ulist1 entry + else if l > 12 && coincide s "ne_" 0 && + coincide s "_list_sep" (l-9) then + let entry = parse_user_entry (String.sub s 3 (l-12)) "" in + Ulist1sep (entry, sep) + else if l > 5 && coincide s "_list" (l-5) then + let entry = parse_user_entry (String.sub s 0 (l-5)) "" in + Ulist0 entry + else if l > 9 && coincide s "_list_sep" (l-9) then + let entry = parse_user_entry (String.sub s 0 (l-9)) "" in + Ulist0sep (entry, sep) + else if l > 4 && coincide s "_opt" (l-4) then + let entry = parse_user_entry (String.sub s 0 (l-4)) "" in + Uopt entry + else if Int.equal l 7 && coincide s "tactic" 0 && '5' >= s.[6] && s.[6] >= '0' then + let n = Char.code s.[6] - 48 in + Uentryl ("tactic", n) + else + let s = match s with "hyp" -> "var" | _ -> s in + Uentry s diff --git a/grammar/q_util.mli b/grammar/q_util.mli index d01fb1e9a..a34fc0bcb 100644 --- a/grammar/q_util.mli +++ b/grammar/q_util.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,20 +8,31 @@ open Compat (* necessary for camlp4 *) +type argument_type = +| ListArgType of argument_type +| OptArgType of argument_type +| PairArgType of argument_type * argument_type +| ExtraArgType of string + +type user_symbol = +| Ulist1 of user_symbol +| Ulist1sep of user_symbol * string +| Ulist0 of user_symbol +| Ulist0sep of user_symbol * string +| Uopt of user_symbol +| Uentry of string +| Uentryl of string * int + +type extend_token = +| ExtTerminal of string +| ExtNonTerminal of user_symbol * string + val mlexpr_of_list : ('a -> MLast.expr) -> 'a list -> MLast.expr val mlexpr_of_pair : ('a -> MLast.expr) -> ('b -> MLast.expr) -> 'a * 'b -> MLast.expr -val mlexpr_of_triple : - ('a -> MLast.expr) -> ('b -> MLast.expr) -> ('c -> MLast.expr) - -> 'a * 'b * 'c -> MLast.expr - -val mlexpr_of_quadruple : - ('a -> MLast.expr) -> ('b -> MLast.expr) -> - ('c -> MLast.expr) -> ('d -> MLast.expr) -> 'a * 'b * 'c * 'd -> MLast.expr - val mlexpr_of_bool : bool -> MLast.expr val mlexpr_of_int : int -> MLast.expr @@ -30,4 +41,10 @@ val mlexpr_of_string : string -> MLast.expr val mlexpr_of_option : ('a -> MLast.expr) -> 'a option -> MLast.expr -val mlexpr_of_prod_entry_key : ('self, 'a) Pcoq.entry_key -> MLast.expr +val mlexpr_of_ident : string -> MLast.expr + +val mlexpr_of_prod_entry_key : (string -> MLast.expr) -> user_symbol -> MLast.expr + +val type_of_user_symbol : user_symbol -> argument_type + +val parse_user_entry : string -> string -> user_symbol diff --git a/grammar/tacextend.ml4 b/grammar/tacextend.ml4 index df2209606..2ef30f299 100644 --- a/grammar/tacextend.ml4 +++ b/grammar/tacextend.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -10,15 +10,8 @@ (** Implementation of the TACTIC EXTEND macro. *) -open Util -open Pp -open Names -open Genarg open Q_util -open Q_coqast open Argextend -open Pcoq -open Egramml open Compat let dloc = <:expr< Loc.ghost >> @@ -27,160 +20,63 @@ let plugin_name = <:expr< __coq_plugin_name >> let rec make_patt = function | [] -> <:patt< [] >> - | GramNonTerminal(loc',_,_,Some p)::l -> - let p = Names.Id.to_string p in + | ExtNonTerminal (_, p) :: l -> <:patt< [ $lid:p$ :: $make_patt l$ ] >> | _::l -> make_patt l -let rec make_when loc = function - | [] -> <:expr< True >> - | GramNonTerminal(loc',t,_,Some p)::l -> - let loc' = of_coqloc loc' in - let p = Names.Id.to_string p in - let l = make_when loc l in - let loc = CompatLoc.merge loc' loc in - let t = mlexpr_of_argtype loc' (Genarg.unquote t) in - <:expr< Genarg.argument_type_eq (Genarg.genarg_tag $lid:p$) $t$ && $l$ >> - | _::l -> make_when loc l - let rec make_let raw e = function | [] -> <:expr< fun $lid:"ist"$ -> $e$ >> - | GramNonTerminal(loc,t,_,Some p)::l -> - let t = Genarg.unquote t in - let loc = of_coqloc loc in - let p = Names.Id.to_string p in - let loc = CompatLoc.merge loc (MLast.loc_of_expr e) in + | ExtNonTerminal (g, p) :: l -> + let t = type_of_user_symbol g in + let loc = MLast.loc_of_expr e in let e = make_let raw e l in let v = if raw then <:expr< Genarg.out_gen $make_rawwit loc t$ $lid:p$ >> - else <:expr< Genarg.out_gen $make_topwit loc t$ $lid:p$ >> in + else <:expr< Tacinterp.Value.cast $make_topwit loc t$ $lid:p$ >> in <:expr< let $lid:p$ = $v$ in $e$ >> | _::l -> make_let raw e l -let rec extract_signature = function - | [] -> [] - | GramNonTerminal (_,t,_,_) :: l -> Genarg.unquote t :: extract_signature l - | _::l -> extract_signature l - - - -let check_unicity s l = - let l' = List.map (fun (l,_,_) -> extract_signature l) l in - if not (Util.List.distinct l') then - Pp.msg_warning - (strbrk ("Two distinct rules of tactic entry "^s^" have the same "^ - "non-terminals in the same order: put them in distinct tactic entries")) - let make_clause (pt,_,e) = (make_patt pt, - vala (Some (make_when (MLast.loc_of_expr e) pt)), + vala None, make_let false e pt) let make_fun_clauses loc s l = - check_unicity s l; let map c = Compat.make_fun loc [make_clause c] in mlexpr_of_list map l -let rec make_args = function - | [] -> <:expr< [] >> - | GramNonTerminal(loc,t,_,Some p)::l -> - let t = Genarg.unquote t in - let loc = of_coqloc loc in - let p = Names.Id.to_string p in - <:expr< [ Genarg.in_gen $make_topwit loc t$ $lid:p$ :: $make_args l$ ] >> - | _::l -> make_args l - -let mlexpr_terminals_of_grammar_tactic_prod_item_expr = function - | GramTerminal s -> <:expr< Some $mlexpr_of_string s$ >> - | GramNonTerminal (loc,nt,_,sopt) -> - let loc = of_coqloc loc in <:expr< None >> - let make_prod_item = function - | GramTerminal s -> <:expr< Egramml.GramTerminal $str:s$ >> - | GramNonTerminal (loc,nt,g,sopt) -> - let loc = of_coqloc loc in - let nt = Genarg.unquote nt in + | ExtTerminal s -> <:expr< Egramml.GramTerminal $str:s$ >> + | ExtNonTerminal (g, id) -> + let nt = type_of_user_symbol g in + let base s = <:expr< Pcoq.name_of_entry (Pcoq.genarg_grammar $mk_extraarg loc s$) >> in <:expr< Egramml.GramNonTerminal $default_loc$ $make_rawwit loc nt$ - $mlexpr_of_prod_entry_key g$ $mlexpr_of_option mlexpr_of_ident sopt$ >> + $mlexpr_of_prod_entry_key base g$ >> let mlexpr_of_clause cl = - mlexpr_of_list (fun (a,_,b) -> mlexpr_of_list make_prod_item a) cl - -let rec make_tags loc = function - | [] -> <:expr< [] >> - | GramNonTerminal(loc',t,_,Some p)::l -> - let loc' = of_coqloc loc' in - let l = make_tags loc l in - let loc = CompatLoc.merge loc' loc in - let t = Genarg.unquote t in - let t = mlexpr_of_argtype loc' t in - <:expr< [ $t$ :: $l$ ] >> - | _::l -> make_tags loc l + mlexpr_of_list (fun (a,_,_) -> mlexpr_of_list make_prod_item a) cl let make_one_printing_rule (pt,_,e) = let level = mlexpr_of_int 0 in (* only level 0 supported here *) let loc = MLast.loc_of_expr e in - let prods = mlexpr_of_list mlexpr_terminals_of_grammar_tactic_prod_item_expr pt in - <:expr< { Pptactic.pptac_args = $make_tags loc pt$; - pptac_prods = ($level$, $prods$) } >> + let prods = mlexpr_of_list make_prod_item pt in + <:expr< { Pptactic.pptac_level = $level$; + pptac_prods = $prods$ } >> let make_printing_rule r = mlexpr_of_list make_one_printing_rule r -let make_empty_check = function -| GramNonTerminal(_, t, e, _)-> - let t = Genarg.unquote t in - let is_extra = match t with ExtraArgType _ -> true | _ -> false in - if is_possibly_empty e || is_extra then - (* This possibly parses epsilon *) - let wit = make_wit loc t in - let rawwit = make_rawwit loc t in - <:expr< - match Genarg.default_empty_value $wit$ with - [ None -> raise Exit - | Some v -> - Tacintern.intern_genarg Tacintern.fully_empty_glob_sign - (Genarg.in_gen $rawwit$ v) ] >> - else - (* This does not parse epsilon (this Exit is static time) *) - raise Exit -| GramTerminal _ -> - (* Idem *) - raise Exit - -let rec possibly_atomic loc = function -| [] -> [] -| ((GramNonTerminal _ :: _ | []), _, _) :: rem -> - (** This is not parsed by the TACTIC EXTEND rules *) - assert false -| (GramTerminal s :: prods, _, _) :: rem -> - let entry = - try - let l = List.map make_empty_check prods in - let l = mlexpr_of_list (fun x -> x) l in - (s, <:expr< try Some $l$ with [ Exit -> None ] >>) - with Exit -> (s, <:expr< None >>) - in - entry :: possibly_atomic loc rem - (** Special treatment of constr entries *) let is_constr_gram = function -| GramTerminal _ -> false -| GramNonTerminal (_, _, e, _) -> - match e with - | Aentry e -> - begin match Entry.repr e with - | Entry.Static ("constr", "constr") -> true - | _ -> false - end - | _ -> false +| ExtTerminal _ -> false +| ExtNonTerminal (Uentry "constr", _) -> true +| _ -> false let make_var = function - | GramNonTerminal(loc',_,_,Some p) -> Some p - | GramNonTerminal(loc',_,_,None) -> Some (Id.of_string "_") + | ExtNonTerminal (_, p) -> Some p | _ -> assert false let declare_tactic loc s c cl = match cl with -| [(GramTerminal name) :: rem, _, tac] when List.for_all is_constr_gram rem -> +| [(ExtTerminal 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 @@ -190,13 +86,13 @@ let declare_tactic loc s c cl = match cl with let se = <:expr< { Tacexpr.mltac_tactic = $entry$; Tacexpr.mltac_plugin = $plugin_name$ } >> in let ml = <:expr< { Tacexpr.mltac_name = $se$; Tacexpr.mltac_index = 0 } >> in let name = mlexpr_of_string name in - let tac = + let tac = match rem with + | [] -> (** Special handling of tactics without arguments: such tactics do not do a Proofview.Goal.nf_enter to compute their arguments. It matters for some whole-prof tactics like [shelve_unifiable]. *) - if List.is_empty rem then <:expr< fun _ $lid:"ist"$ -> $tac$ >> - else + | _ -> let f = Compat.make_fun loc [patt, vala None, <:expr< fun $lid:"ist"$ -> $tac$ >>] in <:expr< Tacinterp.lift_constr_tac_to_ml_tac $vars$ $f$ >> in @@ -224,10 +120,7 @@ let declare_tactic loc s c cl = match cl with let se = <:expr< { Tacexpr.mltac_tactic = $entry$; Tacexpr.mltac_plugin = $plugin_name$ } >> in let pp = make_printing_rule cl in let gl = mlexpr_of_clause cl in - let atom = - mlexpr_of_list (mlexpr_of_pair mlexpr_of_string (fun x -> x)) - (possibly_atomic loc cl) in - let obj = <:expr< fun () -> Metasyntax.add_ml_tactic_notation $se$ $gl$ $atom$ >> in + let obj = <:expr< fun () -> Tacentries.add_ml_tactic_notation $se$ $gl$ >> in declare_str_items loc [ <:str_item< do { try do { @@ -258,7 +151,7 @@ EXTEND c = OPT [ "=>"; "["; c = Pcaml.expr; "]" -> c ]; "->"; "["; e = Pcaml.expr; "]" -> (match l with - | GramNonTerminal _ :: _ -> + | ExtNonTerminal _ :: _ -> (* En attendant la syntaxe de tacticielles *) failwith "Tactic syntax must start with an identifier" | _ -> (l,c,e)) @@ -266,14 +159,14 @@ EXTEND ; tacargs: [ [ e = LIDENT; "("; s = LIDENT; ")" -> - let EntryName (t, g) = interp_entry_name false TgAny e "" in - GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s)) + let e = parse_user_entry e "" in + ExtNonTerminal (e, s) | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" -> - let EntryName (t, g) = interp_entry_name false TgAny e sep in - GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s)) + let e = parse_user_entry e sep in + ExtNonTerminal (e, s) | s = STRING -> - if String.is_empty s then Errors.user_err_loc (!@loc,"",Pp.str "Empty terminal."); - GramTerminal s + let () = if s = "" then failwith "Empty terminal." in + ExtTerminal s ] ] ; tac_name: diff --git a/grammar/vernacextend.ml4 b/grammar/vernacextend.ml4 index 54638556d..aedaead71 100644 --- a/grammar/vernacextend.ml4 +++ b/grammar/vernacextend.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -10,19 +10,15 @@ (** Implementation of the VERNAC EXTEND macro. *) -open Pp -open Util open Q_util open Argextend open Tacextend -open Pcoq -open Egramml open Compat type rule = { r_head : string option; (** The first terminal grammar token *) - r_patt : Vernacexpr.vernac_expr grammar_prod_item list; + r_patt : extend_token list; (** The remaining tokens of the parsing rule *) r_class : MLast.expr option; (** An optional classifier for the STM *) @@ -34,25 +30,25 @@ type rule = { let rec make_let e = function | [] -> e - | GramNonTerminal(loc,t,_,Some p)::l -> - let t = Genarg.unquote t in - let loc = of_coqloc loc in - let p = Names.Id.to_string p in - let loc = CompatLoc.merge loc (MLast.loc_of_expr e) in + | ExtNonTerminal (g, p) :: l -> + let t = type_of_user_symbol g in + let loc = MLast.loc_of_expr e in let e = make_let e l in <:expr< let $lid:p$ = Genarg.out_gen $make_rawwit loc t$ $lid:p$ in $e$ >> | _::l -> make_let e l let make_clause { r_patt = pt; r_branch = e; } = (make_patt pt, - vala (Some (make_when (MLast.loc_of_expr e) pt)), + vala None, make_let e pt) (* To avoid warnings *) let mk_ignore c pt = - let names = CList.map_filter (function - | GramNonTerminal(_,_,_,Some p) -> Some (Names.Id.to_string p) - | _ -> None) pt in + let fold accu = function + | ExtNonTerminal (_, p) -> p :: accu + | _ -> accu + in + let names = List.fold_left fold [] pt in let fold accu id = <:expr< let _ = $lid:id$ in $accu$ >> in let names = List.fold_left fold <:expr< () >> names in <:expr< do { let _ = $names$ in $c$ } >> @@ -61,34 +57,34 @@ let make_clause_classifier cg s { r_patt = pt; r_class = c; } = match c ,cg with | Some c, _ -> (make_patt pt, - vala (Some (make_when (MLast.loc_of_expr c) pt)), + vala None, make_let (mk_ignore c pt) pt) | None, Some cg -> (make_patt pt, - vala (Some (make_when (MLast.loc_of_expr cg) pt)), + vala None, <:expr< fun () -> $cg$ $str:s$ >>) - | None, None -> msg_warning - (strbrk("Vernac entry \""^s^"\" misses a classifier. "^ + | None, None -> prerr_endline + (("Vernac entry \""^s^"\" misses a classifier. "^ "A classifier is a function that returns an expression "^ - "of type vernac_classification (see Vernacexpr). You can: ")++ - str"- "++hov 0 ( - strbrk("Use '... EXTEND "^s^" CLASSIFIED AS QUERY ...' if the "^ - "new vernacular command does not alter the system state;"))++fnl()++ - str"- "++hov 0 ( - strbrk("Use '... EXTEND "^s^" CLASSIFIED AS SIDEFF ...' if the "^ + "of type vernac_classification (see Vernacexpr). You can: ") ^ + "- " ^ ( + ("Use '... EXTEND "^s^" CLASSIFIED AS QUERY ...' if the "^ + "new vernacular command does not alter the system state;"))^ "\n" ^ + "- " ^ ( + ("Use '... EXTEND "^s^" CLASSIFIED AS SIDEFF ...' if the "^ "new vernacular command alters the system state but not the "^ - "parser nor it starts a proof or ends one;"))++fnl()++ - str"- "++hov 0 ( - strbrk("Use '... EXTEND "^s^" CLASSIFIED BY f ...' to specify "^ + "parser nor it starts a proof or ends one;"))^ "\n" ^ + "- " ^ ( + ("Use '... EXTEND "^s^" CLASSIFIED BY f ...' to specify "^ "a global function f. The function f will be called passing "^ - "\""^s^"\" as the only argument;")) ++fnl()++ - str"- "++hov 0 ( - strbrk"Add a specific classifier in each clause using the syntax:" - ++fnl()++strbrk("'[...] => [ f ] -> [...]'. "))++fnl()++ - strbrk("Specific classifiers have precedence over global "^ - "classifiers. Only one classifier is called.")++fnl()); + "\""^s^"\" as the only argument;")) ^ "\n" ^ + "- " ^ ( + "Add a specific classifier in each clause using the syntax:" + ^ "\n" ^("'[...] => [ f ] -> [...]'. "))^ "\n" ^ + ("Specific classifiers have precedence over global "^ + "classifiers. Only one classifier is called.") ^ "\n"); (make_patt pt, - vala (Some (make_when loc pt)), + vala None, <:expr< fun () -> (Vernacexpr.VtUnknown, Vernacexpr.VtNow) >>) let make_fun_clauses loc s l = @@ -106,10 +102,12 @@ let make_fun_classifiers loc s c l = let cl = List.map (fun x -> Compat.make_fun loc [make_clause_classifier c s x]) l in mlexpr_of_list (fun x -> x) cl -let mlexpr_of_clause = - mlexpr_of_list - (fun { r_head = a; r_patt = b; } -> mlexpr_of_list make_prod_item - (Option.List.cons (Option.map (fun a -> GramTerminal a) a) b)) +let mlexpr_of_clause cl = + let mkexpr { r_head = a; r_patt = b; } = match a with + | None -> mlexpr_of_list make_prod_item b + | Some a -> mlexpr_of_list make_prod_item (ExtTerminal a :: b) + in + mlexpr_of_list mkexpr cl let declare_command loc s c nt cl = let se = mlexpr_of_string s in @@ -167,8 +165,7 @@ EXTEND rule: [ [ "["; s = STRING; l = LIST0 args; "]"; d = OPT deprecation; c = OPT classifier; "->"; "["; e = Pcaml.expr; "]" -> - if String.is_empty s then - Errors.user_err_loc (!@loc,"",Pp.str"Command name is empty."); + let () = if s = "" then failwith "Command name is empty." in let b = <:expr< fun () -> $e$ >> in { r_head = Some s; r_patt = l; r_class = c; r_branch = b; r_depr = d; } | "[" ; "-" ; l = LIST1 args ; "]" ; @@ -182,13 +179,13 @@ EXTEND ; args: [ [ e = LIDENT; "("; s = LIDENT; ")" -> - let EntryName (t, g) = interp_entry_name false TgAny e "" in - GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s)) + let e = parse_user_entry e "" in + ExtNonTerminal (e, s) | e = LIDENT; "("; s = LIDENT; ","; sep = STRING; ")" -> - let EntryName (t, g) = interp_entry_name false TgAny e sep in - GramNonTerminal (!@loc, t, g, Some (Names.Id.of_string s)) + let e = parse_user_entry e sep in + ExtNonTerminal (e, s) | s = STRING -> - GramTerminal s + ExtTerminal s ] ] ; END @@ -1,7 +1,7 @@ CoqIde FAQ Q0) What is CoqIde? -R0: A powerfull graphical interface for Coq. See http://coq.inria.fr. for more informations. +R0: A powerful graphical interface for Coq. See http://coq.inria.fr. for more informations. Q1) How to enable Emacs keybindings? R1: Insert diff --git a/ide/MacOS/Info.plist.template b/ide/MacOS/Info.plist.template index e224e8120..fbe7773dd 100644 --- a/ide/MacOS/Info.plist.template +++ b/ide/MacOS/Info.plist.template @@ -66,7 +66,7 @@ <key>CFBundleGetInfoString</key> <string>Coq_vVERSION</string> <key>NSHumanReadableCopyright</key> - <string>Copyright 1999-2015, The Coq Development Team INRIA - CNRS - LIX - LRI - PPS</string> + <string>Copyright 1999-2016, The Coq Development Team INRIA - CNRS - LIX - LRI - PPS</string> <key>CFBundleHelpBookFolder</key> <string>share/doc/coq/html/</string> <key>CFAppleHelpAnchor</key> diff --git a/ide/config_lexer.mll b/ide/config_lexer.mll index 367153568..ac9cc57bc 100644 --- a/ide/config_lexer.mll +++ b/ide/config_lexer.mll @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/coq.ml b/ide/coq.ml index a60f327b4..fa0adf979 100644 --- a/ide/coq.ml +++ b/ide/coq.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -99,9 +99,6 @@ let display_coqtop_answer cmd lines = "Command was: "^cmd^"\n"^ "Answer was: "^(String.concat "\n " lines)) -let check_remaining_opt arg = - if arg <> "" && arg.[0] = '-' then fatal_error_popup ("Illegal option: "^arg) - let rec filter_coq_opts args = let argstr = String.concat " " (List.map Filename.quote args) in let cmd = Filename.quote (coqtop_path ()) ^" -nois -filteropts " ^ argstr in @@ -200,8 +197,6 @@ module GlibMainLoop = struct let read_all = Ideutils.io_read_all let async_chan_of_file fd = Glib.Io.channel_of_descr fd let async_chan_of_socket s = !gio_channel_of_descr_socket s - let add_timeout ~sec callback = - ignore(Glib.Timeout.add ~ms:(sec * 1000) ~callback) end module CoqTop = Spawn.Async(GlibMainLoop) @@ -465,10 +460,6 @@ let close_coqtop coqtop = let reset_coqtop coqtop = respawn_coqtop ~why:Planned coqtop -let break_coqtop coqtop = - try !interrupter (CoqTop.unixpid coqtop.handle.proc) - with _ -> Minilib.log "Error while sending Ctrl-C" - let get_arguments coqtop = coqtop.sup_args let set_arguments coqtop args = @@ -518,6 +509,17 @@ let search flags = eval_call (Xmlprotocol.search flags) let init x = eval_call (Xmlprotocol.init x) let stop_worker x = eval_call (Xmlprotocol.stop_worker x) +let break_coqtop coqtop workers = + if coqtop.status = Busy then + try !interrupter (CoqTop.unixpid coqtop.handle.proc) + with _ -> Minilib.log "Error while sending Ctrl-C" + else + let rec aux = function + | [] -> Void + | w :: ws -> stop_worker w coqtop.handle (fun _ -> aux ws) + in + let Void = aux workers in () + module PrintOpt = struct type t = string list diff --git a/ide/coq.mli b/ide/coq.mli index 2dc5ad307..7cef6a4d0 100644 --- a/ide/coq.mli +++ b/ide/coq.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -70,8 +70,8 @@ val init_coqtop : coqtop -> unit task -> unit (** Finish initializing a freshly spawned coqtop, by running a first task on it. The task should run its inner continuation at the end. *) -val break_coqtop : coqtop -> unit -(** Interrupt the current computation of coqtop. *) +val break_coqtop : coqtop -> string list -> unit +(** Interrupt the current computation of coqtop or the worker if coqtop it not running. *) val close_coqtop : coqtop -> unit (** Close coqtop. Subsequent requests will be discarded. Hook ignored. *) diff --git a/ide/coqOps.ml b/ide/coqOps.ml index 8bfc70b63..aa1a75db6 100644 --- a/ide/coqOps.ml +++ b/ide/coqOps.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -174,6 +174,55 @@ let validate s = module Doc = Document +let segment_model (doc : sentence Doc.document) : Wg_Segment.model = +object (self) + + val mutable cbs = [] + + val mutable document_length = 0 + + method length = document_length + + method changed ~callback = cbs <- callback :: cbs + + method fold : 'a. ('a -> Wg_Segment.color -> 'a) -> 'a -> 'a = fun f accu -> + let fold accu _ _ s = + let flags = List.map mem_flag_of_flag s.flags in + f accu (flags_to_color flags) + in + Doc.fold_all doc accu fold + + method private on_changed (i, f) = + let data = (i, flags_to_color f) in + List.iter (fun f -> f (`SET data)) cbs + + method private on_push s ctx = + let after = match ctx with + | None -> [] + | Some (l, _) -> l + in + List.iter (fun s -> set_index s (s.index + 1)) after; + set_index s (document_length - List.length after); + ignore ((SentenceId.connect s)#changed self#on_changed); + document_length <- document_length + 1; + List.iter (fun f -> f `INSERT) cbs + + method private on_pop s ctx = + let () = match ctx with + | None -> () + | Some (l, _) -> List.iter (fun s -> set_index s (s.index - 1)) l + in + set_index s (-1); + document_length <- document_length - 1; + List.iter (fun f -> f `REMOVE) cbs + + initializer + let _ = (Doc.connect doc)#pushed self#on_push in + let _ = (Doc.connect doc)#popped self#on_pop in + () + +end + class coqops (_script:Wg_ScriptView.script_view) (_pv:Wg_ProofView.proof_view) @@ -206,20 +255,8 @@ object(self) script#misc#set_has_tooltip true; ignore(script#misc#connect#query_tooltip ~callback:self#tooltip_callback); feedback_timer.Ideutils.run ~ms:300 ~callback:self#process_feedback; - let on_changed (i, f) = segment#add i (flags_to_color f) in - let on_push s = - set_index s document_length; - 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 - segment#add s.index (flags_to_color flags); - in - let on_pop s = - set_index s (-1); - document_length <- pred document_length; - segment#set_length document_length; - in + let md = segment_model document in + segment#set_model md; let on_click id = let find _ _ s = Int.equal s.index id in let sentence = Doc.find document find in @@ -235,8 +272,6 @@ object(self) script#buffer#place_cursor iter; ignore (script#scroll_to_iter ~use_align:true ~yalign:0. iter) in - let _ = (Doc.connect document)#pushed on_push in - let _ = (Doc.connect document)#popped on_pop in let _ = segment#connect#clicked on_click in () @@ -564,7 +599,7 @@ object(self) if Queue.is_empty queue then conclude topstack else match Queue.pop queue, topstack with | `Skip(start,stop), [] -> - logger Pp.Error (Richpp.richpp_of_string "You muse close the proof with Qed or Admitted"); + logger Pp.Error (Richpp.richpp_of_string "You must close the proof with Qed or Admitted"); self#discard_command_queue queue; conclude [] | `Skip(start,stop), (_,s) :: topstack -> @@ -834,7 +869,10 @@ object(self) method initialize = let get_initial_state = let next = function - | Fail _ -> messages#set (Richpp.richpp_of_string "Couln't initialize Coq"); Coq.return () + | Fail (_, _, message) -> + let message = "Couldn't initialize coqtop\n\n" ^ (Richpp.raw_print message) in + let popup = GWindow.message_dialog ~buttons:GWindow.Buttons.ok ~message_type:`ERROR ~message () in + ignore (popup#run ()); exit 1 | Good id -> initial_state <- id; Coq.return () in Coq.bind (Coq.init (get_filename ())) next in Coq.seq get_initial_state Coq.PrintOpt.enforce diff --git a/ide/coqOps.mli b/ide/coqOps.mli index 8e76d3b27..4a37a1fa5 100644 --- a/ide/coqOps.mli +++ b/ide/coqOps.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/coq_commands.ml b/ide/coq_commands.ml index 37e38a546..d55e7f9dd 100644 --- a/ide/coq_commands.ml +++ b/ide/coq_commands.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/coq_lex.mll b/ide/coq_lex.mll index e333c0b24..b6286c49f 100644 --- a/ide/coq_lex.mll +++ b/ide/coq_lex.mll @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/coqide.ml b/ide/coqide.ml index 5fdb4a2a4..1fe393d2b 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -570,7 +570,7 @@ module Nav = struct let restart _ = on_current_term restart let interrupt sn = Minilib.log "User break received"; - Coq.break_coqtop sn.coqtop + Coq.break_coqtop sn.coqtop CString.(Set.elements (Map.domain sn.jobpage#data)) let interrupt = cb_on_current_term interrupt let join_document _ = send_to_coq (fun sn -> sn.coqops#join_document) end diff --git a/ide/coqide.mli b/ide/coqide.mli index 669151284..744b974ff 100644 --- a/ide/coqide.mli +++ b/ide/coqide.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/coqide_main.ml4 b/ide/coqide_main.ml4 index db69ec661..534a3f179 100644 --- a/ide/coqide_main.ml4 +++ b/ide/coqide_main.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/document.ml b/ide/document.ml index 9823e7576..62457fe56 100644 --- a/ide/document.ml +++ b/ide/document.ml @@ -16,8 +16,8 @@ type id = Stateid.t class type ['a] signals = object - method popped : callback:('a -> unit) -> unit - method pushed : callback:('a -> unit) -> unit + method popped : callback:('a -> ('a list * 'a list) option -> unit) -> unit + method pushed : callback:('a -> ('a list * 'a list) option -> unit) -> unit end class ['a] signal () = @@ -32,14 +32,14 @@ end type 'a document = { mutable stack : 'a sentence list; mutable context : ('a sentence list * 'a sentence list) option; - pushed_sig : 'a signal; - popped_sig : 'a signal; + pushed_sig : ('a * ('a list * 'a list) option) signal; + popped_sig : ('a * ('a list * 'a list) option) signal; } -let connect d = +let connect d : 'a signals = object - method pushed ~callback = d.pushed_sig#connect callback - method popped ~callback = d.popped_sig#connect callback + method pushed ~callback = d.pushed_sig#connect (fun (x, ctx) -> callback x ctx) + method popped ~callback = d.popped_sig#connect (fun (x, ctx) -> callback x ctx) end let create () = { @@ -49,6 +49,12 @@ let create () = { popped_sig = new signal (); } +let repr_context s = match s.context with +| None -> None +| Some (cl, cr) -> + let map s = s.data in + Some (List.map map cl, List.map map cr) + (* Invariant, only the tip is a allowed to have state_id = None *) let invariant l = l = [] || (List.hd l).state_id <> None @@ -64,12 +70,13 @@ let tip_data = function let push d x = assert(invariant d.stack); d.stack <- { data = x; state_id = None } :: d.stack; - d.pushed_sig#call x + d.pushed_sig#call (x, repr_context d) let pop = function | { stack = [] } -> raise Empty - | { stack = { data }::xs } as s -> s.stack <- xs; s.popped_sig#call data; data - + | { stack = { data }::xs } as s -> + s.stack <- xs; s.popped_sig#call (data, repr_context s); data + let focus d ~cond_top:c_start ~cond_bot:c_stop = assert(invariant d.stack); if d.context <> None then invalid_arg "focus"; @@ -124,12 +131,6 @@ let context d = let pair _ x y = try Option.get x, y with Option.IsNone -> assert false in List.map (flat pair true) top, List.map (flat pair true) bot -let iter d f = - let a, s, b = to_lists d in - List.iter (flat f false) a; - List.iter (flat f true) s; - List.iter (flat f false) b - let stateid_opt_equal = Option.equal Stateid.equal let is_in_focus d id = @@ -154,7 +155,7 @@ let cut_at d id = if stateid_opt_equal state_id (Some id) then CSig.Stop (n, zone) else CSig.Cont (n + 1, data :: zone) in let n, zone = CList.fold_left_until aux (0, []) d.stack in - for i = 1 to n do ignore(pop d) done; + for _i = 1 to n do ignore(pop d) done; List.rev zone let find_id d f = diff --git a/ide/document.mli b/ide/document.mli index 0d803ff00..fb96cb6d7 100644 --- a/ide/document.mli +++ b/ide/document.mli @@ -108,8 +108,8 @@ val print : class type ['a] signals = object - method popped : callback:('a -> unit) -> unit - method pushed : callback:('a -> unit) -> unit + method popped : callback:('a -> ('a list * 'a list) option -> unit) -> unit + method pushed : callback:('a -> ('a list * 'a list) option -> unit) -> unit end val connect : 'a document -> 'a signals diff --git a/ide/fileOps.ml b/ide/fileOps.ml index eccd61d0d..7be1bdb92 100644 --- a/ide/fileOps.ml +++ b/ide/fileOps.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/fileOps.mli b/ide/fileOps.mli index 48b7c8f65..9f0b75ac5 100644 --- a/ide/fileOps.mli +++ b/ide/fileOps.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/gtk_parsing.ml b/ide/gtk_parsing.ml index 79ccf61a4..f905053dd 100644 --- a/ide/gtk_parsing.ml +++ b/ide/gtk_parsing.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml index a6c42b28c..9a3e85e47 100644 --- a/ide/ide_slave.ml +++ b/ide/ide_slave.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -130,7 +130,8 @@ let annotate phrase = (** Goal display *) -let hyp_next_tac sigma env (id,_,ast) = +let hyp_next_tac sigma env decl = + let (id,_,ast) = Context.Named.Declaration.to_tuple decl in let id_s = Names.Id.to_string id in let type_s = string_of_ppcmds (pr_ltype_env env sigma ast) in [ @@ -187,12 +188,16 @@ let process_goal sigma g = Richpp.richpp_of_pp (pr_goal_concl_style_env env sigma norm_constr) in let process_hyp d (env,l) = - let d = Context.map_named_list_declaration (Reductionops.nf_evar sigma) d in - let d' = List.map (fun x -> (x, pi2 d, pi3 d)) (pi1 d) in + let d = Context.NamedList.Declaration.map_constr (Reductionops.nf_evar sigma) d in + let d' = List.map (fun name -> let open Context.Named.Declaration in + match pi2 d with + | None -> LocalAssum (name, pi3 d) + | Some value -> LocalDef (name, value, pi3 d)) + (pi1 d) in (List.fold_right Environ.push_named d' env, (Richpp.richpp_of_pp (pr_var_list_decl env sigma d)) :: l) in let (_env, hyps) = - Context.fold_named_list_context process_hyp + Context.NamedList.fold 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; } @@ -366,6 +371,7 @@ let init = 0 (Printf.sprintf "Add LoadPath \"%s\". " dir) else Stm.get_current_state (), `NewTip in Stm.set_compilation_hints file; + Stm.finish (); initial_id end diff --git a/ide/ideutils.ml b/ide/ideutils.ml index 2e4adba73..508881cad 100644 --- a/ide/ideutils.ml +++ b/ide/ideutils.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -9,8 +9,6 @@ open Preferences -exception Forbidden - let warn_image () = let img = GMisc.image () in img#set_stock `DIALOG_WARNING; @@ -31,7 +29,7 @@ let push_info,pop_info,clear_info = let size = ref 0 in (fun s -> incr size; ignore (status_context#push s)), (fun () -> decr size; status_context#pop ()), - (fun () -> for i = 1 to !size do status_context#pop () done; size := 0) + (fun () -> for _i = 1 to !size do status_context#pop () done; size := 0) let flash_info = let flash_context = status#new_context ~name:"Flash" in diff --git a/ide/ideutils.mli b/ide/ideutils.mli index db2dce5a3..4e35a6f9f 100644 --- a/ide/ideutils.mli +++ b/ide/ideutils.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/interface.mli b/ide/interface.mli index f2f121ac0..2a9b8b241 100644 --- a/ide/interface.mli +++ b/ide/interface.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/nanoPG.ml b/ide/nanoPG.ml index 0668ad09f..93bdeb324 100644 --- a/ide/nanoPG.ml +++ b/ide/nanoPG.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/preferences.ml b/ide/preferences.ml index a605014f2..addea9074 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -700,10 +700,6 @@ let configure ?(apply=(fun () -> ())) () = ~border_width:2 ~packing:scroll#add_with_viewport () in - let reset_button = GButton.button - ~label:"Reset" - ~packing:box#pack () - in let i = ref 0 in let cb = ref [] in let iter text tag = diff --git a/ide/preferences.mli b/ide/preferences.mli index b5c7ea222..1733091a5 100644 --- a/ide/preferences.mli +++ b/ide/preferences.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/project_file.ml4 b/ide/project_file.ml4 index f7279f9cf..081094e2b 100644 --- a/ide/project_file.ml4 +++ b/ide/project_file.ml4 @@ -28,6 +28,7 @@ let rec parse_string = parser and parse_string2 = parser | [< ''"' >] -> "" | [< 'c; s >] -> (String.make 1 c)^(parse_string2 s) + | [< >] -> raise Parsing_error and parse_skip_comment = parser | [< ''\n'; s >] -> s | [< 'c; s >] -> parse_skip_comment s @@ -47,7 +48,7 @@ let parse f = res let rec process_cmd_line orig_dir ((project_file,makefile,install,opt) as opts) l = function - | [] -> opts,List.rev l + | [] -> opts, l | ("-h"|"--help") :: _ -> raise Parsing_error | ("-no-opt"|"-byte") :: r -> @@ -85,7 +86,6 @@ let rec process_cmd_line orig_dir ((project_file,makefile,install,opt) as opts) process_cmd_line orig_dir opts ((Include (CUnix.correct_path d orig_dir, lp)) :: l) r | "-I" :: d :: r -> process_cmd_line orig_dir opts ((MLInclude (CUnix.correct_path d orig_dir)) :: l) r - | "-R" :: p :: "-as" :: lp :: r | "-R" :: p :: lp :: r -> process_cmd_line orig_dir opts (RInclude (CUnix.correct_path p orig_dir,lp) :: l) r | ("-Q"|"-R"|"-I"|"-custom"|"-extra"|"-extra-phony") :: _ -> @@ -127,6 +127,10 @@ let rec process_cmd_line orig_dir ((project_file,makefile,install,opt) as opts) else if (Filename.check_suffix f ".mlpack") then MLPACK f else Subdir f) :: l) r +let process_cmd_line orig_dir opts l args = + let (opts, l) = process_cmd_line orig_dir opts l args in + opts, List.rev l + let rec post_canonize f = if Filename.basename f = Filename.current_dir_name then let dir = Filename.dirname f in @@ -134,48 +138,44 @@ let rec post_canonize f = else f (* Return: ((v,(mli,ml4,ml,mllib,mlpack),special,subdir),(ml_inc,q_inc,r_inc),(args,defs)) *) -let split_arguments = - let rec aux = function - | V n :: r -> - let (v,m,o,s),i,d = aux r in ((CUnix.remove_path_dot n::v,m,o,s),i,d) - | ML n :: r -> - let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in - ((v,(mli,ml4,CUnix.remove_path_dot n::ml,mllib,mlpack),o,s),i,d) - | MLI n :: r -> - let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in - ((v,(CUnix.remove_path_dot n::mli,ml4,ml,mllib,mlpack),o,s),i,d) - | ML4 n :: r -> - let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in - ((v,(mli,CUnix.remove_path_dot n::ml4,ml,mllib,mlpack),o,s),i,d) - | MLLIB n :: r -> - let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in - ((v,(mli,ml4,ml,CUnix.remove_path_dot n::mllib,mlpack),o,s),i,d) - | MLPACK n :: r -> - let (v,(mli,ml4,ml,mllib,mlpack),o,s),i,d = aux r in - ((v,(mli,ml4,ml,mllib,CUnix.remove_path_dot n::mlpack),o,s),i,d) - | Special (n,dep,is_phony,c) :: r -> - let (v,m,o,s),i,d = aux r in ((v,m,(n,dep,is_phony,c)::o,s),i,d) - | Subdir n :: r -> - let (v,m,o,s),i,d = aux r in ((v,m,o,n::s),i,d) - | MLInclude p :: r -> - let t,(ml,q,r),d = aux r in (t,((CUnix.remove_path_dot (post_canonize p), - CUnix.canonical_path_name p)::ml,q,r),d) - | Include (p,l) :: r -> - let t,(ml,i,r),d = aux r in - let i_new = (CUnix.remove_path_dot (post_canonize p),l, - CUnix.canonical_path_name p) in - (t,(ml,i_new::i,r),d) - | RInclude (p,l) :: r -> - let t,(ml,i,r),d = aux r in - let r_new = (CUnix.remove_path_dot (post_canonize p),l, - CUnix.canonical_path_name p) in - (t,(ml,i,r_new::r),d) - | Def (v,def) :: r -> - let t,i,(args,defs) = aux r in (t,i,(args,(v,def)::defs)) - | Arg a :: r -> - let t,i,(args,defs) = aux r in (t,i,(a::args,defs)) - | [] -> ([],([],[],[],[],[]),[],[]),([],[],[]),([],[]) - in aux +let split_arguments args = + List.fold_right + (fun a ((v,(mli,ml4,ml,mllib,mlpack as m),o,s as t), + (ml_inc,q_inc,r_inc as i),(args,defs as d)) -> + match a with + | V n -> + ((CUnix.remove_path_dot n::v,m,o,s),i,d) + | ML n -> + ((v,(mli,ml4,CUnix.remove_path_dot n::ml,mllib,mlpack),o,s),i,d) + | MLI n -> + ((v,(CUnix.remove_path_dot n::mli,ml4,ml,mllib,mlpack),o,s),i,d) + | ML4 n -> + ((v,(mli,CUnix.remove_path_dot n::ml4,ml,mllib,mlpack),o,s),i,d) + | MLLIB n -> + ((v,(mli,ml4,ml,CUnix.remove_path_dot n::mllib,mlpack),o,s),i,d) + | MLPACK n -> + ((v,(mli,ml4,ml,mllib,CUnix.remove_path_dot n::mlpack),o,s),i,d) + | Special (n,dep,is_phony,c) -> + ((v,m,(n,dep,is_phony,c)::o,s),i,d) + | Subdir n -> + ((v,m,o,n::s),i,d) + | MLInclude p -> + let ml_new = (CUnix.remove_path_dot (post_canonize p), + CUnix.canonical_path_name p) in + (t,(ml_new::ml_inc,q_inc,r_inc),d) + | Include (p,l) -> + let q_new = (CUnix.remove_path_dot (post_canonize p),l, + CUnix.canonical_path_name p) in + (t,(ml_inc,q_new::q_inc,r_inc),d) + | RInclude (p,l) -> + let r_new = (CUnix.remove_path_dot (post_canonize p),l, + CUnix.canonical_path_name p) in + (t,(ml_inc,q_inc,r_new::r_inc),d) + | Def (v,def) -> + (t,i,(args,(v,def)::defs)) + | Arg a -> + (t,i,(a::args,defs))) + args (([],([],[],[],[],[]),[],[]),([],[],[]),([],[])) let read_project_file f = split_arguments diff --git a/ide/sentence.ml b/ide/sentence.ml index dd6b10a46..6897779e8 100644 --- a/ide/sentence.ml +++ b/ide/sentence.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -63,13 +63,13 @@ let grab_sentence_start (iter:GText.iter) soi = (** Search forward the first character immediately after a sentence end *) -let rec grab_sentence_stop (start:GText.iter) = +let grab_sentence_stop (start:GText.iter) = (forward_search is_sentence_end start)#forward_char (** Search forward the first character immediately after a "." sentence end (and not just a "\{" or "\}" or comment end *) -let rec grab_ending_dot (start:GText.iter) = +let grab_ending_dot (start:GText.iter) = let is_ending_dot s = is_sentence_end s && s#char = Char.code '.' in (forward_search is_ending_dot start)#forward_char diff --git a/ide/sentence.mli b/ide/sentence.mli index f0ba5d22c..feb3c0ac0 100644 --- a/ide/sentence.mli +++ b/ide/sentence.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/session.ml b/ide/session.ml index e4cc17742..cdec392ec 100644 --- a/ide/session.ml +++ b/ide/session.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -16,6 +16,7 @@ class type ['a] page = inherit GObj.widget method update : 'a -> unit method on_update : callback:('a -> unit) -> unit + method data : 'a end class type control = @@ -316,6 +317,7 @@ let create_errpage (script : Wg_ScriptView.script_view) : errpage = errs end method on_update ~callback:cb = callback := cb + method data = !last_update end let create_jobpage coqtop coqops : jobpage = @@ -355,6 +357,7 @@ let create_jobpage coqtop coqops : jobpage = jobs end method on_update ~callback:cb = callback := cb + method data = !last_update end let create_proof () = diff --git a/ide/session.mli b/ide/session.mli index 3a6b45858..028a1f9de 100644 --- a/ide/session.mli +++ b/ide/session.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -14,6 +14,7 @@ class type ['a] page = inherit GObj.widget method update : 'a -> unit method on_update : callback:('a -> unit) -> unit + method data : 'a end class type control = diff --git a/ide/tags.ml b/ide/tags.ml index 09b562530..9ccff9fb5 100644 --- a/ide/tags.ml +++ b/ide/tags.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/tags.mli b/ide/tags.mli index 6418d1b2e..5a932f330 100644 --- a/ide/tags.mli +++ b/ide/tags.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/utf8_convert.mll b/ide/utf8_convert.mll index 4ebf9a62e..5cc8cbc0d 100644 --- a/ide/utf8_convert.mll +++ b/ide/utf8_convert.mll @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/wg_Command.ml b/ide/wg_Command.ml index 7d8993aa8..946aaf010 100644 --- a/ide/wg_Command.ml +++ b/ide/wg_Command.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/wg_Command.mli b/ide/wg_Command.mli index 1f0e31988..fa50ba5fd 100644 --- a/ide/wg_Command.mli +++ b/ide/wg_Command.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/wg_Completion.ml b/ide/wg_Completion.ml index 7d77679ce..6c53fc013 100644 --- a/ide/wg_Completion.ml +++ b/ide/wg_Completion.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/wg_Completion.mli b/ide/wg_Completion.mli index c3cb230d7..dd496aa5f 100644 --- a/ide/wg_Completion.mli +++ b/ide/wg_Completion.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/wg_Detachable.ml b/ide/wg_Detachable.ml index 53c634d7e..3d1b63dfa 100644 --- a/ide/wg_Detachable.ml +++ b/ide/wg_Detachable.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/wg_Detachable.mli b/ide/wg_Detachable.mli index 71f85ad82..a7e8f4676 100644 --- a/ide/wg_Detachable.mli +++ b/ide/wg_Detachable.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/wg_Find.ml b/ide/wg_Find.ml index a0949ca0c..3d847ddcc 100644 --- a/ide/wg_Find.ml +++ b/ide/wg_Find.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -type mode = [ `FIND | `REPLACE ] - let b2c = Ideutils.byte_offset_to_char_offset class finder name (view : GText.view) = diff --git a/ide/wg_Find.mli b/ide/wg_Find.mli index 7811fc43e..1ef1c4d49 100644 --- a/ide/wg_Find.mli +++ b/ide/wg_Find.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/wg_MessageView.ml b/ide/wg_MessageView.ml index 615e989de..7728ad236 100644 --- a/ide/wg_MessageView.ml +++ b/ide/wg_MessageView.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/wg_MessageView.mli b/ide/wg_MessageView.mli index 388ab259f..2d34533de 100644 --- a/ide/wg_MessageView.mli +++ b/ide/wg_MessageView.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/wg_Notebook.ml b/ide/wg_Notebook.ml index 0611c3f39..08d7d1983 100644 --- a/ide/wg_Notebook.ml +++ b/ide/wg_Notebook.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/wg_Notebook.mli b/ide/wg_Notebook.mli index 15a2ba41e..34eb1d11e 100644 --- a/ide/wg_Notebook.mli +++ b/ide/wg_Notebook.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/wg_ProofView.ml b/ide/wg_ProofView.ml index 148add6e9..4d95fdd0d 100644 --- a/ide/wg_ProofView.ml +++ b/ide/wg_ProofView.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -114,19 +114,6 @@ let mode_tactic sel_cb (proof : #GText.view_skel) goals hints = match goals with (Some Tags.Proof.goal))); ignore(proof#scroll_to_mark ~use_align:true ~yalign:0.95 `INSERT) -let mode_cesar (proof : #GText.view_skel) = function - | [] -> assert false - | { Interface.goal_hyp = hyps; Interface.goal_ccl = cur_goal; } :: _ -> - proof#buffer#insert " *** Declarative Mode ***\n"; - List.iter - (fun hyp -> insert_xml proof#buffer hyp; proof#buffer#insert "\n") - hyps; - proof#buffer#insert "______________________________________\n"; - proof#buffer#insert "thesis := \n "; - insert_xml proof#buffer cur_goal; - proof#buffer#insert "\n"; - ignore (proof#scroll_to_iter (proof#buffer#get_iter_at_mark `INSERT)) - let rec flatten = function | [] -> [] | (lg, rg) :: l -> diff --git a/ide/wg_ProofView.mli b/ide/wg_ProofView.mli index c5e042ea5..b6eae48b3 100644 --- a/ide/wg_ProofView.mli +++ b/ide/wg_ProofView.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/wg_ScriptView.ml b/ide/wg_ScriptView.ml index b672e016b..83fbda487 100644 --- a/ide/wg_ScriptView.ml +++ b/ide/wg_ScriptView.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/wg_ScriptView.mli b/ide/wg_ScriptView.mli index 6e54c4452..6cce5e5b4 100644 --- a/ide/wg_ScriptView.mli +++ b/ide/wg_ScriptView.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/wg_Segment.ml b/ide/wg_Segment.ml index 2ee288454..c2799e40b 100644 --- a/ide/wg_Segment.ml +++ b/ide/wg_Segment.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -11,53 +11,13 @@ open Preferences type color = GDraw.color -module Segment : -sig - type +'a t - val length : 'a t -> int - val resize : 'a t -> int -> 'a t - val empty : 'a t - val add : int -> 'a -> 'a t -> 'a t - val remove : int -> 'a t -> 'a t - val fold : ('a -> 'a -> bool) -> (int -> int -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b -end = -struct - type 'a t = { - length : int; - content : 'a Int.Map.t; - } - - let empty = { length = 0; content = Int.Map.empty } - - let length s = s.length - - let resize s len = - if s.length <= len then { s with length = len } - else - let filter i v = i < len in - { length = len; content = Int.Map.filter filter s.content } - - let add i v s = - if i < s.length then - { s with content = Int.Map.add i v s.content } - else s - - let remove i s = { s with content = Int.Map.remove i s.content } - - let fold eq f s accu = - let make k v (cur, accu) = match cur with - | None -> Some (k, k, v), accu - | Some (i, j, w) -> - if k = j + 1 && eq v w then Some (i, k, w), accu - else Some (k, k, v), (i, j, w) :: accu - in - let p, segments = Int.Map.fold make s.content (None, []) in - let segments = match p with - | None -> segments - | Some p -> p :: segments - in - List.fold_left (fun accu (i, j, v) -> f i j v accu) accu segments +type model_event = [ `INSERT | `REMOVE | `SET of int * color ] +class type model = +object + method changed : callback:(model_event -> unit) -> unit + method length : int + method fold : 'a. ('a -> color -> 'a) -> 'a -> 'a end let i2f = float_of_int @@ -96,7 +56,7 @@ object (self) val mutable width = 1 val mutable height = 20 - val mutable data = Segment.empty + val mutable model : model option = None val mutable default : color = `WHITE val mutable pixmap : GDraw.pixmap = GDraw.pixmap ~width:1 ~height:1 () val clicked = new GUtil.signal () @@ -114,10 +74,12 @@ object (self) end in let _ = box#misc#connect#size_allocate cb in - let clicked_cb ev = + let clicked_cb ev = match model with + | None -> true + | Some md -> let x = GdkEvent.Button.x ev in let (width, _) = pixmap#size in - let len = Segment.length data in + let len = md#length in let idx = f2i ((x *. i2f len) /. i2f width) in let () = clicked#call idx in true @@ -128,17 +90,23 @@ object (self) (** Initial pixmap *) draw#set_pixmap pixmap - method length = Segment.length data - - method set_length len = - data <- Segment.resize data len; - if self#misc#visible then self#refresh () + method set_model md = + model <- Some md; + let changed_cb = function + | `INSERT | `REMOVE -> + if self#misc#visible then self#refresh () + | `SET (i, color) -> + if self#misc#visible then self#fill_range color i (i + 1) + in + md#changed changed_cb - method private fill_range color i j = + method private fill_range color i j = match model with + | None -> () + | Some md -> let i = i2f i in let j = i2f j in let width = i2f width in - let len = i2f (Segment.length data) in + let len = i2f md#length in let x = f2i ((i *. width) /. len) in let x' = f2i ((j *. width) /. len) in let w = x' - x in @@ -146,14 +114,6 @@ object (self) pixmap#rectangle ~x ~y:0 ~width:w ~height ~filled:true (); draw#set_mask None; - method add i color = - data <- Segment.add i color data; - if self#misc#visible then self#fill_range color i (i + 1) - - method remove i = - data <- Segment.remove i data; - if self#misc#visible then self#fill_range default i (i + 1) - method set_default_color color = default <- color method default_color = default @@ -162,11 +122,23 @@ object (self) draw#set_pixmap pixmap; self#refresh (); - method private refresh () = + method private refresh () = match model with + | None -> () + | Some md -> pixmap#set_foreground default; pixmap#rectangle ~x:0 ~y:0 ~width ~height ~filled:true (); - let fold i j v () = self#fill_range v i (j + 1) in - Segment.fold color_eq fold data (); + let make (k, cur, accu) v = match cur with + | None -> pred k, Some (k, k, v), accu + | Some (i, j, w) -> + if k = j - 1 && color_eq v w then pred k, Some (k, i, w), accu + else pred k, Some (k, k, v), (i, j, w) :: accu + in + let _, p, segments = md#fold make (md#length - 1, None, []) in + let segments = match p with + | None -> segments + | Some p -> p :: segments + in + List.iter (fun (i, j, v) -> self#fill_range v i (j + 1)) segments; draw#set_mask None; method connect = diff --git a/ide/wg_Segment.mli b/ide/wg_Segment.mli index 0263856ae..29cbbedac 100644 --- a/ide/wg_Segment.mli +++ b/ide/wg_Segment.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,6 +8,8 @@ type color = GDraw.color +type model_event = [ `INSERT | `REMOVE | `SET of int * color ] + class type segment_signals = object inherit GObj.misc_signals @@ -15,15 +17,19 @@ object method clicked : callback:(int -> unit) -> GtkSignal.id end +class type model = +object + method changed : callback:(model_event -> unit) -> unit + method length : int + method fold : 'a. ('a -> color -> 'a) -> 'a -> 'a +end + class segment : unit -> object inherit GObj.widget val obj : Gtk.widget Gtk.obj + method set_model : model -> unit method connect : segment_signals - method length : int - method set_length : int -> unit method default_color : color method set_default_color : color -> unit - method add : int -> color -> unit - method remove : int -> unit end diff --git a/ide/xmlprotocol.ml b/ide/xmlprotocol.ml index bb6a18158..232630e5b 100644 --- a/ide/xmlprotocol.ml +++ b/ide/xmlprotocol.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ide/xmlprotocol.mli b/ide/xmlprotocol.mli index 7806550d1..265a50c47 100644 --- a/ide/xmlprotocol.mli +++ b/ide/xmlprotocol.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/interp/constrarg.ml b/interp/constrarg.ml index a7241399e..46be0b8a1 100644 --- a/interp/constrarg.ml +++ b/interp/constrarg.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -19,56 +19,57 @@ let loc_of_or_by_notation f = function | AN c -> f c | ByNotation (loc,s,_) -> loc -let unsafe_of_type (t : argument_type) : ('a, 'b, 'c) Genarg.genarg_type = - Obj.magic t - -let wit_int_or_var = unsafe_of_type IntOrVarArgType +let wit_int_or_var = + Genarg.make0 ~dyn:(val_tag (topwit Stdarg.wit_int)) "int_or_var" let wit_intro_pattern : (Constrexpr.constr_expr intro_pattern_expr located, glob_constr_and_expr intro_pattern_expr located, intro_pattern) genarg_type = - Genarg.make0 None "intropattern" + Genarg.make0 "intropattern" -let wit_tactic : (raw_tactic_expr, glob_tactic_expr, glob_tactic_expr) genarg_type = - Genarg.make0 None "tactic" +let wit_tactic : (raw_tactic_expr, glob_tactic_expr, Val.t) genarg_type = + Genarg.make0 "tactic" -let wit_ident = unsafe_of_type IdentArgType +let wit_ltac = Genarg.make0 ~dyn:(val_tag (topwit Stdarg.wit_unit)) "ltac" -let wit_var = unsafe_of_type VarArgType +let wit_ident = + Genarg.make0 "ident" -let wit_ref = Genarg.make0 None "ref" +let wit_var = + Genarg.make0 ~dyn:(val_tag (topwit wit_ident)) "var" -let wit_quant_hyp = unsafe_of_type QuantHypArgType +let wit_ref = Genarg.make0 "ref" -let wit_genarg = unsafe_of_type GenArgType +let wit_quant_hyp = Genarg.make0 "quant_hyp" let wit_sort : (glob_sort, glob_sort, sorts) genarg_type = - Genarg.make0 None "sort" + Genarg.make0 "sort" -let wit_constr = unsafe_of_type ConstrArgType +let wit_constr = + Genarg.make0 "constr" -let wit_constr_may_eval = unsafe_of_type ConstrMayEvalArgType +let wit_constr_may_eval = + Genarg.make0 ~dyn:(val_tag (topwit wit_constr)) "constr_may_eval" -let wit_uconstr = Genarg.make0 None "uconstr" +let wit_uconstr = Genarg.make0 "uconstr" -let wit_open_constr = unsafe_of_type OpenConstrArgType +let wit_open_constr = Genarg.make0 ~dyn:(val_tag (topwit wit_constr)) "open_constr" -let wit_constr_with_bindings = unsafe_of_type ConstrWithBindingsArgType +let wit_constr_with_bindings = Genarg.make0 "constr_with_bindings" -let wit_bindings = unsafe_of_type BindingsArgType +let wit_bindings = Genarg.make0 "bindings" let wit_hyp_location_flag : 'a Genarg.uniform_genarg_type = - Genarg.make0 None "hyp_location_flag" + Genarg.make0 "hyp_location_flag" -let wit_red_expr = unsafe_of_type RedExprArgType +let wit_red_expr = Genarg.make0 "redexpr" let wit_clause_dft_concl = - Genarg.make0 None "clause_dft_concl" + Genarg.make0 "clause_dft_concl" -(** Register location *) +(** Aliases *) -let () = - register_name0 wit_ref "Constrarg.wit_ref"; - register_name0 wit_intro_pattern "Constrarg.wit_intro_pattern"; - register_name0 wit_tactic "Constrarg.wit_tactic"; - register_name0 wit_sort "Constrarg.wit_sort"; - register_name0 wit_uconstr "Constrarg.wit_uconstr"; - register_name0 wit_clause_dft_concl "Constrarg.wit_clause_dft_concl"; +let wit_reference = wit_ref +let wit_global = wit_ref +let wit_clause = wit_clause_dft_concl +let wit_quantified_hypothesis = wit_quant_hyp +let wit_intropattern = wit_intro_pattern +let wit_redexpr = wit_red_expr diff --git a/interp/constrarg.mli b/interp/constrarg.mli index fdeddd66a..d38b1183c 100644 --- a/interp/constrarg.mli +++ b/interp/constrarg.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -26,7 +26,7 @@ val loc_of_or_by_notation : ('a -> Loc.t) -> 'a or_by_notation -> Loc.t (** {5 Additional generic arguments} *) -val wit_int_or_var : int or_var uniform_genarg_type +val wit_int_or_var : (int or_var, int or_var, int) genarg_type val wit_intro_pattern : (constr_expr intro_pattern_expr located, glob_constr_and_expr intro_pattern_expr located, intro_pattern) genarg_type @@ -38,8 +38,6 @@ val wit_ref : (reference, global_reference located or_var, global_reference) gen val wit_quant_hyp : quantified_hypothesis uniform_genarg_type -val wit_genarg : (raw_generic_argument, glob_generic_argument, typed_generic_argument) genarg_type - val wit_sort : (glob_sort, glob_sort, sorts) genarg_type val wit_constr : (constr_expr, glob_constr_and_expr, constr) genarg_type @@ -52,17 +50,17 @@ val wit_constr_may_eval : val wit_uconstr : (constr_expr , glob_constr_and_expr, Glob_term.closed_glob_constr) genarg_type val wit_open_constr : - (open_constr_expr, open_glob_constr, Evd.open_constr) genarg_type + (constr_expr, glob_constr_and_expr, constr) genarg_type val wit_constr_with_bindings : (constr_expr with_bindings, glob_constr_and_expr with_bindings, - constr with_bindings Evd.sigma) genarg_type + constr with_bindings delayed_open) genarg_type val wit_bindings : (constr_expr bindings, glob_constr_and_expr bindings, - constr bindings Evd.sigma) genarg_type + constr bindings delayed_open) genarg_type val wit_hyp_location_flag : Locus.hyp_location_flag uniform_genarg_type @@ -71,6 +69,23 @@ val wit_red_expr : (glob_constr_and_expr,evaluable_global_reference and_short_name or_var,glob_constr_pattern_and_expr) red_expr_gen, (constr,evaluable_global_reference,constr_pattern) red_expr_gen) genarg_type -val wit_tactic : (raw_tactic_expr, glob_tactic_expr, glob_tactic_expr) genarg_type +val wit_tactic : (raw_tactic_expr, glob_tactic_expr, Val.t) genarg_type + +(** [wit_ltac] is subtly different from [wit_tactic]: they only change for their + toplevel interpretation. The one of [wit_ltac] forces the tactic and + discards the result. *) +val wit_ltac : (raw_tactic_expr, glob_tactic_expr, unit) genarg_type val wit_clause_dft_concl : (Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Locus.clause_expr) genarg_type + +(** Aliases for compatibility *) + +val wit_reference : (reference, global_reference located or_var, global_reference) genarg_type +val wit_global : (reference, global_reference located or_var, global_reference) genarg_type +val wit_clause : (Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Loc.located Locus.clause_expr,Names.Id.t Locus.clause_expr) genarg_type +val wit_quantified_hypothesis : quantified_hypothesis uniform_genarg_type +val wit_intropattern : (constr_expr intro_pattern_expr located, glob_constr_and_expr intro_pattern_expr located, intro_pattern) genarg_type +val wit_redexpr : + ((constr_expr,reference or_by_notation,constr_expr) red_expr_gen, + (glob_constr_and_expr,evaluable_global_reference and_short_name or_var,glob_constr_pattern_and_expr) red_expr_gen, + (constr,evaluable_global_reference,constr_pattern) red_expr_gen) genarg_type diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index 2d48ea4d0..c5730e626 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -66,7 +66,7 @@ let rec cases_pattern_expr_eq p1 p2 = Id.equal i1 i2 && cases_pattern_expr_eq a1 a2 | CPatCstr(_,c1,a1,b1), CPatCstr(_,c2,a2,b2) -> eq_reference c1 c2 && - List.equal cases_pattern_expr_eq a1 a2 && + Option.equal (List.equal cases_pattern_expr_eq) a1 a2 && List.equal cases_pattern_expr_eq b1 b2 | CPatAtom(_,r1), CPatAtom(_,r2) -> Option.equal eq_reference r1 r2 @@ -125,11 +125,10 @@ let rec constr_expr_eq e1 e2 = Option.equal Int.equal proj1 proj2 && constr_expr_eq e1 e2 && List.equal args_eq al1 al2 - | CRecord (_, e1, l1), CRecord (_, e2, l2) -> + | CRecord (_, l1), CRecord (_, l2) -> let field_eq (r1, e1) (r2, e2) = eq_reference r1 r2 && constr_expr_eq e1 e2 in - Option.equal constr_expr_eq e1 e2 && List.equal field_eq l1 l2 | CCases(_,_,r1,a1,brl1), CCases(_,_,r2,a2,brl2) -> (** Don't care about the case_style *) @@ -178,7 +177,7 @@ and args_eq (a1,e1) (a2,e2) = Option.equal (eq_located explicitation_eq) e1 e2 && constr_expr_eq a1 a2 -and case_expr_eq (e1, (n1, p1)) (e2, (n2, p2)) = +and case_expr_eq (e1, n1, p1) (e2, n2, p2) = constr_expr_eq e1 e2 && Option.equal (eq_located Name.equal) n1 n2 && Option.equal cases_pattern_expr_eq p1 p2 @@ -238,7 +237,7 @@ let constr_loc = function | CLetIn (loc,_,_,_) -> loc | CAppExpl (loc,_,_) -> loc | CApp (loc,_,_) -> loc - | CRecord (loc,_,_) -> loc + | CRecord (loc,_) -> loc | CCases (loc,_,_,_,_) -> loc | CLetTuple (loc,_,_,_,_) -> loc | CIf (loc,_,_,_,_) -> loc diff --git a/interp/constrexpr_ops.mli b/interp/constrexpr_ops.mli index 10c84b8dd..3f5be4855 100644 --- a/interp/constrexpr_ops.mli +++ b/interp/constrexpr_ops.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/interp/constrextern.ml b/interp/constrextern.ml index f57772ecb..49892bec4 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -29,6 +29,8 @@ open Notation open Detyping open Misctypes open Decl_kinds + +module NamedDecl = Context.Named.Declaration (*i*) (* Translation from glob_constr to front constr *) @@ -147,8 +149,17 @@ let extern_evar loc n l = CEvar (loc,n,l) For instance, in the debugger the tables of global references may be inaccurate *) +let safe_shortest_qualid_of_global vars r = + try shortest_qualid_of_global vars r + with Not_found -> + match r with + | VarRef v -> make_qualid DirPath.empty v + | ConstRef c -> make_qualid DirPath.empty Names.(Label.to_id (con_label c)) + | IndRef (i,_) | ConstructRef ((i,_),_) -> + make_qualid DirPath.empty Names.(Label.to_id (mind_label i)) + let default_extern_reference loc vars r = - Qualid (loc,shortest_qualid_of_global vars r) + Qualid (loc,safe_shortest_qualid_of_global vars r) let my_extern_reference = ref default_extern_reference @@ -255,7 +266,7 @@ let make_pat_notation loc ntn (terms,termlists as subst) args = let mkPat loc qid l = (* Normally irrelevant test with v8 syntax, but let's do it anyway *) - if List.is_empty l then CPatAtom (loc,Some qid) else CPatCstr (loc,qid,[],l) + if List.is_empty l then CPatAtom (loc,Some qid) else CPatCstr (loc,qid,None,l) let pattern_printable_in_both_syntax (ind,_ as c) = let impl_st = extract_impargs_data (implicits_of_global (ConstructRef c)) in @@ -275,7 +286,7 @@ let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat = when !Flags.in_debugger||Inductiveops.constructor_has_local_defs cstrsp -> let c = extern_reference loc Id.Set.empty (ConstructRef cstrsp) in let args = List.map (extern_cases_pattern_in_scope scopes vars) args in - CPatCstr (loc, c, add_patt_for_params (fst cstrsp) args, []) + CPatCstr (loc, c, Some (add_patt_for_params (fst cstrsp) args), []) | _ -> try if !Flags.raw_print || !print_no_symbol then raise No_match; @@ -316,15 +327,15 @@ let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat = with Not_found | No_match | Exit -> let c = extern_reference loc Id.Set.empty (ConstructRef cstrsp) in - if !Topconstr.oldfashion_patterns then + if !Topconstr.asymmetric_patterns then if pattern_printable_in_both_syntax cstrsp - then CPatCstr (loc, c, [], args) - else CPatCstr (loc, c, add_patt_for_params (fst cstrsp) args, []) + then CPatCstr (loc, c, None, args) + else CPatCstr (loc, c, Some (add_patt_for_params (fst cstrsp) args), []) else let full_args = add_patt_for_params (fst cstrsp) args in match drop_implicits_in_patt (ConstructRef cstrsp) 0 full_args with - |Some true_args -> CPatCstr (loc, c, [], true_args) - |None -> CPatCstr (loc, c, full_args, []) + |Some true_args -> CPatCstr (loc, c, None, true_args) + |None -> CPatCstr (loc, c, Some full_args, []) in insert_pat_alias loc p na and apply_notation_to_pattern loc gr ((subst,substlist),(nb_to_drop,more_args)) (tmp_scope, scopes as allscopes) vars = @@ -347,7 +358,7 @@ and apply_notation_to_pattern loc gr ((subst,substlist),(nb_to_drop,more_args)) List.map (extern_cases_pattern_in_scope subscope vars) c) substlist in let l2 = List.map (extern_cases_pattern_in_scope allscopes vars) more_args in - let l2' = if !Topconstr.oldfashion_patterns || not (List.is_empty ll) then l2 + let l2' = if !Topconstr.asymmetric_patterns || not (List.is_empty ll) then l2 else match drop_implicits_in_patt gr nb_to_drop l2 with |Some true_args -> true_args @@ -363,7 +374,7 @@ and apply_notation_to_pattern loc gr ((subst,substlist),(nb_to_drop,more_args)) extern_cases_pattern_in_scope (scopt,scl@scopes) vars c) subst in let l2 = List.map (extern_cases_pattern_in_scope allscopes vars) more_args in - let l2' = if !Topconstr.oldfashion_patterns then l2 + let l2' = if !Topconstr.asymmetric_patterns then l2 else match drop_implicits_in_patt gr (nb_to_drop + List.length l1) l2 with |Some true_args -> true_args @@ -402,7 +413,7 @@ let extern_ind_pattern_in_scope (scopes:local_scopes) vars ind args = if !Flags.in_debugger||Inductiveops.inductive_has_local_defs ind then let c = extern_reference Loc.ghost vars (IndRef ind) in let args = List.map (extern_cases_pattern_in_scope scopes vars) args in - CPatCstr (Loc.ghost, c, add_patt_for_params ind args, []) + CPatCstr (Loc.ghost, c, Some (add_patt_for_params ind args), []) else try if !Flags.raw_print || !print_no_symbol then raise No_match; @@ -420,8 +431,8 @@ let extern_ind_pattern_in_scope (scopes:local_scopes) vars ind args = let c = extern_reference Loc.ghost vars (IndRef ind) in let args = List.map (extern_cases_pattern_in_scope scopes vars) args in match drop_implicits_in_patt (IndRef ind) 0 args with - |Some true_args -> CPatCstr (Loc.ghost, c, [], true_args) - |None -> CPatCstr (Loc.ghost, c, args, []) + |Some true_args -> CPatCstr (Loc.ghost, c, None, true_args) + |None -> CPatCstr (Loc.ghost, c, Some args, []) let extern_cases_pattern vars p = extern_cases_pattern_in_scope (None,[]) vars p @@ -438,8 +449,8 @@ let is_projection nargs = function | Some r when not !Flags.in_debugger && not !Flags.raw_print && !print_projections -> (try let n = Recordops.find_projection_nparams r + 1 in - if n <= nargs then None - else Some n + if n <= nargs then Some n + else None with Not_found -> None) | _ -> None @@ -453,15 +464,6 @@ let is_needed_for_correct_partial_application tail imp = exception Expl -let params_implicit n impl = - let rec aux n impl = - if n == 0 then true - else match impl with - | [] -> false - | imp :: impl when is_status_implicit imp -> aux (pred n) impl - | _ -> false - in aux n impl - (* Implicit args indexes are in ascending order *) (* inctx is useful only if there is a last argument to be deduced from ctxt *) let explicitize loc inctx impl (cf,f) args = @@ -680,7 +682,7 @@ let rec extern inctx scopes vars r = | head :: tail -> ip q locs' tail ((extern_reference loc Id.Set.empty (ConstRef c), head) :: acc) in - CRecord (loc, None, List.rev (ip projs locals args [])) + CRecord (loc, List.rev (ip projs locals args [])) with | Not_found | No_match | Exit -> extern_app loc inctx @@ -712,26 +714,29 @@ let rec extern inctx scopes vars r = (cases_predicate_names tml) vars in let rtntypopt' = Option.map (extern_typ scopes vars') rtntypopt in let tml = List.map (fun (tm,(na,x)) -> - let na' = match na,tm with - | Anonymous, GVar (_, id) -> - begin match rtntypopt with - | None -> None - | Some ntn -> - if occur_glob_constr id ntn then - Some (Loc.ghost, Anonymous) - else None - end - | Anonymous, _ -> None - | Name id, GVar (_,id') when Id.equal id id' -> None - | Name _, _ -> Some (Loc.ghost,na) in - (sub_extern false scopes vars tm, - (na',Option.map (fun (loc,ind,nal) -> - let args = List.map (fun x -> PatVar (Loc.ghost, x)) nal in - let fullargs = - if !Flags.in_debugger then args else - Notation_ops.add_patterns_for_params ind args in - extern_ind_pattern_in_scope scopes vars ind fullargs - ) x))) tml in + let na' = match na,tm with + | Anonymous, GVar (_, id) -> + begin match rtntypopt with + | None -> None + | Some ntn -> + if occur_glob_constr id ntn then + Some (Loc.ghost, Anonymous) + else None + end + | Anonymous, _ -> None + | Name id, GVar (_,id') when Id.equal id id' -> None + | Name _, _ -> Some (Loc.ghost,na) in + (sub_extern false scopes vars tm, + na', + Option.map (fun (loc,ind,nal) -> + let args = List.map (fun x -> PatVar (Loc.ghost, x)) nal in + let fullargs = + if !Flags.in_debugger then args else + Notation_ops.add_patterns_for_params ind args in + extern_ind_pattern_in_scope scopes vars ind fullargs + ) x)) + tml + in let eqns = List.map (extern_eqn inctx scopes vars) eqns in CCases (loc,sty,rtntypopt',tml,eqns) @@ -977,9 +982,12 @@ let rec glob_of_pat env sigma = function | PRef ref -> GRef (loc,ref,None) | PVar id -> GVar (loc,id) | PEvar (evk,l) -> - let test (id,_,_) = function PVar id' -> Id.equal id id' | _ -> false in + let test decl = function PVar id' -> Id.equal (NamedDecl.get_id decl) id' | _ -> false in let l = Evd.evar_instance_array test (Evd.find sigma evk) l in - let id = Evd.evar_ident evk sigma in + let id = match Evd.evar_ident evk sigma with + | None -> Id.of_string "__" + | Some id -> id + in GEvar (loc,id,List.map (on_snd (glob_of_pat env sigma)) l) | PRel n -> let id = try match lookup_name_of_rel n env with diff --git a/interp/constrextern.mli b/interp/constrextern.mli index b797e455c..f617faa38 100644 --- a/interp/constrextern.mli +++ b/interp/constrextern.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,7 +8,6 @@ open Names open Term -open Context open Termops open Environ open Libnames @@ -42,7 +41,7 @@ val extern_reference : Loc.t -> Id.Set.t -> global_reference -> reference val extern_type : bool -> env -> Evd.evar_map -> types -> constr_expr val extern_sort : Evd.evar_map -> sorts -> glob_sort val extern_rel_context : constr option -> env -> Evd.evar_map -> - rel_context -> local_binder list + Context.Rel.t -> local_binder list (** Printing options *) val print_implicits : bool ref diff --git a/interp/constrintern.ml b/interp/constrintern.ml index c754f1910..fa3869570 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -29,6 +29,7 @@ open Nametab open Notation open Inductiveops open Decl_kinds +open Context.Rel.Declaration (** constr_expr -> glob_constr translation: - it adds holes for implicit arguments @@ -101,7 +102,7 @@ let global_reference id = let construct_reference ctx id = try - Term.mkVar (let _ = Context.lookup_named id ctx in id) + Term.mkVar (let _ = Context.Named.lookup id ctx in id) with Not_found -> global_reference id @@ -274,7 +275,8 @@ let error_expect_binder_notation_type loc id = let set_var_scope loc id istermvar env ntnvars = try - let idscopes,typ = Id.Map.find id ntnvars in + let isonlybinding,idscopes,typ = Id.Map.find id ntnvars in + if istermvar then isonlybinding := false; let () = if istermvar then (* scopes have no effect on the interpretation of identifiers *) begin match !idscopes with @@ -317,7 +319,7 @@ let rec it_mkGLambda loc2 env body = let build_impls = function |Implicit -> (function |Name id -> Some (id, Impargs.Manual, (true,true)) - |Anonymous -> anomaly (Pp.str "Anonymous implicit argument")) + |Anonymous -> Some (Id.of_string "_", Impargs.Manual, (true,true))) |Explicit -> fun _ -> None let impls_type_list ?(args = []) = @@ -628,7 +630,7 @@ let subst_aconstr_in_glob_constr loc intern (_,ntnvars as lvar) subst infos c = let split_by_type ids = List.fold_right (fun (x,(scl,typ)) (l1,l2,l3) -> match typ with - | NtnTypeConstr -> ((x,scl)::l1,l2,l3) + | NtnTypeConstr | NtnTypeOnlyBinder -> ((x,scl)::l1,l2,l3) | NtnTypeConstrList -> (l1,(x,scl)::l2,l3) | NtnTypeBinderList -> (l1,l2,(x,scl)::l3)) ids ([],[],[]) @@ -685,7 +687,7 @@ let intern_var genv (ltacvars,ntnvars) namedctx loc id = str "variable " ++ pr_id id ++ str " should be bound to a term.") else (* Is [id] a goal or section variable *) - let _ = Context.lookup_named id namedctx in + let _ = Context.Named.lookup id namedctx in try (* [id] a section variable *) (* Redundant: could be done in intern_qualid *) @@ -698,19 +700,6 @@ let intern_var genv (ltacvars,ntnvars) namedctx loc id = (* [id] a goal variable *) GVar (loc,id), [], [], [] -let proj_impls r impls = - let env = Global.env () in - let f (x, l) = x, projection_implicits env r l in - List.map f impls - -let proj_scopes n scopes = - List.skipn_at_least n scopes - -let proj_impls_scopes p impls scopes = - match p with - | Some (r, n) -> proj_impls r impls, proj_scopes n scopes - | None -> impls, scopes - let find_appl_head_data c = match c with | GRef (loc,ref,_) as x -> @@ -929,7 +918,7 @@ let chop_params_pattern loc ind args with_letin = args let find_constructor loc add_params ref = - let cstr = match ref with + let (ind,_ as cstr) = match ref with | ConstructRef cstr -> cstr | IndRef _ -> let error = str "There is an inductive name deep in a \"in\" clause." in @@ -938,15 +927,15 @@ let find_constructor loc add_params ref = let error = str "This reference is not a constructor." in user_err_loc (loc, "find_constructor", error) in - cstr, (function (ind,_ as c) -> match add_params with - |Some nb_args -> + cstr, match add_params with + | Some nb_args -> let nb = - if Int.equal nb_args (Inductiveops.constructor_nrealdecls c) + if Int.equal nb_args (Inductiveops.constructor_nrealdecls cstr) then Inductiveops.inductive_nparamdecls ind else Inductiveops.inductive_nparams ind in List.make nb ([], [(Id.Map.empty, PatVar(Loc.ghost,Anonymous))]) - |None -> []) cstr + | None -> [] let find_pattern_variable = function | Ident (loc,id) -> id @@ -1106,20 +1095,21 @@ let drop_notations_pattern looked_for = let (loc,qid) = qualid_of_reference re in try match locate_extended qid with - |SynDef sp -> + | SynDef sp -> let (vars,a) = Syntax_def.search_syntactic_definition sp in (match a with | NRef g -> + (* Convention: do not deactivate implicit arguments and scopes for further arguments *) test_kind top g; let () = assert (List.is_empty vars) in let (_,argscs) = find_remaining_scopes [] pats g in Some (g, [], List.map2 (in_pat_sc env) argscs pats) - | NApp (NRef g,[]) -> (* special case : Syndef for @Cstr *) + | NApp (NRef g,[]) -> (* special case: Syndef for @Cstr, this deactivates *) test_kind top g; let () = assert (List.is_empty vars) in - let (argscs,_) = find_remaining_scopes pats [] g in - Some (g, List.map2 (in_pat_sc env) argscs pats, []) + Some (g, List.map (in_pat false env) pats, []) | NApp (NRef g,args) -> + (* Convention: do not deactivate implicit arguments and scopes for further arguments *) test_kind top g; let nvars = List.length vars in if List.length pats < nvars then error_not_enough_arguments loc; @@ -1129,7 +1119,7 @@ let drop_notations_pattern looked_for = let (_,argscs) = find_remaining_scopes pats1 pats2 g in Some (g, idspl1, List.map2 (in_pat_sc env) argscs pats2) | _ -> raise Not_found) - |TrueGlobal g -> + | TrueGlobal g -> test_kind top g; Dumpglob.add_glob loc g; let (_,argscs) = find_remaining_scopes [] pats g in @@ -1144,26 +1134,31 @@ let drop_notations_pattern looked_for = | None -> RCPatAtom (loc, None) | Some (n, head, pl) -> let pl = - if !oldfashion_patterns then pl else + if !asymmetric_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)) end - | CPatCstr (loc, head, [], pl) -> + | CPatCstr (loc, head, None, pl) -> begin match drop_syndef top env head pl with | Some (a,b,c) -> RCPatCstr(loc, a, b, c) | None -> raise (InternalizationError (loc,NotAConstructor head)) end - | CPatCstr (loc, r, expl_pl, pl) -> - let g = try - (locate (snd (qualid_of_reference r))) - with Not_found -> + | CPatCstr (loc, r, Some expl_pl, pl) -> + let g = try locate (snd (qualid_of_reference r)) + with Not_found -> raise (InternalizationError (loc,NotAConstructor r)) in - let (argscs1,argscs2) = find_remaining_scopes expl_pl pl g in - RCPatCstr (loc, g, List.map2 (in_pat_sc env) argscs1 expl_pl, List.map2 (in_pat_sc env) argscs2 pl) + if expl_pl == [] then + (* Convention: (@r) deactivates all further implicit arguments and scopes *) + RCPatCstr (loc, g, List.map (in_pat false env) pl, []) + else + (* Convention: (@r expl_pl) deactivates implicit arguments in expl_pl and in pl *) + (* but not scopes in expl_pl *) + let (argscs1,_) = find_remaining_scopes expl_pl pl g in + RCPatCstr (loc, g, List.map2 (in_pat_sc env) argscs1 expl_pl @ List.map (in_pat false env) pl, []) | CPatNotation (loc,"- _",([CPatPrim(_,Numeral p)],[]),[]) when Bigint.is_strictly_pos p -> fst (Notation.interp_prim_token_cases_pattern_expr loc (ensure_kind false loc) (Numeral (Bigint.neg p)) @@ -1215,8 +1210,8 @@ let drop_notations_pattern looked_for = ensure_kind top loc g; let (argscs1,argscs2) = find_remaining_scopes pl args g in RCPatCstr (loc, g, - List.map2 (fun x -> in_not false loc {env with tmp_scope = x} fullsubst []) argscs1 pl, - List.map2 (in_pat_sc env) argscs2 args) + List.map2 (fun x -> in_not false loc {env with tmp_scope = x} fullsubst []) argscs1 pl @ + List.map (in_pat false env) args, []) | NList (x,_,iter,terminator,lassoc) -> if not (List.is_empty args) then user_err_loc (loc,"",strbrk "Application of arguments to a recursive notation not supported in patterns."); @@ -1249,7 +1244,7 @@ let rec intern_pat genv aliases pat = let aliases' = merge_aliases aliases id in intern_pat genv aliases' p | RCPatCstr (loc, head, expl_pl, pl) -> - if !oldfashion_patterns then + if !asymmetric_patterns then let len = if List.is_empty expl_pl then Some (List.length pl) else None in let c,idslpl1 = find_constructor loc len head in let with_letin = @@ -1386,7 +1381,7 @@ let internalize globalenv env allow_patvar lvar c = let (env',rbefore) = List.fold_left intern_local_binder (env,[]) before in let ro = f (intern env') in - let n' = Option.map (fun _ -> List.length (List.filter (fun (_,(_,_,b,_)) -> (* remove let-ins *) b = None) rbefore)) n in + let n' = Option.map (fun _ -> List.count (fun (_,(_,_,b,_)) -> (* remove let-ins *) b = None) rbefore) n in n', ro, List.fold_left intern_local_binder (env',rbefore) after in let n, ro, (env',rbl) = @@ -1492,7 +1487,7 @@ let internalize globalenv env allow_patvar lvar c = apply_impargs c env impargs args_scopes (merge_impargs l args) loc - | CRecord (loc, _, fs) -> + | CRecord (loc, fs) -> let cargs = sort_fields true loc fs (fun k l -> CHole (loc, Some (Evar_kinds.QuestionMark (Evar_kinds.Define true)), Misctypes.IntroAnonymous, None) :: l) @@ -1506,7 +1501,7 @@ let internalize globalenv env allow_patvar lvar c = intern env app end | CCases (loc, sty, rtnpo, tms, eqns) -> - let as_in_vars = List.fold_left (fun acc (_,(na,inb)) -> + let as_in_vars = List.fold_left (fun acc (_,na,inb) -> Option.fold_left (fun x tt -> List.fold_right Id.Set.add (ids_of_cases_indtype tt) x) (Option.fold_left (fun x (_,y) -> match y with | Name y' -> Id.Set.add y' x |_ -> x) acc na) inb) Id.Set.empty tms in @@ -1542,7 +1537,7 @@ let internalize globalenv env allow_patvar lvar c = | CLetTuple (loc, nal, (na,po), b, c) -> let env' = reset_tmp_scope env in (* "in" is None so no match to add *) - let ((b',(na',_)),_,_) = intern_case_item env' Id.Set.empty (b,(na,None)) in + let ((b',(na',_)),_,_) = intern_case_item env' Id.Set.empty (b,na,None) in let p' = Option.map (fun u -> let env'' = push_name_env lvar (Variable,[],[],[]) (reset_hidden_inductive_implicit_test env') (Loc.ghost,na') in @@ -1551,7 +1546,7 @@ let internalize globalenv env allow_patvar lvar c = intern (List.fold_left (push_name_env lvar (Variable,[],[],[])) (reset_hidden_inductive_implicit_test env) nal) c) | CIf (loc, c, (na,po), b1, b2) -> let env' = reset_tmp_scope env in - let ((c',(na',_)),_,_) = intern_case_item env' Id.Set.empty (c,(na,None)) in (* no "in" no match to ad too *) + let ((c',(na',_)),_,_) = intern_case_item env' Id.Set.empty (c,na,None) in (* no "in" no match to ad too *) let p' = Option.map (fun p -> let env'' = push_name_env lvar (Variable,[],[],[]) (reset_hidden_inductive_implicit_test env) (Loc.ghost,na') in @@ -1628,7 +1623,7 @@ let internalize globalenv env allow_patvar lvar c = let rhs' = intern {env with ids = env_ids} rhs in (loc,eqn_ids,pl,rhs')) pll - and intern_case_item env forbidden_names_for_gen (tm,(na,t)) = + and intern_case_item env forbidden_names_for_gen (tm,na,t) = (*the "match" part *) let tm' = intern env tm in (* the "as" part *) @@ -1658,14 +1653,14 @@ let internalize globalenv env allow_patvar lvar c = |loc,(Name y as x) -> (y,PatVar(loc,x)) :: l in match case_rel_ctxt,arg_pats with (* LetIn in the rel_context *) - |(_,Some _,_)::t, l when not with_letin -> + | LocalDef _ :: t, l when not with_letin -> canonize_args t l forbidden_names match_acc ((Loc.ghost,Anonymous)::var_acc) |[],[] -> (add_name match_acc na, var_acc) |_::t,PatVar (loc,x)::tt -> canonize_args t tt forbidden_names (add_name match_acc (loc,x)) ((loc,x)::var_acc) - |(cano_name,_,ty)::t,c::tt -> + | (LocalAssum (cano_name,ty) | LocalDef (cano_name,_,ty)) :: t, c::tt -> let fresh = Namegen.next_name_away_with_default_using_types "iV" cano_name forbidden_names ty in canonize_args t tt (fresh::forbidden_names) @@ -1857,7 +1852,7 @@ let intern_constr_pattern env ?(as_type=false) ?(ltacvars=empty_ltac_sign) c = let interp_notation_constr ?(impls=empty_internalization_env) nenv a = let env = Global.env () in (* [vl] is intended to remember the scope of the free variables of [a] *) - let vl = Id.Map.map (fun typ -> (ref None, typ)) nenv.ninterp_var_type in + let vl = Id.Map.map (fun typ -> (ref true, ref None, typ)) nenv.ninterp_var_type in let c = internalize (Global.env()) {ids = extract_ids env; unb = false; tmp_scope = None; scopes = []; impls = impls} false (empty_ltac_sign, vl) a in @@ -1866,7 +1861,8 @@ let interp_notation_constr ?(impls=empty_internalization_env) nenv a = (* Splits variables into those that are binding, bound, or both *) (* binding and bound *) let out_scope = function None -> None,[] | Some (a,l) -> a,l in - let vars = Id.Map.map (fun (sc, typ) -> (out_scope !sc, typ)) vl in + let vars = Id.Map.map (fun (isonlybinding, sc, typ) -> + (!isonlybinding, out_scope !sc, typ)) vl in (* Returns [a] and the ordered list of variables with their scopes *) vars, a @@ -1907,7 +1903,7 @@ let interp_rawcontext_evars env evdref k bl = let t' = locate_if_hole (loc_of_glob_constr t) na t in let t = understand_tcc_evars env evdref ~expected_type:IsType t' in - let d = (na,None,t) in + let d = LocalAssum (na,t) in let impls = if k == Implicit then let na = match na with Name n -> Some n | Anonymous -> None in @@ -1917,7 +1913,7 @@ let interp_rawcontext_evars env evdref k bl = (push_rel d env, d::params, succ n, impls) | Some b -> let c = understand_judgment_tcc env evdref b in - let d = (na, Some c.uj_val, c.uj_type) in + let d = LocalDef (na, c.uj_val, c.uj_type) in (push_rel d env, d::params, n, impls)) (env,[],k+1,[]) (List.rev bl) in (env, par), impls diff --git a/interp/constrintern.mli b/interp/constrintern.mli index 4d2c99467..eea76aa31 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,7 +8,6 @@ open Names open Term -open Context open Evd open Environ open Libnames @@ -95,7 +94,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 +106,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 *) @@ -159,7 +160,7 @@ val interp_binder_evars : env -> evar_map ref -> Name.t -> constr_expr -> types val interp_context_evars : ?global_level:bool -> ?impl_env:internalization_env -> ?shift:int -> env -> evar_map ref -> local_binder list -> - internalization_env * ((env * rel_context) * Impargs.manual_implicits) + internalization_env * ((env * Context.Rel.t) * Impargs.manual_implicits) (* val interp_context_gen : (env -> glob_constr -> unsafe_type_judgment Evd.in_evar_universe_context) -> *) (* (env -> Evarutil.type_constraint -> glob_constr -> unsafe_judgment Evd.in_evar_universe_context) -> *) @@ -176,7 +177,7 @@ val interp_context_evars : val locate_reference : Libnames.qualid -> Globnames.global_reference val is_global : Id.t -> bool -val construct_reference : named_context -> Id.t -> constr +val construct_reference : Context.Named.t -> Id.t -> constr val global_reference : Id.t -> constr val global_reference_in_absolute_module : DirPath.t -> Id.t -> constr @@ -184,7 +185,7 @@ val global_reference_in_absolute_module : DirPath.t -> Id.t -> constr guaranteed to have the same domain as the input one. *) val interp_notation_constr : ?impls:internalization_env -> notation_interp_env -> constr_expr -> - (subscopes * notation_var_internalization_type) Id.Map.t * + (bool * subscopes * notation_var_internalization_type) Id.Map.t * notation_constr (** Globalization options *) diff --git a/interp/coqlib.ml b/interp/coqlib.ml index 5ac718e3b..23bcddaea 100644 --- a/interp/coqlib.ml +++ b/interp/coqlib.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -87,7 +87,7 @@ let check_required_library d = *) (* or failing ...*) errorlabstrm "Coqlib.check_required_library" - (str "Library " ++ str (DirPath.to_string dir) ++ str " has to be required first.") + (str "Library " ++ pr_dirpath dir ++ str " has to be required first.") (************************************************************************) (* Specific Coq objects *) diff --git a/interp/coqlib.mli b/interp/coqlib.mli index 41204a715..5ba26d828 100644 --- a/interp/coqlib.mli +++ b/interp/coqlib.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/interp/dumpglob.ml b/interp/dumpglob.ml index c18ceecab..44a62ef37 100644 --- a/interp/dumpglob.ml +++ b/interp/dumpglob.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -139,12 +139,15 @@ let interval loc = loc1, loc2-1 let dump_ref loc filepath modpath ident ty = - if !glob_output = Feedback then + match !glob_output with + | Feedback -> Pp.feedback (Feedback.GlobRef (loc, filepath, modpath, ident, ty)) - else + | NoGlob -> () + | _ when not (Loc.is_ghost loc) -> let bl,el = interval loc in dump_string (Printf.sprintf "R%d:%d %s %s %s %s\n" bl el filepath modpath ident ty) + | _ -> () let dump_reference loc modpath ident ty = let filepath = Names.DirPath.to_string (Lib.library_dp ()) in @@ -245,7 +248,7 @@ let dump_def ty loc secpath id = let dump_definition (loc, id) sec s = dump_def s loc (Names.DirPath.to_string (Lib.current_dirpath sec)) (Names.Id.to_string id) -let dump_constraint ((loc, n), _, _) sec ty = +let dump_constraint (((loc, n),_), _, _) sec ty = match n with | Names.Name id -> dump_definition (loc, id) sec ty | Names.Anonymous -> () diff --git a/interp/dumpglob.mli b/interp/dumpglob.mli index 428189bec..a7c799114 100644 --- a/interp/dumpglob.mli +++ b/interp/dumpglob.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/interp/genintern.ml b/interp/genintern.ml index 7795946d5..d6bfd347f 100644 --- a/interp/genintern.ml +++ b/interp/genintern.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -37,20 +37,16 @@ module Subst = Register (SubstObj) let intern = Intern.obj let register_intern0 = Intern.register0 -let generic_intern ist v = - let unpacker wit v = - let (ist, v) = intern wit ist (raw v) in - (ist, in_gen (glbwit wit) v) - in - unpack { unpacker; } v +let generic_intern ist (GenArg (Rawwit wit, v)) = + let (ist, v) = intern wit ist v in + (ist, in_gen (glbwit wit) v) (** Substitution functions *) let substitute = Subst.obj let register_subst0 = Subst.register0 -let generic_substitute subs v = - let unpacker wit v = in_gen (glbwit wit) (substitute wit subs (glb v)) in - unpack { unpacker; } v +let generic_substitute subs (GenArg (Glbwit wit, v)) = + in_gen (glbwit wit) (substitute wit subs v) let () = Hook.set Detyping.subst_genarg_hook generic_substitute diff --git a/interp/genintern.mli b/interp/genintern.mli index 28f4f530b..4b244b38d 100644 --- a/interp/genintern.mli +++ b/interp/genintern.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml index 87f7a6d6e..751b03a4a 100644 --- a/interp/implicit_quantifiers.ml +++ b/interp/implicit_quantifiers.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -20,6 +20,7 @@ open Pp open Libobject open Nameops open Misctypes +open Context.Rel.Declaration (*i*) let generalizable_table = Summary.ref Id.Pred.empty ~name:"generalizable-ident" @@ -196,7 +197,7 @@ let combine_params avoid fn applied needed = List.partition (function (t, Some (loc, ExplByName id)) -> - let is_id (_, (na, _, _)) = match na with + let is_id (_, decl) = match get_name decl with | Name id' -> Id.equal id id' | Anonymous -> false in @@ -209,22 +210,22 @@ let combine_params avoid fn applied needed = (fun x -> match x with (t, Some (loc, ExplByName id)) -> id, t | _ -> assert false) named in - let is_unset (_, (_, b, _)) = match b with - | None -> true - | Some _ -> false + let is_unset (_, decl) = match decl with + | LocalAssum _ -> true + | LocalDef _ -> false in let needed = List.filter is_unset needed in let rec aux ids avoid app need = match app, need with [], [] -> List.rev ids, avoid - | app, (_, (Name id, _, _)) :: need when Id.List.mem_assoc id named -> + | app, (_, (LocalAssum (Name id, _) | LocalDef (Name id, _, _))) :: need when Id.List.mem_assoc id named -> aux (Id.List.assoc id named :: ids) avoid app need - | (x, None) :: app, (None, (Name id, _, _)) :: need -> + | (x, None) :: app, (None, (LocalAssum (Name id, _) | LocalDef (Name id, _, _))) :: need -> aux (x :: ids) avoid app need - | _, (Some cl, (_, _, _) as d) :: need -> + | _, (Some cl, _ as d) :: need -> let t', avoid' = fn avoid d in aux (t' :: ids) avoid' app need @@ -239,8 +240,8 @@ let combine_params avoid fn applied needed = in aux [] avoid applied needed let combine_params_freevar = - fun avoid (_, (na, _, _)) -> - let id' = next_name_away_from na avoid in + fun avoid (_, decl) -> + let id' = next_name_away_from (get_name decl) avoid in (CRef (Ident (Loc.ghost, id'),None), Id.Set.add id' avoid) let destClassApp cl = diff --git a/interp/implicit_quantifiers.mli b/interp/implicit_quantifiers.mli index eee928989..d0327e506 100644 --- a/interp/implicit_quantifiers.mli +++ b/interp/implicit_quantifiers.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -38,10 +38,10 @@ val make_fresh : Id.Set.t -> Environ.env -> Id.t -> Id.t val implicits_of_glob_constr : ?with_products:bool -> Glob_term.glob_constr -> Impargs.manual_implicits val combine_params_freevar : - Id.Set.t -> (global_reference * bool) option * (Name.t * Term.constr option * Term.types) -> + Id.Set.t -> (global_reference * bool) option * Context.Rel.Declaration.t -> Constrexpr.constr_expr * Id.Set.t val implicit_application : Id.Set.t -> ?allow_partial:bool -> - (Id.Set.t -> (global_reference * bool) option * (Name.t * Term.constr option * Term.types) -> + (Id.Set.t -> (global_reference * bool) option * Context.Rel.Declaration.t -> Constrexpr.constr_expr * Id.Set.t) -> constr_expr -> constr_expr * Id.Set.t diff --git a/interp/interp.mllib b/interp/interp.mllib index c9a031526..96b52959a 100644 --- a/interp/interp.mllib +++ b/interp/interp.mllib @@ -3,12 +3,12 @@ Constrarg Genintern Constrexpr_ops Notation_ops -Topconstr Ppextend Notation Dumpglob Syntax_def Smartlocate +Topconstr Reserve Impargs Implicit_quantifiers diff --git a/interp/modintern.ml b/interp/modintern.ml index 35e731137..e5dce5ccf 100644 --- a/interp/modintern.ml +++ b/interp/modintern.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/interp/modintern.mli b/interp/modintern.mli index 8b6d002e3..1e04ada17 100644 --- a/interp/modintern.mli +++ b/interp/modintern.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/interp/notation.ml b/interp/notation.ml index d18b804bf..ab0dcbeb7 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -314,7 +314,9 @@ let declare_prim_token_interpreter sc interp (patl,uninterp,b) = patl let mkNumeral n = Numeral n -let mkString s = String s +let mkString = function +| None -> None +| Some s -> if Unicode.is_utf8 s then Some (String s) else None let delay dir int loc x = (dir, (fun () -> int loc x)) @@ -326,7 +328,7 @@ let declare_numeral_interpreter sc dir interp (patl,uninterp,inpat) = let declare_string_interpreter sc dir interp (patl,uninterp,inpat) = declare_prim_token_interpreter sc (fun cont loc -> function String s -> delay dir interp loc s | p -> cont loc p) - (patl, (fun r -> Option.map mkString (uninterp r)), inpat) + (patl, (fun r -> mkString (uninterp r)), inpat) let check_required_module loc sc (sp,d) = try let _ = Nametab.global_of_path sp in () @@ -529,9 +531,10 @@ let pair_eq f g (x1, y1) (x2, y2) = f x1 x2 && g y1 y2 let ntpe_eq t1 t2 = match t1, t2 with | NtnTypeConstr, NtnTypeConstr -> true +| NtnTypeOnlyBinder, NtnTypeOnlyBinder -> true | NtnTypeConstrList, NtnTypeConstrList -> true | NtnTypeBinderList, NtnTypeBinderList -> true -| (NtnTypeConstr | NtnTypeConstrList | NtnTypeBinderList), _ -> false +| (NtnTypeConstr | NtnTypeOnlyBinder | NtnTypeConstrList | NtnTypeBinderList), _ -> false let vars_eq (id1, (sc1, tp1)) (id2, (sc2, tp2)) = diff --git a/interp/notation.mli b/interp/notation.mli index 38bd5fc7b..7885814c7 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index 2762dc0b8..6561000c4 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -567,6 +567,18 @@ let abstract_return_type_context_notation_constr = abstract_return_type_context snd (fun na c -> NLambda(na,NHole (Evar_kinds.InternalHole, Misctypes.IntroAnonymous, None),c)) +let is_term_meta id metas = + try match Id.List.assoc id metas with _,(NtnTypeConstr | NtnTypeConstrList) -> true | _ -> false + with Not_found -> false + +let is_onlybinding_meta id metas = + try match Id.List.assoc id metas with _,NtnTypeOnlyBinder -> true | _ -> false + with Not_found -> false + +let is_bindinglist_meta id metas = + try match Id.List.assoc id metas with _,NtnTypeBinderList -> true | _ -> false + with Not_found -> false + exception No_match let rec alpha_var id1 id2 = function @@ -575,26 +587,67 @@ let rec alpha_var id1 id2 = function | _::idl -> alpha_var id1 id2 idl | [] -> Id.equal id1 id2 -let add_env alp (sigma,sigmalist,sigmabinders) var v = +let add_env (alp,alpmetas) (terms,onlybinders,termlists,binderlists) var v = (* Check that no capture of binding variables occur *) + (* [alp] is used when matching a pattern "fun x => ... x ... ?var ... x ..." + with an actual term "fun z => ... z ..." when "x" is not bound in the + notation, as in "Notation "'twice_upto' y" := (fun x => x + x + y)". Then + we keep (z,x) in alp, and we have to check that what the [v] which is bound + to [var] does not contain z *) if List.exists (fun (id,_) ->occur_glob_constr id v) alp then raise No_match; + (* [alpmetas] is used when matching a pattern "fun x => ... x ... ?var ... x ..." + with an actual term "fun z => ... z ..." when "x" is bound in the + notation and the name "x" cannot be changed to "z", e.g. because + used at another occurrence, as in "Notation "'lam' y , P & Q" := + ((fun y => P),(fun y => Q))". Then, we keep (z,y) in alpmetas, and we + have to check that "fun z => ... z ..." denotes the same term as + "fun x => ... x ... ?var ... x" up to alpha-conversion when [var] + is instantiated by [v]; + Currently, we fail, but, eventually, [x] in [v] could be replaced by [x], + and, in match_, when finding "x" in subterm, failing because of a capture, + and, in match_, when finding "z" in subterm, replacing it with "x", + and, in an even further step, being even more robust, independent of the order, so + that e.g. the notation for ex2 works on "x y |- ex2 (fun x => y=x) (fun y => x=y)" + by giving, say, "exists2 x0, y=x0 & x=x0", but this would typically require the + glob_constr_eq in bind_term_env to be postponed in match_notation_constr, and the + choice of exact variable be done there; but again, this would be a non-trivial + refinement *) + if alpmetas != [] then raise No_match; + (* TODO: handle the case of multiple occs in different scopes *) + ((var,v)::terms,onlybinders,termlists,binderlists) + +let add_binding_env alp (terms,onlybinders,termlists,binderlists) var v = (* TODO: handle the case of multiple occs in different scopes *) - ((var,v)::sigma,sigmalist,sigmabinders) + (terms,(var,v)::onlybinders,termlists,binderlists) -let bind_env alp (sigma,sigmalist,sigmabinders as fullsigma) var v = +let add_bindinglist_env (terms,onlybinders,termlists,binderlists) x bl = + (terms,onlybinders,termlists,(x,List.rev bl)::binderlists) + +let bind_term_env alp (terms,onlybinders,termlists,binderlists as sigma) var v = try - let v' = Id.List.assoc var sigma in + let v' = Id.List.assoc var terms in match v, v' with - | GHole _, _ -> fullsigma + | GHole _, _ -> sigma | _, GHole _ -> - add_env alp (Id.List.remove_assoc var sigma,sigmalist,sigmabinders) var v + let sigma = Id.List.remove_assoc var terms,onlybinders,termlists,binderlists in + add_env alp sigma var v | _, _ -> - if glob_constr_eq v v' then fullsigma + if glob_constr_eq v v' then sigma else raise No_match - with Not_found -> add_env alp fullsigma var v + with Not_found -> add_env alp sigma var v -let bind_binder (sigma,sigmalist,sigmabinders) x bl = - (sigma,sigmalist,(x,List.rev bl)::sigmabinders) +let bind_binding_env alp (terms,onlybinders,termlists,binderlists as sigma) var v = + try + let v' = Id.List.assoc var onlybinders in + match v, v' with + | Anonymous, _ -> alp, sigma + | _, Anonymous -> + let sigma = (terms,Id.List.remove_assoc var onlybinders,termlists,binderlists) in + alp, add_binding_env alp sigma var v + | Name id1, Name id2 -> + if Id.equal id1 id2 then alp,sigma + else (fst alp,(id1,id2)::snd alp),sigma + with Not_found -> alp, add_binding_env alp sigma var v let match_fix_kind fk1 fk2 = match (fk1,fk2) with @@ -615,12 +668,16 @@ let match_opt f sigma t1 t2 = match (t1,t2) with | _ -> raise No_match let match_names metas (alp,sigma) na1 na2 = match (na1,na2) with - | (_,Name id2) when Id.List.mem id2 (fst metas) -> - let rhs = match na1 with - | Name id1 -> GVar (Loc.ghost,id1) - | Anonymous -> GHole (Loc.ghost,Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None) in - alp, bind_env alp sigma id2 rhs - | (Name id1,Name id2) -> (id1,id2)::alp,sigma + | (na1,Name id2) when is_onlybinding_meta id2 metas -> + bind_binding_env alp sigma id2 na1 + | (Name id1,Name id2) when is_term_meta id2 metas -> + (* We let the non-binding occurrence define the rhs and hence reason up to *) + (* alpha-conversion for the given occurrence of the name (see #)) *) + (fst alp,(id1,id2)::snd alp), sigma + | (Anonymous,Name id2) when is_term_meta id2 metas -> + (* We let the non-binding occurrence define the rhs *) + alp, sigma + | (Name id1,Name id2) -> ((id1,id2)::fst alp, snd alp),sigma | (Anonymous,Anonymous) -> alp,sigma | _ -> raise No_match @@ -645,36 +702,38 @@ let rec match_iterated_binders islambda decls = function ((na,Explicit (*?*), Some c,GHole(loc,Evar_kinds.BinderType na,Misctypes.IntroAnonymous,None))::decls) b | b -> (decls,b) -let remove_sigma x (sigmavar,sigmalist,sigmabinders) = - (Id.List.remove_assoc x sigmavar,sigmalist,sigmabinders) +let remove_sigma x (terms,onlybinders,termlists,binderlists) = + (Id.List.remove_assoc x terms,onlybinders,termlists,binderlists) + +let add_ldots_var metas = (ldots_var,((None,[]),NtnTypeConstr))::metas let match_abinderlist_with_app match_fun metas sigma rest x iter termin = let rec aux sigma acc rest = try - let sigma = match_fun (ldots_var::fst metas,snd metas) sigma rest iter in - let rest = Id.List.assoc ldots_var (pi1 sigma) in + let (terms,_,_,binderlists as sigma) = match_fun (add_ldots_var metas) sigma rest iter in + let rest = Id.List.assoc ldots_var terms in let b = - match Id.List.assoc x (pi3 sigma) with [b] -> b | _ ->assert false + match Id.List.assoc x binderlists with [b] -> b | _ ->assert false in let sigma = remove_sigma x (remove_sigma ldots_var sigma) in aux sigma (b::acc) rest with No_match when not (List.is_empty acc) -> acc, match_fun metas sigma rest termin in let bl,sigma = aux sigma [] rest in - bind_binder sigma x bl + add_bindinglist_env sigma x bl let match_alist match_fun metas sigma rest x iter termin lassoc = let rec aux sigma acc rest = try - let sigma = match_fun (ldots_var::fst metas,snd metas) sigma rest iter in - let rest = Id.List.assoc ldots_var (pi1 sigma) in - let t = Id.List.assoc x (pi1 sigma) in + let (terms,_,_,_ as sigma) = match_fun (add_ldots_var metas) sigma rest iter in + let rest = Id.List.assoc ldots_var terms in + let t = Id.List.assoc x terms in let sigma = remove_sigma x (remove_sigma ldots_var sigma) in aux sigma (t::acc) rest with No_match when not (List.is_empty acc) -> acc, match_fun metas sigma rest termin in - let l,sigma = aux sigma [] rest in - (pi1 sigma, (x,if lassoc then l else List.rev l)::pi2 sigma, pi3 sigma) + let l,(terms,onlybinders,termlists,binderlists as sigma) = aux sigma [] rest in + (terms,onlybinders,(x,if lassoc then l else List.rev l)::termlists, binderlists) let does_not_come_from_already_eta_expanded_var = (* This is hack to avoid looping on a rule with rhs of the form *) @@ -688,11 +747,11 @@ let does_not_come_from_already_eta_expanded_var = (* checked). *) function GVar _ -> false | _ -> true -let rec match_ inner u alp (tmetas,blmetas as metas) sigma a1 a2 = +let rec match_ inner u alp metas sigma a1 a2 = match (a1,a2) with (* Matching notation variable *) - | r1, NVar id2 when Id.List.mem id2 tmetas -> bind_env alp sigma id2 r1 + | r1, NVar id2 when is_term_meta id2 metas -> bind_term_env alp sigma id2 r1 (* Matching recursive notations for terms *) | r1, NList (x,_,iter,termin,lassoc) -> @@ -702,25 +761,26 @@ let rec match_ inner u alp (tmetas,blmetas as metas) sigma a1 a2 = | GLambda (_,na1,bk,t1,b1), NBinderList (x,_,NLambda (Name id2,_,b2),termin)-> let (decls,b) = match_iterated_binders true [(na1,bk,None,t1)] b1 in (* TODO: address the possibility that termin is a Lambda itself *) - match_in u alp metas (bind_binder sigma x decls) b termin + match_in u alp metas (add_bindinglist_env sigma x decls) b termin | GProd (_,na1,bk,t1,b1), NBinderList (x,_,NProd (Name id2,_,b2),termin) when na1 != Anonymous -> let (decls,b) = match_iterated_binders false [(na1,bk,None,t1)] b1 in (* TODO: address the possibility that termin is a Prod itself *) - match_in u alp metas (bind_binder sigma x decls) b termin + match_in u alp metas (add_bindinglist_env sigma x decls) b termin (* Matching recursive notations for binders: general case *) | r, NBinderList (x,_,iter,termin) -> match_abinderlist_with_app (match_hd u alp) metas sigma r x iter termin (* Matching individual binders as part of a recursive pattern *) - | GLambda (_,na,bk,t,b1), NLambda (Name id,_,b2) when Id.List.mem id blmetas -> - match_in u alp metas (bind_binder sigma id [(na,bk,None,t)]) b1 b2 + | GLambda (_,na,bk,t,b1), NLambda (Name id,_,b2) + when is_bindinglist_meta id metas -> + match_in u alp metas (add_bindinglist_env sigma id [(na,bk,None,t)]) b1 b2 | GProd (_,na,bk,t,b1), NProd (Name id,_,b2) - when Id.List.mem id blmetas && na != Anonymous -> - match_in u alp metas (bind_binder sigma id [(na,bk,None,t)]) b1 b2 + when is_bindinglist_meta id metas && na != Anonymous -> + match_in u alp metas (add_bindinglist_env sigma id [(na,bk,None,t)]) b1 b2 (* Matching compositionally *) - | GVar (_,id1), NVar id2 when alpha_var id1 id2 alp -> sigma + | GVar (_,id1), NVar id2 when alpha_var id1 id2 (fst alp) -> sigma | GRef (_,r1,_), NRef r2 when (eq_gr r1 r2) -> sigma | GPatVar (_,(_,n1)), NPatVar n2 when Id.equal n1 n2 -> sigma | GApp (loc,f1,l1), NApp (f2,l2) -> @@ -799,9 +859,9 @@ let rec match_ inner u alp (tmetas,blmetas as metas) sigma a1 a2 = let t1 = GHole(Loc.ghost,Evar_kinds.BinderType (Name id'),Misctypes.IntroAnonymous,None) in let sigma = match t2 with | NHole _ -> sigma - | NVar id2 -> bind_env alp sigma id2 t1 + | NVar id2 -> bind_term_env alp sigma id2 t1 | _ -> assert false in - match_in u alp metas (bind_binder sigma id [(Name id',Explicit,None,t1)]) + match_in u alp metas (add_bindinglist_env sigma id [(Name id',Explicit,None,t1)]) (mkGApp Loc.ghost b1 (GVar (Loc.ghost,id'))) b2 | (GRec _ | GEvar _), _ @@ -823,14 +883,16 @@ and match_equations u alp metas sigma (_,_,patl1,rhs1) (patl2,rhs2) = (alp,sigma) patl1 patl2 in match_in u alp metas sigma rhs1 rhs2 +let term_of_binder = function + | Name id -> GVar (Loc.ghost,id) + | Anonymous -> GHole (Loc.ghost,Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None) + let match_notation_constr u c (metas,pat) = - let test (_, (_, x)) = match x with NtnTypeBinderList -> false | _ -> true in - let vars = List.partition test metas in - let vars = (List.map fst (fst vars), List.map fst (snd vars)) in - let terms,termlists,binders = match_ false u [] vars ([],[],[]) c pat in + let terms,binders,termlists,binderlists = + match_ false u ([],[]) metas ([],[],[],[]) c pat in (* Reorder canonically the substitution *) - let find x = - try Id.List.assoc x terms + let find_binder x = + try term_of_binder (Id.List.assoc x binders) with Not_found -> (* Happens for binders bound to Anonymous *) (* Find a better way to propagate Anonymous... *) @@ -838,11 +900,13 @@ let match_notation_constr u c (metas,pat) = List.fold_right (fun (x,(scl,typ)) (terms',termlists',binders') -> match typ with | NtnTypeConstr -> - ((find x, scl)::terms',termlists',binders') + ((Id.List.assoc x terms, scl)::terms',termlists',binders') + | NtnTypeOnlyBinder -> + ((find_binder x, scl)::terms',termlists',binders') | NtnTypeConstrList -> (terms',(Id.List.assoc x termlists,scl)::termlists',binders') | NtnTypeBinderList -> - (terms',termlists',(Id.List.assoc x binders,scl)::binders')) + (terms',termlists',(Id.List.assoc x binderlists,scl)::binders')) metas ([],[],[]) (* Matching cases pattern *) @@ -851,17 +915,17 @@ let add_patterns_for_params ind l = let nparams = mib.Declarations.mind_nparams in Util.List.addn nparams (PatVar (Loc.ghost,Anonymous)) l -let bind_env_cases_pattern (sigma,sigmalist,x as fullsigma) var v = +let bind_env_cases_pattern (terms,x,termlists,y as sigma) var v = try - let vvar = Id.List.assoc var sigma in - if cases_pattern_eq v vvar then fullsigma else raise No_match + let vvar = Id.List.assoc var terms in + if cases_pattern_eq v vvar then sigma else raise No_match with Not_found -> (* TODO: handle the case of multiple occs in different scopes *) - (var,v)::sigma,sigmalist,x + (var,v)::terms,x,termlists,y -let rec match_cases_pattern metas sigma a1 a2 = +let rec match_cases_pattern metas (terms,x,termlists,y as sigma) a1 a2 = match (a1,a2) with - | r1, NVar id2 when Id.List.mem id2 metas -> (bind_env_cases_pattern sigma id2 r1),(0,[]) + | r1, NVar id2 when Id.List.mem_assoc id2 metas -> (bind_env_cases_pattern sigma id2 r1),(0,[]) | PatVar (_,Anonymous), NHole _ -> sigma,(0,[]) | PatCstr (loc,(ind,_ as r1),largs,_), NRef (ConstructRef r2) when eq_constructor r1 r2 -> sigma,(0,add_patterns_for_params (fst r1) largs) @@ -876,14 +940,14 @@ let rec match_cases_pattern metas sigma a1 a2 = let l1',more_args = Util.List.chop le2 l1 in (List.fold_left2 (match_cases_pattern_no_more_args metas) sigma l1' l2),(le2,more_args) | r1, NList (x,_,iter,termin,lassoc) -> - (match_alist (fun (metas,_) -> match_cases_pattern_no_more_args metas) - (metas,[]) (pi1 sigma,pi2 sigma,()) r1 x iter termin lassoc),(0,[]) + (match_alist (match_cases_pattern_no_more_args) + metas (terms,(),termlists,()) r1 x iter termin lassoc),(0,[]) | _ -> raise No_match and match_cases_pattern_no_more_args metas sigma a1 a2 = match match_cases_pattern metas sigma a1 a2 with - |out,(_,[]) -> out - |_ -> raise No_match + | out,(_,[]) -> out + | _ -> raise No_match let match_ind_pattern metas sigma ind pats a2 = match a2 with @@ -904,16 +968,15 @@ let reorder_canonically_substitution terms termlists metas = List.fold_right (fun (x,(scl,typ)) (terms',termlists') -> match typ with | NtnTypeConstr -> ((Id.List.assoc x terms, scl)::terms',termlists') + | NtnTypeOnlyBinder -> assert false | NtnTypeConstrList -> (terms',(Id.List.assoc x termlists,scl)::termlists') | NtnTypeBinderList -> assert false) metas ([],[]) let match_notation_constr_cases_pattern c (metas,pat) = - let vars = List.map fst metas in - let (terms,termlists,()),more_args = match_cases_pattern vars ([],[],()) c pat in + let (terms,(),termlists,()),more_args = match_cases_pattern metas ([],(),[],()) c pat in reorder_canonically_substitution terms termlists metas, more_args let match_notation_constr_ind_pattern ind args (metas,pat) = - let vars = List.map fst metas in - let (terms,termlists,()),more_args = match_ind_pattern vars ([],[],()) ind args pat in + let (terms,(),termlists,()),more_args = match_ind_pattern metas ([],(),[],()) ind args pat in reorder_canonically_substitution terms termlists metas, more_args diff --git a/interp/notation_ops.mli b/interp/notation_ops.mli index c6770deea..280ccfd21 100644 --- a/interp/notation_ops.mli +++ b/interp/notation_ops.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/interp/ppextend.ml b/interp/ppextend.ml index cb12b98ae..37bbe0ce8 100644 --- a/interp/ppextend.ml +++ b/interp/ppextend.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/interp/ppextend.mli b/interp/ppextend.mli index 0385eea27..de7a42eee 100644 --- a/interp/ppextend.mli +++ b/interp/ppextend.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/interp/reserve.ml b/interp/reserve.ml index 3100298e5..7e42c1a22 100644 --- a/interp/reserve.ml +++ b/interp/reserve.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/interp/reserve.mli b/interp/reserve.mli index 6cae2b026..9c77400da 100644 --- a/interp/reserve.mli +++ b/interp/reserve.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/interp/smartlocate.ml b/interp/smartlocate.ml index ce3c9b8f6..1f28ba656 100644 --- a/interp/smartlocate.ml +++ b/interp/smartlocate.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/interp/smartlocate.mli b/interp/smartlocate.mli index 68ef6594f..0749ca576 100644 --- a/interp/smartlocate.mli +++ b/interp/smartlocate.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/interp/stdarg.ml b/interp/stdarg.ml index e155a5217..244cdd0a7 100644 --- a/interp/stdarg.ml +++ b/interp/stdarg.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -9,22 +9,21 @@ open Genarg let wit_unit : unit uniform_genarg_type = - make0 None "unit" + make0 "unit" let wit_bool : bool uniform_genarg_type = - make0 None "bool" + make0 "bool" let wit_int : int uniform_genarg_type = - make0 None "int" + make0 "int" let wit_string : string uniform_genarg_type = - make0 None "string" + make0 "string" let wit_pre_ident : string uniform_genarg_type = - make0 None "preident" + make0 "preident" -let () = register_name0 wit_unit "Stdarg.wit_unit" -let () = register_name0 wit_bool "Stdarg.wit_bool" -let () = register_name0 wit_int "Stdarg.wit_int" -let () = register_name0 wit_string "Stdarg.wit_string" -let () = register_name0 wit_pre_ident "Stdarg.wit_pre_ident" +(** Aliases for compatibility *) + +let wit_integer = wit_int +let wit_preident = wit_pre_ident diff --git a/interp/stdarg.mli b/interp/stdarg.mli index 5a44b1ca6..e1f648d7f 100644 --- a/interp/stdarg.mli +++ b/interp/stdarg.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -19,3 +19,8 @@ val wit_int : int uniform_genarg_type val wit_string : string uniform_genarg_type val wit_pre_ident : string uniform_genarg_type + +(** Aliases for compatibility *) + +val wit_integer : int uniform_genarg_type +val wit_preident : string uniform_genarg_type diff --git a/interp/syntax_def.ml b/interp/syntax_def.ml index d2709d5e3..db548ec32 100644 --- a/interp/syntax_def.ml +++ b/interp/syntax_def.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/interp/syntax_def.mli b/interp/syntax_def.mli index e5a3f4ceb..7a1c9c5cb 100644 --- a/interp/syntax_def.mli +++ b/interp/syntax_def.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/interp/topconstr.ml b/interp/topconstr.ml index 1231f1155..e569f543b 100644 --- a/interp/topconstr.ml +++ b/interp/topconstr.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -19,14 +19,14 @@ open Constrexpr_ops (*i*) -let oldfashion_patterns = ref (false) +let asymmetric_patterns = ref (false) let _ = Goptions.declare_bool_option { Goptions.optsync = true; Goptions.optdepr = false; Goptions.optname = "Constructors in patterns require all their arguments but no parameters instead of explicit parameters and arguments"; Goptions.optkey = ["Asymmetric";"Patterns"]; - Goptions.optread = (fun () -> !oldfashion_patterns); - Goptions.optwrite = (fun a -> oldfashion_patterns:=a); + Goptions.optread = (fun () -> !asymmetric_patterns); + Goptions.optwrite = (fun a -> asymmetric_patterns:=a); } (**********************************************************************) @@ -38,27 +38,11 @@ let error_invalid_pattern_notation loc = (**********************************************************************) (* Functions on constr_expr *) -let ids_of_cases_indtype = - let rec vars_of ids = function - (* We deal only with the regular cases *) - | (CPatCstr (_,_,l1,l2)|CPatNotation (_,_,(l1,[]),l2)) -> - List.fold_left vars_of (List.fold_left vars_of [] l2) l1 - (* assume the ntn is applicative and does not instantiate the head !! *) - | CPatDelimiters(_,_,c) -> vars_of ids c - | CPatAtom (_, Some (Libnames.Ident (_, x))) -> x::ids - | _ -> ids in - vars_of [] - -let ids_of_cases_tomatch tms = - List.fold_right - (fun (_,(ona,indnal)) l -> - Option.fold_right (fun t -> (@) (ids_of_cases_indtype t)) - indnal (Option.fold_right (Loc.down_located name_cons) ona l)) - tms [] - let is_constructor id = - try ignore (Nametab.locate_extended (qualid_of_ident id)); true - with Not_found -> true + try Globnames.isConstructRef + (Smartlocate.global_of_extended_global + (Nametab.locate_extended (qualid_of_ident id))) + with Not_found -> false let rec cases_pattern_fold_names f a = function | CPatRecord (_, l) -> @@ -68,7 +52,7 @@ let rec cases_pattern_fold_names f a = function List.fold_left (cases_pattern_fold_names f) a patl | CPatCstr (_,_,patl1,patl2) -> List.fold_left (cases_pattern_fold_names f) - (List.fold_left (cases_pattern_fold_names f) a patl1) patl2 + (Option.fold_left (List.fold_left (cases_pattern_fold_names f)) a patl1) patl2 | CPatNotation (_,_,(patl,patll),patl') -> List.fold_left (cases_pattern_fold_names f) (List.fold_left (cases_pattern_fold_names f) a (patl@List.flatten patll)) patl' @@ -82,6 +66,17 @@ let ids_of_pattern_list = (List.fold_left (cases_pattern_fold_names Id.Set.add))) Id.Set.empty +let ids_of_cases_indtype p = + Id.Set.elements (cases_pattern_fold_names Id.Set.add Id.Set.empty p) + +let ids_of_cases_tomatch tms = + List.fold_right + (fun (_, ona, indnal) l -> + Option.fold_right (fun t ids -> cases_pattern_fold_names Id.Set.add ids t) + indnal + (Option.fold_right (Loc.down_located (name_fold Id.Set.add)) ona l)) + tms Id.Set.empty + let rec fold_constr_expr_binders g f n acc b = function | (nal,bk,t)::l -> let nal = snd (List.split nal) in @@ -116,11 +111,11 @@ let fold_constr_expr_with_binders g f n acc = function | CDelimiters (loc,_,a) -> f n acc a | CHole _ | CEvar _ | CPatVar _ | CSort _ | CPrim _ | CRef _ -> acc - | CRecord (loc,_,l) -> List.fold_left (fun acc (id, c) -> f n acc c) acc l + | CRecord (loc,l) -> List.fold_left (fun acc (id, c) -> f n acc c) acc l | CCases (loc,sty,rtnpo,al,bl) -> let ids = ids_of_cases_tomatch al in - let acc = Option.fold_left (f (List.fold_right g ids n)) acc rtnpo in - let acc = List.fold_left (f n) acc (List.map fst al) in + let acc = Option.fold_left (f (Id.Set.fold g ids n)) acc rtnpo in + let acc = List.fold_left (f n) acc (List.map (fun (fst,_,_) -> fst) al) in List.fold_right (fun (loc,patl,rhs) acc -> let ids = ids_of_pattern_list patl in f (Id.Set.fold g ids n) acc rhs) bl acc @@ -218,13 +213,14 @@ let map_constr_expr_with_binders g f e = function | CDelimiters (loc,s,a) -> CDelimiters (loc,s,f e a) | CHole _ | CEvar _ | CPatVar _ | CSort _ | CPrim _ | CRef _ as x -> x - | CRecord (loc,p,l) -> CRecord (loc,p,List.map (fun (id, c) -> (id, f e c)) l) + | CRecord (loc,l) -> CRecord (loc,List.map (fun (id, c) -> (id, f e c)) l) | CCases (loc,sty,rtnpo,a,bl) -> - (* TODO: apply g on the binding variables in pat... *) - let bl = List.map (fun (loc,pat,rhs) -> (loc,pat,f e rhs)) bl in + let bl = List.map (fun (loc,patl,rhs) -> + let ids = ids_of_pattern_list patl in + (loc,patl,f (Id.Set.fold g ids e) rhs)) bl in let ids = ids_of_cases_tomatch a in - let po = Option.map (f (List.fold_right g ids e)) rtnpo in - CCases (loc, sty, po, List.map (fun (tm,x) -> (f e tm,x)) a,bl) + let po = Option.map (f (Id.Set.fold g ids e)) rtnpo in + CCases (loc, sty, po, List.map (fun (tm,x,y) -> f e tm,x,y) a,bl) | CLetTuple (loc,nal,(ona,po),b,c) -> let e' = List.fold_right (Loc.down_located (name_fold g)) nal e in let e'' = Option.fold_right (Loc.down_located (name_fold g)) ona e in diff --git a/interp/topconstr.mli b/interp/topconstr.mli index b25d7082c..0f30135f8 100644 --- a/interp/topconstr.mli +++ b/interp/topconstr.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -12,7 +12,7 @@ open Constrexpr (** Topconstr *) -val oldfashion_patterns : bool ref +val asymmetric_patterns : bool ref (** Utilities on constr_expr *) diff --git a/intf/constrexpr.mli b/intf/constrexpr.mli index 79f4e99e1..efd5129b6 100644 --- a/intf/constrexpr.mli +++ b/intf/constrexpr.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -32,21 +32,23 @@ type abstraction_kind = AbsLambda | AbsPi type proj_flag = int option (** [Some n] = proj of the n-th visible argument *) -type prim_token = Numeral of Bigint.bigint | String of string +type prim_token = + | Numeral of Bigint.bigint (** representation of integer literals that appear in Coq scripts. *) + | String of string type raw_cases_pattern_expr = | RCPatAlias of Loc.t * raw_cases_pattern_expr * Id.t | RCPatCstr of Loc.t * Globnames.global_reference * raw_cases_pattern_expr list * raw_cases_pattern_expr list - (** [CPatCstr (_, Inl c, l1, l2)] represents (@c l1) l2 *) + (** [CPatCstr (_, c, l1, l2)] represents ((@c l1) l2) *) | RCPatAtom of Loc.t * Id.t option | RCPatOr of Loc.t * raw_cases_pattern_expr list type cases_pattern_expr = | CPatAlias of Loc.t * cases_pattern_expr * Id.t | CPatCstr of Loc.t * reference - * cases_pattern_expr list * cases_pattern_expr list - (** [CPatCstr (_, Inl c, l1, l2)] represents (@c l1) l2 *) + * cases_pattern_expr list option * cases_pattern_expr list + (** [CPatCstr (_, c, Some l1, l2)] represents (@c l1) l2 *) | CPatAtom of Loc.t * reference option | CPatOr of Loc.t * cases_pattern_expr list | CPatNotation of Loc.t * notation * cases_pattern_notation_substitution @@ -73,9 +75,15 @@ type constr_expr = | CAppExpl of Loc.t * (proj_flag * reference * instance_expr option) * constr_expr list | CApp of Loc.t * (proj_flag * constr_expr) * (constr_expr * explicitation located option) list - | CRecord of Loc.t * constr_expr option * (reference * constr_expr) list - | CCases of Loc.t * case_style * constr_expr option * - case_expr list * branch_expr list + | CRecord of Loc.t * (reference * constr_expr) list + + (* representation of the "let" and "match" constructs *) + | CCases of Loc.t (* position of the "match" keyword *) + * case_style (* determines whether this value represents "let" or "match" construct *) + * constr_expr option (* return-clause *) + * case_expr list + * branch_expr list (* branches *) + | CLetTuple of Loc.t * Name.t located list * (Name.t located option * constr_expr option) * constr_expr * constr_expr | CIf of Loc.t * constr_expr * (Name.t located option * constr_expr option) @@ -90,8 +98,9 @@ type constr_expr = | CPrim of Loc.t * prim_token | CDelimiters of Loc.t * string * constr_expr -and case_expr = - constr_expr * (Name.t located option * cases_pattern_expr option) +and case_expr = constr_expr (* expression that is being matched *) + * Name.t located option (* as-clause *) + * cases_pattern_expr option (* in-clause *) and branch_expr = Loc.t * cases_pattern_expr list located list * constr_expr @@ -121,7 +130,7 @@ and constr_notation_substitution = constr_expr list list * (** for recursive notations *) local_binder list list (** for binders subexpressions *) -type typeclass_constraint = Name.t located * binding_kind * constr_expr +type typeclass_constraint = (Name.t located * Id.t located list option) * binding_kind * constr_expr and typeclass_context = typeclass_constraint list diff --git a/intf/decl_kinds.mli b/intf/decl_kinds.mli index 6886083c8..6a4e18833 100644 --- a/intf/decl_kinds.mli +++ b/intf/decl_kinds.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/intf/evar_kinds.mli b/intf/evar_kinds.mli index 38a3e81f4..afc5e3bab 100644 --- a/intf/evar_kinds.mli +++ b/intf/evar_kinds.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/intf/extend.mli b/intf/extend.mli index 975f194b0..10713745e 100644 --- a/intf/extend.mli +++ b/intf/extend.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -51,8 +51,30 @@ type constr_prod_entry_key = type simple_constr_prod_entry_key = (production_level,unit) constr_entry_key_gen +(** {5 AST for user-provided entries} *) + +type user_symbol = +| Ulist1 : user_symbol -> user_symbol +| Ulist1sep : user_symbol * string -> user_symbol +| Ulist0 : user_symbol -> user_symbol +| Ulist0sep : user_symbol * string -> user_symbol +| Uopt : user_symbol -> user_symbol +| Uentry : string -> user_symbol +| Uentryl : string * int -> user_symbol + (** {5 Type-safe grammar extension} *) +(** (a, b, r) adj => [a = x₁ -> ... xₙ -> r] & [b = x₁ * (... (xₙ * unit))]. *) +type (_, _, _) adj = +| Adj0 : ('r, unit, 'r) adj +| AdjS : ('s, 'b, 'r) adj -> ('a -> 's, 'a * 'b, 'r) adj + +type _ index = +| I0 : 'a -> ('a * 'r) index +| IS : 'a index -> ('b * 'a) index + +(** This type should be marshallable, this is why we use a convoluted + representation in the [Arules] constructor instead of putting a function. *) type ('self, 'a) symbol = | Atoken : Tok.t -> ('self, string) symbol | Alist1 : ('self, 'a) symbol -> ('self, 'a list) symbol @@ -60,16 +82,23 @@ type ('self, 'a) symbol = | Alist0 : ('self, 'a) symbol -> ('self, 'a list) symbol | Alist0sep : ('self, 'a) symbol * string -> ('self, 'a list) symbol | Aopt : ('self, 'a) symbol -> ('self, 'a option) symbol -| Amodifiers : ('self, 'a) symbol -> ('self, 'a list) symbol | Aself : ('self, 'self) symbol | Anext : ('self, 'self) symbol | Aentry : 'a Entry.t -> ('self, 'a) symbol | Aentryl : 'a Entry.t * int -> ('self, 'a) symbol +| Arules : 'a rules -> ('self, 'a index) symbol -type ('self, _, 'r) rule = +and ('self, _, 'r) rule = | Stop : ('self, 'r, 'r) rule | Next : ('self, 'a, 'r) rule * ('self, 'b) symbol -> ('self, 'b -> 'a, 'r) rule +and 'a rules = +| Rule0 : unit rules +| RuleS : + ('any, 'act, Loc.t -> Loc.t * 'a) rule * + ('act, 'a, Loc.t -> Loc.t * 'a) adj * + 'b rules -> ((Loc.t * 'a) * 'b) rules + type 'a production_rule = | Rule : ('a, 'act, Loc.t -> 'a) rule * 'act -> 'a production_rule diff --git a/intf/genredexpr.mli b/intf/genredexpr.mli index 613409145..ff036a13f 100644 --- a/intf/genredexpr.mli +++ b/intf/genredexpr.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/intf/glob_term.mli b/intf/glob_term.mli index 32cf9eaf1..b3159c860 100644 --- a/intf/glob_term.mli +++ b/intf/glob_term.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -29,9 +29,14 @@ type cases_pattern = | PatCstr of Loc.t * constructor * cases_pattern list * Name.t (** [PatCstr(p,C,l,x)] = "|'C' 'l' as 'x'" *) +(** Representation of an internalized (or in other words globalized) term. *) type glob_constr = | GRef of (Loc.t * global_reference * glob_level list option) + (** An identifier that represents a reference to an object defined + either in the (global) environment or in the (local) context. *) | GVar of (Loc.t * Id.t) + (** An identifier that cannot be regarded as "GRef". + Bound variables are typically represented this way. *) | GEvar of Loc.t * existential_name * (Id.t * glob_constr) list | GPatVar of Loc.t * (bool * patvar) (** Used for patterns only *) | GApp of Loc.t * glob_constr * glob_constr list @@ -39,8 +44,7 @@ type glob_constr = | GProd of Loc.t * Name.t * binding_kind * glob_constr * glob_constr | GLetIn of Loc.t * Name.t * glob_constr * glob_constr | GCases of Loc.t * case_style * glob_constr option * tomatch_tuples * cases_clauses - (** [GCases(l,style,r,tur,cc)] = "match 'tur' return 'r' with 'cc'" (in - [MatchStyle]) *) + (** [GCases(l,style,r,tur,cc)] = "match 'tur' return 'r' with 'cc'" (in [MatchStyle]) *) | GLetTuple of Loc.t * Name.t list * (Name.t * glob_constr option) * glob_constr * glob_constr | GIf of Loc.t * glob_constr * (Name.t * glob_constr option) * glob_constr * glob_constr diff --git a/intf/locus.mli b/intf/locus.mli index 808577943..57b398ab4 100644 --- a/intf/locus.mli +++ b/intf/locus.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/intf/misctypes.mli b/intf/misctypes.mli index 5c11119ed..1452bbc34 100644 --- a/intf/misctypes.mli +++ b/intf/misctypes.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -31,7 +31,8 @@ and 'constr intro_pattern_action_expr = | IntroApplyOn of 'constr * (Loc.t * 'constr intro_pattern_expr) | IntroRewrite of bool and 'constr or_and_intro_pattern_expr = - (Loc.t * 'constr intro_pattern_expr) list list + | IntroOrPattern of (Loc.t * 'constr intro_pattern_expr) list list + | IntroAndPattern of (Loc.t * 'constr intro_pattern_expr) list (** Move destination for hypothesis *) @@ -43,7 +44,10 @@ type 'id move_location = (** Sorts *) -type 'a glob_sort_gen = GProp | GSet | GType of 'a +type 'a glob_sort_gen = + | GProp (** representation of [Prop] literal *) + | GSet (** representation of [Set] literal *) + | GType of 'a (** representation of [Type] literal *) type sort_info = string Loc.located list type level_info = string Loc.located option diff --git a/intf/notation_term.mli b/intf/notation_term.mli index 5a563bf95..39a36310d 100644 --- a/intf/notation_term.mli +++ b/intf/notation_term.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -61,7 +61,7 @@ type subscopes = tmp_scope_name option * scope_name list (** Type of the meta-variables of an notation_constr: in a recursive pattern x..y, x carries the sequence of objects bound to the list x..y *) type notation_var_instance_type = - | NtnTypeConstr | NtnTypeConstrList | NtnTypeBinderList + | NtnTypeConstr | NtnTypeOnlyBinder | NtnTypeConstrList | NtnTypeBinderList (** Type of variables when interpreting a constr_expr as an notation_constr: in a recursive pattern x..y, both x and y carry the individual type diff --git a/intf/pattern.mli b/intf/pattern.mli index 18cd2df0c..329ae837e 100644 --- a/intf/pattern.mli +++ b/intf/pattern.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/intf/tacexpr.mli b/intf/tacexpr.mli index 124d4c0fe..0aa3b936c 100644 --- a/intf/tacexpr.mli +++ b/intf/tacexpr.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -122,7 +122,7 @@ 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 'a delayed_open = +type 'a delayed_open = 'a Pretyping.delayed_open = { delayed : 'r. Environ.env -> 'r Sigma.t -> ('a, 'r) Sigma.sigma } type delayed_open_constr_with_bindings = Term.constr with_bindings delayed_open @@ -142,18 +142,15 @@ type 'a gen_atomic_tactic_expr = | TacIntroMove of Id.t option * 'nam move_location | TacExact of 'trm | TacApply of advanced_flag * evars_flag * 'trm with_bindings_arg list * - (clear_flag * 'nam * 'dtrm intro_pattern_expr located option) option + ('nam * 'dtrm intro_pattern_expr located option) option | TacElim of evars_flag * 'trm with_bindings_arg * 'trm with_bindings option | TacCase of evars_flag * 'trm with_bindings_arg - | TacFix of Id.t option * int | TacMutualFix of Id.t * int * (Id.t * int * 'trm) list - | TacCofix of Id.t option | TacMutualCofix of Id.t * (Id.t * 'trm) list | TacAssert of bool * 'tacexpr option * 'dtrm intro_pattern_expr located option * 'trm | TacGeneralize of ('trm with_occurrences * Name.t) list - | TacGeneralizeDep of 'trm | TacLetTac of Name.t * 'trm * 'nam clause_expr * letin_flag * intro_pattern_naming_expr located option @@ -162,26 +159,13 @@ type 'a gen_atomic_tactic_expr = rec_flag * evars_flag * ('trm,'dtrm,'nam) induction_clause_list | TacDoubleInduction of quantified_hypothesis * quantified_hypothesis - (* Automation tactics *) - | TacTrivial of debug * 'trm list * string list option - | TacAuto of debug * int or_var option * 'trm list * string list option - (* Context management *) - | TacClear of bool * 'nam list - | TacClearBody of 'nam list - | TacMove of 'nam * 'nam move_location | TacRename of ('nam *'nam) list - (* Trmuctors *) - | TacSplit of evars_flag * 'trm bindings list - (* Conversion *) | TacReduce of ('trm,'cst,'pat) red_expr_gen * 'nam clause_expr | TacChange of 'pat option * 'dtrm * 'nam clause_expr - (* Equivalence relations *) - | TacSymmetry of 'nam clause_expr - (* Equality and inversion *) | TacRewrite of evars_flag * (bool * multi * 'dtrm with_bindings_arg) list * 'nam clause_expr * @@ -196,7 +180,6 @@ type 'a gen_atomic_tactic_expr = constraint 'a = < term:'trm; - utrm: 'utrm; dterm: 'dtrm; pattern:'pat; constant:'cst; @@ -209,11 +192,8 @@ constraint 'a = < (** Possible arguments of a tactic definition *) and 'a gen_tactic_arg = - | TacDynamic of Loc.t * Dyn.t | TacGeneric of 'lev generic_argument - | MetaIdArg of Loc.t * bool * string | ConstrMayEval of ('trm,'cst,'pat) may_eval - | UConstr of 'utrm | Reference of 'ref | TacCall of Loc.t * 'ref * 'a gen_tactic_arg list @@ -224,7 +204,6 @@ and 'a gen_tactic_arg = constraint 'a = < term:'trm; - utrm: 'utrm; dterm: 'dtrm; pattern:'pat; constant:'cst; @@ -297,13 +276,12 @@ and 'a gen_tactic_expr = | TacFun of 'a gen_tactic_fun_ast | TacArg of 'a gen_tactic_arg located (* For ML extensions *) - | TacML of Loc.t * ml_tactic_entry * 'l generic_argument list + | TacML of Loc.t * ml_tactic_entry * 'a gen_tactic_arg list (* For syntax extensions *) - | TacAlias of Loc.t * KerName.t * (Id.t * 'l generic_argument) list + | TacAlias of Loc.t * KerName.t * 'a gen_tactic_arg list constraint 'a = < term:'t; - utrm: 'utrm; dterm: 'dtrm; pattern:'p; constant:'c; @@ -318,7 +296,6 @@ and 'a gen_tactic_fun_ast = constraint 'a = < term:'t; - utrm: 'utrm; dterm: 'dtrm; pattern:'p; constant:'c; @@ -331,7 +308,6 @@ constraint 'a = < (** Globalized tactics *) type g_trm = glob_constr_and_expr -type g_utrm = g_trm 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 @@ -339,7 +315,6 @@ type g_nam = Id.t located type g_dispatch = < term:g_trm; - utrm:g_utrm; dterm:g_trm; pattern:g_pat; constant:g_cst; @@ -361,7 +336,6 @@ type glob_tactic_arg = (** Raw tactics *) type r_trm = constr_expr -type r_utrm = r_trm type r_pat = constr_pattern_expr type r_cst = reference or_by_notation type r_ref = reference @@ -370,7 +344,6 @@ type r_lev = rlevel type r_dispatch = < term:r_trm; - utrm:r_utrm; dterm:r_trm; pattern:r_pat; constant:r_cst; @@ -392,7 +365,6 @@ type raw_tactic_arg = (** Interpreted tactics *) type t_trm = Term.constr -type t_utrm = Glob_term.closed_glob_constr type t_pat = constr_pattern type t_cst = evaluable_global_reference type t_ref = ltac_constant located @@ -400,7 +372,6 @@ type t_nam = Id.t type t_dispatch = < term:t_trm; - utrm:t_utrm; dterm:g_trm; pattern:t_pat; constant:t_cst; @@ -423,3 +394,15 @@ type tactic_arg = type raw_red_expr = (r_trm, r_cst, r_pat) red_expr_gen type glob_red_expr = (g_trm, g_cst, g_pat) red_expr_gen + +(** Traces *) + +type ltac_call_kind = + | LtacMLCall of glob_tactic_expr + | LtacNotationCall of KerName.t + | LtacNameCall of ltac_constant + | LtacAtomCall of glob_atomic_tactic_expr + | LtacVarCall of Id.t * glob_tactic_expr + | LtacConstrInterp of Glob_term.glob_constr * Pretyping.ltac_var_map + +type ltac_trace = (Loc.t * ltac_call_kind) list diff --git a/intf/vernacexpr.mli b/intf/vernacexpr.mli index f89f076b5..bd5890e29 100644 --- a/intf/vernacexpr.mli +++ b/intf/vernacexpr.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -19,7 +19,6 @@ open Libnames type lident = Id.t located type lname = Name.t located type lstring = string located -type lreference = reference type class_rawexpr = FunClass | SortClass | RefClass of reference or_by_notation @@ -32,7 +31,6 @@ type goal_selector = | SelectNth of int | SelectId of Id.t | SelectAll - | SelectAllParallel type goal_identifier = string type scope_name = string @@ -40,7 +38,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 @@ -61,7 +60,6 @@ type printable = | PrintClasses | PrintTypeClasses | PrintInstances of reference or_by_notation - | PrintLtac of reference | PrintCoercions | PrintCoercionPaths of class_rawexpr * class_rawexpr | PrintCanonicalConversions @@ -69,7 +67,6 @@ type printable = | PrintHint of reference or_by_notation | PrintHintGoal | PrintHintDbName of string - | PrintRewriteHintDbName of string | PrintHintDb | PrintScopes | PrintScope of string @@ -205,7 +202,7 @@ type proof_expr = type grammar_tactic_prod_item_expr = | TacTerm of string - | TacNonTerm of Loc.t * string * (Names.Id.t * string) option + | TacNonTerm of Loc.t * string * (Names.Id.t * string) type syntax_modifier = | SetItemLevel of string list * Extend.production_level @@ -286,15 +283,13 @@ type module_binder = bool option * lident list * module_ast_inl type vernac_expr = (* Control *) | VernacLoad of verbose_flag * string - | VernacTime of vernac_list - | VernacRedirect of string * vernac_list + | VernacTime of vernac_expr located + | VernacRedirect of string * vernac_expr located | VernacTimeout of int * vernac_expr | VernacFail of vernac_expr | VernacError of exn (* always fails *) (* Syntax *) - | VernacTacticNotation of - int * grammar_tactic_prod_item_expr list * raw_tactic_expr | VernacSyntaxExtension of obsolete_locality * (lstring * syntax_modifier list) | VernacOpenCloseScope of obsolete_locality * (bool * scope_name) @@ -329,8 +324,8 @@ type vernac_expr = | VernacBeginSection of lident | VernacEndSegment of lident | VernacRequire of - lreference option * export_flag option * lreference list - | VernacImport of export_flag * lreference list + reference option * export_flag option * reference list + | VernacImport of export_flag * reference list | VernacCanonical of reference or_by_notation | VernacCoercion of obsolete_locality * reference or_by_notation * class_rawexpr * class_rawexpr @@ -364,7 +359,6 @@ type vernac_expr = (* Solving *) - | VernacSolve of goal_selector * int option * raw_tactic_expr * bool | VernacSolveExistential of int * constr_expr (* Auxiliary file and library management *) @@ -385,8 +379,6 @@ type vernac_expr = | VernacBackTo of int (* Commands *) - | VernacDeclareTacticDefinition of - (rec_flag * (reference * bool * raw_tactic_expr) list) | VernacCreateHintDb of string * bool | VernacRemoveHints of string list * reference list | VernacHints of obsolete_locality * string list * hints_expr @@ -420,7 +412,6 @@ type vernac_expr = | VernacLocate of locatable | VernacRegister of lident * register_kind | VernacComments of comment list - | VernacNop (* Stm backdoor *) | VernacStm of vernac_expr stm_vernac @@ -454,9 +445,9 @@ type vernac_expr = | VernacPolymorphic of bool * vernac_expr | VernacLocal of bool * vernac_expr -and vernac_list = located_vernac_expr list - -and located_vernac_expr = Loc.t * vernac_expr +and tacdef_body = + | TacticDefinition of Id.t Loc.located * raw_tactic_expr (* indicates that user employed ':=' in Ltac body *) + | TacticRedefinition of reference * raw_tactic_expr (* indicates that user employed '::=' in Ltac body *) (* A vernac classifier has to tell if a command: vernac_when: has to be executed now (alters the parser) or later diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c index 0553a5ed7..bf383a33a 100644 --- a/kernel/byterun/coq_interp.c +++ b/kernel/byterun/coq_interp.c @@ -22,18 +22,10 @@ #include "coq_memory.h" #include "coq_values.h" -/*spiwack : imports support functions for 64-bit integers */ -#include <caml/config.h> -#ifdef ARCH_INT64_TYPE -#include "int64_native.h" -#else -#include "int64_emul.h" -#endif - /* spiwack: I append here a few macros for value/number manipulation */ #define uint32_of_value(val) (((uint32_t)val >> 1)) #define value_of_uint32(i) ((value)(((uint32_t)(i) << 1) | 1)) -#define UI64_of_uint32(lo) ((uint64_t)(I64_literal(0,(uint32_t)(lo)))) +#define UI64_of_uint32(lo) ((uint64_t)(lo)) #define UI64_of_value(val) (UI64_of_uint32(uint32_of_value(val))) /* /spiwack */ @@ -341,6 +333,7 @@ value coq_interprete /* Fallthrough */ Instruct(ENVACC){ print_instr("ENVACC"); + print_int(*pc); accu = Field(coq_env, *pc++); Next; } @@ -371,6 +364,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; @@ -458,6 +455,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; @@ -481,11 +479,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]); @@ -585,7 +590,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; } @@ -720,6 +728,7 @@ value coq_interprete /* Fallthrough */ Instruct(GETGLOBAL){ print_instr("GETGLOBAL"); + print_int(*pc); accu = Field(coq_global_data, *pc); pc++; Next; @@ -732,7 +741,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++; @@ -743,7 +752,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; @@ -753,7 +763,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]; @@ -764,7 +775,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]; @@ -776,7 +788,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]; @@ -940,6 +953,7 @@ value coq_interprete /* Fallthrough */ Instruct(CONSTINT) { print_instr("CONSTINT"); + print_int(*pc); accu = Val_int(*pc); pc++; Next; @@ -1179,8 +1193,8 @@ value coq_interprete print_instr("MULCINT31"); uint64_t p; /*accu = 2v+1, *sp=2w+1 ==> p = 2v*w */ - p = I64_mul (UI64_of_value (accu), UI64_of_uint32 ((*sp++)^1)); - if ( I64_is_zero(p) ) { + p = UI64_of_value (accu) * UI64_of_uint32 ((*sp++)^1); + if (p == 0) { accu = (value)1; } else { @@ -1189,8 +1203,8 @@ value coq_interprete of the non-constant constructor is then 1 */ Alloc_small(accu, 2, 1); /* ( _ , arity, tag ) */ /*unsigned shift*/ - Field(accu, 0) = (value)(I64_lsr(p,31)|1) ; /*higher part*/ - Field(accu, 1) = (value)(I64_to_int32(p)|1); /*lower part*/ + Field(accu, 0) = (value)((p >> 31)|1) ; /*higher part*/ + Field(accu, 1) = (value)((int32_t)p|1); /*lower part*/ } Next; } @@ -1202,19 +1216,20 @@ value coq_interprete int62 by the int31 */ uint64_t bigint; bigint = UI64_of_value(accu); - bigint = I64_or(I64_lsl(bigint, 31),UI64_of_value(*sp++)); + bigint = (bigint << 31) | UI64_of_value(*sp++); uint64_t divisor; divisor = UI64_of_value(*sp++); Alloc_small(accu, 2, 1); /* ( _ , arity, tag ) */ - if (I64_is_zero (divisor)) { + if (divisor == 0) { Field(accu, 0) = 1; /* 2*0+1 */ Field(accu, 1) = 1; /* 2*0+1 */ } else { uint64_t quo, mod; - I64_udivmod(bigint, divisor, &quo, &mod); - Field(accu, 0) = value_of_uint32(I64_to_int32(quo)); - Field(accu, 1) = value_of_uint32(I64_to_int32(mod)); + quo = bigint / divisor; + mod = bigint % divisor; + Field(accu, 0) = value_of_uint32((uint32_t)(quo)); + Field(accu, 1) = value_of_uint32((uint32_t)(mod)); } Next; } diff --git a/kernel/byterun/coq_values.h b/kernel/byterun/coq_values.h index 80100da71..bb0f0eb5e 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_INDUCTIVE_TAG 1 -#define ATOM_PROJ_TAG 2 -#define ATOM_FIX_TAG 3 -#define ATOM_SWITCH_TAG 4 -#define ATOM_COFIX_TAG 5 -#define ATOM_COFIXEVALUATED_TAG 6 - - +#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/byterun/int64_emul.h b/kernel/byterun/int64_emul.h deleted file mode 100644 index 86bee72ed..000000000 --- a/kernel/byterun/int64_emul.h +++ /dev/null @@ -1,270 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* Software emulation of 64-bit integer arithmetic, for C compilers - that do not support it. */ - -#ifndef CAML_INT64_EMUL_H -#define CAML_INT64_EMUL_H - -#include <math.h> - -#ifdef ARCH_BIG_ENDIAN -#define I64_literal(hi,lo) { hi, lo } -#else -#define I64_literal(hi,lo) { lo, hi } -#endif - -/* Unsigned comparison */ -static int I64_ucompare(uint64 x, uint64 y) -{ - if (x.h > y.h) return 1; - if (x.h < y.h) return -1; - if (x.l > y.l) return 1; - if (x.l < y.l) return -1; - return 0; -} - -#define I64_ult(x, y) (I64_ucompare(x, y) < 0) - -/* Signed comparison */ -static int I64_compare(int64 x, int64 y) -{ - if ((int32)x.h > (int32)y.h) return 1; - if ((int32)x.h < (int32)y.h) return -1; - if (x.l > y.l) return 1; - if (x.l < y.l) return -1; - return 0; -} - -/* Negation */ -static int64 I64_neg(int64 x) -{ - int64 res; - res.l = -x.l; - res.h = ~x.h; - if (res.l == 0) res.h++; - return res; -} - -/* Addition */ -static int64 I64_add(int64 x, int64 y) -{ - int64 res; - res.l = x.l + y.l; - res.h = x.h + y.h; - if (res.l < x.l) res.h++; - return res; -} - -/* Subtraction */ -static int64 I64_sub(int64 x, int64 y) -{ - int64 res; - res.l = x.l - y.l; - res.h = x.h - y.h; - if (x.l < y.l) res.h--; - return res; -} - -/* Multiplication */ -static int64 I64_mul(int64 x, int64 y) -{ - int64 res; - uint32 prod00 = (x.l & 0xFFFF) * (y.l & 0xFFFF); - uint32 prod10 = (x.l >> 16) * (y.l & 0xFFFF); - uint32 prod01 = (x.l & 0xFFFF) * (y.l >> 16); - uint32 prod11 = (x.l >> 16) * (y.l >> 16); - res.l = prod00; - res.h = prod11 + (prod01 >> 16) + (prod10 >> 16); - prod01 = prod01 << 16; res.l += prod01; if (res.l < prod01) res.h++; - prod10 = prod10 << 16; res.l += prod10; if (res.l < prod10) res.h++; - res.h += x.l * y.h + x.h * y.l; - return res; -} - -#define I64_is_zero(x) (((x).l | (x).h) == 0) - -#define I64_is_negative(x) ((int32) (x).h < 0) - -/* Bitwise operations */ -static int64 I64_and(int64 x, int64 y) -{ - int64 res; - res.l = x.l & y.l; - res.h = x.h & y.h; - return res; -} - -static int64 I64_or(int64 x, int64 y) -{ - int64 res; - res.l = x.l | y.l; - res.h = x.h | y.h; - return res; -} - -static int64 I64_xor(int64 x, int64 y) -{ - int64 res; - res.l = x.l ^ y.l; - res.h = x.h ^ y.h; - return res; -} - -/* Shifts */ -static int64 I64_lsl(int64 x, int s) -{ - int64 res; - s = s & 63; - if (s == 0) return x; - if (s < 32) { - res.l = x.l << s; - res.h = (x.h << s) | (x.l >> (32 - s)); - } else { - res.l = 0; - res.h = x.l << (s - 32); - } - return res; -} - -static int64 I64_lsr(int64 x, int s) -{ - int64 res; - s = s & 63; - if (s == 0) return x; - if (s < 32) { - res.l = (x.l >> s) | (x.h << (32 - s)); - res.h = x.h >> s; - } else { - res.l = x.h >> (s - 32); - res.h = 0; - } - return res; -} - -static int64 I64_asr(int64 x, int s) -{ - int64 res; - s = s & 63; - if (s == 0) return x; - if (s < 32) { - res.l = (x.l >> s) | (x.h << (32 - s)); - res.h = (int32) x.h >> s; - } else { - res.l = (int32) x.h >> (s - 32); - res.h = (int32) x.h >> 31; - } - return res; -} - -/* Division and modulus */ - -#define I64_SHL1(x) x.h = (x.h << 1) | (x.l >> 31); x.l <<= 1 -#define I64_SHR1(x) x.l = (x.l >> 1) | (x.h << 31); x.h >>= 1 - -static void I64_udivmod(uint64 modulus, uint64 divisor, - uint64 * quo, uint64 * mod) -{ - int64 quotient, mask; - int cmp; - - quotient.h = 0; quotient.l = 0; - mask.h = 0; mask.l = 1; - while ((int32) divisor.h >= 0) { - cmp = I64_ucompare(divisor, modulus); - I64_SHL1(divisor); - I64_SHL1(mask); - if (cmp >= 0) break; - } - while (mask.l | mask.h) { - if (I64_ucompare(modulus, divisor) >= 0) { - quotient.h |= mask.h; quotient.l |= mask.l; - modulus = I64_sub(modulus, divisor); - } - I64_SHR1(mask); - I64_SHR1(divisor); - } - *quo = quotient; - *mod = modulus; -} - -static int64 I64_div(int64 x, int64 y) -{ - int64 q, r; - int32 sign; - - sign = x.h ^ y.h; - if ((int32) x.h < 0) x = I64_neg(x); - if ((int32) y.h < 0) y = I64_neg(y); - I64_udivmod(x, y, &q, &r); - if (sign < 0) q = I64_neg(q); - return q; -} - -static int64 I64_mod(int64 x, int64 y) -{ - int64 q, r; - int32 sign; - - sign = x.h; - if ((int32) x.h < 0) x = I64_neg(x); - if ((int32) y.h < 0) y = I64_neg(y); - I64_udivmod(x, y, &q, &r); - if (sign < 0) r = I64_neg(r); - return r; -} - -/* Coercions */ - -static int64 I64_of_int32(int32 x) -{ - int64 res; - res.l = x; - res.h = x >> 31; - return res; -} - -#define I64_to_int32(x) ((int32) (x).l) - -/* Note: we assume sizeof(intnat) = 4 here, which is true otherwise - autoconfiguration would have selected native 64-bit integers */ -#define I64_of_intnat I64_of_int32 -#define I64_to_intnat I64_to_int32 - -static double I64_to_double(int64 x) -{ - double res; - int32 sign = x.h; - if (sign < 0) x = I64_neg(x); - res = ldexp((double) x.h, 32) + x.l; - if (sign < 0) res = -res; - return res; -} - -static int64 I64_of_double(double f) -{ - int64 res; - double frac, integ; - int neg; - - neg = (f < 0); - f = fabs(f); - frac = modf(ldexp(f, -32), &integ); - res.h = (uint32) integ; - res.l = (uint32) ldexp(frac, 32); - if (neg) res = I64_neg(res); - return res; -} - -#endif /* CAML_INT64_EMUL_H */ diff --git a/kernel/byterun/int64_native.h b/kernel/byterun/int64_native.h deleted file mode 100644 index 657d0a07e..000000000 --- a/kernel/byterun/int64_native.h +++ /dev/null @@ -1,48 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* Wrapper macros around native 64-bit integer arithmetic, - so that it has the same interface as the software emulation - provided in int64_emul.h */ - -#ifndef CAML_INT64_NATIVE_H -#define CAML_INT64_NATIVE_H - -#define I64_literal(hi,lo) ((int64_t)(hi) << 32 | (lo)) -#define I64_compare(x,y) (((x) > (y)) - ((x) < (y))) -#define I64_ult(x,y) ((uint64_t)(x) < (uint64_t)(y)) -#define I64_neg(x) (-(x)) -#define I64_add(x,y) ((x) + (y)) -#define I64_sub(x,y) ((x) - (y)) -#define I64_mul(x,y) ((x) * (y)) -#define I64_is_zero(x) ((x) == 0) -#define I64_is_negative(x) ((x) < 0) -#define I64_div(x,y) ((x) / (y)) -#define I64_mod(x,y) ((x) % (y)) -#define I64_udivmod(x,y,quo,rem) \ - (*(rem) = (uint64_t)(x) % (uint64_t)(y), \ - *(quo) = (uint64_t)(x) / (uint64_t)(y)) -#define I64_and(x,y) ((x) & (y)) -#define I64_or(x,y) ((x) | (y)) -#define I64_xor(x,y) ((x) ^ (y)) -#define I64_lsl(x,y) ((x) << (y)) -#define I64_asr(x,y) ((x) >> (y)) -#define I64_lsr(x,y) ((uint64_t)(x) >> (y)) -#define I64_to_intnat(x) ((intnat) (x)) -#define I64_of_intnat(x) ((intnat) (x)) -#define I64_to_int32(x) ((int32_t) (x)) -#define I64_of_int32(x) ((int64_t) (x)) -#define I64_to_double(x) ((double)(x)) -#define I64_of_double(x) ((int64_t)(x)) - -#endif /* CAML_INT64_NATIVE_H */ diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml index 448bf8544..f9cf2691e 100644 --- a/kernel/cbytecodes.ml +++ b/kernel/cbytecodes.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -19,13 +19,13 @@ type tag = int let accu_tag = 0 -let max_atom_tag = 1 -let proj_tag = 2 -let fix_app_tag = 3 -let switch_tag = 4 -let cofix_tag = 5 -let cofix_evaluated_tag = 6 - +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 *) @@ -33,10 +33,12 @@ 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 @@ -71,7 +73,8 @@ type instruction = | Kclosure of Label.t * int | Kclosurerec of int * int * Label.t array * Label.t array | Kclosurecofix of int * int * Label.t array * Label.t array - | Kgetglobal of pconstant + (* nb fv, init, lbl types, lbl bodies *) + | Kgetglobal of constant | Kconst of structured_constant | Kmakeblock of int * tag | Kmakeprod @@ -127,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 @@ -145,18 +151,17 @@ 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 @@ -169,14 +174,24 @@ let pp_sort s = let rec pp_struct_const = function | Const_sorts s -> pp_sort s - | Const_ind ((mind, i), u) -> pr_mind mind ++ str"#" ++ int i + | 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 @@ -210,8 +225,7 @@ let rec pp_instr i = prlist_with_sep spc pp_lbl (Array.to_list lblt) ++ str " bodies = " ++ prlist_with_sep spc pp_lbl (Array.to_list lblb)) - | Kgetglobal (id,u) -> - str "getglobal " ++ pr_con id ++ str "@{" ++ Univ.Instance.pr Univ.Level.pr u ++ str "}" + | Kgetglobal idu -> str "getglobal " ++ pr_con idu | Kconst sc -> str "const " ++ pp_struct_const sc | Kmakeblock(n, m) -> @@ -269,10 +283,6 @@ and pp_bytecodes c = | i :: c -> tab () ++ pp_instr i ++ fnl () ++ pp_bytecodes c -let dump_bytecode c = - pperrnl (pp_bytecodes c); - flush_all() - (*spiwack: moved this type in this file because I needed it for retroknowledge which can't depend from cbytegen *) type block = diff --git a/kernel/cbytecodes.mli b/kernel/cbytecodes.mli index 03d638305..6fa0841af 100644 --- a/kernel/cbytecodes.mli +++ b/kernel/cbytecodes.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -15,6 +15,7 @@ type tag = int val accu_tag : tag +val type_atom_tag : tag val max_atom_tag : tag val proj_tag : tag val fix_app_tag : tag @@ -22,14 +23,18 @@ 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 @@ -64,9 +69,11 @@ 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 (** accu = coq_global_data[c] *) + | Kgetglobal of constant | Kconst of structured_constant - | Kmakeblock of (* size: *) int * tag (** allocate an ocaml block *) + | 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 *) @@ -120,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 @@ -129,26 +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_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 *) - (** recursives = nbr *) + (** (= 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 dump_bytecode : 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 3462694d6..77eac9ee9 100644 --- a/kernel/cbytegen.ml +++ b/kernel/cbytegen.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -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; @@ -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,18 +547,17 @@ let rec compile_fv reloc l sz cont = (* Compiling constants *) -let rec get_alias 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 - | BCalias (kn',u') -> get_alias 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" @@ -552,9 +574,44 @@ let rec 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 :: @@ -663,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 @@ -745,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 @@ -756,31 +827,84 @@ and compile_const = (mkConstU (kn,u)) reloc args sz cont with Not_found -> if Int.equal nargs 0 then - Kgetglobal (get_alias !global_env (kn, u)) :: cont + compile_get_global reloc (kn,u) sz cont else - comp_app (fun _ _ _ cont -> - Kgetglobal (get_alias !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 fv = List.rev (!(reloc.in_env).fv_rev) in - let pp_v v = - match v with - | FVnamed id -> Pp.str (Id.to_string id) - | FVrel i -> Pp.str (string_of_int i) + 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 open Pp in - if !Flags.dump_bytecode then - (dump_bytecode init_code; - dump_bytecode !fun_code; - Pp.msg_debug (Pp.str "fv = " ++ - Pp.prlist_with_sep (fun () -> Pp.str "; ") pp_v fv ++ Pp.fnl ())); + let fv = List.rev (!(reloc.in_env).fv_rev) in + (if !Flags.dump_bytecode then + Pp.msg_debug (dump_bytecodes init_code !fun_code fv)) ; 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 @@ -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 (BCalias (get_alias 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) = BCalias (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 @@ -902,14 +1031,14 @@ let op2_compilation op = 3/ if at least one is not, branches to the normal behavior: 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_alias !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_alias !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 1128f0d0b..c0f48641c 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 4e64ed697..d779a81ff 100644 --- a/kernel/cemitcodes.ml +++ b/kernel/cemitcodes.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -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 @@ -135,11 +135,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 @@ -198,7 +198,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) @@ -306,8 +306,6 @@ let init () = type emitcodes = string -let copy = String.copy - let length = String.length type to_patch = emitcodes * (patch list) * fv @@ -315,10 +313,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 @@ -327,21 +325,19 @@ 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 -let subst_pconstant s (kn, u) = (fst (subst_con_kn s kn), u) - type body_code = | BCdefined of to_patch - | BCalias of pconstant + | BCalias of Names.constant | BCconstant type to_patch_substituted = | PBCdefined of to_patch substituted -| PBCalias of pconstant substituted +| PBCalias of Names.constant substituted | PBCconstant let from_val = function @@ -351,7 +347,7 @@ let from_val = function let force = function | PBCdefined tp -> BCdefined (force subst_to_patch tp) -| PBCalias cu -> BCalias (force subst_pconstant cu) +| PBCalias cu -> BCalias (force subst_constant cu) | PBCconstant -> BCconstant let subst_to_patch_subst s = function @@ -383,8 +379,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 398b60eca..c80edd596 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 @@ -23,7 +23,7 @@ val subst_to_patch : Mod_subst.substitution -> to_patch -> to_patch type body_code = | BCdefined of to_patch - | BCalias of constant Univ.puniverses + | BCalias of constant | BCconstant diff --git a/kernel/closure.ml b/kernel/closure.ml index bc414d971..bf3801e54 100644 --- a/kernel/closure.ml +++ b/kernel/closure.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -245,10 +245,12 @@ and 'a infos = { let info_flags info = info.i_flags let info_env info = info.i_cache.i_env +open Context.Named.Declaration + let rec assoc_defined id = function | [] -> raise Not_found -| (_, None, _) :: ctxt -> assoc_defined id ctxt -| (id', Some c, _) :: ctxt -> +| LocalAssum _ :: ctxt -> assoc_defined id ctxt +| LocalDef (id', c, _) :: ctxt -> if Id.equal id id' then c else assoc_defined id ctxt let ref_value_cache ({i_cache = cache} as infos) ref = @@ -285,9 +287,10 @@ let defined_rels flags env = let ctx = rel_context env in let len = List.length ctx in let ans = Array.make len None in - let iter i (_, b, _) = match b with - | None -> () - | Some _ -> Array.unsafe_set ans i b + let open Context.Rel.Declaration in + let iter i = function + | LocalAssum _ -> () + | LocalDef (_,b,_) -> Array.unsafe_set ans i (Some b) in let () = List.iteri iter ctx in ans @@ -762,7 +765,7 @@ let drop_parameters depth n argstk = (* we know that n < stack_args_size(argstk) (if well-typed term) *) anomaly (Pp.str "ill-typed term: found a match on a partially applied constructor") -(** [eta_expand_ind_stack env ind c s t] computes stacks correspoding +(** [eta_expand_ind_stack env ind c s t] computes stacks corresponding to the conversion of the eta expansion of t, considered as an inhabitant of ind, and the Constructor c of this inductive type applied to arguments s. @@ -775,7 +778,7 @@ let eta_expand_ind_stack env ind m s (f, s') = let mib = lookup_mind (fst ind) env in match mib.Declarations.mind_record with | Some (Some (_,projs,pbs)) when - mib.Declarations.mind_finite <> Decl_kinds.CoFinite -> + mib.Declarations.mind_finite == Decl_kinds.BiFinite -> (* (Construct, pars1 .. parsm :: arg1...argn :: []) ~= (f, s') -> arg1..argn ~= (proj1 t...projn t) where t = zip (f,s') *) let pars = mib.Declarations.mind_nparams in diff --git a/kernel/closure.mli b/kernel/closure.mli index c6f212aa5..07176cb7d 100644 --- a/kernel/closure.mli +++ b/kernel/closure.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/kernel/constr.ml b/kernel/constr.ml index 753d18845..ce20751ab 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -41,12 +41,24 @@ type case_printing = { ind_tags : bool list; (** tell whether letin or lambda in the arity of the inductive type *) cstr_tags : bool list array; (* whether each pattern var of each constructor is a let-in (true) or not (false) *) style : case_style } + +(* INVARIANT: + * - Array.length ci_cstr_ndecls = Array.length ci_cstr_nargs + * - forall (i : 0 .. pred (Array.length ci_cstr_ndecls)), + * ci_cstr_ndecls.(i) >= ci_cstr_nargs.(i) + *) type case_info = - { ci_ind : inductive; - ci_npar : int; - ci_cstr_ndecls : int array; (* number of pattern vars of each constructor (with let's)*) - ci_cstr_nargs : int array; (* number of pattern vars of each constructor (w/o let's) *) - ci_pp_info : case_printing (* not interpreted by the kernel *) + { ci_ind : inductive; (* inductive type to which belongs the value that is being matched *) + ci_npar : int; (* number of parameters of the above inductive type *) + ci_cstr_ndecls : int array; (* For each constructor, the corresponding integer determines + the number of values that can be bound in a match-construct. + NOTE: parameters of the inductive type are therefore excluded from the count *) + ci_cstr_nargs : int array; (* for each constructor, the corresponding integers determines + the number of values that can be applied to the constructor, + in addition to the parameters of the related inductive type + NOTE: "lets" are therefore excluded from the count + NOTE: parameters of the inductive type are also excluded from the count *) + ci_pp_info : case_printing (* not interpreted by the kernel *) } (********************************************************************) @@ -732,12 +744,10 @@ let hasheq t1 t2 = n1 == n2 && b1 == b2 && t1 == t2 && c1 == c2 | App (c1,l1), App (c2,l2) -> c1 == c2 && array_eqeq l1 l2 | Proj (p1,c1), Proj(p2,c2) -> p1 == p2 && c1 == c2 - | Evar (e1,l1), Evar (e2,l2) -> Evar.equal e1 e2 && array_eqeq l1 l2 + | Evar (e1,l1), Evar (e2,l2) -> e1 == e2 && array_eqeq l1 l2 | Const (c1,u1), Const (c2,u2) -> c1 == c2 && u1 == u2 - | Ind ((sp1,i1),u1), Ind ((sp2,i2),u2) -> - sp1 == sp2 && Int.equal i1 i2 && u1 == u2 - | Construct (((sp1,i1),j1),u1), Construct (((sp2,i2),j2),u2) -> - sp1 == sp2 && Int.equal i1 i2 && Int.equal j1 j2 && u1 == u2 + | Ind (ind1,u1), Ind (ind2,u2) -> ind1 == ind2 && u1 == u2 + | Construct (cstr1,u1), Construct (cstr2,u2) -> cstr1 == cstr2 && u1 == u2 | Case (ci1,p1,c1,bl1), Case (ci2,p2,c2,bl2) -> ci1 == ci2 && p1 == p2 && c1 == c2 && array_eqeq bl1 bl2 | Fix ((ln1, i1),(lna1,tl1,bl1)), Fix ((ln2, i2),(lna2,tl2,bl2)) -> @@ -757,10 +767,10 @@ let hasheq t1 t2 = once and for all the table we'll use for hash-consing all constr *) module HashsetTerm = - Hashset.Make(struct type t = constr let equal = hasheq end) + Hashset.Make(struct type t = constr let eq = hasheq end) module HashsetTermArray = - Hashset.Make(struct type t = constr array let equal = array_eqeq end) + Hashset.Make(struct type t = constr array let eq = array_eqeq end) let term_table = HashsetTerm.create 19991 (* The associative table to hashcons terms. *) @@ -815,19 +825,19 @@ let hashcons (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) = | Proj (p,c) -> let c, hc = sh_rec c in let p' = Projection.hcons p in - (Proj (p', c), combinesmall 17 (combine (Projection.hash p') hc)) + (Proj (p', c), combinesmall 17 (combine (Projection.SyntacticOrd.hash p') hc)) | Const (c,u) -> let c' = sh_con c in let u', hu = sh_instance u in - (Const (c', u'), combinesmall 9 (combine (Constant.hash c) hu)) - | Ind ((kn,i) as ind,u) -> + (Const (c', u'), combinesmall 9 (combine (Constant.SyntacticOrd.hash c) hu)) + | Ind (ind,u) -> let u', hu = sh_instance u in (Ind (sh_ind ind, u'), - combinesmall 10 (combine (ind_hash ind) hu)) - | Construct ((((kn,i),j) as c,u))-> + combinesmall 10 (combine (ind_syntactic_hash ind) hu)) + | Construct (c,u) -> let u', hu = sh_instance u in (Construct (sh_construct c, u'), - combinesmall 11 (combine (constructor_hash c) hu)) + combinesmall 11 (combine (constructor_syntactic_hash c) hu)) | Case (ci,p,c,bl) -> let p, hp = sh_rec p and c, hc = sh_rec c in @@ -930,7 +940,7 @@ struct List.equal (==) info1.ind_tags info2.ind_tags && Array.equal (List.equal (==)) info1.cstr_tags info2.cstr_tags && info1.style == info2.style - let equal ci ci' = + let eq ci ci' = ci.ci_ind == ci'.ci_ind && Int.equal ci.ci_npar ci'.ci_npar && Array.equal Int.equal ci.ci_cstr_ndecls ci'.ci_cstr_ndecls && (* we use [Array.equal] on purpose *) @@ -972,7 +982,7 @@ module Hsorts = let hashcons huniv = function Prop c -> Prop c | Type u -> Type (huniv u) - let equal s1 s2 = + let eq s1 s2 = s1 == s2 || match (s1,s2) with (Prop c1, Prop c2) -> c1 == c2 diff --git a/kernel/constr.mli b/kernel/constr.mli index 5a370d31d..f76b5ae4f 100644 --- a/kernel/constr.mli +++ b/kernel/constr.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -30,13 +30,23 @@ type case_printing = cstr_tags : bool list array; (** tell whether letin or lambda in the signature of each constructor *) style : case_style } -(** the integer is the number of real args, needed for reduction *) +(* INVARIANT: + * - Array.length ci_cstr_ndecls = Array.length ci_cstr_nargs + * - forall (i : 0 .. pred (Array.length ci_cstr_ndecls)), + * ci_cstr_ndecls.(i) >= ci_cstr_nargs.(i) + *) type case_info = - { ci_ind : inductive; - ci_npar : int; - ci_cstr_ndecls : int array; (* number of pattern vars of each constructor (with let's)*) - ci_cstr_nargs : int array; (* number of pattern vars of each constructor (w/o let's) *) - ci_pp_info : case_printing (** not interpreted by the kernel *) + { ci_ind : inductive; (* inductive type to which belongs the value that is being matched *) + ci_npar : int; (* number of parameters of the above inductive type *) + ci_cstr_ndecls : int array; (* For each constructor, the corresponding integer determines + the number of values that can be bound in a match-construct. + NOTE: parameters of the inductive type are therefore excluded from the count *) + ci_cstr_nargs : int array; (* for each constructor, the corresponding integers determines + the number of values that can be applied to the constructor, + in addition to the parameters of the related inductive type + NOTE: "lets" are therefore excluded from the count + NOTE: parameters of the inductive type are also excluded from the count *) + ci_pp_info : case_printing (* not interpreted by the kernel *) } (** {6 The type of constructions } *) @@ -93,8 +103,9 @@ val mkLambda : Name.t * types * constr -> constr (** Constructs the product [let x = t1 : t2 in t3] *) val mkLetIn : Name.t * constr * types * constr -> constr -(** [mkApp (f,[| t_1; ...; t_n |]] constructs the application - {% $(f~t_1~\dots~t_n)$ %}. *) +(** [mkApp (f, [|t1; ...; tN|]] constructs the application + {%html:(f t<sub>1</sub> ... t<sub>n</sub>)%} + {%latex:$(f~t_1\dots f_n)$%}. *) val mkApp : constr * constr array -> constr val map_puniverses : ('a -> 'b) -> 'a puniverses -> 'b puniverses @@ -181,10 +192,13 @@ type ('constr, 'types) kind_of_term = | Evar of 'constr pexistential | Sort of Sorts.t | Cast of 'constr * cast_kind * 'types - | Prod of Name.t * 'types * 'types - | Lambda of Name.t * 'types * 'constr - | LetIn of Name.t * 'constr * 'types * 'constr - | App of 'constr * 'constr array + | Prod of Name.t * 'types * 'types (** Concrete syntax ["forall A:B,C"] is represented as [Prod (A,B,C)]. *) + | Lambda of Name.t * 'types * 'constr (** Concrete syntax ["fun A:B => C"] is represented as [Lambda (A,B,C)]. *) + | LetIn of Name.t * 'constr * 'types * 'constr (** Concrete syntax ["let A:B := C in D"] is represented as [LetIn (A,B,C,D)]. *) + | App of 'constr * 'constr array (** Concrete syntax ["(F P1 P2 ... Pn)"] is represented as [App (F, [|P1; P2; ...; Pn|])]. + The {!mkApp} constructor also enforces the following invariant: + - [F] itself is not {!App} + - and [[|P1;..;Pn|]] is not empty. *) | Const of constant puniverses | Ind of inductive puniverses | Construct of constructor puniverses diff --git a/kernel/context.ml b/kernel/context.ml index 796f06d37..4e53b73a2 100644 --- a/kernel/context.ml +++ b/kernel/context.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -15,123 +15,409 @@ (* This file defines types and combinators regarding indexes-based and names-based contexts *) -open Util -open Names - -(***************************************************************************) -(* Type of assumptions *) -(***************************************************************************) - -type named_declaration = Id.t * Constr.t option * Constr.t -type named_list_declaration = Id.t list * Constr.t option * Constr.t -type rel_declaration = Name.t * Constr.t option * Constr.t - -let map_named_declaration_skel f (id, (v : Constr.t option), ty) = - (id, Option.map f v, f ty) -let map_named_list_declaration = map_named_declaration_skel -let map_named_declaration = map_named_declaration_skel - -let map_rel_declaration = map_named_declaration - -let fold_named_declaration f (_, v, ty) a = f ty (Option.fold_right f v a) -let fold_rel_declaration = fold_named_declaration - -let exists_named_declaration f (_, v, ty) = Option.cata f false v || f ty -let exists_rel_declaration f (_, v, ty) = Option.cata f false v || f ty - -let for_all_named_declaration f (_, v, ty) = Option.cata f true v && f ty -let for_all_rel_declaration f (_, v, ty) = Option.cata f true v && f ty - -let eq_named_declaration (i1, c1, t1) (i2, c2, t2) = - Id.equal i1 i2 && Option.equal Constr.equal c1 c2 && Constr.equal t1 t2 - -let eq_rel_declaration (n1, c1, t1) (n2, c2, t2) = - Name.equal n1 n2 && Option.equal Constr.equal c1 c2 && Constr.equal t1 t2 - -(***************************************************************************) -(* Type of local contexts (telescopes) *) -(***************************************************************************) - -(*s Signatures of ordered optionally named variables, intended to be - accessed by de Bruijn indices (to represent bound variables) *) - -type rel_context = rel_declaration list - -let empty_rel_context = [] - -let add_rel_decl d ctxt = d::ctxt +(** The modules defined below represent a {e local context} + as defined by Chapter 4 in the Reference Manual: -let rec lookup_rel n sign = - match n, sign with - | 1, decl :: _ -> decl - | n, _ :: sign -> lookup_rel (n-1) sign - | _, [] -> raise Not_found + A {e local context} is an ordered list of of {e local declarations} + of names that we call {e variables}. -let rel_context_length = List.length + A {e local declaration} of some variable can be either: + - a {e local assumption}, or + - a {e local definition}. +*) -let rel_context_nhyps hyps = - let rec nhyps acc = function - | [] -> acc - | (_,None,_)::hyps -> nhyps (1+acc) hyps - | (_,Some _,_)::hyps -> nhyps acc hyps in - nhyps 0 hyps - -let rel_context_tags ctx = - let rec aux l = function - | [] -> l - | (_,Some _,_)::ctx -> aux (true::l) ctx - | (_,None,_)::ctx -> aux (false::l) ctx - in aux [] ctx - -(*s Signatures of named hypotheses. Used for section variables and - goal assumptions. *) - -type named_context = named_declaration list -type named_list_context = named_list_declaration list - -let empty_named_context = [] - -let add_named_decl d sign = d::sign - -let rec lookup_named id = function - | (id',_,_ as decl) :: _ when Id.equal id id' -> decl - | _ :: sign -> lookup_named id sign - | [] -> raise Not_found - -let named_context_length = List.length -let named_context_equal = List.equal eq_named_declaration - -let vars_of_named_context ctx = - List.fold_left (fun accu (id, _, _) -> Id.Set.add id accu) Id.Set.empty ctx - -let instance_from_named_context sign = - let filter = function - | (id, None, _) -> Some (Constr.mkVar id) - | (_, Some _, _) -> None - in - List.map_filter filter sign - -let fold_named_context f l ~init = List.fold_right f l init -let fold_named_list_context f l ~init = List.fold_right f l init -let fold_named_context_reverse f ~init l = List.fold_left f init l - -(*s Signatures of ordered section variables *) -type section_context = named_context - -let fold_rel_context f l ~init:x = List.fold_right f l x -let fold_rel_context_reverse f ~init:x l = List.fold_left f x l - -let map_context f l = - let map_decl (n, body_o, typ as decl) = - let body_o' = Option.smartmap f body_o in - let typ' = f typ in - if body_o' == body_o && typ' == typ then decl else - (n, body_o', typ') - in - List.smartmap map_decl l - -let map_rel_context = map_context -let map_named_context = map_context +open Util +open Names -let iter_rel_context f = List.iter (fun (_,b,t) -> f t; Option.iter f b) -let iter_named_context f = List.iter (fun (_,b,t) -> f t; Option.iter f b) +(** Representation of contexts that can capture anonymous as well as non-anonymous variables. + Individual declarations are then designated by de Bruijn indexes. *) +module Rel = +struct + (** Representation of {e local declarations}. *) + module Declaration = + struct + (* local declaration *) + type t = + | LocalAssum of Name.t * Constr.t (** name, type *) + | LocalDef of Name.t * Constr.t * Constr.t (** name, value, type *) + + (** Return the name bound by a given declaration. *) + let get_name = function + | LocalAssum (na,_) + | LocalDef (na,_,_) -> na + + (** Return [Some value] for local-declarations and [None] for local-assumptions. *) + let get_value = function + | LocalAssum _ -> None + | LocalDef (_,v,_) -> Some v + + (** Return the type of the name bound by a given declaration. *) + let get_type = function + | LocalAssum (_,ty) + | LocalDef (_,_,ty) -> ty + + (** Set the name that is bound by a given declaration. *) + let set_name na = function + | LocalAssum (_,ty) -> LocalAssum (na, ty) + | LocalDef (_,v,ty) -> LocalDef (na, v, ty) + + (** Set the type of the bound variable in a given declaration. *) + let set_type ty = function + | LocalAssum (na,_) -> LocalAssum (na, ty) + | LocalDef (na,v,_) -> LocalDef (na, v, ty) + + (** Return [true] iff a given declaration is a local assumption. *) + let is_local_assum = function + | LocalAssum _ -> true + | LocalDef _ -> false + + (** Return [true] iff a given declaration is a local definition. *) + let is_local_def = function + | LocalAssum _ -> false + | LocalDef _ -> true + + (** Check whether any term in a given declaration satisfies a given predicate. *) + let exists f = function + | LocalAssum (_, ty) -> f ty + | LocalDef (_, v, ty) -> f v || f ty + + (** Check whether all terms in a given declaration satisfy a given predicate. *) + let for_all f = function + | LocalAssum (_, ty) -> f ty + | LocalDef (_, v, ty) -> f v && f ty + + (** Check whether the two given declarations are equal. *) + let equal decl1 decl2 = + match decl1, decl2 with + | LocalAssum (n1,ty1), LocalAssum (n2, ty2) -> + Name.equal n1 n2 && Constr.equal ty1 ty2 + | LocalDef (n1,v1,ty1), LocalDef (n2,v2,ty2) -> + Name.equal n1 n2 && Constr.equal v1 v2 && Constr.equal ty1 ty2 + | _ -> + false + + (** Map the name bound by a given declaration. *) + let map_name f = function + | LocalAssum (na, ty) as decl -> + let na' = f na in + if na == na' then decl else LocalAssum (na', ty) + | LocalDef (na, v, ty) as decl -> + let na' = f na in + if na == na' then decl else LocalDef (na', v, ty) + + (** For local assumptions, this function returns the original local assumptions. + For local definitions, this function maps the value in the local definition. *) + let map_value f = function + | LocalAssum _ as decl -> decl + | LocalDef (na, v, t) as decl -> + let v' = f v in + if v == v' then decl else LocalDef (na, v', t) + + (** Map the type of the name bound by a given declaration. *) + let map_type f = function + | LocalAssum (na, ty) as decl -> + let ty' = f ty in + if ty == ty' then decl else LocalAssum (na, ty') + | LocalDef (na, v, ty) as decl -> + let ty' = f ty in + if ty == ty' then decl else LocalDef (na, v, ty') + + (** Map all terms in a given declaration. *) + let map_constr f = function + | LocalAssum (na, ty) as decl -> + let ty' = f ty in + if ty == ty' then decl else LocalAssum (na, ty') + | LocalDef (na, v, ty) as decl -> + let v' = f v in + let ty' = f ty in + if v == v' && ty == ty' then decl else LocalDef (na, v', ty') + + (** Perform a given action on all terms in a given declaration. *) + let iter_constr f = function + | LocalAssum (_,ty) -> f ty + | LocalDef (_,v,ty) -> f v; f ty + + (** Reduce all terms in a given declaration to a single value. *) + let fold f decl acc = + match decl with + | LocalAssum (n,ty) -> f ty acc + | LocalDef (n,v,ty) -> f ty (f v acc) + + let to_tuple = function + | LocalAssum (na, ty) -> na, None, ty + | LocalDef (na, v, ty) -> na, Some v, ty + + let of_tuple = function + | n, None, ty -> LocalAssum (n,ty) + | n, Some v, ty -> LocalDef (n,v,ty) + end + + (** Rel-context is represented as a list of declarations. + Inner-most declarations are at the beginning of the list. + Outer-most declarations are at the end of the list. *) + type t = Declaration.t list + + (** empty rel-context *) + let empty = [] + + (** Return a new rel-context enriched by with a given inner-most declaration. *) + let add d ctx = d :: ctx + + (** Return the number of {e local declarations} in a given context. *) + let length = List.length + + (** [extended_rel_list n Γ] builds an instance [args] such that [Γ,Δ ⊢ args:Γ] + with n = |Δ| and with the local definitions of [Γ] skipped in + [args]. Example: for [x:T,y:=c,z:U] and [n]=2, it gives [Rel 5, Rel 3]. *) + let nhyps = + let open Declaration in + let rec nhyps acc = function + | [] -> acc + | LocalAssum _ :: hyps -> nhyps (succ acc) hyps + | LocalDef _ :: hyps -> nhyps acc hyps + in + nhyps 0 + + (** Return a declaration designated by a given de Bruijn index. + @raise Not_found if the designated de Bruijn index is not present in the designated rel-context. *) + let rec lookup n ctx = + match n, ctx with + | 1, decl :: _ -> decl + | n, _ :: sign -> lookup (n-1) sign + | _, [] -> raise Not_found + + (** Check whether given two rel-contexts are equal. *) + let equal = List.equal Declaration.equal + + (** Map all terms in a given rel-context. *) + let map f = List.smartmap (Declaration.map_constr f) + + (** Perform a given action on every declaration in a given rel-context. *) + let iter f = List.iter (Declaration.iter_constr f) + + (** Reduce all terms in a given rel-context to a single value. + Innermost declarations are processed first. *) + let fold_inside f ~init = List.fold_left f init + + (** Reduce all terms in a given rel-context to a single value. + Outermost declarations are processed first. *) + let fold_outside f l ~init = List.fold_right f l init + + (** Map a given rel-context to a list where each {e local assumption} is mapped to [true] + and each {e local definition} is mapped to [false]. *) + let to_tags = + let rec aux l = function + | [] -> l + | Declaration.LocalDef _ :: ctx -> aux (true::l) ctx + | Declaration.LocalAssum _ :: ctx -> aux (false::l) ctx + in aux [] + + (** [extended_list n Γ] builds an instance [args] such that [Γ,Δ ⊢ args:Γ] + with n = |Δ| and with the {e local definitions} of [Γ] skipped in + [args]. Example: for [x:T, y:=c, z:U] and [n]=2, it gives [Rel 5, Rel 3]. *) + let to_extended_list n = + let rec reln l p = function + | Declaration.LocalAssum _ :: hyps -> reln (Constr.mkRel (n+p) :: l) (p+1) hyps + | Declaration.LocalDef _ :: hyps -> reln l (p+1) hyps + | [] -> l + in + reln [] 1 + + (** [extended_vect n Γ] does the same, returning instead an array. *) + let to_extended_vect n hyps = Array.of_list (to_extended_list n hyps) +end + +(** This module represents contexts that can capture non-anonymous variables. + Individual declarations are then designated by the identifiers they bind. *) +module Named = +struct + (** Representation of {e local declarations}. *) + module Declaration = + struct + (** local declaration *) + type t = + | LocalAssum of Id.t * Constr.t (** identifier, type *) + | LocalDef of Id.t * Constr.t * Constr.t (** identifier, value, type *) + + (** Return the identifier bound by a given declaration. *) + let get_id = function + | LocalAssum (id,_) -> id + | LocalDef (id,_,_) -> id + + (** Return [Some value] for local-declarations and [None] for local-assumptions. *) + let get_value = function + | LocalAssum _ -> None + | LocalDef (_,v,_) -> Some v + + (** Return the type of the name bound by a given declaration. *) + let get_type = function + | LocalAssum (_,ty) + | LocalDef (_,_,ty) -> ty + + (** Set the identifier that is bound by a given declaration. *) + let set_id id = function + | LocalAssum (_,ty) -> LocalAssum (id, ty) + | LocalDef (_, v, ty) -> LocalDef (id, v, ty) + + (** Set the type of the bound variable in a given declaration. *) + let set_type ty = function + | LocalAssum (id,_) -> LocalAssum (id, ty) + | LocalDef (id,v,_) -> LocalDef (id, v, ty) + + (** Return [true] iff a given declaration is a local assumption. *) + let is_local_assum = function + | LocalAssum _ -> true + | LocalDef _ -> false + + (** Return [true] iff a given declaration is a local definition. *) + let is_local_def = function + | LocalDef _ -> true + | LocalAssum _ -> false + + (** Check whether any term in a given declaration satisfies a given predicate. *) + let exists f = function + | LocalAssum (_, ty) -> f ty + | LocalDef (_, v, ty) -> f v || f ty + + (** Check whether all terms in a given declaration satisfy a given predicate. *) + let for_all f = function + | LocalAssum (_, ty) -> f ty + | LocalDef (_, v, ty) -> f v && f ty + + (** Check whether the two given declarations are equal. *) + let equal decl1 decl2 = + match decl1, decl2 with + | LocalAssum (id1, ty1), LocalAssum (id2, ty2) -> + Id.equal id1 id2 && Constr.equal ty1 ty2 + | LocalDef (id1, v1, ty1), LocalDef (id2, v2, ty2) -> + Id.equal id1 id2 && Constr.equal v1 v2 && Constr.equal ty1 ty2 + | _ -> + false + + (** Map the identifier bound by a given declaration. *) + let map_id f = function + | LocalAssum (id, ty) as decl -> + let id' = f id in + if id == id' then decl else LocalAssum (id', ty) + | LocalDef (id, v, ty) as decl -> + let id' = f id in + if id == id' then decl else LocalDef (id', v, ty) + + (** For local assumptions, this function returns the original local assumptions. + For local definitions, this function maps the value in the local definition. *) + let map_value f = function + | LocalAssum _ as decl -> decl + | LocalDef (na, v, t) as decl -> + let v' = f v in + if v == v' then decl else LocalDef (na, v', t) + + (** Map the type of the name bound by a given declaration. *) + let map_type f = function + | LocalAssum (id, ty) as decl -> + let ty' = f ty in + if ty == ty' then decl else LocalAssum (id, ty') + | LocalDef (id, v, ty) as decl -> + let ty' = f ty in + if ty == ty' then decl else LocalDef (id, v, ty') + + (** Map all terms in a given declaration. *) + let map_constr f = function + | LocalAssum (id, ty) as decl -> + let ty' = f ty in + if ty == ty' then decl else LocalAssum (id, ty') + | LocalDef (id, v, ty) as decl -> + let v' = f v in + let ty' = f ty in + if v == v' && ty == ty' then decl else LocalDef (id, v', ty') + + (** Perform a given action on all terms in a given declaration. *) + let iter_constr f = function + | LocalAssum (_, ty) -> f ty + | LocalDef (_, v, ty) -> f v; f ty + + (** Reduce all terms in a given declaration to a single value. *) + let fold f decl a = + match decl with + | LocalAssum (_, ty) -> f ty a + | LocalDef (_, v, ty) -> a |> f v |> f ty + + let to_tuple = function + | LocalAssum (id, ty) -> id, None, ty + | LocalDef (id, v, ty) -> id, Some v, ty + + let of_tuple = function + | id, None, ty -> LocalAssum (id, ty) + | id, Some v, ty -> LocalDef (id, v, ty) + end + + (** Named-context is represented as a list of declarations. + Inner-most declarations are at the beginning of the list. + Outer-most declarations are at the end of the list. *) + type t = Declaration.t list + + (** empty named-context *) + let empty = [] + + (** empty named-context *) + let add d ctx = d :: ctx + + (** Return the number of {e local declarations} in a given named-context. *) + let length = List.length + +(** Return a declaration designated by a given de Bruijn index. + @raise Not_found if the designated identifier is not present in the designated named-context. *) let rec lookup id = function + | decl :: _ when Id.equal id (Declaration.get_id decl) -> decl + | _ :: sign -> lookup id sign + | [] -> raise Not_found + + (** Check whether given two named-contexts are equal. *) + let equal = List.equal Declaration.equal + + (** Map all terms in a given named-context. *) + let map f = List.smartmap (Declaration.map_constr f) + + (** Perform a given action on every declaration in a given named-context. *) + let iter f = List.iter (Declaration.iter_constr f) + + (** Reduce all terms in a given named-context to a single value. + Innermost declarations are processed first. *) + let fold_inside f ~init = List.fold_left f init + + (** Reduce all terms in a given named-context to a single value. + Outermost declarations are processed first. *) + let fold_outside f l ~init = List.fold_right f l init + + (** Return the set of all identifiers bound in a given named-context. *) + let to_vars = + List.fold_left (fun accu decl -> Id.Set.add (Declaration.get_id decl) accu) Id.Set.empty + + (** [instance_from_named_context Ω] builds an instance [args] such + that [Ω ⊢ args:Ω] where [Ω] is a named context and with the local + definitions of [Ω] skipped. Example: for [id1:T,id2:=c,id3:U], it + gives [Var id1, Var id3]. All [idj] are supposed distinct. *) + let to_instance = + let filter = function + | Declaration.LocalAssum (id, _) -> Some (Constr.mkVar id) + | _ -> None + in + List.map_filter filter + end + +module NamedList = + struct + module Declaration = + struct + type t = Id.t list * Constr.t option * Constr.t + + let map_constr f (ids, copt, ty as decl) = + let copt' = Option.map f copt in + let ty' = f ty in + if copt == copt' && ty == ty' then decl else (ids, copt', ty') + end + + type t = Declaration.t list + + let fold f l ~init = List.fold_right f l init + end + +type section_context = Named.t diff --git a/kernel/context.mli b/kernel/context.mli index 5279aefb6..b5f3904d2 100644 --- a/kernel/context.mli +++ b/kernel/context.mli @@ -1,122 +1,260 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +(** The modules defined below represent a {e local context} + as defined by Chapter 4 in the Reference Manual: + + A {e local context} is an ordered list of of {e local declarations} + of names that we call {e variables}. + + A {e local declaration} of some variable can be either: + - a {e local assumption}, or + - a {e local definition}. + + {e Local assumptions} are denoted in the Reference Manual as [(name : typ)] and + {e local definitions} are there denoted as [(name := value : typ)]. +*) + open Names -(** TODO: cleanup *) +(** Representation of contexts that can capture anonymous as well as non-anonymous variables. + Individual declarations are then designated by de Bruijn indexes. *) +module Rel : +sig + module Declaration : + sig + (* local declaration *) + type t = LocalAssum of Name.t * Constr.t (** name, type *) + | LocalDef of Name.t * Constr.t * Constr.t (** name, value, type *) + + (** Return the name bound by a given declaration. *) + val get_name : t -> Name.t + + (** Return [Some value] for local-declarations and [None] for local-assumptions. *) + val get_value : t -> Constr.t option + + (** Return the type of the name bound by a given declaration. *) + val get_type : t -> Constr.t + + (** Set the name that is bound by a given declaration. *) + val set_name : Name.t -> t -> t + + (** Set the type of the bound variable in a given declaration. *) + val set_type : Constr.t -> t -> t + + (** Return [true] iff a given declaration is a local assumption. *) + val is_local_assum : t -> bool + + (** Return [true] iff a given declaration is a local definition. *) + val is_local_def : t -> bool + + (** Check whether any term in a given declaration satisfies a given predicate. *) + val exists : (Constr.t -> bool) -> t -> bool + + (** Check whether all terms in a given declaration satisfy a given predicate. *) + val for_all : (Constr.t -> bool) -> t -> bool + + (** Check whether the two given declarations are equal. *) + val equal : t -> t -> bool + + (** Map the name bound by a given declaration. *) + val map_name : (Name.t -> Name.t) -> t -> t + + (** For local assumptions, this function returns the original local assumptions. + For local definitions, this function maps the value in the local definition. *) + val map_value : (Constr.t -> Constr.t) -> t -> t + + (** Map the type of the name bound by a given declaration. *) + val map_type : (Constr.t -> Constr.t) -> t -> t + + (** Map all terms in a given declaration. *) + val map_constr : (Constr.t -> Constr.t) -> t -> t + + (** Perform a given action on all terms in a given declaration. *) + val iter_constr : (Constr.t -> unit) -> t -> unit + + (** Reduce all terms in a given declaration to a single value. *) + val fold : (Constr.t -> 'a -> 'a) -> t -> 'a -> 'a + + val to_tuple : t -> Name.t * Constr.t option * Constr.t + val of_tuple : Name.t * Constr.t option * Constr.t -> t + end + + (** Rel-context is represented as a list of declarations. + Inner-most declarations are at the beginning of the list. + Outer-most declarations are at the end of the list. *) + type t = Declaration.t list + + (** empty rel-context *) + val empty : t + + (** Return a new rel-context enriched by with a given inner-most declaration. *) + val add : Declaration.t -> t -> t + + (** Return the number of {e local declarations} in a given context. *) + val length : t -> int + + (** Check whether given two rel-contexts are equal. *) + val equal : t -> t -> bool + + (** Return the number of {e local assumptions} in a given rel-context. *) + val nhyps : t -> int + + (** Return a declaration designated by a given de Bruijn index. + @raise Not_found if the designated de Bruijn index outside the range. *) + val lookup : int -> t -> Declaration.t + + (** Map all terms in a given rel-context. *) + val map : (Constr.t -> Constr.t) -> t -> t + + (** Perform a given action on every declaration in a given rel-context. *) + val iter : (Constr.t -> unit) -> t -> unit + + (** Reduce all terms in a given rel-context to a single value. + Innermost declarations are processed first. *) + val fold_inside : ('a -> Declaration.t -> 'a) -> init:'a -> t -> 'a + + (** Reduce all terms in a given rel-context to a single value. + Outermost declarations are processed first. *) + val fold_outside : (Declaration.t -> 'a -> 'a) -> t -> init:'a -> 'a + + (** Map a given rel-context to a list where each {e local assumption} is mapped to [true] + and each {e local definition} is mapped to [false]. *) + val to_tags : t -> bool list + + (** [extended_list n Γ] builds an instance [args] such that [Γ,Δ ⊢ args:Γ] + with n = |Δ| and with the {e local definitions} of [Γ] skipped in + [args]. Example: for [x:T, y:=c, z:U] and [n]=2, it gives [Rel 5, Rel 3]. *) + val to_extended_list : int -> t -> Constr.t list + + (** [extended_vect n Γ] does the same, returning instead an array. *) + val to_extended_vect : int -> t -> Constr.t array +end + +(** This module represents contexts that can capture non-anonymous variables. + Individual declarations are then designated by the identifiers they bind. *) +module Named : +sig + (** Representation of {e local declarations}. *) + module Declaration : + sig + type t = LocalAssum of Id.t * Constr.t (** identifier, type *) + | LocalDef of Id.t * Constr.t * Constr.t (** identifier, value, type *) + + (** Return the identifier bound by a given declaration. *) + val get_id : t -> Id.t + + (** Return [Some value] for local-declarations and [None] for local-assumptions. *) + val get_value : t -> Constr.t option + + (** Return the type of the name bound by a given declaration. *) + val get_type : t -> Constr.t + + (** Set the identifier that is bound by a given declaration. *) + val set_id : Id.t -> t -> t + + (** Set the type of the bound variable in a given declaration. *) + val set_type : Constr.t -> t -> t -(** {6 Declarations} *) -(** A {e declaration} has the form [(name,body,type)]. It is either an - {e assumption} if [body=None] or a {e definition} if - [body=Some actualbody]. It is referred by {e name} if [na] is an - identifier or by {e relative index} if [na] is not an identifier - (in the latter case, [na] is of type [name] but just for printing - purpose) *) + (** Return [true] iff a given declaration is a local assumption. *) + val is_local_assum : t -> bool -type named_declaration = Id.t * Constr.t option * Constr.t -type named_list_declaration = Id.t list * Constr.t option * Constr.t -type rel_declaration = Name.t * Constr.t option * Constr.t + (** Return [true] iff a given declaration is a local definition. *) + val is_local_def : t -> bool -val map_named_declaration : - (Constr.t -> Constr.t) -> named_declaration -> named_declaration -val map_named_list_declaration : - (Constr.t -> Constr.t) -> named_list_declaration -> named_list_declaration -val map_rel_declaration : - (Constr.t -> Constr.t) -> rel_declaration -> rel_declaration + (** Check whether any term in a given declaration satisfies a given predicate. *) + val exists : (Constr.t -> bool) -> t -> bool -val fold_named_declaration : - (Constr.t -> 'a -> 'a) -> named_declaration -> 'a -> 'a -val fold_rel_declaration : - (Constr.t -> 'a -> 'a) -> rel_declaration -> 'a -> 'a + (** Check whether all terms in a given declaration satisfy a given predicate. *) + val for_all : (Constr.t -> bool) -> t -> bool -val exists_named_declaration : - (Constr.t -> bool) -> named_declaration -> bool -val exists_rel_declaration : - (Constr.t -> bool) -> rel_declaration -> bool + (** Check whether the two given declarations are equal. *) + val equal : t -> t -> bool -val for_all_named_declaration : - (Constr.t -> bool) -> named_declaration -> bool -val for_all_rel_declaration : - (Constr.t -> bool) -> rel_declaration -> bool + (** Map the identifier bound by a given declaration. *) + val map_id : (Id.t -> Id.t) -> t -> t -val eq_named_declaration : - named_declaration -> named_declaration -> bool + (** For local assumptions, this function returns the original local assumptions. + For local definitions, this function maps the value in the local definition. *) + val map_value : (Constr.t -> Constr.t) -> t -> t -val eq_rel_declaration : - rel_declaration -> rel_declaration -> bool + (** Map the type of the name bound by a given declaration. *) + val map_type : (Constr.t -> Constr.t) -> t -> t -(** {6 Signatures of ordered named declarations } *) + (** Map all terms in a given declaration. *) + val map_constr : (Constr.t -> Constr.t) -> t -> t -type named_context = named_declaration list -type section_context = named_context -type named_list_context = named_list_declaration list -type rel_context = rel_declaration list -(** In [rel_context], more recent declaration is on top *) + (** Perform a given action on all terms in a given declaration. *) + val iter_constr : (Constr.t -> unit) -> t -> unit -val empty_named_context : named_context -val add_named_decl : named_declaration -> named_context -> named_context -val vars_of_named_context : named_context -> Id.Set.t + (** Reduce all terms in a given declaration to a single value. *) + val fold : (Constr.t -> 'a -> 'a) -> t -> 'a -> 'a -val lookup_named : Id.t -> named_context -> named_declaration + val to_tuple : t -> Id.t * Constr.t option * Constr.t + val of_tuple : Id.t * Constr.t option * Constr.t -> t + end -(** number of declarations *) -val named_context_length : named_context -> int + (** Rel-context is represented as a list of declarations. + Inner-most declarations are at the beginning of the list. + Outer-most declarations are at the end of the list. *) + type t = Declaration.t list -(** named context equality *) -val named_context_equal : named_context -> named_context -> bool + (** empty named-context *) + val empty : t -(** {6 Recurrence on [named_context]: older declarations processed first } *) -val fold_named_context : - (named_declaration -> 'a -> 'a) -> named_context -> init:'a -> 'a + (** Return a new rel-context enriched by with a given inner-most declaration. *) + val add : Declaration.t -> t -> t -val fold_named_list_context : - (named_list_declaration -> 'a -> 'a) -> named_list_context -> init:'a -> 'a + (** Return the number of {e local declarations} in a given named-context. *) + val length : t -> int -(** newer declarations first *) -val fold_named_context_reverse : - ('a -> named_declaration -> 'a) -> init:'a -> named_context -> 'a + (** Return a declaration designated by an identifier of the variable bound in that declaration. + @raise Not_found if the designated identifier is not bound in a given named-context. *) + val lookup : Id.t -> t -> Declaration.t -(** {6 Section-related auxiliary functions } *) -val instance_from_named_context : named_context -> Constr.t list + (** Check whether given two rel-contexts are equal. *) + val equal : t -> t -> bool -(** {6 ... } *) -(** Signatures of ordered optionally named variables, intended to be - accessed by de Bruijn indices *) + (** Map all terms in a given named-context. *) + val map : (Constr.t -> Constr.t) -> t -> t -(** {6 Recurrence on [rel_context]: older declarations processed first } *) -val fold_rel_context : - (rel_declaration -> 'a -> 'a) -> rel_context -> init:'a -> 'a + (** Perform a given action on every declaration in a given named-context. *) + val iter : (Constr.t -> unit) -> t -> unit -(** newer declarations first *) -val fold_rel_context_reverse : - ('a -> rel_declaration -> 'a) -> init:'a -> rel_context -> 'a + (** Reduce all terms in a given named-context to a single value. + Innermost declarations are processed first. *) + val fold_inside : ('a -> Declaration.t -> 'a) -> init:'a -> t -> 'a -(** {6 Map function of [rel_context] } *) -val map_rel_context : (Constr.t -> Constr.t) -> rel_context -> rel_context + (** Reduce all terms in a given named-context to a single value. + Outermost declarations are processed first. *) + val fold_outside : (Declaration.t -> 'a -> 'a) -> t -> init:'a -> 'a -(** {6 Map function of [named_context] } *) -val map_named_context : (Constr.t -> Constr.t) -> named_context -> named_context + (** Return the set of all identifiers bound in a given named-context. *) + val to_vars : t -> Id.Set.t -(** {6 Map function of [rel_context] } *) -val iter_rel_context : (Constr.t -> unit) -> rel_context -> unit + (** [instance_from_named_context Ω] builds an instance [args] such + that [Ω ⊢ args:Ω] where [Ω] is a named context and with the local + definitions of [Ω] skipped. Example: for [id1:T,id2:=c,id3:U], it + gives [Var id1, Var id3]. All [idj] are supposed distinct. *) + val to_instance : t -> Constr.t list +end -(** {6 Map function of [named_context] } *) -val iter_named_context : (Constr.t -> unit) -> named_context -> unit +module NamedList : +sig + module Declaration : + sig + type t = Id.t list * Constr.t option * Constr.t + val map_constr : (Constr.t -> Constr.t) -> t -> t + end -(** {6 Contexts of declarations referred to by de Bruijn indices } *) + type t = Declaration.t list -val empty_rel_context : rel_context -val add_rel_decl : rel_declaration -> rel_context -> rel_context + val fold : (Declaration.t -> 'a -> 'a) -> t -> init:'a -> 'a +end -val lookup_rel : int -> rel_context -> rel_declaration -(** Size of the [rel_context] including LetIns *) -val rel_context_length : rel_context -> int -(** Size of the [rel_context] without LetIns *) -val rel_context_nhyps : rel_context -> int -(** Indicates whether a LetIn or a Lambda, starting from oldest declaration *) -val rel_context_tags : rel_context -> bool list +type section_context = Named.t diff --git a/kernel/conv_oracle.ml b/kernel/conv_oracle.ml index ec2c334b6..462413bd3 100644 --- a/kernel/conv_oracle.ml +++ b/kernel/conv_oracle.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/kernel/conv_oracle.mli b/kernel/conv_oracle.mli index 629912220..70f02b54d 100644 --- a/kernel/conv_oracle.mli +++ b/kernel/conv_oracle.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/kernel/cooking.ml b/kernel/cooking.ml index be71bd7b4..6dc2a617d 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -44,15 +44,15 @@ module RefHash = struct type t = my_global_reference let equal gr1 gr2 = match gr1, gr2 with - | ConstRef c1, ConstRef c2 -> Constant.CanOrd.equal c1 c2 - | IndRef i1, IndRef i2 -> eq_ind i1 i2 - | ConstructRef c1, ConstructRef c2 -> eq_constructor c1 c2 + | ConstRef c1, ConstRef c2 -> Constant.SyntacticOrd.equal c1 c2 + | IndRef i1, IndRef i2 -> eq_syntactic_ind i1 i2 + | ConstructRef c1, ConstructRef c2 -> eq_syntactic_constructor c1 c2 | _ -> false open Hashset.Combine let hash = function - | ConstRef c -> combinesmall 1 (Constant.hash c) - | IndRef i -> combinesmall 2 (ind_hash i) - | ConstructRef c -> combinesmall 3 (constructor_hash c) + | ConstRef c -> combinesmall 1 (Constant.SyntacticOrd.hash c) + | IndRef i -> combinesmall 2 (ind_syntactic_hash i) + | ConstructRef c -> combinesmall 3 (constructor_syntactic_hash c) end module RefTable = Hashtbl.Make(RefHash) @@ -173,7 +173,7 @@ let expmod_constr_subst cache modlist subst c = let cook_constr { Opaqueproof.modlist ; abstract } c = let cache = RefTable.create 13 in let expmod = expmod_constr_subst cache modlist (pi2 abstract) in - let hyps = Context.map_named_context expmod (pi1 abstract) in + let hyps = Context.Named.map expmod (pi1 abstract) in abstract_constant_body (expmod c) hyps let lift_univs cb subst = @@ -195,14 +195,16 @@ let cook_constant env { from = cb; info } = let abstract, usubst, abs_ctx = abstract in let usubst, univs = lift_univs cb usubst in let expmod = expmod_constr_subst cache modlist usubst in - let hyps = Context.map_named_context expmod abstract in + let hyps = Context.Named.map expmod abstract in let body = on_body modlist (hyps, usubst, abs_ctx) (fun c -> abstract_constant_body (expmod c) hyps) cb.const_body in let const_hyps = - Context.fold_named_context (fun (h,_,_) hyps -> - List.filter (fun (id,_,_) -> not (Id.equal id h)) hyps) + Context.Named.fold_outside (fun decl hyps -> + let open Context.Named.Declaration in + List.filter (fun decl' -> not (Id.equal (get_id decl) (get_id decl'))) + hyps) hyps ~init:cb.const_hyps in let typ = match cb.const_type with | RegularArity t -> diff --git a/kernel/cooking.mli b/kernel/cooking.mli index 441c9dd2d..327e697d2 100644 --- a/kernel/cooking.mli +++ b/kernel/cooking.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml index e242449b1..047da682a 100644 --- a/kernel/csymtable.ml +++ b/kernel/csymtable.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -15,7 +15,6 @@ open Util open Names open Term -open Context open Vm open Cemitcodes open Cbytecodes @@ -58,7 +57,7 @@ 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_sorts _, _ -> false -| Const_ind i1, Const_ind i2 -> Univ.eq_puniverses eq_ind i1 i2 +| 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 @@ -67,18 +66,24 @@ let rec eq_structured_constant c1 c2 = match c1, c2 with | Const_bn (t1, a1), Const_bn (t2, a2) -> Int.equal t1 t2 && Array.equal eq_structured_constant a1 a2 | 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_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 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 @@ -124,9 +129,9 @@ exception NotEvaluated let key rk = match !rk with | None -> raise NotEvaluated - | Some k -> (*Pp.msgnl (str"found at: "++int k);*) - try Ephemeron.get k - with Ephemeron.InvalidKey -> raise NotEvaluated + | Some k -> + try CEphemeron.get k + with CEphemeron.InvalidKey -> raise NotEvaluated (************************) (* traduction des patch *) @@ -148,25 +153,24 @@ 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)) + 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,u)) in + | BCconstant -> set_global (val_of_constant kn) + in (*Pp.msgnl(str"value stored at: "++int pos);*) - rk := Some (Ephemeron.create pos); + rk := Some (CEphemeron.create pos); pos and slot_for_fv env fv = @@ -185,18 +189,22 @@ and slot_for_fv env fv = let nv = Pre_env.lookup_named_val id env in begin match force_lazy_val nv with | None -> - let _, b, _ = Context.lookup_named id env.env_named_context in - fill_fv_cache nv id val_of_named idfun b + let open Context.Named in + let open Declaration in + env.env_named_context |> lookup id |> get_value |> fill_fv_cache nv id val_of_named idfun | Some (v, _) -> v end | FVrel i -> let rv = Pre_env.lookup_rel_val i env in begin match force_lazy_val rv with | None -> - let _, b, _ = lookup_rel i env.env_rel_context in - fill_fv_cache rv i val_of_rel env_of_rel b + let open Context.Rel in + let open Declaration in + env.env_rel_context |> lookup i |> get_value |> fill_fv_cache rv i val_of_rel env_of_rel | Some (v, _) -> v end + | FVuniv_var idu -> + assert false and eval_to_patch env (buff,pl,fv) = let patch = function @@ -208,7 +216,6 @@ and eval_to_patch env (buff,pl,fv) = let buff = patch_int buff patches in 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 +233,3 @@ and val_of_constr env c = let set_transparent_const kn = () (* !?! *) let set_opaque_const kn = () (* !?! *) - - diff --git a/kernel/csymtable.mli b/kernel/csymtable.mli index ca5f8ac29..cd561148b 100644 --- a/kernel/csymtable.mli +++ b/kernel/csymtable.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/kernel/declarations.mli b/kernel/declarations.mli index 7def963e7..1b77d5b7c 100644 --- a/kernel/declarations.mli +++ b/kernel/declarations.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,7 +8,6 @@ open Names open Term -open Context (** This module defines the internal representation of global declarations. This includes global constants/axioms, mutual @@ -38,7 +37,7 @@ type ('a, 'b) declaration_arity = | RegularArity of 'a | TemplateArity of 'b -type constant_type = (types, rel_context * template_arity) declaration_arity +type constant_type = (types, Context.Rel.t * template_arity) declaration_arity (** Inlining level of parameters at functor applications. None means no inlining *) @@ -79,12 +78,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 = @@ -123,7 +116,7 @@ type one_inductive_body = { mind_typename : Id.t; (** Name of the type: [Ii] *) - mind_arity_ctxt : rel_context; (** Arity context of [Ii] with parameters: [forall params, Ui] *) + mind_arity_ctxt : Context.Rel.t; (** Arity context of [Ii] with parameters: [forall params, Ui] *) mind_arity : inductive_arity; (** Arity sort and original user arity *) @@ -177,7 +170,7 @@ type mutual_inductive_body = { mind_nparams_rec : int; (** Number of recursively uniform (i.e. ordinary) parameters *) - mind_params_ctxt : rel_context; (** The context of parameters (includes let-in declaration) *) + mind_params_ctxt : Context.Rel.t; (** The context of parameters (includes let-in declaration) *) mind_polymorphic : bool; (** Is it polymorphic or not *) @@ -244,17 +237,26 @@ and module_body = { mod_mp : module_path; (** absolute path of the module *) mod_expr : module_implementation; (** implementation *) mod_type : module_signature; (** expanded type *) - (** algebraic type, kept if it's relevant for extraction *) - mod_type_alg : module_expression option; - (** 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_type_alg : module_expression option; (** algebraic type *) + mod_constraints : Univ.ContextSet.t; (** + set of all universes constraints in the module *) + mod_delta : Mod_subst.delta_resolver; (** + quotiented set of equivalent constants and inductive names *) mod_retroknowledge : Retroknowledge.action list } +(** For a module, there are five possible situations: + - [Declare Module M : T] then [mod_expr = Abstract; mod_type_alg = Some T] + - [Module M := E] then [mod_expr = Algebraic E; mod_type_alg = None] + - [Module M : T := E] then [mod_expr = Algebraic E; mod_type_alg = Some T] + - [Module M. ... End M] then [mod_expr = FullStruct; mod_type_alg = None] + - [Module M : T. ... End M] then [mod_expr = Struct; mod_type_alg = Some T] + And of course, all these situations may be functors or not. *) + (** A [module_type_body] is just a [module_body] with no implementation ([mod_expr] always [Abstract]) and also - an empty [mod_retroknowledge] *) + an empty [mod_retroknowledge]. Its [mod_type_alg] contains + the algebraic definition of this module type, or [None] + if it has been built interactively. *) and module_type_body = module_body diff --git a/kernel/declareops.ml b/kernel/declareops.ml index a7051d5c1..a09a8b786 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -9,6 +9,7 @@ open Declarations open Mod_subst open Util +open Context.Rel.Declaration (** Operations concernings types in [Declarations] : [constant_body], [mutual_inductive_body], [module_body] ... *) @@ -87,10 +88,8 @@ let is_opaque cb = match cb.const_body with (** {7 Constant substitutions } *) -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 - if copt == copt' && t == t' then x else (id,copt',t') +let subst_rel_declaration sub = + map_constr (subst_mps sub) let subst_rel_context sub = List.smartmap (subst_rel_declaration sub) @@ -140,11 +139,8 @@ let subst_const_body sub cb = share internal fields (e.g. constr), and not the records themselves. But would it really bring substantial gains ? *) -let hcons_rel_decl ((n,oc,t) as d) = - let n' = Names.Name.hcons n - and oc' = Option.smartmap Term.hcons_constr oc - and t' = Term.hcons_types t - in if n' == n && oc' == oc && t' == t then d else (n',oc',t') +let hcons_rel_decl = + map_type Term.hcons_types % map_value Term.hcons_constr % map_name Names.Name.hcons let hcons_rel_context l = List.smartmap hcons_rel_decl l @@ -254,7 +250,7 @@ let subst_mind_body sub mib = mind_nparams = mib.mind_nparams; mind_nparams_rec = mib.mind_nparams_rec; mind_params_ctxt = - Context.map_rel_context (subst_mps sub) mib.mind_params_ctxt; + Context.Rel.map (subst_mps sub) mib.mind_params_ctxt; mind_packets = Array.smartmap (subst_mind_packet sub) mib.mind_packets ; mind_polymorphic = mib.mind_polymorphic; mind_universes = mib.mind_universes; @@ -304,17 +300,90 @@ 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) ^ ")" + +(** Hashconsing of modules *) + +let hcons_functorize hty he hself f = match f with +| NoFunctor e -> + let e' = he e in + if e == e' then f else NoFunctor e' +| MoreFunctor (mid, ty, nf) -> + (** FIXME *) + let mid' = mid in + let ty' = hty ty in + let nf' = hself nf in + if mid == mid' && ty == ty' && nf == nf' then f + else MoreFunctor (mid, ty', nf') + +let hcons_module_alg_expr me = me + +let rec hcons_structure_field_body sb = match sb with +| SFBconst cb -> + let cb' = hcons_const_body cb in + if cb == cb' then sb else SFBconst cb' +| SFBmind mib -> + let mib' = hcons_mind mib in + if mib == mib' then sb else SFBmind mib' +| SFBmodule mb -> + let mb' = hcons_module_body mb in + if mb == mb' then sb else SFBmodule mb' +| SFBmodtype mb -> + let mb' = hcons_module_body mb in + if mb == mb' then sb else SFBmodtype mb' + +and hcons_structure_body sb = + (** FIXME *) + let map (l, sfb as fb) = + let l' = Names.Label.hcons l in + let sfb' = hcons_structure_field_body sfb in + if l == l' && sfb == sfb' then fb else (l', sfb') + in + List.smartmap map sb + +and hcons_module_signature ms = + hcons_functorize hcons_module_body hcons_structure_body hcons_module_signature ms + +and hcons_module_expression me = + hcons_functorize hcons_module_body hcons_module_alg_expr hcons_module_expression me + +and hcons_module_implementation mip = match mip with +| Abstract -> Abstract +| Algebraic me -> + let me' = hcons_module_expression me in + if me == me' then mip else Algebraic me' +| Struct ms -> + let ms' = hcons_module_signature ms in + if ms == ms' then mip else Struct ms +| FullStruct -> FullStruct + +and hcons_module_body mb = + let mp' = mb.mod_mp in + let expr' = hcons_module_implementation mb.mod_expr in + let type' = hcons_module_signature mb.mod_type in + let type_alg' = mb.mod_type_alg in + let constraints' = Univ.hcons_universe_context_set mb.mod_constraints in + let delta' = mb.mod_delta in + let retroknowledge' = mb.mod_retroknowledge in + + if + mb.mod_mp == mp' && + mb.mod_expr == expr' && + mb.mod_type == type' && + mb.mod_type_alg == type_alg' && + mb.mod_constraints == constraints' && + mb.mod_delta == delta' && + mb.mod_retroknowledge == retroknowledge' + then mb + else { + mod_mp = mp'; + mod_expr = expr'; + mod_type = type'; + mod_type_alg = type_alg'; + mod_constraints = constraints'; + mod_delta = delta'; + mod_retroknowledge = retroknowledge'; + } diff --git a/kernel/declareops.mli b/kernel/declareops.mli index ce65af975..ad2b5d0a6 100644 --- a/kernel/declareops.mli +++ b/kernel/declareops.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -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 @@ -87,3 +77,4 @@ val inductive_context : mutual_inductive_body -> universe_context val hcons_const_body : constant_body -> constant_body val hcons_mind : mutual_inductive_body -> mutual_inductive_body +val hcons_module_body : module_body -> module_body diff --git a/kernel/entries.mli b/kernel/entries.mli index 303d27d35..d07ca2103 100644 --- a/kernel/entries.mli +++ b/kernel/entries.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -18,8 +18,8 @@ open Term (** {6 Local entries } *) type local_entry = - | LocalDef of constr - | LocalAssum of constr + | LocalDefEntry of constr + | LocalAssumEntry of constr (** {6 Declaration of inductive types. } *) @@ -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 CEphemeron.key; + eff : side_eff; +} + +type side_effects = side_effect list diff --git a/kernel/environ.ml b/kernel/environ.ml index 09fe64d77..d8493d9ba 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -24,10 +24,10 @@ open Errors open Util open Names open Term -open Context open Vars open Declarations open Pre_env +open Context.Rel.Declaration (* The type of environments. *) @@ -70,21 +70,19 @@ let empty_context env = (* Rel context *) let lookup_rel n env = - lookup_rel n env.env_rel_context + Context.Rel.lookup n env.env_rel_context let evaluable_rel n env = - match lookup_rel n env with - | (_,Some _,_) -> true - | _ -> false + is_local_def (lookup_rel n env) let nb_rel env = env.env_nb_rel let push_rel = push_rel -let push_rel_context ctxt x = Context.fold_rel_context push_rel ctxt ~init:x +let push_rel_context ctxt x = Context.Rel.fold_outside push_rel ctxt ~init:x let push_rec_types (lna,typarray,_) env = - let ctxt = Array.map2_i (fun i na t -> (na, None, lift i t)) lna typarray in + let ctxt = Array.map2_i (fun i na t -> LocalAssum (na, lift i t)) lna typarray in Array.fold_left (fun e assum -> push_rel assum e) env ctxt let fold_rel_context f env ~init = @@ -108,19 +106,10 @@ let named_vals_of_val = snd (* [map_named_val f ctxt] apply [f] to the body and the type of each declarations. *** /!\ *** [f t] should be convertible with t *) -let map_named_val f (ctxt,ctxtv) = - let rec map ctx = match ctx with - | [] -> [] - | (id, body, typ) :: rem -> - let body' = Option.smartmap f body in - let typ' = f typ in - let rem' = map rem in - if body' == body && typ' == typ && rem' == rem then ctx - else (id, body', typ') :: rem' - in - (map ctxt, ctxtv) +let map_named_val f = + on_fst (Context.Named.map f) -let empty_named_context = empty_named_context +let empty_named_context = Context.Named.empty let push_named = push_named let push_named_context = List.fold_right push_named @@ -130,19 +119,21 @@ let val_of_named_context ctxt = List.fold_right push_named_context_val ctxt empty_named_context_val -let lookup_named id env = Context.lookup_named id env.env_named_context -let lookup_named_val id (ctxt,_) = Context.lookup_named id ctxt +let lookup_named id env = Context.Named.lookup id env.env_named_context +let lookup_named_val id (ctxt,_) = Context.Named.lookup id ctxt let eq_named_context_val c1 c2 = - c1 == c2 || named_context_equal (named_context_of_val c1) (named_context_of_val c2) + c1 == c2 || Context.Named.equal (named_context_of_val c1) (named_context_of_val c2) (* A local const is evaluable if it is defined *) +open Context.Named.Declaration + let named_type id env = - let (_,_,t) = lookup_named id env in t + get_type (lookup_named id env) let named_body id env = - let (_,b,_) = lookup_named id env in b + get_value (lookup_named id env) let evaluable_named id env = match named_body id env with @@ -153,7 +144,7 @@ let reset_with_named_context (ctxt,ctxtv) env = { env with env_named_context = ctxt; env_named_vals = ctxtv; - env_rel_context = empty_rel_context; + env_rel_context = Context.Rel.empty; env_rel_val = []; env_nb_rel = 0 } @@ -176,7 +167,7 @@ let fold_named_context f env ~init = in fold_right env let fold_named_context_reverse f ~init env = - Context.fold_named_context_reverse f ~init:init (named_context env) + Context.Named.fold_inside f ~init:init (named_context env) (* Universe constraints *) @@ -389,11 +380,11 @@ let add_mind kn mib env = let lookup_constant_variables c env = let cmap = lookup_constant c env in - Context.vars_of_named_context cmap.const_hyps + Context.Named.to_vars cmap.const_hyps let lookup_inductive_variables (kn,i) env = let mis = lookup_mind kn env in - Context.vars_of_named_context mis.mind_hyps + Context.Named.to_vars mis.mind_hyps let lookup_constructor_variables (ind,_) env = lookup_inductive_variables ind env @@ -427,15 +418,15 @@ let global_vars_set env constr = contained in the types of the needed variables. *) let really_needed env needed = - Context.fold_named_context_reverse - (fun need (id,copt,t) -> - if Id.Set.mem id need then + Context.Named.fold_inside + (fun need decl -> + if Id.Set.mem (get_id decl) need then let globc = - match copt with - | None -> Id.Set.empty - | Some c -> global_vars_set env c in + match decl with + | LocalAssum _ -> Id.Set.empty + | LocalDef (_,c,_) -> global_vars_set env c in Id.Set.union - (global_vars_set env t) + (global_vars_set env (get_type decl)) (Id.Set.union globc need) else need) ~init:needed @@ -443,9 +434,9 @@ let really_needed env needed = let keep_hyps env needed = let really_needed = really_needed env needed in - Context.fold_named_context - (fun (id,_,_ as d) nsign -> - if Id.Set.mem id really_needed then add_named_decl d nsign + Context.Named.fold_outside + (fun d nsign -> + if Id.Set.mem (get_id d) really_needed then Context.Named.add d nsign else nsign) (named_context env) ~init:empty_named_context @@ -497,9 +488,9 @@ exception Hyp_not_found let apply_to_hyp (ctxt,vals) id f = let rec aux rtail ctxt vals = match ctxt, vals with - | (idc,c,ct as d)::ctxt, v::vals -> - if Id.equal idc id then - (f ctxt d rtail)::ctxt, v::vals + | d::ctxt, v::vals -> + if Id.equal (get_id d) id then + (f ctxt d rtail)::ctxt, v::vals else let ctxt',vals' = aux (d::rtail) ctxt vals in d::ctxt', v::vals' @@ -510,8 +501,8 @@ let apply_to_hyp (ctxt,vals) id f = let apply_to_hyp_and_dependent_on (ctxt,vals) id f g = let rec aux ctxt vals = match ctxt,vals with - | (idc,c,ct as d)::ctxt, v::vals -> - if Id.equal idc id then + | d::ctxt, v::vals -> + if Id.equal (get_id d) id then let sign = ctxt,vals in push_named_context_val (f d sign) sign else @@ -524,8 +515,8 @@ let apply_to_hyp_and_dependent_on (ctxt,vals) id f g = let insert_after_hyp (ctxt,vals) id d check = let rec aux ctxt vals = match ctxt, vals with - | (idc,c,ct)::ctxt', v::vals' -> - if Id.equal idc id then begin + | decl::ctxt', v::vals' -> + if Id.equal (get_id decl) id then begin check ctxt; push_named_context_val d (ctxt,vals) end else @@ -541,9 +532,8 @@ let remove_hyps ids check_context check_value (ctxt, vals) = let rec remove_hyps ctxt vals = match ctxt, vals with | [], [] -> [], [] | d :: rctxt, (nid, v) :: rvals -> - let (id, _, _) = d in let ans = remove_hyps rctxt rvals in - if Id.Set.mem id ids then ans + if Id.Set.mem (get_id d) ids then ans else let (rctxt', rvals') = ans in let d' = check_context d in diff --git a/kernel/environ.mli b/kernel/environ.mli index 714c26066..520389954 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,7 +8,6 @@ open Names open Term -open Context open Declarations open Univ @@ -42,8 +41,8 @@ val eq_named_context_val : named_context_val -> named_context_val -> bool val empty_env : env val universes : env -> UGraph.t -val rel_context : env -> rel_context -val named_context : env -> named_context +val rel_context : env -> Context.Rel.t +val named_context : env -> Context.Named.t val named_context_val : env -> named_context_val val opaque_tables : env -> Opaqueproof.opaquetab @@ -60,25 +59,25 @@ val empty_context : env -> bool (** {5 Context of de Bruijn variables ([rel_context]) } *) val nb_rel : env -> int -val push_rel : rel_declaration -> env -> env -val push_rel_context : rel_context -> env -> env +val push_rel : Context.Rel.Declaration.t -> env -> env +val push_rel_context : Context.Rel.t -> env -> env val push_rec_types : rec_declaration -> env -> env (** Looks up in the context of local vars referred by indice ([rel_context]) raises [Not_found] if the index points out of the context *) -val lookup_rel : int -> env -> rel_declaration +val lookup_rel : int -> env -> Context.Rel.Declaration.t val evaluable_rel : int -> env -> bool (** {6 Recurrence on [rel_context] } *) val fold_rel_context : - (env -> rel_declaration -> 'a -> 'a) -> env -> init:'a -> 'a + (env -> Context.Rel.Declaration.t -> 'a -> 'a) -> env -> init:'a -> 'a (** {5 Context of variables (section variables and goal assumptions) } *) -val named_context_of_val : named_context_val -> named_context +val named_context_of_val : named_context_val -> Context.Named.t val named_vals_of_val : named_context_val -> Pre_env.named_vals -val val_of_named_context : named_context -> named_context_val +val val_of_named_context : Context.Named.t -> named_context_val val empty_named_context_val : named_context_val @@ -88,18 +87,18 @@ val empty_named_context_val : named_context_val val map_named_val : (constr -> constr) -> named_context_val -> named_context_val -val push_named : named_declaration -> env -> env -val push_named_context : named_context -> env -> env +val push_named : Context.Named.Declaration.t -> env -> env +val push_named_context : Context.Named.t -> env -> env val push_named_context_val : - named_declaration -> named_context_val -> named_context_val + Context.Named.Declaration.t -> named_context_val -> named_context_val (** Looks up in the context of local vars referred by names ([named_context]) raises [Not_found] if the Id.t is not found *) -val lookup_named : variable -> env -> named_declaration -val lookup_named_val : variable -> named_context_val -> named_declaration +val lookup_named : variable -> env -> Context.Named.Declaration.t +val lookup_named_val : variable -> named_context_val -> Context.Named.Declaration.t val evaluable_named : variable -> env -> bool val named_type : variable -> env -> types val named_body : variable -> env -> constr option @@ -107,11 +106,11 @@ val named_body : variable -> env -> constr option (** {6 Recurrence on [named_context]: older declarations processed first } *) val fold_named_context : - (env -> named_declaration -> 'a -> 'a) -> env -> init:'a -> 'a + (env -> Context.Named.Declaration.t -> 'a -> 'a) -> env -> init:'a -> 'a (** Recurrence on [named_context] starting from younger decl *) val fold_named_context_reverse : - ('a -> named_declaration -> 'a) -> init:'a -> env -> 'a + ('a -> Context.Named.Declaration.t -> 'a) -> init:'a -> env -> 'a (** This forgets named and rel contexts *) val reset_context : env -> env @@ -228,7 +227,7 @@ val vars_of_global : env -> constr -> Id.Set.t val really_needed : env -> Id.Set.t -> Id.Set.t (** like [really_needed] but computes a well ordered named context *) -val keep_hyps : env -> Id.Set.t -> section_context +val keep_hyps : env -> Id.Set.t -> Context.section_context (** {5 Unsafe judgments. } We introduce here the pre-type of judgments, which is @@ -250,7 +249,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 @@ -258,22 +257,22 @@ exception Hyp_not_found return [tail::(f head (id,_,_) (rev tail))::head]. the value associated to id should not change *) val apply_to_hyp : named_context_val -> variable -> - (named_context -> named_declaration -> named_context -> named_declaration) -> + (Context.Named.t -> Context.Named.Declaration.t -> Context.Named.t -> Context.Named.Declaration.t) -> named_context_val (** [apply_to_hyp_and_dependent_on sign id f g] split [sign] into [tail::(id,_,_)::head] and return [(g tail)::(f (id,_,_))::head]. *) val apply_to_hyp_and_dependent_on : named_context_val -> variable -> - (named_declaration -> named_context_val -> named_declaration) -> - (named_declaration -> named_context_val -> named_declaration) -> + (Context.Named.Declaration.t -> named_context_val -> Context.Named.Declaration.t) -> + (Context.Named.Declaration.t -> named_context_val -> Context.Named.Declaration.t) -> named_context_val val insert_after_hyp : named_context_val -> variable -> - named_declaration -> - (named_context -> unit) -> named_context_val + Context.Named.Declaration.t -> + (Context.Named.t -> unit) -> named_context_val -val remove_hyps : Id.Set.t -> (named_declaration -> named_declaration) -> (Pre_env.lazy_val -> Pre_env.lazy_val) -> named_context_val -> named_context_val +val remove_hyps : Id.Set.t -> (Context.Named.Declaration.t -> Context.Named.Declaration.t) -> (Pre_env.lazy_val -> Pre_env.lazy_val) -> named_context_val -> named_context_val diff --git a/kernel/esubst.ml b/kernel/esubst.ml index 42ca48ef3..1dc389c64 100644 --- a/kernel/esubst.ml +++ b/kernel/esubst.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/kernel/esubst.mli b/kernel/esubst.mli index 2b34da4da..533d1c68c 100644 --- a/kernel/esubst.mli +++ b/kernel/esubst.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/kernel/evar.ml b/kernel/evar.ml index 54f15df4d..b972fc114 100644 --- a/kernel/evar.ml +++ b/kernel/evar.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/kernel/evar.mli b/kernel/evar.mli index 2c94db3f0..f28a13640 100644 --- a/kernel/evar.mli +++ b/kernel/evar.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/kernel/fast_typeops.ml b/kernel/fast_typeops.ml index 063c9cf12..7f4ba8ecb 100644 --- a/kernel/fast_typeops.ml +++ b/kernel/fast_typeops.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -33,7 +33,7 @@ let check_constraints cst env = if Environ.check_constraints cst env then () else error_unsatisfied_constraints env cst -(* This should be a type (a priori without intension to be an assumption) *) +(* This should be a type (a priori without intention to be an assumption) *) let type_judgment env c t = match kind_of_term(whd_betadeltaiota env t) with | Sort s -> {utj_val = c; utj_type = s } @@ -52,8 +52,8 @@ let assumption_of_judgment env t ty = error_assumption env (make_judge t ty) (************************************************) -(* Incremental typing rules: builds a typing judgement given the *) -(* judgements for the subterms. *) +(* Incremental typing rules: builds a typing judgment given the *) +(* judgments for the subterms. *) (*s Type of sorts *) @@ -73,8 +73,8 @@ let judge_of_type u = let judge_of_relative env n = try - let (_,_,typ) = lookup_rel n env in - lift n typ + let open Context.Rel.Declaration in + env |> lookup_rel n |> get_type |> lift n with Not_found -> error_unbound_rel env n @@ -90,8 +90,11 @@ let judge_of_variable env id = variables of the current env *) (* TODO: check order? *) let check_hyps_inclusion env f c sign = - Context.fold_named_context - (fun (id,_,ty1) () -> + Context.Named.fold_outside + (fun decl () -> + let open Context.Named.Declaration in + let id = get_id decl in + let ty1 = get_type decl in try let ty2 = named_type id env in if not (eq_constr ty2 ty1) then raise Exit @@ -325,6 +328,7 @@ let type_fixpoint env lna lar vdef vdeft = Ind et Constructsi un jour cela devient des constructions arbitraires et non plus des variables *) let rec execute env cstr = + let open Context.Rel.Declaration in match kind_of_term cstr with (* Atomic terms *) | Sort (Prop c) -> @@ -368,13 +372,13 @@ let rec execute env cstr = | Lambda (name,c1,c2) -> let _ = execute_is_type env c1 in - let env1 = push_rel (name,None,c1) env in + let env1 = push_rel (LocalAssum (name,c1)) env in let c2t = execute env1 c2 in judge_of_abstraction env name c1 c2t | Prod (name,c1,c2) -> let vars = execute_is_type env c1 in - let env1 = push_rel (name,None,c1) env in + let env1 = push_rel (LocalAssum (name,c1)) env in let vars' = execute_is_type env1 c2 in judge_of_product env name vars vars' @@ -382,7 +386,7 @@ let rec execute env cstr = let c1t = execute env c1 in let _c2s = execute_is_type env c2 in let _ = judge_of_cast env c1 c1t DEFAULTcast c2 in - let env1 = push_rel (name,Some c1,c2) env in + let env1 = push_rel (LocalDef (name,c1,c2)) env in let c3t = execute env1 c3 in subst1 c1 c3t diff --git a/kernel/fast_typeops.mli b/kernel/fast_typeops.mli index 90d9c55f1..05d52b2d3 100644 --- a/kernel/fast_typeops.mli +++ b/kernel/fast_typeops.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 23320daef..33abfe5b7 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -12,7 +12,6 @@ open Names open Univ open Term open Vars -open Context open Declarations open Declareops open Inductive @@ -21,6 +20,7 @@ open Reduction open Typeops open Entries open Pp +open Context.Rel.Declaration (* Tell if indices (aka real arguments) contribute to size of inductive type *) (* If yes, this is compatible with the univalent model *) @@ -117,18 +117,18 @@ let is_unit constrsinfos = | [] -> (* type without constructors *) true | _ -> false -let infos_and_sort env ctx t = - let rec aux env ctx t max = +let infos_and_sort env t = + let rec aux env t max = let t = whd_betadeltaiota env t in match kind_of_term t with | Prod (name,c1,c2) -> let varj = infer_type env c1 in - let env1 = Environ.push_rel (name,None,varj.utj_val) env in + let env1 = Environ.push_rel (LocalAssum (name,varj.utj_val)) env in let max = Universe.sup max (univ_of_sort varj.utj_type) in - aux env1 ctx c2 max + aux env1 c2 max | _ when is_constructor_head t -> max | _ -> (* don't fail if not positive, it is tested later *) max - in aux env ctx t Universe.type0m + in aux env t Universe.type0m (* Computing the levels of polymorphic inductive types @@ -153,14 +153,14 @@ let infos_and_sort env ctx t = (* This (re)computes informations relevant to extraction and the sort of an arity or type constructor; we do not to recompute universes constraints *) -let infer_constructor_packet env_ar_par ctx params lc = +let infer_constructor_packet env_ar_par params lc = (* type-check the constructors *) let jlc = List.map (infer_type env_ar_par) lc in let jlc = Array.of_list jlc in (* generalize the constructor over the parameters *) let lc'' = Array.map (fun j -> it_mkProd_or_LetIn j.utj_val params) jlc in (* compute the max of the sorts of the products of the constructors types *) - let levels = List.map (infos_and_sort env_ar_par ctx) lc in + let levels = List.map (infos_and_sort env_ar_par) lc in let isunit = is_unit levels in let min = if Array.length jlc > 1 then Universe.type0 else Universe.type0m in let level = List.fold_left (fun max l -> Universe.sup max l) min levels in @@ -169,12 +169,14 @@ let infer_constructor_packet env_ar_par ctx params lc = (* If indices matter *) let cumulate_arity_large_levels env sign = fst (List.fold_right - (fun (_,b,t as d) (lev,env) -> - if Option.is_empty b then + (fun d (lev,env) -> + match d with + | LocalAssum (_,t) -> let tj = infer_type env t in let u = univ_of_sort tj.utj_type in (Universe.sup u lev, push_rel d env) - else lev, push_rel d env) + | LocalDef _ -> + lev, push_rel d env) sign (Universe.type0m,env)) let is_impredicative env u = @@ -185,12 +187,12 @@ let is_impredicative env u = 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 fold acc = function (_, None, p) -> + let fold acc = function (LocalAssum (_, p)) -> (let c = strip_prod_assum p in match kind_of_term c with | Sort (Type u) -> Univ.Universe.level u | _ -> None) :: acc - | _ -> acc + | LocalDef _ -> acc in List.fold_left fold [] params @@ -250,7 +252,7 @@ let typecheck_inductive env mie = let full_arity = it_mkProd_or_LetIn arity params in let id = ind.mind_entry_typename in let env_ar' = - push_rel (Name id, None, full_arity) env_ar in + push_rel (LocalAssum (Name id, full_arity)) env_ar in (* (add_constraints cst2 env_ar) in *) (env_ar', (id,full_arity,sign @ params,expltype,deflev,inflev)::l)) (env',[]) @@ -266,8 +268,7 @@ let typecheck_inductive env mie = List.fold_right2 (fun ind arity_data inds -> let (lc',cstrs_univ) = - infer_constructor_packet env_ar_par ContextSet.empty - params ind.mind_entry_lc in + infer_constructor_packet env_ar_par params ind.mind_entry_lc in let consnames = ind.mind_entry_consnames in let ind' = (arity_data,consnames,lc',cstrs_univ) in ind'::inds) @@ -342,7 +343,7 @@ let typecheck_inductive env mie = type ill_formed_ind = | LocalNonPos of int | LocalNotEnoughArgs of int - | LocalNotConstructor + | LocalNotConstructor of Context.Rel.t * int | LocalNonPar of int * int * int exception IllFormedInd of ill_formed_ind @@ -353,7 +354,7 @@ exception IllFormedInd of ill_formed_ind let mind_extract_params = decompose_prod_n_assum -let explain_ind_err id ntyp env nbpar c nargs err = +let explain_ind_err id ntyp env nbpar c err = let (lpar,c') = mind_extract_params nbpar c in match err with | LocalNonPos kt -> @@ -361,9 +362,10 @@ let explain_ind_err id ntyp env nbpar c nargs err = | LocalNotEnoughArgs kt -> raise (InductiveError (NotEnoughArgs (env,c',mkRel (kt+nbpar)))) - | LocalNotConstructor -> + | LocalNotConstructor (paramsctxt,nargs)-> + let nparams = Context.Rel.nhyps paramsctxt in raise (InductiveError - (NotConstructor (env,id,c',mkRel (ntyp+nbpar),nbpar,nargs))) + (NotConstructor (env,id,c',mkRel (ntyp+nbpar),nparams,nargs))) | LocalNonPar (n,i,l) -> raise (InductiveError (NonPar (env,c',n,mkRel i, mkRel (l+nbpar)))) @@ -383,7 +385,7 @@ let failwith_non_pos_list n ntypes l = (* Check the inductive type is called with the expected parameters *) let check_correct_par (env,n,ntypes,_) hyps l largs = - let nparams = rel_context_nhyps hyps in + let nparams = Context.Rel.nhyps hyps in let largs = Array.of_list largs in if Array.length largs < nparams then raise (IllFormedInd (LocalNotEnoughArgs l)); @@ -391,7 +393,7 @@ let check_correct_par (env,n,ntypes,_) hyps l largs = let nhyps = List.length hyps in let rec check k index = function | [] -> () - | (_,Some _,_)::hyps -> check k (index+1) hyps + | LocalDef _ :: hyps -> check k (index+1) hyps | _::hyps -> match kind_of_term (whd_betadeltaiota env lpar.(k)) with | Rel w when Int.equal w index -> check (k-1) (index+1) hyps @@ -413,7 +415,7 @@ if Int.equal nmr 0 then 0 else function ([],_) -> nmr | (_,[]) -> assert false (* |hyps|>=nmr *) - | (lp,(_,Some _,_)::hyps) -> find k (index-1) (lp,hyps) + | (lp, LocalDef _ :: hyps) -> find k (index-1) (lp,hyps) | (p::lp,_::hyps) -> ( match kind_of_term (whd_betadeltaiota env p) with | Rel w when Int.equal w index -> find (k+1) (index-1) (lp,hyps) @@ -427,15 +429,15 @@ if Int.equal nmr 0 then 0 else [lra] is the list of recursive tree of each variable *) let ienv_push_var (env, n, ntypes, lra) (x,a,ra) = - (push_rel (x,None,a) env, n+1, ntypes, (Norec,ra)::lra) + (push_rel (LocalAssum (x,a)) env, n+1, ntypes, (Norec,ra)::lra) let ienv_push_inductive (env, n, ntypes, ra_env) ((mi,u),lpar) = let auxntyp = 1 in let specif = (lookup_mind_specif env mi, u) in let ty = type_of_inductive env specif in let env' = - push_rel (Anonymous,None, - hnf_prod_applist env ty lpar) env in + let decl = LocalAssum (Anonymous, hnf_prod_applist env ty lpar) in + push_rel decl env in let ra_env' = (Imbr mi,(Rtree.mk_rec_calls 1).(0)) :: List.map (fun (r,t) -> (r,Rtree.lift 1 t)) ra_env in @@ -463,9 +465,9 @@ let array_min nmr a = if Int.equal nmr 0 then 0 else considered sub-terms) as well as the number of of non-uniform arguments (used to generate induction schemes, so a priori less relevant to the kernel). *) -let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcnames indlc = - let lparams = rel_context_length hyps in - let nmr = rel_context_nhyps hyps in +let check_positivity_one recursive (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcnames indlc = + let lparams = Context.Rel.length hyps in + let nmr = Context.Rel.nhyps hyps in (** Positivity of one argument [c] of a constructor (i.e. the constructor [cn] has a type of the shape [… -> c … -> P], where, more generally, the arrows may be dependent). *) @@ -578,6 +580,8 @@ let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcname | Prod (na,b,d) -> let () = assert (List.is_empty largs) in + if not recursive && not (noccur_between n ntypes b) then + raise (InductiveError BadEntry); let nmr',recarg = check_pos ienv nmr b in let ienv' = ienv_push_var ienv (na,b,mk_norec) in check_constr_rec ienv' nmr' (recarg::lrec) d @@ -587,7 +591,7 @@ let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcname begin match hd with | Rel j when Int.equal j (n + ntypes - i - 1) -> check_correct_par ienv hyps (ntypes - i) largs - | _ -> raise (IllFormedInd LocalNotConstructor) + | _ -> raise (IllFormedInd (LocalNotConstructor(hyps,nargs))) end else if not (List.for_all (noccur_between n ntypes) largs) @@ -603,7 +607,7 @@ let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcname try check_constructors ienv true nmr rawc with IllFormedInd err -> - explain_ind_err id (ntypes-i) env lparams c nargs err) + explain_ind_err id (ntypes-i) env lparams c err) (Array.of_list lcnames) indlc in let irecargs = Array.map snd irecargs_nmr @@ -612,18 +616,20 @@ let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcname (** [check_positivity kn env_ar params] checks that the mutually inductive block [inds] is strictly positive. *) -let check_positivity kn env_ar params inds = +let check_positivity kn env_ar params finite inds = let ntypes = Array.length inds in - let rc = Array.mapi (fun j t -> (Mrec (kn,j),t)) (Rtree.mk_rec_calls ntypes) in + let recursive = finite != Decl_kinds.BiFinite in + let rc = Array.mapi (fun j t -> (Mrec (kn,j),t)) + (Rtree.mk_rec_calls ntypes) in let lra_ind = Array.rev_to_list rc in - let lparams = rel_context_length params in - let nmr = rel_context_nhyps params in + let lparams = Context.Rel.length params in + let nmr = Context.Rel.nhyps params in let check_one i (_,lcnames,lc,(sign,_)) = let ra_env = List.init lparams (fun _ -> (Norec,mk_norec)) @ lra_ind in let ienv = (env_ar, 1+lparams, ntypes, ra_env) in - let nargs = rel_context_nhyps sign - nmr in - check_positivity_one ienv params (kn,i) nargs lcnames lc + let nargs = Context.Rel.nhyps sign - nmr in + check_positivity_one recursive ienv params (kn,i) nargs lcnames lc in let irecargs_nmr = Array.mapi check_one inds in let irecargs = Array.map snd irecargs_nmr @@ -680,6 +686,7 @@ let used_section_variables env inds = keep_hyps env ids let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i)) +let rel_list n m = Array.to_list (rel_vect n m) exception UndefinableExpansion @@ -694,24 +701,21 @@ let compute_projections ((kn, _ as ind), u as indu) n x nparamargs params 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 + (* [ty] = [Ind inst] is typed in context [params] *) + let inst = Context.Rel.to_extended_vect 0 paramslet in + let ty = mkApp (mkIndU indu, inst) in + (* [Ind inst] is typed in context [params-wo-let] *) + let inst' = rel_list 0 nparamargs in + (* {params-wo-let |- subst:params] *) + let subst = subst_of_rel_context_instance paramslet inst' in + (* {params-wo-let, x:Ind inst' |- subst':(params,x:Ind inst)] *) 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 + mkRel 1 :: List.map (lift 1) subst in ty, subst in let ci = let print_info = - { ind_tags = []; cstr_tags = [|rel_context_tags ctx|]; style = LetStyle } in + { ind_tags = []; cstr_tags = [|Context.Rel.to_tags ctx|]; style = LetStyle } in { ci_ind = ind; ci_npar = nparamargs; ci_cstr_ndecls = mind_consnrealdecls; @@ -729,16 +733,39 @@ let compute_projections ((kn, _ as ind), u as indu) n x nparamargs params let body = mkCase (ci, p, mkRel 1, [|lift 1 branch|]) in it_mkLambda_or_LetIn (mkLambda (x,indty,body)) params in - 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, - substl letsubst c :: subst) - | None -> + let projections decl (i, j, kns, pbs, subst, letsubst) = + match decl with + | LocalDef (na,c,t) -> + (* From [params, field1,..,fieldj |- c(params,field1,..,fieldj)] + to [params, x:I, field1,..,fieldj |- c(params,field1,..,fieldj)] *) + let c = liftn 1 j c in + (* From [params, x:I, field1,..,fieldj |- c(params,field1,..,fieldj)] + to [params, x:I |- c(params,proj1 x,..,projj x)] *) + let c1 = substl subst c in + (* From [params, x:I |- subst:field1,..,fieldj] + to [params, x:I |- subst:field1,..,fieldj+1] where [subst] + is represented with instance of field1 last *) + let subst = c1 :: subst in + (* From [params, x:I, field1,..,fieldj |- c(params,field1,..,fieldj)] + to [params-wo-let, x:I |- c(params,proj1 x,..,projj x)] *) + let c2 = substl letsubst c in + (* From [params-wo-let, x:I |- subst:(params, x:I, field1,..,fieldj)] + to [params-wo-let, x:I |- subst:(params, x:I, field1,..,fieldj+1)] *) + let letsubst = c2 :: letsubst in + (i, j+1, kns, pbs, subst, letsubst) + | LocalAssum (na,t) -> 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 + (* from [params, field1,..,fieldj |- t(params,field1,..,fieldj)] + to [params, x:I, field1,..,fieldj |- t(params,field1,..,fieldj] *) + let t = liftn 1 j t in + (* from [params, x:I, field1,..,fieldj |- t(params,field1,..,fieldj)] + to [params-wo-let, x:I |- t(params,proj1 x,..,projj x)] *) + let projty = substl letsubst t in + (* from [params, x:I, field1,..,fieldj |- t(field1,..,fieldj)] + to [params, x:I |- t(proj1 x,..,projj x)] *) + let ty = substl subst 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 @@ -761,8 +788,8 @@ let build_inductive env p prv ctx env_ar params kn isrecord isfinite inds nmr re let ntypes = Array.length inds in (* Compute the set of used section variables *) let hyps = used_section_variables env inds in - let nparamargs = rel_context_nhyps params in - let nparamdecls = rel_context_length params in + let nparamargs = Context.Rel.nhyps params in + let nparamdecls = Context.Rel.length params in let subst, ctx = Univ.abstract_universes p ctx in let params = Vars.subst_univs_level_context subst params in let env_ar = @@ -777,10 +804,10 @@ let build_inductive env p prv ctx env_ar params kn isrecord isfinite inds nmr re let splayed_lc = Array.map (dest_prod_assum env_ar) lc in let nf_lc = Array.map (fun (d,b) -> it_mkProd_or_LetIn b d) splayed_lc in let consnrealdecls = - Array.map (fun (d,_) -> rel_context_length d - rel_context_length params) + Array.map (fun (d,_) -> Context.Rel.length d - Context.Rel.length params) splayed_lc in let consnrealargs = - Array.map (fun (d,_) -> rel_context_nhyps d - rel_context_nhyps params) + Array.map (fun (d,_) -> Context.Rel.nhyps d - Context.Rel.nhyps params) splayed_lc in (* Elimination sorts *) let arkind,kelim = @@ -813,8 +840,8 @@ let build_inductive env p prv ctx env_ar params kn isrecord isfinite inds nmr re { mind_typename = id; mind_arity = arkind; mind_arity_ctxt = Vars.subst_univs_level_context subst ar_sign; - mind_nrealargs = rel_context_nhyps ar_sign - nparamargs; - mind_nrealdecls = rel_context_length ar_sign - nparamdecls; + mind_nrealargs = Context.Rel.nhyps ar_sign - nparamargs; + mind_nrealdecls = Context.Rel.length ar_sign - nparamdecls; mind_kelim = kelim; mind_consnames = Array.of_list cnames; mind_consnrealdecls = consnrealdecls; @@ -827,10 +854,11 @@ let build_inductive env p prv ctx env_ar params kn isrecord isfinite inds nmr re mind_reloc_tbl = rtbl; } in let packets = Array.map2 build_one_packet inds recargs in - let pkt = packets.(0) in + let pkt = packets.(0) in let isrecord = match isrecord with - | Some (Some rid) when pkt.mind_kelim == all_sorts && Array.length pkt.mind_consnames == 1 + | Some (Some rid) when pkt.mind_kelim == all_sorts + && Array.length pkt.mind_consnames == 1 && pkt.mind_consnrealargs.(0) > 0 -> (** The elimination criterion ensures that all projections can be defined. *) let u = @@ -871,7 +899,7 @@ let check_inductive env kn mie = (* First type-check the inductive definition *) let (env_ar, env_ar_par, params, inds) = typecheck_inductive env mie in (* Then check positivity conditions *) - let (nmr,recargs) = check_positivity kn env_ar_par params inds in + let (nmr,recargs) = check_positivity kn env_ar_par params mie.mind_entry_finite inds in (* Build the inductive packets *) build_inductive env mie.mind_entry_polymorphic mie.mind_entry_private mie.mind_entry_universes diff --git a/kernel/indtypes.mli b/kernel/indtypes.mli index 01acdce5c..5b4615399 100644 --- a/kernel/indtypes.mli +++ b/kernel/indtypes.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -42,6 +42,6 @@ val enforce_indices_matter : unit -> unit 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 -> + int -> Context.Rel.t -> int array -> int array -> + Context.Rel.t -> Context.Rel.t -> (constant array * projection_body array) diff --git a/kernel/inductive.ml b/kernel/inductive.ml index 1f8706652..499cbf0df 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -12,12 +12,12 @@ open Names open Univ open Term open Vars -open Context open Declarations open Declareops open Environ open Reduction open Type_errors +open Context.Rel.Declaration type mind_specif = mutual_inductive_body * one_inductive_body @@ -77,11 +77,11 @@ 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) = - Context.fold_rel_context - (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)) -> + Context.Rel.fold_outside + (fun decl (largs,subs,ty) -> + match (decl, largs, kind_of_term ty) with + | (LocalAssum _, a::args, Prod(_,_,t)) -> (args, a::subs, t) + | (LocalDef (_,b,_), _, LetIn(_,_,_,t)) -> (largs, (substl subs (subst_instance_constr u b))::subs, t) | (_,[],_) -> if full then fail() else ([], subs, ty) | _ -> fail ()) @@ -151,9 +151,9 @@ let remember_subst u subst = (* Bind expected levels of parameters to actual levels *) (* Propagate the new levels in the signature *) -let rec make_subst env = +let make_subst env = let rec make subst = function - | (_,Some _,_)::sign, exp, args -> + | LocalDef _ :: sign, exp, args -> make subst (sign, exp, args) | d::sign, None::exp, args -> let args = match args with _::args -> args | [] -> [] in @@ -166,7 +166,7 @@ let rec make_subst env = (* 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, [] -> + | LocalAssum (na,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 *) @@ -270,18 +270,6 @@ let type_of_constructors (ind,u) (mib,mip) = (* Type of case predicates *) -let local_rels ctxt = - let (rels,_) = - Context.fold_rel_context_reverse - (fun (rels,n) (_,copt,_) -> - match copt with - None -> (mkRel n :: rels, n+1) - | Some _ -> (rels, n+1)) - ~init:([],1) - ctxt - in - rels - (* Get type of inductive, with parameters instantiated *) let inductive_sort_family mip = @@ -304,20 +292,12 @@ let is_primitive_record (mib,_) = | Some (Some _) -> true | _ -> false -let extended_rel_list n hyps = - let rec reln l p = function - | (_,None,_) :: hyps -> reln (mkRel (n+p) :: l) (p+1) hyps - | (_,Some _,_) :: hyps -> reln l (p+1) hyps - | [] -> l - in - reln [] 1 hyps - let build_dependent_inductive ind (_,mip) params = let realargs,_ = List.chop mip.mind_nrealdecls mip.mind_arity_ctxt in applist (mkIndU ind, List.map (lift mip.mind_nrealdecls) params - @ extended_rel_list 0 realargs) + @ Context.Rel.to_extended_list 0 realargs) (* This exception is local *) exception LocalArity of (sorts_family * sorts_family * arity_error) option @@ -335,14 +315,14 @@ let is_correct_arity env c pj ind specif params = let rec srec env pt ar = let pt' = whd_betadeltaiota env pt in match kind_of_term pt', ar with - | Prod (na1,a1,t), (_,None,a1')::ar' -> + | Prod (na1,a1,t), (LocalAssum (_,a1'))::ar' -> let () = try conv env a1 a1' with NotConvertible -> raise (LocalArity None) in - srec (push_rel (na1,None,a1) env) t ar' + srec (push_rel (LocalAssum (na1,a1)) env) t ar' (* The last Prod domain is the type of the scrutinee *) | Prod (na1,a1,a2), [] -> (* whnf of t was not needed here! *) - let env' = push_rel (na1,None,a1) env in + let env' = push_rel (LocalAssum (na1,a1)) env in let ksort = match kind_of_term (whd_betadeltaiota env' a2) with | Sort s -> family_of_sort s | _ -> raise (LocalArity None) in @@ -351,7 +331,7 @@ let is_correct_arity env c pj ind specif params = try conv env a1 dep_ind with NotConvertible -> raise (LocalArity None) in check_allowed_sort ksort specif - | _, (_,Some _,_ as d)::ar' -> + | _, (LocalDef _ as d)::ar' -> srec (push_rel d env) (lift 1 pt') ar' | _ -> raise (LocalArity None) @@ -369,22 +349,22 @@ let is_correct_arity env c pj ind specif params = let build_branches_type (ind,u) (_,mip as specif) params p = let build_one_branch i cty = let typi = full_constructor_instantiate (ind,u,specif,params) cty in - let (args,ccl) = decompose_prod_assum typi in - let nargs = rel_context_length args in + let (cstrsign,ccl) = decompose_prod_assum typi in + let nargs = Context.Rel.length cstrsign in let (_,allargs) = decompose_app ccl in let (lparams,vargs) = List.chop (inductive_params specif) allargs in let cargs = let cstr = ith_constructor_of_inductive ind (i+1) in - let dep_cstr = applist (mkConstructU (cstr,u),lparams@(local_rels args)) in + let dep_cstr = applist (mkConstructU (cstr,u),lparams@(Context.Rel.to_extended_list 0 cstrsign)) in vargs @ [dep_cstr] in - let base = betazeta_appvect mip.mind_nrealdecls (lift nargs p) (Array.of_list cargs) in - it_mkProd_or_LetIn base args in + let base = lambda_appvect_assum (mip.mind_nrealdecls+1) (lift nargs p) (Array.of_list cargs) in + it_mkProd_or_LetIn base cstrsign in Array.mapi build_one_branch mip.mind_nf_lc (* [p] is the predicate, [c] is the match object, [realargs] is the list of real args of the inductive type *) let build_case_type env n p c realargs = - whd_betaiota env (betazeta_appvect (n+1) p (Array.of_list (realargs@[c]))) + whd_betaiota env (lambda_appvect_assum (n+1) p (Array.of_list (realargs@[c]))) let type_case_branches env (pind,largs) pj c = let specif = lookup_mind_specif env (fst pind) in @@ -500,10 +480,10 @@ type guard_env = let make_renv env recarg tree = { env = env; rel_min = recarg+2; (* recarg = 0 ==> Rel 1 -> recarg; Rel 2 -> fix *) - genv = [Lazy.lazy_from_val(Subterm(Large,tree))] } + genv = [Lazy.from_val(Subterm(Large,tree))] } let push_var renv (x,ty,spec) = - { env = push_rel (x,None,ty) renv.env; + { env = push_rel (LocalAssum (x,ty)) renv.env; rel_min = renv.rel_min+1; genv = spec:: renv.genv } @@ -519,7 +499,7 @@ let subterm_var p renv = with Failure _ | Invalid_argument _ -> Not_subterm let push_ctxt_renv renv ctxt = - let n = rel_context_length ctxt in + let n = Context.Rel.length ctxt in { env = push_rel_context ctxt renv.env; rel_min = renv.rel_min+n; genv = iterate (fun ge -> lazy Not_subterm::ge) n renv.genv } @@ -589,14 +569,14 @@ let check_inductive_codomain env p = (* The following functions are almost duplicated from indtypes.ml, except that they carry here a poorer environment (containing less information). *) let ienv_push_var (env, lra) (x,a,ra) = - (push_rel (x,None,a) env, (Norec,ra)::lra) + (push_rel (LocalAssum (x,a)) env, (Norec,ra)::lra) let ienv_push_inductive (env, ra_env) ((mind,u),lpar) = let mib = Environ.lookup_mind mind env in let ntypes = mib.mind_ntypes in let push_ind specif env = - push_rel (Anonymous,None, - hnf_prod_applist env (type_of_inductive env ((mib,specif),u)) lpar) env + let decl = LocalAssum (Anonymous, hnf_prod_applist env (type_of_inductive env ((mib,specif),u)) lpar) in + push_rel decl env in let env = Array.fold_right push_ind mib.mind_packets env in let rc = Array.mapi (fun j t -> (Imbr (mind,j),t)) (Rtree.mk_rec_calls ntypes) in @@ -721,7 +701,7 @@ let restrict_spec env spec p = else let absctx, ar = dest_lam_assum env p in (* Optimization: if the predicate is not dependent, no restriction is needed and we avoid building the recargs tree. *) - if noccur_with_meta 1 (rel_context_length absctx) ar then spec + if noccur_with_meta 1 (Context.Rel.length absctx) ar then spec else let env = push_rel_context absctx env in let arctx, s = dest_prod_assum env ar in @@ -814,7 +794,15 @@ let rec subterm_specif renv stack t = | Proj (p, c) -> let subt = subterm_specif renv stack c in (match subt with - | Subterm (s, wf) -> Subterm (Strict, wf) + | Subterm (s, wf) -> + (* We take the subterm specs of the constructor of the record *) + let wf_args = (dest_subterms wf).(0) in + (* We extract the tree of the projected argument *) + let kn = Projection.constant p in + let cb = lookup_constant kn renv.env in + let pb = Option.get cb.const_proj in + let n = pb.proj_arg in + Subterm (Strict, List.nth wf_args n) | Dead_code -> Dead_code | Not_subterm -> Not_subterm) @@ -829,7 +817,7 @@ and stack_element_specif = function |SArg x -> x and extract_stack renv a = function - | [] -> Lazy.lazy_from_val Not_subterm , [] + | [] -> Lazy.from_val Not_subterm , [] | h::t -> stack_element_specif h, t (* Check term c can be applied to one of the mutual fixpoints. *) @@ -863,13 +851,13 @@ let filter_stack_domain env ci p stack = let absctx, ar = dest_lam_assum env p in (* Optimization: if the predicate is not dependent, no restriction is needed and we avoid building the recargs tree. *) - if noccur_with_meta 1 (rel_context_length absctx) ar then stack + if noccur_with_meta 1 (Context.Rel.length absctx) ar then stack else let env = push_rel_context absctx env in let rec filter_stack env ar stack = let t = whd_betadeltaiota env ar in match stack, kind_of_term t with | elt :: stack', Prod (n,a,c0) -> - let d = (n,None,a) in + let d = LocalAssum (n,a) in let ty, args = decompose_app (whd_betadeltaiota env a) in let elt = match kind_of_term ty with | Ind ind -> @@ -926,10 +914,10 @@ let check_one_fix renv recpos trees def = end else begin - match pi2 (lookup_rel p renv.env) with - | None -> + match lookup_rel p renv.env with + | LocalAssum _ -> List.iter (check_rec_call renv []) l - | Some c -> + | LocalDef (_,c,_) -> try List.iter (check_rec_call renv []) l with FixGuardError _ -> check_rec_call renv stack (applist(lift p c,l)) @@ -1004,10 +992,11 @@ let check_one_fix renv recpos trees def = | Var id -> begin - match pi2 (lookup_named id renv.env) with - | None -> + let open Context.Named.Declaration in + match lookup_named id renv.env with + | LocalAssum _ -> List.iter (check_rec_call renv []) l - | Some c -> + | LocalDef (_,c,_) -> try List.iter (check_rec_call renv []) l with (FixGuardError _) -> check_rec_call renv stack (applist(c,l)) @@ -1061,7 +1050,7 @@ let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) = match kind_of_term (whd_betadeltaiota env def) with | Lambda (x,a,b) -> if noccur_with_meta n nbfix a then - let env' = push_rel (x, None, a) env in + let env' = push_rel (LocalAssum (x,a)) env in if Int.equal n (k + 1) then (* get the inductive type of the fixpoint *) let (mind, _) = @@ -1111,7 +1100,7 @@ let rec codomain_is_coind env c = let b = whd_betadeltaiota env c in match kind_of_term b with | Prod (x,a,b) -> - codomain_is_coind (push_rel (x, None, a) env) b + codomain_is_coind (push_rel (LocalAssum (x,a)) env) b | _ -> (try find_coinductive env b with Not_found -> @@ -1152,7 +1141,7 @@ let check_one_cofix env nbfix def deftype = | Lambda (x,a,b) -> let () = assert (List.is_empty args) in if noccur_with_meta n nbfix a then - let env' = push_rel (x, None, a) env in + let env' = push_rel (LocalAssum (x,a)) env in check_rec_call env' alreadygrd (n+1) tree vlra b else raise (CoFixGuardError (env,RecCallInTypeOfAbstraction a)) diff --git a/kernel/inductive.mli b/kernel/inductive.mli index 5847d25f6..c0d18bc6e 100644 --- a/kernel/inductive.mli +++ b/kernel/inductive.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,7 +8,6 @@ open Names open Term -open Context open Univ open Declarations open Environ @@ -35,7 +34,7 @@ val lookup_mind_specif : env -> inductive -> mind_specif (** {6 Functions to build standard types related to inductive } *) val ind_subst : mutual_inductive -> mutual_inductive_body -> universe_instance -> constr list -val inductive_paramdecls : mutual_inductive_body puniverses -> rel_context +val inductive_paramdecls : mutual_inductive_body puniverses -> Context.Rel.t val instantiate_inductive_constraints : mutual_inductive_body -> universe_instance -> constraints @@ -86,7 +85,7 @@ val build_branches_type : constr list -> constr -> types array (** Return the arity of an inductive type *) -val mind_arity : one_inductive_body -> rel_context * sorts_family +val mind_arity : one_inductive_body -> Context.Rel.t * sorts_family val inductive_sort_family : one_inductive_body -> sorts_family @@ -111,8 +110,8 @@ exception SingletonInductiveBecomesProp of Id.t val max_inductive_sort : sorts array -> universe -val instantiate_universes : env -> rel_context -> - template_arity -> constr Lazy.t array -> rel_context * sorts +val instantiate_universes : env -> Context.Rel.t -> + template_arity -> constr Lazy.t array -> Context.Rel.t * sorts (** {6 Debug} *) diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml index ba14f65d9..95990bea6 100644 --- a/kernel/mod_subst.ml +++ b/kernel/mod_subst.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/kernel/mod_subst.mli b/kernel/mod_subst.mli index cd9fa7921..6d86b9416 100644 --- a/kernel/mod_subst.mli +++ b/kernel/mod_subst.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index d4b381264..ff44f0f54 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -21,7 +21,7 @@ open Modops open Mod_subst type 'alg translation = - module_signature * 'alg option * delta_resolver * Univ.ContextSet.t + module_signature * 'alg * delta_resolver * Univ.ContextSet.t let rec mp_from_mexpr = function | MEident mp -> mp @@ -126,11 +126,17 @@ let rec check_with_def env struc (idl,(c,ctx)) mp equiv = 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 univs = + if cb.const_polymorphic then Some cb.const_universes + else None + in let cb' = { cb with const_body = def; - const_universes = univs; - const_body_code = Option.map Cemitcodes.from_val (compile_constant_body env' def) } + 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 @@ -177,8 +183,11 @@ let rec check_with_mod env struc (idl,mp1) mp equiv = begin try let mtb_old = module_type_of_module old in - Univ.ContextSet.add_constraints (Subtyping.check_subtypes env' mtb_mp1 mtb_old) old.mod_constraints - with Failure _ -> error_incorrect_with_constraint lab + let chk_cst = Subtyping.check_subtypes env' mtb_mp1 mtb_old in + Univ.ContextSet.add_constraints chk_cst old.mod_constraints + with Failure _ -> + (* TODO: where can a Failure come from ??? *) + error_incorrect_with_constraint lab end | Algebraic (NoFunctor (MEident(mp'))) -> check_modpath_equiv env' mp1 mp'; @@ -232,104 +241,89 @@ let rec check_with_mod env struc (idl,mp1) mp equiv = | Not_found -> error_no_such_label lab | Reduction.NotConvertible -> error_incorrect_with_constraint lab -let mk_alg_with alg wd = Option.map (fun a -> MEwith (a,wd)) alg - 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',Univ.ContextSet.to_context cst'))) in - (NoFunctor struc'),alg',reso, cst+++cst' + let wd' = WithDef (idl,(c',Univ.ContextSet.to_context cst')) in + NoFunctor struc', MEwith (alg,wd'), 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 - let alg' = mk_alg_with alg wd in - (NoFunctor struc'),alg',reso', cst+++cst' + NoFunctor struc', MEwith (alg,wd), reso', cst+++cst' -let mk_alg_app mpo alg arg = match mpo, alg with - | Some _, Some alg -> Some (MEapply (alg,arg)) - | _ -> None +let translate_apply env inl (sign,alg,reso,cst1) mp1 mkalg = + let farg_id, farg_b, fbody_b = destr_functor sign in + let mtb = module_type_of_module (lookup_module mp1 env) in + let cst2 = Subtyping.check_subtypes env mtb farg_b in + let mp_delta = discr_resolver mtb in + let mp_delta = inline_delta_resolver env inl mp1 farg_id farg_b mp_delta in + let subst = map_mbid farg_id mp1 mp_delta in + 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', Univ.ContextSet.add_constraints cst2 cst1 (** Translation of a module struct entry : - We translate to a module when a [module_path] is given, otherwise to a module type. - The first output is the expanded signature - The second output is the algebraic expression, kept for the extraction. - It is never None when translating to a module, but for module type - it could not be contain [SEBapply] or [SEBfunctor]. *) +let mk_alg_app alg arg = MEapply (alg,arg) + let rec translate_mse env mpo inl = function - |MEident mp1 -> - let sign,reso = match mpo with - |Some mp -> - let mb = strengthen_and_subst_mb (lookup_module mp1 env) mp false in - mb.mod_type, mb.mod_delta - |None -> - let mtb = lookup_modtype mp1 env in - mtb.mod_type, mtb.mod_delta + |MEident mp1 as me -> + let mb = match mpo with + |Some mp -> strengthen_and_subst_mb (lookup_module mp1 env) mp false + |None -> lookup_modtype mp1 env in - sign,Some (MEident mp1),reso,Univ.ContextSet.empty + mb.mod_type, me, mb.mod_delta, Univ.ContextSet.empty |MEapply (fe,mp1) -> - translate_apply env inl (translate_mse env mpo inl fe) mp1 (mk_alg_app mpo) + translate_apply env inl (translate_mse env mpo inl fe) mp1 mk_alg_app |MEwith(me, with_decl) -> assert (mpo == None); (* No 'with' syntax for modules *) let mp = mp_from_mexpr me in check_with env mp (translate_mse env None inl me) with_decl -and translate_apply env inl (sign,alg,reso,cst1) mp1 mkalg = - let farg_id, farg_b, fbody_b = destr_functor sign in - let mtb = module_type_of_module (lookup_module mp1 env) in - let cst2 = Subtyping.check_subtypes env mtb farg_b in - let mp_delta = discr_resolver mtb in - let mp_delta = inline_delta_resolver env inl mp1 farg_id farg_b mp_delta in - let subst = map_mbid farg_id mp1 mp_delta in - 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', 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)) - | _ -> None - -let mk_mod mp e ty ty' cst reso = +let mk_mod mp e ty cst reso = { mod_mp = mp; mod_expr = e; mod_type = ty; - mod_type_alg = ty'; + mod_type_alg = None; mod_constraints = cst; mod_delta = reso; mod_retroknowledge = [] } -let mk_modtype mp ty cst reso = mk_mod mp Abstract ty None cst reso +let mk_modtype mp ty cst reso = mk_mod mp Abstract ty cst reso let rec translate_mse_funct env mpo inl mse = function |[] -> let sign,alg,reso,cst = translate_mse env mpo inl mse in - sign, Option.map (fun a -> NoFunctor a) alg, reso, cst + sign, NoFunctor alg, reso, cst |(mbid, ty) :: params -> let mp_id = MPbound mbid in let mtb = translate_modtype env mp_id inl ([],ty) in let env' = add_module_type mp_id mtb env in let sign,alg,reso,cst = translate_mse_funct env' mpo inl mse params in - let alg' = mk_alg_funct mpo mbid mtb alg in + let alg' = MoreFunctor (mbid,mtb,alg) in MoreFunctor (mbid, mtb, sign), alg',reso, cst +++ mtb.mod_constraints and translate_modtype env mp inl (params,mte) = let sign,alg,reso,cst = translate_mse_funct env None inl mte params in let mtb = mk_modtype (mp_from_mexpr mte) sign cst reso in let mtb' = subst_modtype_and_resolver mtb mp in - { mtb' with mod_type_alg = alg } + { mtb' with mod_type_alg = Some alg } (** [finalize_module] : - from an already-translated (or interactive) implementation - and a signature entry, produce a final [module_expr] *) + from an already-translated (or interactive) implementation and + an (optional) signature entry, produces a final [module_body] *) let finalize_module env mp (sign,alg,reso,cst) restype = match restype with |None -> let impl = match alg with Some e -> Algebraic e | None -> FullStruct in - mk_mod mp impl sign None cst reso + mk_mod mp impl sign 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.ContextSet.empty reso in @@ -338,33 +332,59 @@ let finalize_module env mp (sign,alg,reso,cst) restype = match restype with { res_mtb with mod_mp = mp; mod_expr = impl; - (** 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) } + (** cst from module body typing, + cst' from subtyping, + 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) -> let mtb = translate_modtype env mp inl (params,ty) in module_body_of_type mp mtb |MExpr (params,mse,oty) -> - let t = translate_mse_funct env (Some mp) inl mse params in + let (sg,alg,reso,cst) = translate_mse_funct env (Some mp) inl mse params in let restype = Option.map (fun ty -> ((params,ty),inl)) oty in - finalize_module env mp t restype + finalize_module env mp (sg,Some alg,reso,cst) restype + +(** We now forbid any Include of functors with restricted signatures. + Otherwise, we could end with the creation of undesired axioms + (see #3746). Note that restricted non-functorized modules are ok, + thanks to strengthening. *) + +let rec unfunct = function + |NoFunctor me -> me + |MoreFunctor(_,_,me) -> unfunct me + +let rec forbid_incl_signed_functor env = function + |MEapply(fe,_) -> forbid_incl_signed_functor env fe + |MEwith _ -> assert false (* No 'with' syntax for modules *) + |MEident mp1 -> + let mb = lookup_module mp1 env in + match mb.mod_type, mb.mod_type_alg, mb.mod_expr with + |MoreFunctor _, Some _, _ -> + (* functor + restricted signature = error *) + error_include_restricted_functor mp1 + |MoreFunctor _, None, Algebraic me -> + (* functor, no signature yet, a definition which may be restricted *) + forbid_incl_signed_functor env (unfunct me) + |_ -> () 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.ContextSet.empty + sign,(),mb.mod_delta,Univ.ContextSet.empty |MEapply (fe,arg) -> let ftrans = translate_mse_inclmod env mp inl fe in - translate_apply env inl ftrans arg (fun _ _ -> None) + translate_apply env inl ftrans arg (fun _ _ -> ()) |MEwith _ -> assert false (* No 'with' syntax for modules *) let translate_mse_incl is_mod env mp inl me = if is_mod then + let () = forbid_incl_signed_functor env me in 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 + sign,(),mtb.mod_delta,mtb.mod_constraints diff --git a/kernel/mod_typing.mli b/kernel/mod_typing.mli index bc0e20205..5949dad08 100644 --- a/kernel/mod_typing.mli +++ b/kernel/mod_typing.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -14,9 +14,18 @@ open Names (** Main functions for translating module entries *) +(** [translate_module] produces a [module_body] out of a [module_entry]. + In the output fields: + - [mod_expr] is [Abstract] for a [MType] entry, or [Algebraic] for [MExpr]. + - [mod_type_alg] is [None] only for a [MExpr] without explicit signature. +*) + val translate_module : env -> module_path -> inline -> module_entry -> module_body +(** [translate_modtype] produces a [module_type_body] whose [mod_type_alg] + cannot be [None] (and of course [mod_expr] is [Abstract]). *) + val translate_modtype : env -> module_path -> inline -> module_type_entry -> module_type_body @@ -24,20 +33,21 @@ val translate_modtype : - We translate to a module when a [module_path] is given, otherwise to a module type. - The first output is the expanded signature - - The second output is the algebraic expression, kept for the extraction. - It is never None when translating to a module, but for module type - it could not be contain applications or functors. -*) + - The second output is the algebraic expression, kept mostly for + the extraction. *) type 'alg translation = - module_signature * 'alg option * delta_resolver * Univ.ContextSet.t + module_signature * 'alg * delta_resolver * Univ.ContextSet.t val translate_mse : env -> module_path option -> inline -> module_struct_entry -> module_alg_expr translation +(** From an already-translated (or interactive) implementation and + an (optional) signature entry, produces a final [module_body] *) + val finalize_module : - env -> module_path -> module_expression translation -> + env -> module_path -> (module_expression option) translation -> (module_type_entry * inline) option -> module_body @@ -46,4 +56,4 @@ val finalize_module : val translate_mse_incl : bool -> env -> module_path -> inline -> module_struct_entry -> - module_alg_expr translation + unit translation diff --git a/kernel/modops.ml b/kernel/modops.ml index f0cb65c96..6fe7e382c 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -67,15 +67,13 @@ type module_typing_error = | IncorrectWithConstraint of Label.t | GenerativeModuleExpected of Label.t | LabelMissing of Label.t * string + | IncludeRestrictedFunctor of module_path exception ModuleTypingError of module_typing_error let error_existing_label l = raise (ModuleTypingError (LabelAlreadyDeclared l)) -let error_application_to_not_path mexpr = - raise (ModuleTypingError (ApplicationToNotPath mexpr)) - let error_not_a_functor () = raise (ModuleTypingError NotAFunctor) @@ -112,6 +110,9 @@ let error_generative_module_expected l = let error_no_such_label_sub l l1 = raise (ModuleTypingError (LabelMissing (l,l1))) +let error_include_restricted_functor mp = + raise (ModuleTypingError (IncludeRestrictedFunctor mp)) + (** {6 Operations on functors } *) let is_functor = function @@ -335,7 +336,7 @@ let strengthen_const mp_from l cb resolver = 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 a335ad9b4..e9f3db6e9 100644 --- a/kernel/modops.mli +++ b/kernel/modops.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -126,13 +126,12 @@ type module_typing_error = | IncorrectWithConstraint of Label.t | GenerativeModuleExpected of Label.t | LabelMissing of Label.t * string + | IncludeRestrictedFunctor of module_path exception ModuleTypingError of module_typing_error val error_existing_label : Label.t -> 'a -val error_application_to_not_path : module_struct_entry -> 'a - val error_incompatible_modtypes : module_type_body -> module_type_body -> 'a @@ -152,3 +151,5 @@ 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_include_restricted_functor : module_path -> 'a diff --git a/kernel/names.ml b/kernel/names.ml index 9e4e8cd61..8e0237863 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -23,6 +23,7 @@ open Util (** {6 Identifiers } *) +(** Representation and operations on identifiers. *) module Id = struct type t = string @@ -74,10 +75,18 @@ struct end - +(** Representation and operations on identifiers that are allowed to be anonymous + (i.e. "_" in concrete syntax). *) module Name = struct - type t = Name of Id.t | Anonymous + type t = Anonymous (** anonymous identifier *) + | Name of Id.t (** non-anonymous identifier *) + + let is_anonymous = function + | Anonymous -> true + | Name _ -> false + + let is_name = not % is_anonymous let compare n1 n2 = match n1, n2 with | Anonymous, Anonymous -> 0 @@ -102,7 +111,7 @@ struct let hashcons hident = function | Name id -> Name (hident id) | n -> n - let equal n1 n2 = + let eq n1 n2 = n1 == n2 || match (n1,n2) with | (Name id1, Name id2) -> id1 == id2 @@ -117,8 +126,8 @@ struct end -type name = Name.t = Name of Id.t | Anonymous (** Alias, to import constructors. *) +type name = Name.t = Anonymous | Name of Id.t (** {6 Various types based on identifiers } *) @@ -236,7 +245,7 @@ struct type t = _t type u = (Id.t -> Id.t) * (DirPath.t -> DirPath.t) let hashcons (hid,hdir) (n,s,dir) = (n,hid s,hdir dir) - let equal ((n1,s1,dir1) as x) ((n2,s2,dir2) as y) = + let eq ((n1,s1,dir1) as x) ((n2,s2,dir2) as y) = (x == y) || (Int.equal n1 n2 && s1 == s2 && dir1 == dir2) let hash = hash @@ -332,7 +341,7 @@ module ModPath = struct | MPfile dir -> MPfile (hdir dir) | MPbound m -> MPbound (huniqid m) | MPdot (md,l) -> MPdot (hashcons hfuns md, hstr l) - let rec equal d1 d2 = + let rec eq d1 d2 = d1 == d2 || match d1,d2 with | MPfile dir1, MPfile dir2 -> dir1 == dir2 @@ -432,7 +441,7 @@ module KerName = struct let hashcons (hmod,hdir,hstr) kn = let { modpath = mp; dirpath = dp; knlabel = l; refhash; } = kn in { modpath = hmod mp; dirpath = hdir dp; knlabel = hstr l; refhash; canary; } - let equal kn1 kn2 = + let eq kn1 kn2 = kn1.modpath == kn2.modpath && kn1.dirpath == kn2.dirpath && kn1.knlabel == kn2.knlabel let hash = hash @@ -486,7 +495,7 @@ module KerPair = struct | Dual (kn,_) -> kn let same kn = Same kn - let make knu knc = if knu == knc then Same knc else Dual (knu,knc) + let make knu knc = if KerName.equal knu knc then Same knc else Dual (knu,knc) let make1 = same let make2 mp l = same (KerName.make2 mp l) @@ -533,6 +542,23 @@ module KerPair = struct let hash x = KerName.hash (canonical x) end + module SyntacticOrd = struct + type t = kernel_pair + let compare x y = match x, y with + | Same knx, Same kny -> KerName.compare knx kny + | Dual (knux,kncx), Dual (knuy,kncy) -> + let c = KerName.compare knux knuy in + if not (Int.equal c 0) then c + else KerName.compare kncx kncy + | Same _, _ -> -1 + | Dual _, _ -> 1 + let equal x y = x == y || compare x y = 0 + let hash = function + | Same kn -> KerName.hash kn + | Dual (knu, knc) -> + Hashset.Combine.combine (KerName.hash knu) (KerName.hash knc) + end + (** Default (logical) comparison and hash is on the canonical part *) let equal = CanOrd.equal let hash = CanOrd.hash @@ -544,7 +570,7 @@ module KerPair = struct let hashcons hkn = function | Same kn -> Same (hkn kn) | Dual (knu,knc) -> make (hkn knu) (hkn knc) - let equal x y = (* physical comparison on subterms *) + let eq x y = (* physical comparison on subterms *) x == y || match x,y with | Same x, Same y -> x == y @@ -582,11 +608,16 @@ module Mindmap = HMap.Make(MutInd.CanOrd) module Mindset = Mindmap.Set module Mindmap_env = HMap.Make(MutInd.UserOrd) -(** Beware: first inductive has index 0 *) -(** Beware: first constructor has index 1 *) +(** Designation of a (particular) inductive type. *) +type inductive = MutInd.t (* the name of the inductive type *) + * int (* the position of this inductive type + within the block of mutually-recursive inductive types. + BEWARE: indexing starts from 0. *) -type inductive = MutInd.t * int -type constructor = inductive * int +(** Designation of a (particular) constructor of a (particular) inductive type. *) +type constructor = inductive (* designates the inductive type *) + * int (* the index of the constructor + BEWARE: indexing starts from 1. *) let ind_modpath (mind,_) = MutInd.modpath mind let constr_modpath (ind,_) = ind_modpath ind @@ -599,6 +630,8 @@ let index_of_constructor (ind, i) = i let eq_ind (m1, i1) (m2, i2) = Int.equal i1 i2 && MutInd.equal m1 m2 let eq_user_ind (m1, i1) (m2, i2) = Int.equal i1 i2 && MutInd.UserOrd.equal m1 m2 +let eq_syntactic_ind (m1, i1) (m2, i2) = + Int.equal i1 i2 && MutInd.SyntacticOrd.equal m1 m2 let ind_ord (m1, i1) (m2, i2) = let c = Int.compare i1 i2 in @@ -606,15 +639,22 @@ let ind_ord (m1, i1) (m2, i2) = let ind_user_ord (m1, i1) (m2, i2) = let c = Int.compare i1 i2 in if Int.equal c 0 then MutInd.UserOrd.compare m1 m2 else c +let ind_syntactic_ord (m1, i1) (m2, i2) = + let c = Int.compare i1 i2 in + if Int.equal c 0 then MutInd.SyntacticOrd.compare m1 m2 else c let ind_hash (m, i) = Hashset.Combine.combine (MutInd.hash m) (Int.hash i) let ind_user_hash (m, i) = Hashset.Combine.combine (MutInd.UserOrd.hash m) (Int.hash i) +let ind_syntactic_hash (m, i) = + Hashset.Combine.combine (MutInd.SyntacticOrd.hash m) (Int.hash i) let eq_constructor (ind1, j1) (ind2, j2) = Int.equal j1 j2 && eq_ind ind1 ind2 let eq_user_constructor (ind1, j1) (ind2, j2) = Int.equal j1 j2 && eq_user_ind ind1 ind2 +let eq_syntactic_constructor (ind1, j1) (ind2, j2) = + Int.equal j1 j2 && eq_syntactic_ind ind1 ind2 let constructor_ord (ind1, j1) (ind2, j2) = let c = Int.compare j1 j2 in @@ -622,11 +662,16 @@ let constructor_ord (ind1, j1) (ind2, j2) = let constructor_user_ord (ind1, j1) (ind2, j2) = let c = Int.compare j1 j2 in if Int.equal c 0 then ind_user_ord ind1 ind2 else c +let constructor_syntactic_ord (ind1, j1) (ind2, j2) = + let c = Int.compare j1 j2 in + if Int.equal c 0 then ind_syntactic_ord ind1 ind2 else c let constructor_hash (ind, i) = Hashset.Combine.combine (ind_hash ind) (Int.hash i) let constructor_user_hash (ind, i) = Hashset.Combine.combine (ind_user_hash ind) (Int.hash i) +let constructor_syntactic_hash (ind, i) = + Hashset.Combine.combine (ind_syntactic_hash ind) (Int.hash i) module InductiveOrdered = struct type t = inductive @@ -671,7 +716,7 @@ module Hind = Hashcons.Make( type t = inductive type u = MutInd.t -> MutInd.t let hashcons hmind (mind, i) = (hmind mind, i) - let equal (mind1,i1) (mind2,i2) = mind1 == mind2 && Int.equal i1 i2 + let eq (mind1,i1) (mind2,i2) = mind1 == mind2 && Int.equal i1 i2 let hash = ind_hash end) @@ -680,7 +725,7 @@ module Hconstruct = Hashcons.Make( type t = constructor type u = inductive -> inductive let hashcons hind (ind, j) = (hind ind, j) - let equal (ind1, j1) (ind2, j2) = ind1 == ind2 && Int.equal j1 j2 + let eq (ind1, j1) (ind2, j2) = ind1 == ind2 && Int.equal j1 j2 let hash = constructor_hash end) @@ -814,13 +859,22 @@ struct let hash (c, b) = (if b then 0 else 1) + Constant.hash c + module SyntacticOrd = struct + type t = constant * bool + let compare (c, b) (c', b') = + if b = b' then Constant.SyntacticOrd.compare c c' else -1 + let equal (c, b as x) (c', b' as x') = + x == x' || b = b' && Constant.SyntacticOrd.equal c c' + let hash (c, b) = (if b then 0 else 1) + Constant.SyntacticOrd.hash c + end + module Self_Hashcons = struct type _t = t type t = _t type u = Constant.t -> Constant.t let hashcons hc (c,b) = (hc c,b) - let equal ((c,b) as x) ((c',b') as y) = + let eq ((c,b) as x) ((c',b') as y) = x == y || (c == c' && b == b') let hash = hash end diff --git a/kernel/names.mli b/kernel/names.mli index 77139f1c3..1dfdd8290 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -10,30 +10,33 @@ open Util (** {6 Identifiers } *) +(** Representation and operations on identifiers. *) module Id : sig type t - (** Type of identifiers *) + (** Values of this type represent (Coq) identifiers. *) val equal : t -> t -> bool - (** Equality over identifiers *) + (** Equality over identifiers. *) val compare : t -> t -> int - (** Comparison over identifiers *) + (** Comparison over identifiers. *) val hash : t -> int - (** Hash over identifiers *) + (** Hash over identifiers. *) val is_valid : string -> bool - (** Check that a string may be converted to an identifier. *) + (** Check that a string may be converted to an identifier. + @raise Unicode.Unsupported if the provided string contains unsupported UTF-8 characters. *) val of_string : string -> t - (** Converts a string into an identifier. May raise [UserError _] if the - string is not valid, or echo a warning if it contains invalid identifier - characters. *) + (** Converts a string into an identifier. + @raise UserError if the string is not valid, or echo a warning if it contains invalid identifier characters. + @raise Unicode.Unsupported if the provided string contains unsupported UTF-8 characters. *) val of_string_soft : string -> t - (** Same as {!of_string} except that no warning is ever issued. *) + (** Same as {!of_string} except that no warning is ever issued. + @raise Unicode.Unsupported if the provided string contains unsupported UTF-8 characters. *) val to_string : t -> string (** Converts a identifier into an string. *) @@ -58,10 +61,18 @@ sig end +(** Representation and operations on identifiers that are allowed to be anonymous + (i.e. "_" in concrete syntax). *) module Name : sig - type t = Name of Id.t | Anonymous - (** A name is either undefined, either an identifier. *) + type t = Anonymous (** anonymous identifier *) + | Name of Id.t (** non-anonymous identifier *) + + val is_anonymous : t -> bool + (** Return [true] iff a given name is [Anonymous]. *) + + val is_name : t -> bool + (** Return [true] iff a given name is [Name _]. *) val compare : t -> t -> int (** Comparison over names. *) @@ -79,7 +90,7 @@ end (** {6 Type aliases} *) -type name = Name.t = Name of Id.t | Anonymous +type name = Name.t = Anonymous | Name of Id.t type variable = Id.t type module_ident = Id.t @@ -160,6 +171,8 @@ sig module Set : Set.S with type elt = t module Map : Map.ExtS with type key = t and module Set := Set + val hcons : t -> t + end (** {6 Unique names for bound modules} *) @@ -312,6 +325,12 @@ sig val hash : t -> int end + module SyntacticOrd : sig + val compare : t -> t -> int + val equal : t -> t -> bool + val hash : t -> int + end + val equal : t -> t -> bool (** Default comparison, alias for [CanOrd.equal] *) @@ -386,6 +405,12 @@ sig val hash : t -> int end + module SyntacticOrd : sig + val compare : t -> t -> int + val equal : t -> t -> bool + val hash : t -> int + end + val equal : t -> t -> bool (** Default comparison, alias for [CanOrd.equal] *) @@ -402,18 +427,23 @@ end module Mindset : CSig.SetS with type elt = MutInd.t module Mindmap : Map.ExtS with type key = MutInd.t and module Set := Mindset -module Mindmap_env : Map.S with type key = MutInd.t +module Mindmap_env : CSig.MapS with type key = MutInd.t -(** Beware: first inductive has index 0 *) -type inductive = MutInd.t * int +(** Designation of a (particular) inductive type. *) +type inductive = MutInd.t (* the name of the inductive type *) + * int (* the position of this inductive type + within the block of mutually-recursive inductive types. + BEWARE: indexing starts from 0. *) -(** Beware: first constructor has index 1 *) -type constructor = inductive * int +(** Designation of a (particular) constructor of a (particular) inductive type. *) +type constructor = inductive (* designates the inductive type *) + * int (* the index of the constructor + BEWARE: indexing starts from 1. *) -module Indmap : Map.S with type key = inductive -module Constrmap : Map.S with type key = constructor -module Indmap_env : Map.S with type key = inductive -module Constrmap_env : Map.S with type key = constructor +module Indmap : CSig.MapS with type key = inductive +module Constrmap : CSig.MapS with type key = constructor +module Indmap_env : CSig.MapS with type key = inductive +module Constrmap_env : CSig.MapS with type key = constructor val ind_modpath : inductive -> ModPath.t val constr_modpath : constructor -> ModPath.t @@ -424,16 +454,22 @@ val inductive_of_constructor : constructor -> inductive val index_of_constructor : constructor -> int val eq_ind : inductive -> inductive -> bool val eq_user_ind : inductive -> inductive -> bool +val eq_syntactic_ind : inductive -> inductive -> bool val ind_ord : inductive -> inductive -> int val ind_hash : inductive -> int val ind_user_ord : inductive -> inductive -> int val ind_user_hash : inductive -> int +val ind_syntactic_ord : inductive -> inductive -> int +val ind_syntactic_hash : inductive -> int val eq_constructor : constructor -> constructor -> bool val eq_user_constructor : constructor -> constructor -> bool +val eq_syntactic_constructor : constructor -> constructor -> bool val constructor_ord : constructor -> constructor -> int -val constructor_user_ord : constructor -> constructor -> int val constructor_hash : constructor -> int +val constructor_user_ord : constructor -> constructor -> int val constructor_user_hash : constructor -> int +val constructor_syntactic_ord : constructor -> constructor -> int +val constructor_syntactic_hash : constructor -> int (** Better to have it here that in Closure, since required in grammar.cma *) type evaluable_global_reference = @@ -647,6 +683,12 @@ module Projection : sig val make : constant -> bool -> t + module SyntacticOrd : sig + val compare : t -> t -> int + val equal : t -> t -> bool + val hash : t -> int + end + val constant : t -> constant val unfolded : t -> bool val unfold : t -> t diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index 98b2d6d2e..dabe905de 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,7 +8,6 @@ open Errors open Names open Term -open Context open Declarations open Util open Nativevalues @@ -1826,31 +1825,32 @@ and apply_fv env sigma univ (fv_named,fv_rel) auxdefs ml = in let auxdefs = List.fold_right get_rel_val fv_rel auxdefs in let auxdefs = List.fold_right get_named_val fv_named auxdefs in - let lvl = rel_context_length env.env_rel_context in + let lvl = Context.Rel.length env.env_rel_context in let fv_rel = List.map (fun (n,_) -> MLglobal (Grel (lvl-n))) fv_rel in let fv_named = List.map (fun (id,_) -> MLglobal (Gnamed id)) fv_named in let aux_name = fresh_lname Anonymous in auxdefs, MLlet(aux_name, ml, mkMLapp (MLlocal aux_name) (Array.of_list (fv_rel@fv_named))) and compile_rel env sigma univ auxdefs n = - let (_,body,_) = lookup_rel n env.env_rel_context in - let n = rel_context_length env.env_rel_context - n in - match body with - | Some t -> + let open Context.Rel in + let n = length env.env_rel_context - n in + let open Declaration in + match lookup n env.env_rel_context with + | LocalDef (_,t,_) -> let code = lambda_of_constr env sigma t in let auxdefs,code = compile_with_fv env sigma univ auxdefs None code in Glet(Grel n, code)::auxdefs - | None -> + | LocalAssum _ -> Glet(Grel n, MLprimitive (Mk_rel n))::auxdefs and compile_named env sigma univ auxdefs id = - let (_,body,_) = lookup_named id env.env_named_context in - match body with - | Some t -> + let open Context.Named.Declaration in + match Context.Named.lookup id env.env_named_context with + | LocalDef (_,t,_) -> let code = lambda_of_constr env sigma t in let auxdefs,code = compile_with_fv env sigma univ auxdefs None code in Glet(Gnamed id, code)::auxdefs - | None -> + | LocalAssum _ -> Glet(Gnamed id, MLprimitive (Mk_var id))::auxdefs let compile_constant env sigma prefix ~interactive con cb = diff --git a/kernel/nativecode.mli b/kernel/nativecode.mli index 5d4c9e1e2..77d9c33f8 100644 --- a/kernel/nativecode.mli +++ b/kernel/nativecode.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/kernel/nativeconv.ml b/kernel/nativeconv.ml index 7ae66c485..7ac5b8d7b 100644 --- a/kernel/nativeconv.ml +++ b/kernel/nativeconv.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -63,10 +63,12 @@ and conv_atom env pb lvl a1 a2 cu = | Ameta _, _ | _, Ameta _ | Aevar _, _ | _, Aevar _ -> assert false | Arel i1, Arel i2 -> if Int.equal i1 i2 then cu else raise NotConvertible - | Aind ind1, Aind ind2 -> - if eq_puniverses eq_ind ind1 ind2 then cu else raise NotConvertible - | Aconstant c1, Aconstant c2 -> - if eq_puniverses eq_constant c1 c2 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 -> sort_cmp_universes env pb s1 s2 cu | Avar id1, Avar id2 -> diff --git a/kernel/nativeconv.mli b/kernel/nativeconv.mli index 4dddb9fd3..63b1eb058 100644 --- a/kernel/nativeconv.mli +++ b/kernel/nativeconv.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -11,7 +11,7 @@ open Nativelambda (** This module implements the conversion test by compiling to OCaml code *) -val native_conv : conv_pb -> evars -> types conversion_function +val native_conv : conv_pb -> evars -> types kernel_conversion_function (** A conversion function parametrized by a universe comparator. Used outside of the kernel. *) diff --git a/kernel/nativeinstr.mli b/kernel/nativeinstr.mli index b7d3dadcd..41e79a535 100644 --- a/kernel/nativeinstr.mli +++ b/kernel/nativeinstr.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index 263befd21..91b40be7e 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -379,7 +379,7 @@ let rec get_alias env (kn, u as p) = | None -> p | Some tps -> match Cemitcodes.force tps with - | Cemitcodes.BCalias kn' -> get_alias env kn' + | Cemitcodes.BCalias kn' -> get_alias env (kn', u) | _ -> p (*i Global environment *) @@ -485,7 +485,7 @@ module Renv = let pop env = Vect.pop env.name_rel let popn env n = - for i = 1 to n do pop env done + for _i = 1 to n do pop env done let get env n = Lrel (Vect.get_last env.name_rel (n-1), n) @@ -727,7 +727,8 @@ let optimize lam = let lambda_of_constr env sigma c = set_global_env env; let env = Renv.make () in - let ids = List.rev_map (fun (id, _, _) -> id) !global_env.env_rel_context in + let open Context.Rel.Declaration in + let ids = List.rev_map get_name !global_env.env_rel_context in Renv.push_rels env (Array.of_list ids); let lam = lambda_of_constr env sigma c in (* if Flags.vm_draw_opt () then begin diff --git a/kernel/nativelambda.mli b/kernel/nativelambda.mli index 3b6fafbbc..c33574408 100644 --- a/kernel/nativelambda.mli +++ b/kernel/nativelambda.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/kernel/nativelib.ml b/kernel/nativelib.ml index 331598d85..4296b73ab 100644 --- a/kernel/nativelib.ml +++ b/kernel/nativelib.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -74,7 +74,17 @@ let call_compiler ml_filename = ::include_dirs @ ["-impl"; ml_filename] in if !Flags.debug then Pp.msg_debug (Pp.str (ocamlfind () ^ " " ^ (String.concat " " args))); - try CUnix.sys_command (ocamlfind ()) args = Unix.WEXITED 0, link_filename + try + let res = CUnix.sys_command (ocamlfind ()) args in + let res = match res with + | Unix.WEXITED 0 -> true + | Unix.WEXITED n -> + Pp.(msg_warning (str "command exited with status " ++ int n)); false + | Unix.WSIGNALED n -> + Pp.(msg_warning (str "command killed by signal " ++ int n)); false + | Unix.WSTOPPED n -> + Pp.(msg_warning (str "command stopped by signal " ++ int n)); false in + res, link_filename with Unix.Unix_error (e,_,_) -> Pp.(msg_warning (str (Unix.error_message e))); false, link_filename diff --git a/kernel/nativelib.mli b/kernel/nativelib.mli index 0941dc56c..12ad3cf2f 100644 --- a/kernel/nativelib.mli +++ b/kernel/nativelib.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/kernel/nativelibrary.ml b/kernel/nativelibrary.ml index 443cd8c2a..9d159be64 100644 --- a/kernel/nativelibrary.ml +++ b/kernel/nativelibrary.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/kernel/nativelibrary.mli b/kernel/nativelibrary.mli index 29368d140..7d01640b2 100644 --- a/kernel/nativelibrary.mli +++ b/kernel/nativelibrary.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/kernel/nativevalues.ml b/kernel/nativevalues.ml index e4a779993..d6fdfefa0 100644 --- a/kernel/nativevalues.ml +++ b/kernel/nativevalues.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -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 @@ -78,8 +78,6 @@ let accumulate_code (k:accumulator) (x:t) = let rec accumulate (x:t) = accumulate_code (Obj.magic accumulate) x -let raccumulate = ref accumulate - let mk_accu_gen rcode (a:atom) = (* Format.eprintf "size rcode =%i\n" (Obj.size (Obj.magic rcode)); *) let r = Obj.new_block 0 3 in @@ -160,31 +158,6 @@ let is_accu x = let o = Obj.repr x in Obj.is_block o && Int.equal (Obj.tag o) accumulate_tag -(*let accumulate_fix_code (k:accumulator) (a:t) = - match atom_of_accu k with - | Afix(frec,_,rec_pos,_,_) -> - let nargs = accu_nargs k in - if nargs <> rec_pos || is_accu a then - accumulate_code k a - else - let r = ref frec in - for i = 0 to nargs - 1 do - r := !r (arg_of_accu k i) - done; - !r a - | _ -> assert false - - -let rec accumulate_fix (x:t) = - accumulate_fix_code (Obj.magic accumulate_fix) x - -let raccumulate_fix = ref accumulate_fix *) - -let is_atom_fix (a:atom) = - match a with - | Afix _ -> true - | _ -> false - let mk_fix_accu rec_pos pos types bodies = mk_accu_gen accumulate (Afix(types,bodies,rec_pos, pos)) diff --git a/kernel/nativevalues.mli b/kernel/nativevalues.mli index 79e35d4a0..f4396659e 100644 --- a/kernel/nativevalues.mli +++ b/kernel/nativevalues.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/kernel/opaqueproof.ml b/kernel/opaqueproof.ml index 9f4361f40..0c8772d8d 100644 --- a/kernel/opaqueproof.ml +++ b/kernel/opaqueproof.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -16,7 +16,7 @@ type work_list = (Instance.t * Id.t array) Cmap.t * type cooking_info = { modlist : work_list; - abstract : Context.named_context * Univ.universe_level_subst * Univ.UContext.t } + abstract : Context.Named.t * Univ.universe_level_subst * Univ.UContext.t } type proofterm = (constr * Univ.universe_context_set) Future.computation type opaque = | Indirect of substitution list * DirPath.t * int (* subst, lib, index *) @@ -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/opaqueproof.mli b/kernel/opaqueproof.mli index 0609c8517..5139cf051 100644 --- a/kernel/opaqueproof.mli +++ b/kernel/opaqueproof.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -11,9 +11,9 @@ open Term open Mod_subst (** This module implements the handling of opaque proof terms. - Opauqe proof terms are special since: + Opaque proof terms are special since: - they can be lazily computed and substituted - - they are stoked in an optionally loaded segment of .vo files + - they are stored in an optionally loaded segment of .vo files An [opaque] proof terms holds the real data until fully discharged. In this case it is called [direct]. When it is [turn_indirect] the data is relocated to an opaque table @@ -48,7 +48,7 @@ type work_list = (Univ.Instance.t * Id.t array) Cmap.t * type cooking_info = { modlist : work_list; - abstract : Context.named_context * Univ.universe_level_subst * Univ.UContext.t } + abstract : Context.Named.t * Univ.universe_level_subst * Univ.UContext.t } (* The type has two caveats: 1) cook_constr is defined after diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml index 615b9d49b..0e56e76aa 100644 --- a/kernel/pre_env.ml +++ b/kernel/pre_env.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -15,17 +15,17 @@ open Util open Names -open Context open Univ open Term open Declarations +open Context.Named.Declaration (* The type of environments. *) (* The key attached to each constant is used by the VM to retrieve previous *) (* evaluations of the constant. It is essentially an index in the symbols table *) (* used by the VM. *) -type key = int Ephemeron.key option ref +type key = int CEphemeron.key option ref (** Linking information for the native compiler. *) @@ -50,25 +50,25 @@ type stratification = { } type val_kind = - | VKvalue of (values * Id.Set.t) Ephemeron.key + | VKvalue of (values * Id.Set.t) CEphemeron.key | VKnone type lazy_val = val_kind ref let force_lazy_val vk = match !vk with | VKnone -> None -| VKvalue v -> try Some (Ephemeron.get v) with Ephemeron.InvalidKey -> None +| VKvalue v -> try Some (CEphemeron.get v) with CEphemeron.InvalidKey -> None let dummy_lazy_val () = ref VKnone -let build_lazy_val vk key = vk := VKvalue (Ephemeron.create key) +let build_lazy_val vk key = vk := VKvalue (CEphemeron.create key) type named_vals = (Id.t * lazy_val) list type env = { env_globals : globals; - env_named_context : named_context; + env_named_context : Context.Named.t; env_named_vals : named_vals; - env_rel_context : rel_context; + env_rel_context : Context.Rel.t; env_rel_val : lazy_val list; env_nb_rel : int; env_stratification : stratification; @@ -77,7 +77,7 @@ type env = { indirect_pterms : Opaqueproof.opaquetab; } -type named_context_val = named_context * named_vals +type named_context_val = Context.Named.t * named_vals let empty_named_context_val = [],[] @@ -87,9 +87,9 @@ let empty_env = { env_inductives = Mindmap_env.empty; env_modules = MPmap.empty; env_modtypes = MPmap.empty}; - env_named_context = empty_named_context; + env_named_context = Context.Named.empty; env_named_vals = []; - env_rel_context = empty_rel_context; + env_rel_context = Context.Rel.empty; env_rel_val = []; env_nb_rel = 0; env_stratification = { @@ -107,7 +107,7 @@ let nb_rel env = env.env_nb_rel let push_rel d env = let rval = ref VKnone in { env with - env_rel_context = add_rel_decl d env.env_rel_context; + env_rel_context = Context.Rel.add d env.env_rel_context; env_rel_val = rval :: env.env_rel_val; env_nb_rel = env.env_nb_rel + 1 } @@ -125,18 +125,16 @@ let env_of_rel n env = (* Named context *) let push_named_context_val d (ctxt,vals) = - let id,_,_ = d in let rval = ref VKnone in - add_named_decl d ctxt, (id,rval)::vals + Context.Named.add d ctxt, (get_id d,rval)::vals let push_named d env = (* if not (env.env_rel_context = []) then raise (ASSERT env.env_rel_context); assert (env.env_rel_context = []); *) - let id,body,_ = d in let rval = ref VKnone in { env_globals = env.env_globals; - env_named_context = Context.add_named_decl d env.env_named_context; - env_named_vals = (id, rval) :: env.env_named_vals; + env_named_context = Context.Named.add d env.env_named_context; + env_named_vals = (get_id d, rval) :: env.env_named_vals; env_rel_context = env.env_rel_context; env_rel_val = env.env_rel_val; env_nb_rel = env.env_nb_rel; diff --git a/kernel/pre_env.mli b/kernel/pre_env.mli index b499ac0c5..353c46112 100644 --- a/kernel/pre_env.mli +++ b/kernel/pre_env.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,9 +8,7 @@ open Names open Term -open Context open Declarations -open Univ (** The type of environments. *) @@ -19,7 +17,7 @@ type link_info = | LinkedInteractive of string | NotLinked -type key = int Ephemeron.key option ref +type key = int CEphemeron.key option ref type constant_key = constant_body * (link_info ref * key) @@ -46,9 +44,9 @@ type named_vals = (Id.t * lazy_val) list type env = { env_globals : globals; - env_named_context : named_context; + env_named_context : Context.Named.t; env_named_vals : named_vals; - env_rel_context : rel_context; + env_rel_context : Context.Rel.t; env_rel_val : lazy_val list; env_nb_rel : int; env_stratification : stratification; @@ -57,7 +55,7 @@ type env = { indirect_pterms : Opaqueproof.opaquetab; } -type named_context_val = named_context * named_vals +type named_context_val = Context.Named.t * named_vals val empty_named_context_val : named_context_val @@ -66,15 +64,15 @@ val empty_env : env (** Rel context *) val nb_rel : env -> int -val push_rel : rel_declaration -> env -> env +val push_rel : Context.Rel.Declaration.t -> env -> env val lookup_rel_val : int -> env -> lazy_val val env_of_rel : int -> env -> env (** Named context *) val push_named_context_val : - named_declaration -> named_context_val -> named_context_val -val push_named : named_declaration -> env -> env + Context.Named.Declaration.t -> named_context_val -> named_context_val +val push_named : Context.Named.Declaration.t -> env -> env val lookup_named_val : Id.t -> env -> lazy_val val env_of_named : Id.t -> env -> env diff --git a/kernel/primitives.ml b/kernel/primitives.ml index 649eb125e..27732c00c 100644 --- a/kernel/primitives.ml +++ b/kernel/primitives.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/kernel/primitives.mli b/kernel/primitives.mli index 9f99264af..86e86a5e5 100644 --- a/kernel/primitives.mli +++ b/kernel/primitives.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/kernel/reduction.ml b/kernel/reduction.ml index e081870ba..cfc286135 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -20,11 +20,11 @@ open Util open Names open Term open Vars -open Context open Univ open Environ open Closure open Esubst +open Context.Rel.Declaration let rec is_empty_stack = function [] -> true @@ -120,34 +120,20 @@ let whd_betadeltaiota_nolet env t = Prod _|Lambda _|Fix _|CoFix _|LetIn _) -> t | _ -> whd_val (create_clos_infos betadeltaiotanolet env) (inject t) -(* Beta *) - -let beta_appvect c v = - let rec stacklam env t stack = - match kind_of_term t, stack with - Lambda(_,_,c), arg::stacktl -> stacklam (arg::env) c stacktl - | _ -> applist (substl env t, stack) in - stacklam [] c (Array.to_list v) - -let betazeta_appvect n c v = - let rec stacklam n env t stack = - if Int.equal n 0 then applist (substl env t, stack) else - match kind_of_term t, stack with - Lambda(_,_,c), arg::stacktl -> stacklam (n-1) (arg::env) c stacktl - | LetIn(_,b,_,c), _ -> stacklam (n-1) (b::env) c stack - | _ -> anomaly (Pp.str "Not enough lambda/let's") in - stacklam n [] c (Array.to_list v) - (********************************************************************) (* Conversion *) (********************************************************************) (* Conversion utility functions *) -type 'a conversion_function = env -> 'a -> 'a -> unit -type 'a trans_conversion_function = Names.transparent_state -> 'a conversion_function -type 'a universe_conversion_function = env -> UGraph.t -> 'a -> 'a -> unit -type 'a trans_universe_conversion_function = - Names.transparent_state -> 'a universe_conversion_function + +(* functions of this type are called from the kernel *) +type 'a kernel_conversion_function = env -> 'a -> 'a -> unit + +(* functions of this type can be called from outside the kernel *) +type 'a extended_conversion_function = + ?l2r:bool -> ?reds:Names.transparent_state -> env -> + ?evars:((existential->constr option) * UGraph.t) -> + 'a -> 'a -> unit exception NotConvertible exception NotConvertibleVect of int @@ -171,7 +157,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 @@ -183,8 +169,10 @@ type 'a infer_conversion_function = env -> UGraph.t -> 'a -> 'a -> Univ.constrai 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 @@ -194,7 +182,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 @@ -549,7 +537,7 @@ and convert_vect l2r infos lft1 lft2 v1 v2 cuniv = fold 0 cuniv else raise NotConvertible -let clos_fconv trans cv_pb l2r evars env univs t1 t2 = +let clos_gen_conv trans cv_pb l2r evars env univs t1 t2 = let reds = Closure.RedFlags.red_add_transparent betaiotazeta trans in let infos = create_clos_infos ~evars reds env in ccnv cv_pb l2r infos el_id el_id (inject t1) (inject t2) univs @@ -585,7 +573,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 UGraph.check_eq_instances univs u u' then univs else raise NotConvertible @@ -625,60 +613,38 @@ 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 inferred_universes : (UGraph.t * Univ.Constraint.t) universe_compare = { compare = infer_cmp_universes; compare_instances = infer_convert_instances } -let trans_fconv_universes reds cv_pb l2r evars env univs t1 t2 = +let gen_conv cv_pb l2r reds env evars univs t1 t2 = let b = if cv_pb = CUMUL then leq_constr_univs univs t1 t2 else eq_constr_univs univs t1 t2 in if b then () else - let _ = clos_fconv reds cv_pb l2r evars env (univs, checked_universes) t1 t2 in + let _ = clos_gen_conv reds cv_pb l2r evars env (univs, checked_universes) t1 t2 in () (* Profiling *) -let trans_fconv_universes = +let gen_conv cv_pb ?(l2r=false) ?(reds=full_transparent_state) env ?(evars=(fun _->None), universes env) = + let evars, univs = evars in if Flags.profile then - let trans_fconv_universes_key = Profile.declare_profile "trans_fconv_universes" in - Profile.profile8 trans_fconv_universes_key trans_fconv_universes - else trans_fconv_universes - -let trans_fconv reds cv_pb l2r evars env = - trans_fconv_universes reds cv_pb l2r evars env (universes env) - -let trans_conv_cmp ?(l2r=false) conv reds = trans_fconv reds conv l2r (fun _->None) -let trans_conv ?(l2r=false) ?(evars=fun _->None) reds = trans_fconv reds CONV l2r evars -let trans_conv_leq ?(l2r=false) ?(evars=fun _->None) reds = trans_fconv reds CUMUL l2r evars - -let trans_conv_universes ?(l2r=false) ?(evars=fun _->None) reds = - trans_fconv_universes reds CONV l2r evars -let trans_conv_leq_universes ?(l2r=false) ?(evars=fun _->None) reds = - trans_fconv_universes reds CUMUL l2r evars - -let fconv = trans_fconv full_transparent_state + let fconv_universes_key = Profile.declare_profile "trans_fconv_universes" in + Profile.profile8 fconv_universes_key gen_conv cv_pb l2r reds env evars univs + else gen_conv cv_pb l2r reds env evars univs -let conv_cmp ?(l2r=false) cv_pb = fconv cv_pb l2r (fun _->None) -let conv ?(l2r=false) ?(evars=fun _->None) = fconv CONV l2r evars -let conv_leq ?(l2r=false) ?(evars=fun _->None) = fconv CUMUL l2r evars +let conv = gen_conv CONV -let conv_leq_vecti ?(l2r=false) ?(evars=fun _->None) env v1 v2 = - Array.fold_left2_i - (fun i _ t1 t2 -> - try conv_leq ~l2r ~evars env t1 t2 - with NotConvertible -> raise (NotConvertibleVect i)) - () - v1 - v2 +let conv_leq = gen_conv CUMUL 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 + clos_gen_conv reds cv_pb l2r evars env univs t1 t2 in s let infer_conv_universes cv_pb l2r evars reds env univs t1 t2 = @@ -689,7 +655,7 @@ let infer_conv_universes cv_pb l2r evars reds env univs t1 t2 = if b then cstrs else let univs = ((univs, Univ.Constraint.empty), inferred_universes) in - let ((_,cstrs), _) = clos_fconv reds cv_pb l2r evars env univs t1 t2 in + let ((_,cstrs), _) = clos_gen_conv reds cv_pb l2r evars env univs t1 t2 in cstrs (* Profiling *) @@ -708,17 +674,19 @@ let infer_conv_leq ?(l2r=false) ?(evars=fun _ -> None) ?(ts=full_transparent_sta infer_conv_universes CUMUL l2r evars ts env univs t1 t2 (* 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 = ref (fun cv_pb env -> + gen_conv cv_pb env ~evars:((fun _->None), universes env)) + +let set_vm_conv (f:conv_pb -> Term.types kernel_conversion_function) = vm_conv := f let vm_conv cv_pb env t1 t2 = try !vm_conv cv_pb env t1 t2 with Not_found | Invalid_argument _ -> Pp.msg_warning (Pp.str "Bytecode compilation failed, falling back to standard conversion"); - fconv cv_pb false (fun _->None) env t1 t2 + gen_conv cv_pb env t1 t2 let default_conv cv_pb ?(l2r=false) env t1 t2 = - fconv cv_pb false (fun _ -> None) env t1 t2 + gen_conv cv_pb env t1 t2 let default_conv_leq = default_conv CUMUL (* @@ -731,12 +699,28 @@ let conv env t1 t2 = Profile.profile4 convleqkey conv env t1 t2;; *) +(* Application with on-the-fly reduction *) + +let beta_applist c l = + let rec app subst c l = + match kind_of_term c, l with + | Lambda(_,_,c), arg::l -> app (arg::subst) c l + | _ -> applist (substl subst c, l) in + app [] c l + +let beta_appvect c v = beta_applist c (Array.to_list v) + +let beta_app c a = beta_applist c [a] + +(* Compatibility *) +let betazeta_appvect = lambda_appvect_assum + (********************************************************************) (* Special-Purpose Reduction *) (********************************************************************) (* pseudo-reduction rule: - * [hnf_prod_app env s (Prod(_,B)) N --> B[N] + * [hnf_prod_app env (Prod(_,B)) N --> B[N] * with an HNF on the first argument to produce a product. * if this does not work, then we use the string S as part of our * error message. *) @@ -756,11 +740,11 @@ let dest_prod env = let t = whd_betadeltaiota env c in match kind_of_term t with | Prod (n,a,c0) -> - let d = (n,None,a) in - decrec (push_rel d env) (add_rel_decl d m) c0 + let d = LocalAssum (n,a) in + decrec (push_rel d env) (Context.Rel.add d m) c0 | _ -> m,t in - decrec env empty_rel_context + decrec env Context.Rel.empty (* The same but preserving lets in the context, not internal ones. *) let dest_prod_assum env = @@ -768,33 +752,33 @@ let dest_prod_assum env = let rty = whd_betadeltaiota_nolet env ty in match kind_of_term rty with | Prod (x,t,c) -> - let d = (x,None,t) in - prodec_rec (push_rel d env) (add_rel_decl d l) c + let d = LocalAssum (x,t) in + prodec_rec (push_rel d env) (Context.Rel.add d l) c | LetIn (x,b,t,c) -> - let d = (x,Some b,t) in - prodec_rec (push_rel d env) (add_rel_decl d l) c + let d = LocalDef (x,b,t) in + prodec_rec (push_rel d env) (Context.Rel.add d l) c | Cast (c,_,_) -> prodec_rec env l c | _ -> let rty' = whd_betadeltaiota env rty in if Term.eq_constr rty' rty then l, rty else prodec_rec env l rty' in - prodec_rec env empty_rel_context + prodec_rec env Context.Rel.empty let dest_lam_assum env = let rec lamec_rec env l ty = let rty = whd_betadeltaiota_nolet env ty in match kind_of_term rty with | Lambda (x,t,c) -> - let d = (x,None,t) in - lamec_rec (push_rel d env) (add_rel_decl d l) c + let d = LocalAssum (x,t) in + lamec_rec (push_rel d env) (Context.Rel.add d l) c | LetIn (x,b,t,c) -> - let d = (x,Some b,t) in - lamec_rec (push_rel d env) (add_rel_decl d l) c + let d = LocalDef (x,b,t) in + lamec_rec (push_rel d env) (Context.Rel.add d l) c | Cast (c,_,_) -> lamec_rec env l c | _ -> l,rty in - lamec_rec env empty_rel_context + lamec_rec env Context.Rel.empty exception NotArity diff --git a/kernel/reduction.mli b/kernel/reduction.mli index 0bb855c67..1b5e5e32a 100644 --- a/kernel/reduction.mli +++ b/kernel/reduction.mli @@ -1,13 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) open Term -open Context open Environ (*********************************************************************** @@ -26,18 +25,18 @@ val nf_betaiota : env -> constr -> constr exception NotConvertible exception NotConvertibleVect of int -type 'a conversion_function = env -> 'a -> 'a -> unit -type 'a trans_conversion_function = Names.transparent_state -> 'a conversion_function -type 'a universe_conversion_function = env -> UGraph.t -> 'a -> 'a -> unit -type 'a trans_universe_conversion_function = - Names.transparent_state -> 'a universe_conversion_function +type 'a kernel_conversion_function = env -> 'a -> 'a -> unit +type 'a extended_conversion_function = + ?l2r:bool -> ?reds:Names.transparent_state -> env -> + ?evars:((existential->constr option) * UGraph.t) -> + 'a -> 'a -> unit 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; } @@ -50,27 +49,17 @@ type 'a infer_conversion_function = env -> UGraph.t -> 'a -> 'a -> Univ.constrai val sort_cmp_universes : env -> conv_pb -> sorts -> sorts -> 'a * 'a universe_compare -> 'a * 'a universe_compare +(* [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 checked_universes : UGraph.t universe_compare val inferred_universes : (UGraph.t * Univ.Constraint.t) universe_compare -val trans_conv_cmp : ?l2r:bool -> conv_pb -> constr trans_conversion_function -val trans_conv : - ?l2r:bool -> ?evars:(existential->constr option) -> constr trans_conversion_function -val trans_conv_leq : - ?l2r:bool -> ?evars:(existential->constr option) -> types trans_conversion_function - -val trans_conv_universes : - ?l2r:bool -> ?evars:(existential->constr option) -> constr trans_universe_conversion_function -val trans_conv_leq_universes : - ?l2r:bool -> ?evars:(existential->constr option) -> types trans_universe_conversion_function - -val conv_cmp : ?l2r:bool -> conv_pb -> constr conversion_function -val conv : - ?l2r:bool -> ?evars:(existential->constr option) -> constr conversion_function -val conv_leq : - ?l2r:bool -> ?evars:(existential->constr option) -> types conversion_function -val conv_leq_vecti : - ?l2r:bool -> ?evars:(existential->constr option) -> types array conversion_function +val conv : constr extended_conversion_function + +val conv_leq : types extended_conversion_function (** These conversion functions are used by module subtyping, which needs to infer universe constraints inside the kernel *) @@ -83,30 +72,35 @@ 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_vm_conv : (conv_pb -> types kernel_conversion_function) -> unit +val vm_conv : conv_pb -> types kernel_conversion_function -val default_conv : conv_pb -> ?l2r:bool -> types conversion_function -val default_conv_leq : ?l2r:bool -> types conversion_function +val default_conv : conv_pb -> ?l2r:bool -> types kernel_conversion_function +val default_conv_leq : ?l2r:bool -> types kernel_conversion_function (************************************************************************) (** Builds an application node, reducing beta redexes it may produce. *) +val beta_applist : constr -> constr list -> constr + +(** Builds an application node, reducing beta redexes it may produce. *) val beta_appvect : constr -> constr array -> constr -(** Builds an application node, reducing the [n] first beta-zeta redexes. *) -val betazeta_appvect : int -> constr -> constr array -> constr +(** Builds an application node, reducing beta redexe it may produce. *) +val beta_app : constr -> constr -> constr (** Pseudo-reduction rule Prod(x,A,B) a --> B[x\a] *) val hnf_prod_applist : env -> types -> constr list -> types +(** Compatibility alias for Term.lambda_appvect_assum *) +val betazeta_appvect : int -> constr -> constr array -> constr (*********************************************************************** s Recognizing products and arities modulo reduction *) -val dest_prod : env -> types -> rel_context * types -val dest_prod_assum : env -> types -> rel_context * types -val dest_lam_assum : env -> types -> rel_context * types +val dest_prod : env -> types -> Context.Rel.t * types +val dest_prod_assum : env -> types -> Context.Rel.t * types +val dest_lam_assum : env -> types -> Context.Rel.t * types exception NotArity diff --git a/kernel/retroknowledge.ml b/kernel/retroknowledge.ml index cc307f145..970bc0fcc 100644 --- a/kernel/retroknowledge.ml +++ b/kernel/retroknowledge.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/kernel/retroknowledge.mli b/kernel/retroknowledge.mli index 9a63deb7e..905a05fe5 100644 --- a/kernel/retroknowledge.mli +++ b/kernel/retroknowledge.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index ec245b064..ce05190b6 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -60,6 +60,7 @@ open Util open Names open Declarations +open Context.Named.Declaration (** {6 Safe environments } @@ -207,15 +208,50 @@ 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 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 = CEphemeron.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 = CEphemeron.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 @@ -327,7 +363,8 @@ let check_required current_libs needed = hypothesis many many times, and the check performed here would cost too much. *) -let safe_push_named (id,_,_ as d) env = +let safe_push_named d env = + let id = get_id d in let _ = try let _ = Environ.lookup_named id env in @@ -337,7 +374,7 @@ 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 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 @@ -348,13 +385,13 @@ let push_named_def (id,de) senv = (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 + let env'' = safe_push_named (LocalDef (id,c,typ)) senv'.env in univs, {senv' with env=env''} 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 + let env'' = safe_push_named (LocalAssum (id,t)) senv'.env in {senv' with env=env''} @@ -442,19 +479,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 = @@ -471,7 +505,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 *) @@ -497,6 +556,7 @@ let add_mind dir l mie senv = let add_modtype l params_mte inl senv = let mp = MPdot(senv.modpath, l) in let mtb = Mod_typing.translate_modtype senv.env mp inl params_mte in + let mtb = Declareops.hcons_module_body mtb in let senv' = add_field (l,SFBmodtype mtb) MT senv in mp, senv' @@ -517,6 +577,7 @@ let full_add_module_type mp mt senv = let add_module l me inl senv = let mp = MPdot(senv.modpath, l) in let mb = Mod_typing.translate_module senv.env mp inl me in + let mb = Declareops.hcons_module_body mb in let senv' = add_field (l,SFBmodule mb) M senv in let senv'' = if Modops.is_functor mb.mod_type then senv' @@ -682,7 +743,7 @@ 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,_,resolver,cst = + let sign,(),resolver,cst = translate_mse_incl is_module senv.env mp_sup inl me in let senv = add_constraints (Now (false, cst)) senv in diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index eac08eb83..71dac321f 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -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 @@ -63,16 +83,23 @@ val push_named_assum : (** Returns the full universe context necessary to typecheck the definition (futures are forced) *) val push_named_def : - Id.t * Entries.definition_entry -> Univ.universe_context_set safe_transformer + 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 *) diff --git a/kernel/sorts.ml b/kernel/sorts.ml index e2854abfd..62013b38f 100644 --- a/kernel/sorts.ml +++ b/kernel/sorts.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -98,7 +98,7 @@ module Hsorts = let u' = huniv u in if u' == u then c else Type u' | s -> s - let equal s1 s2 = match (s1,s2) with + let eq s1 s2 = match (s1,s2) with | (Prop c1, Prop c2) -> c1 == c2 | (Type u1, Type u2) -> u1 == u2 |_ -> false diff --git a/kernel/sorts.mli b/kernel/sorts.mli index cd65b2315..eb4697ad6 100644 --- a/kernel/sorts.mli +++ b/kernel/sorts.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index a00a462e1..5efc1078e 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/kernel/subtyping.mli b/kernel/subtyping.mli index 443f5037f..a00eb8732 100644 --- a/kernel/subtyping.mli +++ b/kernel/subtyping.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/kernel/term.ml b/kernel/term.ml index 33ed25fe1..4416770fe 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -10,7 +10,6 @@ open Util open Pp open Errors open Names -open Context open Vars (**********************************************************************) @@ -384,40 +383,46 @@ let mkNamedLambda id typ c = mkLambda (Name id, typ, subst_var id c) let mkNamedLetIn id c1 t c2 = mkLetIn (Name id, c1, t, subst_var id c2) (* Constructs either [(x:t)c] or [[x=b:t]c] *) -let mkProd_or_LetIn (na,body,t) c = - match body with - | None -> mkProd (na, t, c) - | Some b -> mkLetIn (na, b, t, c) - -let mkNamedProd_or_LetIn (id,body,t) c = - match body with - | None -> mkNamedProd id t c - | Some b -> mkNamedLetIn id b t c +let mkProd_or_LetIn decl c = + let open Context.Rel.Declaration in + match decl with + | LocalAssum (na,t) -> mkProd (na, t, c) + | LocalDef (na,b,t) -> mkLetIn (na, b, t, c) + +let mkNamedProd_or_LetIn decl c = + let open Context.Named.Declaration in + match decl with + | LocalAssum (id,t) -> mkNamedProd id t c + | LocalDef (id,b,t) -> mkNamedLetIn id b t c (* Constructs either [(x:t)c] or [c] where [x] is replaced by [b] *) -let mkProd_wo_LetIn (na,body,t) c = - match body with - | None -> mkProd (na, t, c) - | Some b -> subst1 b c - -let mkNamedProd_wo_LetIn (id,body,t) c = - match body with - | None -> mkNamedProd id t c - | Some b -> subst1 b (subst_var id c) +let mkProd_wo_LetIn decl c = + let open Context.Rel.Declaration in + match decl with + | LocalAssum (na,t) -> mkProd (na, t, c) + | LocalDef (na,b,t) -> subst1 b c + +let mkNamedProd_wo_LetIn decl c = + let open Context.Named.Declaration in + match decl with + | LocalAssum (id,t) -> mkNamedProd id t c + | LocalDef (id,b,t) -> subst1 b (subst_var id c) (* non-dependent product t1 -> t2 *) let mkArrow t1 t2 = mkProd (Anonymous, t1, t2) (* Constructs either [[x:t]c] or [[x=b:t]c] *) -let mkLambda_or_LetIn (na,body,t) c = - match body with - | None -> mkLambda (na, t, c) - | Some b -> mkLetIn (na, b, t, c) - -let mkNamedLambda_or_LetIn (id,body,t) c = - match body with - | None -> mkNamedLambda id t c - | Some b -> mkNamedLetIn id b t c +let mkLambda_or_LetIn decl c = + let open Context.Rel.Declaration in + match decl with + | LocalAssum (na,t) -> mkLambda (na, t, c) + | LocalDef (na,b,t) -> mkLetIn (na, b, t, c) + +let mkNamedLambda_or_LetIn decl c = + let open Context.Named.Declaration in + match decl with + | LocalAssum (id,t) -> mkNamedLambda id t c + | LocalDef (id,b,t) -> mkNamedLetIn id b t c (* prodn n [xn:Tn;..;x1:T1;Gamma] b = (x1:T1)..(xn:Tn)b *) let prodn n env b = @@ -471,26 +476,58 @@ let rec to_prod n lam = | Cast (c,_,_) -> to_prod n c | _ -> errorlabstrm "to_prod" (mt ()) -(* pseudo-reduction rule: - * [prod_app s (Prod(_,B)) N --> B[N] - * with an strip_outer_cast on the first argument to produce a product *) +let it_mkProd_or_LetIn = List.fold_left (fun c d -> mkProd_or_LetIn d c) +let it_mkLambda_or_LetIn = List.fold_left (fun c d -> mkLambda_or_LetIn d c) -let prod_app t n = - match kind_of_term (strip_outer_cast t) with - | Prod (_,_,b) -> subst1 n b - | _ -> - errorlabstrm "prod_app" - (str"Needed a product, but didn't find one" ++ fnl ()) +(* Application with expected on-the-fly reduction *) +let lambda_applist c l = + let rec app subst c l = + match kind_of_term c, l with + | Lambda(_,_,c), arg::l -> app (arg::subst) c l + | _, [] -> substl subst c + | _ -> anomaly (Pp.str "Not enough lambda's") in + app [] c l -(* prod_appvect T [| a1 ; ... ; an |] -> (T a1 ... an) *) -let prod_appvect t nL = Array.fold_left prod_app t nL +let lambda_appvect c v = lambda_applist c (Array.to_list v) + +let lambda_applist_assum n c l = + let rec app n subst t l = + if Int.equal n 0 then + if l == [] then substl subst t + else anomaly (Pp.str "Not enough arguments") + else match kind_of_term t, l with + | Lambda(_,_,c), arg::l -> app (n-1) (arg::subst) c l + | LetIn(_,b,_,c), _ -> app (n-1) (substl subst b::subst) c l + | _ -> anomaly (Pp.str "Not enough lambda/let's") in + app n [] c l + +let lambda_appvect_assum n c v = lambda_applist_assum n c (Array.to_list v) (* prod_applist T [ a1 ; ... ; an ] -> (T a1 ... an) *) -let prod_applist t nL = List.fold_left prod_app t nL +let prod_applist c l = + let rec app subst c l = + match kind_of_term c, l with + | Prod(_,_,c), arg::l -> app (arg::subst) c l + | _, [] -> substl subst c + | _ -> anomaly (Pp.str "Not enough prod's") in + app [] c l -let it_mkProd_or_LetIn = List.fold_left (fun c d -> mkProd_or_LetIn d c) -let it_mkLambda_or_LetIn = List.fold_left (fun c d -> mkLambda_or_LetIn d c) +(* prod_appvect T [| a1 ; ... ; an |] -> (T a1 ... an) *) +let prod_appvect c v = prod_applist c (Array.to_list v) + +let prod_applist_assum n c l = + let rec app n subst t l = + if Int.equal n 0 then + if l == [] then substl subst t + else anomaly (Pp.str "Not enough arguments") + else match kind_of_term t, l with + | Prod(_,_,c), arg::l -> app (n-1) (arg::subst) c l + | LetIn(_,b,_,c), _ -> app (n-1) (substl subst b::subst) c l + | _ -> anomaly (Pp.str "Not enough prod/let's") in + app n [] c l + +let prod_appvect_assum n c v = prod_applist_assum n c (Array.to_list v) (*********************************) (* Other term destructors *) @@ -545,26 +582,28 @@ let decompose_lam_n n = (* Transforms a product term (x1:T1)..(xn:Tn)T into the pair ([(xn,Tn);...;(x1,T1)],T), where T is not a product *) let decompose_prod_assum = + let open Context.Rel.Declaration in let rec prodec_rec l c = match kind_of_term c with - | Prod (x,t,c) -> prodec_rec (add_rel_decl (x,None,t) l) c - | LetIn (x,b,t,c) -> prodec_rec (add_rel_decl (x,Some b,t) l) c + | Prod (x,t,c) -> prodec_rec (Context.Rel.add (LocalAssum (x,t)) l) c + | LetIn (x,b,t,c) -> prodec_rec (Context.Rel.add (LocalDef (x,b,t)) l) c | Cast (c,_,_) -> prodec_rec l c | _ -> l,c in - prodec_rec empty_rel_context + prodec_rec Context.Rel.empty (* Transforms a lambda term [x1:T1]..[xn:Tn]T into the pair ([(xn,Tn);...;(x1,T1)],T), where T is not a lambda *) let decompose_lam_assum = let rec lamdec_rec l c = + let open Context.Rel.Declaration in match kind_of_term c with - | Lambda (x,t,c) -> lamdec_rec (add_rel_decl (x,None,t) l) c - | LetIn (x,b,t,c) -> lamdec_rec (add_rel_decl (x,Some b,t) l) c + | Lambda (x,t,c) -> lamdec_rec (Context.Rel.add (LocalAssum (x,t)) l) c + | LetIn (x,b,t,c) -> lamdec_rec (Context.Rel.add (LocalDef (x,b,t)) l) c | Cast (c,_,_) -> lamdec_rec l c | _ -> l,c in - lamdec_rec empty_rel_context + lamdec_rec Context.Rel.empty (* 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 @@ -575,13 +614,15 @@ let decompose_prod_n_assum n = error "decompose_prod_n_assum: integer parameter must be positive"; let rec prodec_rec l n c = if Int.equal n 0 then l,c - else match kind_of_term c with - | Prod (x,t,c) -> prodec_rec (add_rel_decl (x,None,t) l) (n-1) c - | LetIn (x,b,t,c) -> prodec_rec (add_rel_decl (x,Some b,t) l) (n-1) c - | Cast (c,_,_) -> prodec_rec l n c - | c -> error "decompose_prod_n_assum: not enough assumptions" + else + let open Context.Rel.Declaration in + match kind_of_term c with + | Prod (x,t,c) -> prodec_rec (Context.Rel.add (LocalAssum (x,t)) l) (n-1) c + | LetIn (x,b,t,c) -> prodec_rec (Context.Rel.add (LocalDef (x,b,t)) l) (n-1) c + | Cast (c,_,_) -> prodec_rec l n c + | c -> error "decompose_prod_n_assum: not enough assumptions" in - prodec_rec empty_rel_context n + prodec_rec Context.Rel.empty n (* 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 @@ -594,13 +635,15 @@ let decompose_lam_n_assum n = error "decompose_lam_n_assum: 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 c - | Cast (c,_,_) -> lamdec_rec l n c - | c -> error "decompose_lam_n_assum: not enough abstractions" + else + let open Context.Rel.Declaration in + match kind_of_term c with + | Lambda (x,t,c) -> lamdec_rec (Context.Rel.add (LocalAssum (x,t)) l) (n-1) c + | LetIn (x,b,t,c) -> lamdec_rec (Context.Rel.add (LocalDef (x,b,t)) l) n c + | Cast (c,_,_) -> lamdec_rec l n c + | c -> error "decompose_lam_n_assum: not enough abstractions" in - lamdec_rec empty_rel_context n + lamdec_rec Context.Rel.empty n (* Same, counting let-in *) let decompose_lam_n_decls n = @@ -608,32 +651,15 @@ let decompose_lam_n_decls n = 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 = - let rec nbrec n c = match kind_of_term c with - | Lambda (_,_,c) -> nbrec (n+1) c - | Cast (c,_,_) -> nbrec n c - | _ -> n - in - nbrec 0 - -(* similar to nb_lam, but gives the number of products instead *) -let nb_prod = - let rec nbrec n c = match kind_of_term c with - | Prod (_,_,c) -> nbrec (n+1) c - | Cast (c,_,_) -> nbrec n c - | _ -> n + else + let open Context.Rel.Declaration in + match kind_of_term c with + | Lambda (x,t,c) -> lamdec_rec (Context.Rel.add (LocalAssum (x,t)) l) (n-1) c + | LetIn (x,b,t,c) -> lamdec_rec (Context.Rel.add (LocalDef (x,b,t)) l) (n-1) c + | Cast (c,_,_) -> lamdec_rec l n c + | c -> error "decompose_lam_n_decls: not enough abstractions" in - nbrec 0 + lamdec_rec Context.Rel.empty n let prod_assum t = fst (decompose_prod_assum t) let prod_n_assum n t = fst (decompose_prod_n_assum n t) @@ -654,13 +680,14 @@ let strip_lam_n n t = snd (decompose_lam_n n t) Such a term can canonically be seen as the pair of a context of types and of a sort *) -type arity = rel_context * sorts +type arity = Context.Rel.t * sorts let destArity = + let open Context.Rel.Declaration in let rec prodec_rec l c = match kind_of_term c with - | Prod (x,t,c) -> prodec_rec ((x,None,t)::l) c - | LetIn (x,b,t,c) -> prodec_rec ((x,Some b,t)::l) c + | Prod (x,t,c) -> prodec_rec (LocalAssum (x,t) :: l) c + | LetIn (x,b,t,c) -> prodec_rec (LocalDef (x,b,t) :: l) c | Cast (c,_,_) -> prodec_rec l c | Sort s -> l,s | _ -> anomaly ~label:"destArity" (Pp.str "not an arity") diff --git a/kernel/term.mli b/kernel/term.mli index 2bb811060..32267f6c4 100644 --- a/kernel/term.mli +++ b/kernel/term.mli @@ -1,13 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) open Names -open Context (** {5 Redeclaration of types from module Constr and Sorts} @@ -203,7 +202,7 @@ val destCoFix : constr -> cofixpoint (** non-dependent product [t1 -> t2], an alias for [forall (_:t1), t2]. Beware [t_2] is NOT lifted. - Eg: in context [A:Prop], [A->A] is built by [(mkArrow (mkRel 0) (mkRel 1))] + Eg: in context [A:Prop], [A->A] is built by [(mkArrow (mkRel 1) (mkRel 2))] *) val mkArrow : types -> types -> constr @@ -213,14 +212,14 @@ val mkNamedLetIn : Id.t -> constr -> types -> constr -> constr val mkNamedProd : Id.t -> types -> types -> types (** Constructs either [(x:t)c] or [[x=b:t]c] *) -val mkProd_or_LetIn : rel_declaration -> types -> types -val mkProd_wo_LetIn : rel_declaration -> types -> types -val mkNamedProd_or_LetIn : named_declaration -> types -> types -val mkNamedProd_wo_LetIn : named_declaration -> types -> types +val mkProd_or_LetIn : Context.Rel.Declaration.t -> types -> types +val mkProd_wo_LetIn : Context.Rel.Declaration.t -> types -> types +val mkNamedProd_or_LetIn : Context.Named.Declaration.t -> types -> types +val mkNamedProd_wo_LetIn : Context.Named.Declaration.t -> types -> types (** Constructs either [[x:t]c] or [[x=b:t]c] *) -val mkLambda_or_LetIn : rel_declaration -> constr -> constr -val mkNamedLambda_or_LetIn : named_declaration -> constr -> constr +val mkLambda_or_LetIn : Context.Rel.Declaration.t -> constr -> constr +val mkNamedLambda_or_LetIn : Context.Named.Declaration.t -> constr -> constr (** {5 Other term constructors. } *) @@ -262,14 +261,34 @@ val to_lambda : int -> constr -> constr where [l] is [fun (x_1:T_1)...(x_n:T_n) => T] *) val to_prod : int -> constr -> constr +val it_mkLambda_or_LetIn : constr -> Context.Rel.t -> constr +val it_mkProd_or_LetIn : types -> Context.Rel.t -> types + +(** In [lambda_applist c args], [c] is supposed to have the form + [λΓ.c] with [Γ] without let-in; it returns [c] with the variables + of [Γ] instantiated by [args]. *) +val lambda_applist : constr -> constr list -> constr +val lambda_appvect : constr -> constr array -> constr + +(** In [lambda_applist_assum n c args], [c] is supposed to have the + form [λΓ.c] with [Γ] of length [m] and possibly with let-ins; it + returns [c] with the assumptions of [Γ] instantiated by [args] and + the local definitions of [Γ] expanded. *) +val lambda_applist_assum : int -> constr -> constr list -> constr +val lambda_appvect_assum : int -> constr -> constr array -> constr + (** pseudo-reduction rule *) (** [prod_appvect] [forall (x1:B1;...;xn:Bn), B] [a1...an] @return [B[a1...an]] *) val prod_appvect : constr -> constr array -> constr val prod_applist : constr -> constr list -> constr -val it_mkLambda_or_LetIn : constr -> rel_context -> constr -val it_mkProd_or_LetIn : types -> rel_context -> types +(** In [prod_appvect_assum n c args], [c] is supposed to have the + form [∀Γ.c] with [Γ] of length [m] and possibly with let-ins; it + returns [c] with the assumptions of [Γ] instantiated by [args] and + the local definitions of [Γ] expanded. *) +val prod_appvect_assum : int -> constr -> constr array -> constr +val prod_applist_assum : int -> constr -> constr list -> constr (** {5 Other term destructors. } *) @@ -294,36 +313,29 @@ val decompose_lam_n : int -> constr -> (Name.t * constr) list * constr (** Extract the premisses and the conclusion of a term of the form "(xi:Ti) ... (xj:=cj:Tj) ..., T" where T is not a product nor a let *) -val decompose_prod_assum : types -> rel_context * types +val decompose_prod_assum : types -> Context.Rel.t * types (** Idem with lambda's *) -val decompose_lam_assum : constr -> rel_context * constr +val decompose_lam_assum : constr -> Context.Rel.t * constr (** Idem but extract the first [n] premisses, counting let-ins. *) -val decompose_prod_n_assum : int -> types -> rel_context * types +val decompose_prod_n_assum : int -> types -> Context.Rel.t * types (** Idem for lambdas, _not_ counting let-ins *) -val decompose_lam_n_assum : int -> constr -> rel_context * constr +val decompose_lam_n_assum : int -> constr -> Context.Rel.t * 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 - -(** Similar to [nb_lam], but gives the number of products instead *) -val nb_prod : constr -> int +val decompose_lam_n_decls : int -> constr -> Context.Rel.t * constr (** Return the premisses/parameters of a type/term (let-in included) *) -val prod_assum : types -> rel_context -val lam_assum : constr -> rel_context +val prod_assum : types -> Context.Rel.t +val lam_assum : constr -> Context.Rel.t (** Return the first n-th premisses/parameters of a type (let included and counted) *) -val prod_n_assum : int -> types -> rel_context +val prod_n_assum : int -> types -> Context.Rel.t (** Return the first n-th premisses/parameters of a term (let included but not counted) *) -val lam_n_assum : int -> constr -> rel_context +val lam_n_assum : int -> constr -> Context.Rel.t (** Remove the premisses/parameters of a type/term *) val strip_prod : types -> types @@ -356,7 +368,7 @@ val under_outer_cast : (constr -> constr) -> constr -> constr Such a term can canonically be seen as the pair of a context of types and of a sort *) -type arity = rel_context * sorts +type arity = Context.Rel.t * sorts (** Build an "arity" from its canonical form *) val mkArity : arity -> types diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index b6df8f454..3839135a8 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -16,7 +16,6 @@ open Errors open Util open Names open Term -open Context open Declarations open Environ open Entries @@ -43,10 +42,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 ctx side_eff = - let handle_sideff (t,ctx) 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,7 +83,7 @@ let handle_side_effects env body ctx 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 + | _ -> 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, _ -> @@ -87,17 +105,63 @@ let handle_side_effects env body ctx side_eff = let t = sub c 1 (Vars.lift 1 t) in mkApp (mkLambda (cname c, b_ty, t), [|b|]), Univ.ContextSet.union ctx - (Univ.ContextSet.of_context cb.const_universes) + (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), ctx | _ -> assert false in - List.fold_right fix_body cbl (t,ctx) + 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,ctx) - (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 = CEphemeron.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 CEphemeron.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 = + let open Context.Rel.Declaration in + 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 (LocalDef (n,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 (LocalAssum (n,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} @@ -105,7 +169,7 @@ let hcons_j j = 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 ~strict:(not poly) uctx env in @@ -123,16 +187,21 @@ let infer_declaration env kn dcl = 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,ctx = handle_side_effects env body ctx 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, @@ -143,7 +212,7 @@ let infer_declaration env kn dcl = let { const_entry_body = body; const_entry_feedback = feedback_id } = c in let (body, ctx), side_eff = Future.join body in let univsctx = Univ.ContextSet.of_context c.const_entry_universes in - let body, ctx = handle_side_effects env body + 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 @@ -177,17 +246,19 @@ let infer_declaration env kn dcl = let global_vars_set_constant_type env = function | RegularArity t -> global_vars_set env t | TemplateArity (ctx,_) -> - Context.fold_rel_context - (fold_rel_declaration + Context.Rel.fold_outside + (Context.Rel.Declaration.fold (fun t c -> Id.Set.union (global_vars_set env t) c)) ctx ~init:Id.Set.empty let record_aux env s_ty s_bo suggested_expr = + let open Context.Named.Declaration in let in_ty = keep_hyps env s_ty in let v = String.concat " " - (CList.map_filter (fun (id, _,_) -> - if List.exists (fun (id',_,_) -> Id.equal id id') in_ty then None + (CList.map_filter (fun decl -> + let id = get_id decl in + if List.exists (Id.equal id % get_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) @@ -196,8 +267,9 @@ 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) = + let open Context.Named.Declaration in let check declared inferred = - let mk_set l = List.fold_right Id.Set.add (List.map pi1 l) Id.Set.empty in + let mk_set l = List.fold_right Id.Set.add (List.map get_id l) Id.Set.empty in let inferred_set, declared_set = mk_set inferred, mk_set declared in if not (Id.Set.subset inferred_set declared_set) then let l = Id.Set.elements (Idset.diff inferred_set declared_set) in @@ -208,12 +280,13 @@ let build_constant_declaration kn env (def,typ,proj,poly,univs,inline_code,ctx) 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) + List.filter (fun decl -> + let id = get_id decl in + List.exists (Names.Id.equal id % get_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 + let context_ids = List.map get_id (named_context env) in match ctx with | None when not (List.is_empty context_ids) -> (* No declared section vars, and non-empty section context: @@ -258,33 +331,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 -> + 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 def - in Option.map Cemitcodes.from_val res + 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; @@ -297,8 +367,98 @@ let build_constant_declaration kn env (def,typ,proj,poly,univs,inline_code,ctx) (*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, _ -> + let env = Environ.add_constant kn cb env in + if not cb.const_polymorphic then + Environ.push_context ~strict:true cb.const_universes env + else env + | kn, cb, `Opaque(_, ctx), _ -> + let env = Environ.add_constant kn cb env in + if not cb.const_polymorphic then + let env = Environ.push_context ~strict:true cb.const_universes env in + Environ.push_context_set ~strict:true ctx env + else 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 @@ -308,16 +468,17 @@ 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 open Context.Named.Declaration in + let context_ids = List.map get_id (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 @@ -332,12 +493,12 @@ let translate_local_def env id centry = 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) -> - let body, ctx' = handle_side_effects env body ctx side_eff in - (body, ctx'), Declareops.no_seff); + let body, ctx',_ = inline_side_effects env body ctx side_eff in + (body, ctx'), []); } -let handle_side_effects env body side_eff = - fst (handle_side_effects env body Univ.ContextSet.empty side_eff) +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 8d92bcc68..fcd95576c 100644 --- a/kernel/term_typing.mli +++ b/kernel/term_typing.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -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,8 +60,8 @@ 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 diff --git a/kernel/type_errors.ml b/kernel/type_errors.ml index 33c4172e5..5071f0ad5 100644 --- a/kernel/type_errors.ml +++ b/kernel/type_errors.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/kernel/type_errors.mli b/kernel/type_errors.mli index 7b3d2f1c6..0c3a952b8 100644 --- a/kernel/type_errors.mli +++ b/kernel/type_errors.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/kernel/typeops.ml b/kernel/typeops.ml index 4f32fdce8..0ea68e2bc 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -12,13 +12,13 @@ open Names open Univ open Term open Vars -open Context open Declarations open Environ open Entries open Reduction open Inductive open Type_errors +open Context.Rel.Declaration let conv_leq l2r env x y = default_conv CUMUL ~l2r env x y @@ -79,7 +79,7 @@ let judge_of_type u = let judge_of_relative env n = try - let (_,_,typ) = lookup_rel n env in + let typ = get_type (lookup_rel n env) in { uj_val = mkRel n; uj_type = lift n typ } with Not_found -> @@ -99,18 +99,20 @@ let judge_of_variable env id = variables of the current env. Order does not have to be checked assuming that all names are distinct *) let check_hyps_inclusion env c sign = - Context.fold_named_context - (fun (id,b1,ty1) () -> + Context.Named.fold_outside + (fun d1 () -> + let open Context.Named.Declaration in + let id = get_id d1 in try - let (_,b2,ty2) = lookup_named id env in - conv env ty2 ty1; - (match b2,b1 with - | None, None -> () - | None, Some _ -> + let d2 = lookup_named id env in + conv env (get_type d2) (get_type d1); + (match d2,d1 with + | LocalAssum _, LocalAssum _ -> () + | LocalAssum _, LocalDef _ -> (* This is wrong, because we don't know if the body is needed or not for typechecking: *) () - | Some _, None -> raise NotConvertible - | Some b2, Some b1 -> conv env b2 b1); + | LocalDef _, LocalAssum _ -> raise NotConvertible + | LocalDef (_,b2,_), LocalDef (_,b1,_) -> conv env b2 b1); with Not_found | NotConvertible | Option.Heterogeneous -> error_reference_variables env id c) sign @@ -125,9 +127,9 @@ let extract_level env p = match kind_of_term c with Sort (Type u) -> Univ.Universe.level u | _ -> None let extract_context_levels env l = - let fold l (_, b, p) = match b with - | None -> extract_level env p :: l - | _ -> l + let fold l = function + | LocalAssum (_,p) -> extract_level env p :: l + | LocalDef _ -> l in List.fold_left fold [] l @@ -459,13 +461,13 @@ let rec execute env cstr = | Lambda (name,c1,c2) -> let varj = execute_type env c1 in - let env1 = push_rel (name,None,varj.utj_val) env in + let env1 = push_rel (LocalAssum (name,varj.utj_val)) env in let j' = execute env1 c2 in judge_of_abstraction env name varj j' | Prod (name,c1,c2) -> let varj = execute_type env c1 in - let env1 = push_rel (name,None,varj.utj_val) env in + let env1 = push_rel (LocalAssum (name,varj.utj_val)) env in let varj' = execute_type env1 c2 in judge_of_product env name varj varj' @@ -473,7 +475,7 @@ let rec execute env cstr = let j1 = execute env c1 in let j2 = execute_type env c2 in let _ = judge_of_cast env j1 DEFAULTcast j2 in - let env1 = push_rel (name,Some j1.uj_val,j2.utj_val) env in + let env1 = push_rel (LocalDef (name,j1.uj_val,j2.utj_val)) env in let j' = execute env1 c3 in judge_of_letin env name j1 j2 j' @@ -549,18 +551,18 @@ let infer_v env cv = (* Typing of several terms. *) let infer_local_decl env id = function - | LocalDef c -> + | LocalDefEntry c -> let j = infer env c in - (Name id, Some j.uj_val, j.uj_type) - | LocalAssum c -> + LocalDef (Name id, j.uj_val, j.uj_type) + | LocalAssumEntry c -> let j = infer env c in - (Name id, None, assumption_of_judgment env j) + LocalAssum (Name id, assumption_of_judgment env j) let infer_local_decls env decls = let rec inferec env = function | (id, d) :: l -> let (env, l) = inferec env l in let d = infer_local_decl env id d in - (push_rel d env, add_rel_decl d l) - | [] -> (env, empty_rel_context) in + (push_rel d env, Context.Rel.add d l) + | [] -> (env, Context.Rel.empty) in inferec env decls diff --git a/kernel/typeops.mli b/kernel/typeops.mli index 010b2b6f0..2112284ea 100644 --- a/kernel/typeops.mli +++ b/kernel/typeops.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -9,7 +9,6 @@ open Names open Univ open Term -open Context open Environ open Entries open Declarations @@ -28,7 +27,7 @@ val infer_v : env -> constr array -> unsafe_judgment array val infer_type : env -> types -> unsafe_type_judgment val infer_local_decls : - env -> (Id.t * local_entry) list -> (env * rel_context) + env -> (Id.t * local_entry) list -> (env * Context.Rel.t) (** {6 Basic operations of the typing machine. } *) @@ -128,4 +127,4 @@ val make_polymorphic_if_constant_for_ind : env -> unsafe_judgment -> constant_type (** Check that hyps are included in env and fails with error otherwise *) -val check_hyps_inclusion : env -> constr -> section_context -> unit +val check_hyps_inclusion : env -> constr -> Context.section_context -> unit diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml index 356cf4da6..00883ddd8 100644 --- a/kernel/uGraph.ml +++ b/kernel/uGraph.ml @@ -17,68 +17,74 @@ open Univ (* Additional support for sort-polymorphic inductive types by HH [Mar 2006] *) (* Support for universe polymorphism by MS [2014] *) -(* Revisions by Bruno Barras, Hugo Herbelin, Pierre Letouzey, Matthieu Sozeau, - Pierre-Marie Pédrot *) +(* Revisions by Bruno Barras, Hugo Herbelin, Pierre Letouzey, Matthieu + Sozeau, Pierre-Marie Pédrot, Jacques-Henri Jourdan *) let error_inconsistency o u v (p:explanation option) = raise (UniverseInconsistency (o,Universe.make u,Universe.make v,p)) -type status = Unset | SetLe | SetLt +(* Universes are stratified by a partial ordering $\le$. + Let $\~{}$ be the associated equivalence. We also have a strict ordering + $<$ between equivalence classes, and we maintain that $<$ is acyclic, + and contained in $\le$ in the sense that $[U]<[V]$ implies $U\le V$. + + At every moment, we have a finite number of universes, and we + maintain the ordering in the presence of assertions $U<V$ and $U\le V$. + + The equivalence $\~{}$ is represented by a tree structure, as in the + union-find algorithm. The assertions $<$ and $\le$ are represented by + adjacency lists. + + We use the algorithm described in the paper: + + Bender, M. A., Fineman, J. T., Gilbert, S., & Tarjan, R. E. (2011). A + new approach to incremental cycle detection and related + problems. arXiv preprint arXiv:1112.0784. + + *) + +open Universe + +module UMap = LMap + +type status = NoMark | Visited | WeakVisited | ToMerge (* Comparison on this type is pointer equality *) -type canonical_arc = +type canonical_node = { univ: Level.t; - lt: Level.t list; - le: Level.t list; + ltle: bool UMap.t; (* true: strict (lt) constraint. + false: weak (le) constraint. *) + gtge: LSet.t; rank : int; - 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 - a node has already been visited. Quite performance critical indeed. *) + klvl: int; + ilvl: int; + mutable status: status } -let arc_is_le arc = match arc.status with -| Unset -> false -| SetLe | SetLt -> true - -let arc_is_lt arc = match arc.status with -| Unset | SetLe -> false -| SetLt -> true - -let terminal u = {univ=u; lt=[]; le=[]; rank=0; status = Unset} - -module UMap : -sig - type key = Level.t - type +'a t - val empty : 'a t - val add : key -> 'a -> 'a t -> 'a t - val find : key -> 'a t -> 'a - val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool - val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b - val iter : (key -> 'a -> unit) -> 'a t -> unit - val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t -end = HMap.Make(Level) +let big_rank = 1000000 (* A Level.t is either an alias for another one, or a canonical one, for which we know the universes that are above *) type univ_entry = - Canonical of canonical_arc + Canonical of canonical_node | Equiv of Level.t -type universes = univ_entry UMap.t +type universes = + { entries : univ_entry UMap.t; + index : int; + n_nodes : int; n_edges : int } type t = universes (** Used to cleanup universes if a traversal function is interrupted before it has the opportunity to do it itself. *) let unsafe_cleanup_universes g = - let iter _ arc = match arc with + let iter _ n = match n with | Equiv _ -> () - | Canonical arc -> arc.status <- Unset + | Canonical n -> n.status <- NoMark in - UMap.iter iter g + UMap.iter iter g.entries let rec cleanup_universes g = try unsafe_cleanup_universes g @@ -89,30 +95,43 @@ let rec cleanup_universes g = succeed. *) cleanup_universes g; raise e -let enter_equiv_arc u v g = - UMap.add u (Equiv v) g - -let enter_arc ca g = - UMap.add ca.univ (Canonical 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 *) +(* Low-level function : makes u an alias for v. + Does not removes edges from n_edges, but decrements n_nodes. + u should be entered as canonical before. *) +let enter_equiv g u v = + { entries = + UMap.modify u (fun _ a -> + match a with + | Canonical n -> + n.status <- NoMark; + Equiv v + | _ -> assert false) g.entries; + index = g.index; + n_nodes = g.n_nodes - 1; + n_edges = g.n_edges } + +(* Low-level function : changes data associated with a canonical node. + Resets the mutable fields in the old record, in order to avoid breaking + invariants for other users of this record. + n.univ should already been inserted as a canonical node. *) +let change_node g n = + { g with entries = + UMap.modify n.univ + (fun _ a -> + match a with + | Canonical n' -> + n'.status <- NoMark; + Canonical n + | _ -> assert false) + g.entries } + +(* repr : universes -> Level.t -> canonical_node *) (* canonical representative : we follow the Equiv links *) - let rec repr g u = let a = - try UMap.find u g + try UMap.find u g.entries with Not_found -> anomaly ~label:"Univ.repr" (str"Universe " ++ Level.pr u ++ str" undefined") in @@ -120,279 +139,484 @@ let rec repr g u = | Equiv v -> repr g v | Canonical arc -> arc -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 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 = - let rec searchrec w = function - | [] -> w - | v :: vl -> - let arcv = repr g v in - if List.memq arcv w || arcu==arcv then - searchrec w vl - else - searchrec (arcv :: w) vl + +(* Reindexes the given universe, using the next available index. *) +let use_index g u = + let u = repr g u in + let g = change_node g { u with ilvl = g.index } in + assert (g.index > min_int); + { g with index = g.index - 1 } + +(* [safe_repr] is like [repr] but if the graph doesn't contain the + searched universe, we add it. *) +let safe_repr g u = + let rec safe_repr_rec entries u = + match UMap.find u entries with + | Equiv v -> safe_repr_rec entries v + | Canonical arc -> arc in - searchrec [] arcu.le - - -(* between : Level.t -> canonical_arc -> canonical_arc list *) -(* between u v = { w | u<=w<=v, w canonical } *) -(* between is the most costly operation *) - -let between g arcu arcv = - (* good are all w | u <= w <= v *) - (* bad are all w | u <= w ~<= v *) - (* find good and bad nodes in {w | u <= w} *) - (* explore b u = (b or "u is good") *) - let rec explore ((good, bad, b) as input) arcu = - if List.memq arcu good then - (good, bad, true) (* b or true *) - else if List.memq arcu bad then - input (* (good, bad, b or false) *) + try g, safe_repr_rec g.entries u + with Not_found -> + let can = + { univ = u; + ltle = UMap.empty; gtge = LSet.empty; + rank = if Level.is_small u then big_rank else 0; + klvl = 0; ilvl = 0; + status = NoMark } + in + let g = { g with + entries = UMap.add u (Canonical can) g.entries; + n_nodes = g.n_nodes + 1 } + in + let g = use_index g u in + g, repr g u + +(* Returns 1 if u is higher than v in topological order. + -1 lower + 0 if u = v *) +let topo_compare u v = + if u.klvl > v.klvl then 1 + else if u.klvl < v.klvl then -1 + else if u.ilvl > v.ilvl then 1 + else if u.ilvl < v.ilvl then -1 + else (assert (u==v); 0) + +(* Checks most of the invariants of the graph. For debugging purposes. *) +let check_universes_invariants g = + let n_edges = ref 0 in + let n_nodes = ref 0 in + UMap.iter (fun l u -> + match u with + | Canonical u -> + UMap.iter (fun v strict -> + incr n_edges; + let v = repr g v in + assert (topo_compare u v = -1); + if u.klvl = v.klvl then + assert (LSet.mem u.univ v.gtge || + LSet.exists (fun l -> u == repr g l) v.gtge)) + u.ltle; + LSet.iter (fun v -> + let v = repr g v in + assert (v.klvl = u.klvl && + (UMap.mem u.univ v.ltle || + UMap.exists (fun l _ -> u == repr g l) v.ltle)) + ) u.gtge; + assert (u.status = NoMark); + assert (Level.equal l u.univ); + assert (u.ilvl > g.index); + assert (not (UMap.mem u.univ u.ltle)); + incr n_nodes + | Equiv _ -> assert (not (Level.is_small l))) + g.entries; + assert (!n_edges = g.n_edges); + assert (!n_nodes = g.n_nodes) + +let clean_ltle g ltle = + UMap.fold (fun u strict acc -> + let uu = (repr g u).univ in + if Level.equal uu u then acc + else ( + let acc = UMap.remove u (fst acc) in + if not strict && UMap.mem uu acc then (acc, true) + else (UMap.add uu strict acc, true))) + ltle (ltle, false) + +let clean_gtge g gtge = + LSet.fold (fun u acc -> + let uu = (repr g u).univ in + if Level.equal uu u then acc + else LSet.add uu (LSet.remove u (fst acc)), true) + gtge (gtge, false) + +(* [get_ltle] and [get_gtge] return ltle and gtge arcs. + Moreover, if one of these lists is dirty (e.g. points to a + non-canonical node), these functions clean this node in the + graph by removing some duplicate edges *) +let get_ltle g u = + let ltle, chgt_ltle = clean_ltle g u.ltle in + if not chgt_ltle then u.ltle, u, g + else + let sz = UMap.cardinal u.ltle in + let sz2 = UMap.cardinal ltle in + let u = { u with ltle } in + let g = change_node g u in + let g = { g with n_edges = g.n_edges + sz2 - sz } in + u.ltle, u, g + +let get_gtge g u = + let gtge, chgt_gtge = clean_gtge g u.gtge in + if not chgt_gtge then u.gtge, u, g + else + let u = { u with gtge } in + let g = change_node g u in + u.gtge, u, g + +(* [revert_graph] rollbacks the changes made to mutable fields in + nodes in the graph. + [to_revert] contains the touched nodes. *) +let revert_graph to_revert g = + List.iter (fun t -> + match UMap.find t g.entries with + | Equiv _ -> () + | Canonical t -> + t.status <- NoMark) to_revert + +exception AbortBackward of universes +exception CycleDetected + +(* Implementation of the algorithm described in § 5.1 of the following paper: + + Bender, M. A., Fineman, J. T., Gilbert, S., & Tarjan, R. E. (2011). A + new approach to incremental cycle detection and related + problems. arXiv preprint arXiv:1112.0784. + + The "STEP X" comments contained in this file refers to the + corresponding step numbers of the algorithm described in Section + 5.1 of this paper. *) + +(* [delta] is the timeout for backward search. It might be + useful to tune a multiplicative constant. *) +let get_delta g = + int_of_float + (min (float_of_int g.n_edges ** 0.5) + (float_of_int g.n_nodes ** (2./.3.))) + +let rec backward_traverse to_revert b_traversed count g x = + let x = repr g x in + let count = count - 1 in + if count < 0 then begin + revert_graph to_revert g; + raise (AbortBackward g) + end; + if x.status = NoMark then begin + x.status <- Visited; + let to_revert = x.univ::to_revert in + let gtge, x, g = get_gtge g x in + let to_revert, b_traversed, count, g = + LSet.fold (fun y (to_revert, b_traversed, count, g) -> + backward_traverse to_revert b_traversed count g y) + gtge (to_revert, b_traversed, count, g) + in + to_revert, x.univ::b_traversed, count, g + end + else to_revert, b_traversed, count, g + +let rec forward_traverse f_traversed g v_klvl x y = + let y = repr g y in + if y.klvl < v_klvl then begin + let y = { y with klvl = v_klvl; + gtge = if x == y then LSet.empty + else LSet.singleton x.univ } + in + let g = change_node g y in + let ltle, y, g = get_ltle g y in + let f_traversed, g = + UMap.fold (fun z _ (f_traversed, g) -> + forward_traverse f_traversed g v_klvl y z) + ltle (f_traversed, g) + in + y.univ::f_traversed, g + end else if y.klvl = v_klvl && x != y then + let g = change_node g + { y with gtge = LSet.add x.univ y.gtge } in + f_traversed, g + else f_traversed, g + +let rec find_to_merge to_revert g x v = + let x = repr g x in + match x.status with + | Visited -> false, to_revert | ToMerge -> true, to_revert + | NoMark -> + let to_revert = x::to_revert in + if Level.equal x.univ v then + begin x.status <- ToMerge; true, to_revert end else - let leq = reprleq g arcu in - (* is some universe >= u good ? *) - let good, bad, b_leq = - List.fold_left explore (good, bad, false) leq - in - if b_leq then - arcu::good, bad, true (* b or true *) - else - good, arcu::bad, b (* b or false *) + begin + let merge, to_revert = LSet.fold + (fun y (merge, to_revert) -> + let merge', to_revert = find_to_merge to_revert g y v in + merge' || merge, to_revert) x.gtge (false, to_revert) + in + x.status <- if merge then ToMerge else Visited; + merge, to_revert + end + | _ -> assert false + +let get_new_edges g to_merge = + (* Computing edge sets. *) + let to_merge_lvl = + List.fold_left (fun acc u -> UMap.add u.univ u acc) + UMap.empty to_merge 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 = [] - *) + let ltle = + UMap.fold (fun _ n acc -> + UMap.merge (fun _ strict1 strict2 -> + match strict1, strict2 with + | Some true, _ | _, Some true -> Some true + | _, _ -> Some false) + acc n.ltle) + to_merge_lvl UMap.empty + in + let ltle, _ = clean_ltle g ltle in + let ltle = + UMap.merge (fun _ a strict -> + match a, strict with + | Some _, Some true -> + (* There is a lt edge inside the new component. This is a + "bad cycle". *) + raise CycleDetected + | Some _, Some false -> None + | _, _ -> strict + ) to_merge_lvl ltle + in + let gtge = + UMap.fold (fun _ n acc -> LSet.union acc n.gtge) + to_merge_lvl LSet.empty + in + let gtge, _ = clean_gtge g gtge in + let gtge = LSet.diff gtge (UMap.domain to_merge_lvl) in + (ltle, gtge) -(** [fast_compare_neq] : is [arcv] in the transitive upward closure of [arcu] ? - - In [strict] mode, we fully distinguish between LE and LT, while in - non-strict mode, we simply answer LE for both situations. - - If [arcv] is encountered in a LT part, we could directly answer - without visiting unneeded parts of this transitive closure. - In [strict] mode, if [arcv] is encountered in a LE part, we could only - change the default answer (1st arg [c]) from NLE to LE, since a strict - constraint may appear later. During the recursive traversal, - [lt_done] and [le_done] are universes we have already visited, - they do not contain [arcv]. The 4rd arg is [(lt_todo,le_todo)], - two lists of universes not yet considered, known to be above [arcu], - strictly or not. - - We use depth-first search, but the presence of [arcv] in [new_lt] - is checked as soon as possible : this seems to be slightly faster - on a test. - - We do the traversal imperatively, setting the [status] flag on visited nodes. - This ensures O(1) check, but it also requires unsetting the flag when leaving - the function. Some special care has to be taken in order to ensure we do not - recover a messed up graph at the end. This occurs in particular when the - traversal raises an exception. Even though the code below is exception-free, - OCaml may still raise random exceptions, essentially fatal exceptions or - signal handlers. Therefore we ensure the cleanup by a catch-all clause. Note - also that the use of an imperative solution does make this function - thread-unsafe. For now we do not check universes in different threads, but if - ever this is to be done, we would need some lock somewhere. -*) +let reorder g u v = + (* STEP 2: backward search in the k-level of u. *) + let delta = get_delta g in -let get_explanation strict g arcu arcv = - (* [c] characterizes whether (and how) arcv has already been related - to arcu among the lt_done,le_done universe *) - let rec cmp c to_revert lt_todo le_todo = match lt_todo, le_todo with - | [],[] -> (to_revert, c) - | (arc,p)::lt_todo, le_todo -> - 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 - let p = (Lt, Universe.make u) :: p in - if arc == arcv then - if strict then (to_revert, p) else (to_revert, p) - else find ((arc, p) :: lt_todo) lt le - end - | u :: le -> - let arc = repr g u in - let p = (Le, Universe.make u) :: p in - if arc == arcv then - if strict then (to_revert, p) else (to_revert, p) - else find ((arc, p) :: lt_todo) lt le - in - find lt_todo arc.lt arc.le - | [], (arc,p)::le_todo -> - if arc == arcv then - (* No need to continue inspecting universes above arc: - if arcv is strictly above arc, then we would have a cycle. - But we cannot answer LE yet, a stronger constraint may - come later from [le_todo]. *) - if strict then cmp p to_revert [] le_todo else (to_revert, p) - else - 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 p = (Le, Universe.make u) :: p in - let node = (repr g u, p) 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 - let p = (Lt, Universe.make u) :: p in - if arc == arcv then - if strict then (to_revert, p) else (to_revert, p) - else find ((arc, p) :: lt_todo) lt + (* [v_klvl] is the chosen future level for u, v and all + traversed nodes. *) + let b_traversed, v_klvl, g = + try + let to_revert, b_traversed, _, g = backward_traverse [] [] delta g u in + revert_graph to_revert g; + let v_klvl = (repr g u).klvl in + b_traversed, v_klvl, g + with AbortBackward g -> + (* Backward search was too long, use the next k-level. *) + let v_klvl = (repr g u).klvl + 1 in + [], v_klvl, g + in + let f_traversed, g = + (* STEP 3: forward search. Contrary to what is described in + the paper, we do not test whether v_klvl = u.klvl nor we assign + v_klvl to v.klvl. Indeed, the first call to forward_traverse + will do all that. *) + forward_traverse [] g v_klvl (repr g v) v + in + + (* STEP 4: merge nodes if needed. *) + let to_merge, b_reindex, f_reindex = + if (repr g u).klvl = v_klvl then + begin + let merge, to_revert = find_to_merge [] g u v in + let r = + if merge then + List.filter (fun u -> u.status = ToMerge) to_revert, + List.filter (fun u -> (repr g u).status <> ToMerge) b_traversed, + List.filter (fun u -> (repr g u).status <> ToMerge) f_traversed + else [], b_traversed, f_traversed in - find [] arc.lt + List.iter (fun u -> u.status <- NoMark) to_revert; + r + end + else [], b_traversed, f_traversed in - let start = (* if is_prop_arc arcu then [Le, make arcv.univ] else *) [] in - try - 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 - with e -> - (** Unlikely event: fatal error or signal *) - let () = cleanup_universes g in - raise e + let to_reindex, g = + match to_merge with + | [] -> List.rev_append f_reindex b_reindex, g + | n0::q0 -> + (* Computing new root. *) + let root, rank_rest = + List.fold_left (fun ((best, rank_rest) as acc) n -> + if n.rank >= best.rank then n, best.rank else acc) + (n0, min_int) q0 + in + let ltle, gtge = get_new_edges g to_merge in + (* Inserting the new root. *) + let g = change_node g + { root with ltle; gtge; + rank = max root.rank (rank_rest + 1); } + in -let get_explanation strict g arcu arcv = - if !Flags.univ_print then Some (get_explanation strict g arcu arcv) - else None + (* Inserting shortcuts for old nodes. *) + let g = List.fold_left (fun g n -> + if Level.equal n.univ root.univ then g else enter_equiv g n.univ root.univ) + g to_merge + in -type fast_order = FastEQ | FastLT | FastLE | FastNLE + (* Updating g.n_edges *) + let oldsz = + List.fold_left (fun sz u -> sz+UMap.cardinal u.ltle) + 0 to_merge + in + let sz = UMap.cardinal ltle in + let g = { g with n_edges = g.n_edges + sz - oldsz } in -let fast_compare_neq strict g arcu arcv = - (* [c] characterizes whether arcv has already been related - to arcu among the lt_done,le_done universe *) - let rec cmp c to_revert lt_todo le_todo = match lt_todo, le_todo with - | [],[] -> (to_revert, c) - | arc::lt_todo, le_todo -> - if arc_is_lt arc then - cmp c to_revert lt_todo le_todo - else - 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: - if arcv is strictly above arc, then we would have a cycle. - But we cannot answer LE yet, a stronger constraint may - come later from [le_todo]. *) - if strict then cmp FastLE to_revert [] le_todo else (to_revert, FastLE) - else - if arc_is_le arc then - cmp c to_revert [] le_todo - else - 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 + (* Not clear in the paper: we have to put the newly + created component just between B and F. *) + List.rev_append f_reindex (root.univ::b_reindex), g in + + (* STEP 5: reindex traversed nodes. *) + List.fold_left use_index g to_reindex + +(* Assumes [u] and [v] are already in the graph. *) +(* Does NOT assume that ucan != vcan. *) +let insert_edge strict ucan vcan g = try - let (to_revert, c) = cmp FastNLE [] [] [arcu] in - (** Reset all the touched arcs. *) - let () = List.iter (fun arc -> arc.status <- Unset) to_revert in - c - with e -> + let u = ucan.univ and v = vcan.univ in + (* STEP 1: do we need to reorder nodes ? *) + let g = if topo_compare ucan vcan <= 0 then g else reorder g u v in + + (* STEP 6: insert the new edge in the graph. *) + let u = repr g u in + let v = repr g v in + if u == v then + if strict then raise CycleDetected else g + else + let g = + try let oldstrict = UMap.find v.univ u.ltle in + if strict && not oldstrict then + change_node g { u with ltle = UMap.add v.univ true u.ltle } + else g + with Not_found -> + { (change_node g { u with ltle = UMap.add v.univ strict u.ltle }) + with n_edges = g.n_edges + 1 } + in + if u.klvl <> v.klvl || LSet.mem u.univ v.gtge then g + else + let v = { v with gtge = LSet.add u.univ v.gtge } in + change_node g v + with + | CycleDetected as e -> raise e + | e -> (** Unlikely event: fatal error or signal *) let () = cleanup_universes g in raise e -let get_explanation_strict g arcu arcv = get_explanation true g arcu arcv +let add_universe vlev strict g = + try + let _arcv = UMap.find vlev g.entries in + raise AlreadyDeclared + with Not_found -> + assert (g.index > min_int); + let v = { + univ = vlev; + ltle = LMap.empty; + gtge = LSet.empty; + rank = 0; + klvl = 0; + ilvl = g.index; + status = NoMark; + } + in + let entries = UMap.add vlev (Canonical v) g.entries in + let g = { entries; index = g.index - 1; n_nodes = g.n_nodes + 1; n_edges = g.n_edges } in + insert_edge strict (get_set_arc g) v g + +exception Found_explanation of explanation + +let get_explanation strict u v g = + let v = repr g v in + let visited_strict = ref UMap.empty in + let rec traverse strict u = + if u == v then + if strict then None else Some [] + else if topo_compare u v = 1 then None + else + let visited = + try not (UMap.find u.univ !visited_strict) || strict + with Not_found -> false + in + if visited then None + else begin + visited_strict := UMap.add u.univ strict !visited_strict; + try + UMap.iter (fun u' strictu' -> + match traverse (strict && not strictu') (repr g u') with + | None -> () + | Some exp -> + let typ = if strictu' then Lt else Le in + raise (Found_explanation ((typ, make u') :: exp))) + u.ltle; + None + with Found_explanation exp -> Some exp + end + in + let u = repr g u in + if u == v then [(Eq, make v.univ)] + else match traverse strict u with Some exp -> exp | None -> assert false -let fast_compare g arcu arcv = - if arcu == arcv then FastEQ else fast_compare_neq true g arcu arcv +let get_explanation strict u v g = + if !Flags.univ_print then Some (get_explanation strict u v g) + else None -let is_leq g arcu arcv = - arcu == arcv || - (match fast_compare_neq false g arcu arcv with - | FastNLE -> false - | (FastEQ|FastLE|FastLT) -> true) - -let is_lt g arcu arcv = - if arcu == arcv then false +(* To compare two nodes, we simply do a forward search. + We implement two improvements: + - we ignore nodes that are higher than the destination; + - we do a BFS rather than a DFS because we expect to have a short + path (typically, the shortest path has length 1) +*) +exception Found of canonical_node list +let search_path strict u v g = + let rec loop to_revert todo next_todo = + match todo, next_todo with + | [], [] -> to_revert (* No path found *) + | [], _ -> loop to_revert next_todo [] + | (u, strict)::todo, _ -> + if u.status = Visited || (u.status = WeakVisited && strict) + then loop to_revert todo next_todo + else + let to_revert = + if u.status = NoMark then u::to_revert else to_revert + in + u.status <- if strict then WeakVisited else Visited; + if try UMap.find v.univ u.ltle || not strict + with Not_found -> false + then raise (Found to_revert) + else + begin + let next_todo = + UMap.fold (fun u strictu next_todo -> + let strict = not strictu && strict in + let u = repr g u in + if u == v && not strict then raise (Found to_revert) + else if topo_compare u v = 1 then next_todo + else (u, strict)::next_todo) + u.ltle next_todo + in + loop to_revert todo next_todo + end + in + if u == v then not strict else - match fast_compare_neq true g arcu arcv with - | FastLT -> true - | (FastEQ|FastLE|FastNLE) -> false - -(* Invariants : compare(u,v) = EQ <=> compare(v,u) = EQ - compare(u,v) = LT or LE => compare(v,u) = NLE - compare(u,v) = NLE => compare(v,u) = NLE or LE or LT - - Adding u>=v is consistent iff compare(v,u) # LT - and then it is redundant iff compare(u,v) # NLE - Adding u>v is consistent iff compare(v,u) = NLE - and then it is redundant iff compare(u,v) = LT *) - -(** * Universe checks [check_eq] and [check_leq], used in coqchk *) + try + let res, to_revert = + try false, loop [] [u, strict] [] + with Found to_revert -> true, to_revert + in + List.iter (fun u -> u.status <- NoMark) to_revert; + res + with e -> + (** Unlikely event: fatal error or signal *) + let () = cleanup_universes g in + raise e + +(** Uncomment to debug the cycle detection algorithm. *) +(*let insert_edge strict ucan vcan g = + check_universes_invariants g; + let g = insert_edge strict ucan vcan g in + check_universes_invariants g; + let ucan = repr g ucan.univ in + let vcan = repr g vcan.univ in + assert (search_path strict ucan vcan g); + g*) (** First, checks on universe levels *) @@ -405,11 +629,11 @@ let check_eq_level g u v = u == v || check_equal g u v let check_smaller g strict u v = let arcu = repr g u and arcv = repr g v in if strict then - is_lt g arcu arcv + search_path true arcu arcv g else is_prop_arc arcu || (is_set_arc arcu && not (is_prop_arc arcv)) - || is_leq g arcu arcv + || search_path false arcu arcv g (** Then, checks on universes *) @@ -448,145 +672,68 @@ let check_leq g u v = is_type0m_univ u || check_eq_univs g u v || real_check_leq g u v -(** Enforcing new constraints : [setlt], [setleq], [merge], [merge_disc] *) - -(* 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 - enter_arc arcu' g, arcu' - -(* checks that non-redundant *) -let setlt_if (g,arcu) v = - let arcv = repr g v in - if is_lt g arcu arcv then g, arcu - else setlt g arcu arcv - -(* setleq : Level.t -> Level.t -> unit *) -(* forces u >= 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 - enter_arc arcu' g, arcu' - -(* checks that non-redundant *) -let setleq_if (g,arcu) v = - let arcv = repr g v in - if is_leq g arcu arcv then g, arcu - else setleq g arcu arcv - -(* merge : Level.t -> Level.t -> unit *) -(* we assume compare(u,v) = LE *) -(* merge u v forces u ~ v with repr u as canonical repr *) -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 && 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 - match between g arcu arcv with - | [] -> anomaly (str "Univ.between") - | arc::rest -> - let (max_rank, old_max_rank, best_arc, rest) = - List.fold_left best_ranked (arc.rank, min_int, arc, []) rest in - if max_rank > old_max_rank then best_arc, g, rest - else begin - (* one redirected node also has max_rank *) - let arcu = {best_arc with rank = max_rank + 1} in - arcu, enter_arc arcu g, rest - end - in - let redirect (g,w,w') arcv = - let g' = enter_equiv_arc arcv.univ arcu.univ g in - (g',List.unionq arcv.lt w,arcv.le@w') - in - let (g',w,w') = List.fold_left redirect (g,[],[]) v in - let g_arcu = (g',arcu) in - let g_arcu = List.fold_left setlt_if g_arcu w in - let g_arcu = List.fold_left setleq_if g_arcu w' in - fst g_arcu - -(* merge_disc : Level.t -> Level.t -> unit *) -(* 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 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 - let arcu = {arcu with rank = succ arcu.rank} in - arcu, enter_arc arcu g - in - let g' = enter_equiv_arc arcv.univ arcu.univ g in - let g_arcu = (g',arcu) in - let g_arcu = List.fold_left setlt_if g_arcu arcv.lt in - let g_arcu = List.fold_left setleq_if g_arcu arcv.le in - fst g_arcu +(* enforce_univ_eq g 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 rec enforce_univ_eq u v g = + let ucan = repr g u in + let vcan = repr g v in + if topo_compare ucan vcan = 1 then enforce_univ_eq v u g + else + let g = insert_edge false ucan vcan g in (* Cannot fail *) + try insert_edge false vcan ucan g + with CycleDetected -> + error_inconsistency Eq v u (get_explanation true u v g) -let enforce_univ_eq u v g = - let arcu = repr g u and arcv = repr g v in - match fast_compare g arcu arcv with - | FastEQ -> g - | FastLT -> - let p = get_explanation_strict g arcu arcv in - error_inconsistency Eq v u p - | FastLE -> merge g arcu arcv - | FastNLE -> - (match fast_compare g arcv arcu with - | FastLT -> - let p = get_explanation_strict g arcv arcu in - error_inconsistency Eq u v p - | FastLE -> merge g arcv arcu - | FastNLE -> merge_disc g arcu arcv - | FastEQ -> anomaly (Pp.str "Univ.compare")) - -(* enforce_univ_leq : Level.t -> Level.t -> unit *) -(* enforce_univ_leq u v will force u<=v if possible, will fail otherwise *) +(* enforce_univ_leq g u v will force u<=v if possible, will fail otherwise *) let enforce_univ_leq u v g = - 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 - | FastLT -> - let p = get_explanation_strict g arcv arcu in - error_inconsistency Le u v p - | FastLE -> merge g arcv arcu - | FastNLE -> fst (setleq g arcu arcv) - | FastEQ -> anomaly (Pp.str "Univ.compare") + let ucan = repr g u in + let vcan = repr g v in + try insert_edge false ucan vcan g + with CycleDetected -> + error_inconsistency Le u v (get_explanation true v u g) (* enforce_univ_lt u v will force u<v if possible, will fail otherwise *) let enforce_univ_lt u v g = - 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) - | FastEQ -> error_inconsistency Lt u v (Some [(Eq,Universe.make v)]) - | FastNLE -> - match fast_compare_neq false g arcv arcu with - FastNLE -> fst (setlt g arcu arcv) - | FastEQ -> anomaly (Pp.str "Univ.compare") - | (FastLE|FastLT) -> - let p = get_explanation false g arcv arcu in - error_inconsistency Lt u v p + let ucan = repr g u in + let vcan = repr g v in + try insert_edge true ucan vcan g + with CycleDetected -> + error_inconsistency Lt u v (get_explanation false v u g) + +let empty_universes = + let set_arc = Canonical { + univ = Level.set; + ltle = LMap.empty; + gtge = LSet.empty; + rank = big_rank; + klvl = 0; + ilvl = (-1); + status = NoMark; + } in + let prop_arc = Canonical { + univ = Level.prop; + ltle = LMap.empty; + gtge = LSet.empty; + rank = big_rank; + klvl = 0; + ilvl = 0; + status = NoMark; + } in + let entries = UMap.add Level.set set_arc (UMap.singleton Level.prop prop_arc) in + let empty = { entries; index = (-2); n_nodes = 2; n_edges = 0 } in + enforce_univ_lt Level.prop Level.set empty (* Prop = Set is forbidden here. *) let initial_universes = empty_universes -let is_initial_universes g = UMap.equal (==) g initial_universes - +let is_initial_universes g = UMap.equal (==) g.entries initial_universes.entries + let enforce_constraint cst g = match cst with | (u,Lt,v) -> enforce_univ_lt u v g | (u,Le,v) -> enforce_univ_leq u v g | (u,Eq,v) -> enforce_univ_eq u v g - + let merge_constraints c g = Constraint.fold enforce_constraint c g @@ -601,200 +748,93 @@ let check_constraints c g = (* Normalization *) -let lookup_level u g = - try Some (UMap.find u g) with Not_found -> None - (** [normalize_universes g] returns a graph where all edges point directly to the canonical representent of their target. The output graph should be equivalent to the input graph from a logical point of view, but optimized. We maintain the invariant that the key of - a [Canonical] element is its own name, by keeping [Equiv] edges - (see the assertion)... I (Stéphane Glondu) am not sure if this - plays a role in the rest of the module. *) + a [Canonical] element is its own name, by keeping [Equiv] edges. *) let normalize_universes g = - let rec visit u arc cache = match lookup_level u cache with - | Some x -> x, cache - | None -> match Lazy.force arc with - | None -> - u, UMap.add u u cache - | Some (Canonical {univ=v; lt=_; le=_}) -> - v, UMap.add u v cache - | Some (Equiv v) -> - let v, cache = visit v (lazy (lookup_level v g)) cache in - v, UMap.add u v cache - in - let cache = UMap.fold - (fun u arc cache -> snd (visit u (Lazy.lazy_from_val (Some arc)) cache)) - g UMap.empty - in - let repr x = UMap.find x cache in - let lrepr us = List.fold_left - (fun e x -> LSet.add (repr x) e) LSet.empty us + let g = + { g with + entries = UMap.map (fun entry -> + match entry with + | Equiv u -> Equiv ((repr g u).univ) + | Canonical ucan -> Canonical { ucan with rank = 1 }) + g.entries } in - let canonicalize u = function - | Equiv _ -> Equiv (repr u) - | Canonical {univ=v; lt=lt; le=le; rank=rank} -> - assert (u == v); - (* avoid duplicates and self-loops *) - let lt = lrepr lt and le = lrepr le in - let le = LSet.filter - (fun x -> x != u && not (LSet.mem x lt)) le - in - LSet.iter (fun x -> assert (x != u)) lt; - Canonical { - univ = v; - lt = LSet.elements lt; - le = LSet.elements le; - rank = rank; - status = Unset; - } - in - UMap.mapi canonicalize g + UMap.fold (fun _ u g -> + match u with + | Equiv u -> g + | Canonical u -> + let _, u, g = get_ltle g u in + let _, _, g = get_gtge g u in + g) + g.entries g let constraints_of_universes g = let constraints_of u v acc = match v with - | Canonical {univ=u; lt=lt; le=le} -> - let acc = List.fold_left (fun acc v -> Constraint.add (u,Lt,v) acc) acc lt in - let acc = List.fold_left (fun acc v -> Constraint.add (u,Le,v) acc) acc le in - acc + | Canonical {univ=u; ltle} -> + UMap.fold (fun v strict acc-> + let typ = if strict then Lt else Le in + Constraint.add (u,typ,v) acc) ltle acc | Equiv v -> Constraint.add (u,Eq,v) acc in - UMap.fold constraints_of g Constraint.empty + UMap.fold constraints_of g.entries Constraint.empty let constraints_of_universes g = constraints_of_universes (normalize_universes g) -(** Longest path algorithm. This is used to compute the minimal number of - universes required if the only strict edge would be the Lt one. This - algorithm assumes that the given universes constraints are a almost DAG, in - the sense that there may be {Eq, Le}-cycles. This is OK for consistent - universes, which is the only case where we use this algorithm. *) - -(** Adjacency graph *) -type graph = constraint_type LMap.t LMap.t - -exception Connected - -(** Check connectedness *) -let connected x y (g : graph) = - let rec connected x target seen g = - if Level.equal x target then raise Connected - else if not (LSet.mem x seen) then - let seen = LSet.add x seen in - let fold z _ seen = connected z target seen g in - let neighbours = try LMap.find x g with Not_found -> LMap.empty in - LMap.fold fold neighbours seen - else seen +(** [sort_universes g] builds a totally ordered universe graph. The + output graph should imply the input graph (and the implication + will be strict most of the time), but is not necessarily minimal. + Moreover, it adds levels [Type.n] to identify universes at level + n. An artificial constraint Set < Type.2 is added to ensure that + Type.n and small universes are not merged. Note: the result is + unspecified if the input graph already contains [Type.n] nodes + (calling a module Type is probably a bad idea anyway). *) +let sort_universes g = + let cans = + UMap.fold (fun _ u l -> + match u with + | Equiv _ -> l + | Canonical can -> can :: l + ) g.entries [] in - try ignore(connected x y LSet.empty g); false with Connected -> true - -let add_edge x y v (g : graph) = - try - let neighbours = LMap.find x g in - let neighbours = LMap.add y v neighbours in - LMap.add x neighbours g - with Not_found -> - LMap.add x (LMap.singleton y v) g - -(** We want to keep the graph DAG. If adding an edge would cause a cycle, that - would necessarily be an {Eq, Le}-cycle, otherwise there would have been a - universe inconsistency. Therefore we may omit adding such a cycling edge - without changing the compacted graph. *) -let add_eq_edge x y v g = if connected y x g then g else add_edge x y v g - -(** Construct the DAG and its inverse at the same time. *) -let make_graph g : (graph * graph) = - let fold u arc accu = match arc with - | Equiv v -> - let (dir, rev) = accu in - (add_eq_edge u v Eq dir, add_eq_edge v u Eq rev) - | Canonical { univ; lt; le; } -> - let () = assert (u == univ) in - let fold_lt (dir, rev) v = (add_edge u v Lt dir, add_edge v u Lt rev) in - let fold_le (dir, rev) v = (add_eq_edge u v Le dir, add_eq_edge v u Le rev) in - (** Order is important : lt after le, because of the possible redundancy - between [le] and [lt] in a canonical arc. This way, the [lt] constraint - is the last one set, which is correct because it implies [le]. *) - let accu = List.fold_left fold_le accu le in - let accu = List.fold_left fold_lt accu lt in - accu - in - UMap.fold fold g (LMap.empty, LMap.empty) - -(** Construct a topological order out of a DAG. *) -let rec topological_fold u g rem seen accu = - let is_seen = - try - let status = LMap.find u seen in - assert status; (** If false, not a DAG! *) - true - with Not_found -> false + let cans = List.sort topo_compare cans in + let lowest_levels = + UMap.mapi (fun u _ -> if Level.is_small u then 0 else 2) + (UMap.filter + (fun _ u -> match u with Equiv _ -> false | Canonical _ -> true) + g.entries) in - if not is_seen then - let rem = LMap.remove u rem in - let seen = LMap.add u false seen in - let neighbours = try LMap.find u g with Not_found -> LMap.empty in - let fold v _ (rem, seen, accu) = topological_fold v g rem seen accu in - let (rem, seen, accu) = LMap.fold fold neighbours (rem, seen, accu) in - (rem, LMap.add u true seen, u :: accu) - else (rem, seen, accu) - -let rec topological g rem seen accu = - let node = try Some (LMap.choose rem) with Not_found -> None in - match node with - | None -> accu - | Some (u, _) -> - let rem, seen, accu = topological_fold u g rem seen accu in - topological g rem seen accu - -(** Compute the longest path from any vertex. *) -let constraint_cost = function -| Eq | Le -> 0 -| Lt -> 1 - -(** This algorithm browses the graph in topological order, computing for each - encountered node the length of the longest path leading to it. Should be - O(|V|) or so (modulo map representation). *) -let rec flatten_graph rem (rev : graph) map mx = match rem with -| [] -> map, mx -| u :: rem -> - let prev = try LMap.find u rev with Not_found -> LMap.empty in - let fold v cstr accu = - let v_cost = LMap.find v map in - max (v_cost + constraint_cost cstr) accu + let lowest_levels = + List.fold_left (fun lowest_levels can -> + let lvl = UMap.find can.univ lowest_levels in + UMap.fold (fun u' strict lowest_levels -> + let cost = if strict then 1 else 0 in + let u' = (repr g u').univ in + UMap.modify u' (fun _ lvl0 -> max lvl0 (lvl+cost)) lowest_levels) + can.ltle lowest_levels) + lowest_levels cans in - let u_cost = LMap.fold fold prev 0 in - let map = LMap.add u u_cost map in - flatten_graph rem rev map (max mx u_cost) - -(** [sort_universes g] builds a map from universes in [g] to natural - numbers. It outputs a graph containing equivalence edges from each - level appearing in [g] to [Type.n], and [lt] edges between the - [Type.n]s. The output graph should imply the input graph (and the - [Type.n]s. The output graph should imply the input graph (and the - implication will be strict most of the time), but is not - necessarily minimal. Note: the result is unspecified if the input - graph already contains [Type.n] nodes (calling a module Type is - probably a bad idea anyway). *) -let sort_universes orig = - let (dir, rev) = make_graph orig in - let order = topological dir dir LMap.empty [] in - let compact, max = flatten_graph order rev LMap.empty 0 in + let max_lvl = UMap.fold (fun _ a b -> max a b) lowest_levels 0 in let mp = Names.DirPath.make [Names.Id.of_string "Type"] in - let types = Array.init (max + 1) (fun n -> Level.make mp n) in - (** Old universes are made equal to [Type.n] *) - let fold u level accu = UMap.add u (Equiv types.(level)) accu in - let sorted = LMap.fold fold compact UMap.empty in - (** Add all [Type.n] nodes *) - let fold i accu u = - 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 + let types = Array.init (max_lvl + 1) (function + | 0 -> Level.prop + | 1 -> Level.set + | n -> Level.make mp (n-2)) + in + let g = Array.fold_left (fun g u -> + let g, u = safe_repr g u in + change_node g { u with rank = big_rank }) g types in - Array.fold_left_i fold sorted types + let g = if max_lvl >= 2 then enforce_univ_lt Level.set types.(2) g else g in + let g = + UMap.fold (fun u lvl g -> enforce_univ_eq u (types.(lvl)) g) + lowest_levels g + in + normalize_universes g (** Instances *) @@ -807,39 +847,38 @@ let check_eq_instances g t1 t2 = (Int.equal i (Array.length t1)) || (check_eq_level g t1.(i) t2.(i) && aux (i + 1)) in aux 0) +(** Pretty-printing *) + let pr_arc prl = function - | _, Canonical {univ=u; lt=[]; le=[]} -> - mt () - | _, Canonical {univ=u; lt=lt; le=le} -> - let opt_sep = match lt, le with - | [], _ | _, [] -> mt () - | _ -> spc () - in + | _, Canonical {univ=u; ltle} -> + if UMap.is_empty ltle then mt () + else prl u ++ str " " ++ v 0 - (pr_sequence (fun v -> str "< " ++ prl v) lt ++ - opt_sep ++ - pr_sequence (fun v -> str "<= " ++ prl v) le) ++ + (pr_sequence (fun (v, strict) -> + (if strict then str "< " else str "<= ") ++ prl v) + (UMap.bindings ltle)) ++ fnl () | u, Equiv v -> prl u ++ str " = " ++ prl v ++ fnl () let pr_universes prl g = - let graph = UMap.fold (fun u a l -> (u,a)::l) g [] in + let graph = UMap.fold (fun u a l -> (u,a)::l) g.entries [] in prlist (pr_arc prl) graph (* Dumping constraints to a file *) let dump_universes output g = let dump_arc u = function - | Canonical {univ=u; lt=lt; le=le} -> + | Canonical {univ=u; ltle} -> let u_str = Level.to_string u in - List.iter (fun v -> output Lt (Level.to_string v) u_str) lt; - List.iter (fun v -> output Le (Level.to_string v) u_str) le + UMap.iter (fun v strict -> + let typ = if strict then Lt else Le in + output typ u_str (Level.to_string v)) ltle; | Equiv v -> output Eq (Level.to_string u) (Level.to_string v) in - UMap.iter dump_arc g + UMap.iter dump_arc g.entries (** Profiling *) @@ -848,7 +887,6 @@ let merge_constraints = let key = Profile.declare_profile "merge_constraints" in Profile.profile2 key merge_constraints else merge_constraints - let check_constraints = if Flags.profile then let key = Profile.declare_profile "check_constraints" in diff --git a/kernel/univ.ml b/kernel/univ.ml index 8201980e3..126f95f1f 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -12,8 +12,8 @@ (* Additional support for sort-polymorphic inductive types by HH [Mar 2006] *) (* Support for universe polymorphism by MS [2014] *) -(* Revisions by Bruno Barras, Hugo Herbelin, Pierre Letouzey, Matthieu Sozeau, - Pierre-Marie Pédrot *) +(* Revisions by Bruno Barras, Hugo Herbelin, Pierre Letouzey, Matthieu + Sozeau, Pierre-Marie Pédrot *) open Pp open Errors @@ -35,7 +35,7 @@ module type Hashconsed = sig type t val hash : t -> int - val equal : t -> t -> bool + val eq : t -> t -> bool val hcons : t -> t end @@ -53,7 +53,7 @@ struct type t = _t type u = (M.t -> M.t) let hash = function Nil -> 0 | Cons (_, h, _) -> h - let equal l1 l2 = match l1, l2 with + let eq l1 l2 = match l1, l2 with | Nil, Nil -> true | Cons (x1, _, l1), Cons (x2, _, l2) -> x1 == x2 && l1 == l2 | _ -> false @@ -135,12 +135,12 @@ module HList = struct let rec remove x = function | Nil -> nil | Cons (y, _, l) -> - if H.equal x y then l + if H.eq x y then l else cons y (remove x l) let rec mem x = function | Nil -> false - | Cons (y, _, l) -> H.equal x y || mem x l + | Cons (y, _, l) -> H.eq x y || mem x l let rec compare cmp l1 l2 = match l1, l2 with | Nil, Nil -> 0 @@ -251,7 +251,7 @@ module Level = struct type _t = t type t = _t type u = unit - let equal x y = x.hash == y.hash && RawLevel.hequal x.data y.data + let eq x y = x.hash == y.hash && RawLevel.hequal x.data y.data let hash x = x.hash let hashcons () x = let data' = RawLevel.hcons x.data in @@ -400,7 +400,7 @@ struct let hashcons hdir (b,n as x) = let b' = hdir b in if b' == b then x else (b',n) - let equal l1 l2 = + let eq l1 l2 = l1 == l2 || match l1,l2 with | (b,n), (b',n') -> b == b' && n == n' @@ -419,7 +419,7 @@ struct let hcons = Hashcons.simple_hcons H.generate H.hcons Level.hcons let hash = ExprHash.hash - let equal x y = x == y || + let eq x y = x == y || (let (u,n) = x and (v,n') = y in Int.equal n n' && Level.equal u v) @@ -724,7 +724,7 @@ module Hconstraint = type t = univ_constraint type u = universe_level -> universe_level let hashcons hul (l1,k,l2) = (hul l1, k, hul l2) - let equal (l1,k,l2) (l1',k',l2') = + let eq (l1,k,l2) (l1',k',l2') = l1 == l1' && k == k' && l2 == l2' let hash = Hashtbl.hash end) @@ -736,7 +736,7 @@ module Hconstraints = type u = univ_constraint -> univ_constraint let hashcons huc s = Constraint.fold (fun x -> Constraint.add (huc x)) s Constraint.empty - let equal s s' = + let eq s s' = List.for_all2eq (==) (Constraint.elements s) (Constraint.elements s') @@ -901,7 +901,7 @@ struct a end - let equal t1 t2 = + let eq t1 t2 = t1 == t2 || (Int.equal (Array.length t1) (Array.length t2) && let rec aux i = @@ -937,7 +937,9 @@ struct else if Array.length y = 0 then x else Array.append x y - let of_array a = a + let of_array a = + assert(Array.for_all (fun x -> not (Level.is_prop x)) a); + a let to_array a = a @@ -945,7 +947,7 @@ struct let subst_fn fn t = let t' = CArray.smartmap fn t in - if t' == t then t else t' + if t' == t then t else of_array t' let levels x = LSet.of_array x @@ -977,7 +979,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 @@ -991,7 +993,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) @@ -1001,8 +1003,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 @@ -1062,7 +1067,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 @@ -1230,7 +1235,7 @@ module Huniverse_set = type u = universe_level -> universe_level let hashcons huc s = LSet.fold (fun x -> LSet.add (huc x)) s LSet.empty - let equal s s' = + let eq s s' = LSet.equal s s' let hash = Hashtbl.hash end) diff --git a/kernel/univ.mli b/kernel/univ.mli index ae7400337..1ccdebd50 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -308,6 +308,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 diff --git a/kernel/vars.ml b/kernel/vars.ml index 88c1e1038..b935ab6b9 100644 --- a/kernel/vars.ml +++ b/kernel/vars.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,7 +8,7 @@ open Names open Esubst -open Context +open Context.Rel.Declaration (*********************) (* Occurring *) @@ -151,20 +151,33 @@ let make_subst = function done; subst +(* The type of substitutions, with term substituting most recent + binder at the head *) + +type substl = Constr.t list + let substnl laml n c = substn_many (make_subst laml) n c let substl laml c = substn_many (make_subst laml) 0 c let subst1 lam c = substn_many [|make_substituend lam|] 0 c -let substnl_decl laml k r = map_rel_declaration (fun c -> substnl laml k c) r -let substl_decl laml r = map_rel_declaration (fun c -> substnl laml 0 c) r -let subst1_decl lam r = map_rel_declaration (fun c -> subst1 lam c) r +let substnl_decl laml k r = map_constr (fun c -> substnl laml k c) r +let substl_decl laml r = map_constr (fun c -> substnl laml 0 c) r +let subst1_decl lam r = map_constr (fun c -> subst1 lam c) r + +(* Build a substitution from an instance, inserting missing let-ins *) + +let subst_of_rel_context_instance sign l = + let rec aux subst sign l = + match sign, l with + | LocalAssum _ :: sign', a::args' -> aux (a::subst) sign' args' + | LocalDef (_,c,_)::sign', args' -> + aux (substl subst c :: subst) sign' args' + | [], [] -> subst + | _ -> Errors.anomaly (Pp.str "Instance and signature do not match") + in aux [] (List.rev sign) l -let substnl_named_decl laml k d = - map_named_declaration (fun c -> substnl laml k c) d -let substl_named_decl laml d = - map_named_declaration (fun c -> substnl laml 0 c) d -let subst1_named_decl lam d = - map_named_declaration (fun c -> subst1 lam c) d +let adjust_subst_to_rel_context sign l = + List.rev (subst_of_rel_context_instance sign l) (* (thin_val sigma) removes identity substitutions from sigma *) @@ -197,15 +210,10 @@ let replace_vars var_alist x = in substrec 0 x -(* -let repvarkey = Profile.declare_profile "replace_vars";; -let replace_vars vl c = Profile.profile2 repvarkey replace_vars vl c ;; -*) - -(* (subst_var str t) substitute (VAR str) by (Rel 1) in t *) +(* (subst_var str t) substitute (Var str) by (Rel 1) in t *) let subst_var str t = replace_vars [(str, Constr.mkRel 1)] t -(* (subst_vars [id1;...;idn] t) substitute (VAR idj) by (Rel j) in t *) +(* (subst_vars [id1;...;idn] t) substitute (Var idj) by (Rel j) in t *) let substn_vars p vars c = let _,subst = List.fold_left (fun (n,l) var -> ((n+1),(var,Constr.mkRel n)::l)) (p,[]) vars @@ -294,7 +302,7 @@ let subst_univs_level_constr subst c = if !changed then c' else c let subst_univs_level_context s = - map_rel_context (subst_univs_level_constr s) + Context.Rel.map (subst_univs_level_constr s) let subst_instance_constr subst c = if Univ.Instance.is_empty subst then c @@ -335,7 +343,7 @@ let subst_instance_constr subst c = 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 + else Context.Rel.map (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 fdd4603b5..574d50ecc 100644 --- a/kernel/vars.mli +++ b/kernel/vars.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,7 +8,6 @@ open Names open Constr -open Context (** {6 Occur checks } *) @@ -42,32 +41,85 @@ val liftn : int -> int -> constr -> constr (** [lift n c] lifts by [n] the positive indexes in [c] *) val lift : int -> constr -> constr -(** [substnl [a1;...;an] k c] substitutes in parallel [a1],...,[an] +(** The type [substl] is the type of substitutions [u₁..un] of type + some context Δ and defined in some environment Γ. Typing of + substitutions is defined by: + - Γ ⊢ ∅ : ∅, + - Γ ⊢ u₁..u{_n-1} : Δ and Γ ⊢ u{_n} : An\[u₁..u{_n-1}\] implies + Γ ⊢ u₁..u{_n} : Δ,x{_n}:A{_n} + - Γ ⊢ u₁..u{_n-1} : Δ and Γ ⊢ un : A{_n}\[u₁..u{_n-1}\] implies + Γ ⊢ u₁..u{_n} : Δ,x{_n}:=c{_n}:A{_n} when Γ ⊢ u{_n} ≡ c{_n}\[u₁..u{_n-1}\] + + Note that [u₁..un] is represented as a list with [un] at the head of + the list, i.e. as [[un;...;u₁]]. *) + +type substl = constr list + +(** Let [Γ] be a context interleaving declarations [x₁:T₁..xn:Tn] + and definitions [y₁:=c₁..yp:=cp] in some context [Γ₀]. Let + [u₁..un] be an {e instance} of [Γ], i.e. an instance in [Γ₀] + of the [xi]. Then, [subst_of_rel_context_instance Γ u₁..un] + returns the corresponding {e substitution} of [Γ], i.e. the + appropriate interleaving [σ] of the [u₁..un] with the [c₁..cp], + all of them in [Γ₀], so that a derivation [Γ₀, Γ, Γ₁|- t:T] + can be instantiated into a derivation [Γ₀, Γ₁ |- t[σ]:T[σ]] using + [substnl σ |Γ₁| t]. + Note that the instance [u₁..un] is represented starting with [u₁], + as if usable in [applist] while the substitution is + represented the other way round, i.e. ending with either [u₁] or + [c₁], as if usable for [substl]. *) +val subst_of_rel_context_instance : Context.Rel.t -> constr list -> substl + +(** For compatibility: returns the substitution reversed *) +val adjust_subst_to_rel_context : Context.Rel.t -> constr list -> constr list + +(** [substnl [a₁;...;an] k c] substitutes in parallel [a₁],...,[an] for respectively [Rel(k+1)],...,[Rel(k+n)] in [c]; it relocates - accordingly indexes in [a1],...,[an] and [c] *) -val substnl : constr list -> int -> constr -> constr -val substl : constr list -> constr -> constr + accordingly indexes in [an],...,[a1] and [c]. In terms of typing, if + Γ ⊢ a{_n}..a₁ : Δ and Γ, Δ, Γ' ⊢ c : T with |Γ'|=k, then + Γ, Γ' ⊢ [substnl [a₁;...;an] k c] : [substnl [a₁;...;an] k T]. *) +val substnl : substl -> int -> constr -> constr + +(** [substl σ c] is a short-hand for [substnl σ 0 c] *) +val substl : substl -> constr -> constr + +(** [substl a c] is a short-hand for [substnl [a] 0 c] *) val subst1 : constr -> constr -> constr -val substnl_decl : constr list -> int -> rel_declaration -> rel_declaration -val substl_decl : constr list -> rel_declaration -> rel_declaration -val subst1_decl : constr -> rel_declaration -> rel_declaration +(** [substnl_decl [a₁;...;an] k Ω] substitutes in parallel [a₁], ..., [an] + for respectively [Rel(k+1)], ..., [Rel(k+n)] in [Ω]; it relocates + accordingly indexes in [a₁],...,[an] and [c]. In terms of typing, if + Γ ⊢ a{_n}..a₁ : Δ and Γ, Δ, Γ', Ω ⊢ with |Γ'|=[k], then + Γ, Γ', [substnl_decl [a₁;...;an]] k Ω ⊢. *) +val substnl_decl : substl -> int -> Context.Rel.Declaration.t -> Context.Rel.Declaration.t -val substnl_named_decl : constr list -> int -> named_declaration -> named_declaration -val subst1_named_decl : constr -> named_declaration -> named_declaration -val substl_named_decl : constr list -> named_declaration -> named_declaration +(** [substl_decl σ Ω] is a short-hand for [substnl_decl σ 0 Ω] *) +val substl_decl : substl -> Context.Rel.Declaration.t -> Context.Rel.Declaration.t +(** [subst1_decl a Ω] is a short-hand for [substnl_decl [a] 0 Ω] *) +val subst1_decl : constr -> Context.Rel.Declaration.t -> Context.Rel.Declaration.t + +(** [replace_vars k [(id₁,c₁);...;(idn,cn)] t] substitutes [Var idj] by + [cj] in [t]. *) val replace_vars : (Id.t * constr) list -> constr -> constr -(** (subst_var str t) substitute (VAR str) by (Rel 1) in t *) -val subst_var : Id.t -> constr -> constr -(** [subst_vars [id1;...;idn] t] substitute [VAR idj] by [Rel j] in [t] - if two names are identical, the one of least indice is kept *) +(** [substn_vars k [id₁;...;idn] t] substitutes [Var idj] by [Rel j+k-1] in [t]. + If two names are identical, the one of least index is kept. In terms of + typing, if Γ,x{_n}:U{_n},...,x₁:U₁,Γ' ⊢ t:T, together with id{_j}:T{_j} and + Γ,x{_n}:U{_n},...,x₁:U₁,Γ' ⊢ T{_j}\[id{_j+1}..id{_n}:=x{_j+1}..x{_n}\] ≡ Uj, + then Γ\\{id₁,...,id{_n}\},x{_n}:U{_n},...,x₁:U₁,Γ' ⊢ [substn_vars + (|Γ'|+1) [id₁;...;idn] t] : [substn_vars (|Γ'|+1) [id₁;...;idn] + T]. *) +val substn_vars : int -> Id.t list -> constr -> constr + +(** [subst_vars [id1;...;idn] t] is a short-hand for [substn_vars + [id1;...;idn] 1 t]: it substitutes [Var idj] by [Rel j] in [t]. If + two names are identical, the one of least index is kept. *) val subst_vars : Id.t list -> constr -> constr -(** [substn_vars n [id1;...;idn] t] substitute [VAR idj] by [Rel j+n-1] in [t] - if two names are identical, the one of least indice is kept *) -val substn_vars : int -> Id.t list -> constr -> constr +(** [subst_var id t] is a short-hand for [substn_vars [id] 1 t]: it + substitutes [Var id] by [Rel 1] in [t]. *) +val subst_var : Id.t -> constr -> constr (** {3 Substitution of universes} *) @@ -82,11 +134,11 @@ val subst_univs_constr : universe_subst -> constr -> constr (** Level substitutions for polymorphism. *) val subst_univs_level_constr : universe_level_subst -> constr -> constr -val subst_univs_level_context : Univ.universe_level_subst -> rel_context -> rel_context +val subst_univs_level_context : Univ.universe_level_subst -> Context.Rel.t -> Context.Rel.t (** Instance substitution for polymorphism. *) val subst_instance_constr : universe_instance -> constr -> constr -val subst_instance_context : universe_instance -> rel_context -> rel_context +val subst_instance_context : universe_instance -> Context.Rel.t -> Context.Rel.t -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 2f6be0601..4610dbcb0 100644 --- a/kernel/vconv.ml +++ b/kernel/vconv.ml @@ -45,8 +45,15 @@ let rec conv_val env pb k v1 v2 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 -> 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 @@ -81,26 +88,46 @@ and conv_whd env pb k whd1 whd2 cu = 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 + | 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 @@ -144,25 +171,18 @@ 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 vm_conv_gen cv_pb env univs t1 t2 = try let v1 = val_of_constr env t1 in diff --git a/kernel/vconv.mli b/kernel/vconv.mli index 49e5d23e6..ff01735c0 100644 --- a/kernel/vconv.mli +++ b/kernel/vconv.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -12,7 +12,7 @@ open Reduction (********************************************************************** s conversion functions *) -val vm_conv : conv_pb -> types conversion_function +val vm_conv : conv_pb -> types kernel_conversion_function (** A conversion function parametrized by a universe comparator. Used outside of the kernel. *) diff --git a/kernel/vm.ml b/kernel/vm.ml index eacd803fd..702987643 100644 --- a/kernel/vm.ml +++ b/kernel/vm.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -121,12 +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|proj name] : a projection blocked by an accu *) -(* -- 4_[accu|fix_app] : a fixpoint blocked by an accu *) -(* -- 5_[accu|vswitch] : a match blocked by an accu *) -(* -- 6_[fcofix] : a cofix function *) -(* -- 7_[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] *) @@ -136,7 +136,8 @@ type vswitch = { type atom = | Aid of Vars.id_key - | Aind of pinductive + | Aind of inductive + | Atype of Univ.universe (* Zippers *) @@ -159,17 +160,98 @@ 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 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) | i when Int.equal i proj_tag -> @@ -199,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" @@ -212,67 +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)) - -(* 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 + else + Vconstr_block(Obj.obj o) (**********************************************) (* Constructors *******************************) @@ -299,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) @@ -317,11 +355,11 @@ let val_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 @@ -606,3 +644,34 @@ let apply_whd k whd = interprete (fun_code to_up) (Obj.magic to_up) (Obj.magic to_up) 0 | Vatom_stk(a,stk) -> 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 045d02333..6e9579aa4 100644 --- a/kernel/vm.mli +++ b/kernel/vm.mli @@ -22,7 +22,8 @@ type arguments type atom = | Aid of Vars.id_key - | Aind of pinductive + | Aind of inductive + | Atype of Univ.universe (** Zippers *) @@ -45,19 +46,27 @@ type whd = | Vconstr_const of int | Vconstr_block of vblock | Vatom_stk of atom * stack + | Vuniv_level of Univ.universe_level + +(** For debugging purposes only *) + +val pr_atom : atom -> Pp.std_ppcmds +val pr_whd : whd -> Pp.std_ppcmds +val pr_stack : stack -> 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 *) diff --git a/lib/aux_file.ml b/lib/aux_file.ml index 5dedb0d0a..f7bd81f85 100644 --- a/lib/aux_file.ml +++ b/lib/aux_file.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/aux_file.mli b/lib/aux_file.mli index b672d3db2..127827ab6 100644 --- a/lib/aux_file.mli +++ b/lib/aux_file.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/bigint.ml b/lib/bigint.ml index e739c7a11..e95604ffc 100644 --- a/lib/bigint.ml +++ b/lib/bigint.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/bigint.mli b/lib/bigint.mli index 02e3c1ad5..e5525f164 100644 --- a/lib/bigint.mli +++ b/lib/bigint.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/ephemeron.ml b/lib/cEphemeron.ml index b36904ca6..a38ea11e1 100644 --- a/lib/ephemeron.ml +++ b/lib/cEphemeron.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/ephemeron.mli b/lib/cEphemeron.mli index 195b23db3..1200e4e20 100644 --- a/lib/ephemeron.mli +++ b/lib/cEphemeron.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/cList.ml b/lib/cList.ml index 0ac372d8d..ba592d13f 100644 --- a/lib/cList.ml +++ b/lib/cList.ml @@ -48,6 +48,8 @@ sig val filteri : (int -> 'a -> bool) -> 'a list -> 'a list val smartfilter : ('a -> bool) -> 'a list -> 'a list + val extend : bool list -> 'a -> 'a list -> 'a list + val count : ('a -> bool) -> 'a list -> int val index : 'a eq -> 'a -> 'a list -> int val index0 : 'a eq -> 'a -> 'a list -> int val iteri : (int -> 'a -> unit) -> 'a list -> unit @@ -375,6 +377,18 @@ let rec smartfilter f l = match l with else h :: tl' else tl' +let rec extend l a l' = match l,l' with + | true::l, b::l' -> b :: extend l a l' + | false::l, l' -> a :: extend l a l' + | [], [] -> [] + | _ -> invalid_arg "extend" + +let count f l = + let rec aux acc = function + | [] -> acc + | h :: t -> if f h then aux (acc + 1) t else aux acc t in + aux 0 l + let rec index_f f x l n = match l with | [] -> raise Not_found | y :: l -> if f x y then n else index_f f x l (succ n) @@ -638,12 +652,13 @@ let rec split3 = function let (rx, ry, rz) = split3 l in (x::rx, y::ry, z::rz) let firstn n l = - let rec aux acc = function - | (0, l) -> List.rev acc - | (n, (h::t)) -> aux (h::acc) (pred n, t) + let rec aux acc n l = + match n, l with + | 0, _ -> List.rev acc + | n, h::t -> aux (h::acc) (pred n) t | _ -> failwith "firstn" in - aux [] (n,l) + aux [] n l let rec last = function | [] -> failwith "List.last" diff --git a/lib/cList.mli b/lib/cList.mli index 19eeb2509..9c7b815c1 100644 --- a/lib/cList.mli +++ b/lib/cList.mli @@ -94,6 +94,11 @@ sig (** [smartfilter f [a1...an] = List.filter f [a1...an]] but if for all i [f ai = true], then [smartfilter f l == l] *) + val extend : bool list -> 'a -> 'a list -> 'a list +(** [extend l a [a1..an]] assumes that the number of [true] in [l] is [n]; + it extends [a1..an] by inserting [a] at the position of [false] in [l] *) + val count : ('a -> bool) -> 'a list -> int + val index : 'a eq -> 'a -> 'a list -> int (** [index] returns the 1st index of an element in a list (counting from 1). *) diff --git a/lib/cMap.ml b/lib/cMap.ml index 876f84736..4b058380c 100644 --- a/lib/cMap.ml +++ b/lib/cMap.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -23,8 +23,9 @@ module type S = Map.S module type ExtS = sig - include Map.S + include CSig.MapS module Set : CSig.SetS with type elt = key + val get : key -> 'a t -> 'a val update : key -> 'a -> 'a t -> 'a t val modify : key -> (key -> 'a -> 'a) -> 'a t -> 'a t val domain : 'a t -> Set.t @@ -207,4 +208,5 @@ module Make(M : Map.OrderedType) = struct include Map.Make(M) include MapExt(M) + let get k m = try find k m with Not_found -> assert false end diff --git a/lib/cMap.mli b/lib/cMap.mli index cd3d2f5b1..3ef7fa2c8 100644 --- a/lib/cMap.mli +++ b/lib/cMap.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -25,12 +25,15 @@ module type S = Map.S module type ExtS = sig - include Map.S + include CSig.MapS (** The underlying Map library *) module Set : CSig.SetS with type elt = key (** Sets used by the domain function *) + val get : key -> 'a t -> 'a + (** Same as {!find} but fails an assertion instead of raising [Not_found] *) + val update : key -> 'a -> 'a t -> 'a t (** Same as [add], but expects the key to be present, and thus faster. @raise Not_found when the key is unbound in the map. *) diff --git a/lib/cSet.ml b/lib/cSet.ml index d7d5c70b3..037cdc356 100644 --- a/lib/cSet.ml +++ b/lib/cSet.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -57,7 +57,7 @@ struct open Hashset.Combine type t = set type u = M.t -> M.t - let equal s1 s2 = s1 == s2 || eqeq (spine s1 []) (spine s2 []) + let eq s1 s2 = s1 == s2 || eqeq (spine s1 []) (spine s2 []) let hash s = Set.fold (fun v accu -> combine (H.hash v) accu) s 0 let hashcons = umap end diff --git a/lib/cSet.mli b/lib/cSet.mli index e55054103..2452bb60e 100644 --- a/lib/cSet.mli +++ b/lib/cSet.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/cSig.mli b/lib/cSig.mli index 2a8bda293..151cfbdca 100644 --- a/lib/cSig.mli +++ b/lib/cSig.mli @@ -14,6 +14,8 @@ type ('a, 'b) union = Inl of 'a | Inr of 'b type 'a until = Stop of 'a | Cont of 'a (** Used for browsable-until structures. *) +type (_, _) eq = Refl : ('a, 'a) eq + module type SetS = sig type elt @@ -45,3 +47,36 @@ sig end (** Redeclaration of OCaml set signature, to preserve compatibility. See OCaml documentation for more information. *) + +module type EmptyS = sig end + +module type MapS = +sig + type key + type (+'a) t + val empty: 'a t + val is_empty: 'a t -> bool + val mem: key -> 'a t -> bool + val add: key -> 'a -> 'a t -> 'a t + val singleton: key -> 'a -> 'a t + val remove: key -> 'a t -> 'a t + val merge: + (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t + val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int + val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool + val iter: (key -> 'a -> unit) -> 'a t -> unit + val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + val for_all: (key -> 'a -> bool) -> 'a t -> bool + val exists: (key -> 'a -> bool) -> 'a t -> bool + val filter: (key -> 'a -> bool) -> 'a t -> 'a t + val partition: (key -> 'a -> bool) -> 'a t -> 'a t * 'a t + val cardinal: 'a t -> int + val bindings: 'a t -> (key * 'a) list + val min_binding: 'a t -> (key * 'a) + val max_binding: 'a t -> (key * 'a) + val choose: 'a t -> (key * 'a) + val split: key -> 'a t -> 'a t * 'a option * 'a t + val find: key -> 'a t -> 'a + val map: ('a -> 'b) -> 'a t -> 'b t + val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t +end diff --git a/lib/cString.ml b/lib/cString.ml index e9006860f..0c2ed2e7c 100644 --- a/lib/cString.ml +++ b/lib/cString.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/cString.mli b/lib/cString.mli index 4fa9e1e93..5292b34d0 100644 --- a/lib/cString.mli +++ b/lib/cString.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/cThread.ml b/lib/cThread.ml index 9cbdf5a9e..4f60a6974 100644 --- a/lib/cThread.ml +++ b/lib/cThread.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/cThread.mli b/lib/cThread.mli index 8b110f3f3..7302dfb55 100644 --- a/lib/cThread.mli +++ b/lib/cThread.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/cUnix.ml b/lib/cUnix.ml index 4a1fc7621..cb436511f 100644 --- a/lib/cUnix.ml +++ b/lib/cUnix.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/cUnix.mli b/lib/cUnix.mli index 2d0d202d7..f03719c3d 100644 --- a/lib/cUnix.mli +++ b/lib/cUnix.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/canary.ml b/lib/canary.ml index 23d7bd216..c01bc1587 100644 --- a/lib/canary.ml +++ b/lib/canary.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/canary.mli b/lib/canary.mli index c0ba86a79..21949e735 100644 --- a/lib/canary.mli +++ b/lib/canary.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/clib.mllib b/lib/clib.mllib index 7ff1d2935..3c1c5da33 100644 --- a/lib/clib.mllib +++ b/lib/clib.mllib @@ -8,6 +8,7 @@ Hashcons CSet CMap Int +Dyn HMap Option Store @@ -18,11 +19,11 @@ Pp_control Flags Control Loc +CList +CString Serialize Deque CObj -CList -CString CArray CStack Util diff --git a/lib/control.ml b/lib/control.ml index 673a75a20..bf0e1b1cd 100644 --- a/lib/control.ml +++ b/lib/control.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/control.mli b/lib/control.mli index 2a496bcac..681df313b 100644 --- a/lib/control.mli +++ b/lib/control.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/deque.ml b/lib/deque.ml index c04d59939..ac89a35b1 100644 --- a/lib/deque.ml +++ b/lib/deque.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/deque.mli b/lib/deque.mli index fd644e3c6..6963f1dba 100644 --- a/lib/deque.mli +++ b/lib/deque.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/dyn.ml b/lib/dyn.ml index 056b68731..676467e46 100644 --- a/lib/dyn.ml +++ b/lib/dyn.ml @@ -1,17 +1,60 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Errors -open Pp +module type TParam = +sig + type 'a t +end +module type S = +sig +type 'a tag +type t = Dyn : 'a tag * 'a -> t + +val create : string -> 'a tag +val eq : 'a tag -> 'b tag -> ('a, 'b) CSig.eq option +val repr : 'a tag -> string + +type any = Any : 'a tag -> any + +val name : string -> any option + +module Map(M : TParam) : +sig + type t + val empty : t + val add : 'a tag -> 'a M.t -> t -> t + val remove : 'a tag -> t -> t + val find : 'a tag -> t -> 'a M.t + val mem : 'a tag -> t -> bool + + type any = Any : 'a tag * 'a M.t -> any + + type map = { map : 'a. 'a tag -> 'a M.t -> 'a M.t } + val map : map -> t -> t + + val iter : (any -> unit) -> t -> unit + val fold : (any -> 'r -> 'r) -> t -> 'r -> 'r + +end + +val dump : unit -> (int * string) list +end + +module Make(M : CSig.EmptyS) = +struct (* Dynamics, programmed with DANGER !!! *) -type t = int * Obj.t +type 'a tag = int + +type t = Dyn : 'a tag * 'a -> t + +type any = Any : 'a tag -> any let dyntab = ref (Int.Map.empty : string Int.Map.t) (** Instead of working with tags as strings, which are costly, we use their @@ -24,27 +67,44 @@ let create (s : string) = let () = if Int.Map.mem hash !dyntab then let old = Int.Map.find hash !dyntab in - let msg = str "Dynamic tag collision: " ++ str s ++ str " vs. " ++ str old in - anomaly ~label:"Dyn.create" msg + let () = Printf.eprintf "Dynamic tag collision: %s vs. %s\n%!" s old in + assert false in let () = dyntab := Int.Map.add hash s !dyntab in - let infun v = (hash, Obj.repr v) in - let outfun (nh, rv) = - if Int.equal hash nh then Obj.magic rv - else - anomaly (str "dyn_out: expected " ++ str s) - in - (infun, outfun) + hash -let has_tag (s, _) tag = - let hash = Hashtbl.hash (tag : string) in - Int.equal s hash +let eq : 'a 'b. 'a tag -> 'b tag -> ('a, 'b) CSig.eq option = + fun h1 h2 -> if Int.equal h1 h2 then Some (Obj.magic CSig.Refl) else None -let tag (s,_) = +let repr s = try Int.Map.find s !dyntab with Not_found -> - anomaly (str "Unknown dynamic tag " ++ int s) + let () = Printf.eprintf "Unknown dynamic tag %i\n%!" s in + assert false -let pointer_equal (t1,o1) (t2,o2) = t1 = t2 && o1 == o2 +let name s = + let hash = Hashtbl.hash s in + if Int.Map.mem hash !dyntab then Some (Any hash) else None let dump () = Int.Map.bindings !dyntab + +module Map(M : TParam) = +struct +type t = Obj.t M.t Int.Map.t +let cast : 'a M.t -> 'b M.t = Obj.magic +let empty = Int.Map.empty +let add tag v m = Int.Map.add tag (cast v) m +let remove tag m = Int.Map.remove tag m +let find tag m = cast (Int.Map.find tag m) +let mem = Int.Map.mem + +type any = Any : 'a tag * 'a M.t -> any + +type map = { map : 'a. 'a tag -> 'a M.t -> 'a M.t } +let map f m = Int.Map.mapi f.map m + +let iter f m = Int.Map.iter (fun k v -> f (Any (k, v))) m +let fold f m accu = Int.Map.fold (fun k v accu -> f (Any (k, v)) accu) m accu +end + +end diff --git a/lib/dyn.mli b/lib/dyn.mli index cac912aca..c94fa764b 100644 --- a/lib/dyn.mli +++ b/lib/dyn.mli @@ -1,17 +1,52 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) (** Dynamics. Use with extreme care. Not for kids. *) +module type TParam = +sig + type 'a t +end -type t +module type S = +sig +type 'a tag +type t = Dyn : 'a tag * 'a -> t + +val create : string -> 'a tag +val eq : 'a tag -> 'b tag -> ('a, 'b) CSig.eq option +val repr : 'a tag -> string + +type any = Any : 'a tag -> any + +val name : string -> any option + +module Map(M : TParam) : +sig + type t + val empty : t + val add : 'a tag -> 'a M.t -> t -> t + val remove : 'a tag -> t -> t + val find : 'a tag -> t -> 'a M.t + val mem : 'a tag -> t -> bool + + type any = Any : 'a tag * 'a M.t -> any + + type map = { map : 'a. 'a tag -> 'a M.t -> 'a M.t } + val map : map -> t -> t + + val iter : (any -> unit) -> t -> unit + val fold : (any -> 'r -> 'r) -> t -> 'r -> 'r + +end -val create : string -> ('a -> t) * (t -> 'a) -val tag : t -> string -val has_tag : t -> string -> bool -val pointer_equal : t -> t -> bool val dump : unit -> (int * string) list + +end + +(** FIXME: use OCaml 4.02 generative functors when available *) +module Make(M : CSig.EmptyS) : S diff --git a/lib/envars.ml b/lib/envars.ml index bafe2401b..89ce52831 100644 --- a/lib/envars.ml +++ b/lib/envars.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -39,6 +39,8 @@ let path_to_list p = let user_path () = path_to_list (Sys.getenv "PATH") (* may raise Not_found *) +(* Finding a name in path using the equality provided by the file system *) +(* whether it is case-sensitive or case-insensitive *) let rec which l f = match l with | [] -> @@ -99,7 +101,8 @@ let _ = (** [check_file_else ~dir ~file oth] checks if [file] exists in the installation directory [dir] given relatively to [coqroot]. If this Coq is only locally built, then [file] must be in [coqroot]. - If the check fails, then [oth ()] is evaluated. *) + If the check fails, then [oth ()] is evaluated. + Using file system equality seems well enough for this heuristic *) let check_file_else ~dir ~file oth = let path = if Coq_config.local then coqroot else coqroot / dir in if Sys.file_exists (path / file) then path else oth () diff --git a/lib/envars.mli b/lib/envars.mli index 7c20c035a..90a42859b 100644 --- a/lib/envars.mli +++ b/lib/envars.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/explore.ml b/lib/explore.ml index 3d57fc082..587db1156 100644 --- a/lib/explore.ml +++ b/lib/explore.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/explore.mli b/lib/explore.mli index f3679188c..2b273e12b 100644 --- a/lib/explore.mli +++ b/lib/explore.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/feedback.ml b/lib/feedback.ml index 1726da2fd..1a90685de 100644 --- a/lib/feedback.ml +++ b/lib/feedback.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/feedback.mli b/lib/feedback.mli index 38c867f5b..0d8e20230 100644 --- a/lib/feedback.mli +++ b/lib/feedback.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/flags.ml b/lib/flags.ml index 9a0d4b5ec..c1ec9738c 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -83,6 +83,8 @@ let profile = false let print_emacs = ref false let coqtop_ui = ref false +let xml_export = ref false + let ide_slave = ref false let ideslave_coqtop_flags = ref None @@ -101,18 +103,20 @@ let we_are_parsing = ref false (* Current means no particular compatibility consideration. For correct comparisons, this constructor should remain the last one. *) -type compat_version = V8_2 | V8_3 | V8_4 | Current +type compat_version = V8_2 | V8_3 | V8_4 | V8_5 | Current let compat_version = ref Current let version_strictly_greater v = match !compat_version, v with -| V8_2, (V8_2 | V8_3 | V8_4 | Current) -> false -| V8_3, (V8_3 | V8_4 | Current) -> false -| V8_4, (V8_4 | Current) -> false +| V8_2, (V8_2 | V8_3 | V8_4 | V8_5 | Current) -> false +| V8_3, (V8_3 | V8_4 | V8_5 | Current) -> false +| V8_4, (V8_4 | V8_5 | Current) -> false +| V8_5, (V8_5 | Current) -> false | Current, Current -> false | V8_3, V8_2 -> true | V8_4, (V8_2 | V8_3) -> true -| Current, (V8_2 | V8_3 | V8_4) -> true +| V8_5, (V8_2 | V8_3 | V8_4) -> true +| Current, (V8_2 | V8_3 | V8_4 | V8_5) -> true let version_less_or_equal v = not (version_strictly_greater v) @@ -120,6 +124,7 @@ let pr_version = function | V8_2 -> "8.2" | V8_3 -> "8.3" | V8_4 -> "8.4" + | V8_5 -> "8.5" | Current -> "current" (* Translate *) diff --git a/lib/flags.mli b/lib/flags.mli index 29a0bbef0..24780f0dc 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -44,6 +44,8 @@ val profile : bool val print_emacs : bool ref val coqtop_ui : bool ref +val xml_export : bool ref + val ide_slave : bool ref val ideslave_coqtop_flags : string option ref @@ -55,7 +57,7 @@ val raw_print : bool ref val record_print : bool ref val univ_print : bool ref -type compat_version = V8_2 | V8_3 | V8_4 | Current +type compat_version = V8_2 | V8_3 | V8_4 | V8_5 | Current val compat_version : compat_version ref val version_strictly_greater : compat_version -> bool val version_less_or_equal : compat_version -> bool @@ -88,6 +90,7 @@ val is_universe_polymorphism : unit -> bool val make_polymorphic_flag : bool -> unit val use_polymorphic_flag : unit -> bool +val warn : bool ref val make_warn : bool -> unit val if_warn : ('a -> unit) -> 'a -> unit diff --git a/lib/future.ml b/lib/future.ml index 78a158264..9cdc1c20e 100644 --- a/lib/future.ml +++ b/lib/future.ml @@ -1,14 +1,15 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) (* To deal with side effects we have to save/restore the system state *) -let freeze = ref (fun () -> assert false : unit -> Dyn.t) -let unfreeze = ref (fun _ -> () : Dyn.t -> unit) +type freeze +let freeze = ref (fun () -> assert false : unit -> freeze) +let unfreeze = ref (fun _ -> () : freeze -> unit) let set_freeze f g = freeze := f; unfreeze := g let not_ready_msg = ref (fun name -> @@ -58,11 +59,11 @@ type 'a assignement = [ `Val of 'a | `Exn of Exninfo.iexn | `Comp of 'a computat and 'a comp = | Delegated of (unit -> unit) | Closure of (unit -> 'a) - | Val of 'a * Dyn.t option + | Val of 'a * freeze option | Exn of Exninfo.iexn (* Invariant: this exception is always "fixed" as in fix_exn *) and 'a comput = - | Ongoing of string * (UUID.t * fix_exn * 'a comp ref) Ephemeron.key + | Ongoing of string * (UUID.t * fix_exn * 'a comp ref) CEphemeron.key | Finished of 'a and 'a computation = 'a comput ref @@ -70,13 +71,13 @@ and 'a computation = 'a comput ref let unnamed = "unnamed" let create ?(name=unnamed) ?(uuid=UUID.fresh ()) f x = - ref (Ongoing (name, Ephemeron.create (uuid, f, Pervasives.ref x))) + ref (Ongoing (name, CEphemeron.create (uuid, f, Pervasives.ref x))) let get x = match !x with | Finished v -> unnamed, UUID.invalid, id, ref (Val (v,None)) | Ongoing (name, x) -> - try let uuid, fix, c = Ephemeron.get x in name, uuid, fix, c - with Ephemeron.InvalidKey -> + try let uuid, fix, c = CEphemeron.get x in name, uuid, fix, c + with CEphemeron.InvalidKey -> name, UUID.invalid, id, ref (Exn (NotHere name, Exninfo.null)) type 'a value = [ `Val of 'a | `Exn of Exninfo.iexn ] diff --git a/lib/future.mli b/lib/future.mli index adc15e49c..114c59176 100644 --- a/lib/future.mli +++ b/lib/future.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -157,10 +157,11 @@ val transactify : ('a -> 'b) -> 'a -> 'b (** Debug: print a computation given an inner printing function. *) val print : ('a -> Pp.std_ppcmds) -> 'a computation -> Pp.std_ppcmds +type freeze (* These functions are needed to get rid of side effects. 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 set_freeze : (unit -> freeze) -> (freeze -> unit) -> unit val customize_not_ready_msg : (string -> Pp.std_ppcmds) -> unit val customize_not_here_msg : (string -> Pp.std_ppcmds) -> unit diff --git a/lib/genarg.ml b/lib/genarg.ml index 42458ecb3..5d5b29c99 100644 --- a/lib/genarg.ml +++ b/lib/genarg.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -9,167 +9,226 @@ open Pp open Util -type argument_type = - (* Basic types *) - | IntOrVarArgType - | IdentArgType - | VarArgType - (* Specific types *) - | GenArgType - | ConstrArgType - | ConstrMayEvalArgType - | QuantHypArgType - | OpenConstrArgType - | ConstrWithBindingsArgType - | BindingsArgType - | RedExprArgType - | ListArgType of argument_type - | OptArgType of argument_type - | PairArgType of argument_type * argument_type - | ExtraArgType of string - -let rec argument_type_eq arg1 arg2 = match arg1, arg2 with -| IntOrVarArgType, IntOrVarArgType -> true -| IdentArgType, IdentArgType -> true -| VarArgType, VarArgType -> true -| GenArgType, GenArgType -> true -| ConstrArgType, ConstrArgType -> true -| ConstrMayEvalArgType, ConstrMayEvalArgType -> true -| QuantHypArgType, QuantHypArgType -> true -| OpenConstrArgType, OpenConstrArgType -> true -| ConstrWithBindingsArgType, ConstrWithBindingsArgType -> true -| BindingsArgType, BindingsArgType -> true -| RedExprArgType, RedExprArgType -> true -| ListArgType arg1, ListArgType arg2 -> argument_type_eq arg1 arg2 -| OptArgType arg1, OptArgType arg2 -> argument_type_eq arg1 arg2 -| PairArgType (arg1l, arg1r), PairArgType (arg2l, arg2r) -> - argument_type_eq arg1l arg2l && argument_type_eq arg1r arg2r -| ExtraArgType s1, ExtraArgType s2 -> CString.equal s1 s2 -| _ -> false - -let rec pr_argument_type = function -| IntOrVarArgType -> str "int_or_var" -| IdentArgType -> str "ident" -| VarArgType -> str "var" -| GenArgType -> str "genarg" -| ConstrArgType -> str "constr" -| ConstrMayEvalArgType -> str "constr_may_eval" -| QuantHypArgType -> str "qhyp" -| OpenConstrArgType -> str "open_constr" -| ConstrWithBindingsArgType -> str "constr_with_bindings" -| BindingsArgType -> str "bindings" -| RedExprArgType -> str "redexp" -| ListArgType t -> pr_argument_type t ++ spc () ++ str "list" -| OptArgType t -> pr_argument_type t ++ spc () ++ str "opt" -| PairArgType (t1, t2) -> - str "("++ pr_argument_type t1 ++ spc () ++ - str "*" ++ spc () ++ pr_argument_type t2 ++ str ")" -| ExtraArgType s -> str s - -type ('raw, 'glob, 'top) genarg_type = argument_type +module ValT = Dyn.Make(struct end) +module ArgT = +struct + module DYN = Dyn.Make(struct end) + module Map = DYN.Map + type ('a, 'b, 'c) tag = ('a * 'b * 'c) DYN.tag + type any = Any : ('a, 'b, 'c) tag -> any + let eq = DYN.eq + let repr = DYN.repr + let create = DYN.create + let name s = match DYN.name s with + | None -> None + | Some (DYN.Any t) -> + Some (Any (Obj.magic t)) (** All created tags are made of triples *) +end -type 'a uniform_genarg_type = ('a, 'a, 'a) genarg_type -(** Alias for concision *) +module Val = +struct -(* Dynamics but tagged by a type expression *) + type 'a typ = 'a ValT.tag + + type _ tag = + | Base : 'a typ -> 'a tag + | List : 'a tag -> 'a list tag + | Opt : 'a tag -> 'a option tag + | Pair : 'a tag * 'b tag -> ('a * 'b) tag + + type t = Dyn : 'a tag * 'a -> t + + let rec eq : type a b. a tag -> b tag -> (a, b) CSig.eq option = + fun t1 t2 -> match t1, t2 with + | Base t1, Base t2 -> ValT.eq t1 t2 + | List t1, List t2 -> + begin match eq t1 t2 with + | None -> None + | Some Refl -> Some Refl + end + | Opt t1, Opt t2 -> + begin match eq t1 t2 with + | None -> None + | Some Refl -> Some Refl + end + | Pair (t1, u1), Pair (t2, u2) -> + begin match eq t1 t2 with + | None -> None + | Some Refl -> + match eq u1 u2 with + | None -> None + | Some Refl -> Some Refl + end + | _ -> None + + let rec repr : type a. a tag -> std_ppcmds = function + | Base t -> str (ValT.repr t) + | List t -> repr t ++ spc () ++ str "list" + | Opt t -> repr t ++ spc () ++ str "option" + | Pair (t1, t2) -> str "(" ++ repr t1 ++ str " * " ++ repr t2 ++ str ")" -type rlevel -type glevel -type tlevel +end -type 'a generic_argument = argument_type * Obj.t -type raw_generic_argument = rlevel generic_argument -type glob_generic_argument = glevel generic_argument -type typed_generic_argument = tlevel generic_argument +type (_, _, _) genarg_type = +| ExtraArg : ('a, 'b, 'c) ArgT.tag -> ('a, 'b, 'c) genarg_type +| ListArg : ('a, 'b, 'c) genarg_type -> ('a list, 'b list, 'c list) genarg_type +| OptArg : ('a, 'b, 'c) genarg_type -> ('a option, 'b option, 'c option) genarg_type +| PairArg : ('a1, 'b1, 'c1) genarg_type * ('a2, 'b2, 'c2) genarg_type -> + ('a1 * 'a2, 'b1 * 'b2, 'c1 * 'c2) genarg_type + +type argument_type = ArgumentType : ('a, 'b, 'c) genarg_type -> argument_type + +let rec genarg_type_eq : type a1 a2 b1 b2 c1 c2. + (a1, b1, c1) genarg_type -> (a2, b2, c2) genarg_type -> + (a1 * b1 * c1, a2 * b2 * c2) CSig.eq option = +fun t1 t2 -> match t1, t2 with +| ExtraArg t1, ExtraArg t2 -> ArgT.eq t1 t2 +| ListArg t1, ListArg t2 -> + begin match genarg_type_eq t1 t2 with + | None -> None + | Some Refl -> Some Refl + end +| OptArg t1, OptArg t2 -> + begin match genarg_type_eq t1 t2 with + | None -> None + | Some Refl -> Some Refl + end +| PairArg (t1, u1), PairArg (t2, u2) -> + begin match genarg_type_eq t1 t2 with + | None -> None + | Some Refl -> + match genarg_type_eq u1 u2 with + | None -> None + | Some Refl -> Some Refl + end +| _ -> None + +let rec pr_genarg_type : type a b c. (a, b, c) genarg_type -> std_ppcmds = function +| ListArg t -> pr_genarg_type t ++ spc () ++ str "list" +| OptArg t -> pr_genarg_type t ++ spc () ++ str "opt" +| PairArg (t1, t2) -> + str "("++ pr_genarg_type t1 ++ spc () ++ + str "*" ++ spc () ++ pr_genarg_type t2 ++ str ")" +| ExtraArg s -> str (ArgT.repr s) + +let argument_type_eq arg1 arg2 = match arg1, arg2 with +| ArgumentType t1, ArgumentType t2 -> + match genarg_type_eq t1 t2 with + | None -> false + | Some Refl -> true + +let pr_argument_type (ArgumentType t) = pr_genarg_type t -let rawwit t = t -let glbwit t = t -let topwit t = t +type 'a uniform_genarg_type = ('a, 'a, 'a) genarg_type +(** Alias for concision *) -let wit_list t = ListArgType t +(* Dynamics but tagged by a type expression *) -let wit_opt t = OptArgType t +type rlevel = [ `rlevel ] +type glevel = [ `glevel ] +type tlevel = [ `tlevel ] -let wit_pair t1 t2 = PairArgType (t1,t2) +type (_, _) abstract_argument_type = +| Rawwit : ('a, 'b, 'c) genarg_type -> ('a, rlevel) abstract_argument_type +| Glbwit : ('a, 'b, 'c) genarg_type -> ('b, glevel) abstract_argument_type +| Topwit : ('a, 'b, 'c) genarg_type -> ('c, tlevel) abstract_argument_type -let in_gen t o = (t,Obj.repr o) -let out_gen t (t',o) = if argument_type_eq t t' then Obj.magic o else failwith "out_gen" -let genarg_tag (s,_) = s +type 'l generic_argument = GenArg : ('a, 'l) abstract_argument_type * 'a -> 'l generic_argument -let has_type (t, v) u = argument_type_eq t u +type raw_generic_argument = rlevel generic_argument +type glob_generic_argument = glevel generic_argument +type typed_generic_argument = tlevel generic_argument -let unquote x = x +let rawwit t = Rawwit t +let glbwit t = Glbwit t +let topwit t = Topwit t + +let wit_list t = ListArg t + +let wit_opt t = OptArg t + +let wit_pair t1 t2 = PairArg (t1, t2) + +let in_gen t o = GenArg (t, o) + +let abstract_argument_type_eq : + type a b l. (a, l) abstract_argument_type -> (b, l) abstract_argument_type -> (a, b) CSig.eq option = + fun t1 t2 -> match t1, t2 with + | Rawwit t1, Rawwit t2 -> + begin match genarg_type_eq t1 t2 with + | None -> None + | Some Refl -> Some Refl + end + | Glbwit t1, Glbwit t2 -> + begin match genarg_type_eq t1 t2 with + | None -> None + | Some Refl -> Some Refl + end + | Topwit t1, Topwit t2 -> + begin match genarg_type_eq t1 t2 with + | None -> None + | Some Refl -> Some Refl + end + +let out_gen (type a) (type l) (t : (a, l) abstract_argument_type) (o : l generic_argument) : a = + let GenArg (t', v) = o in + match abstract_argument_type_eq t t' with + | None -> failwith "out_gen" + | Some Refl -> v + +let has_type (GenArg (t, v)) u = match abstract_argument_type_eq t u with +| None -> false +| Some _ -> true + +let unquote : type l. (_, l) abstract_argument_type -> _ = function +| Rawwit t -> ArgumentType t +| Glbwit t -> ArgumentType t +| Topwit t -> ArgumentType t + +let genarg_tag (GenArg (t, _)) = unquote t -type ('a,'b) abstract_argument_type = argument_type type 'a raw_abstract_argument_type = ('a,rlevel) abstract_argument_type type 'a glob_abstract_argument_type = ('a,glevel) abstract_argument_type type 'a typed_abstract_argument_type = ('a,tlevel) abstract_argument_type -type ('a, 'b, 'c, 'l) cast = Obj.t - -let raw = Obj.obj -let glb = Obj.obj -let top = Obj.obj - -type ('r, 'l) unpacker = - { unpacker : 'a 'b 'c. ('a, 'b, 'c) genarg_type -> ('a, 'b, 'c, 'l) cast -> 'r } - -let unpack pack (t, obj) = pack.unpacker t (Obj.obj obj) - -(** Type transformers *) - -type ('r, 'l) list_unpacker = - { list_unpacker : 'a 'b 'c. ('a, 'b, 'c) genarg_type -> - ('a list, 'b list, 'c list, 'l) cast -> 'r } - -let list_unpack pack (t, obj) = match t with -| ListArgType t -> pack.list_unpacker t (Obj.obj obj) -| _ -> failwith "out_gen" - -type ('r, 'l) opt_unpacker = - { opt_unpacker : 'a 'b 'c. ('a, 'b, 'c) genarg_type -> - ('a option, 'b option, 'c option, 'l) cast -> 'r } - -let opt_unpack pack (t, obj) = match t with -| OptArgType t -> pack.opt_unpacker t (Obj.obj obj) -| _ -> failwith "out_gen" +(** Creating args *) -type ('r, 'l) pair_unpacker = - { pair_unpacker : 'a1 'a2 'b1 'b2 'c1 'c2. - ('a1, 'b1, 'c1) genarg_type -> ('a2, 'b2, 'c2) genarg_type -> - (('a1 * 'a2), ('b1 * 'b2), ('c1 * 'c2), 'l) cast -> 'r } +module type Param = sig type ('raw, 'glb, 'top) t end +module ArgMap(M : Param) = +struct + type _ pack = Pack : ('raw, 'glb, 'top) M.t -> ('raw * 'glb * 'top) pack + include ArgT.Map(struct type 'a t = 'a pack end) +end -let pair_unpack pack (t, obj) = match t with -| PairArgType (t1, t2) -> pack.pair_unpacker t1 t2 (Obj.obj obj) -| _ -> failwith "out_gen" +type ('raw, 'glb, 'top) load = { + dyn : 'top Val.tag; +} -(** Creating args *) +module LoadMap = ArgMap(struct type ('r, 'g, 't) t = ('r, 'g, 't) load end) -let (arg0_map : Obj.t option String.Map.t ref) = ref String.Map.empty +let arg0_map = ref LoadMap.empty -let create_arg opt name = - if String.Map.mem name !arg0_map then +let create_arg ?dyn name = + match ArgT.name name with + | Some _ -> Errors.anomaly (str "generic argument already declared: " ++ str name) - else - let () = arg0_map := String.Map.add name (Obj.magic opt) !arg0_map in - ExtraArgType name + | None -> + let dyn = match dyn with None -> Val.Base (ValT.create name) | Some dyn -> dyn in + let obj = LoadMap.Pack { dyn; } in + let name = ArgT.create name in + let () = arg0_map := LoadMap.add name obj !arg0_map in + ExtraArg name let make0 = create_arg -let default_empty_value t = - let rec aux = function - | ListArgType _ -> Some (Obj.repr []) - | OptArgType _ -> Some (Obj.repr None) - | PairArgType(t1, t2) -> - (match aux t1, aux t2 with - | Some v1, Some v2 -> Some (Obj.repr (v1, v2)) - | _ -> None) - | ExtraArgType s -> - String.Map.find s !arg0_map - | _ -> None in - match aux t with - | Some v -> Some (Obj.obj v) - | None -> None +let rec val_tag : type a b c. (a, b, c) genarg_type -> c Val.tag = function +| ListArg t -> Val.List (val_tag t) +| OptArg t -> Val.Opt (val_tag t) +| PairArg (t1, t2) -> Val.Pair (val_tag t1, val_tag t2) +| ExtraArg s -> + match LoadMap.find s !arg0_map with LoadMap.Pack obj -> obj.dyn + +let val_tag = function Topwit t -> val_tag t (** Registering genarg-manipulating functions *) @@ -182,54 +241,31 @@ end module Register (M : GenObj) = struct - let arg0_map = - ref (String.Map.empty : (Obj.t, Obj.t, Obj.t) M.obj String.Map.t) + module GenMap = ArgMap(struct type ('r, 'g, 't) t = ('r, 'g, 't) M.obj end) + let arg0_map = ref GenMap.empty let register0 arg f = match arg with - | ExtraArgType s -> - if String.Map.mem s !arg0_map then - let msg = str M.name ++ str " function already registered: " ++ str s in + | ExtraArg s -> + if GenMap.mem s !arg0_map then + let msg = str M.name ++ str " function already registered: " ++ str (ArgT.repr s) in Errors.anomaly msg else - arg0_map := String.Map.add s (Obj.magic f) !arg0_map + arg0_map := GenMap.add s (GenMap.Pack f) !arg0_map | _ -> assert false let get_obj0 name = - try String.Map.find name !arg0_map + try + let GenMap.Pack obj = GenMap.find name !arg0_map in obj with Not_found -> - match M.default (ExtraArgType name) with + match M.default (ExtraArg name) with | None -> - Errors.anomaly (str M.name ++ str " function not found: " ++ str name) + Errors.anomaly (str M.name ++ str " function not found: " ++ str (ArgT.repr name)) | Some obj -> obj (** For now, the following function is quite dummy and should only be applied to an extra argument type, otherwise, it will badly fail. *) let obj t = match t with - | ExtraArgType s -> Obj.magic (get_obj0 s) + | ExtraArg s -> get_obj0 s | _ -> assert false end - -(** Hackish part *) - -let arg0_names = ref (String.Map.empty : string String.Map.t) -(** We use this table to associate a name to a given witness, to use it with - the extension mechanism. This is REALLY ad-hoc, but I do not know how to - do so nicely either. *) - -let register_name0 t name = match t with -| ExtraArgType s -> - let () = assert (not (String.Map.mem s !arg0_names)) in - arg0_names := String.Map.add s name !arg0_names -| _ -> failwith "register_name0" - -let get_name0 name = - String.Map.find name !arg0_names - -module Unsafe = -struct - -let inj tpe x = (tpe, x) -let prj (_, x) = x - -end diff --git a/lib/genarg.mli b/lib/genarg.mli index a269f9277..6cc7893dc 100644 --- a/lib/genarg.mli +++ b/lib/genarg.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -68,18 +68,53 @@ ExtraArgType of string '_a '_b (** {5 Generic types} *) -type ('raw, 'glob, 'top) genarg_type +module ArgT : +sig + type ('a, 'b, 'c) tag + val eq : ('a1, 'b1, 'c1) tag -> ('a2, 'b2, 'c2) tag -> ('a1 * 'b1 * 'c1, 'a2 * 'b2 * 'c2) CSig.eq option + val repr : ('a, 'b, 'c) tag -> string + type any = Any : ('a, 'b, 'c) tag -> any + val name : string -> any option +end + +type (_, _, _) genarg_type = +| ExtraArg : ('a, 'b, 'c) ArgT.tag -> ('a, 'b, 'c) genarg_type +| ListArg : ('a, 'b, 'c) genarg_type -> ('a list, 'b list, 'c list) genarg_type +| OptArg : ('a, 'b, 'c) genarg_type -> ('a option, 'b option, 'c option) genarg_type +| PairArg : ('a1, 'b1, 'c1) genarg_type * ('a2, 'b2, 'c2) genarg_type -> + ('a1 * 'a2, 'b1 * 'b2, 'c1 * 'c2) genarg_type (** Generic types. ['raw] is the OCaml lowest level, ['glob] is the globalized one, and ['top] the internalized one. *) +module Val : +sig + type 'a typ + + type _ tag = + | Base : 'a typ -> 'a tag + | List : 'a tag -> 'a list tag + | Opt : 'a tag -> 'a option tag + | Pair : 'a tag * 'b tag -> ('a * 'b) tag + + type t = Dyn : 'a tag * 'a -> t + + val eq : 'a tag -> 'b tag -> ('a, 'b) CSig.eq option + val repr: 'a tag -> Pp.std_ppcmds + +end +(** Dynamic types for toplevel values. While the generic types permit to relate + objects at various levels of interpretation, toplevel values are wearing + their own type regardless of where they came from. This allows to use the + same runtime representation for several generic types. *) + type 'a uniform_genarg_type = ('a, 'a, 'a) genarg_type (** Alias for concision when the three types agree. *) -val make0 : 'raw option -> string -> ('raw, 'glob, 'top) genarg_type +val make0 : ?dyn:'top Val.tag -> string -> ('raw, 'glob, 'top) genarg_type (** Create a new generic type of argument: force to associate unique ML types at each of the three levels. *) -val create_arg : 'raw option -> string -> ('raw, 'glob, 'top) genarg_type +val create_arg : ?dyn:'top Val.tag -> string -> ('raw, 'glob, 'top) genarg_type (** Alias for [make0]. *) (** {5 Specialized types} *) @@ -91,11 +126,14 @@ val create_arg : 'raw option -> string -> ('raw, 'glob, 'top) genarg_type out_gen is monomorphic over 'a, hence type-safe *) -type rlevel -type glevel -type tlevel +type rlevel = [ `rlevel ] +type glevel = [ `glevel ] +type tlevel = [ `tlevel ] -type ('a, 'co) abstract_argument_type +type (_, _) abstract_argument_type = +| Rawwit : ('a, 'b, 'c) genarg_type -> ('a, rlevel) abstract_argument_type +| Glbwit : ('a, 'b, 'c) genarg_type -> ('b, glevel) abstract_argument_type +| Topwit : ('a, 'b, 'c) genarg_type -> ('c, tlevel) abstract_argument_type (** Type at level ['co] represented by an OCaml value of type ['a]. *) type 'a raw_abstract_argument_type = ('a, rlevel) abstract_argument_type @@ -120,7 +158,7 @@ val topwit : ('a, 'b, 'c) genarg_type -> ('c, tlevel) abstract_argument_type (** {5 Generic arguments} *) -type 'a generic_argument +type 'l generic_argument = GenArg : ('a, 'l) abstract_argument_type * 'a -> 'l generic_argument (** A inhabitant of ['level generic_argument] is a inhabitant of some type at level ['level], together with the representation of this type. *) @@ -141,66 +179,26 @@ val has_type : 'co generic_argument -> ('a, 'co) abstract_argument_type -> bool (** [has_type v t] tells whether [v] has type [t]. If true, it ensures that [out_gen t v] will not raise a dynamic type exception. *) -(** {6 Destructors} *) - -type ('a, 'b, 'c, 'l) cast - -val raw : ('a, 'b, 'c, rlevel) cast -> 'a -val glb : ('a, 'b, 'c, glevel) cast -> 'b -val top : ('a, 'b, 'c, tlevel) cast -> 'c - -type ('r, 'l) unpacker = - { unpacker : 'a 'b 'c. ('a, 'b, 'c) genarg_type -> ('a, 'b, 'c, 'l) cast -> 'r } - -val unpack : ('r, 'l) unpacker -> 'l generic_argument -> 'r -(** Existential-type destructors. *) - -(** {6 Manipulation of generic arguments} - -Those functions fail if they are applied to an argument which has not the right -dynamic type. *) - -type ('r, 'l) list_unpacker = - { list_unpacker : 'a 'b 'c. ('a, 'b, 'c) genarg_type -> - ('a list, 'b list, 'c list, 'l) cast -> 'r } +(** {6 Dynamic toplevel values} *) -val list_unpack : ('r, 'l) list_unpacker -> 'l generic_argument -> 'r - -type ('r, 'l) opt_unpacker = - { opt_unpacker : 'a 'b 'c. ('a, 'b, 'c) genarg_type -> - ('a option, 'b option, 'c option, 'l) cast -> 'r } - -val opt_unpack : ('r, 'l) opt_unpacker -> 'l generic_argument -> 'r - -type ('r, 'l) pair_unpacker = - { pair_unpacker : 'a1 'a2 'b1 'b2 'c1 'c2. - ('a1, 'b1, 'c1) genarg_type -> ('a2, 'b2, 'c2) genarg_type -> - (('a1 * 'a2), ('b1 * 'b2), ('c1 * 'c2), 'l) cast -> 'r } - -val pair_unpack : ('r, 'l) pair_unpacker -> 'l generic_argument -> 'r +val val_tag : 'a typed_abstract_argument_type -> 'a Val.tag +(** Retrieve the dynamic type associated to a toplevel genarg. Only works for + ground generic arguments. *) (** {6 Type reification} *) -type argument_type = - (** Basic types *) - | IntOrVarArgType - | IdentArgType - | VarArgType - (** Specific types *) - | GenArgType - | ConstrArgType - | ConstrMayEvalArgType - | QuantHypArgType - | OpenConstrArgType - | ConstrWithBindingsArgType - | BindingsArgType - | RedExprArgType - | ListArgType of argument_type - | OptArgType of argument_type - | PairArgType of argument_type * argument_type - | ExtraArgType of string +type argument_type = ArgumentType : ('a, 'b, 'c) genarg_type -> argument_type + +(** {6 Equalities} *) val argument_type_eq : argument_type -> argument_type -> bool +val genarg_type_eq : + ('a1, 'b1, 'c1) genarg_type -> + ('a2, 'b2, 'c2) genarg_type -> + ('a1 * 'b1 * 'c1, 'a2 * 'b2 * 'c2) CSig.eq option +val abstract_argument_type_eq : + ('a, 'l) abstract_argument_type -> ('b, 'l) abstract_argument_type -> + ('a, 'b) CSig.eq option val pr_argument_type : argument_type -> Pp.std_ppcmds (** Print a human-readable representation for a given type. *) @@ -244,35 +242,3 @@ val wit_list : ('a, 'b, 'c) genarg_type -> ('a list, 'b list, 'c list) genarg_ty val wit_opt : ('a, 'b, 'c) genarg_type -> ('a option, 'b option, 'c option) genarg_type val wit_pair : ('a1, 'b1, 'c1) genarg_type -> ('a2, 'b2, 'c2) genarg_type -> ('a1 * 'a2, 'b1 * 'b2, 'c1 * 'c2) genarg_type - -(** {5 Magic used by the parser} *) - -val default_empty_value : ('raw, 'glb, 'top) genarg_type -> 'raw option - -val register_name0 : ('a, 'b, 'c) genarg_type -> string -> unit -(** Used by the extension to give a name to types. The string should be the - absolute path of the argument witness, e.g. - [register_name0 wit_toto "MyArg.wit_toto"]. *) - -val get_name0 : string -> string -(** Return the absolute path of a given witness. *) - -(** {5 Unsafe loophole} *) - -module Unsafe : -sig - -(** Unsafe magic functions. Not for kids. This is provided here as a loophole to - escape this module. Do NOT use outside of the dedicated areas. NOT. EVER. *) - -val inj : argument_type -> Obj.t -> 'lev generic_argument -(** Injects an object as generic argument. !!!BEWARE!!! only do this as - [inj tpe x] where: - - 1. [tpe] is the reification of a [('a, 'b, 'c) genarg_type]; - 2. [x] has type ['a], ['b] or ['c] according to the return level ['lev]. *) - -val prj : 'lev generic_argument -> Obj.t -(** Recover the contents of a generic argument. *) - -end diff --git a/lib/hMap.ml b/lib/hMap.ml index 8e900cd58..778c366fd 100644 --- a/lib/hMap.ml +++ b/lib/hMap.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -286,6 +286,8 @@ struct let m = Int.Map.find h s in Map.find k m + let get k s = try find k s with Not_found -> assert false + let split k s = assert false (** Cannot be implemented efficiently *) let map f s = @@ -333,7 +335,6 @@ struct struct module IntM = Int.Map.Monad(M) module ExtM = Map.Monad(M) - open M let fold f s accu = let ff _ m accu = ExtM.fold f m accu in diff --git a/lib/hMap.mli b/lib/hMap.mli index cdf933b29..c4e6a08e1 100644 --- a/lib/hMap.mli +++ b/lib/hMap.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/hashcons.ml b/lib/hashcons.ml index 46ba0b628..4eaacf914 100644 --- a/lib/hashcons.ml +++ b/lib/hashcons.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -15,7 +15,7 @@ * of objects of type t (u usually has the form (t1->t1)*(t2->t2)*...). * [hashcons u x] is a function that hash-cons the sub-structures of x using * the hash-consing functions u provides. - * [equal] is a comparison function. It is allowed to use physical equality + * [eq] is a comparison function. It is allowed to use physical equality * on the sub-terms hash-consed by the hashcons function. * [hash] is the hash function given to the Hashtbl.Make function * @@ -27,7 +27,7 @@ module type HashconsedType = type t type u val hashcons : u -> t -> t - val equal : t -> t -> bool + val eq : t -> t -> bool val hash : t -> int end @@ -53,7 +53,7 @@ module Make (X : HashconsedType) : (S with type t = X.t and type u = X.u) = (* We create the type of hashtables for t, with our comparison fun. * An invariant is that the table never contains two entries equals - * w.r.t (=), although the equality on keys is X.equal. This is + * w.r.t (=), although the equality on keys is X.eq. This is * granted since we hcons the subterms before looking up in the table. *) module Htbl = Hashset.Make(X) @@ -72,7 +72,7 @@ module Make (X : HashconsedType) : (S with type t = X.t and type u = X.u) = end -(* A few usefull wrappers: +(* A few useful wrappers: * takes as argument the function [generate] above and build a function of type * u -> t -> t that creates a fresh table each time it is applied to the * sub-hcons functions. *) @@ -96,20 +96,6 @@ let recursive_hcons h f u = let () = loop := hrec in hrec -(* A set of global hashcons functions *) -let hashcons_resets = ref [] -let init() = List.iter (fun f -> f()) !hashcons_resets - -(* [register_hcons h u] registers the hcons function h, result of the above - * wrappers. It returns another hcons function that always uses the same - * table, which can be reinitialized by init() - *) -let register_hcons h u = - let hf = ref (h u) in - let reset() = hf := h u in - hashcons_resets := reset :: !hashcons_resets; - (fun x -> !hf x) - (* Basic hashcons modules for string and obj. Integers do not need be hashconsed. *) @@ -124,7 +110,7 @@ module Hlist (D:HashedType) = let hashcons (hrec,hdata) = function | x :: l -> hdata x :: hrec l | l -> l - let equal l1 l2 = + let eq l1 l2 = l1 == l2 || match l1, l2 with | [], [] -> true @@ -144,7 +130,7 @@ module Hstring = Make( type t = string type u = unit let hashcons () s =(* incr accesstr;*) s - external equal : string -> string -> bool = "caml_string_equal" "noalloc" + external eq : string -> string -> bool = "caml_string_equal" "noalloc" (** Copy from CString *) let rec hash len s i accu = if i = len then accu @@ -191,21 +177,6 @@ module Hobj = Make( type t = Obj.t type u = (Obj.t -> Obj.t) * unit let hashcons (hrec,_) = hash_obj hrec - let equal = comp_obj + let eq = comp_obj let hash = Hashtbl.hash end) - -(* Hashconsing functions for string and obj. Always use the same - * global tables. The latter can be reinitialized with init() - *) -(* string : string -> string *) -(* obj : Obj.t -> Obj.t *) -let string = register_hcons (simple_hcons Hstring.generate Hstring.hcons) () -let obj = register_hcons (recursive_hcons Hobj.generate Hobj.hcons) () - -(* The unsafe polymorphic hashconsing function *) -let magic_hash (c : 'a) = - init(); - let r = obj (Obj.repr c) in - init(); - (Obj.magic r : 'a) diff --git a/lib/hashcons.mli b/lib/hashcons.mli index 8d0adc3fd..150899cef 100644 --- a/lib/hashcons.mli +++ b/lib/hashcons.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -14,9 +14,9 @@ module type HashconsedType = sig (** {6 Generic hashconsing signature} - Given an equivalence relation [equal], a hashconsing function is a + Given an equivalence relation [eq], a hashconsing function is a function that associates the same canonical element to two elements - related by [equal]. Usually, the element chosen is canonical w.r.t. + related by [eq]. Usually, the element chosen is canonical w.r.t. physical equality [(==)], so as to reduce memory consumption and enhance efficiency of equality tests. @@ -32,15 +32,15 @@ module type HashconsedType = Usually a tuple of functions. *) val hashcons : u -> t -> t (** The actual hashconsing function, using its fist argument to recursively - hashcons substructures. It should be compatible with [equal], that is - [equal x (hashcons f x) = true]. *) - val equal : t -> t -> bool + hashcons substructures. It should be compatible with [eq], that is + [eq x (hashcons f x) = true]. *) + val eq : t -> t -> bool (** A comparison function. It is allowed to use physical equality on the sub-terms hashconsed by the [hashcons] function, but it should be insensible to shallow copy of the compared object. *) val hash : t -> int (** A hash function passed to the underlying hashtable structure. [hash] - should be compatible with [equal], i.e. if [equal x y = true] then + should be compatible with [eq], i.e. if [eq x y = true] then [hash x = hash y]. *) end diff --git a/lib/hashset.ml b/lib/hashset.ml index 1ca6cc641..af33544dc 100644 --- a/lib/hashset.ml +++ b/lib/hashset.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -16,7 +16,7 @@ module type EqType = sig type t - val equal : t -> t -> bool + val eq : t -> t -> bool end type statistics = { @@ -162,7 +162,7 @@ module Make (E : EqType) = t.hashes.(index) <- newhashes; if sz <= t.limit && newsz > t.limit then begin t.oversize <- t.oversize + 1; - for i = 0 to over_limit do test_shrink_bucket t done; + for _i = 0 to over_limit do test_shrink_bucket t done; end; if t.oversize > Array.length t.table / over_limit then resize t end else if Weak.check bucket i then begin @@ -183,7 +183,7 @@ module Make (E : EqType) = if i >= sz then ifnotfound index else if h = hashes.(i) then begin match Weak.get bucket i with - | Some v when E.equal v d -> v + | Some v when E.eq v d -> v | _ -> loop (i + 1) end else loop (i + 1) in diff --git a/lib/hashset.mli b/lib/hashset.mli index a455eec66..733c89621 100644 --- a/lib/hashset.mli +++ b/lib/hashset.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -16,7 +16,7 @@ module type EqType = sig type t - val equal : t -> t -> bool + val eq : t -> t -> bool end type statistics = { diff --git a/lib/heap.ml b/lib/heap.ml index a19bc0d1c..97ccadeba 100644 --- a/lib/heap.ml +++ b/lib/heap.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -62,8 +62,6 @@ module Functional(X : Ordered) = struct let empty = Leaf - let is_empty t = t = Leaf - let rec add x = function | Leaf -> Node (Leaf, x, Leaf) diff --git a/lib/heap.mli b/lib/heap.mli index a69de34ce..0e77a3a06 100644 --- a/lib/heap.mli +++ b/lib/heap.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/hook.ml b/lib/hook.ml index 0aa373c21..a370fe357 100644 --- a/lib/hook.ml +++ b/lib/hook.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/hook.mli b/lib/hook.mli index d10f2c86f..50347f334 100644 --- a/lib/hook.mli +++ b/lib/hook.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/iStream.ml b/lib/iStream.ml index f9351d4bb..26a666e17 100644 --- a/lib/iStream.ml +++ b/lib/iStream.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -14,11 +14,11 @@ type 'a node = ('a,'a t) u and 'a t = 'a node Lazy.t -let empty = Lazy.lazy_from_val Nil +let empty = Lazy.from_val Nil -let cons x s = Lazy.lazy_from_val (Cons (x, s)) +let cons x s = Lazy.from_val (Cons (x, s)) -let thunk = Lazy.lazy_from_fun +let thunk = Lazy.from_fun let rec make_node f s = match f s with | Nil -> Nil diff --git a/lib/iStream.mli b/lib/iStream.mli index 8cb12af46..50f5389ba 100644 --- a/lib/iStream.mli +++ b/lib/iStream.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/int.ml b/lib/int.ml index d99176572..70bd74242 100644 --- a/lib/int.ml +++ b/lib/int.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/int.mli b/lib/int.mli index c910bda6a..93d1be1f7 100644 --- a/lib/int.mli +++ b/lib/int.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/lib.mllib b/lib/lib.mllib index f3f6ad8fc..2be435f6f 100644 --- a/lib/lib.mllib +++ b/lib/lib.mllib @@ -1,6 +1,5 @@ Errors Bigint -Dyn Segmenttree Unicodetable Unicode @@ -15,6 +14,6 @@ Rtree Heap Unionfind Genarg -Ephemeron +CEphemeron Future RemoteCounter diff --git a/lib/loc.ml b/lib/loc.ml index b62677d48..afdab928c 100644 --- a/lib/loc.ml +++ b/lib/loc.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -31,7 +31,7 @@ let ghost = { fname = ""; line_nb = -1; bol_pos = 0; line_nb_last = -1; bol_pos_last = 0; bp = 0; ep = 0; } -let is_ghost loc = Pervasives.(=) loc ghost (** FIXME *) +let is_ghost loc = loc.ep = 0 let merge loc1 loc2 = if loc1.bp < loc2.bp then diff --git a/lib/loc.mli b/lib/loc.mli index 7a9a9ffdb..f39cd2670 100644 --- a/lib/loc.mli +++ b/lib/loc.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/option.ml b/lib/option.ml index 9ea1a7698..fbb883d30 100644 --- a/lib/option.ml +++ b/lib/option.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -41,8 +41,8 @@ let hash f = function exception IsNone -(** [get x] returns [y] where [x] is [Some y]. It raises IsNone - if [x] equals [None]. *) +(** [get x] returns [y] where [x] is [Some y]. + @raise [IsNone] if [x] equals [None]. *) let get = function | Some y -> y | _ -> raise IsNone diff --git a/lib/option.mli b/lib/option.mli index d9ad0e119..5e085620e 100644 --- a/lib/option.mli +++ b/lib/option.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -34,8 +34,8 @@ val compare : ('a -> 'a -> int) -> 'a option -> 'a option -> int (** Lift a hash to option types. *) val hash : ('a -> int) -> 'a option -> int -(** [get x] returns [y] where [x] is [Some y]. It raises IsNone - if [x] equals [None]. *) +(** [get x] returns [y] where [x] is [Some y]. + @raise IsNone if [x] equals [None]. *) val get : 'a option -> 'a (** [make x] returns [Some x]. *) @@ -54,7 +54,7 @@ val flatten : 'a option option -> 'a option val append : 'a option -> 'a option -> 'a option -(** {6 "Iterators"} ***) +(** {6 "Iterators"} *) (** [iter f x] executes [f y] if [x] equals [Some y]. It does nothing otherwise. *) @@ -63,8 +63,8 @@ val iter : ('a -> unit) -> 'a option -> unit exception Heterogeneous (** [iter2 f x y] executes [f z w] if [x] equals [Some z] and [y] equals - [Some w]. It does nothing if both [x] and [y] are [None]. And raises - [Heterogeneous] otherwise. *) + [Some w]. It does nothing if both [x] and [y] are [None]. + @raise Heterogeneous otherwise. *) val iter2 : ('a -> 'b -> unit) -> 'a option -> 'b option -> unit (** [map f x] is [None] if [x] is [None] and [Some (f y)] if [x] is [Some y]. *) @@ -78,8 +78,8 @@ val smartmap : ('a -> 'a) -> 'a option -> 'a option val fold_left : ('b -> 'a -> 'b) -> 'b -> 'a option -> 'b (** [fold_left2 f a x y] is [f z w] if [x] is [Some z] and [y] is [Some w]. - It is [a] if both [x] and [y] are [None]. Otherwise it raises - [Heterogeneous]. *) + It is [a] if both [x] and [y] are [None]. + @raise Heterogeneous otherwise. *) val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b option -> 'c option -> 'a (** [fold_right f x a] is [f y a] if [x] is [Some y], and [a] otherwise. *) @@ -91,7 +91,7 @@ val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b option -> 'a * 'c option (** [cata f e x] is [e] if [x] is [None] and [f a] if [x] is [Some a] *) val cata : ('a -> 'b) -> 'b -> 'a option -> 'b -(** {6 More Specific Operations} ***) +(** {6 More Specific Operations} *) (** [default a x] is [y] if [x] is [Some y] and [a] otherwise. *) val default : 'a -> 'a option -> 'a @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -51,25 +51,18 @@ sig val prj : t -> 'a key -> 'a option end = struct - (** See module {Dyn} for more details. *) - type t = int * Obj.t +module Dyn = Dyn.Make(struct end) - type 'a key = int - - let dyntab = ref (Int.Map.empty : string Int.Map.t) - - let create (s : string) = - let hash = Hashtbl.hash s in - let () = assert (not (Int.Map.mem hash !dyntab)) in - let () = dyntab := Int.Map.add hash s !dyntab in - hash - - let inj x h = (h, Obj.repr x) - - let prj (nh, rv) h = - if Int.equal h nh then Some (Obj.magic rv) - else None +type t = Dyn.t +type 'a key = 'a Dyn.tag +let create = Dyn.create +let inj x k = Dyn.Dyn (k, x) +let prj : type a. t -> a key -> a option = fun dyn k -> + let Dyn.Dyn (k', x) = dyn in + match Dyn.eq k k' with + | None -> None + | Some CSig.Refl -> Some x end @@ -268,7 +261,7 @@ let rec pr_com ft s = let n = String.index s '\n' in String.sub s 0 n, Some (String.sub s (n+1) (String.length s - n - 1)) with Not_found -> s,None in - com_if ft (Lazy.lazy_from_val()); + com_if ft (Lazy.from_val()); (* let s1 = if String.length s1 <> 0 && s1.[0] = ' ' then (Format.pp_print_space ft (); String.sub s1 1 (String.length s1 - 1)) @@ -297,29 +290,29 @@ let pp_dirs ?pp_tag ft = begin match tok with | Str_def s -> let n = utf8_length s in - com_if ft (Lazy.lazy_from_val()); Format.pp_print_as ft n s + com_if ft (Lazy.from_val()); Format.pp_print_as ft n s | Str_len (s, n) -> - com_if ft (Lazy.lazy_from_val()); Format.pp_print_as ft n s + com_if ft (Lazy.from_val()); Format.pp_print_as ft n s end | Ppcmd_box(bty,ss) -> (* Prevent evaluation of the stream! *) - com_if ft (Lazy.lazy_from_val()); + com_if ft (Lazy.from_val()); pp_open_box bty ; if not (Format.over_max_boxes ()) then Glue.iter pp_cmd ss; Format.pp_close_box ft () - | Ppcmd_open_box bty -> com_if ft (Lazy.lazy_from_val()); pp_open_box bty + | Ppcmd_open_box bty -> com_if ft (Lazy.from_val()); pp_open_box bty | Ppcmd_close_box -> Format.pp_close_box ft () | Ppcmd_close_tbox -> Format.pp_close_tbox ft () | Ppcmd_white_space n -> - com_if ft (Lazy.lazy_from_fun (fun()->Format.pp_print_break ft n 0)) + com_if ft (Lazy.from_fun (fun()->Format.pp_print_break ft n 0)) | Ppcmd_print_break(m,n) -> - com_if ft (Lazy.lazy_from_fun(fun()->Format.pp_print_break ft m n)) + com_if ft (Lazy.from_fun(fun()->Format.pp_print_break ft m n)) | Ppcmd_set_tab -> Format.pp_set_tab ft () | Ppcmd_print_tbreak(m,n) -> - com_if ft (Lazy.lazy_from_fun(fun()->Format.pp_print_tbreak ft m n)) + com_if ft (Lazy.from_fun(fun()->Format.pp_print_tbreak ft m n)) | Ppcmd_force_newline -> com_brk ft; Format.pp_force_newline ft () | Ppcmd_print_if_broken -> - com_if ft (Lazy.lazy_from_fun(fun()->Format.pp_print_if_newline ft ())) + com_if ft (Lazy.from_fun(fun()->Format.pp_print_if_newline ft ())) | Ppcmd_comment i -> let coms = split_com [] [] i !comments in (* Format.pp_open_hvbox ft 0;*) diff --git a/lib/pp.mli b/lib/pp.mli index d034e6761..015151bc9 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/pp_control.ml b/lib/pp_control.ml index 969c1550e..890ffe0a1 100644 --- a/lib/pp_control.ml +++ b/lib/pp_control.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/pp_control.mli b/lib/pp_control.mli index 28d2e2998..d26f89eb3 100644 --- a/lib/pp_control.mli +++ b/lib/pp_control.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/ppstyle.ml b/lib/ppstyle.ml index fb334c706..3ecaac039 100644 --- a/lib/ppstyle.ml +++ b/lib/ppstyle.ml @@ -1,12 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Util +module String = CString type t = string (** We use the concatenated string, with dots separating each string. We diff --git a/lib/ppstyle.mli b/lib/ppstyle.mli index f5d6184cb..97b5869f9 100644 --- a/lib/ppstyle.mli +++ b/lib/ppstyle.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/predicate.ml b/lib/predicate.ml index a60b3dadd..1aa7db6af 100644 --- a/lib/predicate.ml +++ b/lib/predicate.ml @@ -10,8 +10,6 @@ (* *) (************************************************************************) -(* Sets over ordered types *) - module type OrderedType = sig type t @@ -43,9 +41,10 @@ module Make(Ord: OrderedType) = struct module EltSet = Set.Make(Ord) - (* when bool is false, the denoted set is the complement of - the given set *) type elt = Ord.t + + (* (false, s) represents a set which is equal to the set s + (true, s) represents a set which is equal to the complement of set s *) type t = bool * EltSet.t let elements (b,s) = (b, EltSet.elements s) @@ -84,6 +83,7 @@ module Make(Ord: OrderedType) = let diff s1 s2 = inter s1 (complement s2) + (* assumes the set is infinite *) let subset s1 s2 = match (s1,s2) with ((false,p1),(false,p2)) -> EltSet.subset p1 p2 @@ -91,6 +91,7 @@ module Make(Ord: OrderedType) = | ((false,p1),(true,n2)) -> EltSet.is_empty (EltSet.inter p1 n2) | ((true,_),(false,_)) -> false + (* assumes the set is infinite *) let equal (b1,s1) (b2,s2) = b1=b2 && EltSet.equal s1 s2 diff --git a/lib/predicate.mli b/lib/predicate.mli index bcc89e727..cee3b0bd3 100644 --- a/lib/predicate.mli +++ b/lib/predicate.mli @@ -1,67 +1,84 @@ +(** Infinite sets over a chosen [OrderedType]. -(** Module [Pred]: sets over infinite ordered types with complement. *) - -(** This module implements the set data structure, given a total ordering - function over the set elements. All operations over sets - are purely applicative (no side-effects). - The implementation uses the Set library. *) + All operations over sets are purely applicative (no side-effects). + *) +(** Input signature of the functor [Make]. *) module type OrderedType = sig type t - val compare: t -> t -> int + (** The type of the elements in the set. + + The chosen [t] {b must be infinite}. *) + + val compare : t -> t -> int + (** A total ordering function over the set elements. + This is a two-argument function [f] such that: + - [f e1 e2] is zero if the elements [e1] and [e2] are equal, + - [f e1 e2] is strictly negative if [e1] is smaller than [e2], + - and [f e1 e2] is strictly positive if [e1] is greater than [e2]. + *) end - (** The input signature of the functor [Pred.Make]. - [t] is the type of the set elements. - [compare] is a total ordering function over the set elements. - This is a two-argument function [f] such that - [f e1 e2] is zero if the elements [e1] and [e2] are equal, - [f e1 e2] is strictly negative if [e1] is smaller than [e2], - and [f e1 e2] is strictly positive if [e1] is greater than [e2]. - Example: a suitable ordering function is - the generic structural comparison function [compare]. *) module type S = sig type elt - (** The type of the set elements. *) + (** The type of the elements in the set. *) + type t - (** The type of sets. *) + (** The type of sets. *) + val empty: t - (** The empty set. *) + (** The empty set. *) + val full: t - (** The whole type. *) + (** The set of all elements (of type [elm]). *) + val is_empty: t -> bool - (** Test whether a set is empty or not. *) + (** Test whether a set is empty or not. *) + val is_full: t -> bool - (** Test whether a set contains the whole type or not. *) + (** Test whether a set contains the whole type or not. *) + val mem: elt -> t -> bool - (** [mem x s] tests whether [x] belongs to the set [s]. *) + (** [mem x s] tests whether [x] belongs to the set [s]. *) + val singleton: elt -> t - (** [singleton x] returns the one-element set containing only [x]. *) + (** [singleton x] returns the one-element set containing only [x]. *) + val add: elt -> t -> t - (** [add x s] returns a set containing all elements of [s], - plus [x]. If [x] was already in [s], [s] is returned unchanged. *) + (** [add x s] returns a set containing all elements of [s], + plus [x]. If [x] was already in [s], then [s] is returned unchanged. *) + val remove: elt -> t -> t (** [remove x s] returns a set containing all elements of [s], - except [x]. If [x] was not in [s], [s] is returned unchanged. *) + except [x]. If [x] was not in [s], then [s] is returned unchanged. *) + val union: t -> t -> t + (** Set union. *) + val inter: t -> t -> t + (** Set intersection. *) + val diff: t -> t -> t + (** Set difference. *) + val complement: t -> t - (** Union, intersection, difference and set complement. *) + (** Set complement. *) + val equal: t -> t -> bool - (** [equal s1 s2] tests whether the sets [s1] and [s2] are - equal, that is, contain equal elements. *) + (** [equal s1 s2] tests whether the sets [s1] and [s2] are + equal, that is, contain equal elements. *) + val subset: t -> t -> bool (** [subset s1 s2] tests whether the set [s1] is a subset of - the set [s2]. *) + the set [s2]. *) + val elements: t -> bool * elt list (** Gives a finite representation of the predicate: if the boolean is false, then the predicate is given in extension. if it is true, then the complement is given *) end -module Make(Ord: OrderedType): (S with type elt = Ord.t) - (** Functor building an implementation of the set structure - given a totally ordered type. *) +(** The [Make] functor constructs an implementation for any [OrderedType]. *) +module Make (Ord : OrderedType) : (S with type elt = Ord.t) diff --git a/lib/profile.ml b/lib/profile.ml index c55064ca8..2350cd43a 100644 --- a/lib/profile.ml +++ b/lib/profile.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/profile.mli b/lib/profile.mli index e3221cd2b..3328d7ea3 100644 --- a/lib/profile.mli +++ b/lib/profile.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/remoteCounter.ml b/lib/remoteCounter.ml index f4d7bb7b8..3f1982594 100644 --- a/lib/remoteCounter.ml +++ b/lib/remoteCounter.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/remoteCounter.mli b/lib/remoteCounter.mli index f3eca418f..1b0fa6a00 100644 --- a/lib/remoteCounter.mli +++ b/lib/remoteCounter.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/richpp.ml b/lib/richpp.ml index fff989ce0..fe3edd99c 100644 --- a/lib/richpp.ml +++ b/lib/richpp.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/richpp.mli b/lib/richpp.mli index 7e4b58c9a..807d52aba 100644 --- a/lib/richpp.mli +++ b/lib/richpp.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/rtree.ml b/lib/rtree.ml index f395c086a..f89b98c04 100644 --- a/lib/rtree.ml +++ b/lib/rtree.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/rtree.mli b/lib/rtree.mli index 0b9424b89..e27134c3b 100644 --- a/lib/rtree.mli +++ b/lib/rtree.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/serialize.ml b/lib/serialize.ml index b14bfb283..685ec6049 100644 --- a/lib/serialize.ml +++ b/lib/serialize.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/serialize.mli b/lib/serialize.mli index f4eac5a6b..d7c14e7e7 100644 --- a/lib/serialize.mli +++ b/lib/serialize.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/spawn.ml b/lib/spawn.ml index 851c6a223..fda4b4239 100644 --- a/lib/spawn.ml +++ b/lib/spawn.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -175,7 +175,7 @@ let is_alive p = p.alive let uid { pid; } = string_of_int pid let unixpid { pid; } = pid -let kill ({ pid = unixpid; oob_req; cin; cout; alive; watch } as p) = +let kill ({ pid = unixpid; oob_resp; oob_req; cin; cout; alive; watch } as p) = p.alive <- false; if not alive then prerr_endline "This process is already dead" else begin try @@ -183,6 +183,8 @@ let kill ({ pid = unixpid; oob_req; cin; cout; alive; watch } as p) = output_death_sentence (uid p) oob_req; close_in_noerr cin; close_out_noerr cout; + close_in_noerr oob_resp; + close_out_noerr oob_req; if Sys.os_type = "Unix" then Unix.kill unixpid 9; p.watch <- None with e -> prerr_endline ("kill: "^Printexc.to_string e) end @@ -218,10 +220,13 @@ let stats { oob_req; oob_resp; alive } = input_value oob_resp let rec wait p = - try snd (Unix.waitpid [] p.pid) - with - | Unix.Unix_error (Unix.EINTR, _, _) -> wait p - | Unix.Unix_error _ -> Unix.WEXITED 0o400 + (* On windows kill is not reliable, so wait may never return. *) + if Sys.os_type = "Unix" then + try snd (Unix.waitpid [] p.pid) + with + | Unix.Unix_error (Unix.EINTR, _, _) -> wait p + | Unix.Unix_error _ -> Unix.WEXITED 0o400 + else Unix.WEXITED 0o400 end @@ -247,13 +252,15 @@ let is_alive p = p.alive let uid { pid; } = string_of_int pid let unixpid { pid = pid; } = pid -let kill ({ pid = unixpid; oob_req; cin; cout; alive } as p) = +let kill ({ pid = unixpid; oob_req; oob_resp; cin; cout; alive } as p) = p.alive <- false; if not alive then prerr_endline "This process is already dead" else begin try output_death_sentence (uid p) oob_req; close_in_noerr cin; close_out_noerr cout; + close_in_noerr oob_resp; + close_out_noerr oob_req; if Sys.os_type = "Unix" then Unix.kill unixpid 9; with e -> prerr_endline ("kill: "^Printexc.to_string e) end @@ -263,8 +270,13 @@ let stats { oob_req; oob_resp; alive } = flush oob_req; let RespStats g = input_value oob_resp in g -let wait { pid = unixpid } = - try snd (Unix.waitpid [] unixpid) - with Unix.Unix_error _ -> Unix.WEXITED 0o400 +let rec wait p = + (* On windows kill is not reliable, so wait may never return. *) + if Sys.os_type = "Unix" then + try snd (Unix.waitpid [] p.pid) + with + | Unix.Unix_error (Unix.EINTR, _, _) -> wait p + | Unix.Unix_error _ -> Unix.WEXITED 0o400 + else Unix.WEXITED 0o400 end diff --git a/lib/spawn.mli b/lib/spawn.mli index 8022573bc..9b86b0954 100644 --- a/lib/spawn.mli +++ b/lib/spawn.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/system.ml b/lib/system.ml index 7a62d5603..10ef8580b 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -11,7 +11,6 @@ open Pp open Errors open Util -open Unix (** Dealing with directories *) @@ -44,7 +43,7 @@ let ok_dirname f = (* Check directory can be opened *) let exists_dir dir = - try let _ = closedir (opendir dir) in true with Unix_error _ -> false + try Sys.is_directory dir with Sys_error _ -> false let check_unix_dir warn dir = if (Sys.os_type = "Win32" || Sys.os_type = "Cygwin") && @@ -57,17 +56,17 @@ let check_unix_dir warn dir = let apply_subdir f path name = (* we avoid all files and subdirs starting by '.' (e.g. .svn) *) (* as well as skipped files like CVS, ... *) - if name.[0] <> '.' && ok_dirname name then + if ok_dirname name then let path = if path = "." then name else path//name in - match try (stat path).st_kind with Unix_error _ -> S_BLK with - | S_DIR -> f (FileDir (path,name)) - | S_REG -> f (FileRegular name) + match try (Unix.stat path).Unix.st_kind with Unix.Unix_error _ -> Unix.S_BLK with + | Unix.S_DIR -> f (FileDir (path,name)) + | Unix.S_REG -> f (FileRegular name) | _ -> () +let readdir dir = try Sys.readdir dir with any -> [||] + let process_directory f path = - let dirh = opendir path in - try while true do apply_subdir f path (readdir dirh) done - with End_of_file -> closedir dirh + Array.iter (apply_subdir f path) (readdir path) let process_subdirectories f path = let f = function FileDir (path,base) -> f path base | FileRegular _ -> () in @@ -94,6 +93,51 @@ let all_subdirs ~unix_path:root = else msg_warning (str ("Cannot open " ^ root)); List.rev !l +(* Caching directory contents for efficient syntactic equality of file + names even on case-preserving but case-insensitive file systems *) + +module StrMod = struct + type t = string + let compare = compare +end + +module StrMap = Map.Make(StrMod) +module StrSet = Set.Make(StrMod) + +let dirmap = ref StrMap.empty + +let make_dir_table dir = + let filter_dotfiles s f = if f.[0] = '.' then s else StrSet.add f s in + Array.fold_left filter_dotfiles StrSet.empty (readdir dir) + +let exists_in_dir_respecting_case dir bf = + let cache_dir dir = + let contents = make_dir_table dir in + dirmap := StrMap.add dir contents !dirmap; + contents in + let contents, fresh = + try + (* in batch mode, assume the directory content is still fresh *) + StrMap.find dir !dirmap, !Flags.batch_mode + with Not_found -> + (* in batch mode, we are not yet sure the directory exists *) + if !Flags.batch_mode && not (exists_dir dir) then StrSet.empty, true + else cache_dir dir, true in + StrSet.mem bf contents || + not fresh && + (* rescan, there is a new file we don't know about *) + StrSet.mem bf (cache_dir dir) + +let file_exists_respecting_case path f = + (* This function ensures that a file with expected lowercase/uppercase + is the correct one, even on case-insensitive file systems *) + let rec aux f = + let bf = Filename.basename f in + let df = Filename.dirname f in + (String.equal df "." || aux df) + && exists_in_dir_respecting_case (Filename.concat path df) bf + in (!Flags.batch_mode || Sys.file_exists (Filename.concat path f)) && aux f + let rec search paths test = match paths with | [] -> [] @@ -118,7 +162,7 @@ let where_in_path ?(warn=true) path filename = in check_and_warn (search path (fun lpe -> let f = Filename.concat lpe filename in - if Sys.file_exists f then [lpe,f] else [])) + if file_exists_respecting_case lpe filename then [lpe,f] else [])) let where_in_path_rex path rex = search path (fun lpe -> @@ -134,6 +178,8 @@ let where_in_path_rex path rex = let find_file_in_path ?(warn=true) paths filename = if not (Filename.is_implicit filename) then + (* the name is considered to be a physical name and we use the file + system rules (e.g. possible case-insensitivity) to find it *) if Sys.file_exists filename then let root = Filename.dirname filename in root, filename @@ -141,6 +187,9 @@ let find_file_in_path ?(warn=true) paths filename = errorlabstrm "System.find_file_in_path" (hov 0 (str "Can't find file" ++ spc () ++ str filename)) else + (* the name is considered to be the transcription as a relative + physical name of a logical name, so we deal with it as a name + to be locate respecting case *) try where_in_path ~warn paths filename with Not_found -> errorlabstrm "System.find_file_in_path" @@ -152,10 +201,12 @@ let is_in_path lpath filename = with Not_found -> false let is_in_system_path filename = - let path = try Sys.getenv "PATH" - with Not_found -> error "system variable PATH not found" in - let lpath = CUnix.path_to_list path in - is_in_path lpath filename + try + let lpath = CUnix.path_to_list (Sys.getenv "PATH") in + is_in_path lpath filename + with Not_found -> + msg_warning (str "system variable PATH not found"); + false let open_trapping_failure name = try open_out_bin name @@ -265,7 +316,7 @@ type time = float * float * float let get_time () = let t = Unix.times () in - (Unix.gettimeofday(), t.tms_utime, t.tms_stime) + (Unix.gettimeofday(), t.Unix.tms_utime, t.Unix.tms_stime) (* Keep only 3 significant digits *) let round f = (floor (f *. 1e3)) *. 1e-3 diff --git a/lib/system.mli b/lib/system.mli index 2e773fe96..e1190dfb5 100644 --- a/lib/system.mli +++ b/lib/system.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -59,6 +59,8 @@ val where_in_path_rex : val find_file_in_path : ?warn:bool -> CUnix.load_path -> string -> CUnix.physical_path * string +val file_exists_respecting_case : string -> string -> bool + (** {6 I/O functions } *) (** Generic input and output functions, parameterized by a magic number and a suffix. The intern functions raise the exception [Bad_magic_number] diff --git a/lib/terminal.ml b/lib/terminal.ml index 58851ed27..de21f1028 100644 --- a/lib/terminal.ml +++ b/lib/terminal.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/terminal.mli b/lib/terminal.mli index 49172e3ce..e0fd7f228 100644 --- a/lib/terminal.mli +++ b/lib/terminal.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/trie.ml b/lib/trie.ml index e369e6ad4..0309fde9b 100644 --- a/lib/trie.ml +++ b/lib/trie.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/trie.mli b/lib/trie.mli index 818474858..de67e8f96 100644 --- a/lib/trie.mli +++ b/lib/trie.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/unicode.ml b/lib/unicode.ml index 1765e93dc..938e8f1a9 100644 --- a/lib/unicode.ml +++ b/lib/unicode.ml @@ -18,7 +18,7 @@ exception Unsupported to simplify the masking process. (This choice seems to be a good trade-off between speed and space after some benchmarks.) *) -(* A 256ko table, initially filled with zeros. *) +(* A 256 KiB table, initially filled with zeros. *) let table = Array.make (1 lsl 17) 0 (* Associate a 2-bit pattern to each status at position [i]. @@ -147,6 +147,11 @@ let utf8_of_unicode n = s end +(* If [s] is some UTF-8 encoded string + and [i] is a position of some UTF-8 character within [s] + then [next_utf8 s i] returns [(j,n)] where: + - [j] indicates the position of the next UTF-8 character + - [n] represents the UTF-8 character at index [i] *) let next_utf8 s i = let err () = invalid_arg "utf8" in let l = String.length s - i in @@ -168,6 +173,13 @@ let next_utf8 s i = (c land 0x3F) lsl 6 + (d land 0x3F) else err () +let is_utf8 s = + let rec check i = + let (off, _) = next_utf8 s i in + check (i + off) + in + try check 0 with End_of_input -> true | Invalid_argument _ -> false + (* Check the well-formedness of an identifier *) let initial_refutation j n s = diff --git a/lib/unicode.mli b/lib/unicode.mli index 098f6c919..b8a11e294 100644 --- a/lib/unicode.mli +++ b/lib/unicode.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -10,19 +10,32 @@ type status = Letter | IdentPart | Symbol +(** This exception is raised when UTF-8 the input string contains unsupported UTF-8 characters. *) exception Unsupported -(** Classify a unicode char into 3 classes, or raise [Unsupported] *) +(** Classify a unicode char into 3 classes. + @raise Unsupported if the input string contains unsupported UTF-8 characters. *) val classify : int -> status -(** Check whether a given string be used as a legal identifier. - - [None] means yes - - [Some (b,s)] means no, with explanation [s] and severity [b] *) +(** Return [None] if a given string can be used as a (Coq) identifier. + Return [Some (b,s)] otherwise, where [s] is an explanation and [b] is severity. + @raise Unsupported if the input string contains unsupported UTF-8 characters. *) val ident_refutation : string -> (bool * string) option -(** First char of a string, converted to lowercase *) +(** First char of a string, converted to lowercase + @raise Unsupported if the input string contains unsupported UTF-8 characters. + @raise Assert_failure if the input string is empty. *) val lowercase_first_char : string -> string -(** For extraction, turn a unicode string into an ascii-only one *) +(** Return [true] if all UTF-8 characters in the input string are just plain ASCII characters. + Returns [false] otherwise. *) val is_basic_ascii : string -> bool + +(** [ascii_of_ident s] maps UTF-8 string to a string composed solely from ASCII characters. + Those UTF-8 characters which do not have their ASCII counterparts are + translated to ["__Uxxxx_"] where {i xxxx} are four hexadecimal digits. + @raise Unsupported if the input string contains unsupported UTF-8 characters. *) val ascii_of_ident : string -> string + +(** Validate an UTF-8 string *) +val is_utf8 : string -> bool diff --git a/lib/unionfind.ml b/lib/unionfind.ml index c44aa7363..6e131d8fb 100644 --- a/lib/unionfind.ml +++ b/lib/unionfind.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/unionfind.mli b/lib/unionfind.mli index 310d5e2ae..ea249ae2e 100644 --- a/lib/unionfind.mli +++ b/lib/unionfind.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/util.ml b/lib/util.ml index a20dba0fc..cae996e33 100644 --- a/lib/util.ml +++ b/lib/util.ml @@ -87,7 +87,13 @@ let matrix_transpose mat = let identity x = x -let compose f g x = f (g x) +(** Function composition: the mathematical [∘] operator. + + So [g % f] is a synonym for [fun x -> g (f x)]. + + Also because [%] is right-associative, [h % g % f] means [fun x -> h (g (f x))]. + *) +let (%) f g x = f (g x) let const x _ = x @@ -124,10 +130,38 @@ let delayed_force f = f () type ('a, 'b) union = ('a, 'b) CSig.union = Inl of 'a | Inr of 'b type 'a until = 'a CSig.until = Stop of 'a | Cont of 'a +type ('a, 'b) eq = ('a, 'b) CSig.eq = Refl : ('a, 'a) eq + +module Union = +struct + let map f g = function + | Inl a -> Inl (f a) + | Inr b -> Inr (g b) + + (** Lifting equality onto union types. *) + let equal f g x y = match x, y with + | Inl x, Inl y -> f x y + | Inr x, Inr y -> g x y + | _, _ -> false + + let fold_left f g a = function + | Inl y -> f a y + | Inr y -> g a y + | _ -> a +end + +let map_union = Union.map + +(** Lifting equality onto union types. *) +let equal_union f g x y = match x, y with + | Inl x, Inl y -> f x y + | Inr x, Inr y -> g x y + | _, _ -> false -let map_union f g = function - | Inl a -> Inl (f a) - | Inr b -> Inr (g b) +let fold_left_union f g a = function + | Inl y -> f a y + | Inr y -> g a y + | _ -> a type iexn = Exninfo.iexn diff --git a/lib/util.mli b/lib/util.mli index 1dc405fcb..6bed7e355 100644 --- a/lib/util.mli +++ b/lib/util.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -83,7 +83,15 @@ val matrix_transpose : 'a list list -> 'a list list (** {6 Functions. } *) val identity : 'a -> 'a -val compose : ('a -> 'b) -> ('c -> 'a) -> 'c -> 'b + +(** Function composition: the mathematical [∘] operator. + + So [g % f] is a synonym for [fun x -> g (f x)]. + + Also because [%] is right-associative, [h % g % f] means [fun x -> h (g (f x))]. +*) +val (%) : ('a -> 'b) -> ('c -> 'a) -> 'c -> 'b + val const : 'a -> 'b -> 'a val iterate : ('a -> 'a) -> int -> 'a -> 'a val repeat : int -> ('a -> unit) -> 'a -> unit @@ -106,10 +114,20 @@ val iraise : iexn -> 'a type ('a, 'b) union = ('a, 'b) CSig.union = Inl of 'a | Inr of 'b (** Union type *) +module Union : +sig + val map : ('a -> 'c) -> ('b -> 'd) -> ('a, 'b) union -> ('c, 'd) union + val equal : ('a -> 'a -> bool) -> ('b -> 'b -> bool) -> ('a, 'b) union -> ('a, 'b) union -> bool + val fold_left : ('c -> 'a -> 'c) -> ('c -> 'b -> 'c) -> 'c -> ('a, 'b) union -> 'c +end + val map_union : ('a -> 'c) -> ('b -> 'd) -> ('a, 'b) union -> ('c, 'd) union +(** Alias for [Union.map] *) type 'a until = 'a CSig.until = Stop of 'a | Cont of 'a (** Used for browsable-until structures. *) +type ('a, 'b) eq = ('a, 'b) CSig.eq = Refl : ('a, 'a) eq + 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_datatype.mli b/lib/xml_datatype.mli index f61ba032a..a8e37935b 100644 --- a/lib/xml_datatype.mli +++ b/lib/xml_datatype.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/xml_printer.ml b/lib/xml_printer.ml index bbb7b51ba..e7e4d0ceb 100644 --- a/lib/xml_printer.ml +++ b/lib/xml_printer.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/lib/xml_printer.mli b/lib/xml_printer.mli index e21eca283..f24f51fff 100644 --- a/lib/xml_printer.mli +++ b/lib/xml_printer.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/library/declare.ml b/library/declare.ml index 16803b3bf..c59d190a0 100644 --- a/library/declare.ml +++ b/library/declare.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -27,15 +27,23 @@ open Decls open Decl_kinds (** flag for internal message display *) -type internal_flag = +type internal_flag = | UserAutomaticRequest (* kernel action, a message is displayed *) | InternalTacticRequest (* kernel action, no message is displayed *) | UserIndividualRequest (* user action, a message is displayed *) +(** XML output hooks *) + +let (f_xml_declare_variable, xml_declare_variable) = Hook.make ~default:ignore () +let (f_xml_declare_constant, xml_declare_constant) = Hook.make ~default:ignore () +let (f_xml_declare_inductive, xml_declare_inductive) = Hook.make ~default:ignore () + +let if_xml f x = if !Flags.xml_export then f x else () + (** 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 @@ -63,7 +71,7 @@ let cache_variable ((sp,_),o) = 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 @@ -83,6 +91,7 @@ let declare_variable id obj = declare_var_implicits id; Notation.declare_ref_arguments_scope (VarRef id); Heads.declare_head (EvalVarRef id); + if_xml (Hook.get f_xml_declare_variable) oname; oname @@ -93,9 +102,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 *) @@ -131,12 +144,21 @@ 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 - add_section_constant (cst.const_proj <> None) kn' cst.const_hyps; + add_section_constant cst.const_polymorphic kn' cst.const_hyps; Dischargedhypsmap.set_discharged_hyps sp obj.cst_hyps; add_constant_kind (constant_of_kn kn) obj.cst_kind @@ -157,19 +179,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; @@ -177,17 +202,42 @@ 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; + let () = if_xml (Hook.get f_xml_declare_constant) (InternalTacticRequest, c) in + 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; @@ -196,98 +246,34 @@ 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 = UserIndividualRequest) ?(local = false) id ?(export_seff=false) (cd, kind) = - let cd = (* We deal with side effects *) + 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 + let () = if_xml (Hook.get f_xml_declare_constant) (internal, kn) in kn 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 @@ -339,7 +325,7 @@ let cache_inductive ((sp,kn),(dhyps,mie)) = let kn' = Global.add_mind dir id mie in assert (eq_mind kn' (mind_of_kn kn)); let mind = Global.lookup_mind kn' in - add_section_kn kn' mind.mind_hyps; + add_section_kn mind.mind_polymorphic kn' mind.mind_hyps; Dischargedhypsmap.set_discharged_hyps sp dhyps; List.iter (fun (sp, ref) -> Nametab.push (Nametab.Until 1) sp ref) names @@ -383,15 +369,16 @@ 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 + assert(eq_constant kn kn')) kns; true,true + | Some None -> true,false + | None -> false,false (* for initial declaration *) let declare_mind mie = @@ -400,9 +387,10 @@ let declare_mind mie = | [] -> anomaly (Pp.str "cannot declare an empty list of inductives") in let (sp,kn as oname) = add_leaf id (inInductive ([],mie)) in let mind = Global.mind_of_delta_kn kn in - let isprim = declare_projections mind in + let isrecord,isprim = declare_projections mind in declare_mib_implicits mind; declare_inductive_argument_scopes mind mie; + if_xml (Hook.get f_xml_declare_inductive) (isrecord,oname); oname, isprim (* Declaration messages *) @@ -438,56 +426,73 @@ let definition_message id = Flags.if_verbose msg_info (pr_id id ++ str " is defined") let assumption_message id = - Flags.if_verbose msg_info (pr_id id ++ str " is assumed") + (* Changing "assumed" to "declared", "assuming" referring more to + the type of the object than to the name of the object (see + discussion on coqdev: "Chapter 4 of the Reference Manual", 8/10/2015) *) + Flags.if_verbose msg_info (pr_id id ++ str " is declared") (** Global universe names, in a different summary *) -type universe_names = - (Univ.universe_level Idmap.t * Id.t Univ.LMap.t) +(* Discharged or not *) +type universe_decl = polymorphic * (Id.t * Univ.universe_level) list -let input_universes : universe_names -> Libobject.obj = - let open Libobject in - declare_object +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 p 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', ctx = - List.fold_left (fun ((idl,lid),ctx) (l, id) -> - let lev = Universes.new_univ_level (Global.current_dirpath ()) in - ((Idmap.add id lev idl, Univ.LMap.add lev id lid), - Univ.ContextSet.add_universe lev ctx)) - (glob, Univ.ContextSet.empty) 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 - Global.push_context_set false ctx; - 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 76538a624..8dd24d278 100644 --- a/library/declare.mli +++ b/library/declare.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -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 @@ -48,9 +48,10 @@ type internal_flag = | 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 @@ -70,6 +71,11 @@ val set_declare_scheme : the whole block and a boolean indicating if it is a primitive record. *) val declare_mind : mutual_inductive_entry -> object_name * bool +(** Hooks for XML output *) +val xml_declare_variable : (object_name -> unit) Hook.t +val xml_declare_constant : (internal_flag * constant -> unit) Hook.t +val xml_declare_inductive : (bool * object_name -> unit) Hook.t + (** Declaration messages *) val definition_message : Id.t -> unit @@ -85,5 +91,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 7f607a51c..4c9c40a73 100644 --- a/library/declaremods.ml +++ b/library/declaremods.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -371,7 +371,7 @@ let rec replace_module_object idl mp0 objs0 mp1 objs1 = match idl, objs0 with | _,[] -> [] | id::idl,(id',obj)::tail when Id.equal id id' -> - assert (object_has_tag obj "MODULE"); + assert (String.equal (object_tag obj) "MODULE"); let mp_id = MPdot(mp0, Label.of_id id) in let objs = match idl with | [] -> Lib.subst_objects (map_mp mp1 mp_id empty_delta_resolver) objs1 @@ -557,6 +557,17 @@ let openmodtype_info = Summary.ref ([] : module_type_body list) ~name:"MODTYPE-INFO" +(** XML output hooks *) + +let (f_xml_declare_module, xml_declare_module) = Hook.make ~default:ignore () +let (f_xml_start_module, xml_start_module) = Hook.make ~default:ignore () +let (f_xml_end_module, xml_end_module) = Hook.make ~default:ignore () +let (f_xml_declare_module_type, xml_declare_module_type) = Hook.make ~default:ignore () +let (f_xml_start_module_type, xml_start_module_type) = Hook.make ~default:ignore () +let (f_xml_end_module_type, xml_end_module_type) = Hook.make ~default:ignore () + +let if_xml f x = if !Flags.xml_export then f x else () + (** {6 Modules : start, end, declare} *) module RawModOps = struct @@ -578,7 +589,9 @@ let start_module interp_modast export id args res fs = openmod_info := { cur_typ = res_entry_o; cur_typs = subtyps }; let prefix = Lib.start_module export id mp fs in Nametab.push_dir (Nametab.Until 1) (fst prefix) (DirOpenModule prefix); - Lib.add_frozen_state (); mp + Lib.add_frozen_state (); + if_xml (Hook.get f_xml_start_module) mp; + mp let end_module () = let oldoname,oldprefix,fs,lib_stack = Lib.end_module () in @@ -617,6 +630,7 @@ let end_module () = assert (ModPath.equal (mp_of_kn (snd newoname)) mp); Lib.add_frozen_state () (* to prevent recaching *); + if_xml (Hook.get f_xml_end_module) mp; mp let declare_module interp_modast id args res mexpr_o fs = @@ -666,6 +680,7 @@ let declare_module interp_modast id args res mexpr_o fs = let sobjs = subst_sobjs (map_mp mp0 mp resolver) sobjs in ignore (Lib.add_leaf id (in_module sobjs)); + if_xml (Hook.get f_xml_declare_module) mp; mp end @@ -682,7 +697,9 @@ let start_modtype interp_modast id args mtys fs = openmodtype_info := sub_mty_l; let prefix = Lib.start_modtype id mp fs in Nametab.push_dir (Nametab.Until 1) (fst prefix) (DirOpenModtype prefix); - Lib.add_frozen_state (); mp + Lib.add_frozen_state (); + if_xml (Hook.get f_xml_start_module_type) mp; + mp let end_modtype () = let oldoname,prefix,fs,lib_stack = Lib.end_modtype () in @@ -699,6 +716,7 @@ let end_modtype () = assert (ModPath.equal (mp_of_kn (snd oname)) mp); Lib.add_frozen_state ()(* to prevent recaching *); + if_xml (Hook.get f_xml_end_module_type) mp; mp let declare_modtype interp_modast id args mtys (mty,ann) fs = @@ -729,6 +747,7 @@ let declare_modtype interp_modast id args mtys (mty,ann) fs = check_subtypes_mt mp sub_mty_l; ignore (Lib.add_leaf id (in_modtype sobjs)); + if_xml (Hook.get f_xml_declare_module_type) mp; mp end diff --git a/library/declaremods.mli b/library/declaremods.mli index 319d168d0..2b440c087 100644 --- a/library/declaremods.mli +++ b/library/declaremods.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -63,6 +63,13 @@ val start_modtype : val end_modtype : unit -> module_path +(** Hooks for XML output *) +val xml_declare_module : (module_path -> unit) Hook.t +val xml_start_module : (module_path -> unit) Hook.t +val xml_end_module : (module_path -> unit) Hook.t +val xml_declare_module_type : (module_path -> unit) Hook.t +val xml_start_module_type : (module_path -> unit) Hook.t +val xml_end_module_type : (module_path -> unit) Hook.t (** {6 Libraries i.e. modules on disk } *) diff --git a/library/decls.ml b/library/decls.ml index 8d5085f70..6e21880f1 100644 --- a/library/decls.ml +++ b/library/decls.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -11,7 +11,6 @@ open Util open Names -open Context open Decl_kinds open Libnames @@ -47,16 +46,20 @@ let constant_kind kn = Cmap.find kn !csttab (** Miscellaneous functions. *) +open Context.Named.Declaration + let initialize_named_context_for_proof () = let sign = Global.named_context () in List.fold_right - (fun (id,c,t as d) signv -> - let d = if variable_opacity id then (id,None,t) else d in + (fun d signv -> + let id = get_id d in + let d = if variable_opacity id then LocalAssum (id, get_type d) else d in Environ.push_named_context_val d signv) sign Environ.empty_named_context_val let last_section_hyps dir = - fold_named_context - (fun (id,_,_) sec_ids -> + Context.Named.fold_outside + (fun d sec_ids -> + let id = get_id d in try if DirPath.equal dir (variable_path id) then id::sec_ids else sec_ids with Not_found -> sec_ids) (Environ.named_context (Global.env())) diff --git a/library/decls.mli b/library/decls.mli index ac0d907d8..1ca7f8946 100644 --- a/library/decls.mli +++ b/library/decls.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/library/dischargedhypsmap.ml b/library/dischargedhypsmap.ml index e4280334d..cea1fd7d6 100644 --- a/library/dischargedhypsmap.ml +++ b/library/dischargedhypsmap.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/library/dischargedhypsmap.mli b/library/dischargedhypsmap.mli index 736892016..ea4a9424e 100644 --- a/library/dischargedhypsmap.mli +++ b/library/dischargedhypsmap.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/library/global.ml b/library/global.ml index 6002382c1..2398e92b0 100644 --- a/library/global.ml +++ b/library/global.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -198,13 +198,13 @@ let type_of_global_in_context env r = | IndRef ind -> let (mib, oib as specif) = Inductive.lookup_mind_specif env ind in let univs = - if mib.mind_polymorphic then mib.mind_universes + if mib.mind_polymorphic then Univ.instantiate_univ_context mib.mind_universes else Univ.UContext.empty in Inductive.type_of_inductive env (specif, Univ.UContext.instance univs), univs | ConstructRef cstr -> let (mib,oib as specif) = Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in let univs = - if mib.mind_polymorphic then mib.mind_universes + if mib.mind_polymorphic then Univ.instantiate_univ_context mib.mind_universes else Univ.UContext.empty in let inst = Univ.UContext.instance univs in diff --git a/library/global.mli b/library/global.mli index 455751d41..bf653307c 100644 --- a/library/global.mli +++ b/library/global.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -21,7 +21,7 @@ val env_is_initial : unit -> bool val universes : unit -> UGraph.t val named_context_val : unit -> Environ.named_context_val -val named_context : unit -> Context.named_context +val named_context : unit -> Context.Named.t (** {6 Enriching the global environment } *) @@ -31,10 +31,11 @@ val set_engagement : Declarations.engagement -> unit (** Variables, Local definitions, constants, inductive types *) val push_named_assum : (Id.t * Constr.types * bool) Univ.in_universe_context_set -> unit -val push_named_def : (Id.t * Entries.definition_entry) -> Univ.universe_context_set +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 @@ -72,7 +73,7 @@ val add_module_parameter : (** {6 Queries in the global environment } *) -val lookup_named : variable -> Context.named_declaration +val lookup_named : variable -> Context.Named.Declaration.t val lookup_constant : constant -> Declarations.constant_body val lookup_inductive : inductive -> Declarations.mutual_inductive_body * Declarations.one_inductive_body diff --git a/library/globnames.ml b/library/globnames.ml index 829e2cefc..bec463ecf 100644 --- a/library/globnames.ml +++ b/library/globnames.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -14,10 +14,10 @@ open Libnames (*s Global reference is a kernel side type for all references together *) type global_reference = - | VarRef of variable - | ConstRef of constant - | IndRef of inductive - | ConstructRef of constructor + | VarRef of variable (** A reference to the section-context. *) + | ConstRef of constant (** A reference to the environment. *) + | IndRef of inductive (** A reference to an inductive type. *) + | ConstructRef of constructor (** A reference to a constructor of an inductive type. *) let isVarRef = function VarRef _ -> true | _ -> false let isConstRef = function ConstRef _ -> true | _ -> false @@ -115,7 +115,7 @@ let global_ord_gen ord_cst ord_ind ord_cons x y = | _, ConstRef _ -> 1 | IndRef indx, IndRef indy -> ord_ind indx indy | IndRef _, _ -> -1 - | _ , IndRef _ -> -1 + | _ , IndRef _ -> 1 | ConstructRef consx, ConstructRef consy -> ord_cons consx consy let global_hash_gen hash_cst hash_ind hash_cons gr = diff --git a/library/globnames.mli b/library/globnames.mli index 253c20baa..f4956e3df 100644 --- a/library/globnames.mli +++ b/library/globnames.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -13,10 +13,10 @@ open Mod_subst (** {6 Global reference is a kernel side type for all references together } *) type global_reference = - | VarRef of variable - | ConstRef of constant - | IndRef of inductive - | ConstructRef of constructor + | VarRef of variable (** A reference to the section-context. *) + | ConstRef of constant (** A reference to the environment. *) + | IndRef of inductive (** A reference to an inductive type. *) + | ConstructRef of constructor (** A reference to a constructor of an inductive type. *) val isVarRef : global_reference -> bool val isConstRef : global_reference -> bool diff --git a/library/goptions.ml b/library/goptions.ml index 30d195f83..5f6512e11 100644 --- a/library/goptions.ml +++ b/library/goptions.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/library/goptions.mli b/library/goptions.mli index 9d87c14c5..26864503b 100644 --- a/library/goptions.mli +++ b/library/goptions.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -133,7 +133,7 @@ val declare_stringopt_option: string option option_sig -> string option write_fu (** {6 Special functions supposed to be used only in vernacentries.ml } *) -module OptionMap : Map.S with type key = option_name +module OptionMap : CSig.MapS with type key = option_name val get_string_table : option_name -> diff --git a/library/heads.ml b/library/heads.ml index 5c153b067..4c9b78976 100644 --- a/library/heads.ml +++ b/library/heads.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -15,6 +15,7 @@ open Environ open Globnames open Libobject open Lib +open Context.Named.Declaration (** Characterization of the head of a term *) @@ -63,12 +64,15 @@ let kind_of_head env t = (try on_subterm k l b (variable_head id) with Not_found -> (* a goal variable *) - match pi2 (lookup_named id env) with - | Some c -> aux k l c b - | None -> NotImmediatelyComputableHead) + match lookup_named id env with + | LocalDef (_,c,_) -> aux k l c b + | LocalAssum _ -> 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 @@ -129,8 +133,8 @@ let compute_head = function | None -> RigidHead (RigidParameter cst) | Some c -> kind_of_head env c) | EvalVarRef id -> - (match pi2 (Global.lookup_named id) with - | Some c when not (Decls.variable_opacity id) -> + (match Global.lookup_named id with + | LocalDef (_,c,_) when not (Decls.variable_opacity id) -> kind_of_head (Global.env()) c | _ -> RigidHead (RigidVar id)) diff --git a/library/heads.mli b/library/heads.mli index 52f43824f..5acf5f54f 100644 --- a/library/heads.mli +++ b/library/heads.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/library/impargs.ml b/library/impargs.ml index d15a02fea..4e344a954 100644 --- a/library/impargs.ml +++ b/library/impargs.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -165,6 +165,7 @@ let update pos rig (na,st) = (* modified is_rigid_reference with a truncated env *) let is_flexible_reference env bound depth f = + let open Context.Named.Declaration in match kind_of_term f with | Rel n when n >= bound+depth -> (* inductive type *) false | Rel n when n >= depth -> (* previous argument *) true @@ -173,8 +174,7 @@ let is_flexible_reference env bound depth f = let cb = Environ.lookup_constant kn env in (match cb.const_body with Def _ -> true | _ -> false) | Var id -> - let (_, value, _) = Environ.lookup_named id env in - begin match value with None -> false | _ -> true end + Environ.lookup_named id env |> is_local_def | Ind _ | Construct _ -> false | _ -> true @@ -234,13 +234,14 @@ let find_displayed_name_in all avoid na (_,b as envnames_b) = let compute_implicits_gen strict strongly_strict revpat contextual all env t = let rigid = ref true in + let open Context.Rel.Declaration in let rec aux env avoid n names t = let t = whd_betadeltaiota env t in match kind_of_term t with | Prod (na,a,b) -> let na',avoid' = find_displayed_name_in all avoid na (names,b) in add_free_rels_until strict strongly_strict revpat n env a (Hyp (n+1)) - (aux (push_rel (na',None,a) env) avoid' (n+1) (na'::names) b) + (aux (push_rel (LocalAssum (na',a)) env) avoid' (n+1) (na'::names) b) | _ -> rigid := is_rigid_head t; let names = List.rev names in @@ -252,7 +253,7 @@ let compute_implicits_gen strict strongly_strict revpat contextual all env t = match kind_of_term (whd_betadeltaiota env t) with | Prod (na,a,b) -> let na',avoid = find_displayed_name_in all [] na ([],b) in - let v = aux (push_rel (na',None,a) env) avoid 1 [na'] b in + let v = aux (push_rel (LocalAssum (na',a)) env) avoid 1 [na'] b in !rigid, Array.to_list v | _ -> true, [] @@ -427,7 +428,7 @@ let compute_mib_implicits flags manual kn = (Array.mapi (* No need to lift, arities contain no de Bruijn *) (fun i mip -> (** No need to care about constraints here *) - (Name mip.mind_typename, None, Global.type_of_global_unsafe (IndRef (kn,i)))) + Context.Rel.Declaration.LocalAssum (Name mip.mind_typename, Global.type_of_global_unsafe (IndRef (kn,i)))) mib.mind_packets) in let env_ar = push_rel_context ar env in let imps_one_inductive i mip = @@ -449,8 +450,8 @@ let compute_all_mib_implicits flags manual kn = let compute_var_implicits flags manual id = let env = Global.env () in - let (_,_,ty) = lookup_named id env in - compute_semi_auto_implicits env flags manual ty + let open Context.Named.Declaration in + compute_semi_auto_implicits env flags manual (get_type (lookup_named id env)) (* Implicits of a global reference. *) diff --git a/library/impargs.mli b/library/impargs.mli index 30f2e30f9..34e529ca2 100644 --- a/library/impargs.mli +++ b/library/impargs.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/library/keys.ml b/library/keys.ml index 3d277476f..057dc3b65 100644 --- a/library/keys.ml +++ b/library/keys.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -12,35 +12,31 @@ open Globnames open Term open Libobject -type key = +type key = | KGlob of global_reference - | KLam + | KLam | KLet | KProd | KSort - | KEvar - | KCase - | KFix + | KCase + | KFix | KCoFix - | KRel - | KMeta + | KRel module KeyOrdered = struct type t = key let hash gr = match gr with - | KGlob gr -> 10 + RefOrdered.hash gr + | KGlob gr -> 8 + RefOrdered.hash gr | KLam -> 0 | KLet -> 1 | KProd -> 2 | KSort -> 3 - | KEvar -> 4 - | KCase -> 5 - | KFix -> 6 - | KCoFix -> 7 - | KRel -> 8 - | KMeta -> 9 + | KCase -> 4 + | KFix -> 5 + | KCoFix -> 6 + | KRel -> 7 let compare gr1 gr2 = match gr1, gr2 with @@ -62,8 +58,6 @@ module Keyset = Keymap.Set (* Mapping structure for references to be considered equivalent *) -type keys = Keyset.t Keymap.t - let keys = Summary.ref Keymap.empty ~name:"Keys_decl" let add_kv k v m = @@ -153,12 +147,10 @@ let pr_key pr_global = function | KLet -> str"Let" | KProd -> str"Product" | KSort -> str"Sort" - | KEvar -> str"Evar" | KCase -> str"Case" | KFix -> str"Fix" | KCoFix -> str"CoFix" | KRel -> str"Rel" - | KMeta -> str"Meta" let pr_keyset pr_global v = prlist_with_sep spc (pr_key pr_global) (Keyset.elements v) diff --git a/library/keys.mli b/library/keys.mli index bfbb4c58f..69668590d 100644 --- a/library/keys.mli +++ b/library/keys.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/library/kindops.ml b/library/kindops.ml index 560486473..c634193da 100644 --- a/library/kindops.ml +++ b/library/kindops.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/library/kindops.mli b/library/kindops.mli index cd2e39cf8..3e95eaa7d 100644 --- a/library/kindops.mli +++ b/library/kindops.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/library/lib.ml b/library/lib.ml index f4f52db53..f8bb6bac5 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -198,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)) @@ -392,60 +395,85 @@ 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 () = sectab := ([],(Names.Cmap.empty,Names.Mindmap.empty), (Names.Cmap.empty,Names.Mindmap.empty)) :: !sectab +let check_same_poly p vars = + let pred = function Context _ -> p = false | Variable (_, _, poly, _) -> p != poly in + if List.exists pred vars then + error "Cannot mix universe polymorphic and monomorphic declarations in sections." + 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 + check_same_poly poly vars; + 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 -> + check_same_poly true vars; + sectab := (Context ctx :: vars,repl,abs)::sl let extract_hyps (secs,ohyps) = + let open Context.Named.Declaration in 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, decl::hyps) when Names.Id.equal id (get_id decl) -> + let (id',b,t) = to_tuple decl in 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) let instance_from_variable_context sign = - let rec inst_rec = function | (id,b,None,_) :: sign -> id :: inst_rec sign | _ :: sign -> inst_rec sign | [] -> [] in Array.of_list (inst_rec sign) -let named_of_variable_context ctx = List.map (fun (id,_,b,t) -> (id,b,t)) ctx +let named_of_variable_context ctx = let open Context.Named.Declaration in + List.map (function id,_,None,t -> LocalAssum (id,t) + | id,_,Some b,t -> LocalDef (id,b,t)) + ctx -let add_section_replacement f g hyps = +let add_section_replacement f g poly hyps = match !sectab with | [] -> () | (vars,exps,abs)::sl -> + let () = check_same_poly poly vars in let sechyps,ctx = extract_hyps (vars,hyps) in 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 add_section_kn poly kn = let f x (l1,l2) = (l1,Names.Mindmap.add kn x l2) in - add_section_replacement f f + add_section_replacement f f poly -let add_section_constant is_projection kn = +let add_section_constant poly kn = let f x (l1,l2) = (Names.Cmap.add kn x l1,l2) in - add_section_replacement f f + add_section_replacement f f poly let replacement_context () = pi2 (List.hd !sectab) @@ -457,10 +485,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,_),_) -> @@ -479,6 +510,10 @@ let full_section_segment_of_constant con = (*************) (* Sections. *) +(* XML output hooks *) +let (f_xml_open_section, xml_open_section) = Hook.make ~default:ignore () +let (f_xml_close_section, xml_close_section) = Hook.make ~default:ignore () + let open_section id = let olddir,(mp,oldsec) = !path_prefix in let dir = add_dirpath_suffix olddir id in @@ -490,6 +525,7 @@ let open_section id = (*Pushed for the lifetime of the section: removed by unfrozing the summary*) Nametab.push_dir (Nametab.Until 1) dir (DirOpenSection prefix); path_prefix := prefix; + if !Flags.xml_export then Hook.get f_xml_open_section id; add_section () @@ -518,6 +554,7 @@ let close_section () = let full_olddir = fst !path_prefix in pop_path_prefix (); add_entry oname (ClosedSection (List.rev (mark::secdecls))); + if !Flags.xml_export then Hook.get f_xml_close_section (basename (fst oname)); let newdecls = List.map discharge_item secdecls in Summary.unfreeze_summaries fs; List.iter (Option.iter (fun (id,o) -> add_discharged_leaf id o)) newdecls; diff --git a/library/lib.mli b/library/lib.mli index 9c4d26c5b..e2e71ac90 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -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 *) @@ -156,6 +157,10 @@ val unfreeze : frozen -> unit val init : unit -> unit +(** XML output hooks *) +val xml_open_section : (Names.Id.t -> unit) Hook.t +val xml_close_section : (Names.Id.t -> unit) Hook.t + (** {6 Section management for discharge } *) type variable_info = Names.Id.t * Decl_kinds.binding_kind * Term.constr option * Term.types @@ -163,7 +168,7 @@ type variable_context = variable_info list type abstr_info = variable_context * Univ.universe_level_subst * Univ.UContext.t val instance_from_variable_context : variable_context -> Names.Id.t array -val named_of_variable_context : variable_context -> Context.named_context +val named_of_variable_context : variable_context -> Context.Named.t val section_segment_of_constant : Names.constant -> abstr_info val section_segment_of_mutual_inductive: Names.mutual_inductive -> abstr_info @@ -172,10 +177,11 @@ 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_constant : bool (* is_projection *) -> - Names.constant -> Context.named_context -> unit -val add_section_kn : Names.mutual_inductive -> Context.named_context -> unit +val add_section_context : Univ.universe_context_set -> unit +val add_section_constant : Decl_kinds.polymorphic -> + Names.constant -> Context.Named.t -> unit +val add_section_kn : Decl_kinds.polymorphic -> + Names.mutual_inductive -> Context.Named.t -> unit val replacement_context : unit -> Opaqueproof.work_list (** {6 Discharge: decrease the section level if in the current section } *) @@ -188,6 +194,6 @@ val discharge_inductive : Names.inductive -> Names.inductive (* discharging a constant in one go *) val full_replacement_context : unit -> Opaqueproof.work_list list val full_section_segment_of_constant : - Names.constant -> (Context.named_context -> Context.named_context) list + Names.constant -> (Context.Named.t -> Context.Named.t) list diff --git a/library/libnames.ml b/library/libnames.ml index cdaec6a3d..99ff2f2fb 100644 --- a/library/libnames.ml +++ b/library/libnames.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -13,7 +13,7 @@ open Names (**********************************************) -let pr_dirpath sl = (str (DirPath.to_string sl)) +let pr_dirpath sl = str (DirPath.to_string sl) (*s Operations on dirpaths *) @@ -197,7 +197,7 @@ let string_of_reference = function let pr_reference = function | Qualid (_,qid) -> pr_qualid qid - | Ident (_,id) -> str (Id.to_string id) + | Ident (_,id) -> Id.print id let loc_of_reference = function | Qualid (loc,qid) -> loc diff --git a/library/libnames.mli b/library/libnames.mli index b95c08871..58d1da9d6 100644 --- a/library/libnames.mli +++ b/library/libnames.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -60,7 +60,7 @@ val path_of_string : string -> full_path val string_of_path : full_path -> string val pr_path : full_path -> std_ppcmds -module Spmap : Map.S with type key = full_path +module Spmap : CSig.MapS with type key = full_path val restrict_path : int -> full_path -> full_path diff --git a/library/libobject.ml b/library/libobject.ml index 2ee57baf9..bbbb134df 100644 --- a/library/libobject.ml +++ b/library/libobject.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,6 +8,9 @@ open Libnames open Pp +open Util + +module Dyn = Dyn.Make(struct end) (* 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 @@ -70,15 +73,25 @@ type dynamic_object_declaration = { dyn_discharge_function : object_name * obj -> obj option; dyn_rebuild_function : obj -> obj } -let object_tag = Dyn.tag -let object_has_tag = Dyn.has_tag +let object_tag (Dyn.Dyn (t, _)) = Dyn.repr t let cache_tab = (Hashtbl.create 17 : (string,dynamic_object_declaration) Hashtbl.t) +let make_dyn (type a) (tag : a Dyn.tag) = + let infun x = Dyn.Dyn (tag, x) in + let outfun : (Dyn.t -> a) = fun dyn -> + let Dyn.Dyn (t, x) = dyn in + match Dyn.eq t tag with + | None -> assert false + | Some Refl -> x + in + (infun, outfun) + let declare_object_full odecl = let na = odecl.object_name in - let (infun,outfun) = Dyn.create na in + let tag = Dyn.create na in + let (infun, outfun) = make_dyn tag in let cacher (oname,lobj) = odecl.cache_function (oname,outfun lobj) and loader i (oname,lobj) = odecl.load_function i (oname,outfun lobj) and opener i (oname,lobj) = odecl.open_function i (oname,outfun lobj) @@ -108,6 +121,9 @@ let declare_object_full odecl = 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) @@ -155,3 +171,5 @@ let discharge_object ((_,lobj) as node) = let rebuild_object lobj = apply_dyn_fun lobj (fun d -> d.dyn_rebuild_function lobj) lobj + +let dump = Dyn.dump diff --git a/library/libobject.mli b/library/libobject.mli index 099381897..dbe0de8f8 100644 --- a/library/libobject.mli +++ b/library/libobject.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -99,7 +99,6 @@ val declare_object : 'a object_declaration -> ('a -> obj) val object_tag : obj -> string -val object_has_tag : obj -> string -> bool val cache_object : object_name * obj -> unit val load_object : int -> object_name * obj -> unit @@ -109,3 +108,7 @@ val classify_object : obj -> obj substitutivity val discharge_object : object_name * obj -> obj option val rebuild_object : obj -> obj val relax : bool -> unit + +(** {6 Debug} *) + +val dump : unit -> (int * string) list diff --git a/library/library.ml b/library/library.ml index 024ac9e6f..8e2402dda 100644 --- a/library/library.ml +++ b/library/library.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -132,7 +132,7 @@ let try_find_library dir = try find_library dir with Not_found -> errorlabstrm "Library.find_library" - (str "Unknown library " ++ str (DirPath.to_string dir)) + (str "Unknown library " ++ pr_dirpath dir) let register_library_filename dir f = (* Not synchronized: overwrite the previous binding if one existed *) @@ -171,9 +171,8 @@ 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 - (* This will not produce errors or warnings if the native compiler was - not enabled *) - Nativelib.link_library ~prefix ~dirname ~basename:f + if not Coq_config.no_native_compiler then + Nativelib.link_library ~prefix ~dirname ~basename:f in let rec aux = function | [] -> link m; [libname] @@ -286,28 +285,18 @@ let locate_absolute_library dir = with Not_found -> [] in match find ".vo" @ find ".vio" with | [] -> raise LibNotFound - | [file] -> dir, file + | [file] -> file | [vo;vi] when Unix.((stat vo).st_mtime < (stat vi).st_mtime) -> msg_warning (str"Loading " ++ str vi ++ str " instead of " ++ str vo ++ str " because it is more recent"); - dir, vi - | [vo;vi] -> dir, vo + vi + | [vo;vi] -> vo | _ -> assert false let locate_qualified_library ?root ?(warn = true) qid = (* Search library in loadpath *) let dir, base = repr_qualid qid in - let loadpath = match root with - | None -> Loadpath.expand_path dir - | Some root -> - let filter path = - if is_dirpath_prefix_of root path then - let path = drop_dirpath_prefix root path in - is_dirpath_suffix_of dir path - else false - in - Loadpath.filter_path filter - in + let loadpath = Loadpath.expand_path ?root dir in let () = match loadpath with [] -> raise LibUnmappedDir | _ -> () in let find ext = try @@ -459,7 +448,7 @@ let intern_from_file f = module DPMap = Map.Make(DirPath) let rec intern_library (needed, contents) (dir, f) from = - Pp.feedback(Feedback.FileDependency (from, f)); + Pp.feedback(Feedback.FileDependency (from, DirPath.to_string dir)); (* Look if in the current logical environment *) try (find_library dir).libsum_digests, (needed, contents) with Not_found -> @@ -467,6 +456,7 @@ let rec intern_library (needed, contents) (dir, f) from = try (DPMap.find dir contents).library_digests, (needed, contents) with Not_found -> (* [dir] is an absolute name which matches [f] which must be in loadpath *) + let f = match f with Some f -> f | None -> try_locate_absolute_library dir in let m = intern_from_file f in if not (DirPath.equal dir m.library_name) then errorlabstrm "load_physical_library" @@ -481,13 +471,13 @@ and intern_library_deps libs dir m from = (dir :: needed, DPMap.add dir m contents ) and intern_mandatory_library caller from libs (dir,d) = - let digest, libs = intern_library libs (try_locate_absolute_library dir) from in + let digest, libs = intern_library libs (dir, None) from in if not (Safe_typing.digest_match ~actual:digest ~required:d) then - errorlabstrm "" (str "Compiled library " ++ str (DirPath.to_string caller) ++ str ".vo makes inconsistent assumptions over library " ++ str (DirPath.to_string dir)); + errorlabstrm "" (str "Compiled library " ++ pr_dirpath caller ++ str ".vo makes inconsistent assumptions over library " ++ pr_dirpath dir); libs -let rec_intern_library libs mref = - let _, libs = intern_library libs mref None in +let rec_intern_library libs (dir, f) = + let _, libs = intern_library libs (dir, Some f) None in libs let native_name_from_filename f = @@ -555,6 +545,8 @@ let in_require : require_obj -> obj = (* Require libraries, import them if [export <> None], mark them for export if [export = Some true] *) +let (f_xml_require, xml_require) = Hook.make ~default:ignore () + let require_library_from_dirpath modrefl export = let needed, contents = List.fold_left rec_intern_library ([], DPMap.empty) modrefl in let needed = List.rev_map (fun dir -> DPMap.find dir contents) needed in @@ -568,6 +560,7 @@ let require_library_from_dirpath modrefl export = end else add_anonymous_leaf (in_require (needed,modrefl,export)); + if !Flags.xml_export then List.iter (Hook.get f_xml_require) modrefl; add_frozen_state () (* the function called by Vernacentries.vernac_import *) @@ -576,7 +569,7 @@ 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) ++ str " is not a module") + (loc,"import_library", pr_qualid qid ++ str " is not a module") let import_module export modl = (* Optimization: libraries in a raw in the list are imported @@ -601,7 +594,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) ++ str " is not a module")) + pr_qualid dir ++ str " is not a module")) | [] -> flush acc in aux [] modl @@ -611,9 +604,9 @@ let import_module export modl = let check_coq_overwriting p id = let l = DirPath.repr p in 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 + if not !Flags.boot && not is_empty && Id.equal (List.last l) coq_root then errorlabstrm "" - (str "Cannot build module " ++ str (DirPath.to_string p) ++ str "." ++ pr_id id ++ str "." ++ spc () ++ + (str "Cannot build module " ++ pr_dirpath 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 @@ -778,13 +771,6 @@ let save_library_raw f sum lib univs proofs = System.marshal_out_segment f' ch (proofs : seg_proofs); close_out ch -(************************************************************************) -(*s Display the memory use of a library. *) - -open Printf - -let mem s = Pp.mt () - module StringOrd = struct type t = string let compare = String.compare end module StringSet = Set.Make(StringOrd) diff --git a/library/library.mli b/library/library.mli index d5e610dd6..8f5b775d8 100644 --- a/library/library.mli +++ b/library/library.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -67,6 +67,9 @@ val library_full_filename : DirPath.t -> string (** - Overwrite the filename of all libraries (used when restoring a state) *) val overwrite_library_filenames : string -> unit +(** {6 Hook for the xml exportation of libraries } *) +val xml_require : (DirPath.t -> unit) Hook.t + (** {6 Locate a library in the load paths } *) exception LibUnmappedDir exception LibNotFound @@ -82,8 +85,5 @@ val locate_qualified_library : *) -(** {6 Statistics: display the memory use of a library. } *) -val mem : DirPath.t -> Pp.std_ppcmds - (** {6 Native compiler. } *) val native_name_from_filename : string -> string diff --git a/library/loadpath.ml b/library/loadpath.ml index 622d390a2..f8169576d 100644 --- a/library/loadpath.ml +++ b/library/loadpath.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -84,10 +84,6 @@ let add_load_path phys_path coq_path ~implicit = end | _ -> anomaly_too_many_paths phys_path -let extend_path_with_dirpath p dir = - List.fold_left Filename.concat p - (List.rev_map Id.to_string (DirPath.repr dir)) - let filter_path f = let rec aux = function | [] -> [] @@ -97,18 +93,19 @@ let filter_path f = in aux !load_paths -let expand_path dir = +let expand_path ?root dir = let rec aux = function | [] -> [] - | { path_physical = ph; path_logical = lg; path_implicit = implicit } :: l -> - match implicit with - | true -> - (** The path is implicit, so that we only want match the logical suffix *) - if is_dirpath_suffix_of dir lg then (ph, lg) :: aux l else aux l - | false -> - (** Otherwise we must match exactly *) - if DirPath.equal dir lg then (ph, lg) :: aux l else aux l - in + | { path_physical = ph; path_logical = lg; path_implicit = implicit } :: l -> + let success = + match root with + | None -> + if implicit then is_dirpath_suffix_of dir lg + else DirPath.equal dir lg + | Some root -> + is_dirpath_prefix_of root lg && + is_dirpath_suffix_of dir (drop_dirpath_prefix root lg) in + if success then (ph, lg) :: aux l else aux l in aux !load_paths let locate_file fname = diff --git a/library/loadpath.mli b/library/loadpath.mli index 269e28e0b..4e79edbdc 100644 --- a/library/loadpath.mli +++ b/library/loadpath.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -42,7 +42,7 @@ val find_load_path : CUnix.physical_path -> t val is_in_load_paths : CUnix.physical_path -> bool (** Whether a physical path is currently bound. *) -val expand_path : DirPath.t -> (CUnix.physical_path * DirPath.t) list +val expand_path : ?root:DirPath.t -> DirPath.t -> (CUnix.physical_path * DirPath.t) list (** Given a relative logical path, associate the list of absolute physical and logical paths which are possible matches of it. *) diff --git a/library/nameops.ml b/library/nameops.ml index 3a23ab97d..71405d024 100644 --- a/library/nameops.ml +++ b/library/nameops.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -12,7 +12,7 @@ open Names (* Identifiers *) -let pr_id id = str (Id.to_string id) +let pr_id id = Id.print id let pr_name = function | Anonymous -> str "_" @@ -141,7 +141,7 @@ let name_max na1 na2 = | Name _ -> na1 | Anonymous -> na2 -let pr_lab l = str (Label.to_string l) +let pr_lab l = Label.print l let default_library = Names.DirPath.initial (* = ["Top"] *) diff --git a/library/nameops.mli b/library/nameops.mli index de1f99fe0..39ce409bc 100644 --- a/library/nameops.mli +++ b/library/nameops.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/library/nametab.ml b/library/nametab.ml index 5b6d7cd98..bbae98fc0 100644 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -523,7 +523,7 @@ let shortest_qualid_of_tactic kn = KnTab.shortest_qualid Id.Set.empty sp !the_tactictab let pr_global_env env ref = - try str (string_of_qualid (shortest_qualid_of_global env ref)) + try pr_qualid (shortest_qualid_of_global env ref) with Not_found as e -> if !Flags.debug then Pp.msg_debug (Pp.str "pr_global_env not found"); raise e diff --git a/library/nametab.mli b/library/nametab.mli index e3aeb6757..a8a0572b3 100644 --- a/library/nametab.mli +++ b/library/nametab.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/library/states.ml b/library/states.ml index 3cb6da12e..2e1be764a 100644 --- a/library/states.ml +++ b/library/states.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/library/states.mli b/library/states.mli index 4d5d63e03..12c71c999 100644 --- a/library/states.mli +++ b/library/states.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/library/summary.ml b/library/summary.ml index 8e2abbf15..19e7e5fd9 100644 --- a/library/summary.ml +++ b/library/summary.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -10,6 +10,8 @@ open Pp open Errors open Util +module Dyn = Dyn.Make(struct end) + type marshallable = [ `Yes | `No | `Shallow ] type 'a summary_declaration = { freeze_function : marshallable -> 'a; @@ -20,8 +22,19 @@ let summaries = ref Int.Map.empty let mangle id = id ^ "-SUMMARY" +let make_dyn (type a) (tag : a Dyn.tag) = + let infun x = Dyn.Dyn (tag, x) in + let outfun : (Dyn.t -> a) = fun dyn -> + let Dyn.Dyn (t, x) = dyn in + match Dyn.eq t tag with + | None -> assert false + | Some Refl -> x + in + (infun, outfun) + let internal_declare_summary hash sumname sdecl = - let (infun, outfun) = Dyn.create (mangle sumname) in + let tag = Dyn.create (mangle sumname) in + let (infun, outfun) = make_dyn tag in let dyn_freeze b = infun (sdecl.freeze_function b) and dyn_unfreeze sum = sdecl.unfreeze_function (outfun sum) and dyn_init = sdecl.init_function in @@ -164,8 +177,15 @@ let project_summary { summaries; ml_module } ?(complement=false) ids = List.filter (fun (id, _) -> List.mem id ids) summaries let pointer_equal l1 l2 = + let ptr_equal d1 d2 = + let Dyn.Dyn (t1, x1) = d1 in + let Dyn.Dyn (t2, x2) = d2 in + match Dyn.eq t1 t2 with + | None -> false + | Some Refl -> x1 == x2 + in CList.for_all2eq - (fun (id1,v1) (id2,v2) -> id1 = id2 && Dyn.pointer_equal v1 v2) l1 l2 + (fun (id1,v1) (id2,v2) -> id1 = id2 && ptr_equal v1 v2) l1 l2 (** All-in-one reference declaration + registration *) @@ -176,3 +196,5 @@ let ref ?(freeze=fun _ r -> r) ~name x = unfreeze_function = ((:=) r); init_function = (fun () -> r := x) }; r + +let dump = Dyn.dump diff --git a/library/summary.mli b/library/summary.mli index 48c9390d0..27889cab2 100644 --- a/library/summary.mli +++ b/library/summary.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -71,3 +71,7 @@ val unfreeze_summary : frozen_bits -> unit val surgery_summary : frozen -> frozen_bits -> frozen val project_summary : frozen -> ?complement:bool -> string list -> frozen_bits val pointer_equal : frozen_bits -> frozen_bits -> bool + +(** {6 Debug} *) + +val dump : unit -> (int * string) list diff --git a/library/universes.ml b/library/universes.ml index fe5730e95..c4eb2afcb 100644 --- a/library/universes.ml +++ b/library/universes.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -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,20 @@ 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 @@ -85,6 +102,7 @@ module Constraints = struct end type universe_constraints = Constraints.t +type 'a constraint_accumulator = universe_constraints -> 'a -> 'a option type 'a universe_constrained = 'a * universe_constraints type 'a universe_constraint_function = 'a -> 'a -> universe_constraints -> universe_constraints @@ -124,76 +142,70 @@ let to_constraints g s = "to_constraints: non-trivial algebraic constraint between universes") in Constraints.fold tr s Constraint.empty -let eq_constr_univs_infer univs m n = - if m == n then true, Constraints.empty +let eq_constr_univs_infer univs fold m n accu = + if m == n then Some accu else - let cstrs = ref Constraints.empty in + let cstrs = ref accu in let eq_universes strict = UGraph.check_eq_instances 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 UGraph.check_eq univs u1 u2 then true - else - (cstrs := Constraints.add (u1, UEq, u2) !cstrs; - true) + match fold (Constraints.singleton (u1, UEq, u2)) !cstrs with + | None -> false + | Some accu -> cstrs := accu; true in let rec eq_constr' 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 + if res then Some !cstrs else None (** 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 = +let eq_constr_univs_infer_with kind1 kind2 univs fold m n accu = (* 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 cstrs = ref accu in let eq_universes strict = UGraph.check_eq_instances 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 UGraph.check_eq univs u1 u2 then true - else - (cstrs := Constraints.add (u1, UEq, u2) !cstrs; - true) + match fold (Constraints.singleton (u1, UEq, u2)) !cstrs with + | None -> false + | Some accu -> cstrs := accu; 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 + if res then Some !cstrs else None -let leq_constr_univs_infer univs m n = - if m == n then true, Constraints.empty +let leq_constr_univs_infer univs fold m n accu = + if m == n then Some accu else - let cstrs = ref Constraints.empty in + let cstrs = ref accu in let eq_universes strict l l' = UGraph.check_eq_instances univs l l' 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 UGraph.check_eq univs u1 u2 then true - else (cstrs := Constraints.add (u1, UEq, u2) !cstrs; - true) + match fold (Constraints.singleton (u1, UEq, u2)) !cstrs with + | None -> false + | Some accu -> cstrs := accu; 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 UGraph.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) + match fold (Constraints.singleton (u1, ULe, u2)) !cstrs with + | None -> false + | Some accu -> cstrs := accu; true in let rec eq_constr' m n = m == n || Constr.compare_head_gen eq_universes eq_sorts eq_constr' m n @@ -203,7 +215,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 + if res then Some !cstrs else None let eq_constr_universes m n = if m == n then true, Constraints.empty @@ -633,14 +645,14 @@ let normalize_univ_variable_opt_subst ectx = in let update l b = assert (match Universe.level b with Some l' -> not (Level.equal l l') | None -> true); - ectx := Univ.LMap.add l (Some b) !ectx; b + try ectx := Univ.LMap.add l (Some b) !ectx; b with Not_found -> assert false in normalize_univ_variable ~find ~update let normalize_univ_variable_subst subst = let find l = Univ.LMap.find l !subst in let update l b = assert (match Universe.level b with Some l' -> not (Level.equal l l') | None -> true); - subst := Univ.LMap.add l b !subst; b in + try subst := Univ.LMap.update l b !subst; b with Not_found -> assert false in normalize_univ_variable ~find ~update let normalize_universe_opt_subst subst = @@ -803,7 +815,7 @@ let minimize_univ_variables ctx us algs left right cstrs = let cstrs' = List.fold_left (fun cstrs (d, r) -> if d == Univ.Le then enforce_leq inst (Universe.make r) cstrs - else + else try let lev = Option.get (Universe.level inst) in Constraint.add (lev, d, r) cstrs with Option.IsNone -> failwith "") @@ -837,7 +849,7 @@ let normalize_context_set ctx us algs = 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 + if is_set_minimization () && LSet.mem r ctx then (Constraint.add cstr smallles, noneqs) else (smallles, noneqs) else if Level.is_small r then @@ -887,22 +899,28 @@ let normalize_context_set ctx us algs = 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 -> + let ctx, subst, us, eqs = List.fold_left (fun (ctx, subst, us, cstrs) s -> let canon, (global, rigid, flexible) = choose_canonical ctx flex algs s in (* Add equalities for globals which can't be merged anymore. *) let cstrs = LSet.fold (fun g cst -> Constraint.add (canon, Univ.Eq, g) cst) global cstrs in + (* Also add equalities for rigid variables *) + let cstrs = LSet.fold (fun g cst -> + Constraint.add (canon, Univ.Eq, g) cst) rigid + 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) flexible subst in - (LSet.diff (LSet.diff ctx rigid) flexible, subst, cstrs)) - (ctx, LMap.empty, Constraint.empty) partition + let subst = LSet.fold (fun f -> LMap.add f canon) flexible subst in + let canonu = Some (Universe.make canon) in + let us = LSet.fold (fun f -> LMap.add f canonu) flexible us in + (LSet.diff ctx flexible, subst, us, cstrs)) + (ctx, LMap.empty, us, Constraint.empty) partition in (* Noneqs is now in canonical form w.r.t. equality constraints, and contains only inequality constraints. *) let noneqs = subst_univs_level_constraints subst noneqs in - let us = LMap.fold (fun u v acc -> LMap.add u (Some (Universe.make v)) acc) subst us in (* Compute the left and right set of flexible variables, constraints mentionning other variables remain in noneqs. *) let noneqs, ucstrsl, ucstrsr = @@ -936,10 +954,10 @@ let universes_of_constr c = let rec aux s c = match kind_of_term c with | Const (_, u) | Ind (_, u) | Construct (_, u) -> - LSet.union (Instance.levels u) s + LSet.fold LSet.add (Instance.levels u) s | Sort u when not (Sorts.is_small u) -> let u = univ_of_sort u in - LSet.union (Universe.levels u) s + LSet.fold LSet.add (Universe.levels u) s | _ -> fold_constr aux s c in aux LSet.empty c diff --git a/library/universes.mli b/library/universes.mli index cfa0ad0c1..53cf5f384 100644 --- a/library/universes.mli +++ b/library/universes.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -14,9 +14,10 @@ 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 @@ -25,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 @@ -55,6 +63,7 @@ module Constraints : sig end type universe_constraints = Constraints.t +type 'a constraint_accumulator = universe_constraints -> 'a -> 'a option type 'a universe_constrained = 'a * universe_constraints type 'a universe_constraint_function = 'a -> 'a -> universe_constraints -> universe_constraints @@ -67,7 +76,8 @@ val to_constraints : UGraph.t -> universe_constraints -> constraints (** [eq_constr_univs_infer u a b] is [true, c] if [a] equals [b] modulo alpha, casts, application grouping, the universe constraints in [u] and additional constraints [c]. *) -val eq_constr_univs_infer : UGraph.t -> constr -> constr -> bool universe_constrained +val eq_constr_univs_infer : UGraph.t -> 'a constraint_accumulator -> + constr -> constr -> 'a -> 'a option (** [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 @@ -75,12 +85,13 @@ val eq_constr_univs_infer : UGraph.t -> constr -> constr -> bool universe_constr val eq_constr_univs_infer_with : (constr -> (constr,types) kind_of_term) -> (constr -> (constr,types) kind_of_term) -> - UGraph.t -> constr -> constr -> bool universe_constrained + UGraph.t -> 'a constraint_accumulator -> constr -> constr -> 'a -> 'a option (** [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]. *) -val leq_constr_univs_infer : UGraph.t -> constr -> constr -> bool universe_constrained +val leq_constr_univs_infer : UGraph.t -> 'a constraint_accumulator -> + constr -> constr -> 'a -> 'a option (** [eq_constr_universes a b] [true, c] if [a] equals [b] modulo alpha, casts, application grouping and the universe constraints in [c]. *) diff --git a/tactics/coretactics.ml4 b/ltac/coretactics.ml4 index e909a14c9..6c02a7202 100644 --- a/tactics/coretactics.ml4 +++ b/ltac/coretactics.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -13,11 +13,20 @@ open Names open Locus open Misctypes open Genredexpr +open Stdarg +open Constrarg +open Extraargs +open Pcoq.Constr +open Pcoq.Prim +open Pcoq.Tactic open Proofview.Notations +open Sigma.Notations DECLARE PLUGIN "coretactics" +(** Basic tactics *) + TACTIC EXTEND reflexivity [ "reflexivity" ] -> [ Tactics.intros_reflexivity ] END @@ -42,6 +51,10 @@ TACTIC EXTEND vm_cast_no_check [ "vm_cast_no_check" constr(c) ] -> [ Proofview.V82.tactic (Tactics.vm_cast_no_check c) ] END +TACTIC EXTEND native_cast_no_check + [ "native_cast_no_check" constr(c) ] -> [ Proofview.V82.tactic (Tactics.native_cast_no_check c) ] +END + TACTIC EXTEND casetype [ "casetype" constr(c) ] -> [ Tactics.case_type c ] END @@ -70,15 +83,13 @@ END TACTIC EXTEND left_with [ "left" "with" bindings(bl) ] -> [ - let { Evd.sigma = sigma ; it = bl } = bl in - Tacticals.New.tclWITHHOLES false (Tactics.left_with_bindings false bl) sigma + Tacticals.New.tclDELAYEDWITHHOLES false bl (fun bl -> Tactics.left_with_bindings false bl) ] END TACTIC EXTEND eleft_with [ "eleft" "with" bindings(bl) ] -> [ - let { Evd.sigma = sigma ; it = bl } = bl in - Tacticals.New.tclWITHHOLES true (Tactics.left_with_bindings true bl) sigma + Tacticals.New.tclDELAYEDWITHHOLES true bl (fun bl -> Tactics.left_with_bindings true bl) ] END @@ -94,15 +105,13 @@ END TACTIC EXTEND right_with [ "right" "with" bindings(bl) ] -> [ - let { Evd.sigma = sigma ; it = bl } = bl in - Tacticals.New.tclWITHHOLES false (Tactics.right_with_bindings false bl) sigma + Tacticals.New.tclDELAYEDWITHHOLES false bl (fun bl -> Tactics.right_with_bindings false bl) ] END TACTIC EXTEND eright_with [ "eright" "with" bindings(bl) ] -> [ - let { Evd.sigma = sigma ; it = bl } = bl in - Tacticals.New.tclWITHHOLES true (Tactics.right_with_bindings true bl) sigma + Tacticals.New.tclDELAYEDWITHHOLES true bl (fun bl -> Tactics.right_with_bindings true bl) ] END @@ -111,28 +120,22 @@ END TACTIC EXTEND constructor [ "constructor" ] -> [ Tactics.any_constructor false None ] | [ "constructor" int_or_var(i) ] -> [ - let i = Tacinterp.interp_int_or_var ist i in Tactics.constructor_tac false None i NoBindings ] | [ "constructor" int_or_var(i) "with" bindings(bl) ] -> [ - let { Evd.sigma = sigma; it = bl } = bl in - let i = Tacinterp.interp_int_or_var ist i in - let tac = Tactics.constructor_tac false None i bl in - Tacticals.New.tclWITHHOLES false tac sigma + let tac bl = Tactics.constructor_tac false None i bl in + Tacticals.New.tclDELAYEDWITHHOLES false bl tac ] END TACTIC EXTEND econstructor [ "econstructor" ] -> [ Tactics.any_constructor true None ] | [ "econstructor" int_or_var(i) ] -> [ - let i = Tacinterp.interp_int_or_var ist i in Tactics.constructor_tac true None i NoBindings ] | [ "econstructor" int_or_var(i) "with" bindings(bl) ] -> [ - let { Evd.sigma = sigma; it = bl } = bl in - let i = Tacinterp.interp_int_or_var ist i in - let tac = Tactics.constructor_tac true None i bl in - Tacticals.New.tclWITHHOLES true tac sigma + let tac bl = Tactics.constructor_tac true None i bl in + Tacticals.New.tclDELAYEDWITHHOLES true bl tac ] END @@ -140,18 +143,25 @@ END TACTIC EXTEND specialize [ "specialize" constr_with_bindings(c) ] -> [ - let { Evd.sigma = sigma; it = c } = c in - let specialize = Proofview.V82.tactic (Tactics.specialize c) in - Tacticals.New.tclWITHHOLES false specialize sigma + Tacticals.New.tclDELAYEDWITHHOLES false c Tactics.specialize ] END TACTIC EXTEND symmetry [ "symmetry" ] -> [ Tactics.intros_symmetry {onhyps=Some[];concl_occs=AllOccurrences} ] +| [ "symmetry" clause_dft_concl(cl) ] -> [ Tactics.intros_symmetry cl ] END (** Split *) +let rec delayed_list = function +| [] -> { Tacexpr.delayed = fun _ sigma -> Sigma.here [] sigma } +| x :: l -> + { Tacexpr.delayed = fun env sigma -> + let Sigma (x, sigma, p) = x.Tacexpr.delayed env sigma in + let Sigma (l, sigma, q) = (delayed_list l).Tacexpr.delayed env sigma in + Sigma (x :: l, sigma, p +> q) } + TACTIC EXTEND split [ "split" ] -> [ Tactics.split_with_bindings false [NoBindings] ] END @@ -162,15 +172,27 @@ END TACTIC EXTEND split_with [ "split" "with" bindings(bl) ] -> [ - let { Evd.sigma = sigma ; it = bl } = bl in - Tacticals.New.tclWITHHOLES false (Tactics.split_with_bindings false [bl]) sigma + Tacticals.New.tclDELAYEDWITHHOLES false bl (fun bl -> Tactics.split_with_bindings false [bl]) ] END TACTIC EXTEND esplit_with [ "esplit" "with" bindings(bl) ] -> [ - let { Evd.sigma = sigma ; it = bl } = bl in - Tacticals.New.tclWITHHOLES true (Tactics.split_with_bindings true [bl]) sigma + Tacticals.New.tclDELAYEDWITHHOLES true bl (fun bl -> Tactics.split_with_bindings true [bl]) + ] +END + +TACTIC EXTEND exists + [ "exists" ] -> [ Tactics.split_with_bindings false [NoBindings] ] +| [ "exists" ne_bindings_list_sep(bll, ",") ] -> [ + Tacticals.New.tclDELAYEDWITHHOLES false (delayed_list bll) (fun bll -> Tactics.split_with_bindings false bll) + ] +END + +TACTIC EXTEND eexists + [ "eexists" ] -> [ Tactics.split_with_bindings true [NoBindings] ] +| [ "eexists" ne_bindings_list_sep(bll, ",") ] -> [ + Tacticals.New.tclDELAYEDWITHHOLES true (delayed_list bll) (fun bll -> Tactics.split_with_bindings true bll) ] END @@ -180,6 +202,15 @@ TACTIC EXTEND intros_until [ "intros" "until" quantified_hypothesis(h) ] -> [ Tactics.intros_until h ] END +(** Move *) + +TACTIC EXTEND move + [ "move" hyp(id) "at" "top" ] -> [ Proofview.V82.tactic (Tactics.move_hyp id MoveFirst) ] +| [ "move" hyp(id) "at" "bottom" ] -> [ Proofview.V82.tactic (Tactics.move_hyp id MoveLast) ] +| [ "move" hyp(id) "after" hyp(h) ] -> [ Proofview.V82.tactic (Tactics.move_hyp id (MoveAfter h)) ] +| [ "move" hyp(id) "before" hyp(h) ] -> [ Proofview.V82.tactic (Tactics.move_hyp id (MoveBefore h)) ] +END + (** Revert *) TACTIC EXTEND revert @@ -202,6 +233,42 @@ TACTIC EXTEND admit [ "admit" ] -> [ Proofview.give_up ] END +(* Fix *) + +TACTIC EXTEND fix + [ "fix" natural(n) ] -> [ Proofview.V82.tactic (Tactics.fix None n) ] +| [ "fix" ident(id) natural(n) ] -> [ Proofview.V82.tactic (Tactics.fix (Some id) n) ] +END + +(* Cofix *) + +TACTIC EXTEND cofix + [ "cofix" ] -> [ Proofview.V82.tactic (Tactics.cofix None) ] +| [ "cofix" ident(id) ] -> [ Proofview.V82.tactic (Tactics.cofix (Some id)) ] +END + +(* Clear *) + +TACTIC EXTEND clear + [ "clear" hyp_list(ids) ] -> [ + if List.is_empty ids then Tactics.keep [] + else Proofview.V82.tactic (Tactics.clear ids) + ] +| [ "clear" "-" ne_hyp_list(ids) ] -> [ Tactics.keep ids ] +END + +(* Clearbody *) + +TACTIC EXTEND clearbody + [ "clearbody" ne_hyp_list(ids) ] -> [ Tactics.clear_body ids ] +END + +(* Generalize dependent *) + +TACTIC EXTEND generalize_dependent + [ "generalize" "dependent" constr(c) ] -> [ Proofview.V82.tactic (Tactics.generalize_dep c) ] +END + (* Table of "pervasives" macros tactics (e.g. auto, simpl, etc.) *) open Tacexpr @@ -220,9 +287,6 @@ let initial_atomic () = "compute", TacReduce(Cbv Redops.all_flags,nocl); "intro", TacIntroMove(None,MoveLast); "intros", TacIntroPattern []; - "cofix", TacCofix None; - "trivial", TacTrivial (Off,[],None); - "auto", TacAuto(Off,None,[],None); ] in let iter (s, t) = Tacenv.register_ltac false false (Id.of_string s) t in diff --git a/tactics/evar_tactics.ml b/ltac/evar_tactics.ml index c9fc01088..2e0996bf5 100644 --- a/tactics/evar_tactics.ml +++ b/ltac/evar_tactics.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -16,6 +16,7 @@ open Evd open Locus open Sigma.Notations open Proofview.Notations +open Context.Named.Declaration (* The instantiate tactic *) @@ -43,14 +44,14 @@ let instantiate_tac n c ido = match hloc with InHyp -> (match decl with - (_,None,typ) -> evar_list typ + | LocalAssum (_,typ) -> evar_list typ | _ -> error "Please be more specific: in type or value?") | InHypTypeOnly -> - let (_, _, typ) = decl in evar_list typ + evar_list (get_type decl) | InHypValueOnly -> (match decl with - (_,Some body,_) -> evar_list body + | LocalDef (_,body,_) -> evar_list body | _ -> error "Not a defined hypothesis.") in if List.length evl < n then error "Not enough uninstantiated existential variables."; @@ -70,8 +71,12 @@ let instantiate_tac_by_name id c = let let_evar name typ = let src = (Loc.ghost,Evar_kinds.GoalEvar) in - Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> + let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in + let sigma = ref sigma in + let _ = Typing.e_sort_of env sigma typ in + let sigma = Sigma.Unsafe.of_evar_map !sigma in let id = match name with | Names.Anonymous -> let id = Namegen.id_of_name_using_hdchar env typ name in diff --git a/tactics/evar_tactics.mli b/ltac/evar_tactics.mli index 2c4df0608..e67540c05 100644 --- a/tactics/evar_tactics.mli +++ b/ltac/evar_tactics.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/tactics/extraargs.ml4 b/ltac/extraargs.ml4 index 47987e9ea..4d3507cbc 100644 --- a/tactics/extraargs.ml4 +++ b/ltac/extraargs.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -10,6 +10,10 @@ open Pp open Genarg +open Stdarg +open Constrarg +open Pcoq.Prim +open Pcoq.Constr open Names open Tacexpr open Taccoerce @@ -17,6 +21,25 @@ open Tacinterp open Misctypes open Locus +(** Adding scopes for generic arguments not defined through ARGUMENT EXTEND *) + +let create_generic_quotation name e wit = + let inject (loc, v) = Tacexpr.TacGeneric (Genarg.in_gen (Genarg.rawwit wit) v) in + Tacentries.create_ltac_quotation name inject (e, None) + +let () = create_generic_quotation "integer" Pcoq.Prim.integer Stdarg.wit_int +let () = create_generic_quotation "string" Pcoq.Prim.string Stdarg.wit_string + +let () = create_generic_quotation "ident" Pcoq.Prim.ident Constrarg.wit_ident +let () = create_generic_quotation "reference" Pcoq.Prim.reference Constrarg.wit_ref +let () = create_generic_quotation "uconstr" Pcoq.Constr.lconstr Constrarg.wit_uconstr +let () = create_generic_quotation "constr" Pcoq.Constr.lconstr Constrarg.wit_constr +let () = create_generic_quotation "ipattern" Pcoq.Tactic.simple_intropattern Constrarg.wit_intro_pattern +let () = create_generic_quotation "open_constr" Pcoq.Constr.lconstr Constrarg.wit_open_constr +let () = + let inject (loc, v) = Tacexpr.Tacexp v in + Tacentries.create_ltac_quotation "ltac" inject (Pcoq.Tactic.tactic_expr, Some 5) + (* Rewriting orientation *) let _ = Metasyntax.add_token_obj "<-" @@ -32,6 +55,14 @@ ARGUMENT EXTEND orient TYPED AS bool PRINTED BY pr_orient | [ ] -> [ true ] END +let pr_int _ _ _ i = Pp.int i + +let _natural = Pcoq.Prim.natural + +ARGUMENT EXTEND natural TYPED AS int PRINTED BY pr_int +| [ _natural(i) ] -> [ i ] +END + let pr_orient = pr_orient () () () @@ -99,6 +130,8 @@ let interp_glob ist gl (t,_) = Tacmach.project gl , (ist,t) let glob_glob = Tacintern.intern_constr +let pr_lconstr _ prc _ c = prc c + let subst_glob = Tacsubst.subst_glob_constr_and_expr ARGUMENT EXTEND glob @@ -116,6 +149,14 @@ ARGUMENT EXTEND glob [ constr(c) ] -> [ c ] END +let l_constr = Pcoq.Constr.lconstr + +ARGUMENT EXTEND lconstr + TYPED AS constr + PRINTED BY pr_lconstr + [ l_constr(c) ] -> [ c ] +END + ARGUMENT EXTEND lglob PRINTED BY pr_globc diff --git a/tactics/extraargs.mli b/ltac/extraargs.mli index ef084e9d2..14aa69875 100644 --- a/tactics/extraargs.mli +++ b/ltac/extraargs.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -21,6 +21,8 @@ val wit_occurrences : (int list or_var, int list or_var, int list) Genarg.genarg val pr_occurrences : int list or_var -> Pp.std_ppcmds val occurrences_of : int list -> Locus.occurrences +val wit_natural : int Genarg.uniform_genarg_type + val wit_glob : (constr_expr, Tacexpr.glob_constr_and_expr, @@ -31,6 +33,11 @@ val wit_lglob : Tacexpr.glob_constr_and_expr, Tacinterp.interp_sign * glob_constr) Genarg.genarg_type +val wit_lconstr : + (constr_expr, + Tacexpr.glob_constr_and_expr, + Constr.t) Genarg.genarg_type + val glob : constr_expr Pcoq.Gram.entry val lglob : constr_expr Pcoq.Gram.entry @@ -47,13 +54,12 @@ val by_arg_tac : Tacexpr.raw_tactic_expr option Pcoq.Gram.entry val wit_by_arg_tac : (raw_tactic_expr option, glob_tactic_expr option, - glob_tactic_expr option) Genarg.genarg_type + Genarg.Val.t option) Genarg.genarg_type val pr_by_arg_tac : (int * Ppextend.parenRelation -> raw_tactic_expr -> Pp.std_ppcmds) -> raw_tactic_expr option -> Pp.std_ppcmds - (** Spiwack: Primitive for retroknowledge registration *) val retroknowledge_field : Retroknowledge.field Pcoq.Gram.entry diff --git a/tactics/extratactics.ml4 b/ltac/extratactics.ml4 index e1997c705..ba9f82fb9 100644 --- a/tactics/extratactics.ml4 +++ b/ltac/extratactics.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -10,7 +10,12 @@ open Pp open Genarg +open Stdarg +open Constrarg open Extraargs +open Pcoq.Prim +open Pcoq.Constr +open Pcoq.Tactic open Mod_subst open Names open Tacexpr @@ -19,6 +24,7 @@ open Tactics open Errors open Util open Evd +open Termops open Equality open Misctypes open Sigma.Notations @@ -30,34 +36,44 @@ DECLARE PLUGIN "extratactics" (* replace, discriminate, injection, simplify_eq *) (* cutrewrite, dependent rewrite *) -let replace_in_clause_maybe_by (sigma1,c1) c2 cl tac = - Tacticals.New.tclWITHHOLES false - (replace_in_clause_maybe_by c1 c2 cl (Option.map Tacinterp.eval_tactic tac)) - sigma1 +let with_delayed_uconstr ist c tac = + let flags = { + Pretyping.use_typeclasses = false; + use_unif_heuristics = true; + use_hook = Some Pfedit.solve_by_implicit_tactic; + fail_evar = false; + expand_evars = true + } in + let c = Pretyping.type_uconstr ~flags ist c in + Tacticals.New.tclDELAYEDWITHHOLES false c tac -let replace_term dir_opt (sigma,c) cl = - Tacticals.New.tclWITHHOLES false - (replace_term dir_opt c cl) - sigma +let replace_in_clause_maybe_by ist c1 c2 cl tac = + with_delayed_uconstr ist c1 + (fun c1 -> replace_in_clause_maybe_by c1 c2 cl (Option.map (Tacinterp.tactic_of_value ist) tac)) + +let replace_term ist dir_opt c cl = + with_delayed_uconstr ist c (fun c -> replace_term dir_opt c cl) + +let clause = Pcoq.Tactic.clause_dft_concl TACTIC EXTEND replace - ["replace" open_constr(c1) "with" constr(c2) clause(cl) by_arg_tac(tac) ] --> [ replace_in_clause_maybe_by c1 c2 cl tac ] + ["replace" uconstr(c1) "with" constr(c2) clause(cl) by_arg_tac(tac) ] +-> [ replace_in_clause_maybe_by ist c1 c2 cl tac ] END TACTIC EXTEND replace_term_left - [ "replace" "->" open_constr(c) clause(cl) ] - -> [ replace_term (Some true) c cl ] + [ "replace" "->" uconstr(c) clause(cl) ] + -> [ replace_term ist (Some true) c cl ] END TACTIC EXTEND replace_term_right - [ "replace" "<-" open_constr(c) clause(cl) ] - -> [ replace_term (Some false) c cl ] + [ "replace" "<-" uconstr(c) clause(cl) ] + -> [ replace_term ist (Some false) c cl ] END TACTIC EXTEND replace_term - [ "replace" open_constr(c) clause(cl) ] - -> [ replace_term None c cl ] + [ "replace" uconstr(c) clause(cl) ] + -> [ replace_term ist None c cl ] END let induction_arg_of_quantified_hyp = function @@ -69,8 +85,8 @@ let induction_arg_of_quantified_hyp = function ElimOnIdent and not as "constr" *) let elimOnConstrWithHoles tac with_evars c = - Tacticals.New.tclWITHHOLES with_evars - (tac with_evars (Some (None,ElimOnConstr c.it))) c.sigma + Tacticals.New.tclDELAYEDWITHHOLES with_evars c + (fun c -> tac with_evars (Some (None,ElimOnConstr c))) TACTIC EXTEND simplify_eq_main | [ "simplify_eq" constr_with_bindings(c) ] -> @@ -115,7 +131,7 @@ END open Proofview.Notations let discrHyp id = Proofview.tclEVARMAP >>= fun sigma -> - discr_main {it = Term.mkVar id,NoBindings; sigma = sigma;} + discr_main { delayed = fun env sigma -> Sigma.here (Term.mkVar id, NoBindings) sigma } let injection_main c = elimOnConstrWithHoles (injClause None) false c @@ -138,29 +154,29 @@ TACTIC EXTEND einjection | [ "einjection" quantified_hypothesis(h) ] -> [ injClause None true (Some (induction_arg_of_quantified_hyp h)) ] END TACTIC EXTEND injection_as_main -| [ "injection" constr_with_bindings(c) "as" simple_intropattern_list(ipat)] -> +| [ "injection" constr_with_bindings(c) "as" intropattern_list(ipat)] -> [ elimOnConstrWithHoles (injClause (Some ipat)) false c ] END TACTIC EXTEND injection_as -| [ "injection" "as" simple_intropattern_list(ipat)] -> +| [ "injection" "as" intropattern_list(ipat)] -> [ injClause (Some ipat) false None ] -| [ "injection" quantified_hypothesis(h) "as" simple_intropattern_list(ipat) ] -> +| [ "injection" quantified_hypothesis(h) "as" intropattern_list(ipat) ] -> [ injClause (Some ipat) false (Some (induction_arg_of_quantified_hyp h)) ] END TACTIC EXTEND einjection_as_main -| [ "einjection" constr_with_bindings(c) "as" simple_intropattern_list(ipat)] -> +| [ "einjection" constr_with_bindings(c) "as" intropattern_list(ipat)] -> [ elimOnConstrWithHoles (injClause (Some ipat)) true c ] END TACTIC EXTEND einjection_as -| [ "einjection" "as" simple_intropattern_list(ipat)] -> +| [ "einjection" "as" intropattern_list(ipat)] -> [ injClause (Some ipat) true None ] -| [ "einjection" quantified_hypothesis(h) "as" simple_intropattern_list(ipat) ] -> +| [ "einjection" quantified_hypothesis(h) "as" intropattern_list(ipat) ] -> [ injClause (Some ipat) true (Some (induction_arg_of_quantified_hyp h)) ] END let injHyp id = Proofview.tclEVARMAP >>= fun sigma -> - injection_main { it = Term.mkVar id,NoBindings; sigma = sigma; } + injection_main { delayed = fun env sigma -> Sigma.here (Term.mkVar id, NoBindings) sigma } TACTIC EXTEND dependent_rewrite | [ "dependent" "rewrite" orient(b) constr(c) ] -> [ rewriteInConcl b c ] @@ -200,7 +216,7 @@ END let onSomeWithHoles tac = function | None -> tac None - | Some c -> Tacticals.New.tclWITHHOLES false (tac (Some c.it)) c.sigma + | Some c -> Tacticals.New.tclDELAYEDWITHHOLES false c (fun c -> tac (Some c)) TACTIC EXTEND contradiction [ "contradiction" constr_with_bindings_opt(c) ] -> @@ -228,7 +244,7 @@ TACTIC EXTEND autorewrite [ auto_multi_rewrite l ( cl) ] | [ "autorewrite" "with" ne_preident_list(l) clause(cl) "using" tactic(t) ] -> [ - auto_multi_rewrite_with (Tacinterp.eval_tactic t) l cl + auto_multi_rewrite_with (Tacinterp.tactic_of_value ist t) l cl ] END @@ -236,28 +252,28 @@ TACTIC EXTEND autorewrite_star | [ "autorewrite" "*" "with" ne_preident_list(l) clause(cl) ] -> [ auto_multi_rewrite ~conds:AllMatches l cl ] | [ "autorewrite" "*" "with" ne_preident_list(l) clause(cl) "using" tactic(t) ] -> - [ auto_multi_rewrite_with ~conds:AllMatches (Tacinterp.eval_tactic t) l cl ] + [ auto_multi_rewrite_with ~conds:AllMatches (Tacinterp.tactic_of_value ist t) l cl ] END (**********************************************************************) (* Rewrite star *) -let rewrite_star clause orient occs (sigma,c) (tac : glob_tactic_expr option) = - let tac' = Option.map (fun t -> Tacinterp.eval_tactic t, FirstSolved) tac in - Tacticals.New.tclWITHHOLES false - (general_rewrite_ebindings_clause clause orient occs ?tac:tac' true true (c,NoBindings) true) sigma +let rewrite_star ist clause orient occs c (tac : Val.t option) = + let tac' = Option.map (fun t -> Tacinterp.tactic_of_value ist t, FirstSolved) tac in + with_delayed_uconstr ist c + (fun c -> general_rewrite_ebindings_clause clause orient occs ?tac:tac' true true (c,NoBindings) true) TACTIC EXTEND rewrite_star -| [ "rewrite" "*" orient(o) open_constr(c) "in" hyp(id) "at" occurrences(occ) by_arg_tac(tac) ] -> - [ rewrite_star (Some id) o (occurrences_of occ) c tac ] -| [ "rewrite" "*" orient(o) open_constr(c) "at" occurrences(occ) "in" hyp(id) by_arg_tac(tac) ] -> - [ rewrite_star (Some id) o (occurrences_of occ) c tac ] -| [ "rewrite" "*" orient(o) open_constr(c) "in" hyp(id) by_arg_tac(tac) ] -> - [ rewrite_star (Some id) o Locus.AllOccurrences c tac ] -| [ "rewrite" "*" orient(o) open_constr(c) "at" occurrences(occ) by_arg_tac(tac) ] -> - [ rewrite_star None o (occurrences_of occ) c tac ] -| [ "rewrite" "*" orient(o) open_constr(c) by_arg_tac(tac) ] -> - [ rewrite_star None o Locus.AllOccurrences c tac ] +| [ "rewrite" "*" orient(o) uconstr(c) "in" hyp(id) "at" occurrences(occ) by_arg_tac(tac) ] -> + [ rewrite_star ist (Some id) o (occurrences_of occ) c tac ] +| [ "rewrite" "*" orient(o) uconstr(c) "at" occurrences(occ) "in" hyp(id) by_arg_tac(tac) ] -> + [ rewrite_star ist (Some id) o (occurrences_of occ) c tac ] +| [ "rewrite" "*" orient(o) uconstr(c) "in" hyp(id) by_arg_tac(tac) ] -> + [ rewrite_star ist (Some id) o Locus.AllOccurrences c tac ] +| [ "rewrite" "*" orient(o) uconstr(c) "at" occurrences(occ) by_arg_tac(tac) ] -> + [ rewrite_star ist None o (occurrences_of occ) c tac ] +| [ "rewrite" "*" orient(o) uconstr(c) by_arg_tac(tac) ] -> + [ rewrite_star ist None o Locus.AllOccurrences c tac ] END (**********************************************************************) @@ -266,7 +282,7 @@ TACTIC EXTEND rewrite_star let add_rewrite_hint bases ort t lcsr = let env = Global.env() in let sigma = Evd.from_env env in - let poly = Flags.is_universe_polymorphism () in + let poly = Flags.use_polymorphic_flag () in let f ce = let c, ctx = Constrintern.interp_constr env sigma ce in let ctx = @@ -274,7 +290,7 @@ let add_rewrite_hint bases ort t lcsr = 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 + Constrexpr_ops.constr_loc ce, (c, ctx), ort, Option.map (in_gen (rawwit wit_ltac)) t in let eqs = List.map f lcsr in let add_hints base = add_rew_rules base eqs in List.iter add_hints bases @@ -314,7 +330,7 @@ let project_hint pri l2r r = | _ -> assert false in let p = if l2r then build_coq_iff_left_proj () else build_coq_iff_right_proj () in - let c = Reductionops.whd_beta Evd.empty (mkApp (c,Termops.extended_rel_vect 0 sign)) in + let c = Reductionops.whd_beta Evd.empty (mkApp (c, Context.Rel.to_extended_vect 0 sign)) in let c = it_mkLambda_or_LetIn (mkApp (p,[|mkArrow a (lift 1 b);mkArrow b (lift 1 a);c|])) sign in let id = @@ -346,27 +362,27 @@ END (**********************************************************************) (* Refine *) -let refine_tac {Glob_term.closure=closure;term=term} = +let refine_tac ist simple c = Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in let flags = Pretyping.all_no_fail_flags in - let tycon = Pretyping.OfType concl in - let lvar = { Pretyping.empty_lvar with - Pretyping.ltac_constrs = closure.Glob_term.typed; - Pretyping.ltac_uconstrs = closure.Glob_term.untyped; - Pretyping.ltac_idents = closure.Glob_term.idents; - } in - let update = { run = begin fun sigma -> - let sigma = Sigma.to_evar_map sigma in - let (sigma, c) = Pretyping.understand_ltac flags env sigma lvar tycon term in - Sigma.Unsafe.of_pair (c, sigma) - end } in - Tactics.New.refine ~unsafe:false update + let expected_type = Pretyping.OfType concl in + let c = Pretyping.type_uconstr ~flags ~expected_type ist c in + let update = { run = fun sigma -> c.delayed env sigma } in + let refine = Refine.refine ~unsafe:false update in + if simple then refine + else refine <*> + Tactics.New.reduce_after_refine <*> + Proofview.shelve_unifiable end } TACTIC EXTEND refine - [ "refine" uconstr(c) ] -> [ refine_tac c ] +| [ "refine" uconstr(c) ] -> [ refine_tac ist false c ] +END + +TACTIC EXTEND simple_refine +| [ "simple" "refine" uconstr(c) ] -> [ refine_tac ist true c ] END (**********************************************************************) @@ -503,12 +519,12 @@ let add_transitivity_lemma left lem = (* Vernacular syntax *) TACTIC EXTEND stepl -| ["stepl" constr(c) "by" tactic(tac) ] -> [ step true c (Tacinterp.eval_tactic tac) ] +| ["stepl" constr(c) "by" tactic(tac) ] -> [ step true c (Tacinterp.tactic_of_value ist tac) ] | ["stepl" constr(c) ] -> [ step true c (Proofview.tclUNIT ()) ] END TACTIC EXTEND stepr -| ["stepr" constr(c) "by" tactic(tac) ] -> [ step false c (Tacinterp.eval_tactic tac) ] +| ["stepr" constr(c) "by" tactic(tac) ] -> [ step false c (Tacinterp.tactic_of_value ist tac) ] | ["stepr" constr(c) ] -> [ step false c (Proofview.tclUNIT ()) ] END @@ -613,12 +629,9 @@ let subst_hole_with_term occ tc t = open Tacmach -let out_arg = function - | ArgVar _ -> anomaly (Pp.str "Unevaluated or_var variable") - | ArgArg x -> x - let hResolve id c occ t = - Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in let sigma = Sigma.to_evar_map sigma in let env = Termops.clear_named_body id (Proofview.Goal.env gl) in let concl = Proofview.Goal.concl gl in @@ -654,7 +667,7 @@ let hResolve_auto id c t = resolve_auto 1 TACTIC EXTEND hresolve_core -| [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "at" int_or_var(occ) "in" constr(t) ] -> [ hResolve id c (out_arg occ) t ] +| [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "at" int_or_var(occ) "in" constr(t) ] -> [ hResolve id c occ t ] | [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "in" constr(t) ] -> [ hResolve_auto id c t ] END @@ -676,7 +689,7 @@ let hget_evar n = end } TACTIC EXTEND hget_evar -| [ "hget_evar" int_or_var(n) ] -> [ hget_evar (out_arg n) ] +| [ "hget_evar" int_or_var(n) ] -> [ hget_evar n ] END (**********************************************************************) @@ -714,12 +727,13 @@ let mkCaseEq a : unit Proofview.tactic = Proofview.Goal.nf_enter { enter = begin fun gl -> 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.V82.tactic (Tactics.generalize [mkApp(delayed_force refl_equal, [| type_of_a; a|])]); Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in - change_concl - (snd (Tacred.pattern_occs [Locus.OnlyOccurrences [1], a] env Evd.empty concl)) + (** FIXME: this looks really wrong. Does anybody really use this tactic? *) + let Sigma (c, _, _) = (Tacred.pattern_occs [Locus.OnlyOccurrences [1], a]).Reductionops.e_redfun env (Sigma.Unsafe.of_evar_map Evd.empty) concl in + change_concl c end }; simplest_case a] end } @@ -745,11 +759,14 @@ let case_eq_intros_rewrite x = end } let rec find_a_destructable_match t = + let cl = induction_arg_of_quantified_hyp (NamedHyp (Id.of_string "x")) in + let cl = [cl, (None, None), None], None in + let dest = TacAtom (Loc.ghost, TacInductionDestruct(false, false, cl)) in match kind_of_term t with | Case (_,_,x,_) when closed0 x -> if isVar x then (* TODO check there is no rel n. *) - raise (Found (Tacinterp.eval_tactic(<:tactic<destruct x>>))) + raise (Found (Tacinterp.eval_tactic dest)) else (* let _ = Pp.msgnl (Printer.pr_lconstr x) in *) raise (Found (case_eq_intros_rewrite x)) @@ -872,6 +889,16 @@ TACTIC EXTEND shelve_unifiable [ Proofview.shelve_unifiable ] END +(* Unshelves the goal shelved by the tactic. *) +TACTIC EXTEND unshelve +| [ "unshelve" tactic1(t) ] -> + [ + Proofview.with_shelf (Tacinterp.tactic_of_value ist t) >>= fun (gls, ()) -> + Proofview.Unsafe.tclGETGOALS >>= fun ogls -> + Proofview.Unsafe.tclSETGOALS (gls @ ogls) + ] +END + (* Command to add every unshelved variables to the focus *) VERNAC COMMAND EXTEND Unshelve [ "Unshelve" ] @@ -889,12 +916,12 @@ END (* cycles [n] goals *) TACTIC EXTEND cycle -| [ "cycle" int_or_var(n) ] -> [ Proofview.cycle (out_arg n) ] +| [ "cycle" int_or_var(n) ] -> [ Proofview.cycle n ] END (* swaps goals number [i] and [j] *) TACTIC EXTEND swap -| [ "swap" int_or_var(i) int_or_var(j) ] -> [ Proofview.swap (out_arg i) (out_arg j) ] +| [ "swap" int_or_var(i) int_or_var(j) ] -> [ Proofview.swap i j ] END (* reverses the list of focused goals *) @@ -911,9 +938,9 @@ type cmp = type 'i test = | Test of cmp * 'i * 'i -let wit_cmp : (cmp,cmp,cmp) Genarg.genarg_type = Genarg.make0 None "cmp" +let wit_cmp : (cmp,cmp,cmp) Genarg.genarg_type = Genarg.make0 "cmp" let wit_test : (int or_var test,int or_var test,int test) Genarg.genarg_type = - Genarg.make0 None "tactest" + Genarg.make0 "tactest" let pr_cmp = function | Eq -> Pp.str"=" diff --git a/tactics/extratactics.mli b/ltac/extratactics.mli index 72c2679c0..18334dafe 100644 --- a/tactics/extratactics.mli +++ b/ltac/extratactics.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -11,4 +11,4 @@ val injHyp : Names.Id.t -> unit Proofview.tactic (* val refine_tac : Evd.open_constr -> unit Proofview.tactic *) -val onSomeWithHoles : ('a option -> unit Proofview.tactic) -> 'a Evd.sigma option -> unit Proofview.tactic +val onSomeWithHoles : ('a option -> unit Proofview.tactic) -> 'a Tacexpr.delayed_open option -> unit Proofview.tactic diff --git a/ltac/g_auto.ml4 b/ltac/g_auto.ml4 new file mode 100644 index 000000000..bc98b7d6d --- /dev/null +++ b/ltac/g_auto.ml4 @@ -0,0 +1,211 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) + +(*i camlp4deps: "grammar/grammar.cma" i*) + +open Pp +open Genarg +open Stdarg +open Constrarg +open Pcoq.Prim +open Pcoq.Constr +open Pcoq.Tactic +open Tacexpr + +DECLARE PLUGIN "g_auto" + +(* Hint bases *) + + +TACTIC EXTEND eassumption +| [ "eassumption" ] -> [ Eauto.e_assumption ] +END + +TACTIC EXTEND eexact +| [ "eexact" constr(c) ] -> [ Eauto.e_give_exact c ] +END + +let pr_hintbases _prc _prlc _prt = Pptactic.pr_hintbases + +ARGUMENT EXTEND hintbases + TYPED AS preident_list_opt + PRINTED BY pr_hintbases +| [ "with" "*" ] -> [ None ] +| [ "with" ne_preident_list(l) ] -> [ Some l ] +| [ ] -> [ Some [] ] +END + +let eval_uconstrs ist cs = + let flags = { + Pretyping.use_typeclasses = false; + use_unif_heuristics = true; + use_hook = Some Pfedit.solve_by_implicit_tactic; + fail_evar = false; + expand_evars = true + } in + List.map (fun c -> Pretyping.type_uconstr ~flags ist c) cs + +let pr_auto_using _ _ _ = Pptactic.pr_auto_using (fun _ -> mt ()) + +ARGUMENT EXTEND auto_using + TYPED AS uconstr_list + PRINTED BY pr_auto_using +| [ "using" ne_uconstr_list_sep(l, ",") ] -> [ l ] +| [ ] -> [ [] ] +END + +(** Auto *) + +TACTIC EXTEND trivial +| [ "trivial" auto_using(lems) hintbases(db) ] -> + [ Auto.h_trivial (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND info_trivial +| [ "info_trivial" auto_using(lems) hintbases(db) ] -> + [ Auto.h_trivial ~debug:Info (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND debug_trivial +| [ "debug" "trivial" auto_using(lems) hintbases(db) ] -> + [ Auto.h_trivial ~debug:Debug (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND auto +| [ "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> + [ Auto.h_auto n (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND info_auto +| [ "info_auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> + [ Auto.h_auto ~debug:Info n (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND debug_auto +| [ "debug" "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> + [ Auto.h_auto ~debug:Debug n (eval_uconstrs ist lems) db ] +END + +(** Eauto *) + +TACTIC EXTEND prolog +| [ "prolog" "[" uconstr_list(l) "]" int_or_var(n) ] -> + [ Eauto.prolog_tac (eval_uconstrs ist l) n ] +END + +let make_depth n = snd (Eauto.make_dimension n None) + +TACTIC EXTEND eauto +| [ "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) + hintbases(db) ] -> + [ Eauto.gen_eauto (Eauto.make_dimension n p) (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND new_eauto +| [ "new" "auto" int_or_var_opt(n) auto_using(lems) + hintbases(db) ] -> + [ match db with + | None -> Auto.new_full_auto (make_depth n) (eval_uconstrs ist lems) + | Some l -> Auto.new_auto (make_depth n) (eval_uconstrs ist lems) l ] +END + +TACTIC EXTEND debug_eauto +| [ "debug" "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) + hintbases(db) ] -> + [ Eauto.gen_eauto ~debug:Debug (Eauto.make_dimension n p) (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND info_eauto +| [ "info_eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) + hintbases(db) ] -> + [ Eauto.gen_eauto ~debug:Info (Eauto.make_dimension n p) (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND dfs_eauto +| [ "dfs" "eauto" int_or_var_opt(p) auto_using(lems) + hintbases(db) ] -> + [ Eauto.gen_eauto (Eauto.make_dimension p None) (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND autounfold +| [ "autounfold" hintbases(db) clause_dft_concl(cl) ] -> [ Eauto.autounfold_tac db cl ] +END + +TACTIC EXTEND autounfold_one +| [ "autounfold_one" hintbases(db) "in" hyp(id) ] -> + [ Eauto.autounfold_one (match db with None -> ["core"] | Some x -> "core"::x) (Some (id, Locus.InHyp)) ] +| [ "autounfold_one" hintbases(db) ] -> + [ Eauto.autounfold_one (match db with None -> ["core"] | Some x -> "core"::x) None ] + END + +TACTIC EXTEND autounfoldify +| [ "autounfoldify" constr(x) ] -> [ + let db = match Term.kind_of_term x with + | Term.Const (c,_) -> Names.Label.to_string (Names.con_label c) + | _ -> assert false + in Eauto.autounfold ["core";db] Locusops.onConcl + ] +END + +TACTIC EXTEND unify +| ["unify" constr(x) constr(y) ] -> [ Tactics.unify x y ] +| ["unify" constr(x) constr(y) "with" preident(base) ] -> [ + let table = try Some (Hints.searchtable_map base) with Not_found -> None in + match table with + | None -> + let msg = str "Hint table " ++ str base ++ str " not found" in + Tacticals.New.tclZEROMSG msg + | Some t -> + let state = Hints.Hint_db.transparent_state t in + Tactics.unify ~state x y + ] +END + + +TACTIC EXTEND convert_concl_no_check +| ["convert_concl_no_check" constr(x) ] -> [ Tactics.convert_concl_no_check x Term.DEFAULTcast ] +END + +let pr_hints_path_atom _ _ _ = Hints.pp_hints_path_atom + +ARGUMENT EXTEND hints_path_atom + TYPED AS hints_path_atom + PRINTED BY pr_hints_path_atom +| [ global_list(g) ] -> [ Hints.PathHints (List.map Nametab.global g) ] +| [ "*" ] -> [ Hints.PathAny ] +END + +let pr_hints_path prc prx pry c = Hints.pp_hints_path c + +ARGUMENT EXTEND hints_path + TYPED AS hints_path + PRINTED BY pr_hints_path +| [ "(" hints_path(p) ")" ] -> [ p ] +| [ "!" hints_path(p) ] -> [ Hints.PathStar p ] +| [ "emp" ] -> [ Hints.PathEmpty ] +| [ "eps" ] -> [ Hints.PathEpsilon ] +| [ hints_path_atom(a) ] -> [ Hints.PathAtom a ] +| [ hints_path(p) "|" hints_path(q) ] -> [ Hints.PathOr (p, q) ] +| [ hints_path(p) ";" hints_path(q) ] -> [ Hints.PathSeq (p, q) ] +END + +let pr_hintbases _prc _prlc _prt = Pptactic.pr_hintbases + +ARGUMENT EXTEND opthints + TYPED AS preident_list_opt + PRINTED BY pr_hintbases +| [ ":" ne_preident_list(l) ] -> [ Some l ] +| [ ] -> [ None ] +END + +VERNAC COMMAND EXTEND HintCut CLASSIFIED AS SIDEFF +| [ "Hint" "Cut" "[" hints_path(p) "]" opthints(dbnames) ] -> [ + let entry = Hints.HintsCutEntry p in + Hints.add_hints (Locality.make_section_locality (Locality.LocalityFixme.consume ())) + (match dbnames with None -> ["core"] | Some l -> l) entry ] +END diff --git a/tactics/g_class.ml4 b/ltac/g_class.ml4 index a55da35ef..9ef154541 100644 --- a/tactics/g_class.ml4 +++ b/ltac/g_class.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -10,11 +10,16 @@ open Misctypes open Class_tactics +open Pcoq.Prim +open Pcoq.Constr +open Pcoq.Tactic +open Stdarg +open Constrarg DECLARE PLUGIN "g_class" TACTIC EXTEND progress_evars - [ "progress_evars" tactic(t) ] -> [ progress_evars (Tacinterp.eval_tactic t) ] + [ "progress_evars" tactic(t) ] -> [ progress_evars (Tacinterp.tactic_of_value ist t) ] END (** Options: depth, debug and transparency settings. *) diff --git a/tactics/g_eqdecide.ml4 b/ltac/g_eqdecide.ml4 index 1bd8f075f..905653281 100644 --- a/tactics/g_eqdecide.ml4 +++ b/ltac/g_eqdecide.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/parsing/g_ltac.ml4 b/ltac/g_ltac.ml4 index a4dba506d..b55ac9ad0 100644 --- a/parsing/g_ltac.ml4 +++ b/ltac/g_ltac.ml4 @@ -1,11 +1,14 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +(*i camlp4deps: "grammar/grammar.cma" i*) + +open Util open Pp open Compat open Constrexpr @@ -28,12 +31,51 @@ let arg_of_expr = function let genarg_of_unit () = in_gen (rawwit Stdarg.wit_unit) () let genarg_of_int n = in_gen (rawwit Stdarg.wit_int) n let genarg_of_ipattern pat = in_gen (rawwit Constrarg.wit_intro_pattern) pat +let genarg_of_uconstr c = in_gen (rawwit Constrarg.wit_uconstr) c + +let reference_to_id = function + | Libnames.Ident (loc, id) -> (loc, id) + | Libnames.Qualid (loc,_) -> + Errors.user_err_loc (loc, "", + str "This expression should be a simple identifier.") + +let tactic_mode = Gram.entry_create "vernac:tactic_command" + +let new_entry name = + let e = Gram.entry_create name in + let entry = Entry.create name in + let () = Pcoq.set_grammar entry e in + e + +let selector = new_entry "vernac:selector" +let tacdef_body = new_entry "tactic:tacdef_body" + +(* Registers the Classic Proof Mode (which uses [tactic_mode] as a parser for + proof editing and changes nothing else). Then sets it as the default proof mode. *) +let _ = + let mode = { + Proof_global.name = "Classic"; + set = (fun () -> set_command_entry tactic_mode); + reset = (fun () -> set_command_entry Pcoq.Vernac_.noedit_mode); + } in + Proof_global.register_proof_mode mode + +(* 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) (* Tactics grammar rules *) GEXTEND Gram GLOBAL: tactic tacdef_body tactic_expr binder_tactic tactic_arg - constr_may_eval constr_eval; + tactic_mode constr_may_eval constr_eval selector; tactic_then_last: [ [ "|"; lta = LIST0 OPT tactic_expr SEP "|" -> @@ -105,10 +147,8 @@ GEXTEND Gram | g=failkw; n = [ n = int_or_var -> n | -> fail_default_value ]; l = LIST0 message_token -> TacFail (g,n,l) | st = simple_tactic -> st - | IDENT "constr"; ":"; c = Constr.constr -> - TacArg(!@loc,ConstrMayEval(ConstrTerm c)) - | a = tactic_top_or_arg -> TacArg(!@loc,a) - | r = reference; la = LIST0 tactic_arg -> + | a = tactic_arg -> TacArg(!@loc,a) + | r = reference; la = LIST0 tactic_arg_compat -> TacArg(!@loc,TacCall (!@loc,r,la)) ] | "0" [ "("; a = tactic_expr; ")" -> a @@ -132,23 +172,17 @@ GEXTEND Gram body = tactic_expr LEVEL "5" -> TacLetIn (isrec,llc,body) | IDENT "info"; tc = tactic_expr LEVEL "5" -> TacInfo tc ] ] ; - (* Tactic arguments *) - tactic_arg: - [ [ IDENT "ltac"; ":"; a = tactic_expr LEVEL "0" -> arg_of_expr a - | IDENT "ltac"; ":"; n = natural -> TacGeneric (genarg_of_int n) - | a = tactic_top_or_arg -> a + (* Tactic arguments to the right of an application *) + tactic_arg_compat: + [ [ a = tactic_arg -> a | r = reference -> Reference r | c = Constr.constr -> ConstrMayEval (ConstrTerm c) (* Unambigous entries: tolerated w/o "ltac:" modifier *) - | id = METAIDENT -> MetaIdArg (!@loc,true,id) | "()" -> TacGeneric (genarg_of_unit ()) ] ] ; (* Can be used as argument and at toplevel in tactic expressions. *) - tactic_top_or_arg: - [ [ IDENT "uconstr"; ":" ; c = uconstr -> UConstr c - | IDENT "ipattern"; ":"; ipat = simple_intropattern -> - TacGeneric (genarg_of_ipattern ipat) - | c = constr_eval -> ConstrMayEval c + tactic_arg: + [ [ c = constr_eval -> ConstrMayEval c | IDENT "fresh"; l = LIST0 fresh_id -> TacFreshId l | IDENT "type_term"; c=uconstr -> TacPretype c | IDENT "numgoals" -> TacNumgoals ] ] @@ -173,8 +207,7 @@ GEXTEND Gram | c = Constr.constr -> ConstrTerm c ] ] ; tactic_atom: - [ [ id = METAIDENT -> MetaIdArg (!@loc,true,id) - | n = integer -> TacGeneric (genarg_of_int n) + [ [ n = integer -> TacGeneric (genarg_of_int n) | r = reference -> TacCall (!@loc,r,[]) | "()" -> TacGeneric (genarg_of_unit ()) ] ] ; @@ -250,11 +283,148 @@ GEXTEND Gram (* Definitions for tactics *) tacdef_body: [ [ name = Constr.global; it=LIST1 input_fun; redef = ltac_def_kind; body = tactic_expr -> - (name, redef, TacFun (it, body)) + if redef then Vernacexpr.TacticRedefinition (name, TacFun (it, body)) + else + let id = reference_to_id name in + Vernacexpr.TacticDefinition (id, TacFun (it, body)) | name = Constr.global; redef = ltac_def_kind; body = tactic_expr -> - (name, redef, body) ] ] + if redef then Vernacexpr.TacticRedefinition (name, body) + else + let id = reference_to_id name in + Vernacexpr.TacticDefinition (id, body) + ] ] ; tactic: [ [ tac = tactic_expr -> tac ] ] ; + selector: + [ [ n=natural; ":" -> Vernacexpr.SelectNth n + | test_bracket_ident; "["; id = ident; "]"; ":" -> Vernacexpr.SelectId id + | IDENT "all" ; ":" -> Vernacexpr.SelectAll ] ] + ; + tactic_mode: + [ [ g = OPT selector; tac = G_vernac.subgoal_command -> tac g ] ] + ; END + +open Stdarg +open Constrarg +open Vernacexpr +open Vernac_classifier +open Goptions +open Libnames + +let print_info_trace = ref None + +let _ = declare_int_option { + optsync = true; + optdepr = false; + optname = "print info trace"; + optkey = ["Info" ; "Level"]; + optread = (fun () -> !print_info_trace); + optwrite = fun n -> print_info_trace := n; +} + +let vernac_solve n info tcom b = + let status = Proof_global.with_current_proof (fun etac p -> + let with_end_tac = if b then Some etac else None in + let global = match n with SelectAll -> true | _ -> false in + let info = Option.append info !print_info_trace in + let (p,status) = + Pfedit.solve n info (Tacinterp.hide_interp global tcom None) ?with_end_tac p + in + (* in case a strict subtree was completed, + go back to the top of the prooftree *) + let p = Proof.maximal_unfocus Vernacentries.command_focus p in + p,status) in + if not status then Pp.feedback Feedback.AddedAxiom + +let pr_ltac_selector = function +| SelectNth i -> int i ++ str ":" +| SelectId id -> str "[" ++ Nameops.pr_id id ++ str "]" ++ str ":" +| SelectAll -> str "all" ++ str ":" + +VERNAC ARGUMENT EXTEND ltac_selector PRINTED BY pr_ltac_selector +| [ selector(s) ] -> [ s ] +END + +let pr_ltac_info n = str "Info" ++ spc () ++ int n + +VERNAC ARGUMENT EXTEND ltac_info PRINTED BY pr_ltac_info +| [ "Info" natural(n) ] -> [ n ] +END + +let pr_ltac_use_default b = if b then str ".." else mt () + +VERNAC ARGUMENT EXTEND ltac_use_default PRINTED BY pr_ltac_use_default +| [ "." ] -> [ false ] +| [ "..." ] -> [ true ] +END + +VERNAC tactic_mode EXTEND VernacSolve +| [ - ltac_selector_opt(g) ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => + [ classify_as_proofstep ] -> [ + let g = Option.default (Proof_global.get_default_goal_selector ()) g in + vernac_solve g n t def + ] +| [ - "par" ":" ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => + [ VtProofStep true, VtLater ] -> [ + vernac_solve SelectAll n t def + ] +END + +let pr_ltac_tactic_level n = str "(at level " ++ int n ++ str ")" + +VERNAC ARGUMENT EXTEND ltac_tactic_level PRINTED BY pr_ltac_tactic_level +| [ "(" "at" "level" natural(n) ")" ] -> [ n ] +END + +VERNAC ARGUMENT EXTEND ltac_production_sep +| [ "," string(sep) ] -> [ sep ] +END + +let pr_ltac_production_item = function +| TacTerm s -> quote (str s) +| TacNonTerm (_, arg, (id, sep)) -> + let sep = match sep with + | "" -> mt () + | sep -> str "," ++ spc () ++ quote (str sep) + in + str arg ++ str "(" ++ Nameops.pr_id id ++ sep ++ str ")" + +VERNAC ARGUMENT EXTEND ltac_production_item PRINTED BY pr_ltac_production_item +| [ string(s) ] -> [ TacTerm s ] +| [ ident(nt) "(" ident(p) ltac_production_sep_opt(sep) ")" ] -> + [ TacNonTerm (loc, Names.Id.to_string nt, (p, Option.default "" sep)) ] +END + +VERNAC COMMAND EXTEND VernacTacticNotation +| [ "Tactic" "Notation" ltac_tactic_level_opt(n) ne_ltac_production_item_list(r) ":=" tactic(e) ] => + [ VtUnknown, VtNow ] -> + [ + let l = Locality.LocalityFixme.consume () in + let n = Option.default 0 n in + Tacentries.add_tactic_notation (Locality.make_module_locality l, n, r, e) + ] +END + +VERNAC COMMAND EXTEND VernacPrintLtac CLASSIFIED AS QUERY +| [ "Print" "Ltac" reference(r) ] -> + [ msg_notice (Tacintern.print_ltac (snd (Libnames.qualid_of_reference r))) ] +END + +VERNAC ARGUMENT EXTEND ltac_tacdef_body +| [ tacdef_body(t) ] -> [ t ] +END + +VERNAC COMMAND EXTEND VernacDeclareTacticDefinition +| [ "Ltac" ne_ltac_tacdef_body_list_sep(l, "with") ] => [ + VtSideff (List.map (function + | TacticDefinition ((_,r),_) -> r + | TacticRedefinition (Ident (_,r),_) -> r + | TacticRedefinition (Qualid (_,q),_) -> snd(repr_qualid q)) l), VtLater + ] -> [ + let lc = Locality.LocalityFixme.consume () in + Tacentries.register_ltac (Locality.make_module_locality lc) l + ] +END diff --git a/toplevel/g_obligations.ml4 b/ltac/g_obligations.ml4 index 24661e124..4cd8bf1fe 100644 --- a/toplevel/g_obligations.ml4 +++ b/ltac/g_obligations.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -16,13 +16,25 @@ open Libnames open Constrexpr open Constrexpr_ops +open Stdarg +open Constrarg +open Extraargs + +let (set_default_tactic, get_default_tactic, print_default_tactic) = + Tactic_option.declare_tactic_option "Program tactic" + +let () = + (** Delay to recover the tactic imperatively *) + let tac = Proofview.tclBIND (Proofview.tclUNIT ()) begin fun () -> + snd (get_default_tactic ()) + end in + Obligations.default_tactic := tac (* We define new entries for programs, with the use of this module * Subtac. These entries are named Subtac.<foo> *) module Gram = Pcoq.Gram -module Vernac = Pcoq.Vernac_ module Tactic = Pcoq.Tactic open Pcoq @@ -32,9 +44,9 @@ let sigref = mkRefC (Qualid (Loc.ghost, Libnames.qualid_of_string "Coq.Init.Spec type 'a withtac_argtype = (Tacexpr.raw_tactic_expr option, 'a) Genarg.abstract_argument_type let wit_withtac : Tacexpr.raw_tactic_expr option Genarg.uniform_genarg_type = - Genarg.create_arg None "withtac" + Genarg.create_arg "withtac" -let withtac = Pcoq.create_generic_entry "withtac" (Genarg.rawwit wit_withtac) +let withtac = Pcoq.create_generic_entry Pcoq.utactic "withtac" (Genarg.rawwit wit_withtac) GEXTEND Gram GLOBAL: withtac; @@ -57,11 +69,11 @@ open Obligations let classify_obbl _ = Vernacexpr.(VtStartProof ("Classic",Doesn'tGuaranteeOpacity,[]), VtLater) VERNAC COMMAND EXTEND Obligations CLASSIFIED BY classify_obbl -| [ "Obligation" integer(num) "of" ident(name) ":" lconstr(t) withtac(tac) ] -> +| [ "Obligation" integer(num) "of" ident(name) ":" lglob(t) withtac(tac) ] -> [ obligation (num, Some name, Some t) tac ] | [ "Obligation" integer(num) "of" ident(name) withtac(tac) ] -> [ obligation (num, Some name, None) tac ] -| [ "Obligation" integer(num) ":" lconstr(t) withtac(tac) ] -> +| [ "Obligation" integer(num) ":" lglob(t) withtac(tac) ] -> [ obligation (num, None, Some t) tac ] | [ "Obligation" integer(num) withtac(tac) ] -> [ obligation (num, None, None) tac ] diff --git a/tactics/g_rewrite.ml4 b/ltac/g_rewrite.ml4 index d60cc1268..c4ef1f297 100644 --- a/tactics/g_rewrite.ml4 +++ b/ltac/g_rewrite.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -20,6 +20,11 @@ open Extraargs open Tacmach open Tacticals open Rewrite +open Stdarg +open Constrarg +open Pcoq.Prim +open Pcoq.Constr +open Pcoq.Tactic DECLARE PLUGIN "g_rewrite" @@ -184,9 +189,9 @@ END type binders_argtype = local_binder list let wit_binders = - (Genarg.create_arg None "binders" : binders_argtype Genarg.uniform_genarg_type) + (Genarg.create_arg "binders" : binders_argtype Genarg.uniform_genarg_type) -let binders = Pcoq.create_generic_entry "binders" (Genarg.rawwit wit_binders) +let binders = Pcoq.create_generic_entry Pcoq.utactic "binders" (Genarg.rawwit wit_binders) open Pcoq @@ -261,3 +266,7 @@ TACTIC EXTEND setoid_transitivity [ "setoid_transitivity" constr(t) ] -> [ setoid_transitivity (Some t) ] | [ "setoid_etransitivity" ] -> [ setoid_transitivity None ] END + +VERNAC COMMAND EXTEND PrintRewriteHintDb CLASSIFIED AS QUERY + [ "Print" "Rewrite" "HintDb" preident(s) ] -> [ Pp.msg_notice (Autorewrite.print_rewrite_hintdb s) ] +END diff --git a/ltac/ltac.mllib b/ltac/ltac.mllib new file mode 100644 index 000000000..e0c6f3ac0 --- /dev/null +++ b/ltac/ltac.mllib @@ -0,0 +1,19 @@ +Tacsubst +Tacenv +Tactic_debug +Tacintern +Tacentries +Tacinterp +Evar_tactics +Tactic_option +Extraargs +G_obligations +Coretactics +Extratactics +G_auto +G_class +Rewrite +G_rewrite +Tauto +G_eqdecide +G_ltac diff --git a/tactics/rewrite.ml b/ltac/rewrite.ml index 648d68f27..cf2a01052 100644 --- a/tactics/rewrite.ml +++ b/ltac/rewrite.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4deps: "grammar/grammar.cma" i*) - open Names open Pp open Errors @@ -36,6 +34,7 @@ open Termops open Libnames open Sigma.Notations open Proofview.Notations +open Context.Named.Declaration (** Typeclass-based generalized rewriting. *) @@ -44,6 +43,10 @@ open Proofview.Notations let classes_dirpath = Names.DirPath.make (List.map Id.of_string ["Classes";"Coq"]) +let init_relation_classes () = + if is_dirpath_prefix_of classes_dirpath (Lib.cwd ()) then () + else Coqlib.check_required_library ["Coq";"Classes";"RelationClasses"] + let init_setoid () = if is_dirpath_prefix_of classes_dirpath (Lib.cwd ()) then () else Coqlib.check_required_library ["Coq";"Setoids";"Setoid"] @@ -64,8 +67,10 @@ type evars = evar_map * Evar.Set.t (* goal evars, constraint evars *) let find_global dir s = let gr = lazy (try_find_global_reference dir s) in - fun (evd,cstrs) -> - let evd, c = Evarutil.new_global evd (Lazy.force gr) in + fun (evd,cstrs) -> + let sigma = Sigma.Unsafe.of_evar_map evd in + let Sigma (c, sigma, _) = Evarutil.new_global sigma (Lazy.force gr) in + let evd = Sigma.to_evar_map sigma in (evd, cstrs), c (** Utility for dealing with polymorphic applications *) @@ -105,7 +110,7 @@ let extends_undefined evars evars' = let app_poly_check env evars f args = let (evars, cstrs), fc = f evars in let evdref = ref evars in - let t = Typing.solve_evars env evdref (mkApp (fc, args)) in + let t = Typing.e_solve_evars env evdref (mkApp (fc, args)) in (!evdref, cstrs), t let app_poly_nocheck env evars f args = @@ -134,6 +139,7 @@ module GlobalBindings (M : sig val arrow : evars -> evars * constr end) = struct open M + open Context.Rel.Declaration let relation : evars -> evars * constr = find_global (fst relation) (snd relation) let reflexive_type = find_global relation_classes "Reflexive" @@ -172,13 +178,17 @@ end) = struct let proper_type = let l = lazy (Lazy.force proper_class).cl_impl in fun (evd,cstrs) -> - let evd, c = Evarutil.new_global evd (Lazy.force l) in + let sigma = Sigma.Unsafe.of_evar_map evd in + let Sigma (c, sigma, _) = Evarutil.new_global sigma (Lazy.force l) in + let evd = Sigma.to_evar_map sigma in (evd, cstrs), c let proper_proxy_type = let l = lazy (Lazy.force proper_proxy_class).cl_impl in fun (evd,cstrs) -> - let evd, c = Evarutil.new_global evd (Lazy.force l) in + let sigma = Sigma.Unsafe.of_evar_map evd in + let Sigma (c, sigma, _) = Evarutil.new_global sigma (Lazy.force l) in + let evd = Sigma.to_evar_map sigma in (evd, cstrs), c let proper_proof env evars carrier relation x = @@ -219,8 +229,8 @@ end) = struct let evars, newarg = app_poly env evars respectful [| ty ; b' ; relty ; arg |] in evars, mkProd(na, ty, b), newarg, (ty, Some relty) :: cstrs else - let (evars, b, arg, cstrs) = - aux (Environ.push_rel (na, None, ty) env) evars b cstrs + let (evars, b, arg, cstrs) = + aux (Environ.push_rel (LocalAssum (na, ty)) env) evars b cstrs in let ty = Reductionops.nf_betaiota (goalevars evars) ty in let pred = mkLambda (na, ty, b) in @@ -318,7 +328,7 @@ end) = struct let evars, rb = aux evars env b' (pred n) in app_poly env evars pointwise_relation [| ty; b'; rb |] else - let evars, rb = aux evars (Environ.push_rel (na, None, ty) env) b (pred n) in + let evars, rb = aux evars (Environ.push_rel (LocalAssum (na, ty)) env) b (pred n) in app_poly env evars forall_relation [| ty; mkLambda (na, ty, b); mkLambda (na, ty, rb) |] | _ -> raise Not_found @@ -347,7 +357,9 @@ end) = struct (try let params, args = Array.chop (Array.length args - 2) args in let env' = Environ.push_rel_context rels env in - let evars, (evar, _) = Evarutil.new_type_evar env' sigma Evd.univ_flexible in + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma ((evar, _), evars, _) = Evarutil.new_type_evar env' sigma Evd.univ_flexible in + let evars = Sigma.to_evar_map evars in let evars, inst = app_poly env (evars,Evar.Set.empty) rewrite_relation_class [| evar; mkApp (c, params) |] in @@ -407,7 +419,9 @@ module TypeGlobal = struct let inverse env (evd,cstrs) car rel = - let evd, (sort,_) = Evarutil.new_type_evar env evd Evd.univ_flexible in + let sigma = Sigma.Unsafe.of_evar_map evd in + let Sigma (sort, sigma, _) = Evarutil.new_Type ~rigid:Evd.univ_flexible env sigma in + let evd = Sigma.to_evar_map sigma in app_poly_check env (evd,cstrs) coq_inverse [| car ; car; sort; rel |] end @@ -450,6 +464,8 @@ type hypinfo = { let get_symmetric_proof b = if b then PropGlobal.get_symmetric_proof else TypeGlobal.get_symmetric_proof +let error_no_relation () = error "Cannot find a relation to rewrite." + let rec decompose_app_rel env evd t = (** Head normalize for compatibility with the old meta mechanism *) let t = Reductionops.whd_betaiota evd t in @@ -465,10 +481,18 @@ let rec decompose_app_rel env evd t = | App (f, args) -> let len = Array.length args in let fargs = Array.sub args 0 (Array.length args - 2) in - mkApp (f, fargs), args.(len - 2), args.(len - 1) - | _ -> error "Cannot find a relation to rewrite." + let rel = mkApp (f, fargs) in + rel, args.(len - 2), args.(len - 1) + | _ -> error_no_relation () + +let decompose_app_rel env evd t = + let (rel, t1, t2) = decompose_app_rel env evd t in + let ty = Retyping.get_type_of env evd rel in + let () = if not (Reduction.is_arity env ty) then error_no_relation () in + (rel, t1, t2) let decompose_applied_relation env sigma (c,l) = + let open Context.Rel.Declaration in let ctype = Retyping.get_type_of env sigma c in let find_rel ty = let sigma, cl = Clenv.make_evar_clause env sigma ty in @@ -491,7 +515,7 @@ let decompose_applied_relation env sigma (c,l) = | Some c -> c | None -> let ctx,t' = Reductionops.splay_prod env sigma ctype in (* Search for underlying eq *) - match find_rel (it_mkProd_or_LetIn t' (List.map (fun (n,t) -> n, None, t) ctx)) with + match find_rel (it_mkProd_or_LetIn t' (List.map (fun (n,t) -> LocalAssum (n, t)) ctx)) with | Some c -> c | None -> error "Cannot find an homogeneous relation to rewrite." @@ -588,7 +612,10 @@ let solve_remaining_by env sigma holes by = in (** Only solve independent holes *) let indep = List.map_filter map holes in - let solve_tac = Tacticals.New.tclCOMPLETE (Tacinterp.eval_tactic tac) in + let ist = { Geninterp.lfun = Id.Map.empty; extra = Geninterp.TacStore.empty } in + let solve_tac = Geninterp.generic_interp ist tac in + let solve_tac = Ftactic.run solve_tac (fun _ -> Proofview.tclUNIT ()) in + let solve_tac = Tacticals.New.tclCOMPLETE solve_tac in let solve sigma evk = let evi = try Some (Evd.find_undefined sigma evk) @@ -766,9 +793,9 @@ let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' (b,cstr) ev else TypeGlobal.do_subrelation, TypeGlobal.apply_subrelation in Environ.push_named - (Id.of_string "do_subrelation", - Some (snd (app_poly_sort b env evars dosub [||])), - snd (app_poly_nocheck env evars appsub [||])) + (LocalDef (Id.of_string "do_subrelation", + snd (app_poly_sort b env evars dosub [||]), + snd (app_poly_nocheck env evars appsub [||]))) env in let evars, morph = new_cstr_evar evars env' app in @@ -1019,7 +1046,7 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = | x -> x in let res = - { rew_car = prod_appvect r.rew_car args; + { rew_car = Reductionops.hnf_prod_appvect env (goalevars evars) r.rew_car args; rew_from = mkApp(r.rew_from, args); rew_to = mkApp(r.rew_to, args); rew_prf = prf; rew_evars = r.rew_evars } in @@ -1110,8 +1137,9 @@ 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 unfresh id env) n in - let env' = Environ.push_rel (n', None, t) env in + let n' = name_app (fun id -> Tactics.fresh_id_in_env unfresh id env) n in + let open Context.Rel.Declaration in + let env' = Environ.push_rel (LocalAssum (n', 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.strategy { state ; env = env' ; unfresh ; @@ -1360,7 +1388,9 @@ module Strategies = 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 + let sigma = Sigma.Unsafe.of_evar_map (goalevars evars) in + let Sigma (t', sigma, _) = rfn.Reductionops.e_redfun env sigma t in + let evars' = Sigma.to_evar_map sigma in if eq_constr t' t then state, Identity else @@ -1442,7 +1472,7 @@ type result = (evar_map * constr option * types) option option let cl_rewrite_clause_aux ?(abs=None) strat env avoid sigma concl is_hyp : result = let evdref = ref sigma in - let sort = Typing.sort_of env evdref concl in + let sort = Typing.e_sort_of env evdref concl in let evars = (!evdref, Evar.Set.empty) in let evars, cstr = let prop, (evars, arrow) = @@ -1495,8 +1525,8 @@ let cl_rewrite_clause_aux ?(abs=None) strat env avoid sigma concl is_hyp : resul (** Insert a declaration after the last declaration it depends on *) let rec insert_dependent env decl accu hyps = match hyps with | [] -> List.rev_append accu [decl] -| (id, _, _ as ndecl) :: rem -> - if occur_var_in_decl env id decl then +| ndecl :: rem -> + if occur_var_in_decl env (get_id ndecl) decl then List.rev_append accu (decl :: hyps) else insert_dependent env decl (ndecl :: accu) rem @@ -1506,16 +1536,19 @@ let assert_replacing id newt tac = let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in let ctx = Environ.named_context env in - let after, before = List.split_when (fun (n, b, t) -> Id.equal n id) ctx in + let after, before = List.split_when (Id.equal id % get_id) ctx in let nc = match before with | [] -> assert false - | (id, b, _) :: rem -> insert_dependent env (id, b, newt) [] after @ rem + | d :: rem -> insert_dependent env (LocalAssum (get_id d, newt)) [] after @ rem in let env' = Environ.reset_with_named_context (val_of_named_context nc) env in - Proofview.Refine.refine ~unsafe:false { run = begin fun sigma -> + Refine.refine ~unsafe:false { run = begin fun sigma -> let Sigma (ev, sigma, p) = Evarutil.new_evar env' sigma concl in let Sigma (ev', sigma, q) = Evarutil.new_evar env sigma newt in - let map (n, _, _) = if Id.equal n id then ev' else mkVar n in + let map d = + let n = get_id d in + if Id.equal n id then ev' else mkVar n + in let (e, _) = destEvar ev in Sigma (mkEvar (e, Array.map_of_list map nc), sigma, p +> q) end } @@ -1525,24 +1558,25 @@ let assert_replacing id newt tac = let newfail n s = Proofview.tclZERO (Refiner.FailError (n, lazy s)) -let cl_rewrite_clause_newtac ?abs ?origsigma strat clause = +let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = let open Proofview.Notations in let treat sigma res = match res with | None -> newfail 0 (str "Nothing to rewrite") - | Some None -> Proofview.tclUNIT () + | Some None -> if progress then newfail 0 (str"Failed to progress") + else Proofview.tclUNIT () | Some (Some res) -> 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 clause, prf with | Some id, Some p -> - let tac = Proofview.Refine.refine ~unsafe:false { run = fun h -> Sigma (p, h, Sigma.refl) } <*> Proofview.Unsafe.tclNEWGOALS gls in + let tac = Refine.refine ~unsafe:false { run = fun h -> Sigma (p, h, Sigma.refl) } <*> Proofview.Unsafe.tclNEWGOALS gls in Proofview.Unsafe.tclEVARS undef <*> assert_replacing id newt tac | Some id, None -> Proofview.Unsafe.tclEVARS undef <*> - convert_hyp_no_check (id, None, newt) + convert_hyp_no_check (LocalAssum (id, newt)) | None, Some p -> Proofview.Unsafe.tclEVARS undef <*> Proofview.Goal.enter { enter = begin fun gl -> @@ -1551,17 +1585,17 @@ let cl_rewrite_clause_newtac ?abs ?origsigma strat clause = let Sigma (ev, sigma, q) = Evarutil.new_evar env sigma newt in Sigma (mkApp (p, [| ev |]), sigma, q) end } in - Proofview.Refine.refine ~unsafe:false make <*> Proofview.Unsafe.tclNEWGOALS gls + Refine.refine ~unsafe:false make <*> Proofview.Unsafe.tclNEWGOALS gls end } | None, None -> Proofview.Unsafe.tclEVARS undef <*> convert_concl_no_check newt DEFAULTcast in let beta_red _ sigma c = Reductionops.nf_betaiota sigma c in - let beta = Proofview.V82.tactic (Tactics.reduct_in_concl (beta_red, DEFAULTcast)) in + let beta = Tactics.reduct_in_concl (beta_red, DEFAULTcast) in let opt_beta = match clause with | None -> Proofview.tclUNIT () - | Some id -> Proofview.V82.tactic (Tactics.reduct_in_hyp beta_red (id, InHyp)) + | Some id -> Tactics.reduct_in_hyp beta_red (id, InHyp) in Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in @@ -1597,21 +1631,25 @@ let tactic_init_setoid () = try init_setoid (); tclIDTAC with e when Errors.noncritical e -> tclFAIL 0 (str"Setoid library not loaded") -(** Setoid rewriting when called with "rewrite_strat" *) -let cl_rewrite_clause_strat strat clause = +let cl_rewrite_clause_strat progress strat clause = tclTHEN (tactic_init_setoid ()) - (fun gl -> - try Proofview.V82.of_tactic (cl_rewrite_clause_newtac strat clause) gl - with RewriteFailure e -> - errorlabstrm "" (str"setoid rewrite failed: " ++ e) - | Refiner.FailError (n, pp) -> - tclFAIL n (str"setoid rewrite failed: " ++ Lazy.force pp) gl) + ((if progress then tclWEAK_PROGRESS else fun x -> x) + (fun gl -> + try Proofview.V82.of_tactic (cl_rewrite_clause_newtac ~progress strat clause) gl + with RewriteFailure e -> + errorlabstrm "" (str"setoid rewrite failed: " ++ e) + | Refiner.FailError (n, pp) -> + tclFAIL n (str"setoid rewrite failed: " ++ Lazy.force pp) gl)) (** Setoid rewriting when called with "setoid_rewrite" *) 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 + cl_rewrite_clause_strat true strat clause gl +(** Setoid rewriting when called with "rewrite_strat" *) +let cl_rewrite_clause_strat strat clause = + cl_rewrite_clause_strat false strat clause + 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 @@ -1702,7 +1740,7 @@ let rec strategy_of_ast = function let mkappc s l = CAppExpl (Loc.ghost,(None,(Libnames.Ident (Loc.ghost,Id.of_string s)),None),l) let declare_an_instance n s args = - ((Loc.ghost,Name n), Explicit, + (((Loc.ghost,Name n),None), Explicit, CAppExpl (Loc.ghost, (None, Qualid (Loc.ghost, qualid_of_string s),None), args)) @@ -1710,7 +1748,7 @@ let declare_instance a aeq n s = declare_an_instance n s [a;aeq] let anew_instance global binders instance fields = new_instance (Flags.is_universe_polymorphism ()) - binders instance (Some (true, CRecord (Loc.ghost,None,fields))) + binders instance (Some (true, CRecord (Loc.ghost,fields))) ~global ~generalize:false None let declare_instance_refl global binders a aeq n lemma = @@ -1810,9 +1848,9 @@ 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:(Evd.universe_context sigma) 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)) @@ -1845,7 +1883,7 @@ let build_morphism_signature m = let morph = e_app_poly env evd PropGlobal.proper_type [| t; sig_; m |] in let evd = solve_constraints env !evd in let m = Evarutil.nf_evar evd morph in - Evarutil.check_evars env Evd.empty evd m; m + Pretyping.check_evars env Evd.empty evd m; m let default_morphism sign m = let env = Global.env () in @@ -1918,14 +1956,14 @@ let add_morphism glob binders m s n = let poly = Flags.is_universe_polymorphism () in let instance_id = add_suffix n "_Proper" in let instance = - ((Loc.ghost,Name instance_id), Explicit, + (((Loc.ghost,Name instance_id),None), Explicit, CAppExpl (Loc.ghost, (None, Qualid (Loc.ghost, Libnames.qualid_of_string "Coq.Classes.Morphisms.Proper"),None), [cHole; s; m])) in let tac = Tacinterp.interp (make_tactic "add_morphism_tactic") in ignore(new_instance ~global:glob poly binders instance - (Some (true, CRecord (Loc.ghost,None,[]))) + (Some (true, CRecord (Loc.ghost,[]))) ~generalize:false ~tac ~hook:(declare_projection n instance_id) None) (** Bind to "rewrite" too *) @@ -2017,7 +2055,8 @@ let general_s_rewrite cl l2r occs (c,l) ~new_goals gl = tclWEAK_PROGRESS (tclTHEN (Refiner.tclEVARS evd) - (Proofview.V82.of_tactic (cl_rewrite_clause_newtac ~abs:(Some abs) ~origsigma strat cl))) gl + (Proofview.V82.of_tactic + (cl_rewrite_clause_newtac ~progress:true ~abs:(Some abs) ~origsigma strat cl))) gl with RewriteFailure e -> tclFAIL 0 (str"setoid rewrite failed: " ++ e) gl @@ -2034,8 +2073,9 @@ let _ = Hook.set Equality.general_setoid_rewrite_clause general_s_rewrite_clause (** [setoid_]{reflexivity,symmetry,transitivity} tactics *) let not_declared env ty rel = - Tacticals.New.tclFAIL 0 (str" The relation " ++ Printer.pr_constr_env env Evd.empty rel ++ str" is not a declared " ++ - str ty ++ str" relation. Maybe you need to require the Setoid library") + Tacticals.New.tclFAIL 0 + (str" The relation " ++ Printer.pr_constr_env env Evd.empty rel ++ str" is not a declared " ++ + str ty ++ str" relation. Maybe you need to require the Coq.Classes.RelationClasses library") let setoid_proof ty fn fallback = Proofview.Goal.nf_enter { enter = begin fun gl -> @@ -2046,9 +2086,10 @@ let setoid_proof ty fn fallback = begin 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.unsafe_type_of env evm rel)))) in - (try init_setoid () with _ -> raise Not_found); + let open Context.Rel.Declaration in + let (sigma, t) = Typing.type_of env sigma rel in + let car = get_type (List.hd (fst (Reduction.dest_prod env t))) in + (try init_relation_classes () with _ -> raise Not_found); fn env sigma car rel with e -> Proofview.tclZERO e end @@ -2081,8 +2122,10 @@ let poly_proof getp gett env evm car rel = let setoid_reflexivity = setoid_proof "reflexive" (fun env evm car rel -> - tac_open (poly_proof PropGlobal.get_reflexive_proof TypeGlobal.get_reflexive_proof - env evm car rel) (fun c -> Proofview.V82.of_tactic (apply c))) + tac_open (poly_proof PropGlobal.get_reflexive_proof + TypeGlobal.get_reflexive_proof + env evm car rel) + (fun c -> tclCOMPLETE (Proofview.V82.of_tactic (apply c)))) (reflexivity_red true) let setoid_symmetry = diff --git a/tactics/rewrite.mli b/ltac/rewrite.mli index 40a18ac45..01709f29f 100644 --- a/tactics/rewrite.mli +++ b/ltac/rewrite.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -71,7 +71,7 @@ val cl_rewrite_clause : bool -> Locus.occurrences -> Id.t option -> tactic val is_applied_rewrite_relation : - env -> evar_map -> Context.rel_context -> constr -> types option + env -> evar_map -> Context.Rel.t -> constr -> types option val declare_relation : ?binders:local_binder list -> constr_expr -> constr_expr -> Id.t -> diff --git a/ltac/tacentries.ml b/ltac/tacentries.ml new file mode 100644 index 000000000..ced473343 --- /dev/null +++ b/ltac/tacentries.ml @@ -0,0 +1,479 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Pp +open Errors +open Util +open Names +open Libobject +open Genarg +open Pcoq +open Egramml +open Egramcoq +open Vernacexpr +open Libnames +open Nameops + +(**********************************************************************) +(* Interpret entry names of the form "ne_constr_list" as entry keys *) + +let coincide s pat off = + let len = String.length pat in + let break = ref true in + let i = ref 0 in + while !break && !i < len do + let c = Char.code s.[off + !i] in + let d = Char.code pat.[!i] in + break := Int.equal c d; + incr i + done; + !break + +let atactic n = + let open Extend in + if n = 5 then Aentry (name_of_entry Tactic.binder_tactic) + else Aentryl (name_of_entry Tactic.tactic_expr, n) + +type entry_name = EntryName : + 'a raw_abstract_argument_type * (Tacexpr.raw_tactic_expr, 'a) Extend.symbol -> entry_name + +let try_get_entry u s = + let open Extend in + (** Order the effects: get_entry can raise Not_found *) + let TypedEntry (typ, e) = get_entry u s in + EntryName (typ, Aentry (name_of_entry e)) + +(** Quite ad-hoc *) +let get_tacentry n m = + let open Extend in + let check_lvl n = + Int.equal m n + && not (Int.equal m 5) (* Because tactic5 is at binder_tactic *) + && not (Int.equal m 0) (* Because tactic0 is at simple_tactic *) + in + if check_lvl n then EntryName (rawwit Constrarg.wit_tactic, Aself) + else if check_lvl (n + 1) then EntryName (rawwit Constrarg.wit_tactic, Anext) + else EntryName (rawwit Constrarg.wit_tactic, atactic n) + +let rec parse_user_entry s sep = + let open Extend in + let l = String.length s in + if l > 8 && coincide s "ne_" 0 && coincide s "_list" (l - 5) then + let entry = parse_user_entry (String.sub s 3 (l-8)) "" in + Ulist1 entry + else if l > 12 && coincide s "ne_" 0 && + coincide s "_list_sep" (l-9) then + let entry = parse_user_entry (String.sub s 3 (l-12)) "" in + Ulist1sep (entry, sep) + else if l > 5 && coincide s "_list" (l-5) then + let entry = parse_user_entry (String.sub s 0 (l-5)) "" in + Ulist0 entry + else if l > 9 && coincide s "_list_sep" (l-9) then + let entry = parse_user_entry (String.sub s 0 (l-9)) "" in + Ulist0sep (entry, sep) + else if l > 4 && coincide s "_opt" (l-4) then + let entry = parse_user_entry (String.sub s 0 (l-4)) "" in + Uopt entry + else if Int.equal l 7 && coincide s "tactic" 0 && '5' >= s.[6] && s.[6] >= '0' then + let n = Char.code s.[6] - 48 in + Uentryl ("tactic", n) + else + let s = match s with "hyp" -> "var" | _ -> s in + Uentry s + +let arg_list = function Rawwit t -> Rawwit (ListArg t) +let arg_opt = function Rawwit t -> Rawwit (OptArg t) + +let interp_entry_name up_level s sep = + let open Extend in + let rec eval = function + | Ulist1 e -> + let EntryName (t, g) = eval e in + EntryName (arg_list t, Alist1 g) + | Ulist1sep (e, sep) -> + let EntryName (t, g) = eval e in + EntryName (arg_list t, Alist1sep (g, sep)) + | Ulist0 e -> + let EntryName (t, g) = eval e in + EntryName (arg_list t, Alist0 g) + | Ulist0sep (e, sep) -> + let EntryName (t, g) = eval e in + EntryName (arg_list t, Alist0sep (g, sep)) + | Uopt e -> + let EntryName (t, g) = eval e in + EntryName (arg_opt t, Aopt g) + | Uentry s -> + begin + try try_get_entry uprim s with Not_found -> + try try_get_entry uconstr s with Not_found -> + try try_get_entry utactic s with Not_found -> + error ("Unknown entry "^s^".") + end + | Uentryl (s, n) -> + (** FIXME: do better someday *) + assert (String.equal s "tactic"); + get_tacentry n up_level + in + eval (parse_user_entry s sep) + +(**********************************************************************) +(** Grammar declaration for Tactic Notation (Coq level) *) + +let get_tactic_entry n = + if Int.equal n 0 then + Tactic.simple_tactic, None + else if Int.equal n 5 then + Tactic.binder_tactic, None + else if 1<=n && n<5 then + Tactic.tactic_expr, Some (Extend.Level (string_of_int n)) + else + error ("Invalid Tactic Notation level: "^(string_of_int n)^".") + +(**********************************************************************) +(** State of the grammar extensions *) + +type tactic_grammar = { + tacgram_level : int; + tacgram_prods : Tacexpr.raw_tactic_expr grammar_prod_item list; +} + +(** ML Tactic grammar extensions *) + +let add_ml_tactic_entry (name, prods) = + let entry = Tactic.simple_tactic in + let mkact i loc l : Tacexpr.raw_tactic_expr = + let open Tacexpr in + let entry = { mltac_name = name; mltac_index = i } in + let map arg = TacGeneric arg in + TacML (loc, entry, List.map map l) + in + let rules = List.map_i (fun i p -> make_rule (mkact i) p) 0 prods in + synchronize_level_positions (); + grammar_extend entry None (None, [(None, None, List.rev rules)]); + 1 + +(* Declaration of the tactic grammar rule *) + +let head_is_ident tg = match tg.tacgram_prods with +| GramTerminal _::_ -> true +| _ -> false + +(** Tactic grammar extensions *) + +let add_tactic_entry (kn, tg) = + let open Tacexpr in + let entry, pos = get_tactic_entry tg.tacgram_level in + let mkact loc l = + let filter = function + | GramTerminal _ -> None + | GramNonTerminal (_, t, _) -> Some (Genarg.unquote t) + in + let types = List.map_filter filter tg.tacgram_prods in + let map arg t = + (** HACK to handle especially the tactic(...) entry *) + let wit = Genarg.rawwit Constrarg.wit_tactic in + if Genarg.argument_type_eq t (Genarg.unquote wit) then + Tacexp (Genarg.out_gen wit arg) + else + TacGeneric arg + in + let l = List.map2 map l types in + (TacAlias (loc,kn,l):raw_tactic_expr) + in + let () = + if Int.equal tg.tacgram_level 0 && not (head_is_ident tg) then + error "Notation for simple tactic must start with an identifier." + in + let rules = make_rule mkact tg.tacgram_prods in + synchronize_level_positions (); + grammar_extend entry None (pos, [(None, None, List.rev [rules])]); + 1 + +let tactic_grammar = + create_grammar_command "TacticGrammar" add_tactic_entry + +let ml_tactic_grammar = + create_grammar_command "MLTacticGrammar" add_ml_tactic_entry + +let extend_tactic_grammar kn ntn = extend_grammar tactic_grammar (kn, ntn) +let extend_ml_tactic_grammar n ntn = extend_grammar ml_tactic_grammar (n, ntn) + +(**********************************************************************) +(* Tactic Notation *) + +let interp_prod_item lev = function + | TacTerm s -> GramTerminal s + | TacNonTerm (loc, nt, (_, sep)) -> + let EntryName (etyp, e) = interp_entry_name lev nt sep in + GramNonTerminal (loc, etyp, e) + +let make_terminal_status = function + | GramTerminal s -> Some s + | GramNonTerminal _ -> None + +let make_fresh_key = + let id = Summary.ref ~name:"TACTIC-NOTATION-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) + +type tactic_grammar_obj = { + tacobj_key : KerName.t; + tacobj_local : locality_flag; + tacobj_tacgram : tactic_grammar; + tacobj_tacpp : Pptactic.pp_tactic; + tacobj_body : Id.t list * 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; + extend_tactic_grammar key tobj.tacobj_tacgram; + Pptactic.declare_notation_tactic_pprule key tobj.tacobj_tacpp + +let open_tactic_notation i (_, tobj) = + let key = tobj.tacobj_key in + if Int.equal i 1 && not tobj.tacobj_local then + extend_tactic_grammar key tobj.tacobj_tacgram + +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; + if Int.equal i 1 && not tobj.tacobj_local then + extend_tactic_grammar key tobj.tacobj_tacgram + +let subst_tactic_notation (subst, tobj) = + let (ids, body) = tobj.tacobj_body in + { tobj with + tacobj_key = Mod_subst.subst_kn subst tobj.tacobj_key; + tacobj_body = (ids, Tacsubst.subst_tactic subst body); + } + +let classify_tactic_notation tacobj = Substitute tacobj + +let inTacticGrammar : tactic_grammar_obj -> obj = + declare_object {(default_object "TacticGrammar") with + open_function = open_tactic_notation; + load_function = load_tactic_notation; + cache_function = cache_tactic_notation; + subst_function = subst_tactic_notation; + classify_function = classify_tactic_notation} + +let cons_production_parameter = function +| TacTerm _ -> None +| TacNonTerm (_, _, (id, _)) -> Some id + +let add_tactic_notation (local,n,prods,e) = + let ids = List.map_filter cons_production_parameter prods in + let prods = List.map (interp_prod_item n) prods in + let pprule = { + Pptactic.pptac_level = n; + pptac_prods = prods; + } in + let tac = Tacintern.glob_tactic_env ids (Global.env()) e in + let parule = { + tacgram_level = n; + tacgram_prods = prods; + } in + let tacobj = { + tacobj_key = make_fresh_key (); + tacobj_local = local; + tacobj_tacgram = parule; + tacobj_tacpp = pprule; + tacobj_body = (ids, tac); + } in + Lib.add_anonymous_leaf (inTacticGrammar tacobj) + +(**********************************************************************) +(* ML Tactic entries *) + +type ml_tactic_grammar_obj = { + mltacobj_name : Tacexpr.ml_tactic_name; + (** ML-side unique name *) + mltacobj_prod : Tacexpr.raw_tactic_expr grammar_prod_item list list; + (** Grammar rules generating the ML tactic. *) +} + +exception NonEmptyArgument + +(** ML tactic notations whose use can be restricted to an identifier are added + as true Ltac entries. *) +let extend_atomic_tactic name entries = + let open Tacexpr in + let map_prod prods = + let (hd, rem) = match prods with + | GramTerminal s :: rem -> (s, rem) + | _ -> assert false (** Not handled by the ML extension syntax *) + in + let empty_value = function + | GramTerminal s -> raise NonEmptyArgument + | GramNonTerminal (_, typ, e) -> + let Genarg.Rawwit wit = typ in + let inj x = TacArg (Loc.ghost, TacGeneric (Genarg.in_gen typ x)) in + let default = epsilon_value inj e in + match default with + | None -> raise NonEmptyArgument + | Some def -> Tacintern.intern_tactic_or_tacarg Tacintern.fully_empty_glob_sign def + in + try Some (hd, List.map empty_value rem) with NonEmptyArgument -> None + in + let entries = List.map map_prod entries in + let add_atomic i args = match args with + | None -> () + | Some (id, args) -> + let args = List.map (fun a -> Tacexp a) args in + let entry = { mltac_name = name; mltac_index = i } in + let body = TacML (Loc.ghost, entry, args) in + Tacenv.register_ltac false false (Names.Id.of_string id) body + in + List.iteri add_atomic entries + +let cache_ml_tactic_notation (_, obj) = + extend_ml_tactic_grammar obj.mltacobj_name obj.mltacobj_prod + +let open_ml_tactic_notation i obj = + if Int.equal i 1 then cache_ml_tactic_notation obj + +let inMLTacticGrammar : ml_tactic_grammar_obj -> obj = + declare_object { (default_object "MLTacticGrammar") with + open_function = open_ml_tactic_notation; + cache_function = cache_ml_tactic_notation; + classify_function = (fun o -> Substitute o); + subst_function = (fun (_, o) -> o); + } + +let add_ml_tactic_notation name prods = + let obj = { + mltacobj_name = name; + mltacobj_prod = prods; + } in + Lib.add_anonymous_leaf (inMLTacticGrammar obj); + extend_atomic_tactic name prods + +(**********************************************************************) +(** Ltac quotations *) + +let ltac_quotations = ref String.Set.empty + +let create_ltac_quotation name cast (e, l) = + let open Extend in + let () = + if String.Set.mem name !ltac_quotations then + failwith ("Ltac quotation " ^ name ^ " already registered") + in + let () = ltac_quotations := String.Set.add name !ltac_quotations in + let entry = match l with + | None -> Aentry (name_of_entry e) + | Some l -> Aentryl (name_of_entry e, l) + in +(* let level = Some "1" in *) + let level = None in + let assoc = None in + let rule = + Next (Next (Next (Next (Next (Stop, + Atoken (Lexer.terminal name)), + Atoken (Lexer.terminal ":")), + Atoken (Lexer.terminal "(")), + entry), + Atoken (Lexer.terminal ")")) + in + let action _ v _ _ _ loc = cast (loc, v) in + let gram = (level, assoc, [Rule (rule, action)]) in + Pcoq.grammar_extend Tactic.tactic_arg None (None, [gram]) + +(** Command *) + + +type tacdef_kind = + | NewTac of Id.t + | UpdateTac of Nametab.ltac_constant + +let is_defined_tac kn = + try ignore (Tacenv.interp_ltac kn); true with Not_found -> false + +let register_ltac local tacl = + let map tactic_body = + match tactic_body with + | TacticDefinition ((loc,id), body) -> + let kn = Lib.make_kn id in + let id_pp = pr_id id in + let () = if is_defined_tac kn then + Errors.user_err_loc (loc, "", + str "There is already an Ltac named " ++ id_pp ++ str".") + in + let is_primitive = + try + match Pcoq.parse_string Pcoq.Tactic.tactic (Id.to_string id) with + | Tacexpr.TacArg _ -> false + | _ -> true (* most probably TacAtom, i.e. a primitive tactic ident *) + with e when Errors.noncritical e -> true (* prim tactics with args, e.g. "apply" *) + in + let () = if is_primitive then + msg_warning (str "The Ltac name " ++ id_pp ++ + str " may be unusable because of a conflict with a notation.") + in + NewTac id, body + | TacticRedefinition (ident, body) -> + let loc = loc_of_reference ident in + let kn = + try Nametab.locate_tactic (snd (qualid_of_reference ident)) + with Not_found -> + Errors.user_err_loc (loc, "", + str "There is no Ltac named " ++ pr_reference ident ++ str ".") + in + UpdateTac kn, body + in + let rfun = List.map map tacl in + let recvars = + let fold accu (op, _) = match op with + | UpdateTac _ -> accu + | NewTac id -> (Lib.make_path id, Lib.make_kn id) :: accu + in + List.fold_left fold [] rfun + in + let ist = Tacintern.make_empty_glob_sign () in + let map (name, body) = + let body = Flags.with_option Tacintern.strict_check (Tacintern.intern_tactic_or_tacarg ist) body in + (name, body) + in + let defs () = + (** Register locally the tactic to handle recursivity. This function affects + the whole environment, so that we transactify it afterwards. *) + let iter_rec (sp, kn) = Nametab.push_tactic (Nametab.Until 1) sp kn in + let () = List.iter iter_rec recvars in + List.map map rfun + in + let defs = Future.transactify defs () in + let iter (def, tac) = match def with + | NewTac id -> + Tacenv.register_ltac false local id tac; + Flags.if_verbose msg_info (Nameops.pr_id id ++ str " is defined") + | UpdateTac kn -> + Tacenv.redefine_ltac local kn tac; + let name = Nametab.shortest_qualid_of_tactic kn in + Flags.if_verbose msg_info (Libnames.pr_qualid name ++ str " is redefined") + in + List.iter iter defs diff --git a/ltac/tacentries.mli b/ltac/tacentries.mli new file mode 100644 index 000000000..b60d8f478 --- /dev/null +++ b/ltac/tacentries.mli @@ -0,0 +1,29 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Vernacexpr +open Tacexpr + +(** Adding a tactic notation in the environment *) + +val add_tactic_notation : + locality_flag * int * grammar_tactic_prod_item_expr list * raw_tactic_expr -> + unit + +val add_ml_tactic_notation : ml_tactic_name -> + Tacexpr.raw_tactic_expr Egramml.grammar_prod_item list list -> unit + +val register_ltac : bool -> Vernacexpr.tacdef_body list -> unit + +(** {5 Adding tactic quotations} *) + +val create_ltac_quotation : string -> + ('grm Loc.located -> raw_tactic_arg) -> ('grm Pcoq.Gram.entry * int option) -> unit +(** [create_ltac_quotation name f e] adds a quotation rule to Ltac, that is, + Ltac grammar now accepts arguments of the form ["name" ":" "(" <e> ")"], and + generates an argument using [f] on the entry parsed by [e]. *) diff --git a/tactics/tacenv.ml b/ltac/tacenv.ml index c1e4d72e3..d2d3f3117 100644 --- a/tactics/tacenv.ml +++ b/ltac/tacenv.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -15,9 +15,10 @@ open Tacexpr (** Tactic notations (TacAlias) *) type alias = KerName.t +type alias_tactic = Id.t list * glob_tactic_expr let alias_map = Summary.ref ~name:"tactic-alias" - (KNmap.empty : glob_tactic_expr KNmap.t) + (KNmap.empty : alias_tactic KNmap.t) let register_alias key tac = alias_map := KNmap.add key tac !alias_map @@ -31,7 +32,7 @@ let check_alias key = KNmap.mem key !alias_map (** ML tactic extensions (TacML) *) type ml_tactic = - typed_generic_argument list -> Geninterp.interp_sign -> unit Proofview.tactic + Val.t list -> Geninterp.interp_sign -> unit Proofview.tactic module MLName = struct diff --git a/tactics/tacenv.mli b/ltac/tacenv.mli index 47d9efda5..88b54993b 100644 --- a/tactics/tacenv.mli +++ b/ltac/tacenv.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -17,10 +17,13 @@ open Tacexpr type alias = KerName.t (** Type of tactic alias, used in the [TacAlias] node. *) -val register_alias : alias -> glob_tactic_expr -> unit +type alias_tactic = Id.t list * glob_tactic_expr +(** Contents of a tactic notation *) + +val register_alias : alias -> alias_tactic -> unit (** Register a tactic alias. *) -val interp_alias : alias -> glob_tactic_expr +val interp_alias : alias -> alias_tactic (** Recover the the body of an alias. Raises an anomaly if it does not exist. *) val check_alias : alias -> bool @@ -61,7 +64,7 @@ val ltac_entries : unit -> ltac_entry KNmap.t (** {5 ML tactic extensions} *) type ml_tactic = - typed_generic_argument list -> Geninterp.interp_sign -> unit Proofview.tactic + Val.t list -> Geninterp.interp_sign -> unit Proofview.tactic (** Type of external tactics, used by [TacML]. *) val register_ml_tactic : ?overwrite:bool -> ml_tactic_name -> ml_tactic array -> unit diff --git a/tactics/tacintern.ml b/ltac/tacintern.ml index fb22da83a..a75805b4f 100644 --- a/tactics/tacintern.ml +++ b/ltac/tacintern.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -35,11 +35,6 @@ let dloc = Loc.ghost let error_global_not_found_loc (loc,qid) = error_global_not_found_loc loc qid -let error_syntactic_metavariables_not_allowed loc = - user_err_loc - (loc,"out_ident", - str "Syntactic metavariables allowed only in quotations.") - let error_tactic_expected loc = user_err_loc (loc,"",str "Tactic expected.") @@ -97,7 +92,6 @@ let intern_or_var f ist = function | ArgArg x -> ArgArg (f x) let intern_int_or_var = intern_or_var (fun (n : int) -> n) -let intern_id_or_var = intern_or_var (fun (id : Id.t) -> id) let intern_string_or_var = intern_or_var (fun (s : string) -> s) let intern_global_reference ist = function @@ -259,8 +253,11 @@ and intern_intro_pattern_action lf ist = function | IntroApplyOn (c,pat) -> IntroApplyOn (intern_constr ist c, intern_intro_pattern lf ist pat) -and intern_or_and_intro_pattern lf ist = - List.map (List.map (intern_intro_pattern lf ist)) +and intern_or_and_intro_pattern lf ist = function + | IntroAndPattern l -> + IntroAndPattern (List.map (intern_intro_pattern lf ist) l) + | IntroOrPattern ll -> + IntroOrPattern (List.map (List.map (intern_intro_pattern lf ist)) ll) let intern_or_and_intro_pattern_loc lf ist = function | ArgVar (_,id) as x -> @@ -339,7 +336,7 @@ let intern_typed_pattern ist p = (* type it, so we remember the pattern as a glob_constr only *) (intern_constr_gen true false ist p,dummy_pat) -let rec intern_typed_pattern_or_ref_with_occurrences ist (l,p) = +let intern_typed_pattern_or_ref_with_occurrences ist (l,p) = let interp_ref r = try Inl (intern_evaluable ist r) with e when Logic.catchable_exception e -> @@ -400,8 +397,8 @@ let intern_red_expr ist = function | CbvNative o -> CbvNative (Option.map (intern_typed_pattern_or_ref_with_occurrences ist) o) | (Red _ | Hnf | ExtraRedExpr _ as r ) -> r -let intern_in_hyp_as ist lf (clear,id,ipat) = - (clear,intern_hyp ist id, Option.map (intern_intro_pattern lf ist) ipat) +let intern_in_hyp_as ist lf (id,ipat) = + (intern_hyp ist id, Option.map (intern_intro_pattern lf ist) ipat) let intern_hyp_list ist = List.map (intern_hyp ist) @@ -494,11 +491,9 @@ let rec intern_atomic lf ist x = TacElim (ev,intern_constr_with_bindings_arg ist cb, Option.map (intern_constr_with_bindings ist) cbo) | TacCase (ev,cb) -> TacCase (ev,intern_constr_with_bindings_arg ist cb) - | TacFix (idopt,n) -> TacFix (Option.map (intern_ident lf ist) idopt,n) | TacMutualFix (id,n,l) -> let f (id,n,c) = (intern_ident lf ist id,n,intern_type ist c) in TacMutualFix (intern_ident lf ist id, n, List.map f l) - | TacCofix idopt -> TacCofix (Option.map (intern_ident lf ist) idopt) | TacMutualCofix (id,l) -> let f (id,c) = (intern_ident lf ist id,intern_type ist c) in TacMutualCofix (intern_ident lf ist id, List.map f l) @@ -510,19 +505,12 @@ let rec intern_atomic lf ist x = TacGeneralize (List.map (fun (c,na) -> intern_constr_with_occurrences ist c, intern_name lf ist na) cl) - | TacGeneralizeDep c -> TacGeneralizeDep (intern_constr ist c) | TacLetTac (na,c,cls,b,eqpat) -> let na = intern_name lf ist na in TacLetTac (na,intern_constr ist c, (clause_app (intern_hyp_location ist) cls),b, (Option.map (intern_intro_pattern_naming_loc lf ist) eqpat)) - (* Automation tactics *) - | TacTrivial (d,lems,l) -> TacTrivial (d,List.map (intern_constr ist) lems,l) - | TacAuto (d,n,lems,l) -> - TacAuto (d,Option.map (intern_int_or_var ist) n, - List.map (intern_constr ist) lems,l) - (* Derived basic tactics *) | TacInductionDestruct (ev,isrec,(l,el)) -> TacInductionDestruct (ev,isrec,(List.map (fun (c,(ipato,ipats),cls) -> @@ -536,18 +524,11 @@ let rec intern_atomic lf ist x = let h2 = intern_quantified_hypothesis ist h2 in TacDoubleInduction (h1,h2) (* Context management *) - | TacClear (b,l) -> TacClear (b,List.map (intern_hyp ist) l) - | TacClearBody l -> TacClearBody (List.map (intern_hyp ist) l) - | TacMove (id1,id2) -> - TacMove (intern_hyp ist id1,intern_move_location ist id2) | TacRename l -> TacRename (List.map (fun (id1,id2) -> intern_hyp ist id1, intern_hyp ist id2) l) - (* Constructors *) - | TacSplit (ev,bll) -> TacSplit (ev,List.map (intern_bindings ist) bll) - (* Conversion *) | TacReduce (r,cl) -> dump_glob_red_expr r; @@ -569,10 +550,6 @@ let rec intern_atomic lf ist x = TacChange (Some (intern_typed_pattern ist p),intern_constr ist c, clause_app (intern_hyp_location ist) cl) - (* Equivalence relations *) - | TacSymmetry idopt -> - TacSymmetry (clause_app (intern_hyp_location ist) idopt) - (* Equality and inversion *) | TacRewrite (ev,l,cl,by) -> TacRewrite @@ -663,20 +640,19 @@ and intern_tactic_seq onlytac ist = function (* For extensions *) | TacAlias (loc,s,l) -> - let l = List.map (fun (id,a) -> (id,intern_genarg ist a)) l in + let l = List.map (intern_tacarg !strict_check false ist) l in ist.ltacvars, TacAlias (loc,s,l) | TacML (loc,opn,l) -> let _ignore = Tacenv.interp_ml_tactic opn in - ist.ltacvars, TacML (adjust_loc loc,opn,List.map (intern_genarg ist) l) + ist.ltacvars, TacML (adjust_loc loc,opn,List.map (intern_tacarg !strict_check false ist) l) and intern_tactic_as_arg loc onlytac ist a = match intern_tacarg !strict_check onlytac ist a with | TacCall _ | Reference _ - | TacDynamic _ | TacGeneric _ as a -> TacArg (loc,a) + | TacGeneric _ as a -> TacArg (loc,a) | Tacexp a -> a - | ConstrMayEval _ | UConstr _ | TacFreshId _ | TacPretype _ | TacNumgoals as a -> + | ConstrMayEval _ | TacFreshId _ | TacPretype _ | TacNumgoals as a -> if onlytac then error_tactic_expected loc else TacArg (loc,a) - | MetaIdArg _ -> assert false and intern_tactic_or_tacarg ist = intern_tactic false ist @@ -689,14 +665,6 @@ and intern_tactic_fun ist (var,body) = and intern_tacarg strict onlytac ist = function | Reference r -> intern_non_tactic_reference strict ist r | ConstrMayEval c -> ConstrMayEval (intern_constr_may_eval ist c) - | UConstr c -> UConstr (intern_constr ist c) - | MetaIdArg (loc,istac,s) -> - (* $id can occur in Grammar tactic... *) - let id = Id.of_string s in - if find_var id ist then - if istac then Reference (ArgVar (adjust_loc loc,id)) - else ConstrMayEval (ConstrTerm (GVar (adjust_loc loc,id), None)) - else error_syntactic_metavariables_not_allowed loc | TacCall (loc,f,[]) -> intern_isolated_tactic_reference strict ist f | TacCall (loc,f,l) -> TacCall (loc, @@ -707,15 +675,8 @@ and intern_tacarg strict onlytac ist = function | TacNumgoals -> TacNumgoals | Tacexp t -> Tacexp (intern_tactic onlytac ist t) | TacGeneric arg -> - let (_, arg) = Genintern.generic_intern ist arg in + let arg = intern_genarg ist arg in TacGeneric arg - | TacDynamic(loc,t) as x -> - if Dyn.has_tag t "tactic" || Dyn.has_tag t "value" then x - else if Dyn.has_tag t "constr" then - if onlytac then error_tactic_expected loc else x - else - let tag = Dyn.tag t in - anomaly ~loc (str "Unknown dynamic: <" ++ str tag ++ str ">") (* Reads the rules of a Match Context or a Match *) and intern_match_rule onlytac ist = function @@ -732,57 +693,29 @@ and intern_match_rule onlytac ist = function Pat (hyps,pat,intern_tactic onlytac ist' tc) :: (intern_match_rule onlytac ist tl) | [] -> [] -and intern_genarg ist x = - match genarg_tag x with - | IntOrVarArgType -> map_raw wit_int_or_var intern_int_or_var ist x - | IdentArgType -> - let lf = ref Id.Set.empty in - map_raw wit_ident (intern_ident lf) ist x - | VarArgType -> - map_raw wit_var intern_hyp ist x - | GenArgType -> - map_raw wit_genarg intern_genarg ist x - | ConstrArgType -> - map_raw wit_constr intern_constr ist x - | ConstrMayEvalArgType -> - map_raw wit_constr_may_eval intern_constr_may_eval ist x - | QuantHypArgType -> - map_raw wit_quant_hyp intern_quantified_hypothesis ist x - | RedExprArgType -> - map_raw wit_red_expr intern_red_expr ist x - | OpenConstrArgType -> - map_raw wit_open_constr (fun ist -> on_snd (intern_constr ist)) ist x - | ConstrWithBindingsArgType -> - map_raw wit_constr_with_bindings intern_constr_with_bindings ist x - | BindingsArgType -> - map_raw wit_bindings intern_bindings ist x - | ListArgType _ -> - let list_unpacker wit l = - let map x = - let ans = intern_genarg ist (in_gen (rawwit wit) x) in - out_gen (glbwit wit) ans - in - in_gen (glbwit (wit_list wit)) (List.map map (raw l)) +and intern_genarg ist (GenArg (Rawwit wit, x)) = + match wit with + | ListArg wit -> + let map x = + let ans = intern_genarg ist (in_gen (rawwit wit) x) in + out_gen (glbwit wit) ans in - list_unpack { list_unpacker } x - | OptArgType _ -> - let opt_unpacker wit o = match raw o with + in_gen (glbwit (wit_list wit)) (List.map map x) + | OptArg wit -> + let ans = match x with | None -> in_gen (glbwit (wit_opt wit)) None | Some x -> let s = out_gen (glbwit wit) (intern_genarg ist (in_gen (rawwit wit) x)) in in_gen (glbwit (wit_opt wit)) (Some s) in - opt_unpack { opt_unpacker } x - | PairArgType _ -> - let pair_unpacker wit1 wit2 o = - let p, q = raw o in - let p = out_gen (glbwit wit1) (intern_genarg ist (in_gen (rawwit wit1) p)) in - let q = out_gen (glbwit wit2) (intern_genarg ist (in_gen (rawwit wit2) q)) in - in_gen (glbwit (wit_pair wit1 wit2)) (p, q) - in - pair_unpack { pair_unpacker } x - | ExtraArgType s -> - snd (Genintern.generic_intern ist x) + ans + | PairArg (wit1, wit2) -> + let p, q = x in + let p = out_gen (glbwit wit1) (intern_genarg ist (in_gen (rawwit wit1) p)) in + let q = out_gen (glbwit wit2) (intern_genarg ist (in_gen (rawwit wit2) q)) in + in_gen (glbwit (wit_pair wit1 wit2)) (p, q) + | ExtraArg s -> + snd (Genintern.generic_intern ist (in_gen (rawwit wit) x)) (** Other entry points *) @@ -852,13 +785,27 @@ let () = in Genintern.register_intern0 wit_clause_dft_concl intern_clause +let intern_ident' ist id = + let lf = ref Id.Set.empty in + (ist, intern_ident lf ist id) + let () = + Genintern.register_intern0 wit_int_or_var (lift intern_int_or_var); Genintern.register_intern0 wit_ref (lift intern_global_reference); + Genintern.register_intern0 wit_ident intern_ident'; + Genintern.register_intern0 wit_var (lift intern_hyp); Genintern.register_intern0 wit_tactic (lift intern_tactic_or_tacarg); - Genintern.register_intern0 wit_sort (fun ist s -> (ist, s)) - -let () = - Genintern.register_intern0 wit_uconstr (fun ist c -> (ist,intern_constr ist c)) + Genintern.register_intern0 wit_ltac (lift intern_tactic_or_tacarg); + Genintern.register_intern0 wit_sort (fun ist s -> (ist, s)); + Genintern.register_intern0 wit_quant_hyp (lift intern_quantified_hypothesis); + Genintern.register_intern0 wit_constr (fun ist c -> (ist,intern_constr ist c)); + Genintern.register_intern0 wit_uconstr (fun ist c -> (ist,intern_constr ist c)); + Genintern.register_intern0 wit_open_constr (fun ist c -> (ist,intern_constr ist c)); + Genintern.register_intern0 wit_red_expr (lift intern_red_expr); + Genintern.register_intern0 wit_bindings (lift intern_bindings); + Genintern.register_intern0 wit_constr_with_bindings (lift intern_constr_with_bindings); + Genintern.register_intern0 wit_constr_may_eval (lift intern_constr_may_eval); + () (***************************************************************************) (* Backwarding recursive needs of tactic glob/interp/eval functions *) diff --git a/tactics/tacintern.mli b/ltac/tacintern.mli index a6e28d568..71ca354fa 100644 --- a/tactics/tacintern.mli +++ b/ltac/tacintern.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -12,7 +12,6 @@ open Tacexpr open Genarg open Constrexpr open Misctypes -open Nametab (** Globalization of tactic expressions : Conversion from [raw_tactic_expr] to [glob_tactic_expr] *) diff --git a/tactics/tacinterp.ml b/ltac/tacinterp.ml index 1673aac0a..4c74984f8 100644 --- a/tactics/tacinterp.ml +++ b/ltac/tacinterp.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -23,7 +23,7 @@ open Nametab open Pfedit open Proof_type open Refiner -open Tacmach +open Tacmach.New open Tactic_debug open Constrexpr open Term @@ -42,28 +42,50 @@ open Tacintern open Taccoerce open Sigma.Notations open Proofview.Notations +open Context.Named.Declaration + +let ltac_trace_info = Tactic_debug.ltac_trace_info + +let has_type : type a. Val.t -> a typed_abstract_argument_type -> bool = fun v wit -> + let Val.Dyn (t, _) = v in + match Val.eq t (val_tag wit) with + | None -> false + | Some Refl -> true + +let prj : type a. a Val.tag -> Val.t -> a option = fun t v -> + let Val.Dyn (t', x) = v in + match Val.eq t t' with + | None -> None + | Some Refl -> Some x + +let in_gen wit v = Val.Dyn (val_tag wit, v) +let out_gen wit v = match prj (val_tag wit) v with None -> assert false | Some x -> x + +let val_tag wit = val_tag (topwit wit) + +let pr_argument_type arg = + let Val.Dyn (tag, _) = arg in + Val.repr tag let safe_msgnl s = Proofview.NonLogical.catch (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 +type value = Val.t (** Abstract application, to print ltac functions *) type appl = | UnnamedAppl (** For generic applications: nothing is printed *) - | GlbAppl of (Names.kernel_name * typed_generic_argument list) list + | GlbAppl of (Names.kernel_name * Val.t list) list (** For calls to global constants, some may alias other. *) let push_appl appl args = match appl with | UnnamedAppl -> UnnamedAppl | GlbAppl l -> GlbAppl (List.map (fun (h,vs) -> (h,vs@args)) l) -let pr_generic arg = - let pr_gtac _ x = Pptactic.pr_glob_tactic (Global.env()) x in - try - Pptactic.pr_top_generic pr_constr pr_lconstr pr_gtac pr_constr_pattern arg - with e when Errors.noncritical e -> str"<generic>" +let pr_generic arg = (** FIXME *) + let Val.Dyn (tag, _) = arg in + str"<" ++ Val.repr tag ++ str ">" let pr_appl h vs = Pptactic.pr_ltac_constant h ++ spc () ++ Pp.prlist_with_sep spc pr_generic vs @@ -86,8 +108,8 @@ type tacvalue = Id.t option list * glob_tactic_expr | VRec of value Id.Map.t ref * glob_tactic_expr -let (wit_tacvalue : (Empty.t, Empty.t, tacvalue) Genarg.genarg_type) = - Genarg.create_arg None "tacvalue" +let (wit_tacvalue : (Empty.t, tacvalue, tacvalue) Genarg.genarg_type) = + Genarg.create_arg "tacvalue" let of_tacvalue v = in_gen (topwit wit_tacvalue) v let to_tacvalue v = out_gen (topwit wit_tacvalue) v @@ -125,8 +147,59 @@ module Value = struct let closure = VFun (UnnamedAppl,extract_trace ist, ist.lfun, [], tac) in of_tacvalue closure + let cast_error wit v = + let pr_v = mt () in (** FIXME *) + let Val.Dyn (tag, _) = v in + let tag = Val.repr tag in + errorlabstrm "" (str "Type error: value " ++ pr_v ++ str "is a " ++ tag + ++ str " while type " ++ Genarg.pr_argument_type (unquote (rawwit wit)) ++ str " was expected.") + + let prj : type a. a Val.tag -> Val.t -> a option = fun t v -> + let Val.Dyn (t', x) = v in + match Val.eq t t' with + | None -> None + | Some Refl -> Some x + + let try_prj wit v = match prj (val_tag wit) v with + | None -> cast_error wit v + | Some x -> x + + let rec val_cast : type a b c. (a, b, c) genarg_type -> Val.t -> c = + fun wit v -> match wit with + | ExtraArg _ -> try_prj wit v + | ListArg t -> + let Val.Dyn (tag, v) = v in + begin match tag with + | Val.List tag -> + let map x = val_cast t (Val.Dyn (tag, x)) in + List.map map v + | _ -> cast_error wit (Val.Dyn (tag, v)) + end + | OptArg t -> + let Val.Dyn (tag, v) = v in + begin match tag with + | Val.Opt tag -> + let map x = val_cast t (Val.Dyn (tag, x)) in + Option.map map v + | _ -> cast_error wit (Val.Dyn (tag, v)) + end + | PairArg (t1, t2) -> + let Val.Dyn (tag, v) = v in + begin match tag with + | Val.Pair (tag1, tag2) -> + let (v1, v2) = v in + let v1 = Val.Dyn (tag1, v1) in + let v2 = Val.Dyn (tag2, v2) in + (val_cast t1 v1, val_cast t2 v2) + | _ -> cast_error wit (Val.Dyn (tag, v)) + end + + let cast (Topwit wit) v = val_cast wit v + end +let print_top_val env v = mt () (** FIXME *) + let dloc = Loc.ghost let catching_error call_trace fail (e, info) = @@ -178,13 +251,13 @@ let pr_value env v = | Some (env,sigma) -> pr_lconstr_under_binders_env env sigma c | _ -> str "a term" else - str "a value of type" ++ spc () ++ pr_argument_type (genarg_tag v) + str "a value of type" ++ spc () ++ pr_argument_type v let pr_closure env ist body = let pp_body = Pptactic.pr_glob_tactic env body in let pr_sep () = fnl () in let pr_iarg (id, arg) = - let arg = pr_argument_type (genarg_tag arg) in + let arg = pr_argument_type arg in hov 0 (pr_id id ++ spc () ++ str ":" ++ spc () ++ arg) in let pp_iargs = v 0 (prlist_with_sep pr_sep pr_iarg (Id.Map.bindings ist)) in @@ -201,7 +274,7 @@ let pr_inspect env expr result = | VRec (ist, body) -> str "a recursive closure" ++ fnl () ++ pr_closure env !ist body else - let pp_type = pr_argument_type (genarg_tag result) in + let pp_type = pr_argument_type result in str "an object of type" ++ spc () ++ pp_type in pp_expr ++ fnl() ++ str "this is " ++ pp_result @@ -210,17 +283,6 @@ let pr_inspect env expr result = let constr_of_id env id = Term.mkVar (let _ = Environ.lookup_named id env in id) -(* To embed tactics *) - -let ((tactic_in : (interp_sign -> glob_tactic_expr) -> Dyn.t), - (tactic_out : Dyn.t -> (interp_sign -> glob_tactic_expr))) = - Dyn.create "tactic" - -let ((value_in : value -> Dyn.t), - (value_out : Dyn.t -> value)) = Dyn.create "value" - -let valueIn t = TacDynamic (Loc.ghost, value_in t) - (** Generic arguments : table of interpretation functions *) let push_trace call ist = match TacStore.get ist.extra f_trace with @@ -261,9 +323,9 @@ let coerce_to_tactic loc id v = | _ -> fail () else fail () +let intro_pattern_of_ident id = (Loc.ghost, IntroNaming (IntroIdentifier id)) let value_of_ident id = - in_gen (topwit wit_intro_pattern) - (Loc.ghost, IntroNaming (IntroIdentifier id)) + in_gen (topwit wit_intro_pattern) (intro_pattern_of_ident id) let (+++) lfun1 lfun2 = Id.Map.fold Id.Map.add lfun1 lfun2 @@ -303,7 +365,7 @@ let debugging_exception_step ist signal_anomaly e pp = if signal_anomaly then explain_logic_error else explain_logic_error_no_anomaly in debugging_step ist (fun () -> - pp() ++ spc() ++ str "raised the exception" ++ fnl() ++ !explain_exc e) + pp() ++ spc() ++ str "raised the exception" ++ fnl() ++ explain_exc e) let error_ltac_variable loc id env v s = user_err_loc (loc, "", str "Ltac variable " ++ pr_id id ++ @@ -338,10 +400,6 @@ let interp_intro_pattern_naming_var loc ist env sigma id = try try_interp_ltac_var (coerce_to_intro_pattern_naming env) ist (Some (env,sigma)) (loc,id) with Not_found -> IntroIdentifier id -let interp_hint_base ist s = - try try_interp_ltac_var coerce_to_hint_base ist None (dloc,Id.of_string s) - with Not_found -> s - let interp_int ist locid = try try_interp_ltac_var coerce_to_int ist None locid with Not_found -> @@ -389,14 +447,13 @@ let interp_reference ist env sigma = function try try_interp_ltac_var (coerce_to_reference env) ist (Some (env,sigma)) (loc, id) with Not_found -> try - let (v, _, _) = Environ.lookup_named id env in - VarRef v + VarRef (get_id (Environ.lookup_named id env)) with Not_found -> error_global_not_found_loc loc (qualid_of_ident id) let try_interp_evaluable env (loc, id) = let v = Environ.lookup_named id env in match v with - | (_, Some _, _) -> EvalVarRef id + | LocalDef _ -> EvalVarRef id | _ -> error_not_evaluable (VarRef id) let interp_evaluable ist env sigma = function @@ -456,7 +513,9 @@ let extract_ltac_constr_values ist env = (* Extract the identifier list from lfun: join all branches (what to do else?)*) let rec intropattern_ids (loc,pat) = match pat with | IntroNaming (IntroIdentifier id) -> [id] - | IntroAction (IntroOrAndPattern ll) -> + | IntroAction (IntroOrAndPattern (IntroAndPattern l)) -> + List.flatten (List.map intropattern_ids l) + | IntroAction (IntroOrAndPattern (IntroOrPattern ll)) -> List.flatten (List.map intropattern_ids (List.flatten ll)) | IntroAction (IntroInjection l) -> List.flatten (List.map intropattern_ids l) @@ -634,9 +693,9 @@ let pf_interp_constr ist gl = let new_interp_constr ist c k = let open Proofview in - Proofview.Goal.enter { enter = begin fun gl -> - let (sigma, c) = interp_constr ist (Goal.env gl) (Tacmach.New.project gl) c in - Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (k c) + Proofview.Goal.s_enter { s_enter = begin fun gl -> + let (sigma, c) = interp_constr ist (Goal.env gl) (project gl) c in + Sigma.Unsafe.of_pair (k c, sigma) end } let interp_constr_in_compound_list inj_fun dest_fun interp_fun ist env sigma l = @@ -660,13 +719,9 @@ let interp_constr_list ist env sigma c = let interp_open_constr_list = interp_constr_in_compound_list (fun x -> x) (fun x -> x) interp_open_constr -let interp_auto_lemmas ist env sigma lems = - let local_sigma, lems = interp_open_constr_list ist env sigma lems in - List.map (fun lem -> (local_sigma,lem)) lems - (* Interprets a type expression *) -let pf_interp_type ist gl = - interp_type ist (pf_env gl) (project gl) +let pf_interp_type ist env sigma = + interp_type ist env sigma (* Interprets a reduction expression *) let interp_unfold ist env sigma (occs,qid) = @@ -689,12 +744,12 @@ let interp_closed_typed_pattern_with_occurrences ist env sigma (occs, a) = 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 + Inr (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 + | Inr c -> Inr (interp_typed_pattern ist env sigma c) in interp_occurrences ist occs, p let interp_constr_with_occurrences_and_name_as_list = @@ -734,14 +789,17 @@ let interp_may_eval f ist env sigma = function | ConstrEval (r,c) -> let (sigma,redexp) = interp_red_expr ist env sigma r in let (sigma,c_interp) = f ist env sigma c in - (fst (Redexpr.reduction_of_red_expr env redexp) env sigma c_interp) + let (redfun, _) = Redexpr.reduction_of_red_expr env redexp in + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma (c, sigma, _) = redfun.Reductionops.e_redfun env sigma c_interp in + (Sigma.to_evar_map sigma, c) | ConstrContext ((loc,s),c) -> (try let (sigma,ic) = f ist env sigma c in let ctxt = coerce_to_constr_context (Id.Map.find s ist.lfun) in let evdref = ref sigma in let c = subst_meta [Constr_matching.special_meta,ic] ctxt in - let c = Typing.solve_evars env evdref c in + let c = Typing.e_solve_evars env evdref c in !evdref , c with | Not_found -> @@ -786,18 +844,17 @@ let interp_constr_may_eval ist env sigma c = (** TODO: should use dedicated printers *) let rec message_of_value v = let v = Value.normalize v in - let open Tacmach.New in let open Ftactic in if has_type v (topwit wit_tacvalue) then Ftactic.return (str "<tactic>") else if has_type v (topwit wit_constr) then let v = out_gen (topwit wit_constr) v in - Ftactic.nf_enter begin fun gl -> Ftactic.return (pr_constr_env (pf_env gl) (Tacmach.New.project gl) v) end + Ftactic.nf_enter {enter = begin fun gl -> Ftactic.return (pr_constr_env (pf_env gl) (project gl) v) end } else if has_type v (topwit wit_constr_under_binders) then let c = out_gen (topwit wit_constr_under_binders) v in - Ftactic.nf_enter begin fun gl -> - Ftactic.return (pr_constr_under_binders_env (pf_env gl) (Tacmach.New.project gl) c) - end + Ftactic.nf_enter { enter = begin fun gl -> + Ftactic.return (pr_constr_under_binders_env (pf_env gl) (project gl) c) + end } else if has_type v (topwit wit_unit) then Ftactic.return (str "()") else if has_type v (topwit wit_int) then @@ -805,24 +862,24 @@ let rec message_of_value v = else if has_type v (topwit wit_intro_pattern) then let p = out_gen (topwit wit_intro_pattern) v in let print env sigma c = pr_constr_env env sigma (fst (Tactics.run_delayed env Evd.empty c)) in - Ftactic.nf_enter begin fun gl -> - Ftactic.return (Miscprint.pr_intro_pattern (fun c -> print (pf_env gl) (Tacmach.New.project gl) c) p) - end + Ftactic.nf_enter { enter = begin fun gl -> + Ftactic.return (Miscprint.pr_intro_pattern (fun c -> print (pf_env gl) (project gl) c) p) + end } else if has_type v (topwit wit_constr_context) then let c = out_gen (topwit wit_constr_context) v in - Ftactic.nf_enter begin fun gl -> Ftactic.return (pr_constr_env (pf_env gl) (Tacmach.New.project gl) c) end + Ftactic.nf_enter { enter = begin fun gl -> Ftactic.return (pr_constr_env (pf_env gl) (project gl) c) end } else if has_type v (topwit wit_uconstr) then let c = out_gen (topwit wit_uconstr) v in - Ftactic.nf_enter begin fun gl -> + Ftactic.nf_enter { enter = begin fun gl -> Ftactic.return (pr_closed_glob_env (pf_env gl) - (Tacmach.New.project gl) c) - end + (project gl) c) + end } else match Value.to_list v with | Some l -> Ftactic.List.map message_of_value l >>= fun l -> Ftactic.return (prlist_with_sep spc (fun x -> x) l) | None -> - let tag = pr_argument_type (genarg_tag v) in + let tag = pr_argument_type v in Ftactic.return (str "<" ++ tag ++ str ">") (** TODO *) let interp_message_token ist = function @@ -839,11 +896,6 @@ let interp_message ist l = Ftactic.List.map (interp_message_token ist) l >>= fun l -> Ftactic.return (prlist_with_sep spc (fun x -> x) l) -let interp_message ist l = - let open Ftactic in - Ftactic.List.map (interp_message_token ist) l >>= fun l -> - Ftactic.return (prlist_with_sep spc (fun x -> x) l) - let rec interp_intro_pattern ist env sigma = function | loc, IntroAction pat -> let (sigma,pat) = interp_intro_pattern_action ist env sigma pat in @@ -869,15 +921,20 @@ and interp_intro_pattern_action ist env sigma = function | IntroApplyOn (c,ipat) -> let c = { delayed = fun env sigma -> let sigma = Sigma.to_evar_map sigma in - let (sigma, c) = interp_constr ist env sigma c in + let (sigma, c) = interp_open_constr ist env sigma c in Sigma.Unsafe.of_pair (c, sigma) } in let sigma,ipat = interp_intro_pattern ist env sigma ipat in sigma, IntroApplyOn (c,ipat) | IntroWildcard | IntroRewrite _ as x -> sigma, x -and interp_or_and_intro_pattern ist env sigma = - List.fold_map (interp_intro_pattern_list_as_list ist env) sigma +and interp_or_and_intro_pattern ist env sigma = function + | IntroAndPattern l -> + let sigma, l = List.fold_map (interp_intro_pattern ist env) sigma l in + sigma, IntroAndPattern l + | IntroOrPattern ll -> + let sigma, ll = List.fold_map (interp_intro_pattern_list_as_list ist env) sigma ll in + sigma, IntroOrPattern ll and interp_intro_pattern_list_as_list ist env sigma = function | [loc,IntroNaming (IntroIdentifier id)] as l -> @@ -907,9 +964,9 @@ let interp_intro_pattern_option ist env sigma = function let sigma, ipat = interp_intro_pattern ist env sigma ipat in sigma, Some ipat -let interp_in_hyp_as ist env sigma (clear,id,ipat) = +let interp_in_hyp_as ist env sigma (id,ipat) = let sigma, ipat = interp_intro_pattern_option ist env sigma ipat in - sigma,(clear,interp_hyp ist env sigma id,ipat) + sigma,(interp_hyp ist env sigma id,ipat) let interp_quantified_hypothesis ist = function | AnonHyp n -> AnonHyp n @@ -952,19 +1009,11 @@ let interp_constr_with_bindings ist env sigma (c,bl) = let sigma, c = interp_open_constr ist env sigma c in sigma, (c,bl) -let interp_constr_with_bindings_arg ist env sigma (keep,c) = - let sigma, c = interp_constr_with_bindings ist env sigma c in - sigma, (keep,c) - let interp_open_constr_with_bindings ist env sigma (c,bl) = let sigma, bl = interp_bindings ist env sigma bl in let sigma, c = interp_open_constr ist env sigma c in sigma, (c, bl) -let interp_open_constr_with_bindings_arg ist env sigma (keep,c) = - let sigma, c = interp_open_constr_with_bindings ist env sigma c in - sigma,(keep,c) - let loc_of_bindings = function | NoBindings -> Loc.ghost | ImplicitBindings l -> loc_of_glob_constr (fst (List.last l)) @@ -999,10 +1048,12 @@ let interp_induction_arg ist gl arg = if Tactics.is_quantified_hypothesis id' gl then keep,ElimOnIdent (loc,id') else - (try keep,ElimOnConstr { delayed = fun env sigma -> Sigma ((constr_of_id env id',NoBindings), sigma, Sigma.refl) } + (keep, ElimOnConstr { delayed = begin fun env sigma -> + try Sigma.here (constr_of_id env id', NoBindings) sigma with Not_found -> - user_err_loc (loc,"", - pr_id id ++ strbrk " binds to " ++ pr_id id' ++ strbrk " which is neither a declared or a quantified hypothesis.")) + user_err_loc (loc, "interp_induction_arg", + pr_id id ++ strbrk " binds to " ++ pr_id id' ++ strbrk " which is neither a declared nor a quantified hypothesis.") + end }) in try (** FIXME: should be moved to taccoerce *) @@ -1058,7 +1109,7 @@ let use_types = false let eval_pattern lfun ist env sigma ((glob,_),pat as c) = let bound_names = bound_glob_vars glob in if use_types then - (bound_names,pi3 (interp_typed_pattern ist env sigma c)) + (bound_names,interp_typed_pattern ist env sigma c) else (bound_names,instantiate_pattern env sigma lfun pat) @@ -1096,20 +1147,17 @@ let rec read_match_rule lfun ist env sigma = function (* misc *) -let mk_constr_value ist gl c = - let (sigma,c_interp) = pf_interp_constr ist gl c in - sigma, Value.of_constr c_interp -let mk_open_constr_value ist gl c = - let (sigma,c_interp) = pf_apply (interp_open_constr ist) gl c in - sigma, Value.of_constr c_interp -let mk_hyp_value ist env sigma c = - Value.of_constr (mkVar (interp_hyp ist env sigma c)) -let mk_int_or_var_value ist c = in_gen (topwit wit_int) (interp_int_or_var ist c) - -let pack_sigma (sigma,c) = {it=c;sigma=sigma;} +let interp_focussed wit f v = + Ftactic.nf_enter { enter = begin fun gl -> + let v = Genarg.out_gen (glbwit wit) v in + let env = Proofview.Goal.env gl in + let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + let v = in_gen (topwit wit) (f env sigma v) in + Ftactic.return v + end } (* Interprets an l-tac expression into a value *) -let rec val_interp ist ?(appl=UnnamedAppl) (tac:glob_tactic_expr) : typed_generic_argument Ftactic.t = +let rec val_interp ist ?(appl=UnnamedAppl) (tac:glob_tactic_expr) : Val.t Ftactic.t = (* The name [appl] of applied top-level Ltac names is ignored in [value_interp]. It is installed in the second step by a call to [name_vfun], because it gives more opportunities to detect a @@ -1136,7 +1184,7 @@ let rec val_interp ist ?(appl=UnnamedAppl) (tac:glob_tactic_expr) : typed_generi let ist = { ist with extra = TacStore.set ist.extra f_debug v } in value_interp ist >>= fun v -> return (name_vfun appl v) in - Ftactic.debug_prompt lev tac eval + Tactic_debug.debug_prompt lev tac eval | _ -> value_interp ist >>= fun v -> return (name_vfun appl v) @@ -1175,7 +1223,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with end | TacAbstract (tac,ido) -> Proofview.Goal.nf_enter { enter = begin fun gl -> Tactics.tclABSTRACT - (Option.map (Tacmach.New.of_old (pf_interp_ident ist) gl) ido) (interp_tactic ist tac) + (Option.map (pf_interp_ident ist gl) ido) (interp_tactic ist tac) end } | TacThen (t1,t) -> Tacticals.New.tclTHEN (interp_tactic ist t1) (interp_tactic ist t) @@ -1219,102 +1267,12 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with eval_tactic ist tac (* For extensions *) | TacAlias (loc,s,l) -> - let body = Tacenv.interp_alias s in - let rec f x = match genarg_tag x with - | QuantHypArgType | RedExprArgType - | ConstrWithBindingsArgType - | BindingsArgType - | OptArgType _ | PairArgType _ -> (** generic handler *) - Ftactic.nf_enter begin fun gl -> - let sigma = Tacmach.New.project gl in - let env = Proofview.Goal.env gl in - let concl = Proofview.Goal.concl gl in - let goal = Proofview.Goal.goal gl in - let (sigma, arg) = interp_genarg ist env sigma concl goal x in - Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return arg) - end - | _ as tag -> (** Special treatment. TODO: use generic handler *) - Ftactic.nf_enter begin fun gl -> - let sigma = Tacmach.New.project gl in - let env = Proofview.Goal.env gl in - match tag with - | IntOrVarArgType -> - Ftactic.return (mk_int_or_var_value ist (out_gen (glbwit wit_int_or_var) x)) - | IdentArgType -> - Ftactic.return (value_of_ident (interp_ident ist env sigma - (out_gen (glbwit wit_ident) x))) - | VarArgType -> - Ftactic.return (mk_hyp_value ist env sigma (out_gen (glbwit wit_var) x)) - | GenArgType -> f (out_gen (glbwit wit_genarg) x) - | ConstrArgType -> - let (sigma,v) = - Tacmach.New.of_old (fun gl -> mk_constr_value ist gl (out_gen (glbwit wit_constr) x)) gl - in - Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return v) - | OpenConstrArgType -> - let (sigma,v) = - Tacmach.New.of_old (fun gl -> mk_open_constr_value ist gl (snd (out_gen (glbwit wit_open_constr) x))) gl in - Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return v) - | ConstrMayEvalArgType -> - let (sigma,c_interp) = - interp_constr_may_eval ist env sigma - (out_gen (glbwit wit_constr_may_eval) x) - in - Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return (Value.of_constr c_interp)) - | ListArgType ConstrArgType -> - let wit = glbwit (wit_list wit_constr) in - let (sigma,l_interp) = Tacmach.New.of_old begin fun gl -> - Evd.MonadR.List.map_right - (fun c sigma -> mk_constr_value ist { gl with sigma=sigma } c) - (out_gen wit x) - (project gl) - end gl in - Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return (in_gen (topwit (wit_list wit_genarg)) l_interp)) - | ListArgType VarArgType -> - let wit = glbwit (wit_list wit_var) in - Ftactic.return ( - let ans = List.map (mk_hyp_value ist env sigma) (out_gen wit x) in - in_gen (topwit (wit_list wit_genarg)) ans - ) - | ListArgType IntOrVarArgType -> - let wit = glbwit (wit_list wit_int_or_var) in - let ans = List.map (mk_int_or_var_value ist) (out_gen wit x) in - Ftactic.return (in_gen (topwit (wit_list wit_genarg)) ans) - | ListArgType IdentArgType -> - let wit = glbwit (wit_list wit_ident) in - let mk_ident x = value_of_ident (interp_ident ist env sigma x) in - let ans = List.map mk_ident (out_gen wit x) in - Ftactic.return (in_gen (topwit (wit_list wit_genarg)) ans) - | ListArgType t -> - let open Ftactic in - let list_unpacker wit l = - let map x = - f (in_gen (glbwit wit) x) >>= fun v -> - Ftactic.return (out_gen (topwit wit) v) - in - Ftactic.List.map map (glb l) >>= fun l -> - Ftactic.return (in_gen (topwit (wit_list wit)) l) - in - list_unpack { list_unpacker } x - | ExtraArgType _ -> - (** Special treatment of tactics *) - if has_type x (glbwit wit_tactic) then - let tac = out_gen (glbwit wit_tactic) x in - val_interp ist tac - else - let goal = Proofview.Goal.goal gl in - let (newsigma,v) = Geninterp.generic_interp ist {Evd.it=goal;sigma} x in - Ftactic.(lift (Proofview.Unsafe.tclEVARS newsigma) <*> return v) - | _ -> assert false - end - in + let (ids, body) = Tacenv.interp_alias s in let (>>=) = Ftactic.bind in - let interp_vars = - Ftactic.List.map (fun (x,v) -> f v >>= fun v -> Ftactic.return (x,v)) l - in - let addvar (x, v) accu = Id.Map.add x v accu in + let interp_vars = Ftactic.List.map (fun v -> interp_tacarg ist v) l in let tac l = - let lfun = List.fold_right addvar l ist.lfun in + let addvar x v accu = Id.Map.add x v accu in + let lfun = List.fold_right2 addvar ids l ist.lfun in let trace = push_trace (loc,LtacNotationCall s) ist in let ist = { lfun = lfun; @@ -1323,52 +1281,35 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with Ftactic.lift (tactic_of_value ist v) in let tac = - Ftactic.with_env interp_vars >>= fun (env,l) -> - let name () = Pptactic.pr_tactic env (TacAlias(loc,s,l)) in - Proofview.Trace.name_tactic name (tac l) + Ftactic.with_env interp_vars >>= fun (env, lr) -> + let name () = Pptactic.pr_alias (fun v -> print_top_val env v) 0 s lr in + Proofview.Trace.name_tactic name (tac lr) (* spiwack: this use of name_tactic is not robust to a change of implementation of [Ftactic]. In such a situation, some more elaborate solution will have to be used. *) in + let tac = + let len1 = List.length ids in + let len2 = List.length l in + if len1 = len2 then tac + else Tacticals.New.tclZEROMSG (str "Arguments length mismatch: \ + expected " ++ int len1 ++ str ", found " ++ int len2) + in Ftactic.run tac (fun () -> Proofview.tclUNIT ()) - | TacML (loc,opn,l) when List.for_all global_genarg l -> - let trace = push_trace (loc,LtacMLCall tac) ist in - let ist = { ist with extra = TacStore.set ist.extra f_trace trace; } in - (* spiwack: a special case for tactics (from TACTIC EXTEND) when - every argument can be interpreted without a - [Proofview.Goal.nf_enter]. *) - let tac = Tacenv.interp_ml_tactic opn in - (* dummy values, will be ignored *) - let env = Environ.empty_env in - let sigma = Evd.empty in - let concl = Term.mkRel (-1) in - let goal = Evar.unsafe_of_int (-1) in - (* /dummy values *) - let args = List.map (fun a -> snd(interp_genarg ist env sigma concl goal a)) l in - let name () = Pptactic.pr_tactic env (TacML(loc,opn,args)) in - Proofview.Trace.name_tactic name - (catch_error_tac trace (tac args ist)) | TacML (loc,opn,l) -> + let open Ftactic.Notations in let trace = push_trace (loc,LtacMLCall tac) ist in let ist = { ist with extra = TacStore.set ist.extra f_trace trace; } in - Proofview.Goal.nf_enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let goal_sigma = Tacmach.New.project gl in - let concl = Proofview.Goal.concl gl in - let goal = Proofview.Goal.goal gl in - let tac = Tacenv.interp_ml_tactic opn in - let (sigma,args) = - Evd.MonadR.List.map_right - (fun a sigma -> interp_genarg ist env sigma concl goal a) l goal_sigma - in - Proofview.Unsafe.tclEVARS sigma <*> - let name () = Pptactic.pr_tactic env (TacML(loc,opn,args)) in - Proofview.Trace.name_tactic name - (catch_error_tac trace (tac args ist)) - end } + let tac = Tacenv.interp_ml_tactic opn in + let args = Ftactic.List.map_right (fun a -> interp_tacarg ist a) l in + let tac args = + let name () = Pptactic.pr_extend (fun v -> print_top_val () v) 0 opn args in + Proofview.Trace.name_tactic name (catch_error_tac trace (tac args ist)) + in + Ftactic.run args tac -and force_vrec ist v : typed_generic_argument Ftactic.t = +and force_vrec ist v : Val.t Ftactic.t = let v = Value.normalize v in if has_type v (topwit wit_tacvalue) then let v = to_tacvalue v in @@ -1377,7 +1318,7 @@ and force_vrec ist v : typed_generic_argument Ftactic.t = | v -> Ftactic.return (of_tacvalue v) else Ftactic.return v -and interp_ltac_reference loc' mustbetac ist r : typed_generic_argument Ftactic.t = +and interp_ltac_reference loc' mustbetac ist r : Val.t Ftactic.t = match r with | ArgVar (loc,id) -> let v = @@ -1397,29 +1338,17 @@ and interp_ltac_reference loc' mustbetac ist r : typed_generic_argument Ftactic. let appl = GlbAppl[r,[]] in val_interp ~appl ist (Tacenv.interp_ltac r) -and interp_tacarg ist arg : typed_generic_argument Ftactic.t = +and interp_tacarg ist arg : Val.t Ftactic.t = match arg with - | TacGeneric arg -> - Ftactic.nf_enter begin fun gl -> - let sigma = Tacmach.New.project gl in - let goal = Proofview.Goal.goal gl in - let (sigma,v) = Geninterp.generic_interp ist {Evd.it=goal;sigma} arg in - Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return v) - end + | TacGeneric arg -> interp_genarg ist arg | Reference r -> interp_ltac_reference dloc false ist r | ConstrMayEval c -> - Ftactic.enter begin fun gl -> - let sigma = Tacmach.New.project gl in + Ftactic.s_enter { s_enter = begin fun gl -> + let sigma = project gl in let env = Proofview.Goal.env gl in let (sigma,c_interp) = interp_constr_may_eval ist env sigma c in - Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return (Value.of_constr c_interp)) - end - | UConstr c -> - Ftactic.enter begin fun gl -> - let env = Proofview.Goal.env gl in - Ftactic.return (Value.of_uconstr (interp_uconstr ist env c)) - end - | MetaIdArg (loc,_,id) -> assert false + Sigma.Unsafe.of_pair (Ftactic.return (Value.of_constr c_interp), sigma) + end } | TacCall (loc,r,[]) -> interp_ltac_reference loc true ist r | TacCall (loc,f,l) -> @@ -1428,26 +1357,18 @@ and interp_tacarg ist arg : typed_generic_argument Ftactic.t = Ftactic.List.map (fun a -> interp_tacarg ist a) l >>= fun largs -> interp_app loc ist fv largs | TacFreshId l -> - Ftactic.enter begin fun gl -> - let id = interp_fresh_id ist (Tacmach.New.pf_env gl) (Tacmach.New.project gl) l in + Ftactic.enter { enter = begin fun gl -> + let id = interp_fresh_id ist (pf_env gl) (project gl) l in Ftactic.return (in_gen (topwit wit_intro_pattern) (dloc, IntroNaming (IntroIdentifier id))) - end + end } | TacPretype c -> - Ftactic.enter begin fun gl -> - let sigma = Tacmach.New.project gl in + Ftactic.s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in - let {closure;term} = interp_uconstr ist env c in - let vars = { - Pretyping.ltac_constrs = closure.typed; - Pretyping.ltac_uconstrs = closure.untyped; - Pretyping.ltac_idents = closure.idents; - Pretyping.ltac_genargs = ist.lfun; - } in - let (sigma,c_interp) = - Pretyping.understand_ltac constr_flags env sigma vars WithoutTypeConstraint term - in - Ftactic.(lift (Proofview.Unsafe.tclEVARS sigma) <*> return (Value.of_constr c_interp)) - end + let c = interp_uconstr ist env c in + let Sigma (c, sigma, p) = (type_uconstr ist c).delayed env sigma in + Sigma (Ftactic.return (Value.of_constr c), sigma, p) + end } | TacNumgoals -> Ftactic.lift begin let open Proofview.Notations in @@ -1455,20 +1376,9 @@ and interp_tacarg ist arg : typed_generic_argument Ftactic.t = Proofview.tclUNIT (Value.of_int i) end | Tacexp t -> val_interp ist t - | TacDynamic(_,t) -> - let tg = (Dyn.tag t) in - if String.equal tg "tactic" then - val_interp ist (tactic_out t ist) - else if String.equal tg "value" then - Ftactic.return (value_out t) - else if String.equal tg "constr" then - Ftactic.return (Value.of_constr (constr_out t)) - else - Errors.anomaly ~loc:dloc ~label:"Tacinterp.val_interp" - (str "Unknown dynamic: <" ++ str (Dyn.tag t) ++ str ">") (* Interprets an application node *) -and interp_app loc ist fv largs : typed_generic_argument Ftactic.t = +and interp_app loc ist fv largs : Val.t Ftactic.t = let (>>=) = Ftactic.bind in let fail = Tacticals.New.tclZEROMSG (str "Illegal tactic application.") in let fv = Value.normalize fv in @@ -1525,7 +1435,7 @@ and tactic_of_value ist vle = | (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 + tactic_of_value ist tac else Tacticals.New.tclZEROMSG (str "Expression does not evaluate to a tactic.") (* Interprets the clauses of a recursive LetIn *) @@ -1612,141 +1522,84 @@ and interp_match ist lz constr lmr = Proofview.tclZERO ~info e end end >>= fun constr -> - Ftactic.enter begin fun gl -> - let sigma = Tacmach.New.project gl in + Ftactic.enter { enter = begin fun gl -> + let sigma = project gl in let env = Proofview.Goal.env gl in let ilr = read_match_rule (extract_ltac_constr_values ist env) ist env sigma lmr in interp_match_successes lz ist (Tactic_matching.match_term env sigma constr ilr) - end + end } (* Interprets the Match Context expressions *) and interp_match_goal ist lz lr lmr = - Ftactic.nf_enter begin fun gl -> - let sigma = Tacmach.New.project gl in + Ftactic.nf_enter { enter = begin fun gl -> + let sigma = project gl in let env = Proofview.Goal.env gl in let hyps = Proofview.Goal.hyps gl in let hyps = if lr then List.rev hyps else hyps in let concl = Proofview.Goal.concl gl in let ilr = read_match_rule (extract_ltac_constr_values ist env) ist env sigma lmr in interp_match_successes lz ist (Tactic_matching.match_goal env sigma hyps concl ilr) - end + end } (* Interprets extended tactic generic arguments *) -(* spiwack: interp_genarg has an argument [concl] for the case of - "casted open constr". And [gl] for [Geninterp]. I haven't changed - the interface for geninterp yet as it is used by ARGUMENT EXTEND - (in turn used by plugins). At the time I'm writing this comment - though, the only concerned plugins are the declarative mode (which - needs the [extra] field of goals to interprete rules) and ssreflect - (a handful of time). I believe we'd need to address "casted open - constr" and the declarative mode rules to provide a reasonable - interface. *) -and interp_genarg ist env sigma concl gl x = - let evdref = ref sigma in - let rec interp_genarg x = - match genarg_tag x with - | IntOrVarArgType -> - in_gen (topwit wit_int_or_var) - (ArgArg (interp_int_or_var ist (out_gen (glbwit wit_int_or_var) x))) - | IdentArgType -> - in_gen (topwit wit_ident) - (interp_ident ist env sigma (out_gen (glbwit wit_ident) x)) - | VarArgType -> - in_gen (topwit wit_var) (interp_hyp ist env sigma (out_gen (glbwit wit_var) x)) - | GenArgType -> - in_gen (topwit wit_genarg) (interp_genarg (out_gen (glbwit wit_genarg) x)) - | ConstrArgType -> - let (sigma,c_interp) = - interp_constr ist env !evdref (out_gen (glbwit wit_constr) x) - in - evdref := sigma; - in_gen (topwit wit_constr) c_interp - | ConstrMayEvalArgType -> - let (sigma,c_interp) = interp_constr_may_eval ist env !evdref (out_gen (glbwit wit_constr_may_eval) x) in - evdref := sigma; - in_gen (topwit wit_constr_may_eval) c_interp - | QuantHypArgType -> - in_gen (topwit wit_quant_hyp) - (interp_declared_or_quantified_hypothesis ist env sigma - (out_gen (glbwit wit_quant_hyp) x)) - | RedExprArgType -> - let (sigma,r_interp) = - interp_red_expr ist env !evdref (out_gen (glbwit wit_red_expr) x) - in - evdref := sigma; - in_gen (topwit wit_red_expr) r_interp - | OpenConstrArgType -> - let expected_type = WithoutTypeConstraint in - in_gen (topwit wit_open_constr) - (interp_open_constr ~expected_type - ist env !evdref - (snd (out_gen (glbwit wit_open_constr) x))) - | ConstrWithBindingsArgType -> - in_gen (topwit wit_constr_with_bindings) - (pack_sigma (interp_constr_with_bindings ist env !evdref - (out_gen (glbwit wit_constr_with_bindings) x))) - | BindingsArgType -> - in_gen (topwit wit_bindings) - (pack_sigma (interp_bindings ist env !evdref (out_gen (glbwit wit_bindings) x))) - | ListArgType ConstrArgType -> - let (sigma,v) = interp_genarg_constr_list ist env !evdref x in - evdref := sigma; - v - | ListArgType VarArgType -> interp_genarg_var_list ist env sigma x - | ListArgType _ -> - let list_unpacker wit l = - let map x = - out_gen (topwit wit) (interp_genarg (in_gen (glbwit wit) x)) - in - in_gen (topwit (wit_list wit)) (List.map map (glb l)) +and interp_genarg ist x : Val.t Ftactic.t = + let open Ftactic.Notations in + (** Ad-hoc handling of some types. *) + let tag = genarg_tag x in + if argument_type_eq tag (unquote (topwit (wit_list wit_var))) then + interp_genarg_var_list ist x + else if argument_type_eq tag (unquote (topwit (wit_list wit_constr))) then + interp_genarg_constr_list ist x + else + let GenArg (Glbwit wit, x) = x in + match wit with + | ListArg wit -> + let map x = + interp_genarg ist (Genarg.in_gen (glbwit wit) x) >>= fun x -> + Ftactic.return (Value.cast (topwit wit) x) in - list_unpack { list_unpacker } x - | OptArgType _ -> - let opt_unpacker wit o = match glb o with - | None -> in_gen (topwit (wit_opt wit)) None + Ftactic.List.map map x >>= fun l -> + Ftactic.return (Value.of_list (val_tag wit) l) + | OptArg wit -> + let ans = match x with + | None -> Ftactic.return (Value.of_option (val_tag wit) None) | Some x -> - let x = out_gen (topwit wit) (interp_genarg (in_gen (glbwit wit) x)) in - in_gen (topwit (wit_opt wit)) (Some x) + interp_genarg ist (Genarg.in_gen (glbwit wit) x) >>= fun x -> + let x = Value.cast (topwit wit) x in + Ftactic.return (Value.of_option (val_tag wit) (Some x)) in - opt_unpack { opt_unpacker } x - | PairArgType _ -> - let pair_unpacker wit1 wit2 o = - let (p, q) = glb o in - let p = out_gen (topwit wit1) (interp_genarg (in_gen (glbwit wit1) p)) in - let q = out_gen (topwit wit2) (interp_genarg (in_gen (glbwit wit2) q)) in - in_gen (topwit (wit_pair wit1 wit2)) (p, q) - in - pair_unpack { pair_unpacker } x - | ExtraArgType s -> - let (sigma,v) = Geninterp.generic_interp ist { Evd.it=gl;sigma=(!evdref) } x in - evdref:=sigma; - v - in - let v = interp_genarg x in - !evdref , v - + ans + | PairArg (wit1, wit2) -> + let (p, q) = x in + interp_genarg ist (Genarg.in_gen (glbwit wit1) p) >>= fun p -> + interp_genarg ist (Genarg.in_gen (glbwit wit2) q) >>= fun q -> + let p = Value.cast (topwit wit1) p in + let q = Value.cast (topwit wit2) q in + Ftactic.return (Val.Dyn (Val.Pair (val_tag wit1, val_tag wit2), (p, q))) + | ExtraArg s -> + Geninterp.generic_interp ist (Genarg.in_gen (glbwit wit) x) (** returns [true] for genargs which have the same meaning independently of goals. *) -and global_genarg = - let rec global_tag = function - | IntOrVarArgType | GenArgType -> true - | ListArgType t | OptArgType t -> global_tag t - | PairArgType (t1,t2) -> global_tag t1 && global_tag t2 - | _ -> false - in - fun x -> global_tag (genarg_tag x) - -and interp_genarg_constr_list ist env sigma x = - let lc = out_gen (glbwit (wit_list wit_constr)) x in +and interp_genarg_constr_list ist x = + Ftactic.nf_s_enter { s_enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + let lc = Genarg.out_gen (glbwit (wit_list wit_constr)) x in let (sigma,lc) = interp_constr_list ist env sigma lc in - sigma , in_gen (topwit (wit_list wit_constr)) lc + let lc = Value.of_list (val_tag wit_constr) lc in + Sigma.Unsafe.of_pair (Ftactic.return lc, sigma) + end } -and interp_genarg_var_list ist env sigma x = - let lc = out_gen (glbwit (wit_list wit_var)) x in +and interp_genarg_var_list ist x = + Ftactic.nf_enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + let lc = Genarg.out_gen (glbwit (wit_list wit_var)) x in let lc = interp_hyp_list ist env sigma lc in - in_gen (topwit (wit_list wit_var)) lc + Ftactic.return (Value.of_list (val_tag wit_var) lc) + end } (* Interprets tactic expressions : returns a "constr" *) and interp_ltac_constr ist e : constr Ftactic.t = @@ -1755,7 +1608,7 @@ and interp_ltac_constr ist e : constr Ftactic.t = (val_interp ist e) begin function (err, info) -> match err with | Not_found -> - Ftactic.enter begin fun gl -> + Ftactic.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in Proofview.tclLIFT begin debugging_step ist (fun () -> @@ -1763,13 +1616,13 @@ and interp_ltac_constr ist e : constr Ftactic.t = Pptactic.pr_glob_tactic env e) end <*> Proofview.tclZERO Not_found - end + end } | err -> Proofview.tclZERO ~info err end end >>= fun result -> - Ftactic.enter begin fun gl -> + Ftactic.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in + let sigma = project gl in let result = Value.normalize result in try let cresult = coerce_to_closed_constr env result in @@ -1784,7 +1637,7 @@ and interp_ltac_constr ist e : constr Ftactic.t = let env = Proofview.Goal.env gl in Tacticals.New.tclZEROMSG (str "Must evaluate to a closed term" ++ fnl() ++ str "offending expression: " ++ fnl() ++ pr_inspect env e result) - end + end } (* Interprets tactic expressions : returns a "tactic" *) @@ -1807,19 +1660,19 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacIntroPattern l -> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in + let sigma = project gl in let sigma,l' = interp_intro_pattern_list_as_list ist env sigma l in Tacticals.New.tclWITHHOLES false (name_atomic ~env (TacIntroPattern l) (* spiwack: print uninterpreted, not sure if it is the expected behaviour. *) - (Tactics.intros_patterns l')) sigma + (Tactics.intro_patterns l')) sigma end } | TacIntroMove (ido,hto) -> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in + let sigma = project gl in let mloc = interp_move_location ist env sigma hto in let ido = Option.map (interp_ident ist env sigma) ido in name_atomic ~env @@ -1829,20 +1682,17 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacExact c -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun () -> Pp.str"<exact>") begin - Proofview.V82.tactic begin fun gl -> - let (sigma,c_interp) = pf_interp_casted_constr ist gl c in - tclTHEN - (tclEVARS sigma) - (Tactics.exact_no_check c_interp) - gl - end + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let (sigma, c_interp) = pf_interp_casted_constr ist gl c in + Sigma.Unsafe.of_pair (Proofview.V82.tactic (Tactics.exact_no_check c_interp), sigma) + end } end | TacApply (a,ev,cb,cl) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun () -> Pp.str"<apply>") begin Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in + let sigma = project gl in let l = List.map (fun (k,c) -> let loc, f = interp_open_constr_with_bindings_loc ist c in (k,(loc,f))) cb @@ -1850,15 +1700,15 @@ and interp_atomic ist tac : unit Proofview.tactic = let sigma,tac = match cl with | None -> sigma, Tactics.apply_with_delayed_bindings_gen a ev l | Some cl -> - let sigma,(clear,id,cl) = interp_in_hyp_as ist env sigma cl in - sigma, Tactics.apply_delayed_in a ev clear id l cl in + let sigma,(id,cl) = interp_in_hyp_as ist env sigma cl in + sigma, Tactics.apply_delayed_in a ev id l cl in Tacticals.New.tclWITHHOLES ev tac sigma end } end | TacElim (ev,(keep,cb),cbo) -> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in + let sigma = project gl in let sigma, cb = interp_constr_with_bindings ist env sigma cb in let sigma, cbo = Option.fold_map (interp_constr_with_bindings ist env) sigma cbo in let named_tac = @@ -1869,7 +1719,7 @@ and interp_atomic ist tac : unit Proofview.tactic = end } | TacCase (ev,(keep,cb)) -> Proofview.Goal.enter { enter = begin fun gl -> - let sigma = Tacmach.New.project gl in + let sigma = project gl in let env = Proofview.Goal.env gl in let sigma, cb = interp_constr_with_bindings ist env sigma cb in let named_tac = @@ -1878,62 +1728,40 @@ and interp_atomic ist tac : unit Proofview.tactic = in Tacticals.New.tclWITHHOLES ev named_tac sigma end } - | TacFix (idopt,n) -> - Proofview.Goal.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in - let idopt = Option.map (interp_ident ist env sigma) idopt in - name_atomic ~env - (TacFix(idopt,n)) - (Proofview.V82.tactic (Tactics.fix idopt n)) - end } | TacMutualFix (id,n,l) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun () -> Pp.str"<mutual fix>") begin - Proofview.V82.tactic begin fun gl -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let env = pf_env gl in let f sigma (id,n,c) = - let (sigma,c_interp) = pf_interp_type ist { gl with sigma=sigma } c in + let (sigma,c_interp) = pf_interp_type ist env sigma c in sigma , (interp_ident ist env sigma id,n,c_interp) in let (sigma,l_interp) = Evd.MonadR.List.map_right (fun c sigma -> f sigma c) l (project gl) in - tclTHEN - (tclEVARS sigma) - (Tactics.mutual_fix (interp_ident ist env sigma id) n l_interp 0) - gl - end - end - | TacCofix idopt -> - Proofview.Goal.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in - let idopt = Option.map (interp_ident ist env sigma) idopt in - name_atomic ~env - (TacCofix (idopt)) - (Proofview.V82.tactic (Tactics.cofix idopt)) + let tac = Proofview.V82.tactic (Tactics.mutual_fix (interp_ident ist env sigma id) n l_interp 0) in + Sigma.Unsafe.of_pair (tac, sigma) end } + end | TacMutualCofix (id,l) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun () -> Pp.str"<mutual cofix>") begin - Proofview.V82.tactic begin fun gl -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let env = pf_env gl in let f sigma (id,c) = - let (sigma,c_interp) = pf_interp_type ist { gl with sigma=sigma } c in + let (sigma,c_interp) = pf_interp_type ist env sigma c in sigma , (interp_ident ist env sigma id,c_interp) in let (sigma,l_interp) = Evd.MonadR.List.map_right (fun c sigma -> f sigma c) l (project gl) in - tclTHEN - (tclEVARS sigma) - (Tactics.mutual_cofix (interp_ident ist env sigma id) l_interp 0) - gl - end + let tac = Proofview.V82.tactic (Tactics.mutual_cofix (interp_ident ist env sigma id) l_interp 0) in + Sigma.Unsafe.of_pair (tac, sigma) + end } end | TacAssert (b,t,ipat,c) -> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in + let sigma = project gl in let (sigma,c) = (if Option.is_empty t then interp_constr else interp_type) ist env sigma c in @@ -1946,32 +1774,24 @@ and interp_atomic ist tac : unit Proofview.tactic = end } | TacGeneralize cl -> Proofview.Goal.enter { enter = begin fun gl -> - let sigma = Tacmach.New.project gl in + let sigma = project gl in let env = Proofview.Goal.env gl in let sigma, cl = interp_constr_with_occurrences_and_name_as_list ist env sigma cl in Tacticals.New.tclWITHHOLES false (name_atomic ~env (TacGeneralize cl) - (Proofview.V82.tactic (Tactics.Simple.generalize_gen cl))) sigma + (Proofview.V82.tactic (Tactics.generalize_gen cl))) sigma end } - | TacGeneralizeDep c -> - (new_interp_constr ist c) (fun c -> - name_atomic (* spiwack: probably needs a goal environment *) - (TacGeneralizeDep c) - (Proofview.V82.tactic (Tactics.generalize_dep c)) - ) | TacLetTac (na,c,clp,b,eqpat) -> Proofview.V82.nf_evar_goals <*> Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in + let sigma = project gl in let clp = interp_clause ist env sigma clp in let eqpat = interp_intro_pattern_naming_option ist env sigma eqpat in if Locusops.is_nowhere clp then (* We try to fully-typecheck the term *) - let (sigma,c_interp) = - Tacmach.New.of_old (fun gl -> pf_interp_constr ist gl c) gl - in + let (sigma,c_interp) = pf_interp_constr ist gl c in let let_tac b na c cl eqpat = let id = Option.default (Loc.ghost,IntroAnonymous) eqpat in let with_eq = if b then None else Some (true,id) in @@ -1997,56 +1817,20 @@ and interp_atomic ist tac : unit Proofview.tactic = ((sigma,sigma'),c) clp eqpat) sigma') end } - (* Automation tactics *) - | TacTrivial (debug,lems,l) -> - begin if debug == Tacexpr.Info then - msg_warning - (strbrk"The \"info_trivial\" tactic" ++ spc () - ++strbrk"does not print traces anymore." ++ spc() - ++strbrk"Use \"Info 1 trivial\", instead.") - end; - Proofview.Goal.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in - let lems = interp_auto_lemmas ist env sigma lems in - name_atomic ~env - (TacTrivial(debug,List.map snd lems,l)) - (Auto.h_trivial ~debug - lems - (Option.map (List.map (interp_hint_base ist)) l)) - end } - | TacAuto (debug,n,lems,l) -> - begin if debug == Tacexpr.Info then - msg_warning - (strbrk"The \"info_auto\" tactic" ++ spc () - ++strbrk"does not print traces anymore." ++ spc() - ++strbrk"Use \"Info 1 auto\", instead.") - end; - Proofview.Goal.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in - let lems = interp_auto_lemmas ist env sigma lems in - name_atomic ~env - (TacAuto(debug,n,List.map snd lems,l)) - (Auto.h_auto ~debug (Option.map (interp_int_or_var ist) n) - lems - (Option.map (List.map (interp_hint_base ist)) l)) - end } - (* Derived basic tactics *) | TacInductionDestruct (isrec,ev,(l,el)) -> (* spiwack: some unknown part of destruct needs the goal to be prenormalised. *) Proofview.V82.nf_evar_goals <*> - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in + let sigma = project gl in let sigma,l = List.fold_map begin fun sigma (c,(ipato,ipats),cls) -> (* TODO: move sigma as a side-effect *) (* spiwack: the [*p] variants are for printing *) let cp = c in - let c = Tacmach.New.of_old (fun gl -> interp_induction_arg ist gl c) gl in + let c = interp_induction_arg ist gl c in let ipato = interp_intro_pattern_naming_option ist env sigma ipato in let ipatsp = ipats in let sigma,ipats = interp_or_and_intro_pattern_option ist env sigma ipats in @@ -2057,11 +1841,11 @@ and interp_atomic ist tac : unit Proofview.tactic = let l,lp = List.split l in let sigma,el = Option.fold_map (interp_constr_with_bindings ist env) sigma el in - name_atomic ~env + let tac = name_atomic ~env (TacInductionDestruct(isrec,ev,(lp,el))) - (Tacticals.New.tclTHEN - (Proofview.Unsafe.tclEVARS sigma) - (Tactics.induction_destruct isrec ev (l,el))) + (Tactics.induction_destruct isrec ev (l,el)) + in + Sigma.Unsafe.of_pair (tac, sigma) end } | TacDoubleInduction (h1,h2) -> let h1 = interp_quantified_hypothesis ist h1 in @@ -2070,36 +1854,10 @@ and interp_atomic ist tac : unit Proofview.tactic = (TacDoubleInduction (h1,h2)) (Elim.h_double_induction h1 h2) (* Context management *) - | TacClear (b,l) -> - Proofview.Goal.enter { enter = begin fun gl -> - let env = Tacmach.New.pf_env gl in - let sigma = Tacmach.New.project gl in - let l = interp_hyp_list ist env sigma l in - if b then name_atomic ~env (TacClear (b, l)) (Tactics.keep l) - else - (* spiwack: until the tactic is in the monad *) - let tac = Proofview.V82.tactic (fun gl -> Tactics.clear l gl) in - Proofview.Trace.name_tactic (fun () -> Pp.str"<clear>") tac - end } - | TacClearBody l -> - Proofview.Goal.enter { enter = begin fun gl -> - let env = Tacmach.New.pf_env gl in - let sigma = Tacmach.New.project gl in - let l = interp_hyp_list ist env sigma l in - name_atomic ~env - (TacClearBody l) - (Tactics.clear_body l) - end } - | TacMove (id1,id2) -> - Proofview.V82.tactic begin fun gl -> - Tactics.move_hyp (interp_hyp ist (pf_env gl) (project gl) id1) - (interp_move_location ist (pf_env gl) (project gl) id2) - gl - end | TacRename l -> Proofview.Goal.enter { enter = begin fun gl -> - let env = Tacmach.New.pf_env gl in - let sigma = Tacmach.New.project gl in + let env = pf_env gl in + let sigma = project gl in let l = List.map (fun (id1,id2) -> interp_hyp ist env sigma id1, @@ -2110,35 +1868,20 @@ and interp_atomic ist tac : unit Proofview.tactic = (Tactics.rename_hyp l) end } - (* Constructors *) - | TacSplit (ev,bll) -> - Proofview.Goal.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in - let sigma, bll = List.fold_map (interp_bindings ist env) sigma bll in - let named_tac = - let tac = Tactics.split_with_bindings ev bll in - name_atomic ~env (TacSplit (ev, bll)) tac - in - Tacticals.New.tclWITHHOLES ev named_tac sigma - end } (* Conversion *) | TacReduce (r,cl) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun () -> Pp.str"<reduce>") begin - Proofview.V82.tactic begin fun gl -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let (sigma,r_interp) = interp_red_expr ist (pf_env gl) (project gl) r in - tclTHEN - (tclEVARS sigma) - (Tactics.reduce r_interp (interp_clause ist (pf_env gl) (project gl) cl)) - gl - end + Sigma.Unsafe.of_pair (Tactics.reduce r_interp (interp_clause ist (pf_env gl) (project gl) cl), sigma) + end } end | TacChange (None,c,cl) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun () -> Pp.str"<change>") begin Proofview.V82.nf_evar_goals <*> - Proofview.V82.tactic begin fun gl -> + Proofview.Goal.nf_enter { enter = begin fun gl -> let is_onhyps = match cl.onhyps with | None | Some [] -> true | _ -> false @@ -2147,19 +1890,22 @@ and interp_atomic ist tac : unit Proofview.tactic = | AllOccurrences | NoOccurrences -> true | _ -> false in - let c_interp patvars sigma = + let c_interp patvars = { Sigma.run = begin fun sigma -> let lfun' = Id.Map.fold (fun id c lfun -> Id.Map.add id (Value.of_constr c) lfun) patvars ist.lfun in + let sigma = Sigma.to_evar_map sigma in let ist = { ist with lfun = lfun' } in - if is_onhyps && is_onconcl - then interp_type ist (pf_env gl) sigma c - else interp_constr ist (pf_env gl) sigma c - in - (Tactics.change None c_interp (interp_clause ist (pf_env gl) (project gl) cl)) - gl - end + let (sigma, c) = + if is_onhyps && is_onconcl + then interp_type ist (pf_env gl) sigma c + else interp_constr ist (pf_env gl) sigma c + in + Sigma.Unsafe.of_pair (c, sigma) + end } in + Proofview.V82.tactic (Tactics.change None c_interp (interp_clause ist (pf_env gl) (project gl) cl)) + end } end | TacChange (Some op,c,cl) -> (* spiwack: until the tactic is in the monad *) @@ -2167,36 +1913,29 @@ and interp_atomic ist tac : unit Proofview.tactic = Proofview.V82.nf_evar_goals <*> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in + let sigma = project gl in Proofview.V82.tactic begin fun gl -> - let (sigma,sign,op) = interp_typed_pattern ist env sigma op in + let op = interp_typed_pattern ist env sigma op in let to_catch = function Not_found -> true | e -> Errors.is_anomaly e in - let c_interp patvars sigma = + let c_interp patvars = { Sigma.run = begin fun sigma -> let lfun' = Id.Map.fold (fun id c lfun -> Id.Map.add id (Value.of_constr c) lfun) patvars ist.lfun in let ist = { ist with lfun = lfun' } in - try interp_constr ist env sigma c + try + let sigma = Sigma.to_evar_map sigma in + let (sigma, c) = interp_constr ist env sigma c in + Sigma.Unsafe.of_pair (c, sigma) with e when to_catch e (* Hack *) -> errorlabstrm "" (strbrk "Failed to get enough information from the left-hand side to type the right-hand side.") - in + end } in (Tactics.change (Some op) c_interp (interp_clause ist env sigma cl)) - { gl with sigma = sigma } + gl end end } end - (* Equivalence relations *) - | TacSymmetry c -> - Proofview.Goal.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in - let cl = interp_clause ist env sigma c in - name_atomic ~env - (TacSymmetry cl) - (Tactics.intros_symmetry cl) - end } (* Equality and inversion *) | TacRewrite (ev,l,cl,by) -> @@ -2209,7 +1948,7 @@ and interp_atomic ist tac : unit Proofview.tactic = } in (b,m,keep,f)) l in let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in + let sigma = project gl in let cl = interp_clause ist env sigma cl in name_atomic ~env (TacRewrite (ev,l,cl,by)) @@ -2221,14 +1960,12 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacInversion (DepInversion (k,c,ids),hyp) -> Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in + let sigma = project gl in let (sigma,c_interp) = match c with | None -> sigma , None | Some c -> - let (sigma,c_interp) = - Tacmach.New.of_old (fun gl -> pf_interp_constr ist gl c) gl - in + let (sigma,c_interp) = pf_interp_constr ist gl c in sigma , Some c_interp in let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in @@ -2241,7 +1978,7 @@ and interp_atomic ist tac : unit Proofview.tactic = | TacInversion (NonDepInversion (k,idl,ids),hyp) -> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in + let sigma = project gl in let hyps = interp_hyp_list ist env sigma idl in let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in let sigma, ids_interp = interp_or_and_intro_pattern_option ist env sigma ids in @@ -2251,16 +1988,17 @@ and interp_atomic ist tac : unit Proofview.tactic = (Inv.inv_clause k ids_interp hyps dqhyps)) sigma end } | TacInversion (InversionUsing (c,idl),hyp) -> - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in + let sigma = project gl in let (sigma,c_interp) = interp_constr ist env sigma c in let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in let hyps = interp_hyp_list ist env sigma idl in - Proofview.Unsafe.tclEVARS sigma <*> - name_atomic ~env + let tac = name_atomic ~env (TacInversion (InversionUsing (c_interp,hyps),dqhyps)) (Leminv.lemInv_clause dqhyps c_interp hyps) + in + Sigma.Unsafe.of_pair (tac, sigma) end } (* Initial call for interpretation *) @@ -2320,7 +2058,7 @@ let hide_interp global t ot = let def_intern ist x = (ist, x) let def_subst _ x = x -let def_interp ist gl x = (project gl, x) +let def_interp ist x = Ftactic.return x let declare_uniform t = Genintern.register_intern0 t def_intern; @@ -2342,27 +2080,59 @@ let () = let () = declare_uniform wit_pre_ident +let lift f = (); fun ist x -> Ftactic.nf_enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + Ftactic.return (f ist env sigma x) +end } + +let lifts f = (); fun ist x -> Ftactic.nf_s_enter { s_enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + let (sigma, v) = f ist env sigma x in + Sigma.Unsafe.of_pair (Ftactic.return v, sigma) +end } + +let interp_bindings' ist bl = Ftactic.return { delayed = fun env sigma -> + let (sigma, bl) = interp_bindings ist env (Sigma.to_evar_map sigma) bl in + Sigma.Unsafe.of_pair (bl, sigma) + } + +let interp_constr_with_bindings' ist c = Ftactic.return { delayed = fun env sigma -> + let (sigma, c) = interp_constr_with_bindings ist env (Sigma.to_evar_map sigma) c in + Sigma.Unsafe.of_pair (c, sigma) + } + let () = - let interp ist gl ref = (project gl, interp_reference ist (pf_env gl) (project gl) ref) in - Geninterp.register_interp0 wit_ref interp; - let interp ist gl pat = interp_intro_pattern ist (pf_env gl) (project gl) pat in - Geninterp.register_interp0 wit_intro_pattern interp; - let interp ist gl pat = (project gl, interp_clause ist (pf_env gl) (project gl) pat) in - Geninterp.register_interp0 wit_clause_dft_concl interp; - let interp ist gl s = interp_sort (project gl) s in - Geninterp.register_interp0 wit_sort interp + Geninterp.register_interp0 wit_int_or_var (fun ist n -> Ftactic.return (interp_int_or_var ist n)); + Geninterp.register_interp0 wit_ref (lift interp_reference); + Geninterp.register_interp0 wit_ident (lift interp_ident); + Geninterp.register_interp0 wit_var (lift interp_hyp); + Geninterp.register_interp0 wit_intro_pattern (lifts interp_intro_pattern); + Geninterp.register_interp0 wit_clause_dft_concl (lift interp_clause); + Geninterp.register_interp0 wit_constr (lifts interp_constr); + Geninterp.register_interp0 wit_sort (lifts (fun _ _ evd s -> interp_sort evd s)); + Geninterp.register_interp0 wit_tacvalue (fun ist v -> Ftactic.return v); + Geninterp.register_interp0 wit_red_expr (lifts interp_red_expr); + Geninterp.register_interp0 wit_quant_hyp (lift interp_declared_or_quantified_hypothesis); + Geninterp.register_interp0 wit_open_constr (lifts interp_open_constr); + Geninterp.register_interp0 wit_bindings interp_bindings'; + Geninterp.register_interp0 wit_constr_with_bindings interp_constr_with_bindings'; + Geninterp.register_interp0 wit_constr_may_eval (lifts interp_constr_may_eval); + () let () = - let interp ist gl tac = - let f = VFun (UnnamedAppl,extract_trace ist, ist.lfun, [], tac) in - (project gl, TacArg (dloc, valueIn (of_tacvalue f))) - in + let interp ist tac = Ftactic.return (Value.of_closure ist tac) in Geninterp.register_interp0 wit_tactic interp let () = - Geninterp.register_interp0 wit_uconstr (fun ist gl c -> - project gl , interp_uconstr ist (pf_env gl) c - ) + let interp ist tac = interp_tactic ist tac >>= fun () -> Ftactic.return () in + Geninterp.register_interp0 wit_ltac interp + +let () = + Geninterp.register_interp0 wit_uconstr (fun ist c -> Ftactic.nf_enter { enter = begin fun gl -> + Ftactic.return (interp_uconstr ist (Proofview.Goal.env gl) c) + end }) (***************************************************************************) (* Other entry points *) @@ -2377,24 +2147,13 @@ let interp_redexp env sigma r = interp_red_expr ist env sigma (intern_red_expr gist r) (***************************************************************************) -(* Embed tactics in raw or glob tactic expr *) - -let globTacticIn t = TacArg (dloc,TacDynamic (dloc,tactic_in t)) -let tacticIn t = - globTacticIn (fun ist -> - try glob_tactic (t ist) - with e when Errors.noncritical e -> anomaly ~label:"tacticIn" - (str "Incorrect tactic expression. Received exception is:" ++ - Errors.print e)) - -(***************************************************************************) (* Backwarding recursive needs of tactic glob/interp/eval functions *) let _ = let eval ty env sigma lfun arg = let ist = { lfun = lfun; extra = TacStore.empty; } in - if has_type arg (glbwit wit_tactic) then - let tac = out_gen (glbwit wit_tactic) arg in + if Genarg.has_type arg (glbwit wit_tactic) then + let tac = Genarg.out_gen (glbwit wit_tactic) arg in let tac = interp_tactic ist tac in Pfedit.refine_by_tactic env sigma ty tac else @@ -2402,12 +2161,6 @@ let _ = in Hook.set Pretyping.genarg_interp_hook eval -let _ = Hook.set Auto.extern_interp - (fun l -> - let lfun = Id.Map.map (fun c -> Value.of_constr c) l in - let ist = { (default_ist ()) with lfun; } in - interp_tactic ist) - (** Used in tactic extension **) let dummy_id = Id.of_string "_" @@ -2415,7 +2168,7 @@ let dummy_id = Id.of_string "_" let lift_constr_tac_to_ml_tac vars tac = let tac _ ist = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in + let sigma = project gl in let map = function | None -> None | Some id -> @@ -2428,3 +2181,18 @@ let lift_constr_tac_to_ml_tac vars tac = tac args ist end } in tac + +let vernac_debug b = + set_debug (if b then Tactic_debug.DebugOn 0 else Tactic_debug.DebugOff) + +let _ = + let open Goptions in + declare_bool_option + { optsync = false; + optdepr = false; + optname = "Ltac debug"; + optkey = ["Ltac";"Debug"]; + optread = (fun () -> get_debug () != Tactic_debug.DebugOff); + optwrite = vernac_debug } + +let () = Hook.set Vernacentries.interp_redexp_hook interp_redexp diff --git a/tactics/tacinterp.mli b/ltac/tacinterp.mli index 7605c9155..92f12fc8f 100644 --- a/tactics/tacinterp.mli +++ b/ltac/tacinterp.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -14,15 +14,18 @@ open Genarg open Redexpr open Misctypes +val ltac_trace_info : ltac_trace Exninfo.t + module Value : sig - type t = tlevel generic_argument + type t = Val.t val of_constr : constr -> t val to_constr : t -> constr option val of_int : int -> t val to_int : t -> int option val to_list : t -> t list option val of_closure : Geninterp.interp_sign -> glob_tactic_expr -> t + val cast : 'a typed_abstract_argument_type -> Val.t -> 'a end (** Values for interpretation *) @@ -45,14 +48,6 @@ val extract_ltac_constr_values : interp_sign -> Environ.env -> (** Given an interpretation signature, extract all values which are coercible to a [constr]. *) -(** To embed several objects in Coqast.t *) -val tactic_in : (interp_sign -> glob_tactic_expr) -> Dyn.t -val tactic_out : Dyn.t -> (interp_sign -> glob_tactic_expr) - -val tacticIn : (interp_sign -> raw_tactic_expr) -> raw_tactic_expr -val globTacticIn : (interp_sign -> glob_tactic_expr) -> raw_tactic_expr -val valueIn : value -> raw_tactic_arg - (** Sets the debugger mode *) val set_debug : debug_info -> unit @@ -61,10 +56,7 @@ val get_debug : unit -> debug_info (** Adds an interpretation function for extra generic arguments *) -(* spiwack: the [Term.constr] argument is the conclusion of the goal, - for "casted open constr" *) -val interp_genarg : interp_sign -> Environ.env -> Evd.evar_map -> Term.constr -> Goal.goal -> - glob_generic_argument -> Evd.evar_map * typed_generic_argument +val interp_genarg : interp_sign -> glob_generic_argument -> Value.t Ftactic.t (** Interprets any expression *) val val_interp : interp_sign -> glob_tactic_expr -> (value -> unit Proofview.tactic) -> unit Proofview.tactic @@ -93,6 +85,8 @@ val eval_tactic : glob_tactic_expr -> unit Proofview.tactic val eval_tactic_ist : interp_sign -> glob_tactic_expr -> unit Proofview.tactic (** Same as [eval_tactic], but with the provided [interp_sign]. *) +val tactic_of_value : interp_sign -> Value.t -> unit Proofview.tactic + (** Globalization + interpretation *) val interp_tac_gen : value Id.Map.t -> Id.t list -> diff --git a/tactics/tacsubst.ml b/ltac/tacsubst.ml index afffaffbe..4059877b7 100644 --- a/tactics/tacsubst.ml +++ b/ltac/tacsubst.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -54,10 +54,16 @@ and subst_intro_pattern_action subst = function | IntroApplyOn (t,pat) -> IntroApplyOn (subst_glob_constr subst t,subst_intro_pattern subst pat) | IntroOrAndPattern l -> - IntroOrAndPattern (List.map (List.map (subst_intro_pattern subst)) l) + IntroOrAndPattern (subst_intro_or_and_pattern subst l) | IntroInjection l -> IntroInjection (List.map (subst_intro_pattern subst) l) | IntroWildcard | IntroRewrite _ as x -> x +and subst_intro_or_and_pattern subst = function + | IntroAndPattern l -> + IntroAndPattern (List.map (subst_intro_pattern subst) l) + | IntroOrPattern ll -> + IntroOrPattern (List.map (List.map (subst_intro_pattern subst)) ll) + let subst_induction_arg subst = function | clear,ElimOnConstr c -> clear,ElimOnConstr (subst_glob_with_bindings subst c) | clear,ElimOnAnonHyp n as x -> x @@ -140,24 +146,17 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with TacElim (ev,subst_glob_with_bindings_arg subst cb, Option.map (subst_glob_with_bindings subst) cbo) | TacCase (ev,cb) -> TacCase (ev,subst_glob_with_bindings_arg subst cb) - | TacFix (idopt,n) as x -> x | TacMutualFix (id,n,l) -> TacMutualFix(id,n,List.map (fun (id,n,c) -> (id,n,subst_glob_constr subst c)) l) - | TacCofix idopt as x -> x | TacMutualCofix (id,l) -> TacMutualCofix (id, List.map (fun (id,c) -> (id,subst_glob_constr subst c)) l) | TacAssert (b,otac,na,c) -> TacAssert (b,Option.map (subst_tactic subst) otac,na,subst_glob_constr subst c) | TacGeneralize cl -> TacGeneralize (List.map (on_fst (subst_constr_with_occurrences subst))cl) - | TacGeneralizeDep c -> TacGeneralizeDep (subst_glob_constr subst c) | TacLetTac (id,c,clp,b,eqpat) -> TacLetTac (id,subst_glob_constr subst c,clp,b,eqpat) - (* Automation tactics *) - | TacTrivial (d,lems,l) -> TacTrivial (d,List.map (subst_glob_constr subst) lems,l) - | TacAuto (d,n,lems,l) -> TacAuto (d,n,List.map (subst_glob_constr subst) lems,l) - (* Derived basic tactics *) | TacInductionDestruct (isrec,ev,(l,el)) -> let l' = List.map (fun (c,ids,cls) -> @@ -167,23 +166,14 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with | TacDoubleInduction (h1,h2) as x -> x (* Context management *) - | TacClear _ as x -> x - | TacClearBody l as x -> x - | TacMove (id1,id2) as x -> x | TacRename l as x -> x - (* Constructors *) - | TacSplit (ev,bll) -> TacSplit (ev,List.map (subst_bindings subst) bll) - (* Conversion *) | TacReduce (r,cl) -> TacReduce (subst_redexp subst r, cl) | TacChange (op,c,cl) -> TacChange (Option.map (subst_glob_constr_or_pattern subst) op, subst_glob_constr subst c, cl) - (* Equivalence relations *) - | TacSymmetry _ as x -> x - (* Equality and inversion *) | TacRewrite (ev,l,cl,by) -> TacRewrite (ev, @@ -249,30 +239,21 @@ and subst_tactic subst (t:glob_tactic_expr) = match t with (* For extensions *) | TacAlias (_,s,l) -> let s = subst_kn subst s in - TacAlias (dloc,s,List.map (fun (id,a) -> (id,subst_genarg subst a)) l) - | TacML (_loc,opn,l) -> TacML (dloc,opn,List.map (subst_genarg subst) l) + TacAlias (dloc,s,List.map (subst_tacarg subst) l) + | TacML (_loc,opn,l) -> TacML (dloc,opn,List.map (subst_tacarg subst) l) and subst_tactic_fun subst (var,body) = (var,subst_tactic subst body) and subst_tacarg subst = function | Reference r -> Reference (subst_reference subst r) | ConstrMayEval c -> ConstrMayEval (subst_raw_may_eval subst c) - | UConstr c -> UConstr (subst_glob_constr subst c) - | MetaIdArg (_loc,_,_) -> assert false | TacCall (_loc,f,l) -> TacCall (_loc, subst_reference subst f, List.map (subst_tacarg subst) l) | TacFreshId _ as x -> x | TacPretype c -> TacPretype (subst_glob_constr subst c) | TacNumgoals -> TacNumgoals | Tacexp t -> Tacexp (subst_tactic subst t) - | TacGeneric arg -> TacGeneric (Genintern.generic_substitute subst arg) - | TacDynamic(the_loc,t) as x -> - (match Dyn.tag t with - | "tactic" | "value" -> x - | "constr" -> - TacDynamic(the_loc, constr_in (subst_mps subst (constr_out t))) - | s -> Errors.anomaly ~loc:dloc ~label:"Tacinterp.val_interp" - (str "Unknown dynamic: <" ++ str s ++ str ">")) + | TacGeneric arg -> TacGeneric (subst_genarg subst arg) (* Reads the rules of a Match Context or a Match *) and subst_match_rule subst = function @@ -285,66 +266,48 @@ and subst_match_rule subst = function ::(subst_match_rule subst tl) | [] -> [] -and subst_genarg subst (x:glob_generic_argument) = - match genarg_tag x with - | IntOrVarArgType -> in_gen (glbwit wit_int_or_var) (out_gen (glbwit wit_int_or_var) x) - | IdentArgType -> - in_gen (glbwit wit_ident) (out_gen (glbwit wit_ident) x) - | VarArgType -> in_gen (glbwit wit_var) (out_gen (glbwit wit_var) x) - | GenArgType -> in_gen (glbwit wit_genarg) (subst_genarg subst (out_gen (glbwit wit_genarg) x)) - | ConstrArgType -> - in_gen (glbwit wit_constr) (subst_glob_constr subst (out_gen (glbwit wit_constr) x)) - | ConstrMayEvalArgType -> - in_gen (glbwit wit_constr_may_eval) (subst_raw_may_eval subst (out_gen (glbwit wit_constr_may_eval) x)) - | QuantHypArgType -> - in_gen (glbwit wit_quant_hyp) - (subst_declared_or_quantified_hypothesis subst - (out_gen (glbwit wit_quant_hyp) x)) - | RedExprArgType -> - in_gen (glbwit wit_red_expr) (subst_redexp subst (out_gen (glbwit wit_red_expr) x)) - | OpenConstrArgType -> - in_gen (glbwit wit_open_constr) - ((),subst_glob_constr subst (snd (out_gen (glbwit wit_open_constr) x))) - | ConstrWithBindingsArgType -> - in_gen (glbwit wit_constr_with_bindings) - (subst_glob_with_bindings subst (out_gen (glbwit wit_constr_with_bindings) x)) - | BindingsArgType -> - in_gen (glbwit wit_bindings) - (subst_bindings subst (out_gen (glbwit wit_bindings) x)) - | ListArgType _ -> - let list_unpacker wit l = - let map x = - let ans = subst_genarg subst (in_gen (glbwit wit) x) in - out_gen (glbwit wit) ans - in - in_gen (glbwit (wit_list wit)) (List.map map (glb l)) +and subst_genarg subst (GenArg (Glbwit wit, x)) = + match wit with + | ListArg wit -> + let map x = + let ans = subst_genarg subst (in_gen (glbwit wit) x) in + out_gen (glbwit wit) ans in - list_unpack { list_unpacker } x - | OptArgType _ -> - let opt_unpacker wit o = match glb o with + in_gen (glbwit (wit_list wit)) (List.map map x) + | OptArg wit -> + let ans = match x with | None -> in_gen (glbwit (wit_opt wit)) None | Some x -> let s = out_gen (glbwit wit) (subst_genarg subst (in_gen (glbwit wit) x)) in in_gen (glbwit (wit_opt wit)) (Some s) in - opt_unpack { opt_unpacker } x - | PairArgType _ -> - let pair_unpacker wit1 wit2 o = - let p, q = glb o in - let p = out_gen (glbwit wit1) (subst_genarg subst (in_gen (glbwit wit1) p)) in - let q = out_gen (glbwit wit2) (subst_genarg subst (in_gen (glbwit wit2) q)) in - in_gen (glbwit (wit_pair wit1 wit2)) (p, q) - in - pair_unpack { pair_unpacker } x - | ExtraArgType s -> - Genintern.generic_substitute subst x + ans + | PairArg (wit1, wit2) -> + let p, q = x in + let p = out_gen (glbwit wit1) (subst_genarg subst (in_gen (glbwit wit1) p)) in + let q = out_gen (glbwit wit2) (subst_genarg subst (in_gen (glbwit wit2) q)) in + in_gen (glbwit (wit_pair wit1 wit2)) (p, q) + | ExtraArg s -> + Genintern.generic_substitute subst (in_gen (glbwit wit) x) (** Registering *) let () = + Genintern.register_subst0 wit_int_or_var (fun _ v -> v); Genintern.register_subst0 wit_ref subst_global_reference; + Genintern.register_subst0 wit_ident (fun _ v -> v); + Genintern.register_subst0 wit_var (fun _ v -> v); Genintern.register_subst0 wit_intro_pattern (fun _ v -> v); Genintern.register_subst0 wit_tactic subst_tactic; + Genintern.register_subst0 wit_ltac subst_tactic; + Genintern.register_subst0 wit_constr subst_glob_constr; Genintern.register_subst0 wit_sort (fun _ v -> v); Genintern.register_subst0 wit_clause_dft_concl (fun _ v -> v); - Genintern.register_subst0 wit_uconstr (fun subst c -> subst_glob_constr subst c) + Genintern.register_subst0 wit_uconstr (fun subst c -> subst_glob_constr subst c); + Genintern.register_subst0 wit_open_constr (fun subst c -> subst_glob_constr subst c); + Genintern.register_subst0 wit_red_expr subst_redexp; + Genintern.register_subst0 wit_quant_hyp subst_declared_or_quantified_hypothesis; + Genintern.register_subst0 wit_bindings subst_bindings; + Genintern.register_subst0 wit_constr_with_bindings subst_glob_with_bindings; + Genintern.register_subst0 wit_constr_may_eval subst_raw_may_eval; + () diff --git a/tactics/tacsubst.mli b/ltac/tacsubst.mli index 52f21ed7c..c1bf27257 100644 --- a/tactics/tacsubst.mli +++ b/ltac/tacsubst.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/proofs/tactic_debug.ml b/ltac/tactic_debug.ml index fb23a28fe..d661f9677 100644 --- a/proofs/tactic_debug.ml +++ b/ltac/tactic_debug.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -14,10 +14,16 @@ open Termops open Nameops open Proofview.Notations -let (prtac, tactic_printer) = Hook.make () -let (prmatchpatt, match_pattern_printer) = Hook.make () -let (prmatchrl, match_rule_printer) = Hook.make () +let (ltac_trace_info : ltac_trace Exninfo.t) = Exninfo.make () + +let prtac x = + Pptactic.pr_glob_tactic (Global.env()) x +let prmatchpatt env sigma hyp = + Pptactic.pr_match_pattern (Printer.pr_constr_pattern_env env sigma) hyp +let prmatchrl rl = + Pptactic.pr_match_rule false (Pptactic.pr_glob_tactic (Global.env())) + (fun (_,p) -> Printer.pr_constr_pattern p) rl (* This module intends to be a beginning of debugger for tactic expressions. Currently, it is quite simple and we can hope to have, in the future, a more @@ -29,9 +35,11 @@ type debug_info = | DebugOff (* An exception handler *) -let explain_logic_error = ref (fun e -> mt()) +let explain_logic_error e = + Errors.print (fst (Cerrors.process_vernac_interp_error (e, Exninfo.null))) -let explain_logic_error_no_anomaly = ref (fun e -> mt()) +let explain_logic_error_no_anomaly e = + Errors.print_no_report (fst (Cerrors.process_vernac_interp_error (e, Exninfo.null))) let msg_tac_debug s = Proofview.NonLogical.print_debug (s++fnl()) let msg_tac_notice s = Proofview.NonLogical.print_notice (s++fnl()) @@ -67,7 +75,7 @@ let help () = let goal_com tac = Proofview.tclTHEN db_pr_goal - (Proofview.tclLIFT (msg_tac_debug (str "Going to execute:" ++ fnl () ++ Hook.get prtac tac))) + (Proofview.tclLIFT (msg_tac_debug (str "Going to execute:" ++ fnl () ++ prtac tac))) (* [run (new_ref _)] gives us a ref shared among [NonLogical.t] expressions. It avoids parametrizing everything over a @@ -197,7 +205,7 @@ let debug_prompt lev tac f = (Proofview.tclLIFT begin (skip:=0) >> (skipped:=0) >> if Logic.catchable_exception reraise then - msg_tac_debug (str "Level " ++ int lev ++ str ": " ++ Pervasives.(!) explain_logic_error reraise) + msg_tac_debug (str "Level " ++ int lev ++ str ": " ++ explain_logic_error reraise) else return () end) (Proofview.tclZERO ~info reraise) @@ -228,7 +236,7 @@ let db_pattern_rule debug num r = if db then begin msg_tac_debug (str "Pattern rule " ++ int num ++ str ":" ++ fnl () ++ - str "|" ++ spc () ++ Hook.get prmatchrl r) + str "|" ++ spc () ++ prmatchrl r) end else return () @@ -270,7 +278,7 @@ let db_hyp_pattern_failure debug env sigma (na,hyp) = if db then msg_tac_debug (str "The pattern hypothesis" ++ hyp_bound na ++ str " cannot match: " ++ - Hook.get prmatchpatt env sigma hyp) + prmatchpatt env sigma hyp) else return () (* Prints a matching failure message for a rule *) @@ -299,7 +307,7 @@ let db_logic_failure debug err = is_debug debug >>= fun db -> if db then begin - msg_tac_debug (Pervasives.(!) explain_logic_error err) >> + msg_tac_debug (explain_logic_error err) >> msg_tac_debug (str "This rule has failed due to a logic error!" ++ fnl() ++ str "Let us try the next one...") end @@ -317,3 +325,88 @@ let db_breakpoint debug s = breakpoint:=None | _ -> return () + +(** Extrating traces *) + +let is_defined_ltac trace = + let rec aux = function + | (_, Tacexpr.LtacNameCall f) :: tail -> + not (Tacenv.is_ltac_for_ml_tactic f) + | (_, Tacexpr.LtacAtomCall _) :: tail -> + false + | _ :: tail -> aux tail + | [] -> false in + aux (List.rev trace) + +let explain_ltac_call_trace last trace loc = + let calls = last :: List.rev_map snd trace in + let pr_call ck = match ck with + | Tacexpr.LtacNotationCall kn -> quote (KerName.print kn) + | Tacexpr.LtacNameCall cst -> quote (Pptactic.pr_ltac_constant cst) + | Tacexpr.LtacMLCall t -> + quote (Pptactic.pr_glob_tactic (Global.env()) t) + | Tacexpr.LtacVarCall (id,t) -> + quote (Nameops.pr_id id) ++ strbrk " (bound to " ++ + Pptactic.pr_glob_tactic (Global.env()) t ++ str ")" + | Tacexpr.LtacAtomCall te -> + quote (Pptactic.pr_glob_tactic (Global.env()) + (Tacexpr.TacAtom (Loc.ghost,te))) + | Tacexpr.LtacConstrInterp (c, { Pretyping.ltac_constrs = vars }) -> + quote (Printer.pr_glob_constr_env (Global.env()) c) ++ + (if not (Id.Map.is_empty vars) then + strbrk " (with " ++ + prlist_with_sep pr_comma + (fun (id,c) -> + pr_id id ++ str ":=" ++ Printer.pr_lconstr_under_binders c) + (List.rev (Id.Map.bindings vars)) ++ str ")" + else mt()) + in + match calls with + | [] -> mt () + | _ -> + let kind_of_last_call = match List.last calls with + | Tacexpr.LtacConstrInterp _ -> ", last term evaluation failed." + | _ -> ", last call failed." + in + hov 0 (str "In nested Ltac calls to " ++ + pr_enum pr_call calls ++ strbrk kind_of_last_call) + +let skip_extensions trace = + let rec aux = function + | (_,Tacexpr.LtacNameCall f as tac) :: _ + when Tacenv.is_ltac_for_ml_tactic f -> [tac] + | (_,(Tacexpr.LtacNotationCall _ | Tacexpr.LtacMLCall _) as tac) + :: _ -> [tac] + | t :: tail -> t :: aux tail + | [] -> [] in + List.rev (aux (List.rev trace)) + +let extract_ltac_trace trace eloc = + let trace = skip_extensions trace in + let (loc,c),tail = List.sep_last trace in + if is_defined_ltac trace then + (* We entered a user-defined tactic, + we display the trace with location of the call *) + let msg = hov 0 (explain_ltac_call_trace c tail eloc ++ fnl()) in + Some msg, loc + else + (* We entered a primitive tactic, we don't display trace but + report on the finest location *) + let best_loc = + if not (Loc.is_ghost eloc) then eloc else + (* trace is with innermost call coming first *) + let rec aux = function + | (loc,_)::tail when not (Loc.is_ghost loc) -> loc + | _::tail -> aux tail + | [] -> Loc.ghost in + aux trace in + None, best_loc + +let get_ltac_trace (_, info) = + let ltac_trace = Exninfo.get info ltac_trace_info in + let loc = Option.default Loc.ghost (Loc.get_loc info) in + match ltac_trace with + | None -> None + | Some trace -> Some (extract_ltac_trace trace loc) + +let () = Cerrors.register_additional_error_info get_ltac_trace diff --git a/proofs/tactic_debug.mli b/ltac/tactic_debug.mli index e4c0a23ef..520fb41ef 100644 --- a/proofs/tactic_debug.mli +++ b/ltac/tactic_debug.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -13,16 +13,14 @@ open Tacexpr open Term open Evd +(** TODO: Move those definitions somewhere sensible *) + +val ltac_trace_info : ltac_trace Exninfo.t + (** This module intends to be a beginning of debugger for tactic expressions. Currently, it is quite simple and we can hope to have, in the future, a more complete panel of commands dedicated to a proof assistant framework *) -val tactic_printer : (glob_tactic_expr -> Pp.std_ppcmds) Hook.t -val match_pattern_printer : - (env -> evar_map -> constr_pattern match_pattern -> Pp.std_ppcmds) Hook.t -val match_rule_printer : - ((Tacexpr.glob_constr_and_expr * constr_pattern,glob_tactic_expr) match_rule -> Pp.std_ppcmds) Hook.t - (** Debug information *) type debug_info = | DebugOn of int @@ -63,13 +61,13 @@ val db_matching_failure : debug_info -> unit Proofview.NonLogical.t val db_eval_failure : debug_info -> Pp.std_ppcmds -> unit Proofview.NonLogical.t (** An exception handler *) -val explain_logic_error: (exn -> Pp.std_ppcmds) ref +val explain_logic_error: exn -> Pp.std_ppcmds (** For use in the Ltac debugger: some exception that are usually consider anomalies are acceptable because they are caught later in the process that is being debugged. One should not require from users that they report these anomalies. *) -val explain_logic_error_no_anomaly : (exn -> Pp.std_ppcmds) ref +val explain_logic_error_no_anomaly : exn -> Pp.std_ppcmds (** Prints a logic failure message for a rule *) val db_logic_failure : debug_info -> exn -> unit Proofview.NonLogical.t @@ -77,3 +75,6 @@ val db_logic_failure : debug_info -> exn -> unit Proofview.NonLogical.t (** Prints a logic failure message for a rule *) val db_breakpoint : debug_info -> Id.t Loc.located message_token list -> unit Proofview.NonLogical.t + +val extract_ltac_trace : + Tacexpr.ltac_trace -> Loc.t -> Pp.std_ppcmds option * Loc.t diff --git a/tactics/tactic_option.ml b/ltac/tactic_option.ml index 34245c6a0..a5ba3b837 100644 --- a/tactics/tactic_option.ml +++ b/ltac/tactic_option.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/tactics/tactic_option.mli b/ltac/tactic_option.mli index ffbd5116d..ed759a76d 100644 --- a/tactics/tactic_option.mli +++ b/ltac/tactic_option.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/ltac/tauto.ml b/ltac/tauto.ml new file mode 100644 index 000000000..a86fdb98a --- /dev/null +++ b/ltac/tauto.ml @@ -0,0 +1,282 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Term +open Hipattern +open Names +open Pp +open Genarg +open Stdarg +open Misctypes +open Tacexpr +open Tacinterp +open Tactics +open Errors +open Util +open Tacticals.New +open Proofview.Notations + +let tauto_plugin = "tauto" +let () = Mltop.add_known_module tauto_plugin + +let assoc_var s ist = + let v = Id.Map.find (Names.Id.of_string s) ist.lfun in + match Value.to_constr v with + | Some c -> c + | None -> failwith "tauto: anomaly" + +(** Parametrization of tauto *) + +type tauto_flags = { + +(* Whether conjunction and disjunction are restricted to binary connectives *) + binary_mode : bool; + +(* Whether compatibility for buggy detection of binary connective is on *) + binary_mode_bugged_detection : bool; + +(* Whether conjunction and disjunction are restricted to the connectives *) +(* having the structure of "and" and "or" (up to the choice of sorts) in *) +(* contravariant position in an hypothesis *) + strict_in_contravariant_hyp : bool; + +(* Whether conjunction and disjunction are restricted to the connectives *) +(* having the structure of "and" and "or" (up to the choice of sorts) in *) +(* an hypothesis and in the conclusion *) + strict_in_hyp_and_ccl : bool; + +(* Whether unit type includes equality types *) + strict_unit : bool; +} + +let wit_tauto_flags : tauto_flags uniform_genarg_type = + Genarg.create_arg "tauto_flags" + +let assoc_flags ist = + let v = Id.Map.find (Names.Id.of_string "tauto_flags") ist.lfun in + try Value.cast (topwit wit_tauto_flags) v with _ -> assert false + +(* Whether inner not are unfolded *) +let negation_unfolding = ref true + +(* Whether inner iff are unfolded *) +let iff_unfolding = ref false + +let unfold_iff () = !iff_unfolding || Flags.version_less_or_equal Flags.V8_2 + +open Goptions +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "unfolding of not in intuition"; + optkey = ["Intuition";"Negation";"Unfolding"]; + optread = (fun () -> !negation_unfolding); + optwrite = (:=) negation_unfolding } + +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "unfolding of iff in intuition"; + optkey = ["Intuition";"Iff";"Unfolding"]; + optread = (fun () -> !iff_unfolding); + optwrite = (:=) iff_unfolding } + +(** Base tactics *) + +let loc = Loc.ghost +let idtac = Proofview.tclUNIT () +let fail = Proofview.tclINDEPENDENT (tclFAIL 0 (Pp.mt ())) + +let intro = Tactics.intro + +let assert_ ?by c = + let tac = match by with + | None -> None + | Some tac -> Some (tclCOMPLETE tac) + in + Proofview.tclINDEPENDENT (Tactics.forward true tac None c) + +let apply c = Tactics.apply c + +let clear id = Proofview.V82.tactic (fun gl -> Tactics.clear [id] gl) + +let assumption = Tactics.assumption + +let split = Tactics.split_with_bindings false [Misctypes.NoBindings] + +(** Test *) + +let is_empty _ ist = + if is_empty_type (assoc_var "X1" ist) then idtac else fail + +(* Strictly speaking, this exceeds the propositional fragment as it + matches also equality types (and solves them if a reflexivity) *) +let is_unit_or_eq _ ist = + let flags = assoc_flags ist in + let test = if flags.strict_unit then is_unit_type else is_unit_or_eq_type in + if test (assoc_var "X1" ist) then idtac else fail + +let bugged_is_binary t = + isApp t && + let (hdapp,args) = decompose_app t in + match (kind_of_term hdapp) with + | Ind (ind,u) -> + let (mib,mip) = Global.lookup_inductive ind in + Int.equal mib.Declarations.mind_nparams 2 + | _ -> false + +(** Dealing with conjunction *) + +let is_conj _ ist = + let flags = assoc_flags ist in + let ind = assoc_var "X1" ist in + if (not flags.binary_mode_bugged_detection || bugged_is_binary ind) && + is_conjunction + ~strict:flags.strict_in_hyp_and_ccl + ~onlybinary:flags.binary_mode ind + then idtac + else fail + +let flatten_contravariant_conj _ ist = + let flags = assoc_flags ist in + let typ = assoc_var "X1" ist in + let c = assoc_var "X2" ist in + let hyp = assoc_var "id" ist in + match match_with_conjunction + ~strict:flags.strict_in_contravariant_hyp + ~onlybinary:flags.binary_mode typ + with + | Some (_,args) -> + let newtyp = List.fold_right mkArrow args c in + let intros = tclMAP (fun _ -> intro) args in + let by = tclTHENLIST [intros; apply hyp; split; assumption] in + tclTHENLIST [assert_ ~by newtyp; clear (destVar hyp)] + | _ -> fail + +(** Dealing with disjunction *) + +let is_disj _ ist = + let flags = assoc_flags ist in + let t = assoc_var "X1" ist in + if (not flags.binary_mode_bugged_detection || bugged_is_binary t) && + is_disjunction + ~strict:flags.strict_in_hyp_and_ccl + ~onlybinary:flags.binary_mode t + then idtac + else fail + +let flatten_contravariant_disj _ ist = + let flags = assoc_flags ist in + let typ = assoc_var "X1" ist in + let c = assoc_var "X2" ist in + let hyp = assoc_var "id" ist in + match match_with_disjunction + ~strict:flags.strict_in_contravariant_hyp + ~onlybinary:flags.binary_mode + typ with + | Some (_,args) -> + let map i arg = + let typ = mkArrow arg c in + let ci = Tactics.constructor_tac false None (succ i) Misctypes.NoBindings in + let by = tclTHENLIST [intro; apply hyp; ci; assumption] in + assert_ ~by typ + in + let tacs = List.mapi map args in + let tac0 = clear (destVar hyp) in + tclTHEN (tclTHENLIST tacs) tac0 + | _ -> fail + +let make_unfold name = + let dir = DirPath.make (List.map Id.of_string ["Logic"; "Init"; "Coq"]) in + let const = Constant.make2 (MPfile dir) (Label.make name) in + (Locus.AllOccurrences, ArgArg (EvalConstRef const, None)) + +let u_iff = make_unfold "iff" +let u_not = make_unfold "not" + +let reduction_not_iff _ ist = + let make_reduce c = TacAtom (loc, TacReduce (Genredexpr.Unfold c, Locusops.allHypsAndConcl)) in + let tac = match !negation_unfolding, unfold_iff () with + | true, true -> make_reduce [u_not; u_iff] + | true, false -> make_reduce [u_not] + | false, true -> make_reduce [u_iff] + | false, false -> TacId [] + in + eval_tactic_ist ist tac + +let coq_nnpp_path = + let dir = List.map Id.of_string ["Classical_Prop";"Logic";"Coq"] in + Libnames.make_path (DirPath.make dir) (Id.of_string "NNPP") + +let apply_nnpp _ ist = + Proofview.tclBIND + (Proofview.tclUNIT ()) + begin fun () -> try + let nnpp = Universes.constr_of_global (Nametab.global_of_path coq_nnpp_path) in + apply nnpp + with Not_found -> tclFAIL 0 (Pp.mt ()) + end + +(* This is the uniform mode dealing with ->, not, iff and types isomorphic to + /\ and *, \/ and +, False and Empty_set, True and unit, _and_ eq-like types. + For the moment not and iff are still always unfolded. *) +let tauto_uniform_unit_flags = { + binary_mode = true; + binary_mode_bugged_detection = false; + strict_in_contravariant_hyp = true; + strict_in_hyp_and_ccl = true; + strict_unit = false +} + +(* This is the compatibility mode (not used) *) +let tauto_legacy_flags = { + binary_mode = true; + binary_mode_bugged_detection = true; + strict_in_contravariant_hyp = true; + strict_in_hyp_and_ccl = false; + strict_unit = false +} + +(* This is the improved mode *) +let tauto_power_flags = { + binary_mode = false; (* support n-ary connectives *) + binary_mode_bugged_detection = false; + strict_in_contravariant_hyp = false; (* supports non-regular connectives *) + strict_in_hyp_and_ccl = false; + strict_unit = false +} + +let with_flags flags _ ist = + let f = (loc, Id.of_string "f") in + let x = (loc, Id.of_string "x") in + let arg = Val.Dyn (val_tag (topwit wit_tauto_flags), flags) in + let ist = { ist with lfun = Id.Map.add (snd x) arg ist.lfun } in + eval_tactic_ist ist (TacArg (loc, TacCall (loc, ArgVar f, [Reference (ArgVar x)]))) + +let register_tauto_tactic tac name0 args = + let ids = List.map (fun id -> Id.of_string id) args in + let ids = List.map (fun id -> Some id) ids in + let name = { mltac_plugin = tauto_plugin; mltac_tactic = name0; } in + let entry = { mltac_name = name; mltac_index = 0 } in + let () = Tacenv.register_ml_tactic name [| tac |] in + let tac = TacFun (ids, TacML (loc, entry, [])) in + let obj () = Tacenv.register_ltac true true (Id.of_string name0) tac in + Mltop.declare_cache_obj obj tauto_plugin + +let () = register_tauto_tactic is_empty "is_empty" ["tauto_flags"; "X1"] +let () = register_tauto_tactic is_unit_or_eq "is_unit_or_eq" ["tauto_flags"; "X1"] +let () = register_tauto_tactic is_disj "is_disj" ["tauto_flags"; "X1"] +let () = register_tauto_tactic is_conj "is_conj" ["tauto_flags"; "X1"] +let () = register_tauto_tactic flatten_contravariant_disj "flatten_contravariant_disj" ["tauto_flags"; "X1"; "X2"; "id"] +let () = register_tauto_tactic flatten_contravariant_conj "flatten_contravariant_conj" ["tauto_flags"; "X1"; "X2"; "id"] +let () = register_tauto_tactic apply_nnpp "apply_nnpp" [] +let () = register_tauto_tactic reduction_not_iff "reduction_not_iff" [] +let () = register_tauto_tactic (with_flags tauto_uniform_unit_flags) "with_uniform_flags" ["f"] +let () = register_tauto_tactic (with_flags tauto_power_flags) "with_power_flags" ["f"] diff --git a/dev/tools/Makefile.common b/ltac/tauto.mli index e69de29bb..e69de29bb 100644 --- a/dev/tools/Makefile.common +++ b/ltac/tauto.mli diff --git a/man/coqdep.1 b/man/coqdep.1 index 5a6cd609e..81f7e1e0d 100644 --- a/man/coqdep.1 +++ b/man/coqdep.1 @@ -46,7 +46,9 @@ commands (Require, Require Export, Require Import), commands and .IR Load \& commands. Dependencies relative to modules from the Coq library are not -printed. +printed except if +.BR \-boot \& +is given. Dependencies of Caml modules are computed by looking at .IR open \& @@ -59,35 +61,50 @@ directives and the dot notation .BI \-c Prints the dependencies of Caml modules. (On Caml modules, the behaviour is exactly the same as ocamldep). -.TP -.BI \-w -Prints a warning if a Coq command -.IR Declare \& -.IR ML \& -.IR Module \& -is incorrect. (For instance, you wrote `Declare ML Module "A".', -but the module A contains #open "B"). The correct command is printed -(see option \-D). The warning is printed on standard error. -.TP -.BI \-D -This commands looks for every command -.IR Declare \& -.IR ML \& -.IR Module \& -of each Coq file given as argument and complete (if needed) -the list of Caml modules. The new command is printed on -the standard output. No dependency is computed with this option. +\" THESE OPTIONS ARE BROKEN CURRENTLY +\" .TP +\" .BI \-w +\" Prints a warning if a Coq command +\" .IR Declare \& +\" .IR ML \& +\" .IR Module \& +\" is incorrect. (For instance, you wrote `Declare ML Module "A".', +\" but the module A contains #open "B"). The correct command is printed +\" (see option \-D). The warning is printed on standard error. +\" .TP +\" .BI \-D +\" This commands looks for every command +\" .IR Declare \& +\" .IR ML \& +\" .IR Module \& +\" of each Coq file given as argument and complete (if needed) +\" the list of Caml modules. The new command is printed on +\" the standard output. No dependency is computed with this option. .TP -.BI \-I \ directory -The files .v .ml .mli of the directory -.IR directory \& -are taken into account during the calculus of dependencies, -but their own dependencies are not printed. +.BI \-I/\-Q/\-R \ options +Have the same effects on load path and modules names than for other +coq commands (coqtop, coqc). .TP .BI \-coqlib \ directory Indicates where is the Coq library. The default value has been determined at installation time, and therefore this option should not be used under normal circumstances. +.TP +.BI \-dumpgraph[box] \ file +Dumps a dot dependency graph in file +.IR file \&. +.TP +.BI \-exclude-dir \ dir +Skips subdirectory +.IR dir \ during +.BR -R/-Q \ search. +.TP +.B \-sort +Output the given file name ordered by dependencies. +.TP +.B \-boot +For coq developpers, prints dependencies over coq library files +(omitted by default). .SH SEE ALSO diff --git a/man/coqide.1 b/man/coqide.1 index 6a3e67ad5..f82bf2ad4 100644 --- a/man/coqide.1 +++ b/man/coqide.1 @@ -123,6 +123,12 @@ Set sort Set impredicative. .TP .B \-dont\-load\-proofs Don't load opaque proofs in memory. +.TP +.B \-xml +Export XML files either to the hierarchy rooted in +the directory +.B COQ_XML_LIBRARY_ROOT +(if set) or to stdout (if unset). .SH SEE ALSO diff --git a/man/coqtop.1 b/man/coqtop.1 index 62d17aa67..feee7fd8b 100644 --- a/man/coqtop.1 +++ b/man/coqtop.1 @@ -153,6 +153,12 @@ set sort Set impredicative .B \-dont\-load\-proofs don't load opaque proofs in memory +.TP +.B \-xml +export XML files either to the hierarchy rooted in +the directory $COQ_XML_LIBRARY_ROOT (if set) or to +stdout (if unset) + .SH SEE ALSO .BR coqc (1), diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 73ef7e1ed..90df4f00c 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -107,7 +107,7 @@ let core_libs = "engine/engine"; "pretyping/pretyping"; "interp/interp"; "proofs/proofs"; "parsing/parsing"; "printing/printing"; "tactics/tactics"; "stm/stm"; "toplevel/toplevel"; "parsing/highparsing"; - "tactics/hightactics"] + "ltac/ltac"] let core_cma = List.map (fun s -> s^".cma") core_libs let core_cmxa = List.map (fun s -> s^".cmxa") core_libs let core_mllib = List.map (fun s -> s^".mllib") core_libs @@ -115,8 +115,8 @@ let core_mllib = List.map (fun s -> s^".mllib") core_libs let tolink = "tools/tolink.ml" let c_headers_base = - ["coq_fix_code.h";"coq_instruct.h"; "coq_memory.h"; "int64_emul.h"; - "coq_gc.h"; "coq_interp.h"; "coq_values.h"; "int64_native.h"; + ["coq_fix_code.h";"coq_instruct.h"; "coq_memory.h"; + "coq_gc.h"; "coq_interp.h"; "coq_values.h"; "coq_jumptbl.h"] let c_headers = List.map ((^) "kernel/byterun/") c_headers_base diff --git a/parsing/compat.ml4 b/parsing/compat.ml4 index 4208fd364..c482c694e 100644 --- a/parsing/compat.ml4 +++ b/parsing/compat.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -262,10 +262,10 @@ IFDEF CAMLP5 THEN let pattern = match tok with | Tok.KEYWORD s -> "", s | Tok.IDENT s -> "IDENT", s - | Tok.METAIDENT s -> "METAIDENT", s | Tok.PATTERNIDENT s -> "PATTERNIDENT", s | Tok.FIELD s -> "FIELD", s | Tok.INT s -> "INT", s + | Tok.INDEX s -> "INDEX", s | Tok.STRING s -> "STRING", s | Tok.LEFTQMARK -> "LEFTQMARK", "" | Tok.BULLET s -> "BULLET", s @@ -276,7 +276,7 @@ ELSE module Gramext = G let stoken tok = match tok with | Tok.KEYWORD s -> Gramext.Skeyword s - | tok -> Gramext.Stoken ((=) tok, G.Token.to_string tok) + | tok -> Gramext.Stoken (Tok.equal tok, G.Token.to_string tok) END IFDEF CAMLP5_6_00 THEN diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml index 84736f8ab..f0c12ab8e 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -206,109 +206,59 @@ type notation_grammar = { let extend_constr_constr_notation ng = let level = ng.notgram_level in let mkact loc env = CNotation (loc, ng.notgram_notation, env) in - let e = interp_constr_entry_key false (ETConstr (level, ())) in + let e = interp_constr_entry_key false level in let ext = (ETConstr (level, ()), ng.notgram_assoc) in extend_constr e ext (make_constr_action mkact) false ng.notgram_prods let extend_constr_pat_notation ng = let level = ng.notgram_level in let mkact loc env = CPatNotation (loc, ng.notgram_notation, env, []) in - let e = interp_constr_entry_key true (ETConstr (level, ())) in + let e = interp_constr_entry_key true level in let ext = ETConstr (level, ()), ng.notgram_assoc in extend_constr e ext (make_cases_pattern_action mkact) true ng.notgram_prods -let extend_constr_notation ng = +let extend_constr_notation (_, ng) = (* Add the notation in constr *) let nb = extend_constr_constr_notation ng in (* Add the notation in cases_pattern *) let nb' = extend_constr_pat_notation ng in nb + nb' -(**********************************************************************) -(** Grammar declaration for Tactic Notation (Coq level) *) - -let get_tactic_entry n = - if Int.equal n 0 then - Tactic.simple_tactic, None - else if Int.equal n 5 then - Tactic.binder_tactic, None - else if 1<=n && n<5 then - Tactic.tactic_expr, Some (Extend.Level (string_of_int n)) - else - error ("Invalid Tactic Notation level: "^(string_of_int n)^".") - -(**********************************************************************) -(** State of the grammar extensions *) - -type tactic_grammar = { - tacgram_level : int; - tacgram_prods : Tacexpr.raw_tactic_expr grammar_prod_item list; -} - -type all_grammar_command = - | Notation of Notation.level * notation_grammar - | TacticGrammar of KerName.t * tactic_grammar - | MLTacticGrammar of ml_tactic_name * Tacexpr.raw_tactic_expr grammar_prod_item list list +module GrammarCommand = Dyn.Make(struct end) +module GrammarInterp = struct type 'a t = 'a -> int end +module GrammarInterpMap = GrammarCommand.Map(GrammarInterp) -(** ML Tactic grammar extensions *) - -let add_ml_tactic_entry name prods = - let entry = Tactic.simple_tactic in - let mkact i loc l : raw_tactic_expr = - let open Tacexpr in - let entry = { mltac_name = name; mltac_index = i } in - TacML (loc, entry, List.map snd l) - in - let rules = List.map_i (fun i p -> make_rule (mkact i) p) 0 prods in - synchronize_level_positions (); - grammar_extend entry None (None, [(None, None, List.rev rules)]); - 1 +let grammar_interp = ref GrammarInterpMap.empty -(* Declaration of the tactic grammar rule *) +let (grammar_state : (int * GrammarCommand.t) list ref) = ref [] -let head_is_ident tg = match tg.tacgram_prods with -| GramTerminal _::_ -> true -| _ -> false +type 'a grammar_command = 'a GrammarCommand.tag -(** Tactic grammar extensions *) +let create_grammar_command name interp : _ grammar_command = + let obj = GrammarCommand.create name in + let () = grammar_interp := GrammarInterpMap.add obj interp !grammar_interp in + obj -let add_tactic_entry kn tg = - let entry, pos = get_tactic_entry tg.tacgram_level in - let mkact loc l = (TacAlias (loc,kn,l):raw_tactic_expr) in - let () = - if Int.equal tg.tacgram_level 0 && not (head_is_ident tg) then - error "Notation for simple tactic must start with an identifier." - in - let rules = make_rule mkact tg.tacgram_prods in - synchronize_level_positions (); - grammar_extend entry None (pos, [(None, None, List.rev [rules])]); - 1 - -let (grammar_state : (int * all_grammar_command) list ref) = ref [] - -let extend_grammar gram = - let nb = match gram with - | Notation (_,a) -> extend_constr_notation a - | TacticGrammar (kn, g) -> add_tactic_entry kn g - | MLTacticGrammar (name, pr) -> add_ml_tactic_entry name pr - in - grammar_state := (nb,gram) :: !grammar_state +let extend_grammar tag g = + let nb = GrammarInterpMap.find tag !grammar_interp g in + grammar_state := (nb, GrammarCommand.Dyn (tag, g)) :: !grammar_state -let extend_constr_grammar pr ntn = - extend_grammar (Notation (pr, ntn)) +let extend_dyn_grammar (GrammarCommand.Dyn (tag, g)) = extend_grammar tag g -let extend_tactic_grammar kn ntn = - extend_grammar (TacticGrammar (kn, ntn)) +let constr_grammar : (Notation.level * notation_grammar) GrammarCommand.tag = + create_grammar_command "Notation" extend_constr_notation -let extend_ml_tactic_grammar name ntn = - extend_grammar (MLTacticGrammar (name, ntn)) +let extend_constr_grammar pr ntn = extend_grammar constr_grammar (pr, ntn) let recover_constr_grammar ntn prec = - let filter = function - | _, Notation (prec', ng) when - Notation.level_eq prec prec' && - String.equal ntn ng.notgram_notation -> Some ng - | _ -> None + let filter (_, gram) : notation_grammar option = match gram with + | GrammarCommand.Dyn (tag, obj) -> + match GrammarCommand.eq tag constr_grammar with + | None -> None + | Some Refl -> + let (prec', ng) = obj in + if Notation.level_eq prec prec' && String.equal ntn ng.notgram_notation then Some ng + else None in match List.map_filter filter !grammar_state with | [x] -> x @@ -317,7 +267,7 @@ let recover_constr_grammar ntn prec = (* Summary functions: the state of the lexer is included in that of the parser. Because the grammar affects the set of keywords when adding or removing grammar rules. *) -type frozen_t = (int * all_grammar_command) list * Lexer.frozen_t +type frozen_t = (int * GrammarCommand.t) list * Lexer.frozen_t let freeze _ : frozen_t = (!grammar_state, Lexer.freeze ()) @@ -336,7 +286,7 @@ let unfreeze (grams, lex) = remove_levels n; grammar_state := common; Lexer.unfreeze lex; - List.iter extend_grammar (List.rev_map snd redo) + List.iter extend_dyn_grammar (List.rev_map snd redo) (** No need to provide an init function : the grammar state is statically available, and already empty initially, while @@ -356,30 +306,3 @@ let with_grammar_rule_protection f x = let reraise = Errors.push reraise in let () = unfreeze fs in iraise reraise - -(**********************************************************************) -(** Ltac quotations *) - -let ltac_quotations = ref String.Set.empty - -let create_ltac_quotation name cast wit e = - let () = - if String.Set.mem name !ltac_quotations then - failwith ("Ltac quotation " ^ name ^ " already registered") - in - let () = ltac_quotations := String.Set.add name !ltac_quotations in -(* let level = Some "1" in *) - let level = None in - let assoc = Some (of_coq_assoc Extend.RightA) in - let rule = [ - gram_token_of_string name; - gram_token_of_string ":"; - symbol_of_prod_entry_key (Aentry (name_of_entry e)); - ] in - let action v _ _ loc = - let loc = !@loc in - let arg = TacGeneric (Genarg.in_gen (Genarg.rawwit wit) (cast (loc, v))) in - TacArg (loc, arg) - in - let gram = (level, assoc, [rule, Gram.action action]) in - maybe_uncurry (Gram.extend Tactic.tactic_expr) (None, [gram]) diff --git a/parsing/egramcoq.mli b/parsing/egramcoq.mli index cdd5fbd0f..6ec106626 100644 --- a/parsing/egramcoq.mli +++ b/parsing/egramcoq.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -36,34 +36,27 @@ type notation_grammar = { notgram_typs : notation_var_internalization_type list; } -type tactic_grammar = { - tacgram_level : int; - tacgram_prods : Tacexpr.raw_tactic_expr grammar_prod_item list; -} +(** {5 Extending the parser with Summary-synchronized commands} *) + +type 'a grammar_command +(** Type of synchronized parsing extensions. The ['a] type should be + marshallable. *) + +val create_grammar_command : string -> ('a -> int) -> 'a grammar_command +(** Create a new grammar-modifying command with the given name. The function + should modify the parser state and return the number of grammar extensions + performed. *) + +val extend_grammar : 'a grammar_command -> 'a -> unit +(** Extend the grammar of Coq with the given data. *) (** {5 Adding notations} *) val extend_constr_grammar : Notation.level -> notation_grammar -> unit (** Add a term notation rule to the parsing system. *) -val extend_tactic_grammar : KerName.t -> tactic_grammar -> unit -(** Add a tactic notation rule to the parsing system. This produces a TacAlias - tactic with the provided kernel name. *) - -val extend_ml_tactic_grammar : Tacexpr.ml_tactic_name -> Tacexpr.raw_tactic_expr grammar_prod_item list list -> unit -(** Add a ML tactic notation rule to the parsing system. This produces a - TacML tactic with the provided string as name. *) - val recover_constr_grammar : notation -> Notation.level -> notation_grammar (** For a declared grammar, returns the rule + the ordered entry types of variables in the rule (for use in the interpretation) *) val with_grammar_rule_protection : ('a -> 'b) -> 'a -> 'b - -(** {5 Adding tactic quotations} *) - -val create_ltac_quotation : string -> ('grm Loc.located -> 'raw) -> - ('raw, 'glb, 'top) genarg_type -> 'grm Gram.entry -> unit -(** [create_ltac_quotation name f wit e] adds a quotation rule to Ltac, that is, - Ltac grammar now accepts arguments of the form ["name" ":" <e>], and - generates a generic argument using [f] on the entry parsed by [e]. *) diff --git a/parsing/egramml.ml b/parsing/egramml.ml index 984027b81..37fccdb3c 100644 --- a/parsing/egramml.ml +++ b/parsing/egramml.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -9,6 +9,7 @@ open Util open Compat open Names +open Extend open Pcoq open Genarg open Vernacexpr @@ -18,9 +19,9 @@ open Vernacexpr type 's grammar_prod_item = | GramTerminal of string | GramNonTerminal : - Loc.t * 'a raw_abstract_argument_type * ('s, 'a) entry_key * Id.t option -> 's grammar_prod_item + Loc.t * 'a raw_abstract_argument_type * ('s, 'a) symbol -> 's grammar_prod_item -type 'a ty_arg = Id.t * ('a -> raw_generic_argument) +type 'a ty_arg = ('a -> raw_generic_argument) type ('self, _, 'r) ty_rule = | TyStop : ('self, 'r, 'r) ty_rule @@ -37,12 +38,9 @@ let rec ty_rule_of_gram = function let tok = Atoken (Lexer.terminal s) in let r = TyNext (rem, tok, None) in AnyTyRule r -| GramNonTerminal (_, t, tok, idopt) :: rem -> +| GramNonTerminal (_, t, tok) :: rem -> let AnyTyRule rem = ty_rule_of_gram rem in - let inj = match idopt with - | None -> None - | Some id -> Some (id, fun obj -> Genarg.in_gen t obj) - in + let inj = Some (fun obj -> Genarg.in_gen t obj) in let r = TyNext (rem, tok, inj) in AnyTyRule r @@ -50,13 +48,13 @@ let rec ty_erase : type s a r. (s, a, r) ty_rule -> (s, a, r) Extend.rule = func | TyStop -> Extend.Stop | TyNext (rem, tok, _) -> Extend.Next (ty_erase rem, tok) -type 'r gen_eval = Loc.t -> (Id.t * raw_generic_argument) list -> 'r +type 'r gen_eval = Loc.t -> raw_generic_argument list -> 'r -let rec ty_eval : type s a r. (s, a, Loc.t -> s) ty_rule -> s gen_eval -> a = function +let rec ty_eval : type s a. (s, a, Loc.t -> s) ty_rule -> s gen_eval -> a = function | TyStop -> fun f loc -> f loc [] | TyNext (rem, tok, None) -> fun f _ -> ty_eval rem f -| TyNext (rem, tok, Some (id, inj)) -> fun f x -> - let f loc args = f loc ((id, inj x) :: args) in +| TyNext (rem, tok, Some inj) -> fun f x -> + let f loc args = f loc (inj x :: args) in ty_eval rem f let make_rule f prod = @@ -81,6 +79,6 @@ let get_extend_vernac_rule (s, i) = let extend_vernac_command_grammar s nt gl = let nt = Option.default Vernac_.command nt in vernac_exts := (s,gl) :: !vernac_exts; - let mkact loc l = VernacExtend (s,List.map snd l) in + let mkact loc l = VernacExtend (s, l) in let rules = [make_rule mkact gl] in grammar_extend nt None (None, [None, None, rules]) diff --git a/parsing/egramml.mli b/parsing/egramml.mli index e3ae4e011..1ad947200 100644 --- a/parsing/egramml.mli +++ b/parsing/egramml.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -16,7 +16,7 @@ open Vernacexpr type 's grammar_prod_item = | GramTerminal of string | GramNonTerminal : Loc.t * 'a Genarg.raw_abstract_argument_type * - ('s, 'a) Pcoq.entry_key * Names.Id.t option -> 's grammar_prod_item + ('s, 'a) Extend.symbol -> 's grammar_prod_item val extend_vernac_command_grammar : Vernacexpr.extend_name -> vernac_expr Pcoq.Gram.entry option -> @@ -27,5 +27,5 @@ val get_extend_vernac_rule : Vernacexpr.extend_name -> vernac_expr grammar_prod_ (** Utility function reused in Egramcoq : *) val make_rule : - (Loc.t -> (Names.Id.t * Genarg.raw_generic_argument) list -> 'a) -> + (Loc.t -> Genarg.raw_generic_argument list -> 'a) -> 'a grammar_prod_item list -> 'a Extend.production_rule diff --git a/parsing/entry.ml b/parsing/entry.ml index 97d601320..b7c6c23fa 100644 --- a/parsing/entry.ml +++ b/parsing/entry.ml @@ -9,55 +9,22 @@ open Errors open Util -type 'a t = string * string - -type repr = -| Static of string * string -| Dynamic of string - -type universe = string - -(* The univ_tab is not part of the state. It contains all the grammars that - exist or have existed before in the session. *) - -let univ_tab = (Hashtbl.create 7 : (string, unit) Hashtbl.t) - -let create_univ s = - Hashtbl.add univ_tab s (); s - -let univ_name s = s - -let uprim = create_univ "prim" -let uconstr = create_univ "constr" -let utactic = create_univ "tactic" -let uvernac = create_univ "vernac" - -let get_univ s = - try - Hashtbl.find univ_tab s; s - with Not_found -> - anomaly (Pp.str ("Unknown grammar universe: "^s)) +type 'a t = string (** Entries are registered with a unique name *) let entries = ref String.Set.empty -let create u name = - let uname = u ^ ":" ^ name in +let create name = let () = - if String.Set.mem uname !entries then - anomaly (Pp.str ("Entry " ^ uname ^ " already defined")) + if String.Set.mem name !entries then + anomaly (Pp.str ("Entry " ^ name ^ " already defined")) in - let () = entries := String.Set.add uname !entries in - (u, name) - -let dynamic name = ("", name) + let () = entries := String.Set.add name !entries in + name -let unsafe_of_name (u, s) = - let uname = u ^ ":" ^ s in - assert (String.Set.mem uname !entries); - (u, s) +let unsafe_of_name name = + assert (String.Set.mem name !entries); + name -let repr = function -| ("", u) -> Dynamic u -| (u, s) -> Static (u, s) +let repr s = s diff --git a/parsing/entry.mli b/parsing/entry.mli index 6854a5cb4..4c73fe204 100644 --- a/parsing/entry.mli +++ b/parsing/entry.mli @@ -11,40 +11,13 @@ type 'a t (** Typed grammar entries. We need to defined them here so that they are marshallable and defined before the Pcoq.Gram module. They are basically - unique names made of a universe and an entry name. They should be kept - synchronized with the {!Pcoq} entries though. *) + unique names. They should be kept synchronized with the {!Pcoq} entries. *) -type repr = -| Static of string * string -| Dynamic of string -(** Representation of entries. *) - -(** Table of Coq statically defined grammar entries *) - -type universe - -(** There are four predefined universes: "prim", "constr", "tactic", "vernac" *) - -val get_univ : string -> universe -val univ_name : universe -> string - -val uprim : universe -val uconstr : universe -val utactic : universe -val uvernac : universe - -(** {5 Uniquely defined entries} *) - -val create : universe -> string -> 'a t +val create : string -> 'a t (** Create an entry. They should be synchronized with the entries defined in {!Pcoq}. *) (** {5 Meta-programming} *) -val dynamic : string -> 'a t -(** Dynamic entries. They refer to entries defined in the code source and may - only be used in meta-programming definitions from the grammar directory. *) - -val repr : 'a t -> repr - -val unsafe_of_name : (string * string) -> 'a t +val repr : 'a t -> string +val unsafe_of_name : string -> 'a t diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index e2e6795f7..7e470e844 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -132,10 +132,7 @@ GEXTEND Gram closed_binder open_binders binder binders binders_fixannot record_declaration typeclass_constraint pattern appl_arg; Constr.ident: - [ [ id = Prim.ident -> id - - (* This is used in quotations and Syntax *) - | id = METAIDENT -> Id.of_string id ] ] + [ [ id = Prim.ident -> id ] ] ; Prim.name: [ [ "_" -> (!@loc, Anonymous) ] ] @@ -218,16 +215,13 @@ GEXTEND Gram CGeneralization (!@loc, Implicit, None, c) | "`("; c = operconstr LEVEL "200"; ")" -> CGeneralization (!@loc, Explicit, None, c) - | "$("; tac = Tactic.tactic; ")$" -> + | IDENT "ltac"; ":"; "("; tac = Tactic.tactic_expr; ")" -> let arg = Genarg.in_gen (Genarg.rawwit Constrarg.wit_tactic) tac in CHole (!@loc, None, IntroAnonymous, Some arg) ] ] ; record_declaration: - [ [ fs = record_fields -> CRecord (!@loc, None, fs) -(* | c = lconstr; "with"; fs = LIST1 record_field_declaration SEP ";" -> *) -(* CRecord (!@loc, Some c, fs) *) - ] ] + [ [ fs = record_fields -> CRecord (!@loc, fs) ] ] ; record_fields: @@ -267,14 +261,14 @@ GEXTEND Gram CLetTuple (!@loc,lb,po,c1,c2) | "let"; "'"; p=pattern; ":="; c1 = operconstr LEVEL "200"; "in"; c2 = operconstr LEVEL "200" -> - CCases (!@loc, LetPatternStyle, None, [(c1,(None,None))], [(!@loc, [(!@loc,[p])], c2)]) + CCases (!@loc, LetPatternStyle, None, [c1, None, None], [(!@loc, [(!@loc,[p])], c2)]) | "let"; "'"; p=pattern; ":="; c1 = operconstr LEVEL "200"; rt = case_type; "in"; c2 = operconstr LEVEL "200" -> - CCases (!@loc, LetPatternStyle, Some rt, [(c1, (aliasvar p, None))], [(!@loc, [(!@loc, [p])], c2)]) + CCases (!@loc, LetPatternStyle, Some rt, [c1, aliasvar p, None], [(!@loc, [(!@loc, [p])], c2)]) | "let"; "'"; p=pattern; "in"; t = pattern LEVEL "200"; ":="; c1 = operconstr LEVEL "200"; rt = case_type; "in"; c2 = operconstr LEVEL "200" -> - CCases (!@loc, LetPatternStyle, Some rt, [(c1, (aliasvar p, Some t))], [(!@loc, [(!@loc, [p])], c2)]) + CCases (!@loc, LetPatternStyle, Some rt, [c1, aliasvar p, Some t], [(!@loc, [(!@loc, [p])], c2)]) | "if"; c=operconstr LEVEL "200"; po = return_type; "then"; b1=operconstr LEVEL "200"; "else"; b2=operconstr LEVEL "200" -> @@ -338,11 +332,10 @@ GEXTEND Gram br=branches; "end" -> CCases(!@loc,RegularStyle,ty,ci,br) ] ] ; case_item: - [ [ c=operconstr LEVEL "100"; p=pred_pattern -> (c,p) ] ] - ; - pred_pattern: - [ [ ona = OPT ["as"; id=name -> id]; - ty = OPT ["in"; t=pattern -> t] -> (ona,ty) ] ] + [ [ c=operconstr LEVEL "100"; + ona = OPT ["as"; id=name -> id]; + ty = OPT ["in"; t=pattern -> t] -> + (c,ona,ty) ] ] ; case_type: [ [ "return"; ty = operconstr LEVEL "100" -> ty ] ] @@ -386,14 +379,17 @@ GEXTEND Gram | "10" RIGHTA [ p = pattern; lp = LIST1 NEXT -> (match p with - | CPatAtom (_, Some r) -> CPatCstr (!@loc, r, [], lp) + | CPatAtom (_, Some r) -> CPatCstr (!@loc, r, None, lp) + | CPatCstr (_, r, None, l2) -> Errors.user_err_loc + (cases_pattern_expr_loc p, "compound_pattern", + Pp.str "Nested applications not supported.") | CPatCstr (_, r, l1, l2) -> CPatCstr (!@loc, r, l1 , l2@lp) | CPatNotation (_, n, s, l) -> CPatNotation (!@loc, n , s, l@lp) | _ -> Errors.user_err_loc (cases_pattern_expr_loc p, "compound_pattern", Pp.str "Such pattern cannot have arguments.")) - |"@"; r = Prim.reference; lp = LIST1 NEXT -> - CPatCstr (!@loc, r, lp, []) ] + |"@"; r = Prim.reference; lp = LIST0 NEXT -> + CPatCstr (!@loc, r, Some lp, []) ] | "1" LEFTA [ c = pattern; "%"; key=IDENT -> CPatDelimiters (!@loc,key,c) ] | "0" diff --git a/parsing/g_prim.ml4 b/parsing/g_prim.ml4 index 84da9c424..5e67e9957 100644 --- a/parsing/g_prim.ml4 +++ b/parsing/g_prim.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -32,7 +32,7 @@ let my_int_of_string loc s = GEXTEND Gram GLOBAL: - bigint natural integer identref name ident var preident + bigint natural index integer identref name ident var preident fullyqualid qualid reference dirpath ne_lstring ne_string string pattern_ident pattern_identref by_notation smart_global; preident: @@ -113,6 +113,9 @@ GEXTEND Gram natural: [ [ i = INT -> my_int_of_string (!@loc) i ] ] ; + index: + [ [ i = INDEX -> my_int_of_string (!@loc) i ] ] + ; bigint: (* Negative numbers are dealt with specially *) [ [ i = INT -> (Bigint.of_string i) ] ] ; diff --git a/parsing/g_proofs.ml4 b/parsing/g_proofs.ml4 index 7f5459bfa..422384f3d 100644 --- a/parsing/g_proofs.ml4 +++ b/parsing/g_proofs.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -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 69593f993..0c90a8bca 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -44,6 +44,20 @@ let test_lpar_id_coloneq = | _ -> err ()) | _ -> err ()) +(* Hack to recognize "(x)" *) +let test_lpar_id_rpar = + Gram.Entry.of_parser "lpar_id_coloneq" + (fun strm -> + match get_tok (stream_nth 0 strm) with + | KEYWORD "(" -> + (match get_tok (stream_nth 1 strm) with + | IDENT _ -> + (match get_tok (stream_nth 2 strm) with + | KEYWORD ")" -> () + | _ -> err ()) + | _ -> err ()) + | _ -> err ()) + (* idem for (x:=t) and (1:=t) *) let test_lpar_idnum_coloneq = Gram.Entry.of_parser "test_lpar_idnum_coloneq" @@ -217,15 +231,16 @@ GEXTEND Gram [ [ id = identref -> id ] ] ; open_constr: - [ [ c = constr -> ((),c) ] ] + [ [ c = constr -> c ] ] ; uconstr: [ [ c = constr -> c ] ] ; induction_arg: [ [ n = natural -> (None,ElimOnAnonHyp n) - | c = constr_with_bindings -> (None,induction_arg_of_constr c) - | "!"; c = constr_with_bindings -> (Some false,induction_arg_of_constr c) + | test_lpar_id_rpar; c = constr_with_bindings -> + (Some false,induction_arg_of_constr c) + | c = constr_with_bindings_arg -> on_snd induction_arg_of_constr c ] ] ; constr_with_bindings_arg: @@ -266,19 +281,23 @@ GEXTEND Gram intropatterns: [ [ l = LIST0 nonsimple_intropattern -> l ]] ; + ne_intropatterns: + [ [ l = LIST1 nonsimple_intropattern -> l ]] + ; or_and_intropattern: - [ [ "["; tc = LIST1 intropatterns SEP "|"; "]" -> tc - | "()" -> [[]] - | "("; si = simple_intropattern; ")" -> [[si]] + [ [ "["; tc = LIST1 intropatterns SEP "|"; "]" -> IntroOrPattern tc + | "()" -> IntroAndPattern [] + | "("; si = simple_intropattern; ")" -> IntroAndPattern [si] | "("; si = simple_intropattern; ","; - tc = LIST1 simple_intropattern SEP "," ; ")" -> [si::tc] + tc = LIST1 simple_intropattern SEP "," ; ")" -> + IntroAndPattern (si::tc) | "("; si = simple_intropattern; "&"; tc = LIST1 simple_intropattern SEP "&" ; ")" -> (* (A & B & C) is translated into (A,(B,C)) *) let rec pairify = function - | ([]|[_]|[_;_]) as l -> [l] - | t::q -> [[t;(loc_of_ne_list q,IntroAction (IntroOrAndPattern (pairify q)))]] - in pairify (si::tc) ] ] + | ([]|[_]|[_;_]) as l -> l + | t::q -> [t;(loc_of_ne_list q,IntroAction (IntroOrAndPattern (IntroAndPattern (pairify q))))] + in IntroAndPattern (pairify (si::tc)) ] ] ; equality_intropattern: [ [ "->" -> IntroRewrite true @@ -296,11 +315,18 @@ GEXTEND Gram | "**" -> !@loc, IntroForthcoming false ]] ; simple_intropattern: + [ [ pat = simple_intropattern_closed; + l = LIST0 ["%"; c = operconstr LEVEL "0" -> c] -> + let loc0,pat = pat in + let f c pat = + let loc = Loc.merge loc0 (Constrexpr_ops.constr_loc c) in + IntroAction (IntroApplyOn (c,(loc,pat))) in + !@loc, List.fold_right f l pat ] ] + ; + simple_intropattern_closed: [ [ pat = or_and_intropattern -> !@loc, IntroAction (IntroOrAndPattern pat) | pat = equality_intropattern -> !@loc, IntroAction pat | "_" -> !@loc, IntroAction IntroWildcard - | pat = simple_intropattern; "/"; c = constr -> - !@loc, IntroAction (IntroApplyOn (c,pat)) | pat = naming_intropattern -> !@loc, IntroNaming pat ] ] ; simple_binding: @@ -339,21 +365,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 @@ -414,7 +425,7 @@ GEXTEND Gram | -> [] ] ] ; in_hyp_as: - [ [ "in"; id = id_or_meta; ipat = as_ipat -> Some (None,id,ipat) + [ [ "in"; id = id_or_meta; ipat = as_ipat -> Some (id,ipat) | -> None ] ] ; orient: @@ -443,25 +454,6 @@ GEXTEND Gram [ [ check_for_coloneq; "("; id = ident; bl = LIST0 simple_binder; ":="; c = lconstr; ")" -> (id, mkCLambdaN_simple bl c) ] ] ; - hintbases: - [ [ "with"; "*" -> None - | "with"; l = LIST1 [ x = IDENT -> x] -> Some l - | -> Some [] ] ] - ; - auto_using: - [ [ "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 ] ] ; @@ -502,12 +494,12 @@ GEXTEND Gram [ [ id1 = id_or_meta; IDENT "into"; id2 = id_or_meta -> (id1,id2) ] ] ; rewriter : - [ [ "!"; c = constr_with_bindings -> (RepeatPlus,(None,c)) + [ [ "!"; c = constr_with_bindings_arg -> (RepeatPlus,c) | ["?"| LEFTQMARK]; c = constr_with_bindings_arg -> (RepeatStar,c) - | n = natural; "!"; c = constr_with_bindings -> (Precisely n,(None,c)) + | n = natural; "!"; c = constr_with_bindings_arg -> (Precisely n,c) | n = natural; ["?" | LEFTQMARK]; c = constr_with_bindings_arg -> (UpTo n,c) | n = natural; c = constr_with_bindings_arg -> (Precisely n,c) - | c = constr_with_bindings -> (Precisely 1, (None,c)) + | c = constr_with_bindings_arg -> (Precisely 1, c) ] ] ; oriented_rewriter : @@ -535,7 +527,10 @@ GEXTEND Gram simple_tactic: [ [ (* Basic tactics *) - IDENT "intros"; pl = intropatterns -> TacAtom (!@loc, TacIntroPattern pl) + IDENT "intros"; pl = ne_intropatterns -> + TacAtom (!@loc, TacIntroPattern pl) + | IDENT "intros" -> + TacAtom (!@loc, TacIntroPattern [!@loc,IntroForthcoming false]) | IDENT "intro"; id = ident; hto = move_location -> TacAtom (!@loc, TacIntroMove (Some id, hto)) | IDENT "intro"; hto = move_location -> TacAtom (!@loc, TacIntroMove (None, hto)) @@ -560,12 +555,8 @@ GEXTEND Gram TacAtom (!@loc, TacElim (true,cl,el)) | IDENT "case"; icl = induction_clause_list -> TacAtom (!@loc, mkTacCase false icl) | IDENT "ecase"; icl = induction_clause_list -> TacAtom (!@loc, mkTacCase true icl) - | "fix"; n = natural -> TacAtom (!@loc, TacFix (None,n)) - | "fix"; id = ident; n = natural -> TacAtom (!@loc, TacFix (Some id,n)) | "fix"; id = ident; n = natural; "with"; fd = LIST1 fixdecl -> TacAtom (!@loc, TacMutualFix (id,n,List.map mk_fix_tac fd)) - | "cofix" -> TacAtom (!@loc, TacCofix None) - | "cofix"; id = ident -> TacAtom (!@loc, TacCofix (Some id)) | "cofix"; id = ident; "with"; fd = LIST1 cofixdecl -> TacAtom (!@loc, TacMutualCofix (id,List.map mk_cofix_tac fd)) @@ -612,7 +603,6 @@ GEXTEND Gram na = as_name; l = LIST0 [","; c = pattern_occ; na = as_name -> (c,na)] -> TacAtom (!@loc, TacGeneralize (((nl,c),na)::l)) - | IDENT "generalize"; IDENT "dependent"; c = constr -> TacAtom (!@loc, TacGeneralizeDep c) (* Derived basic tactics *) | IDENT "induction"; ic = induction_clause_list -> @@ -626,28 +616,9 @@ GEXTEND Gram | IDENT "edestruct"; icl = induction_clause_list -> 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)) - (* Context management *) - | IDENT "clear"; "-"; l = LIST1 id_or_meta -> TacAtom (!@loc, TacClear (true, l)) - | IDENT "clear"; l = LIST0 id_or_meta -> - let is_empty = match l with [] -> true | _ -> false in - TacAtom (!@loc, TacClear (is_empty, l)) - | IDENT "clearbody"; l = LIST1 id_or_meta -> TacAtom (!@loc, TacClearBody l) - | IDENT "move"; hfrom = id_or_meta; hto = move_location -> - TacAtom (!@loc, TacMove (hfrom,hto)) | IDENT "rename"; l = LIST1 rename SEP "," -> TacAtom (!@loc, TacRename l) - (* Constructors *) - | "exists"; bll = opt_bindings -> TacAtom (!@loc, TacSplit (false,bll)) - | IDENT "eexists"; bll = opt_bindings -> - TacAtom (!@loc, TacSplit (true,bll)) - (* Equivalence relations *) - | IDENT "symmetry"; "in"; cl = in_clause -> TacAtom (!@loc, TacSymmetry cl) - (* Equality and inversion *) | IDENT "rewrite"; l = LIST1 oriented_rewriter SEP ","; cl = clause_dft_concl; t=opt_by_tactic -> TacAtom (!@loc, TacRewrite (false,l,cl,t)) @@ -677,7 +648,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 1f9f57f69..8d7b6a2b4 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -34,8 +34,6 @@ let _ = List.iter Lexer.add_keyword vernac_kw let query_command = Gram.entry_create "vernac:query_command" -let tactic_mode = Gram.entry_create "vernac:tactic_command" -let noedit_mode = Gram.entry_create "vernac:noedit_command" let subprf = Gram.entry_create "vernac:subprf" let class_rawexpr = Gram.entry_create "vernac:class_rawexpr" @@ -48,21 +46,6 @@ let subgoal_command = Gram.entry_create "proof_mode:subgoal_command" let instance_name = Gram.entry_create "vernac:instance_name" 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 -let get_command_entry () = !command_entry - - -(* Registers the Classic Proof Mode (which uses [tactic_mode] as a parser for - proof editing and changes nothing else). Then sets it as the default proof mode. *) -let set_tactic_mode () = set_command_entry tactic_mode -let set_noedit_mode () = set_command_entry noedit_mode -let _ = Proof_global.register_proof_mode {Proof_global. - name = "Classic" ; - set = set_tactic_mode ; - reset = set_noedit_mode - } - let make_bullet s = let n = String.length s in match s.[0] with @@ -71,26 +54,11 @@ 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) - GEXTEND Gram - GLOBAL: vernac gallina_ext tactic_mode noedit_mode subprf subgoal_command; + GLOBAL: vernac gallina_ext 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 "Time"; c = located_vernac -> VernacTime c + | IDENT "Redirect"; s = ne_string; c = located_vernac -> VernacRedirect (s, c) | IDENT "Timeout"; n = natural; v = vernac -> VernacTimeout(n,v) | IDENT "Fail"; v = vernac -> VernacFail v @@ -128,28 +96,13 @@ GEXTEND Gram | c = subprf -> c ] ] ; - vernac_list: - [ [ c = located_vernac -> [c] ] ] - ; vernac_aux: LAST - [ [ prfcom = default_command_entry -> prfcom ] ] + [ [ prfcom = command_entry -> prfcom ] ] ; noedit_mode: [ [ c = subgoal_command -> c None] ] ; - selector: - [ [ n=natural; ":" -> SelectNth n - | test_bracket_ident; "["; id = ident; "]"; ":" -> SelectId id - | IDENT "all" ; ":" -> SelectAll - | IDENT "par" ; ":" -> SelectAllParallel ] ] - ; - - tactic_mode: - [ [ gln = OPT selector; - tac = subgoal_command -> tac gln ] ] - ; - subprf: [ [ s = BULLET -> VernacBullet (make_bullet s) | "{" -> VernacSubproof None @@ -164,26 +117,20 @@ GEXTEND Gram | None -> c None | _ -> VernacError (UserError ("",str"Typing and evaluation commands, cannot be used with the \"all:\" selector.")) - end - | info = OPT [IDENT "Info";n=natural -> n]; - tac = Tactic.tactic; - use_dft_tac = [ "." -> false | "..." -> true ] -> - (fun g -> - let g = Option.default (Proof_global.get_default_goal_selector ()) g in - VernacSolve(g,info,tac,use_dft_tac)) ] ] + end ] ] ; located_vernac: [ [ v = vernac -> !@loc, v ] ] ; END -let test_plurial_form = function +let test_plural_form = function | [(_,([_],_))] -> Flags.if_verbose msg_warning (strbrk "Keywords Variables/Hypotheses/Parameters expect more than one assumption") | _ -> () -let test_plurial_form_types = function +let test_plural_form_types = function | [([_],_)] -> Flags.if_verbose msg_warning (strbrk "Keywords Implicit Types expect more than one type") @@ -192,7 +139,7 @@ let test_plurial_form_types = function (* Gallina declarations *) GEXTEND Gram GLOBAL: gallina gallina_ext thm_token def_body of_type_with_opt_coercion - record_field decl_notation rec_definition; + record_field decl_notation rec_definition pidentref; gallina: (* Definition, Theorem, Variable, Axiom, ... *) @@ -204,7 +151,7 @@ GEXTEND Gram | stre = assumption_token; nl = inline; bl = assum_list -> VernacAssumption (stre, nl, bl) | stre = assumptions_token; nl = inline; bl = assum_list -> - test_plurial_form bl; + test_plural_form bl; VernacAssumption (stre, nl, bl) | d = def_token; id = pidentref; b = def_body -> VernacDefinition (d, id, b) @@ -736,7 +683,7 @@ GEXTEND Gram VernacReserve bl | IDENT "Implicit"; IDENT "Types"; bl = reserv_list -> - test_plurial_form_types bl; + test_plural_form_types bl; VernacReserve bl | IDENT "Generalizable"; @@ -783,10 +730,10 @@ GEXTEND Gram | IDENT "transparent" -> Conv_oracle.transparent ] ] ; instance_name: - [ [ name = identref; sup = OPT binders -> - (let (loc,id) = name in (loc, Name id)), + [ [ name = pidentref; sup = OPT binders -> + (let ((loc,id),l) = name in ((loc, Name id),l)), (Option.default [] sup) - | -> (!@loc, Anonymous), [] ] ] + | -> ((!@loc, Anonymous), None), [] ] ] ; reserv_list: [ [ bl = LIST1 reserv_tuple -> bl | b = simple_reserv -> [b] ] ] @@ -804,11 +751,7 @@ GEXTEND Gram GLOBAL: command query_command class_rawexpr; command: - [ [ IDENT "Ltac"; - l = LIST1 tacdef_body SEP "with" -> - VernacDeclareTacticDefinition (true, l) - - | IDENT "Comments"; l = LIST0 comment -> VernacComments l + [ [ IDENT "Comments"; l = LIST0 comment -> VernacComments l (* Hack! Should be in grammar_ext, but camlp4 factorize badly *) | IDENT "Declare"; IDENT "Instance"; namesup = instance_name; ":"; @@ -943,7 +886,6 @@ GEXTEND Gram | IDENT "Classes" -> PrintClasses | IDENT "TypeClasses" -> PrintTypeClasses | IDENT "Instances"; qid = smart_global -> PrintInstances qid - | IDENT "Ltac"; qid = global -> PrintLtac qid | IDENT "Coercions" -> PrintCoercions | IDENT "Coercion"; IDENT "Paths"; s = class_rawexpr; t = class_rawexpr -> PrintCoercionPaths (s,t) @@ -954,7 +896,6 @@ GEXTEND Gram | IDENT "Hint"; qid = smart_global -> PrintHint qid | IDENT "Hint"; "*" -> PrintHintDb | IDENT "HintDb"; s = IDENT -> PrintHintDbName s - | "Rewrite"; IDENT "HintDb"; s = IDENT -> PrintRewriteHintDbName s | IDENT "Scopes" -> PrintScopes | IDENT "Scope"; s = IDENT -> PrintScope s | IDENT "Visibility"; s = OPT [x = IDENT -> x ] -> PrintVisibility s @@ -1102,10 +1043,6 @@ GEXTEND Gram | IDENT "Format"; IDENT "Notation"; n = STRING; s = STRING; fmt = STRING -> VernacNotationAddFormat (n,s,fmt) - | IDENT "Tactic"; IDENT "Notation"; n = tactic_level; - pil = LIST1 production_item; ":="; t = Tactic.tactic - -> VernacTacticNotation (n,pil,t) - | IDENT "Reserved"; IDENT "Infix"; s = ne_lstring; l = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ] -> Metasyntax.check_infix_modifiers l; @@ -1131,9 +1068,6 @@ GEXTEND Gram obsolete_locality: [ [ IDENT "Local" -> true | -> false ] ] ; - tactic_level: - [ [ "("; "at"; IDENT "level"; n = natural; ")" -> n | -> 0 ] ] - ; level: [ [ IDENT "level"; n = natural -> NumLevel n | IDENT "next"; IDENT "level" -> NextLevel ] ] @@ -1165,10 +1099,4 @@ GEXTEND Gram | IDENT "closed"; IDENT "binder" -> ETBinder false ] ] ; - production_item: - [ [ s = ne_string -> TacTerm s - | nt = IDENT; - po = OPT [ "("; p = ident; sep = [ -> "" | ","; sep = STRING -> sep ]; - ")" -> (p,sep) ] -> TacNonTerm (!@loc,nt,po) ] ] - ; END diff --git a/parsing/highparsing.mllib b/parsing/highparsing.mllib index 13ed80464..8df519b56 100644 --- a/parsing/highparsing.mllib +++ b/parsing/highparsing.mllib @@ -3,5 +3,3 @@ G_vernac G_prim G_proofs G_tactic -G_ltac -G_obligations diff --git a/parsing/lexer.ml4 b/parsing/lexer.ml4 index 23bd74da9..8b8b38c34 100644 --- a/parsing/lexer.ml4 +++ b/parsing/lexer.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -80,6 +80,7 @@ module Error = struct | Undefined_token | Bad_token of string | UnsupportedUnicode of int + | IncorrectIndex of char list exception E of t @@ -92,7 +93,16 @@ module Error = struct | Undefined_token -> "Undefined token" | Bad_token tok -> Format.sprintf "Bad token %S" tok | UnsupportedUnicode x -> - Printf.sprintf "Unsupported Unicode character (0x%x)" x) + Printf.sprintf "Unsupported Unicode character (0x%x)" x + | IncorrectIndex l -> + let l = List.map (fun c -> Char.code c - 48) l in + let s = match l with + | c::d::l -> + let l = List.map string_of_int (List.rev l) in + String.concat "" l ^ CString.ordinal (10 * d + c) + | [c] -> CString.ordinal c + | [] -> assert false in + Printf.sprintf "%s expected" s) (* Require to fix the Camlp4 signature *) let print ppf x = Pp.pp_with ppf (Pp.str (to_string x)) @@ -262,9 +272,38 @@ let rec ident_tail len = parser ident_tail (nstore n len s) s | _ -> len -let rec number len = parser - | [< ' ('0'..'9' as c); s >] -> number (store len c) s - | [< >] -> len +let check_no_char s = + match Stream.npeek 3 s with + | [_;_;('a'..'z' | 'A'..'Z' | '0'..'9' | ''' | '_')] -> false + | [_;_;_] -> true + | [_;_] -> true + | _ -> assert false + +let is_teen = function + | _::'1'::l -> true + | _ -> false + +let is_gt3 = function + | c::_ when c == '1' || c == '2' || c == '3' -> false + | _ -> true + +let check_gt3 l loc len = + if not (l == ['0']) && (is_teen l || is_gt3 l) then (false, len) + else err loc (IncorrectIndex l) + +let check_n n l loc len = + if List.hd l == n && not (is_teen l) then (false, len) + else err loc (IncorrectIndex l) + +let rec number_or_index bp l len = parser + | [< ' ('0'..'9' as c); s >] -> number_or_index bp (c::l) (store len c) s + | [< s >] ep -> + match Stream.npeek 2 s with + | ['s';'t'] when check_no_char s -> njunk 2 s; check_n '1' l (bp,ep) len + | ['n';'d'] when check_no_char s -> njunk 2 s; check_n '2' l (bp,ep) len + | ['r';'d'] when check_no_char s -> njunk 2 s; check_n '3' l (bp,ep) len + | ['t';'h'] when check_no_char s -> njunk 2 s; check_gt3 l (bp,ep) len + | _ -> true, len let rec string in_comments bp len = parser | [< ''"'; esc=(parser [<''"' >] -> true | [< >] -> false); s >] -> @@ -297,6 +336,9 @@ let rec string in_comments bp len = parser | [< 'c; s >] -> string in_comments bp (store len c) s | [< _ = Stream.empty >] ep -> err (bp, ep) Unterminated_string +(* Hook for exporting comment into xml theory files *) +let (f_xml_output_comment, xml_output_comment) = Hook.make ~default:ignore () + (* Utilities for comments in beautify *) let comment_begin = ref None let comm_loc bp = match !comment_begin with @@ -339,6 +381,9 @@ let null_comment s = let comment_stop ep = let current_s = Buffer.contents current in + if !Flags.xml_export && Buffer.length current > 0 && + (!between_com || not(null_comment current_s)) then + Hook.get f_xml_output_comment current_s; (if Flags.do_beautify() && Buffer.length current > 0 && (!between_com || not(null_comment current_s)) then let bp = match !comment_begin with @@ -448,7 +493,6 @@ let process_chars bp c cs = err (bp, ep') Undefined_token let token_of_special c s = match c with - | '$' -> METAIDENT s | '.' -> FIELD s | _ -> assert false @@ -487,8 +531,6 @@ let blank_or_eof cs = let rec next_token = parser bp | [< '' ' | '\t' | '\n' |'\r' as c; s >] -> comm_loc bp; push_char c; next_token s - | [< ''$' as c; t = parse_after_special c bp >] ep -> - comment_stop bp; (t, (ep, bp)) | [< ''.' as c; t = parse_after_special c bp; s >] ep -> comment_stop bp; (* We enforce that "." should either be part of a larger keyword, @@ -513,9 +555,9 @@ let rec next_token = parser bp let id = get_buff len in comment_stop bp; (try find_keyword id s with Not_found -> IDENT id), (bp, ep) - | [< ' ('0'..'9' as c); len = number (store 0 c) >] ep -> + | [< ' ('0'..'9' as c); (b,len) = number_or_index bp [c] (store 0 c) >] ep -> comment_stop bp; - (INT (get_buff len), (bp, ep)) + (if b then INT (get_buff len) else INDEX (get_buff len)), (bp, ep) | [< ''\"'; len = string None bp 0 >] ep -> comment_stop bp; (STRING (get_buff len), (bp, ep)) @@ -682,7 +724,7 @@ let strip s = let terminal s = let s = strip s in - let () = match s with "" -> Errors.error "empty token." | _ -> () in + let () = match s with "" -> failwith "empty token." | _ -> () in if is_ident_not_keyword s then IDENT s else if is_number s then INT s else KEYWORD s diff --git a/parsing/lexer.mli b/parsing/lexer.mli index 2b9bd37df..24b0ec847 100644 --- a/parsing/lexer.mli +++ b/parsing/lexer.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -29,6 +29,8 @@ type com_state val com_state: unit -> com_state val restore_com_state: com_state -> unit +val xml_output_comment : (string -> unit) Hook.t + val terminal : string -> Tok.t (** The lexer of Coq: *) diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 4565b87a0..802c24eef 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -53,53 +53,10 @@ end (** Grammar entries with associated types *) type grammar_object = Gramobj.grammar_object -type typed_entry = argument_type * grammar_object G.entry -let in_typed_entry t e = (t,Gramobj.weaken_entry e) -let type_of_typed_entry (t,e) = t -let object_of_typed_entry (t,e) = e +type typed_entry = TypedEntry : 'a raw_abstract_argument_type * 'a G.entry -> typed_entry +let object_of_typed_entry (TypedEntry (_, e)) = Gramobj.weaken_entry e let weaken_entry x = Gramobj.weaken_entry x -(** General entry keys *) - -(** This intermediate abstract representation of entries can - both be reified into mlexpr for the ML extensions and - dynamically interpreted as entries for the Coq level extensions -*) - -type ('self, 'a) entry_key = ('self, 'a) Extend.symbol = -| Atoken : Tok.t -> ('self, string) entry_key -| Alist1 : ('self, 'a) entry_key -> ('self, 'a list) entry_key -| Alist1sep : ('self, 'a) entry_key * string -> ('self, 'a list) entry_key -| Alist0 : ('self, 'a) entry_key -> ('self, 'a list) entry_key -| Alist0sep : ('self, 'a) entry_key * string -> ('self, 'a list) entry_key -| Aopt : ('self, 'a) entry_key -> ('self, 'a option) entry_key -| Amodifiers : ('self, 'a) entry_key -> ('self, 'a list) entry_key -| Aself : ('self, 'self) entry_key -| Anext : ('self, 'self) entry_key -| Aentry : 'a Entry.t -> ('self, 'a) entry_key -| Aentryl : 'a Entry.t * int -> ('self, 'a) entry_key - -type 's entry_name = EntryName : - 'a raw_abstract_argument_type * ('s, 'a) entry_key -> 's entry_name - -module type Gramtypes = -sig - val inGramObj : 'a raw_abstract_argument_type -> 'a G.entry -> typed_entry - val outGramObj : 'a raw_abstract_argument_type -> typed_entry -> 'a G.entry -end - -module Gramtypes : Gramtypes = -struct - let inGramObj rawwit = in_typed_entry (unquote rawwit) - let outGramObj (a:'a raw_abstract_argument_type) o = - if not (argument_type_eq (type_of_typed_entry o) (unquote a)) - then anomaly ~label:"outGramObj" (str "wrong type"); - (* downcast from grammar_object *) - Obj.magic (object_of_typed_entry o) -end - -open Gramtypes - (** Grammar extensions *) (** NB: [extend_statment = @@ -218,74 +175,74 @@ let map_entry f en = let parse_string f x = let strm = Stream.of_string x in Gram.entry_parse f (Gram.parsable strm) -type gram_universe = Entry.universe - -let trace = ref false - -let uprim = Entry.uprim -let uconstr = Entry.uconstr -let utactic = Entry.utactic -let uvernac = Entry.uvernac -let get_univ = Entry.get_univ +type gram_universe = string let utables : (string, (string, typed_entry) Hashtbl.t) Hashtbl.t = Hashtbl.create 97 +let create_universe u = + let table = Hashtbl.create 97 in + let () = Hashtbl.add utables u table in + u + +let uprim = create_universe "prim" +let uconstr = create_universe "constr" +let utactic = create_universe "tactic" +let uvernac = create_universe "vernac" + +let get_univ u = + if Hashtbl.mem utables u then u + else raise Not_found + let get_utable u = - let u = Entry.univ_name u in try Hashtbl.find utables u - with Not_found -> - let table = Hashtbl.create 97 in - Hashtbl.add utables u table; - table + with Not_found -> assert false let get_entry u s = let utab = get_utable u in Hashtbl.find utab s -let get_typed_entry e = - let (u, s) = match Entry.repr e with - | Entry.Dynamic _ -> assert false - | Entry.Static (u, s) -> (u, s) - in - let u = Entry.get_univ u in - get_entry u s +(** A table associating grammar to entries *) +let gtable : Obj.t Gram.entry String.Map.t ref = ref String.Map.empty + +let get_grammar (e : 'a Entry.t) : 'a Gram.entry = + Obj.magic (String.Map.find (Entry.repr e) !gtable) + +let set_grammar (e : 'a Entry.t) (g : 'a Gram.entry) = + assert (not (String.Map.mem (Entry.repr e) !gtable)); + gtable := String.Map.add (Entry.repr e) (Obj.magic g) !gtable let new_entry etyp u s = let utab = get_utable u in - let uname = Entry.univ_name u in - if !trace then (Printf.eprintf "[Creating entry %s:%s]\n" uname s; flush stderr); - let _ = Entry.create u s in - let ename = uname ^ ":" ^ s in - let e = in_typed_entry etyp (Gram.entry_create ename) in - Hashtbl.add utab s e; e - -let create_entry u s etyp = - let utab = get_utable u in - try - let e = Hashtbl.find utab s in - let u = Entry.univ_name u in - if not (argument_type_eq (type_of_typed_entry e) etyp) then - failwith ("Entry " ^ u ^ ":" ^ s ^ " already exists with another type"); - e - with Not_found -> - new_entry etyp u s + let ename = u ^ ":" ^ s in + let entry = Entry.create ename in + let e = Gram.entry_create ename in + let () = set_grammar entry e in + Hashtbl.add utab s (TypedEntry (etyp, e)); e -let create_constr_entry s = - outGramObj (rawwit wit_constr) (create_entry uconstr s ConstrArgType) +let make_gen_entry u rawwit s = new_entry rawwit u s -let create_generic_entry s wit = - outGramObj wit (create_entry utactic s (unquote wit)) +module GrammarObj = +struct + type ('r, _, _) obj = 'r Gram.entry + let name = "grammar" + let default _ = None +end -(* [make_gen_entry] builds entries extensible by giving its name (a string) *) -(* For entries extensible only via the ML name, Gram.entry_create is enough *) +module Grammar = Register(GrammarObj) -let make_gen_entry u rawwit s = - let univ = get_utable u in - let uname = Entry.univ_name u in - let e = Gram.entry_create (uname ^ ":" ^ s) in - let _ = Entry.create u s in - Hashtbl.add univ s (inGramObj rawwit e); e +let register_grammar = Grammar.register0 +let genarg_grammar = Grammar.obj + +let create_generic_entry (type a) u s (etyp : a raw_abstract_argument_type) : a Gram.entry = + let utab = get_utable u in + if Hashtbl.mem utab s then + failwith ("Entry " ^ u ^ ":" ^ s ^ " already exists") + else + let e = new_entry etyp u s in + let Rawwit t = etyp in + let () = Grammar.register0 t e in + e (* Initial grammar entries *) @@ -298,6 +255,7 @@ module Prim = let preident = gec_gen (rawwit wit_pre_ident) "preident" let ident = gec_gen (rawwit wit_ident) "ident" let natural = gec_gen (rawwit wit_int) "natural" + let index = gec_gen (rawwit wit_int) "index" let integer = gec_gen (rawwit wit_int) "integer" let bigint = Gram.entry_create "Prim.bigint" let string = gec_gen (rawwit wit_string) "string" @@ -310,6 +268,7 @@ module Prim = let name = Gram.entry_create "Prim.name" let identref = Gram.entry_create "Prim.identref" + let pidentref = Gram.entry_create "Prim.pidentref" let pattern_ident = Gram.entry_create "pattern_ident" let pattern_identref = Gram.entry_create "pattern_identref" @@ -334,7 +293,7 @@ module Constr = let operconstr = gec_constr "operconstr" let constr_eoi = eoi_entry constr let lconstr = gec_constr "lconstr" - let binder_constr = create_constr_entry "binder_constr" + let binder_constr = gec_constr "binder_constr" let ident = make_gen_entry uconstr (rawwit wit_ident) "ident" let global = make_gen_entry uconstr (rawwit wit_ref) "global" let sort = make_gen_entry uconstr (rawwit wit_sort) "sort" @@ -395,9 +354,6 @@ module Tactic = (* Main entry for quotations *) let tactic_eoi = eoi_entry tactic - (* For Ltac definition *) - let tacdef_body = Gram.entry_create "tactic:tacdef_body" - end module Vernac_ = @@ -414,6 +370,7 @@ module Vernac_ = let rec_definition = gec_vernac "Vernac.rec_definition" (* Main vernac entry *) let main_entry = Gram.entry_create "vernac" + let noedit_mode = gec_vernac "noedit_command" let () = let act_vernac = Gram.action (fun v loc -> Some (!@loc, v)) in @@ -424,10 +381,18 @@ module Vernac_ = ] in maybe_uncurry (Gram.extend main_entry) (None, make_rule rule) + let command_entry_ref = ref noedit_mode + let command_entry = + Gram.Entry.of_parser "command_entry" + (fun strm -> Gram.parse_tokens_after_filter !command_entry_ref strm) + end let main_entry = Vernac_.main_entry +let set_command_entry e = Vernac_.command_entry_ref := e +let get_command_entry () = !Vernac_.command_entry_ref + (**********************************************************************) (* This determines (depending on the associativity of the current level and on the expected associativity) if a reference to constr_n is @@ -612,7 +577,7 @@ let adjust_level assoc from = function | ETConstr (p,()) -> Some (Some (n, Int.equal n p)) | _ -> Some (Some (n,false)) -let compute_entry allow_create adjust forpat = function +let compute_entry adjust forpat = function | ETConstr (n,q) -> (if forpat then weaken_entry Constr.pattern else weaken_entry Constr.operconstr), @@ -629,24 +594,19 @@ let compute_entry allow_create adjust forpat = function | ETPattern -> weaken_entry Constr.pattern, None, false | ETConstrList _ -> anomaly (Pp.str "List of entries cannot be registered.") | ETOther (u,n) -> - let u = get_univ u in - let e = - try get_entry u n - with Not_found when allow_create -> create_entry u n ConstrArgType in + let e = get_entry u n in object_of_typed_entry e, None, true (* This computes the name of the level where to add a new rule *) -let interp_constr_entry_key forpat = function - | ETConstr(200,()) when not forpat -> - weaken_entry Constr.binder_constr, None - | e -> - let (e,level,_) = compute_entry true (fun (n,()) -> Some n) forpat e in - (e, level) +let interp_constr_entry_key forpat level = + if level = 200 && not forpat then weaken_entry Constr.binder_constr, None + else if forpat then weaken_entry Constr.pattern, Some level + else weaken_entry Constr.operconstr, Some level (* This computes the name to give to a production knowing the name and associativity of the level where it must be added *) let interp_constr_prod_entry_key ass from forpat en = - compute_entry false (adjust_level ass from) forpat en + compute_entry (adjust_level ass from) forpat en (**********************************************************************) (* Binding constr entry keys to symbols *) @@ -707,7 +667,14 @@ let rec symbol_of_constr_prod_entry_key assoc from forpat typ = (** Binding general entry keys to symbol *) -let rec symbol_of_prod_entry_key : type s a. (s, a) entry_key -> _ = function +let tuplify l = + List.fold_left (fun accu x -> Obj.repr (x, accu)) (Obj.repr ()) l + +let rec adj : type a b c. (a, b, Loc.t -> Loc.t * c) adj -> _ = function +| Adj0 -> Obj.magic (fun accu f loc -> f (Obj.repr (to_coqloc loc, tuplify accu))) +| AdjS e -> Obj.magic (fun accu f x -> adj e (x :: accu) f) + +let rec symbol_of_prod_entry_key : type s a. (s, a) symbol -> _ = function | Atoken t -> Symbols.stoken t | Alist1 s -> Symbols.slist1 (symbol_of_prod_entry_key s) | Alist1sep (s,sep) -> @@ -716,36 +683,35 @@ let rec symbol_of_prod_entry_key : type s a. (s, a) entry_key -> _ = function | Alist0sep (s,sep) -> Symbols.slist0sep (symbol_of_prod_entry_key s, gram_token_of_string sep) | Aopt s -> Symbols.sopt (symbol_of_prod_entry_key s) - | Amodifiers s -> - Gram.srules' - [([], Gram.action (fun _loc -> [])); - ([gram_token_of_string "("; - Symbols.slist1sep (symbol_of_prod_entry_key s, gram_token_of_string ","); - gram_token_of_string ")"], - Gram.action (fun _ l _ _loc -> l))] | Aself -> Symbols.sself | Anext -> Symbols.snext | Aentry e -> - let e = get_typed_entry e in - Symbols.snterm (Gram.Entry.obj (object_of_typed_entry e)) + let e = get_grammar e in + Symbols.snterm (Gram.Entry.obj (weaken_entry e)) | Aentryl (e, n) -> - let e = get_typed_entry e in - Symbols.snterml (Gram.Entry.obj (object_of_typed_entry e), string_of_int n) + let e = get_grammar e in + Symbols.snterml (Gram.Entry.obj (weaken_entry e), string_of_int n) + | Arules rs -> Gram.srules' (symbol_of_rules rs [] (fun x -> I0 x)) -let level_of_snterml e = int_of_string (Symbols.snterml_level e) - -let rec of_coq_rule : type self a r. (self, a, r) Extend.rule -> _ = function +and symbol_of_rule : type s a r. (s, a, r) Extend.rule -> _ = function | Stop -> fun accu -> accu -| Next (r, tok) -> fun accu -> - let symb = symbol_of_prod_entry_key tok in - of_coq_rule r (symb :: accu) +| Next (r, s) -> fun accu -> symbol_of_rule r (symbol_of_prod_entry_key s :: accu) + +and symbol_of_rules : type a. a Extend.rules -> _ = function +| Rule0 -> fun accu _ -> accu +| RuleS (r, e, rs) -> fun accu f -> + let symb = symbol_of_rule r [] in + let act = adj e [] f in + symbol_of_rules rs ((symb, act) :: accu) (fun x -> IS (f x)) + +let level_of_snterml e = int_of_string (Symbols.snterml_level e) let rec of_coq_action : type a r. (r, a, Loc.t -> r) Extend.rule -> a -> Gram.action = function | Stop -> fun f -> Gram.action (fun loc -> f (to_coqloc loc)) | Next (r, _) -> fun f -> Gram.action (fun x -> of_coq_action r (f x)) let of_coq_production_rule : type a. a Extend.production_rule -> _ = function -| Rule (toks, act) -> (of_coq_rule toks [], of_coq_action toks act) +| Rule (toks, act) -> (symbol_of_rule toks [], of_coq_action toks act) let of_coq_single_extend_statement (lvl, assoc, rule) = (lvl, Option.map of_coq_assoc assoc, List.map of_coq_production_rule rule) @@ -757,107 +723,47 @@ let grammar_extend e reinit ext = let ext = of_coq_extend_statement ext in unsafe_grammar_extend e reinit ext -(**********************************************************************) -(* Interpret entry names of the form "ne_constr_list" as entry keys *) - -let coincide s pat off = - let len = String.length pat in - let break = ref true in - let i = ref 0 in - while !break && !i < len do - let c = Char.code s.[off + !i] in - let d = Char.code pat.[!i] in - break := Int.equal c d; - incr i - done; - !break - -let tactic_level s = - if Int.equal (String.length s) 7 && coincide s "tactic" 0 then - let c = s.[6] in if '5' >= c && c >= '0' then Some (Char.code c - 48) - else None - else None - -let type_of_entry u s = - type_of_typed_entry (get_entry u s) - -let name_of_entry e = match String.split ':' (Gram.Entry.name e) with -| u :: s :: [] -> Entry.unsafe_of_name (u, s) -| _ -> assert false - -let atactic n = - if n = 5 then Aentry (name_of_entry Tactic.binder_tactic) - else Aentryl (name_of_entry Tactic.tactic_expr, n) - -let unsafe_of_genarg : argument_type -> 'a raw_abstract_argument_type = - (** FIXME *) - Obj.magic - -let try_get_entry u s = - (** Order the effects: type_of_entry can raise Not_found *) - let typ = type_of_entry u s in - let typ = unsafe_of_genarg typ in - EntryName (typ, Aentry (Entry.unsafe_of_name (Entry.univ_name u, s))) - -let wit_list : 'a raw_abstract_argument_type -> 'a list raw_abstract_argument_type = - fun t -> unsafe_of_genarg (ListArgType (unquote t)) - -let wit_opt : 'a raw_abstract_argument_type -> 'a option raw_abstract_argument_type = - fun t -> unsafe_of_genarg (OptArgType (unquote t)) - -type _ target = -| TgAny : 's target -| TgTactic : int -> Tacexpr.raw_tactic_expr target - -(** Quite ad-hoc *) -let get_tacentry (type s) (n : int) (t : s target) : s entry_name = match t with -| TgAny -> EntryName (rawwit wit_tactic, atactic n) -| TgTactic m -> - let check_lvl n = - Int.equal m n - && not (Int.equal m 5) (* Because tactic5 is at binder_tactic *) - && not (Int.equal m 0) (* Because tactic0 is at simple_tactic *) - in - if check_lvl n then EntryName (rawwit wit_tactic, Aself) - else if check_lvl (n + 1) then EntryName (rawwit wit_tactic, Anext) - else EntryName (rawwit wit_tactic, atactic n) - -let rec interp_entry_name static up_level s sep = - let l = String.length s in - if l > 8 && coincide s "ne_" 0 && coincide s "_list" (l - 5) then - let EntryName (t, g) = interp_entry_name static up_level (String.sub s 3 (l-8)) "" in - EntryName (wit_list t, Alist1 g) - else if l > 12 && coincide s "ne_" 0 && - coincide s "_list_sep" (l-9) then - let EntryName (t, g) = interp_entry_name static up_level (String.sub s 3 (l-12)) "" in - EntryName (wit_list t, Alist1sep (g,sep)) - else if l > 5 && coincide s "_list" (l-5) then - let EntryName (t, g) = interp_entry_name static up_level (String.sub s 0 (l-5)) "" in - EntryName (wit_list t, Alist0 g) - else if l > 9 && coincide s "_list_sep" (l-9) then - let EntryName (t, g) = interp_entry_name static up_level (String.sub s 0 (l-9)) "" in - EntryName (wit_list t, Alist0sep (g,sep)) - else if l > 4 && coincide s "_opt" (l-4) then - let EntryName (t, g) = interp_entry_name static up_level (String.sub s 0 (l-4)) "" in - EntryName (wit_opt t, Aopt g) - else if l > 5 && coincide s "_mods" (l-5) then - let EntryName (t, g) = interp_entry_name static up_level (String.sub s 0 (l-1)) "" in - EntryName (wit_list t, Amodifiers g) - else - let s = match s with "hyp" -> "var" | _ -> s in - match tactic_level s with - | Some n -> get_tacentry n up_level - | None -> - try try_get_entry uprim s with Not_found -> - try try_get_entry uconstr s with Not_found -> - try try_get_entry utactic s with Not_found -> - if static then - error ("Unknown entry "^s^".") - else - EntryName (unsafe_of_genarg (ExtraArgType s), Aentry (Entry.dynamic s)) +let name_of_entry e = Entry.unsafe_of_name (Gram.Entry.name e) let list_entry_names () = - let add_entry key (entry, _) accu = (key, entry) :: accu in + let add_entry key (TypedEntry (entry, _)) accu = (key, unquote entry) :: accu in let ans = Hashtbl.fold add_entry (get_utable uprim) [] in let ans = Hashtbl.fold add_entry (get_utable uconstr) ans in Hashtbl.fold add_entry (get_utable utactic) ans + +let epsilon_value f e = + let r = Rule (Next (Stop, e), fun x _ -> f x) in + let ext = of_coq_extend_statement (None, [None, None, [r]]) in + let entry = G.entry_create "epsilon" in + let () = maybe_uncurry (Gram.extend entry) ext in + try Some (parse_string entry "") with _ -> None + +(** Registering grammar of generic arguments *) + +let () = + let open Stdarg in + let open Constrarg in +(* Grammar.register0 wit_unit; *) +(* Grammar.register0 wit_bool; *) + Grammar.register0 wit_int (Prim.integer); + Grammar.register0 wit_string (Prim.string); + Grammar.register0 wit_pre_ident (Prim.preident); + Grammar.register0 wit_int_or_var (Tactic.int_or_var); + Grammar.register0 wit_intro_pattern (Tactic.simple_intropattern); + Grammar.register0 wit_ident (Prim.ident); + Grammar.register0 wit_var (Prim.var); + Grammar.register0 wit_ref (Prim.reference); + Grammar.register0 wit_quant_hyp (Tactic.quantified_hypothesis); + Grammar.register0 wit_sort (Constr.sort); + Grammar.register0 wit_constr (Constr.constr); + Grammar.register0 wit_constr_may_eval (Tactic.constr_may_eval); + Grammar.register0 wit_uconstr (Tactic.uconstr); + Grammar.register0 wit_open_constr (Tactic.open_constr); + Grammar.register0 wit_constr_with_bindings (Tactic.constr_with_bindings); + Grammar.register0 wit_bindings (Tactic.bindings); +(* Grammar.register0 wit_hyp_location_flag; *) + Grammar.register0 wit_red_expr (Tactic.red_expr); + Grammar.register0 wit_tactic (Tactic.tactic); + Grammar.register0 wit_ltac (Tactic.tactic); + Grammar.register0 wit_clause_dft_concl (Tactic.clause_dft_concl); + () diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index c224dbad9..afe888909 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -112,19 +112,6 @@ type gram_reinit = gram_assoc * gram_position dynamically interpreted as entries for the Coq level extensions *) -type ('self, 'a) entry_key = ('self, 'a) Extend.symbol = -| Atoken : Tok.t -> ('self, string) entry_key -| Alist1 : ('self, 'a) entry_key -> ('self, 'a list) entry_key -| Alist1sep : ('self, 'a) entry_key * string -> ('self, 'a list) entry_key -| Alist0 : ('self, 'a) entry_key -> ('self, 'a list) entry_key -| Alist0sep : ('self, 'a) entry_key * string -> ('self, 'a list) entry_key -| Aopt : ('self, 'a) entry_key -> ('self, 'a option) entry_key -| Amodifiers : ('self, 'a) entry_key -> ('self, 'a list) entry_key -| Aself : ('self, 'self) entry_key -| Anext : ('self, 'self) entry_key -| Aentry : 'a Entry.t -> ('self, 'a) entry_key -| Aentryl : 'a Entry.t * int -> ('self, 'a) entry_key - (** Add one extension at some camlp4 position of some camlp4 entry *) val unsafe_grammar_extend : grammar_object Gram.entry -> @@ -149,7 +136,7 @@ val parse_string : 'a Gram.entry -> string -> 'a val eoi_entry : 'a Gram.entry -> 'a Gram.entry val map_entry : ('a -> 'b) -> 'a Gram.entry -> 'b Gram.entry -type gram_universe = Entry.universe +type gram_universe val get_univ : string -> gram_universe @@ -158,8 +145,12 @@ val uconstr : gram_universe val utactic : gram_universe val uvernac : gram_universe -val create_generic_entry : string -> ('a, rlevel) abstract_argument_type -> - 'a Gram.entry +val set_grammar : 'a Entry.t -> 'a Gram.entry -> unit +val register_grammar : ('raw, 'glb, 'top) genarg_type -> 'raw Gram.entry -> unit +val genarg_grammar : ('raw, 'glb, 'top) genarg_type -> 'raw Gram.entry + +val create_generic_entry : gram_universe -> string -> + ('a, rlevel) abstract_argument_type -> 'a Gram.entry module Prim : sig @@ -169,10 +160,12 @@ module Prim : val ident : Id.t Gram.entry val name : Name.t located Gram.entry val identref : Id.t located Gram.entry + val pidentref : (Id.t located * (Id.t located list) option) Gram.entry val pattern_ident : Id.t Gram.entry val pattern_identref : Id.t located Gram.entry val base_ident : Id.t Gram.entry val natural : int Gram.entry + val index : int Gram.entry val bigint : Bigint.bigint Gram.entry val integer : int Gram.entry val string : string Gram.entry @@ -218,7 +211,7 @@ module Module : module Tactic : sig - val open_constr : open_constr_expr Gram.entry + val open_constr : constr_expr Gram.entry val constr_with_bindings : constr_expr with_bindings Gram.entry val bindings : constr_expr bindings Gram.entry val hypident : (Id.t located * Locus.hyp_location_flag) Gram.entry @@ -236,7 +229,6 @@ module Tactic : val binder_tactic : raw_tactic_expr Gram.entry val tactic : raw_tactic_expr Gram.entry val tactic_eoi : raw_tactic_expr Gram.entry - val tacdef_body : (reference * bool * raw_tactic_expr) Gram.entry end module Vernac_ : @@ -248,17 +240,23 @@ module Vernac_ : val vernac : vernac_expr Gram.entry val rec_definition : (fixpoint_expr * decl_notation list) Gram.entry val vernac_eoi : vernac_expr Gram.entry + val noedit_mode : vernac_expr Gram.entry + val command_entry : vernac_expr Gram.entry end (** The main entry: reads an optional vernac command *) val main_entry : (Loc.t * vernac_expr) option Gram.entry +(** Handling of the proof mode entry *) +val get_command_entry : unit -> vernac_expr Gram.entry +val set_command_entry : vernac_expr Gram.entry -> unit + (** Mapping formal entries into concrete ones *) (** Binding constr entry keys to entries and symbols *) val interp_constr_entry_key : bool (** true for cases_pattern *) -> - constr_entry_key -> grammar_object Gram.entry * int option + int -> grammar_object Gram.entry * int option val symbol_of_constr_prod_entry_key : gram_assoc option -> constr_entry_key -> bool -> constr_prod_entry_key -> @@ -266,20 +264,13 @@ val symbol_of_constr_prod_entry_key : gram_assoc option -> val name_of_entry : 'a Gram.entry -> 'a Entry.t -(** Binding general entry keys to symbols *) +val epsilon_value : ('a -> 'self) -> ('self, 'a) Extend.symbol -> 'self option -val symbol_of_prod_entry_key : - ('self, 'a) entry_key -> Gram.symbol - -type 's entry_name = EntryName : - 'a raw_abstract_argument_type * ('s, 'a) entry_key -> 's entry_name - -(** Interpret entry names of the form "ne_constr_list" as entry keys *) +(** Binding general entry keys to symbols *) -type _ target = TgAny : 's target | TgTactic : int -> raw_tactic_expr target +type typed_entry = TypedEntry : 'a raw_abstract_argument_type * 'a Gram.entry -> typed_entry -val interp_entry_name : bool (** true to fail on unknown entry *) -> - 's target -> string -> string -> 's entry_name +val get_entry : gram_universe -> string -> typed_entry (** Recover the list of all known tactic notation entries. *) val list_entry_names : unit -> (string * argument_type) list diff --git a/parsing/tok.ml b/parsing/tok.ml index efd57968d..df7e7c2a6 100644 --- a/parsing/tok.ml +++ b/parsing/tok.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,28 +8,31 @@ (** The type of token for the Coq lexer and parser *) +let string_equal (s1 : string) s2 = s1 = s2 + type t = | KEYWORD of string - | METAIDENT of string | PATTERNIDENT of string | IDENT of string | FIELD of string | INT of string + | INDEX of string | STRING of string | LEFTQMARK | BULLET of string | EOI let equal t1 t2 = match t1, t2 with -| KEYWORD s1, KEYWORD s2 -> CString.equal s1 s2 -| METAIDENT s1, METAIDENT s2 -> CString.equal s1 s2 -| PATTERNIDENT s1, PATTERNIDENT s2 -> CString.equal s1 s2 -| IDENT s1, IDENT s2 -> CString.equal s1 s2 -| FIELD s1, FIELD s2 -> CString.equal s1 s2 -| INT s1, INT s2 -> CString.equal s1 s2 -| STRING s1, STRING s2 -> CString.equal s1 s2 +| IDENT s1, KEYWORD s2 -> string_equal s1 s2 +| KEYWORD s1, KEYWORD s2 -> string_equal s1 s2 +| PATTERNIDENT s1, PATTERNIDENT s2 -> string_equal s1 s2 +| IDENT s1, IDENT s2 -> string_equal s1 s2 +| FIELD s1, FIELD s2 -> string_equal s1 s2 +| INT s1, INT s2 -> string_equal s1 s2 +| INDEX s1, INDEX s2 -> string_equal s1 s2 +| STRING s1, STRING s2 -> string_equal s1 s2 | LEFTQMARK, LEFTQMARK -> true -| BULLET s1, BULLET s2 -> CString.equal s1 s2 +| BULLET s1, BULLET s2 -> string_equal s1 s2 | EOI, EOI -> true | _ -> false @@ -37,10 +40,10 @@ let extract_string = function | KEYWORD s -> s | IDENT s -> s | STRING s -> s - | METAIDENT s -> s | PATTERNIDENT s -> s | FIELD s -> s | INT s -> s + | INDEX s -> s | LEFTQMARK -> "?" | BULLET s -> s | EOI -> "" @@ -48,10 +51,10 @@ let extract_string = function let to_string = function | KEYWORD s -> Format.sprintf "%S" s | IDENT s -> Format.sprintf "IDENT %S" s - | METAIDENT s -> Format.sprintf "METAIDENT %S" s | PATTERNIDENT s -> Format.sprintf "PATTERNIDENT %S" s | FIELD s -> Format.sprintf "FIELD %S" s | INT s -> Format.sprintf "INT %s" s + | INDEX s -> Format.sprintf "INDEX %s" s | STRING s -> Format.sprintf "STRING %S" s | LEFTQMARK -> "LEFTQMARK" | BULLET s -> Format.sprintf "STRING %S" s @@ -71,10 +74,10 @@ let print ppf tok = Format.pp_print_string ppf (to_string tok) let of_pattern = function | "", s -> KEYWORD s | "IDENT", s -> IDENT s - | "METAIDENT", s -> METAIDENT s | "PATTERNIDENT", s -> PATTERNIDENT s | "FIELD", s -> FIELD s | "INT", s -> INT s + | "INDEX", s -> INDEX s | "STRING", s -> STRING s | "LEFTQMARK", _ -> LEFTQMARK | "BULLET", s -> BULLET s @@ -84,10 +87,10 @@ let of_pattern = function let to_pattern = function | KEYWORD s -> "", s | IDENT s -> "IDENT", s - | METAIDENT s -> "METAIDENT", s | PATTERNIDENT s -> "PATTERNIDENT", s | FIELD s -> "FIELD", s | INT s -> "INT", s + | INDEX s -> "INDEX", s | STRING s -> "STRING", s | LEFTQMARK -> "LEFTQMARK", "" | BULLET s -> "BULLET", s @@ -98,10 +101,10 @@ let match_pattern = function | "", "" -> (function KEYWORD s -> s | _ -> err ()) | "IDENT", "" -> (function IDENT s -> s | _ -> err ()) - | "METAIDENT", "" -> (function METAIDENT s -> s | _ -> err ()) | "PATTERNIDENT", "" -> (function PATTERNIDENT s -> s | _ -> err ()) | "FIELD", "" -> (function FIELD s -> s | _ -> err ()) | "INT", "" -> (function INT s -> s | _ -> err ()) + | "INDEX", "" -> (function INDEX s -> s | _ -> err ()) | "STRING", "" -> (function STRING s -> s | _ -> err ()) | "LEFTQMARK", "" -> (function LEFTQMARK -> "" | _ -> err ()) | "BULLET", "" -> (function BULLET s -> s | _ -> err ()) diff --git a/parsing/tok.mli b/parsing/tok.mli index feee1983d..54b747952 100644 --- a/parsing/tok.mli +++ b/parsing/tok.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -10,16 +10,17 @@ type t = | KEYWORD of string - | METAIDENT of string | PATTERNIDENT of string | IDENT of string | FIELD of string | INT of string + | INDEX of string | STRING of string | LEFTQMARK | BULLET of string | EOI +val equal : t -> t -> bool val extract_string : t -> string val to_string : t -> string (* Needed to fit Camlp4 signature *) diff --git a/plugins/btauto/g_btauto.ml4 b/plugins/btauto/g_btauto.ml4 index 8e00b1c13..f3e2c99f4 100644 --- a/plugins/btauto/g_btauto.ml4 +++ b/plugins/btauto/g_btauto.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index 5a49fc8f4..aee0bd856 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -12,7 +12,7 @@ let get_constant dir s = lazy (Coqlib.gen_constant contrib_name dir s) let get_inductive dir s = let glob_ref () = Coqlib.find_reference contrib_name ("Coq" :: dir) s in - Lazy.lazy_from_fun (fun () -> Globnames.destIndRef (glob_ref ())) + Lazy.from_fun (fun () -> Globnames.destIndRef (glob_ref ())) let decomp_term (c : Term.constr) = Term.kind_of_term (Term.strip_outer_cast c) @@ -250,7 +250,7 @@ module Btauto = struct Tacticals.New.tclTHENLIST [ Tactics.change_concl changed_gl; Tactics.apply (Lazy.force soundness); - Proofview.V82.tactic (Tactics.normalise_vm_in_concl); + Tactics.normalise_vm_in_concl; try_unification env ] | _ -> diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index 97ea5fdc5..359157a4c 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -824,7 +824,7 @@ let __eps__ = Id.of_string "_eps_" let new_state_var typ state = let id = pf_get_new_id __eps__ state.gls in let {it=gl ; sigma=sigma} = state.gls in - let gls = Goal.V82.new_goal_with sigma gl [id,None,typ] in + let gls = Goal.V82.new_goal_with sigma gl [Context.Named.Declaration.LocalAssum (id,typ)] in state.gls<- gls; id diff --git a/plugins/cc/ccalgo.mli b/plugins/cc/ccalgo.mli index 0dcf3a870..b73c8eef8 100644 --- a/plugins/cc/ccalgo.mli +++ b/plugins/cc/ccalgo.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -20,8 +20,8 @@ type pa_fun= fnargs:int} -module PafMap : Map.S with type key = pa_fun -module PacMap : Map.S with type key = pa_constructor +module PafMap : CSig.MapS with type key = pa_fun +module PacMap : CSig.MapS with type key = pa_constructor type cinfo = {ci_constr: pconstructor; (* inductive type *) @@ -185,7 +185,7 @@ val empty_forest: unit -> forest (*type pa_constructor -module PacMap:Map.S with type key=pa_constructor +module PacMap:CSig.MapS with type key=pa_constructor type term = Symb of Term.constr diff --git a/plugins/cc/ccproof.ml b/plugins/cc/ccproof.ml index 42c03234b..c188bf3bc 100644 --- a/plugins/cc/ccproof.ml +++ b/plugins/cc/ccproof.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/cc/ccproof.mli b/plugins/cc/ccproof.mli index 2ff2bd387..eacbfeac7 100644 --- a/plugins/cc/ccproof.mli +++ b/plugins/cc/ccproof.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 8c15f54af..a1aff12d4 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -23,6 +23,7 @@ open Pp open Errors open Util open Proofview.Notations +open Context.Rel.Declaration let reference dir s = lazy (Coqlib.gen_reference "CC" dir s) @@ -47,7 +48,7 @@ let whd_delta env= (* decompose member of equality in an applicative format *) (** FIXME: evar leak *) -let sf_of env sigma c = sort_of env (ref sigma) c +let sf_of env sigma c = e_sort_of env (ref sigma) c let rec decompose_term env sigma t= match kind_of_term (whd env t) with @@ -152,7 +153,7 @@ let rec quantified_atom_of_constr env sigma nrels term = let patts=patterns_of_constr env sigma nrels atom in `Nrule patts else - quantified_atom_of_constr (Environ.push_rel (id,None,atom) env) sigma (succ nrels) ff + quantified_atom_of_constr (Environ.push_rel (LocalAssum (id,atom)) env) sigma (succ nrels) ff | _ -> let patts=patterns_of_constr env sigma nrels term in `Rule patts @@ -167,7 +168,7 @@ let litteral_of_constr env sigma term= else begin try - quantified_atom_of_constr (Environ.push_rel (id,None,atom) env) sigma 1 ff + quantified_atom_of_constr (Environ.push_rel (LocalAssum (id,atom)) env) sigma 1 ff with Not_found -> `Other (decompose_term env sigma term) end @@ -188,7 +189,8 @@ let make_prb gls depth additionnal_terms = let t = decompose_term env sigma c in ignore (add_term state t)) additionnal_terms; List.iter - (fun (id,_,e) -> + (fun decl -> + let (id,_,e) = Context.Named.Declaration.to_tuple decl in begin let cid=mkVar id in match litteral_of_constr env sigma e with @@ -221,24 +223,9 @@ let make_prb gls depth additionnal_terms = (* indhyps builds the array of arrays of constructor hyps for (ind largs) *) -let build_projection intype outtype (cstr:pconstructor) special default gls= - let env=pf_env gls in - let (h,argv) = try destApp intype with DestKO -> (intype,[||]) in - let ind,u=destInd h in - let types=Inductiveops.arities_of_constructors env (ind,u) in - let lp=Array.length types in - let ci=pred (snd(fst cstr)) in - let branch i= - let ti= prod_appvect types.(i) argv in - let rc=fst (decompose_prod_assum ti) in - let head= - if Int.equal i ci then special else default in - it_mkLambda_or_LetIn head rc in - let branches=Array.init lp branch in - let casee=mkRel 1 in - let pred=mkLambda(Anonymous,intype,outtype) in - let case_info=make_case_info (pf_env gls) ind RegularStyle in - let body= mkCase(case_info, pred, casee, branches) in +let build_projection intype (cstr:pconstructor) special default gls= + let ci= (snd(fst cstr)) in + let body=Equality.build_selector (pf_env gls) (project gls) ci (mkRel 1) intype special default in let id=pf_get_new_id (Id.of_string "t") gls in mkLambda(Name id,intype,body) @@ -320,7 +307,7 @@ let rec proof_tac p : unit Proofview.tactic = let outtype = (* Termops.refresh_universes *) (type_of default) in let special=mkRel (1+nargs-argind) in let proj = - Tacmach.New.of_old (build_projection intype outtype cstr special default) gl + Tacmach.New.of_old (build_projection intype cstr special default) gl in let injt= app_global _f_equal [|intype;outtype;proj;ti;tj;_M 1|] in @@ -389,7 +376,7 @@ let discriminate_tac (cstr,u as cstru) p = let outtype = mkSort outtype in let pred=mkLambda(Name xid,outtype,mkRel 1) in let hid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "Heq")) gl in - let proj = Tacmach.New.of_old (build_projection intype outtype cstru trivial concl) gl in + let proj = Tacmach.New.of_old (build_projection intype cstru trivial concl) gl in let injt=app_global _f_equal [|intype;outtype;proj;t1;t2;mkVar hid|] in let endt k = @@ -501,9 +488,9 @@ let f_equal = let concl = Proofview.Goal.concl gl in let cut_eq c1 c2 = try (* type_of can raise an exception *) - Tacticals.New.tclTHEN + Tacticals.New.tclTHENS (mk_eq _eq c1 c2 Tactics.cut) - (Tacticals.New.tclTRY ((new_app_global _refl_equal [||]) apply)) + [Proofview.tclUNIT ();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/cc/g_congruence.ml4 b/plugins/cc/g_congruence.ml4 index aa31c6f07..9a53e2e16 100644 --- a/plugins/cc/g_congruence.ml4 +++ b/plugins/cc/g_congruence.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -9,6 +9,10 @@ (*i camlp4deps: "grammar/grammar.cma" i*) open Cctac +open Stdarg +open Constrarg +open Pcoq.Prim +open Pcoq.Constr DECLARE PLUGIN "cc_plugin" diff --git a/plugins/decl_mode/decl_expr.mli b/plugins/decl_mode/decl_expr.mli index 3c4cacbc5..9d78a51ef 100644 --- a/plugins/decl_mode/decl_expr.mli +++ b/plugins/decl_mode/decl_expr.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -99,4 +99,4 @@ type proof_instr = (Term.constr statement, Term.constr, proof_pattern, - Tacexpr.glob_tactic_expr) gen_proof_instr + Genarg.Val.t) gen_proof_instr diff --git a/plugins/decl_mode/decl_interp.ml b/plugins/decl_mode/decl_interp.ml index 1c56586ce..34307a358 100644 --- a/plugins/decl_mode/decl_interp.ml +++ b/plugins/decl_mode/decl_interp.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -96,7 +96,7 @@ let rec add_vars_of_simple_pattern globs = function add_vars_of_simple_pattern globs p | CPatCstr (_,_,pl1,pl2) -> List.fold_left add_vars_of_simple_pattern - (List.fold_left add_vars_of_simple_pattern globs pl1) pl2 + (Option.fold_left (List.fold_left add_vars_of_simple_pattern) globs pl1) pl2 | CPatNotation(_,_,(pl,pll),pl') -> List.fold_left add_vars_of_simple_pattern globs (List.flatten (pl::pl'::pll)) | CPatAtom (_,Some (Libnames.Ident (_,id))) -> add_var id globs @@ -384,7 +384,7 @@ let interp_cases info env sigma params (pat:cases_pattern_expr) hyps = let interp_cut interp_it env sigma cut= let nenv,nstat = interp_it env sigma cut.cut_stat in - {cut with + { cut_using=Option.map (Tacinterp.Value.of_closure (Tacinterp.default_ist ())) cut.cut_using; cut_stat=nstat; cut_by=interp_justification_items nenv sigma cut.cut_by} @@ -403,7 +403,7 @@ let interp_suffices_clause env sigma (hyps,cot)= match hyp with (Hprop st | Hvar st) -> match st.st_label with - Name id -> Environ.push_named (id,None,st.st_it) env0 + Name id -> Environ.push_named (Context.Named.Declaration.LocalAssum (id,st.st_it)) env0 | _ -> env in let nenv = List.fold_right push_one locvars env in nenv,res diff --git a/plugins/decl_mode/decl_interp.mli b/plugins/decl_mode/decl_interp.mli index b3d6f82bd..4303ecdb4 100644 --- a/plugins/decl_mode/decl_interp.mli +++ b/plugins/decl_mode/decl_interp.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/decl_mode/decl_mode.ml b/plugins/decl_mode/decl_mode.ml index 774c20c9a..f9399d682 100644 --- a/plugins/decl_mode/decl_mode.ml +++ b/plugins/decl_mode/decl_mode.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -116,7 +116,7 @@ let get_top_stack pts = let get_stack pts = Proof.get_at_focus proof_focus pts let get_last env = match Environ.named_context env with - | (id,_,_)::_ -> id + | decl :: _ -> Context.Named.Declaration.get_id decl | [] -> error "no previous statement to use" diff --git a/plugins/decl_mode/decl_mode.mli b/plugins/decl_mode/decl_mode.mli index fd7e15c15..dfeee833c 100644 --- a/plugins/decl_mode/decl_mode.mli +++ b/plugins/decl_mode/decl_mode.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml index 1741df533..090b293f5 100644 --- a/plugins/decl_mode/decl_proof_instr.ml +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -30,6 +30,7 @@ open Namegen open Goptions open Misctypes open Sigma.Notations +open Context.Named.Declaration (* Strictness option *) @@ -229,7 +230,8 @@ let close_previous_case pts = (* automation *) let filter_hyps f gls = - let filter_aux (id,_,_) = + let filter_aux id = + let id = get_id id in if f id then tclIDTAC else @@ -331,11 +333,12 @@ let enstack_subsubgoals env se stack gls= let rc,_ = Reduction.dest_prod env apptype in let rec meta_aux last lenv = function [] -> (last,lenv,[]) - | (nam,_,typ)::q -> + | decl::q -> let nlast=succ last in let (llast,holes,metas) = meta_aux nlast (mkMeta nlast :: lenv) q in - (llast,holes,(nlast,special_nf gls (substl lenv typ))::metas) in + let open Context.Rel.Declaration in + (llast,holes,(nlast,special_nf gls (substl lenv (get_type decl)))::metas) in let (nlast,holes,nmetas) = meta_aux se.se_last_meta [] (List.rev rc) in let refiner = applist (appterm,List.rev holes) in @@ -404,15 +407,15 @@ let concl_refiner metas body gls = let concl = pf_concl gls in let evd = sig_sig gls in let env = pf_env gls in - let sort = family_of_sort (Typing.sort_of env (ref evd) concl) in + let sort = family_of_sort (Typing.e_sort_of env (ref evd) concl) in let rec aux env avoid subst = function [] -> anomaly ~label:"concl_refiner" (Pp.str "cannot happen") | (n,typ)::rest -> let _A = subst_meta subst typ in let x = id_of_name_using_hdchar env _A Anonymous in let _x = fresh_id avoid x gls in - let nenv = Environ.push_named (_x,None,_A) env in - let asort = family_of_sort (Typing.sort_of nenv (ref evd) _A) in + let nenv = Environ.push_named (LocalAssum (_x,_A)) env in + let asort = family_of_sort (Typing.e_sort_of nenv (ref evd) _A) in let nsubst = (n,mkVar _x)::subst in if List.is_empty rest then asort,_A,mkNamedLambda _x _A (subst_meta nsubst body) @@ -493,7 +496,7 @@ let just_tac _then cut info gls0 = None -> Proofview.V82.of_tactic automation_tac gls | Some tac -> - Proofview.V82.of_tactic (Tacinterp.eval_tactic tac) gls in + Proofview.V82.of_tactic (Tacinterp.tactic_of_value (Tacinterp.default_ist ()) tac) gls in justification (tclTHEN items_tac method_tac) gls0 let instr_cut mkstat _thus _then cut gls0 = @@ -543,7 +546,7 @@ let instr_rew _thus rew_side cut gls0 = None -> Proofview.V82.of_tactic automation_tac gls | Some tac -> - Proofview.V82.of_tactic (Tacinterp.eval_tactic tac) gls in + Proofview.V82.of_tactic (Tacinterp.tactic_of_value (Tacinterp.default_ist ()) tac) gls in let just_tac gls = justification (tclTHEN items_tac method_tac) gls in let (c_id,_) = match cut.cut_stat.st_label with @@ -606,7 +609,7 @@ let assume_tac hyps gls = tclTHEN (push_intro_tac (fun id -> - Proofview.V82.of_tactic (convert_hyp (id,None,st.st_it))) st.st_label)) + Proofview.V82.of_tactic (convert_hyp (LocalAssum (id,st.st_it)))) st.st_label)) hyps tclIDTAC gls let assume_hyps_or_theses hyps gls = @@ -616,7 +619,7 @@ let assume_hyps_or_theses hyps gls = tclTHEN (push_intro_tac (fun id -> - Proofview.V82.of_tactic (convert_hyp (id,None,c))) nam) + Proofview.V82.of_tactic (convert_hyp (LocalAssum (id,c)))) nam) | Hprop {st_label=nam;st_it=Thesis (tk)} -> tclTHEN (push_intro_tac @@ -628,7 +631,7 @@ let assume_st hyps gls = (fun st -> tclTHEN (push_intro_tac - (fun id -> Proofview.V82.of_tactic (convert_hyp (id,None,st.st_it))) st.st_label)) + (fun id -> Proofview.V82.of_tactic (convert_hyp (LocalAssum (id,st.st_it)))) st.st_label)) hyps tclIDTAC gls let assume_st_letin hyps gls = @@ -637,7 +640,7 @@ let assume_st_letin hyps gls = tclTHEN (push_intro_tac (fun id -> - Proofview.V82.of_tactic (convert_hyp (id,Some (fst st.st_it),snd st.st_it))) st.st_label)) + Proofview.V82.of_tactic (convert_hyp (LocalDef (id, fst st.st_it, snd st.st_it)))) st.st_label)) hyps tclIDTAC gls (* suffices *) @@ -731,7 +734,7 @@ let rec consider_match may_intro introduced available expected gls = error "Not enough sub-hypotheses to match statements." (* should tell which ones *) | id::rest_ids,(Hvar st | Hprop st)::rest -> - tclIFTHENELSE (Proofview.V82.of_tactic (convert_hyp (id,None,st.st_it))) + tclIFTHENELSE (Proofview.V82.of_tactic (convert_hyp (LocalAssum (id,st.st_it)))) begin match st.st_label with Anonymous -> @@ -799,8 +802,8 @@ let define_tac id args body gls = let cast_tac id_or_thesis typ gls = match id_or_thesis with This id -> - let (_,body,_) = pf_get_hyp gls id in - Proofview.V82.of_tactic (convert_hyp (id,body,typ)) gls + let body = pf_get_hyp gls id |> get_value in + Proofview.V82.of_tactic (convert_hyp (of_tuple (id,body,typ))) gls | Thesis (For _ ) -> error "\"thesis for ...\" is not applicable here." | Thesis Plain -> diff --git a/plugins/decl_mode/decl_proof_instr.mli b/plugins/decl_mode/decl_proof_instr.mli index f86bfea71..325969dad 100644 --- a/plugins/decl_mode/decl_proof_instr.mli +++ b/plugins/decl_mode/decl_proof_instr.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/decl_mode/g_decl_mode.ml4 b/plugins/decl_mode/g_decl_mode.ml4 index d598e7c3f..a438ca79f 100644 --- a/plugins/decl_mode/g_decl_mode.ml4 +++ b/plugins/decl_mode/g_decl_mode.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -87,7 +87,7 @@ let vernac_proof_instr instr = (* Only declared at raw level, because only used in vernac commands. *) let wit_proof_instr : (raw_proof_instr, glob_proof_instr, proof_instr) Genarg.genarg_type = - Genarg.make0 None "proof_instr" + Genarg.make0 "proof_instr" (* We create a new parser entry [proof_mode]. The Declarative proof mode will replace the normal parser entry for tactics with this one. *) @@ -95,7 +95,7 @@ let proof_mode : vernac_expr Gram.entry = Gram.entry_create "vernac:proof_command" (* Auxiliary grammar entry. *) let proof_instr : raw_proof_instr Gram.entry = - Pcoq.create_generic_entry "proof_instr" (Genarg.rawwit wit_proof_instr) + Pcoq.create_generic_entry Pcoq.utactic "proof_instr" (Genarg.rawwit wit_proof_instr) let _ = Pptactic.declare_extra_genarg_pprule wit_proof_instr pr_raw_proof_instr pr_glob_proof_instr pr_proof_instr @@ -135,7 +135,7 @@ let _ = set = begin fun () -> (* We set the command non terminal to [proof_mode] (which we just defined). *) - G_vernac.set_command_entry proof_mode ; + Pcoq.set_command_entry proof_mode ; (* We substitute the goal printer, by the one we built for the proof mode. *) Printer.set_printer_pr { Printer.default_printer_pr with @@ -147,7 +147,7 @@ let _ = reset = begin fun () -> (* We restore the command non terminal to [noedit_mode]. *) - G_vernac.set_command_entry G_vernac.noedit_mode ; + Pcoq.set_command_entry Pcoq.Vernac_.noedit_mode ; (* We restore the goal printer to default *) Printer.set_printer_pr Printer.default_printer_pr end diff --git a/plugins/decl_mode/ppdecl_proof.ml b/plugins/decl_mode/ppdecl_proof.ml index b3198dbf2..4c71f0410 100644 --- a/plugins/decl_mode/ppdecl_proof.ml +++ b/plugins/decl_mode/ppdecl_proof.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml index 96d5279a7..5d1551106 100644 --- a/plugins/derive/derive.ml +++ b/plugins/derive/derive.ml @@ -1,13 +1,15 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -let map_const_entry_body (f:Term.constr->Term.constr) (x:Entries.const_entry_body) - : Entries.const_entry_body = +open Context.Named.Declaration + +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 @@ -32,7 +34,7 @@ let start_deriving f suchthat lemma = let open Proofview in TCons ( env , sigma , f_type_type , (fun sigma f_type -> TCons ( env , sigma , f_type , (fun sigma ef -> - let env' = Environ.push_named (f , (Some ef) , f_type) env in + let env' = Environ.push_named (LocalDef (f, ef, f_type)) env in let evdref = ref sigma in let suchthat = Constrintern.interp_type_evars env' evdref suchthat in TCons ( env' , !evdref , suchthat , (fun sigma _ -> diff --git a/plugins/derive/derive.mli b/plugins/derive/derive.mli index b49ef6b93..9ea876f13 100644 --- a/plugins/derive/derive.mli +++ b/plugins/derive/derive.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/derive/g_derive.ml4 b/plugins/derive/g_derive.ml4 index c031e3bcf..35a5a7616 100644 --- a/plugins/derive/g_derive.ml4 +++ b/plugins/derive/g_derive.ml4 @@ -1,11 +1,15 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Constrarg +open Pcoq.Prim +open Pcoq.Constr + (*i camlp4deps: "grammar/grammar.cma" i*) let classify_derive_command _ = Vernacexpr.(VtStartProof ("Classic",Doesn'tGuaranteeOpacity,[]),VtLater) diff --git a/plugins/extraction/ExtrOcamlBasic.v b/plugins/extraction/ExtrOcamlBasic.v index 9dbda8216..d9b000c2a 100644 --- a/plugins/extraction/ExtrOcamlBasic.v +++ b/plugins/extraction/ExtrOcamlBasic.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/extraction/ExtrOcamlBigIntConv.v b/plugins/extraction/ExtrOcamlBigIntConv.v index 4cc76d86f..c42938c8e 100644 --- a/plugins/extraction/ExtrOcamlBigIntConv.v +++ b/plugins/extraction/ExtrOcamlBigIntConv.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/extraction/ExtrOcamlIntConv.v b/plugins/extraction/ExtrOcamlIntConv.v index eb43d69fe..515fa52df 100644 --- a/plugins/extraction/ExtrOcamlIntConv.v +++ b/plugins/extraction/ExtrOcamlIntConv.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/extraction/ExtrOcamlNatBigInt.v b/plugins/extraction/ExtrOcamlNatBigInt.v index 1386c2ad5..3149e7029 100644 --- a/plugins/extraction/ExtrOcamlNatBigInt.v +++ b/plugins/extraction/ExtrOcamlNatBigInt.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/extraction/ExtrOcamlNatInt.v b/plugins/extraction/ExtrOcamlNatInt.v index a0930f15f..7c607f7ae 100644 --- a/plugins/extraction/ExtrOcamlNatInt.v +++ b/plugins/extraction/ExtrOcamlNatInt.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/extraction/ExtrOcamlString.v b/plugins/extraction/ExtrOcamlString.v index ce8025bfb..6af591eed 100644 --- a/plugins/extraction/ExtrOcamlString.v +++ b/plugins/extraction/ExtrOcamlString.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/extraction/ExtrOcamlZBigInt.v b/plugins/extraction/ExtrOcamlZBigInt.v index 3d59669a9..9a1a4aa01 100644 --- a/plugins/extraction/ExtrOcamlZBigInt.v +++ b/plugins/extraction/ExtrOcamlZBigInt.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/extraction/ExtrOcamlZInt.v b/plugins/extraction/ExtrOcamlZInt.v index 79d674955..4d33174b3 100644 --- a/plugins/extraction/ExtrOcamlZInt.v +++ b/plugins/extraction/ExtrOcamlZInt.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/extraction/big.ml b/plugins/extraction/big.ml index f2a965c90..44b81d762 100644 --- a/plugins/extraction/big.ml +++ b/plugins/extraction/big.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml index 97f856944..bb9e8e5f5 100644 --- a/plugins/extraction/common.ml +++ b/plugins/extraction/common.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -171,10 +171,7 @@ let push_vars ids (db,avoid) = let ids',avoid' = rename_vars avoid ids in ids', (ids' @ db, avoid') -let get_db_name n (db,_) = - let id = List.nth db (pred n) in - if Id.equal id dummy_name then Id.of_string "__" else id - +let get_db_name n (db,_) = List.nth db (pred n) (*S Renamings of global objects. *) diff --git a/plugins/extraction/common.mli b/plugins/extraction/common.mli index a8ab4fd3c..2f5601964 100644 --- a/plugins/extraction/common.mli +++ b/plugins/extraction/common.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 0f846013b..41a068ff3 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -78,56 +78,51 @@ module type VISIT = sig (* Add reference / ... in the visit lists. These functions silently add the mp of their arg in the mp list *) val add_ref : global_reference -> unit + val add_kn : kernel_name -> unit val add_decl_deps : ml_decl -> unit val add_spec_deps : ml_spec -> unit (* Test functions: is a particular object a needed dependency for the current extraction ? *) val needed_ind : mutual_inductive -> bool - val needed_con : constant -> bool + val needed_cst : constant -> bool val needed_mp : module_path -> bool val needed_mp_all : module_path -> bool end module Visit : VISIT = struct type must_visit = - { mutable ind : KNset.t; mutable con : KNset.t; - mutable mp : MPset.t; mutable mp_all : MPset.t } + { mutable kn : KNset.t; + mutable mp : MPset.t; + mutable mp_all : MPset.t } (* the imperative internal visit lists *) - let v = { ind = KNset.empty ; con = KNset.empty ; - mp = MPset.empty; mp_all = MPset.empty } + let v = { kn = KNset.empty; mp = MPset.empty; mp_all = MPset.empty } (* the accessor functions *) let reset () = - v.ind <- KNset.empty; - v.con <- KNset.empty; + v.kn <- KNset.empty; v.mp <- MPset.empty; v.mp_all <- MPset.empty - let needed_ind i = KNset.mem (user_mind i) v.ind - let needed_con c = KNset.mem (user_con c) v.con + let needed_ind i = KNset.mem (user_mind i) v.kn + let needed_cst c = KNset.mem (user_con c) v.kn let needed_mp mp = MPset.mem mp v.mp || MPset.mem mp v.mp_all let needed_mp_all mp = MPset.mem mp v.mp_all let add_mp mp = check_loaded_modfile mp; v.mp <- MPset.union (prefixes_mp mp) v.mp let add_mp_all mp = - check_loaded_modfile mp; v.mp <- MPset.union (prefixes_mp mp) v.mp; + check_loaded_modfile mp; + v.mp <- MPset.union (prefixes_mp mp) v.mp; v.mp_all <- MPset.add mp v.mp_all - let add_ind i = - let kn = user_mind i in - v.ind <- KNset.add kn v.ind; add_mp (modpath kn) - let add_con c = - let kn = user_con c in - v.con <- KNset.add kn v.con; add_mp (modpath kn) + let add_kn kn = v.kn <- KNset.add kn v.kn; add_mp (modpath kn) let add_ref = function - | ConstRef c -> add_con c - | IndRef (ind,_) | ConstructRef ((ind,_),_) -> add_ind ind + | ConstRef c -> add_kn (user_con c) + | IndRef (ind,_) | ConstructRef ((ind,_),_) -> add_kn (user_mind ind) | VarRef _ -> assert false let add_decl_deps = decl_iter_references add_ref add_ref add_ref let add_spec_deps = spec_iter_references add_ref add_ref add_ref end let add_field_label mp = function - | (lab, SFBconst _) -> Visit.add_ref (ConstRef (Constant.make2 mp lab)) - | (lab, SFBmind _) -> Visit.add_ref (IndRef (MutInd.make2 mp lab, 0)) + | (lab, (SFBconst _|SFBmind _)) -> Visit.add_kn (KerName.make2 mp lab) | (lab, (SFBmodule _|SFBmodtype _)) -> Visit.add_mp_all (MPdot (mp,lab)) let rec add_labels mp = function @@ -182,8 +177,7 @@ let factor_fix env l cb msb = let expand_mexpr env mp me = let inl = Some (Flags.get_inline_level()) in - let sign,_,_,_ = Mod_typing.translate_mse env (Some mp) inl me in - sign + Mod_typing.translate_mse env (Some mp) inl me (** Ad-hoc update of environment, inspired by [Mod_type.check_with_aux_def]. To check with Elie. *) @@ -193,45 +187,52 @@ let rec mp_of_mexpr = function | MEwith (seb,_) -> mp_of_mexpr seb | _ -> assert false +let no_delta = Mod_subst.empty_delta_resolver + let env_for_mtb_with_def env mp me idl = let struc = Modops.destr_nofunctor me in let l = Label.of_id (List.hd idl) in let spot = function (l',SFBconst _) -> Label.equal l l' | _ -> false in let before = fst (List.split_when spot struc) in - Modops.add_structure mp before empty_delta_resolver env + Modops.add_structure mp before no_delta env + +let make_cst resolver mp l = + Mod_subst.constant_of_delta_kn resolver (KerName.make2 mp l) + +let make_mind resolver mp l = + Mod_subst.mind_of_delta_kn resolver (KerName.make2 mp l) (* From a [structure_body] (i.e. a list of [structure_field_body]) to specifications. *) -let rec extract_structure_spec env mp = function +let rec extract_structure_spec env mp reso = function | [] -> [] | (l,SFBconst cb) :: msig -> - let kn = Constant.make2 mp l in - let s = extract_constant_spec env kn cb in - let specs = extract_structure_spec env mp msig in + let c = make_cst reso mp l in + let s = extract_constant_spec env c cb in + let specs = extract_structure_spec env mp reso msig in if logical_spec s then specs else begin Visit.add_spec_deps s; (l,Spec s) :: specs end | (l,SFBmind _) :: msig -> - let mind = MutInd.make2 mp l in + let mind = make_mind reso mp l in let s = Sind (mind, extract_inductive env mind) in - let specs = extract_structure_spec env mp msig in + let specs = extract_structure_spec env mp reso msig in if logical_spec s then specs else begin Visit.add_spec_deps s; (l,Spec s) :: specs end | (l,SFBmodule mb) :: msig -> - let specs = extract_structure_spec env mp msig in + let specs = extract_structure_spec env mp reso msig in let spec = extract_mbody_spec env mb.mod_mp mb in (l,Smodule spec) :: specs | (l,SFBmodtype mtb) :: msig -> - let specs = extract_structure_spec env mp msig in + let specs = extract_structure_spec env mp reso msig in let spec = extract_mbody_spec env mtb.mod_mp mtb in (l,Smodtype spec) :: specs (* From [module_expression] to specifications *) -(* Invariant: the [me] given to [extract_mexpr_spec] should either come - from a [mod_type] or [type_expr] field, or their [_alg] counterparts. - This way, any encountered [MEident] should be a true module type. -*) +(* Invariant: the [me_alg] given to [extract_mexpr_spec] and + [extract_mexpression_spec] should come from a [mod_type_alg] field. + This way, any encountered [MEident] should be a true module type. *) and extract_mexpr_spec env mp1 (me_struct,me_alg) = match me_alg with | MEident mp -> Visit.add_mp_all mp; MTident mp @@ -244,7 +245,9 @@ and extract_mexpr_spec env mp1 (me_struct,me_alg) = match me_alg with | MEwith(me',WithMod(idl,mp))-> Visit.add_mp_all mp; MTwith(extract_mexpr_spec env mp1 (me_struct,me'), ML_With_module(idl,mp)) - | MEapply _ -> extract_msignature_spec env mp1 me_struct + | MEapply _ -> + (* No higher-order module type in OCaml : we use the expanded version *) + extract_msignature_spec env mp1 no_delta (*TODO*) me_struct and extract_mexpression_spec env mp1 (me_struct,me_alg) = match me_alg with | MoreFunctor (mbid, mtb, me_alg') -> @@ -258,19 +261,19 @@ and extract_mexpression_spec env mp1 (me_struct,me_alg) = match me_alg with extract_mexpression_spec env' mp1 (me_struct',me_alg')) | NoFunctor m -> extract_mexpr_spec env mp1 (me_struct,m) -and extract_msignature_spec env mp1 = function +and extract_msignature_spec env mp1 reso = function | NoFunctor struc -> - let env' = Modops.add_structure mp1 struc empty_delta_resolver env in - MTsig (mp1, extract_structure_spec env' mp1 struc) + let env' = Modops.add_structure mp1 struc reso env in + MTsig (mp1, extract_structure_spec env' mp1 reso struc) | MoreFunctor (mbid, mtb, me) -> let mp = MPbound mbid in let env' = Modops.add_module_type mp mtb env in MTfunsig (mbid, extract_mbody_spec env mp mtb, - extract_msignature_spec env' mp1 me) + extract_msignature_spec env' mp1 reso me) and extract_mbody_spec env mp mb = match mb.mod_type_alg with | Some ty -> extract_mexpression_spec env mp (mb.mod_type,ty) - | None -> extract_msignature_spec env mp mb.mod_type + | None -> extract_msignature_spec env mp mb.mod_delta mb.mod_type (* From a [structure_body] (i.e. a list of [structure_field_body]) to implementations. @@ -279,31 +282,31 @@ and extract_mbody_spec env mp mb = match mb.mod_type_alg with important: last to first ensures correct dependencies. *) -let rec extract_structure env mp ~all = function +let rec extract_structure env mp reso ~all = function | [] -> [] | (l,SFBconst cb) :: struc -> (try let vl,recd,struc = factor_fix env l cb struc in - let vc = Array.map (Constant.make2 mp) vl in - let ms = extract_structure env mp ~all struc in - let b = Array.exists Visit.needed_con vc in + let vc = Array.map (make_cst reso mp) vl in + let ms = extract_structure env mp reso ~all struc in + let b = Array.exists Visit.needed_cst vc in if all || b then let d = extract_fixpoint env vc recd in if (not b) && (logical_decl d) then ms else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end else ms with Impossible -> - let ms = extract_structure env mp ~all struc in - let c = Constant.make2 mp l in - let b = Visit.needed_con c in + let ms = extract_structure env mp reso ~all struc in + let c = make_cst reso mp l in + let b = Visit.needed_cst c in if all || b then let d = extract_constant env c cb in if (not b) && (logical_decl d) then ms else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end else ms) | (l,SFBmind mib) :: struc -> - let ms = extract_structure env mp ~all struc in - let mind = MutInd.make2 mp l in + let ms = extract_structure env mp reso ~all struc in + let mind = make_mind reso mp l in let b = Visit.needed_ind mind in if all || b then let d = Dind (mind, extract_inductive env mind) in @@ -311,14 +314,14 @@ let rec extract_structure env mp ~all = function else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end else ms | (l,SFBmodule mb) :: struc -> - let ms = extract_structure env mp ~all struc in + let ms = extract_structure env mp reso ~all struc in let mp = MPdot (mp,l) in let all' = all || Visit.needed_mp_all mp in if all' || Visit.needed_mp mp then (l,SEmodule (extract_module env mp ~all:all' mb)) :: ms else ms | (l,SFBmodtype mtb) :: struc -> - let ms = extract_structure env mp ~all struc in + let ms = extract_structure env mp reso ~all struc in let mp = MPdot (mp,l) in if all || Visit.needed_mp mp then (l,SEmodtype (extract_mbody_spec env mp mtb)) :: ms @@ -332,7 +335,8 @@ and extract_mexpr env mp = function (* In Haskell/Scheme, we expand everything. For now, we also extract everything, dead code will be removed later (see [Modutil.optimize_struct]. *) - extract_msignature env mp ~all:true (expand_mexpr env mp me) + let sign,_,delta,_ = expand_mexpr env mp me in + extract_msignature env mp delta ~all:true sign | MEident mp -> if is_modfile mp && not (modular ()) then error_MPfile_as_mod mp false; Visit.add_mp_all mp; Miniml.MEident mp @@ -350,17 +354,17 @@ and extract_mexpression env mp = function extract_mbody_spec env mp1 mtb, extract_mexpression env' mp me) -and extract_msignature env mp ~all = function +and extract_msignature env mp reso ~all = function | NoFunctor struc -> - let env' = Modops.add_structure mp struc empty_delta_resolver env in - Miniml.MEstruct (mp,extract_structure env' mp ~all struc) + let env' = Modops.add_structure mp struc reso env in + Miniml.MEstruct (mp,extract_structure env' mp reso ~all struc) | MoreFunctor (mbid, mtb, me) -> let mp1 = MPbound mbid in let env' = Modops.add_module_type mp1 mtb env in Miniml.MEfunctor (mbid, extract_mbody_spec env mp1 mtb, - extract_msignature env' mp ~all me) + extract_msignature env' mp reso ~all me) and extract_module env mp ~all mb = (* A module has an empty [mod_expr] when : @@ -376,8 +380,8 @@ and extract_module env mp ~all mb = (* This module has a signature, otherwise it would be FullStruct. We extract just the elements required by this signature. *) let () = add_labels mp mb.mod_type in - extract_msignature env mp ~all:false sign - | FullStruct -> extract_msignature env mp ~all mb.mod_type + extract_msignature env mp mb.mod_delta ~all:false sign + | FullStruct -> extract_msignature env mp mb.mod_delta ~all mb.mod_type in (* Slight optimization: for modules without explicit signatures ([FullStruct] case), we build the type out of the extracted @@ -399,7 +403,7 @@ let mono_environment refs mpl = let l = List.rev (environment_until None) in List.rev_map (fun (mp,struc) -> - mp, extract_structure env mp ~all:(Visit.needed_mp_all mp) struc) + mp, extract_structure env mp no_delta ~all:(Visit.needed_mp_all mp) struc) l (**************************************) @@ -455,7 +459,7 @@ let print_one_decl struc mp decl = push_visible mp []; let ans = d.pp_decl decl in pop_visible (); - ans + v 0 ans (*s Extraction of a ml struct to a file. *) @@ -495,8 +499,8 @@ let print_structure_to_file (fn,si,mo) dry struc = let d = descr () in reset_renaming_tables AllButExternal; let unsafe_needs = { - mldummy = struct_ast_search ((==) MLdummy) struc; - tdummy = struct_type_search Mlutil.isDummy struc; + mldummy = struct_ast_search Mlutil.isMLdummy struc; + tdummy = struct_type_search Mlutil.isTdummy struc; tunknown = struct_type_search ((==) Tunknown) struc; magic = if lang () != Haskell then false @@ -538,7 +542,7 @@ let print_structure_to_file (fn,si,mo) dry struc = (if dry then None else si); (* Print the buffer content via Coq standard formatter (ok with coqide). *) if not (Int.equal (Buffer.length buf) 0) then begin - Pp.msg_info (str (Buffer.contents buf)); + Pp.msg_notice (str (Buffer.contents buf)); Buffer.reset buf end @@ -632,7 +636,7 @@ let simple_extraction r = in let ans = flag ++ print_one_decl struc (modpath_of_r r) d in reset (); - Pp.msg_info ans + Pp.msg_notice ans | _ -> assert false @@ -650,7 +654,7 @@ let extraction_library is_rec m = let l = List.rev (environment_until (Some dir_m)) in let select l (mp,struc) = if Visit.needed_mp mp - then (mp, extract_structure env mp true struc) :: l + then (mp, extract_structure env mp no_delta true struc) :: l else l in let struc = List.fold_left select [] l in diff --git a/plugins/extraction/extract_env.mli b/plugins/extraction/extract_env.mli index e5fe76f58..90f4f911b 100644 --- a/plugins/extraction/extract_env.mli +++ b/plugins/extraction/extract_env.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 6ae519ef6..6c57bc2bb 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -11,7 +11,6 @@ open Util open Names open Term open Vars -open Context open Declarations open Declareops open Environ @@ -26,6 +25,7 @@ open Globnames open Miniml open Table open Mlutil +open Context.Rel.Declaration (*i*) exception I of inductive_kind @@ -75,7 +75,7 @@ type flag = info * scheme let rec flag_of_type env t : flag = let t = whd_betadeltaiota env none t in match kind_of_term t with - | Prod (x,t,c) -> flag_of_type (push_rel (x,None,t) env) c + | Prod (x,t,c) -> flag_of_type (push_rel (LocalAssum (x,t)) env) c | Sort s when Sorts.is_prop s -> (Logic,TypeScheme) | Sort _ -> (Info,TypeScheme) | _ -> if (sort_of env t) == InProp then (Logic,Default) else (Info,Default) @@ -91,7 +91,7 @@ exception NotDefault of kill_reason let check_default env t = match flag_of_type env t with | _,TypeScheme -> raise (NotDefault Ktype) - | Logic,_ -> raise (NotDefault Kother) + | Logic,_ -> raise (NotDefault Kprop) | _ -> () let is_info_scheme env t = match flag_of_type env t with @@ -103,7 +103,7 @@ let is_info_scheme env t = match flag_of_type env t with let rec type_sign env c = match kind_of_term (whd_betadeltaiota env none c) with | Prod (n,t,d) -> - (if is_info_scheme env t then Keep else Kill Kother) + (if is_info_scheme env t then Keep else Kill Kprop) :: (type_sign (push_rel_assum (n,t) env) d) | _ -> [] @@ -137,7 +137,7 @@ let rec type_sign_vl env c = match kind_of_term (whd_betadeltaiota env none c) with | Prod (n,t,d) -> let s,vl = type_sign_vl (push_rel_assum (n,t) env) d in - if not (is_info_scheme env t) then Kill Kother::s, vl + if not (is_info_scheme env t) then Kill Kprop::s, vl else Keep::s, (make_typvar n vl) :: vl | _ -> [],[] @@ -154,25 +154,12 @@ let sign_with_implicits r s nb_params = let implicits = implicits_of_global r in let rec add_impl i = function | [] -> [] - | sign::s -> - let sign' = - if sign == Keep && Int.List.mem i implicits - then Kill Kother else sign - in sign' :: add_impl (succ i) s + | Keep::s when Int.Set.mem i implicits -> + Kill (Kimplicit (r,i)) :: add_impl (i+1) s + | sign::s -> sign :: add_impl (i+1) s in add_impl (1+nb_params) s -(* Enriching a exception message *) - -let rec handle_exn r n fn_name = function - | MLexn s -> - (try Scanf.sscanf s "UNBOUND %d%!" - (fun i -> - assert ((0 < i) && (i <= n)); - MLexn ("IMPLICIT "^ msg_non_implicit r (n+1-i) (fn_name i))) - with Scanf.Scan_failure _ | End_of_file -> MLexn s) - | a -> ast_map (handle_exn r n fn_name) a - (*S Management of type variable contexts. *) (* A De Bruijn variable context (db) is a context for translating Coq [Rel] @@ -214,36 +201,6 @@ let parse_ind_args si args relmax = | _ -> parse (i+1) (j+1) s) in parse 1 1 si -let oib_equal o1 o2 = - Id.equal o1.mind_typename o2.mind_typename && - List.equal eq_rel_declaration o1.mind_arity_ctxt o2.mind_arity_ctxt && - begin - match o1.mind_arity, o2.mind_arity with - | RegularArity {mind_user_arity=c1; mind_sort=s1}, RegularArity {mind_user_arity=c2; mind_sort=s2} -> - eq_constr c1 c2 && Sorts.equal s1 s2 - | TemplateArity p1, TemplateArity p2 -> - let eq o1 o2 = Option.equal Univ.Level.equal o1 o2 in - List.equal eq p1.template_param_levels p2.template_param_levels && - Univ.Universe.equal p1.template_level p2.template_level - | _, _ -> false - end && - Array.equal Id.equal o1.mind_consnames o2.mind_consnames - -let eq_record x y = - Option.equal (Option.equal (fun (_, x, y) (_, x', y') -> Array.for_all2 eq_constant x x')) x y - -let mib_equal m1 m2 = - Array.equal oib_equal m1.mind_packets m1.mind_packets && - eq_record m1.mind_record m2.mind_record && - (m1.mind_finite : Decl_kinds.recursivity_kind) == m2.mind_finite && - Int.equal m1.mind_ntypes m2.mind_ntypes && - List.equal eq_named_declaration m1.mind_hyps m2.mind_hyps && - Int.equal m1.mind_nparams m2.mind_nparams && - Int.equal m1.mind_nparams_rec m2.mind_nparams_rec && - List.equal eq_rel_declaration m1.mind_params_ctxt m2.mind_params_ctxt && - (* Univ.UContext.eq *) m1.mind_universes == m2.mind_universes (** FIXME *) - (* m1.mind_universes = m2.mind_universes *) - (*S Extraction of a type. *) (* [extract_type env db c args] is used to produce an ML type from the @@ -285,13 +242,13 @@ let rec extract_type env db j c args = (match expand env mld with | Tdummy d -> Tdummy d | _ -> - let reason = if lvl == TypeScheme then Ktype else Kother in + let reason = if lvl == TypeScheme then Ktype else Kprop in Tarr (Tdummy reason, mld))) | Sort _ -> Tdummy Ktype (* The two logical cases. *) - | _ when sort_of env (applist (c, args)) == InProp -> Tdummy Kother + | _ when sort_of env (applist (c, args)) == InProp -> Tdummy Kprop | Rel n -> (match lookup_rel n env with - | (_,Some t,_) -> extract_type env db j (lift n t) args + | LocalDef (_,t,_) -> extract_type env db j (lift n t) args | _ -> (* Asks [db] a translation for [n]. *) if n > List.length db then Tunknown @@ -373,14 +330,9 @@ and extract_type_scheme env db c p = and extract_ind env kn = (* kn is supposed to be in long form *) let mib = Environ.lookup_mind kn env in - try - (* For a same kn, we can get various bodies due to module substitutions. - We hence check that the mib has not changed from recording - time to retrieving time. Ideally we should also check the env. *) - let (mib0,ml_ind) = lookup_ind kn in - if not (mib_equal mib mib0) then raise Not_found; - ml_ind - with Not_found -> + match lookup_ind kn mib with + | Some ml_ind -> ml_ind + | None -> (* First, if this inductive is aliased via a Module, we process the original inductive if possible. When at toplevel of the monolithic case, we cannot do much @@ -458,7 +410,7 @@ and extract_ind env kn = (* kn is supposed to be in long form *) if p.ip_logical then raise (I Standard); if not (Int.equal (Array.length p.ip_types) 1) then raise (I Standard); let typ = p.ip_types.(0) in - let l = List.filter (fun t -> not (isDummy (expand env t))) typ in + let l = List.filter (fun t -> not (isTdummy (expand env t))) typ in if not (keep_singleton ()) && Int.equal (List.length l) 1 && not (type_mem_kn kn (List.hd l)) then raise (I Singleton); @@ -479,7 +431,7 @@ and extract_ind env kn = (* kn is supposed to be in long form *) let mp = MutInd.modpath kn in let rec select_fields l typs = match l,typs with | [],[] -> [] - | _::l, typ::typs when isDummy (expand env typ) -> + | _::l, typ::typs when isTdummy (expand env typ) -> select_fields l typs | Anonymous::l, typ::typs -> None :: (select_fields l typs) @@ -536,28 +488,25 @@ and extract_type_cons env db dbmap c i = (*s Recording the ML type abbreviation of a Coq type scheme constant. *) and mlt_env env r = match r with + | IndRef _ | ConstructRef _ | VarRef _ -> None | ConstRef kn -> - (try - if not (visible_con kn) then raise Not_found; - match lookup_term kn with - | Dtype (_,vl,mlt) -> Some mlt + let cb = Environ.lookup_constant kn env in + match cb.const_body with + | Undef _ | OpaqueDef _ -> None + | Def l_body -> + match lookup_typedef kn cb with + | Some _ as o -> o + | None -> + let typ = Typeops.type_of_constant_type env cb.const_type + (* FIXME not sure if we should instantiate univs here *) in + match flag_of_type env typ with + | Info,TypeScheme -> + let body = Mod_subst.force_constr l_body in + let s = type_sign env typ in + let db = db_from_sign s in + let t = extract_type_scheme env db body (List.length s) + in add_typedef kn cb t; Some t | _ -> None - with Not_found -> - let cb = Environ.lookup_constant kn env in - let typ = Typeops.type_of_constant_type env cb.const_type - (* FIXME not sure if we should instantiate univs here *) in - match cb.const_body with - | Undef _ | OpaqueDef _ -> None - | Def l_body -> - (match flag_of_type env typ with - | Info,TypeScheme -> - let body = Mod_subst.force_constr l_body in - let s,vl = type_sign_vl env typ in - let db = db_from_sign s in - let t = extract_type_scheme env db body (List.length s) - in add_term kn (Dtype (r, vl, t)); Some t - | _ -> None)) - | _ -> None and expand env = type_expand (mlt_env env) and type2signature env = type_to_signature (mlt_env env) @@ -568,16 +517,18 @@ let type_expunge_from_sign env = type_expunge_from_sign (mlt_env env) (*s Extraction of the type of a constant. *) let record_constant_type env kn opt_typ = - try - if not (visible_con kn) then raise Not_found; - lookup_type kn - with Not_found -> - let typ = match opt_typ with - | None -> Typeops.type_of_constant_type env (lookup_constant kn env).const_type - | Some typ -> typ - in let mlt = extract_type env [] 1 typ [] - in let schema = (type_maxvar mlt, mlt) - in add_type kn schema; schema + let cb = lookup_constant kn env in + match lookup_cst_type kn cb with + | Some schema -> schema + | None -> + let typ = match opt_typ with + | None -> Typeops.type_of_constant_type env cb.const_type + | Some typ -> typ + in + let mlt = extract_type env [] 1 typ [] in + let schema = (type_maxvar mlt, mlt) in + let () = add_cst_type kn cb schema in + schema (*S Extraction of a term. *) @@ -610,7 +561,7 @@ let rec extract_term env mle mlt c args = put_magic_if magic (MLlam (id, d'))) | LetIn (n, c1, t1, c2) -> let id = id_of_name n in - let env' = push_rel (Name id, Some c1, t1) env in + let env' = push_rel (LocalDef (Name id, c1, t1)) env in (* We directly push the args inside the [LetIn]. TODO: the opt_let_app flag is supposed to prevent that *) let args' = List.map (lift 1) args in @@ -655,7 +606,7 @@ and extract_maybe_term env mle mlt c = try check_default env (type_of env c); extract_term env mle mlt c [] with NotDefault d -> - put_magic (mlt, Tdummy d) MLdummy + put_magic (mlt, Tdummy d) (MLdummy d) (*s Generic way to deal with an application. *) @@ -723,18 +674,18 @@ and extract_cst_app env mle mlt kn u args = else mla with e when Errors.noncritical e -> mla in - (* For strict languages, purely logical signatures with at least - one [Kill Kother] lead to a dummy lam. So a [MLdummy] is left + (* For strict languages, purely logical signatures lead to a dummy lam + (except when [Kill Ktype] everywhere). So a [MLdummy] is left accordingly. *) let optdummy = match sign_kind s_full with - | UnsafeLogicalSig when lang () != Haskell -> [MLdummy] + | UnsafeLogicalSig when lang () != Haskell -> [MLdummy Kprop] | _ -> [] in (* Different situations depending of the number of arguments: *) if la >= ls then (* Enough args, cleanup already done in [mla], we only add the - additionnal dummy if needed. *) + additional dummy if needed. *) put_magic_if (magic2 && not magic1) (mlapp head (optdummy @ mla)) else (* Partially applied function with some logical arg missing. @@ -748,7 +699,7 @@ and extract_cst_app env mle mlt kn u args = (*s Extraction of an inductive constructor applied to arguments. *) (* \begin{itemize} - \item In ML, contructor arguments are uncurryfied. + \item In ML, constructor arguments are uncurryfied. \item We managed to suppress logical parts inside inductive definitions, but they must appears outside (for partial applications for instance) \item We also suppressed all Coq parameters to the inductives, since @@ -826,8 +777,8 @@ and extract_case env mle ((kn,i) as ip,c,br) mlt = (* Logical singleton case: *) (* [match c with C i j k -> t] becomes [t'] *) assert (Int.equal br_size 1); - let s = iterate (fun l -> Kill Kother :: l) ni.(0) [] in - let mlt = iterate (fun t -> Tarr (Tdummy Kother, t)) ni.(0) mlt in + let s = iterate (fun l -> Kill Kprop :: l) ni.(0) [] in + let mlt = iterate (fun t -> Tarr (Tdummy Kprop, t)) ni.(0) mlt in let e = extract_maybe_term env mle mlt br.(0) in snd (case_expunge s e) end @@ -851,8 +802,7 @@ and extract_case env mle ((kn,i) as ip,c,br) mlt = let e = extract_maybe_term env mle (type_recomp (l,mlt)) br.(i) in (* We suppress dummy arguments according to signature. *) let ids,e = case_expunge s e in - let e' = handle_exn r (List.length s) (fun _ -> Anonymous) e in - (List.rev ids, Pusual r, e') + (List.rev ids, Pusual r, e) in if mi.ind_kind == Singleton then begin @@ -886,7 +836,7 @@ and extract_fix env mle i (fi,ti,ci as recd) mlt = let decomp_lams_eta_n n m env c t = let rels = fst (splay_prod_n env none n t) in - let rels = List.map (fun (id,_,c) -> (id,c)) rels in + let rels = List.map (fun (LocalAssum (id,c) | LocalDef (id,_,c)) -> (id,c)) rels in let rels',c = decompose_lam c in let d = n - m in (* we'd better keep rels' as long as possible. *) @@ -960,8 +910,6 @@ let extract_std_constant env kn body typ = let e = extract_term env mle t' c [] in (* Expunging term and type from dummy lambdas. *) let trm = term_expunge s (ids,e) in - let trm = handle_exn (ConstRef kn) n (fun i -> fst (List.nth rels (i-1))) trm - in trm, type_expunge_from_sign env s t (* Extracts the type of an axiom, honors the Extraction Implicit declaration. *) @@ -979,8 +927,8 @@ let extract_axiom env kn typ = let extract_fixpoint env vkn (fi,ti,ci) = let n = Array.length vkn in - let types = Array.make n (Tdummy Kother) - and terms = Array.make n MLdummy in + let types = Array.make n (Tdummy Kprop) + and terms = Array.make n (MLdummy Kprop) in let kns = Array.to_list vkn in current_fixpoints := kns; (* for replacing recursive calls [Rel ..] by the corresponding [Const]: *) @@ -1022,7 +970,7 @@ let extract_constant env kn cb = in match flag_of_type env typ with | (Logic,TypeScheme) -> warn_log (); Dtype (r, [], Tdummy Ktype) - | (Logic,Default) -> warn_log (); Dterm (r, MLdummy, Tdummy Kother) + | (Logic,Default) -> warn_log (); Dterm (r, MLdummy Kprop, Tdummy Kprop) | (Info,TypeScheme) -> (match cb.const_body with | Undef _ -> warn_info (); mk_typ_ax () @@ -1047,7 +995,7 @@ let extract_constant_spec env kn cb = let typ = Typeops.type_of_constant_type env cb.const_type in match flag_of_type env typ with | (Logic, TypeScheme) -> Stype (r, [], Some (Tdummy Ktype)) - | (Logic, Default) -> Sval (r, Tdummy Kother) + | (Logic, Default) -> Sval (r, Tdummy Kprop) | (Info, TypeScheme) -> let s,vl = type_sign_vl env typ in (match cb.const_body with @@ -1075,8 +1023,8 @@ let extract_constr env c = reset_meta_count (); let typ = type_of env c in match flag_of_type env typ with - | (_,TypeScheme) -> MLdummy, Tdummy Ktype - | (Logic,_) -> MLdummy, Tdummy Kother + | (_,TypeScheme) -> MLdummy Ktype, Tdummy Ktype + | (Logic,_) -> MLdummy Kprop, Tdummy Kprop | (Info,Default) -> let mlt = extract_type env [] 1 typ [] in extract_term env Mlenv.empty mlt c [], mlt @@ -1090,7 +1038,7 @@ let extract_inductive env kn = | [] -> [] | t::l -> let l' = filter (succ i) l in - if isDummy (expand env t) || Int.List.mem i implicits then l' + if isTdummy (expand env t) || Int.Set.mem i implicits then l' else t::l' in filter (1+ind.ind_nparams) l in @@ -1102,11 +1050,11 @@ let extract_inductive env kn = (*s Is a [ml_decl] logical ? *) let logical_decl = function - | Dterm (_,MLdummy,Tdummy _) -> true + | Dterm (_,MLdummy _,Tdummy _) -> true | Dtype (_,[],Tdummy _) -> true | Dfix (_,av,tv) -> - (Array.for_all ((==) MLdummy) av) && - (Array.for_all isDummy tv) + (Array.for_all isMLdummy av) && + (Array.for_all isTdummy tv) | Dind (_,i) -> Array.for_all (fun ip -> ip.ip_logical) i.ind_packets | _ -> false diff --git a/plugins/extraction/extraction.mli b/plugins/extraction/extraction.mli index 6bd2541b2..cdda777a6 100644 --- a/plugins/extraction/extraction.mli +++ b/plugins/extraction/extraction.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/extraction/g_extraction.ml4 b/plugins/extraction/g_extraction.ml4 index 3fe5a8c04..7bd07f625 100644 --- a/plugins/extraction/g_extraction.ml4 +++ b/plugins/extraction/g_extraction.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -11,6 +11,10 @@ (* ML names *) open Genarg +open Stdarg +open Constrarg +open Pcoq.Prim +open Pcoq.Constr open Pp open Names open Nameops diff --git a/plugins/extraction/haskell.ml b/plugins/extraction/haskell.ml index 37b414207..22519e347 100644 --- a/plugins/extraction/haskell.ml +++ b/plugins/extraction/haskell.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -35,56 +35,59 @@ let keywords = let pp_comment s = str "-- " ++ s ++ fnl () let pp_bracket_comment s = str"{- " ++ hov 0 s ++ str" -}" +(* Note: do not shorten [str "foo" ++ fnl ()] into [str "foo\n"], + the '\n' character interacts badly with the Format boxing mechanism *) + let preamble mod_name comment used_modules usf = - let pp_import mp = str ("import qualified "^ string_of_modfile mp ^"\n") + let pp_import mp = str ("import qualified "^ string_of_modfile mp) ++ fnl () in (if not (usf.magic || usf.tunknown) then mt () else str "{-# OPTIONS_GHC -cpp -XMagicHash #-}" ++ fnl () ++ - str "{- For Hugs, use the option -F\"cpp -P -traditional\" -}") - ++ fnl () ++ fnl () + str "{- For Hugs, use the option -F\"cpp -P -traditional\" -}" ++ fnl2 ()) ++ (match comment with | None -> mt () - | Some com -> pp_bracket_comment com ++ fnl () ++ fnl ()) + | Some com -> pp_bracket_comment com ++ fnl2 ()) ++ str "module " ++ pr_upper_id mod_name ++ str " where" ++ fnl2 () ++ str "import qualified Prelude" ++ fnl () ++ - prlist pp_import used_modules ++ fnl () ++ - (if List.is_empty used_modules then mt () else fnl ()) ++ + prlist pp_import used_modules ++ fnl () + ++ (if not (usf.magic || usf.tunknown) then mt () - else str "\ -\n#ifdef __GLASGOW_HASKELL__\ -\nimport qualified GHC.Base\ -\nimport qualified GHC.Prim\ -\n#else\ -\n-- HUGS\ -\nimport qualified IOExts\ -\n#endif" ++ fnl2 ()) + else + str "#ifdef __GLASGOW_HASKELL__" ++ fnl () ++ + str "import qualified GHC.Base" ++ fnl () ++ + str "import qualified GHC.Prim" ++ fnl () ++ + str "#else" ++ fnl () ++ + str "-- HUGS" ++ fnl () ++ + str "import qualified IOExts" ++ fnl () ++ + str "#endif" ++ fnl2 ()) ++ (if not usf.magic then mt () - else str "\ -\n#ifdef __GLASGOW_HASKELL__\ -\nunsafeCoerce :: a -> b\ -\nunsafeCoerce = GHC.Base.unsafeCoerce#\ -\n#else\ -\n-- HUGS\ -\nunsafeCoerce :: a -> b\ -\nunsafeCoerce = IOExts.unsafeCoerce\ -\n#endif" ++ fnl2 ()) + else + str "#ifdef __GLASGOW_HASKELL__" ++ fnl () ++ + str "unsafeCoerce :: a -> b" ++ fnl () ++ + str "unsafeCoerce = GHC.Base.unsafeCoerce#" ++ fnl () ++ + str "#else" ++ fnl () ++ + str "-- HUGS" ++ fnl () ++ + str "unsafeCoerce :: a -> b" ++ fnl () ++ + str "unsafeCoerce = IOExts.unsafeCoerce" ++ fnl () ++ + str "#endif" ++ fnl2 ()) ++ (if not usf.tunknown then mt () - else str "\ -\n#ifdef __GLASGOW_HASKELL__\ -\ntype Any = GHC.Prim.Any\ -\n#else\ -\n-- HUGS\ -\ntype Any = ()\ -\n#endif" ++ fnl2 ()) + else + str "#ifdef __GLASGOW_HASKELL__" ++ fnl () ++ + str "type Any = GHC.Prim.Any" ++ fnl () ++ + str "#else" ++ fnl () ++ + str "-- HUGS" ++ fnl () ++ + str "type Any = ()" ++ fnl () ++ + str "#endif" ++ fnl2 ()) ++ (if not usf.mldummy then mt () - else str "__ :: any" ++ fnl () ++ - str "__ = Prelude.error \"Logical or arity value used\"" ++ fnl2 ()) + else + str "__ :: any" ++ fnl () ++ + str "__ = Prelude.error \"Logical or arity value used\"" ++ fnl2 ()) let pp_abst = function | [] -> (mt ()) @@ -120,7 +123,7 @@ let rec pp_type par vl t = (pp_rec true t1 ++ spc () ++ str "->" ++ spc () ++ pp_rec false t2) | Tdummy _ -> str "()" | Tunknown -> str "Any" - | Taxiom -> str "() -- AXIOM TO BE REALIZED\n" + | Taxiom -> str "() -- AXIOM TO BE REALIZED" ++ fnl () in hov 0 (pp_rec par t) @@ -140,7 +143,11 @@ let rec pp_expr par env args = and apply2 st = pp_apply2 st par args in function | MLrel n -> - let id = get_db_name n env in apply (pr_id id) + let id = get_db_name n env in + (* Try to survive to the occurrence of a Dummy rel. + TODO: we should get rid of this hack (cf. #592) *) + let id = if Id.equal id dummy_name then Id.of_string "__" else id in + apply (pr_id id) | MLapp (f,args') -> let stl = List.map (pp_expr true env []) args' in pp_expr par env (stl @ args) f @@ -200,8 +207,11 @@ let rec pp_expr par env args = | MLexn s -> (* An [MLexn] may be applied, but I don't really care. *) pp_par par (str "Prelude.error" ++ spc () ++ qs s) - | MLdummy -> - str "__" (* An [MLdummy] may be applied, but I don't really care. *) + | MLdummy k -> + (* An [MLdummy] may be applied, but I don't really care. *) + (match msg_of_implicit k with + | "" -> str "__" + | s -> str "__" ++ spc () ++ pp_bracket_comment (str s)) | MLmagic a -> pp_apply (str "unsafeCoerce") par (pp_expr true env [] a :: args) | MLaxiom -> pp_par par (str "Prelude.error \"AXIOM TO BE REALIZED\"") @@ -320,7 +330,7 @@ let pp_decl = function prlist (fun id -> str (id^" ")) ids ++ str "=" ++ spc () ++ str s with Not_found -> prlist (fun id -> pr_id id ++ str " ") l ++ - if t == Taxiom then str "= () -- AXIOM TO BE REALIZED\n" + if t == Taxiom then str "= () -- AXIOM TO BE REALIZED" ++ fnl () else str "=" ++ spc () ++ pp_type false l t in hov 2 (str "type " ++ pp_global Type r ++ spc () ++ st) ++ fnl2 () @@ -331,7 +341,8 @@ let pp_decl = function prvecti (fun i r -> let void = is_inline_custom r || - (not (is_custom r) && match defs.(i) with MLexn "UNUSED" -> true | _ -> false) + (not (is_custom r) && + match defs.(i) with MLexn "UNUSED" -> true | _ -> false) in if void then mt () else diff --git a/plugins/extraction/haskell.mli b/plugins/extraction/haskell.mli index 99559bced..6f4932067 100644 --- a/plugins/extraction/haskell.mli +++ b/plugins/extraction/haskell.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/extraction/json.ml b/plugins/extraction/json.ml index 125dc86b8..df79c585e 100644 --- a/plugins/extraction/json.ml +++ b/plugins/extraction/json.ml @@ -153,7 +153,7 @@ let rec json_expr env = function ("what", json_str "expr:exception"); ("msg", json_str s) ] - | MLdummy -> json_dict [("what", json_str "expr:dummy")] + | MLdummy _ -> json_dict [("what", json_str "expr:dummy")] | MLmagic a -> json_dict [ ("what", json_str "expr:coerce"); ("value", json_expr env a) diff --git a/plugins/extraction/miniml.mli b/plugins/extraction/miniml.mli index b7dee6cb1..db3361522 100644 --- a/plugins/extraction/miniml.mli +++ b/plugins/extraction/miniml.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -16,11 +16,16 @@ open Globnames object expects, and what these arguments will become in the ML object. *) -(* We eliminate from terms: 1) types 2) logical parts. - [Kother] stands both for logical or other reasons - (for instance user-declared implicit arguments w.r.t. extraction). *) +(* We eliminate from terms: + 1) types + 2) logical parts + 3) user-declared implicit arguments of a constant of constructor +*) -type kill_reason = Ktype | Kother +type kill_reason = + | Ktype + | Kprop + | Kimplicit of global_reference * int (* n-th arg of a cst or construct *) type sign = Keep | Kill of kill_reason @@ -118,7 +123,7 @@ and ml_ast = | MLcase of ml_type * ml_ast * ml_branch array | MLfix of int * Id.t array * ml_ast array | MLexn of string - | MLdummy + | MLdummy of kill_reason | MLaxiom | MLmagic of ml_ast diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index 6fc1195fb..402fe4ffe 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -299,10 +299,12 @@ let type_to_signature env t = let isKill = function Kill _ -> true | _ -> false -let isDummy = function Tdummy _ -> true | _ -> false +let isTdummy = function Tdummy _ -> true | _ -> false + +let isMLdummy = function MLdummy _ -> true | _ -> false let sign_of_id = function - | Dummy -> Kill Kother + | Dummy -> Kill Kprop | _ -> Keep (* Classification of signatures *) @@ -310,45 +312,44 @@ let sign_of_id = function type sign_kind = | EmptySig | NonLogicalSig (* at least a [Keep] *) - | UnsafeLogicalSig (* No [Keep], at least a [Kill Kother] *) | SafeLogicalSig (* only [Kill Ktype] *) + | UnsafeLogicalSig (* No [Keep], not all [Kill Ktype] *) let rec sign_kind = function | [] -> EmptySig | Keep :: _ -> NonLogicalSig | Kill k :: s -> - match sign_kind s with - | NonLogicalSig -> NonLogicalSig - | UnsafeLogicalSig -> UnsafeLogicalSig - | SafeLogicalSig | EmptySig -> - if k == Kother then UnsafeLogicalSig else SafeLogicalSig + match k, sign_kind s with + | _, NonLogicalSig -> NonLogicalSig + | Ktype, (SafeLogicalSig | EmptySig) -> SafeLogicalSig + | _, _ -> UnsafeLogicalSig (* Removing the final [Keep] in a signature *) let rec sign_no_final_keeps = function | [] -> [] | k :: s -> - let s' = k :: sign_no_final_keeps s in - match s' with [Keep] -> [] | _ -> s' + match k, sign_no_final_keeps s with + | Keep, [] -> [] + | k, l -> k::l (*s Removing [Tdummy] from the top level of a ML type. *) let type_expunge_from_sign env s t = - let rec expunge s t = - if List.is_empty s then t else match t with - | Tmeta {contents = Some t} -> expunge s t - | Tarr (a,b) -> - let t = expunge (List.tl s) b in - if List.hd s == Keep then Tarr (a, t) else t - | Tglob (r,l) -> - (match env r with - | Some mlt -> expunge s (type_subst_list l mlt) - | None -> assert false) - | _ -> assert false + let rec expunge s t = match s, t with + | [], _ -> t + | Keep :: s, Tarr(a,b) -> Tarr (a, expunge s b) + | Kill _ :: s, Tarr(a,b) -> expunge s b + | _, Tmeta {contents = Some t} -> expunge s t + | _, Tglob (r,l) -> + (match env r with + | Some mlt -> expunge s (type_subst_list l mlt) + | None -> assert false) + | _ -> assert false in let t = expunge (sign_no_final_keeps s) t in if lang () != Haskell && sign_kind s == UnsafeLogicalSig then - Tarr (Tdummy Kother, t) + Tarr (Tdummy Kprop, t) else t let type_expunge env t = @@ -385,7 +386,7 @@ let rec eq_ml_ast t1 t2 = match t1, t2 with | MLfix (i1, id1, t1), MLfix (i2, id2, t2) -> Int.equal i1 i2 && Array.equal Id.equal id1 id2 && Array.equal eq_ml_ast t1 t2 | MLexn e1, MLexn e2 -> String.equal e1 e2 -| MLdummy, MLdummy -> true +| MLdummy k1, MLdummy k2 -> k1 == k2 | MLaxiom, MLaxiom -> true | MLmagic t1, MLmagic t2 -> eq_ml_ast t1 t2 | _ -> false @@ -420,7 +421,7 @@ let ast_iter_rel f = | MLapp (a,l) -> iter n a; List.iter (iter n) l | MLcons (_,_,l) | MLtuple l -> List.iter (iter n) l | MLmagic a -> iter n a - | MLglob _ | MLexn _ | MLdummy | MLaxiom -> () + | MLglob _ | MLexn _ | MLdummy _ | MLaxiom -> () in iter 0 (*s Map over asts. *) @@ -439,7 +440,7 @@ let ast_map f = function | MLcons (typ,c,l) -> MLcons (typ,c, List.map f l) | MLtuple l -> MLtuple (List.map f l) | MLmagic a -> MLmagic (f a) - | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom as a -> a + | MLrel _ | MLglob _ | MLexn _ | MLdummy _ | MLaxiom as a -> a (*s Map over asts, with binding depth as parameter. *) @@ -457,7 +458,7 @@ let ast_map_lift f n = function | MLcons (typ,c,l) -> MLcons (typ,c, List.map (f n) l) | MLtuple l -> MLtuple (List.map (f n) l) | MLmagic a -> MLmagic (f n a) - | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom as a -> a + | MLrel _ | MLglob _ | MLexn _ | MLdummy _ | MLaxiom as a -> a (*s Iter over asts. *) @@ -471,7 +472,7 @@ let ast_iter f = function | MLapp (a,l) -> f a; List.iter f l | MLcons (_,_,l) | MLtuple l -> List.iter f l | MLmagic a -> f a - | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom -> () + | MLrel _ | MLglob _ | MLexn _ | MLdummy _ | MLaxiom -> () (*S Operations concerning De Bruijn indices. *) @@ -507,9 +508,73 @@ let nb_occur_match = | MLapp (a,l) -> List.fold_left (fun r a -> r+(nb k a)) (nb k a) l | MLcons (_,_,l) | MLtuple l -> List.fold_left (fun r a -> r+(nb k a)) 0 l | MLmagic a -> nb k a - | MLglob _ | MLexn _ | MLdummy | MLaxiom -> 0 + | MLglob _ | MLexn _ | MLdummy _ | MLaxiom -> 0 in nb 1 +(* Replace unused variables by _ *) + +let dump_unused_vars a = + let rec ren env a = match a with + | MLrel i -> + let () = (List.nth env (i-1)) := true in a + + | MLlam (id,b) -> + let occ_id = ref false in + let b' = ren (occ_id::env) b in + if !occ_id then if b' == b then a else MLlam(id,b') + else MLlam(Dummy,b') + + | MLletin (id,b,c) -> + let occ_id = ref false in + let b' = ren env b in + let c' = ren (occ_id::env) c in + if !occ_id then + if b' == b && c' == c then a else MLletin(id,b',c') + else + (* 'let' without occurrence: shouldn't happen after simpl *) + MLletin(Dummy,b',c') + + | MLcase (t,e,br) -> + let e' = ren env e in + let br' = Array.smartmap (ren_branch env) br in + if e' == e && br' == br then a else MLcase (t,e',br') + + | MLfix (i,ids,v) -> + let env' = List.init (Array.length ids) (fun _ -> ref false) @ env in + let v' = Array.smartmap (ren env') v in + if v' == v then a else MLfix (i,ids,v') + + | MLapp (b,l) -> + let b' = ren env b and l' = List.smartmap (ren env) l in + if b' == b && l' == l then a else MLapp (b',l') + + | MLcons(t,r,l) -> + let l' = List.smartmap (ren env) l in + if l' == l then a else MLcons (t,r,l') + + | MLtuple l -> + let l' = List.smartmap (ren env) l in + if l' == l then a else MLtuple l' + + | MLmagic b -> + let b' = ren env b in + if b' == b then a else MLmagic b' + + | MLglob _ | MLexn _ | MLdummy _ | MLaxiom -> a + + and ren_branch env ((ids,p,b) as tr) = + let occs = List.map (fun _ -> ref false) ids in + let b' = ren (List.rev_append occs env) b in + let ids' = + List.map2 + (fun id occ -> if !occ then id else Dummy) + ids occs + in + if b' == b && List.equal eq_ml_ident ids ids' then tr + else (ids',p,b') + in + ren [] a + (*s Lifting on terms. [ast_lift k t] lifts the binding depth of [t] across [k] bindings. *) @@ -559,7 +624,7 @@ let gen_subst v d t = if i' < 1 then a else if i' <= Array.length v then match v.(i'-1) with - | None -> MLexn ("UNBOUND " ^ string_of_int i') + | None -> assert false | Some u -> ast_lift n u else MLrel (i+d) | a -> ast_map_lift subst n a @@ -813,8 +878,8 @@ let census_add, census_max, census_clean = try h := add k i !h with Not_found -> h := (k, Int.Set.singleton i) :: !h in - let maxf k = - let len = ref 0 and lst = ref Int.Set.empty and elm = ref k in + let maxf () = + let len = ref 0 and lst = ref Int.Set.empty and elm = ref MLaxiom in List.iter (fun (e, s) -> let n = Int.Set.cardinal s in @@ -843,7 +908,7 @@ let factor_branches o typ br = if o.opt_case_cst then (try census_add (branch_as_cst br.(i)) i with Impossible -> ()); done; - let br_factor, br_set = census_max MLdummy in + let br_factor, br_set = census_max () in census_clean (); let n = Int.Set.cardinal br_set in if Int.equal n 0 then None @@ -926,7 +991,7 @@ let iota_gen br hd = in iota 0 hd let is_atomic = function - | MLrel _ | MLglob _ | MLexn _ | MLdummy -> true + | MLrel _ | MLglob _ | MLexn _ | MLdummy _ -> true | _ -> false let is_imm_apply = function MLapp (MLrel 1, _) -> true | _ -> false @@ -948,9 +1013,20 @@ let expand_linear_let o id e = (* Some beta-iota reductions + simplifications. *) +let rec unmagic = function MLmagic e -> unmagic e | e -> e +let is_magic = function MLmagic _ -> true | _ -> false +let magic_hd a = match a with + | MLmagic _ :: _ -> a + | e :: a -> MLmagic e :: a + | [] -> assert false + let rec simpl o = function | MLapp (f, []) -> simpl o f - | MLapp (f, a) -> simpl_app o (List.map (simpl o) a) (simpl o f) + | MLapp (MLapp(f,a),a') -> simpl o (MLapp(f,a@a')) + | MLapp (f, a) -> + (* When the head of the application is magic, no need for magic on args *) + let a = if is_magic f then List.map unmagic a else a in + simpl_app o (List.map (simpl o) a) (simpl o f) | MLcase (typ,e,br) -> let br = Array.map (fun (l,p,t) -> (l,p,simpl o t)) br in simpl_case o typ br (simpl o e) @@ -970,12 +1046,18 @@ let rec simpl o = function if ast_occurs_itvl 1 n c.(i) then MLfix (i, ids, Array.map (simpl o) c) else simpl o (ast_lift (-n) c.(i)) (* Dummy fixpoint *) + | MLmagic(MLmagic _ as e) -> simpl o e + | MLmagic(MLapp (f,l)) -> simpl o (MLapp (MLmagic f, l)) + | MLmagic(MLletin(id,c,e)) -> simpl o (MLletin(id,c,MLmagic e)) + | MLmagic(MLcase(typ,e,br)) -> + let br' = Array.map (fun (ids,p,c) -> (ids,p,MLmagic c)) br in + simpl o (MLcase(typ,e,br')) + | MLmagic(MLexn _ as e) -> e | a -> ast_map (simpl o) a (* invariant : list [a] of arguments is non-empty *) and simpl_app o a = function - | MLapp (f',a') -> simpl_app o (a'@a) f' | MLlam (Dummy,t) -> simpl o (MLapp (ast_pop t, List.tl a)) | MLlam (id,t) -> (* Beta redex *) @@ -986,6 +1068,11 @@ and simpl_app o a = function | _ -> let a' = List.map (ast_lift 1) (List.tl a) in simpl o (MLletin (id, List.hd a, MLapp (t, a')))) + | MLmagic (MLlam (id,t)) -> + (* When we've at least one argument, we permute the magic + and the lambda, to simplify things a bit (see #2795). + Alas, the 1st argument must also be magic then. *) + simpl_app o (magic_hd a) (MLlam (id,MLmagic t)) | MLletin (id,e1,e2) when o.opt_let_app -> (* Application of a letin: we push arguments inside *) MLletin (id, e1, simpl o (MLapp (e2, List.map (ast_lift 1) a))) @@ -998,7 +1085,7 @@ and simpl_app o a = function let a' = List.map (ast_lift k) a in (l, p, simpl o (MLapp (t,a')))) br in simpl o (MLcase (typ,e,br')) - | (MLdummy | MLexn _) as e -> e + | (MLdummy _ | MLexn _) as e -> e (* We just discard arguments in those cases. *) | f -> MLapp (f,a) @@ -1049,20 +1136,26 @@ let rec select_via_bl l args = match l,args with (*s [kill_some_lams] removes some head lambdas according to the signature [bl]. This list is build on the identifier list model: outermost lambda is on the right. - [Rels] corresponding to removed lambdas are supposed not to occur, and + [Rels] corresponding to removed lambdas are not supposed to occur + (except maybe in the case of Kimplicit), and the other [Rels] are made correct via a [gen_subst]. Output is not directly a [ml_ast], compose with [named_lams] if needed. *) +let is_impl_kill = function Kill (Kimplicit _) -> true | _ -> false + let kill_some_lams bl (ids,c) = let n = List.length bl in let n' = List.fold_left (fun n b -> if b == Keep then (n+1) else n) 0 bl in if Int.equal n n' then ids,c - else if Int.equal n' 0 then [],ast_lift (-n) c + else if Int.equal n' 0 && not (List.exists is_impl_kill bl) + then [],ast_lift (-n) c else begin let v = Array.make n None in let rec parse_ids i j = function | [] -> () | Keep :: l -> v.(i) <- Some (MLrel j); parse_ids (i+1) (j+1) l + | Kill (Kimplicit _ as k) :: l -> + v.(i) <- Some (MLdummy k); parse_ids (i+1) j l | Kill _ :: l -> parse_ids (i+1) j l in parse_ids 0 1 bl; select_via_bl bl ids, gen_subst v (n'-n) c @@ -1070,11 +1163,19 @@ let kill_some_lams bl (ids,c) = (*s [kill_dummy_lams] uses the last function to kill the lambdas corresponding to a [dummy_name]. It can raise [Impossible] if there is nothing to do, or - if there is no lambda left at all. *) + if there is no lambda left at all. In addition, it now accepts a signature + that may mention some implicits. *) -let kill_dummy_lams c = +let rec merge_implicits ids s = match ids, s with + | [],_ -> [] + | _,[] -> List.map sign_of_id ids + | Dummy::ids, _::s -> Kill Kprop :: merge_implicits ids s + | _::ids, (Kill (Kimplicit _) as k)::s -> k :: merge_implicits ids s + | _::ids, _::s -> Keep :: merge_implicits ids s + +let kill_dummy_lams sign c = let ids,c = collect_lams c in - let bl = List.map sign_of_id ids in + let bl = merge_implicits ids (List.rev sign) in if not (List.memq Keep bl) then raise Impossible; let rec fst_kill n = function | [] -> raise Impossible @@ -1086,7 +1187,7 @@ let kill_dummy_lams c = let _, bl = List.chop skip bl in let c = named_lams ids_skip c in let ids',c = kill_some_lams bl (ids,c) in - ids, named_lams ids' c + (ids,bl), named_lams ids' c (*s [eta_expansion_sign] takes a function [fun idn ... id1 -> c] and a signature [s] and builds a eta-long version. *) @@ -1100,12 +1201,12 @@ let eta_expansion_sign s (ids,c) = let a = List.rev_map (function MLrel x -> MLrel (i-x) | a -> a) rels in ids, MLapp (ast_lift (i-1) c, a) | Keep :: l -> abs (anonymous :: ids) (MLrel i :: rels) (i+1) l - | Kill _ :: l -> abs (Dummy :: ids) (MLdummy :: rels) (i+1) l + | Kill k :: l -> abs (Dummy :: ids) (MLdummy k :: rels) (i+1) l in abs ids [] 1 s (*s If [s = [b1; ... ; bn]] then [case_expunge] decomposes [e] in [n] lambdas (with eta-expansion if needed) and removes all dummy lambdas - corresponding to [Del] in [s]. *) + corresponding to [Kill _] in [s]. *) let case_expunge s e = let m = List.length s in @@ -1123,17 +1224,18 @@ let term_expunge s (ids,c) = if List.is_empty s then c else let ids,c = kill_some_lams (List.rev s) (ids,c) in - if List.is_empty ids && lang () != Haskell && List.mem (Kill Kother) s then - MLlam (Dummy, ast_lift 1 c) + if List.is_empty ids && lang () != Haskell && + sign_kind s == UnsafeLogicalSig + then MLlam (Dummy, ast_lift 1 c) else named_lams ids c -(*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]. +(*s [kill_dummy_args (ids,bl) r t] looks for occurrences of [MLrel r] in [t] + and purge the args of [MLrel r] corresponding to a [Kill] in [bl]. It makes eta-expansion if needed. *) -let kill_dummy_args ids r t = +let kill_dummy_args (ids,bl) r t = let m = List.length ids in - let bl = List.rev_map sign_of_id ids in + let sign = List.rev bl in let rec found n = function | MLrel r' when Int.equal r' (r + n) -> true | MLmagic e -> found n e @@ -1144,41 +1246,46 @@ let kill_dummy_args ids r t = let k = max 0 (m - (List.length a)) in let a = List.map (killrec n) a in let a = List.map (ast_lift k) a in - let a = select_via_bl bl (a @ (eta_args k)) in + let a = select_via_bl sign (a @ (eta_args k)) in named_lams (List.firstn k ids) (MLapp (ast_lift k e, a)) | e when found n e -> - let a = select_via_bl bl (eta_args m) in + let a = select_via_bl sign (eta_args m) in named_lams ids (MLapp (ast_lift m e, a)) | e -> ast_map_lift killrec n e in killrec 0 t (*s The main function for local [dummy] elimination. *) +let sign_of_args a = + List.map (function MLdummy k -> Kill k | _ -> Keep) a + let rec kill_dummy = function | MLfix(i,fi,c) -> (try - let ids,c = kill_dummy_fix i c in - ast_subst (MLfix (i,fi,c)) (kill_dummy_args ids 1 (MLrel 1)) + let k,c = kill_dummy_fix i c [] in + ast_subst (MLfix (i,fi,c)) (kill_dummy_args k 1 (MLrel 1)) with Impossible -> MLfix (i,fi,Array.map kill_dummy c)) | MLapp (MLfix (i,fi,c),a) -> let a = List.map kill_dummy a in + (* Heuristics: if some arguments are implicit args, we try to + eliminate the corresponding arguments of the fixpoint *) (try - let ids,c = kill_dummy_fix i c in + let k,c = kill_dummy_fix i c (sign_of_args a) in let fake = MLapp (MLrel 1, List.map (ast_lift 1) a) in - let fake' = kill_dummy_args ids 1 fake in + let fake' = kill_dummy_args k 1 fake in ast_subst (MLfix (i,fi,c)) fake' with Impossible -> MLapp(MLfix(i,fi,Array.map kill_dummy c),a)) | MLletin(id, MLfix (i,fi,c),e) -> (try - let ids,c = kill_dummy_fix i c in - let e = kill_dummy (kill_dummy_args ids 1 e) in + let k,c = kill_dummy_fix i c [] in + let e = kill_dummy (kill_dummy_args k 1 e) in MLletin(id, MLfix(i,fi,c),e) with Impossible -> MLletin(id, MLfix(i,fi,Array.map kill_dummy c),kill_dummy e)) | MLletin(id,c,e) -> (try - let ids,c = kill_dummy_lams (kill_dummy_hd c) in - let e = kill_dummy (kill_dummy_args ids 1 e) in + let k,c = kill_dummy_lams [] (kill_dummy_hd c) in + let e = kill_dummy (kill_dummy_args k 1 e) in let c = kill_dummy c in if is_atomic c then ast_subst c e else MLletin (id, c, e) with Impossible -> MLletin(id,kill_dummy c,kill_dummy e)) @@ -1190,21 +1297,21 @@ and kill_dummy_hd = function | MLlam(id,e) -> MLlam(id, kill_dummy_hd e) | MLletin(id,c,e) -> (try - let ids,c = kill_dummy_lams (kill_dummy_hd c) in - let e = kill_dummy_hd (kill_dummy_args ids 1 e) in + let k,c = kill_dummy_lams [] (kill_dummy_hd c) in + let e = kill_dummy_hd (kill_dummy_args k 1 e) in let c = kill_dummy c in if is_atomic c then ast_subst c e else MLletin (id, c, e) with Impossible -> MLletin(id,kill_dummy c,kill_dummy_hd e)) | a -> a -and kill_dummy_fix i c = +and kill_dummy_fix i c s = let n = Array.length c in - let ids,ci = kill_dummy_lams (kill_dummy_hd c.(i)) in + let k,ci = kill_dummy_lams s (kill_dummy_hd c.(i)) in let c = Array.copy c in c.(i) <- ci; for j = 0 to (n-1) do - c.(j) <- kill_dummy (kill_dummy_args ids (n-i) c.(j)) + c.(j) <- kill_dummy (kill_dummy_args k (n-i) c.(j)) done; - ids,c + k,c (*s Putting things together. *) @@ -1267,7 +1374,7 @@ let rec ml_size = function | MLfix(_,_,f) -> ml_size_array f | MLletin (_,_,t) -> ml_size t | MLmagic t -> ml_size t - | MLglob _ | MLrel _ | MLexn _ | MLdummy | MLaxiom -> 0 + | MLglob _ | MLrel _ | MLexn _ | MLdummy _ | MLaxiom -> 0 and ml_size_list l = List.fold_left (fun a t -> a + ml_size t) 0 l diff --git a/plugins/extraction/mlutil.mli b/plugins/extraction/mlutil.mli index 0a71d2c83..c66755249 100644 --- a/plugins/extraction/mlutil.mli +++ b/plugins/extraction/mlutil.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -67,7 +67,8 @@ val type_expunge : abbrev_map -> ml_type -> ml_type val type_expunge_from_sign : abbrev_map -> signature -> ml_type -> ml_type val eq_ml_type : ml_type -> ml_type -> bool -val isDummy : ml_type -> bool +val isTdummy : ml_type -> bool +val isMLdummy : ml_ast -> bool val isKill : sign -> bool val case_expunge : signature -> ml_ast -> ml_ident list * ml_ast @@ -110,6 +111,8 @@ val ast_subst : ml_ast -> ml_ast -> ml_ast val ast_glob_subst : ml_ast Refmap'.t -> ml_ast -> ml_ast +val dump_unused_vars : ml_ast -> ml_ast + val normalize : ml_ast -> ml_ast val optimize_fix : ml_ast -> ml_ast val inline : global_reference -> ml_ast -> bool @@ -125,8 +128,8 @@ exception Impossible type sign_kind = | EmptySig | NonLogicalSig (* at least a [Keep] *) - | UnsafeLogicalSig (* No [Keep], at least a [Kill Kother] *) | SafeLogicalSig (* only [Kill Ktype] *) + | UnsafeLogicalSig (* No [Keep], not all [Kill Ktype] *) val sign_kind : signature -> sign_kind diff --git a/plugins/extraction/modutil.ml b/plugins/extraction/modutil.ml index 8158ac647..b5e8b4804 100644 --- a/plugins/extraction/modutil.ml +++ b/plugins/extraction/modutil.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -100,7 +100,7 @@ let ast_iter_references do_term do_cons do_type a = Array.iter (fun (_,p,_) -> patt_iter_references do_cons p) v | MLrel _ | MLlam _ | MLapp _ | MLletin _ | MLtuple _ | MLfix _ | MLexn _ - | MLdummy | MLaxiom | MLmagic _ -> () + | MLdummy _ | MLaxiom | MLmagic _ -> () in iter a let ind_iter_references do_term do_cons do_type kn ind = @@ -269,7 +269,7 @@ let rec optim_se top to_appear s = function let a = normalize (ast_glob_subst !s a) in let i = inline r a in if i then s := Refmap'.add r a !s; - let d = match optimize_fix a with + let d = match dump_unused_vars (optimize_fix a) with | MLfix (0, _, [|c|]) -> Dfix ([|r|], [|ast_subst (MLglob r) c|], [|t|]) | a -> Dterm (r, a, t) @@ -283,7 +283,8 @@ let rec optim_se top to_appear s = function if inline rv.(i) fake_body then s := Refmap'.add rv.(i) (dfix_to_mlfix rv av i) !s done; - (l,SEdecl (Dfix (rv, av, tv))) :: (optim_se top to_appear s lse) + let av' = Array.map dump_unused_vars av in + (l,SEdecl (Dfix (rv, av', tv))) :: (optim_se top to_appear s lse) | (l,SEmodule m) :: lse -> let m = { m with ml_mod_expr = optim_me to_appear s m.ml_mod_expr} in (l,SEmodule m) :: (optim_se top to_appear s lse) @@ -387,16 +388,15 @@ let is_prefix pre s = in is_prefix_aux 0 -let check_implicits = function - | MLexn s -> - if String.length s > 8 && (s.[0] == 'U' || s.[0] == 'I') then - begin - if is_prefix "UNBOUND" s then assert false; - if is_prefix "IMPLICIT" s then - error_non_implicit (String.sub s 9 (String.length s - 9)); - end; - false - | _ -> false +exception RemainingImplicit of kill_reason + +let check_for_remaining_implicits struc = + let check = function + | MLdummy (Kimplicit _ as k) -> raise (RemainingImplicit k) + | _ -> false + in + try ignore (struct_ast_search check struc) + with RemainingImplicit k -> err_or_warn_remaining_implicit k let optimize_struct to_appear struc = let subst = ref (Refmap'.empty : ml_ast Refmap'.t) in @@ -404,12 +404,16 @@ let optimize_struct to_appear struc = List.map (fun (mp,lse) -> (mp, optim_se true (fst to_appear) subst lse)) struc in - ignore (struct_ast_search check_implicits opt_struc); - if library () then - List.filter (fun (_,lse) -> not (List.is_empty lse)) opt_struc - else begin - reset_needed (); - List.iter add_needed (fst to_appear); - List.iter add_needed_mp (snd to_appear); - depcheck_struct opt_struc - end + let mini_struc = + if library () then + List.filter (fun (_,lse) -> not (List.is_empty lse)) opt_struc + else + begin + reset_needed (); + List.iter add_needed (fst to_appear); + List.iter add_needed_mp (snd to_appear); + depcheck_struct opt_struc + end + in + let () = check_for_remaining_implicits mini_struc in + mini_struc diff --git a/plugins/extraction/modutil.mli b/plugins/extraction/modutil.mli index ca32f0292..dc8708249 100644 --- a/plugins/extraction/modutil.mli +++ b/plugins/extraction/modutil.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml index 8c482b4b1..3cb3810cb 100644 --- a/plugins/extraction/ocaml.ml +++ b/plugins/extraction/ocaml.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -55,29 +55,36 @@ let keywords = "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr" ; "unit" ; "_" ; "__" ] Id.Set.empty -let pp_open mp = str ("open "^ string_of_modfile mp ^"\n") +(* Note: do not shorten [str "foo" ++ fnl ()] into [str "foo\n"], + the '\n' character interacts badly with the Format boxing mechanism *) + +let pp_open mp = str ("open "^ string_of_modfile mp) ++ fnl () let pp_comment s = str "(* " ++ hov 0 s ++ str " *)" let pp_header_comment = function | None -> mt () - | Some com -> pp_comment com ++ fnl () ++ fnl () + | Some com -> pp_comment com ++ fnl2 () + +let then_nl pp = if Pp.is_empty pp then mt () else pp ++ fnl () + +let pp_tdummy usf = + if usf.tdummy || usf.tunknown then str "type __ = Obj.t" ++ fnl () else mt () + +let pp_mldummy usf = + if usf.mldummy then + str "let __ = let rec f _ = Obj.repr f in Obj.repr f" ++ fnl () + else mt () let preamble _ comment used_modules usf = pp_header_comment comment ++ - prlist pp_open used_modules ++ - (if List.is_empty used_modules then mt () else fnl ()) ++ - (if usf.tdummy || usf.tunknown then str "type __ = Obj.t\n" else mt()) ++ - (if usf.mldummy then - str "let __ = let rec f _ = Obj.repr f in Obj.repr f\n" - else mt ()) ++ - (if usf.tdummy || usf.tunknown || usf.mldummy then fnl () else mt ()) + then_nl (prlist pp_open used_modules) ++ + then_nl (pp_tdummy usf ++ pp_mldummy usf) let sig_preamble _ comment used_modules usf = - pp_header_comment comment ++ fnl () ++ fnl () ++ - prlist pp_open used_modules ++ - (if List.is_empty used_modules then mt () else fnl ()) ++ - (if usf.tdummy || usf.tunknown then str "type __ = Obj.t\n\n" else mt()) + pp_header_comment comment ++ + then_nl (prlist pp_open used_modules) ++ + then_nl (pp_tdummy usf) (*s The pretty-printer for Ocaml syntax*) @@ -171,7 +178,11 @@ let rec pp_expr par env args = and apply2 st = pp_apply2 st par args in function | MLrel n -> - let id = get_db_name n env in apply (pr_id id) + let id = get_db_name n env in + (* Try to survive to the occurrence of a Dummy rel. + TODO: we should get rid of this hack (cf. #592) *) + let id = if Id.equal id dummy_name then Id.of_string "__" else id in + apply (pr_id id) | MLapp (f,args') -> let stl = List.map (pp_expr true env []) args' in pp_expr par env (stl @ args) f @@ -199,8 +210,11 @@ let rec pp_expr par env args = | MLexn s -> (* An [MLexn] may be applied, but I don't really care. *) pp_par par (str "assert false" ++ spc () ++ str ("(* "^s^" *)")) - | MLdummy -> - str "__" (* An [MLdummy] may be applied, but I don't really care. *) + | MLdummy k -> + (* An [MLdummy] may be applied, but I don't really care. *) + (match msg_of_implicit k with + | "" -> str "__" + | s -> str "__" ++ spc () ++ str ("(* "^s^" *)")) | MLmagic a -> pp_apply (str "Obj.magic") par (pp_expr true env [] a :: args) | MLaxiom -> @@ -352,7 +366,7 @@ and pp_function env t = | MLcase(Tglob(r,_),MLrel 1,pv) when not (is_coinductive r) && List.is_empty (get_record_fields r) && not (is_custom_match pv) -> - if not (ast_occurs 1 (MLcase(Tunknown,MLdummy,pv))) then + if not (ast_occurs 1 (MLcase(Tunknown,MLaxiom,pv))) then pr_binding (List.rev (List.tl bl)) ++ str " = function" ++ fnl () ++ v 0 (pp_pat env' pv) @@ -378,9 +392,14 @@ and pp_fix par env i (ids,bl) args = fnl () ++ hov 2 (str "in " ++ pp_apply (pr_id ids.(i)) false args))) +(* Ad-hoc double-newline in v boxes, with enough negative whitespace + to avoid indenting the intermediate blank line *) + +let cut2 () = brk (0,-100000) ++ brk (0,0) + let pp_val e typ = hov 4 (str "(** val " ++ e ++ str " :" ++ spc () ++ pp_type false [] typ ++ - str " **)") ++ fnl2 () + str " **)") ++ cut2 () (*s Pretty-printing of [Dfix] *) @@ -389,11 +408,11 @@ let pp_Dfix (rv,c,t) = (fun r -> if is_inline_custom r then mt () else pp_global Term r) rv in let rec pp init i = - if i >= Array.length rv then - (if init then failwith "empty phrase" else mt ()) + if i >= Array.length rv then mt () else let void = is_inline_custom rv.(i) || - (not (is_custom rv.(i)) && match c.(i) with MLexn "UNUSED" -> true | _ -> false) + (not (is_custom rv.(i)) && + match c.(i) with MLexn "UNUSED" -> true | _ -> false) in if void then pp init (i+1) else @@ -401,7 +420,7 @@ let pp_Dfix (rv,c,t) = if is_custom rv.(i) then str " = " ++ str (find_custom rv.(i)) else pp_function (empty_env ()) c.(i) in - (if init then mt () else fnl2 ()) ++ + (if init then mt () else cut2 ()) ++ pp_val names.(i) t.(i) ++ str (if init then "let rec " else "and ") ++ names.(i) ++ def ++ pp false (i+1) @@ -466,8 +485,8 @@ let pp_coind pl name = let pp_ind co kn ind = let prefix = if co then "__" else "" in - let some = ref false in - let init= ref (str "type ") in + let initkwd = str "type " in + let nextkwd = fnl () ++ str "and " in let names = Array.mapi (fun i p -> if p.ip_logical then mt () else pp_global Type (IndRef (kn,i))) @@ -480,29 +499,20 @@ let pp_ind co kn ind = p.ip_types) ind.ind_packets in - let rec pp i = + let rec pp i kwd = if i >= Array.length ind.ind_packets then mt () else let ip = (kn,i) in let ip_equiv = ind.ind_equiv, i in let p = ind.ind_packets.(i) in - if is_custom (IndRef ip) then pp (i+1) - else begin - some := true; - if p.ip_logical then pp_logical_ind p ++ pp (i+1) - else - let s = !init in - begin - init := (fnl () ++ str "and "); - s ++ - (if co then pp_coind p.ip_vars names.(i) else mt ()) ++ - pp_one_ind - prefix ip_equiv p.ip_vars names.(i) cnames.(i) p.ip_types ++ - pp (i+1) - end - end + if is_custom (IndRef ip) then pp (i+1) kwd + else if p.ip_logical then pp_logical_ind p ++ pp (i+1) kwd + else + kwd ++ (if co then pp_coind p.ip_vars names.(i) else mt ()) ++ + pp_one_ind prefix ip_equiv p.ip_vars names.(i) cnames.(i) p.ip_types ++ + pp (i+1) nextkwd in - let st = pp 0 in if !some then st else failwith "empty phrase" + pp 0 initkwd (*s Pretty-printing of a declaration. *) @@ -515,8 +525,8 @@ let pp_mind kn i = | Standard -> pp_ind false kn i let pp_decl = function - | Dtype (r,_,_) when is_inline_custom r -> failwith "empty phrase" - | Dterm (r,_,_) when is_inline_custom r -> failwith "empty phrase" + | Dtype (r,_,_) when is_inline_custom r -> mt () + | Dterm (r,_,_) when is_inline_custom r -> mt () | Dind (kn,i) -> pp_mind kn i | Dtype (r, l, t) -> let name = pp_global Type r in @@ -524,13 +534,13 @@ let pp_decl = function let ids, def = try let ids,s = find_type_custom r in - pp_string_parameters ids, str "=" ++ spc () ++ str s + pp_string_parameters ids, str " =" ++ spc () ++ str s with Not_found -> pp_parameters l, - if t == Taxiom then str "(* AXIOM TO BE REALIZED *)" - else str "=" ++ spc () ++ pp_type false l t + if t == Taxiom then str " (* AXIOM TO BE REALIZED *)" + else str " =" ++ spc () ++ pp_type false l t in - hov 2 (str "type " ++ ids ++ name ++ spc () ++ def) + hov 2 (str "type " ++ ids ++ name ++ def) | Dterm (r, a, t) -> let def = if is_custom r then str (" = " ^ find_custom r) @@ -564,8 +574,8 @@ let pp_alias_decl ren = function rv let pp_spec = function - | Sval (r,_) when is_inline_custom r -> failwith "empty phrase" - | Stype (r,_,_) when is_inline_custom r -> failwith "empty phrase" + | Sval (r,_) when is_inline_custom r -> mt () + | Stype (r,_,_) when is_inline_custom r -> mt () | Sind (kn,i) -> pp_mind kn i | Sval (r,t) -> let def = pp_type false [] t in @@ -577,15 +587,15 @@ let pp_spec = function let ids, def = try let ids, s = find_type_custom r in - pp_string_parameters ids, str "= " ++ str s + pp_string_parameters ids, str " =" ++ spc () ++ str s with Not_found -> let ids = pp_parameters l in match ot with | None -> ids, mt () - | Some Taxiom -> ids, str "(* AXIOM TO BE REALIZED *)" - | Some t -> ids, str "=" ++ spc () ++ pp_type false l t + | Some Taxiom -> ids, str " (* AXIOM TO BE REALIZED *)" + | Some t -> ids, str " =" ++ spc () ++ pp_type false l t in - hov 2 (str "type " ++ ids ++ name ++ spc () ++ def) + hov 2 (str "type " ++ ids ++ name ++ def) let pp_alias_spec ren = function | Sind (kn,i) -> pp_mind kn { i with ind_equiv = RenEquiv ren } @@ -602,7 +612,7 @@ let rec pp_specif = function | (l,Spec s) -> (try let ren = Common.check_duplicate (top_visible_mp ()) l in - hov 1 (str ("module "^ren^" : sig ") ++ fnl () ++ pp_spec s) ++ + hov 1 (str ("module "^ren^" : sig") ++ fnl () ++ pp_spec s) ++ fnl () ++ str "end" ++ fnl () ++ pp_alias_spec ren s with Not_found -> pp_spec s) @@ -610,15 +620,15 @@ let rec pp_specif = function let def = pp_module_type [] mt in let def' = pp_module_type [] mt in let name = pp_modname (MPdot (top_visible_mp (), l)) in - hov 1 (str "module " ++ name ++ str " : " ++ fnl () ++ def) ++ + hov 1 (str "module " ++ name ++ str " :" ++ fnl () ++ def) ++ (try let ren = Common.check_duplicate (top_visible_mp ()) l in - fnl () ++ hov 1 (str ("module "^ren^" : ") ++ fnl () ++ def') + fnl () ++ hov 1 (str ("module "^ren^" :") ++ fnl () ++ def') with Not_found -> Pp.mt ()) | (l,Smodtype mt) -> let def = pp_module_type [] mt in let name = pp_modname (MPdot (top_visible_mp (), l)) in - hov 1 (str "module type " ++ name ++ str " = " ++ fnl () ++ def) ++ + hov 1 (str "module type " ++ name ++ str " =" ++ fnl () ++ def) ++ (try let ren = Common.check_duplicate (top_visible_mp ()) l in fnl () ++ str ("module type "^ren^" = ") ++ name @@ -635,14 +645,15 @@ and pp_module_type params = function | MTsig (mp, sign) -> push_visible mp params; let try_pp_specif l x = - try pp_specif x :: l with Failure "empty phrase" -> l + let px = pp_specif x in + if Pp.is_empty px then l else px::l in (* We cannot use fold_right here due to side effects in pp_specif *) let l = List.fold_left try_pp_specif [] sign in let l = List.rev l in pop_visible (); - str "sig " ++ fnl () ++ - v 1 (str " " ++ prlist_with_sep fnl2 identity l) ++ + str "sig" ++ fnl () ++ + v 1 (str " " ++ prlist_with_sep cut2 identity l) ++ fnl () ++ str "end" | MTwith(mt,ML_With_type(idl,vl,typ)) -> let ids = pp_parameters (rename_tvars keywords vl) in @@ -672,7 +683,7 @@ let rec pp_structure_elem = function | (l,SEdecl d) -> (try let ren = Common.check_duplicate (top_visible_mp ()) l in - hov 1 (str ("module "^ren^" = struct ") ++ fnl () ++ pp_decl d) ++ + hov 1 (str ("module "^ren^" = struct") ++ fnl () ++ pp_decl d) ++ fnl () ++ str "end" ++ fnl () ++ pp_alias_decl ren d with Not_found -> pp_decl d) @@ -686,8 +697,8 @@ let rec pp_structure_elem = function let def = pp_module_expr [] m.ml_mod_expr in let name = pp_modname (MPdot (top_visible_mp (), l)) in hov 1 - (str "module " ++ name ++ typ ++ str " = " ++ - (if (is_short m.ml_mod_expr) then mt () else fnl ()) ++ def) ++ + (str "module " ++ name ++ typ ++ str " =" ++ + (if is_short m.ml_mod_expr then spc () else fnl ()) ++ def) ++ (try let ren = Common.check_duplicate (top_visible_mp ()) l in fnl () ++ str ("module "^ren^" = ") ++ name @@ -695,7 +706,7 @@ let rec pp_structure_elem = function | (l,SEmodtype m) -> let def = pp_module_type [] m in let name = pp_modname (MPdot (top_visible_mp (), l)) in - hov 1 (str "module type " ++ name ++ str " = " ++ fnl () ++ def) ++ + hov 1 (str "module type " ++ name ++ str " =" ++ fnl () ++ def) ++ (try let ren = Common.check_duplicate (top_visible_mp ()) l in fnl () ++ str ("module type "^ren^" = ") ++ name @@ -713,36 +724,42 @@ and pp_module_expr params = function | MEstruct (mp, sel) -> push_visible mp params; let try_pp_structure_elem l x = - try pp_structure_elem x :: l with Failure "empty phrase" -> l + let px = pp_structure_elem x in + if Pp.is_empty px then l else px::l in (* We cannot use fold_right here due to side effects in pp_structure_elem *) let l = List.fold_left try_pp_structure_elem [] sel in let l = List.rev l in pop_visible (); - str "struct " ++ fnl () ++ - v 1 (str " " ++ prlist_with_sep fnl2 identity l) ++ + str "struct" ++ fnl () ++ + v 1 (str " " ++ prlist_with_sep cut2 identity l) ++ fnl () ++ str "end" +let rec prlist_sep_nonempty sep f = function + | [] -> mt () + | [h] -> f h + | h::t -> + let e = f h in + let r = prlist_sep_nonempty sep f t in + if Pp.is_empty e then r + else e ++ sep () ++ r + let do_struct f s = - let pp s = try f s ++ fnl2 () with Failure "empty phrase" -> mt () - in let ppl (mp,sel) = push_visible mp []; - let p = prlist_strict pp sel in + let p = prlist_sep_nonempty cut2 f sel in (* for monolithic extraction, we try to simulate the unavailability of [MPfile] in names by artificially nesting these [MPfile] *) (if modular () then pop_visible ()); p in - let p = prlist_strict ppl s in + let p = prlist_sep_nonempty cut2 ppl s in (if not (modular ()) then repeat (List.length s) pop_visible ()); - p + v 0 p ++ fnl () let pp_struct s = do_struct pp_structure_elem s let pp_signature s = do_struct pp_specif s -let pp_decl d = try pp_decl d with Failure "empty phrase" -> mt () - let ocaml_descr = { keywords = keywords; file_suffix = ".ml"; @@ -754,5 +771,3 @@ let ocaml_descr = { pp_sig = pp_signature; pp_decl = pp_decl; } - - diff --git a/plugins/extraction/ocaml.mli b/plugins/extraction/ocaml.mli index 4e796792e..f579a54b8 100644 --- a/plugins/extraction/ocaml.mli +++ b/plugins/extraction/ocaml.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/extraction/scheme.ml b/plugins/extraction/scheme.ml index cc8b6d8e7..7b0f14dff 100644 --- a/plugins/extraction/scheme.ml +++ b/plugins/extraction/scheme.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -126,7 +126,7 @@ let rec pp_expr env args = | MLexn s -> (* An [MLexn] may be applied, but I don't really care. *) paren (str "error" ++ spc () ++ qs s) - | MLdummy -> + | MLdummy _ -> str "__" (* An [MLdummy] may be applied, but I don't really care. *) | MLmagic a -> pp_expr env args a @@ -183,7 +183,8 @@ let pp_decl = function prvecti (fun i r -> let void = is_inline_custom r || - (not (is_custom r) && match defs.(i) with MLexn "UNUSED" -> true | _ -> false) + (not (is_custom r) && + match defs.(i) with MLexn "UNUSED" -> true | _ -> false) in if void then mt () else diff --git a/plugins/extraction/scheme.mli b/plugins/extraction/scheme.mli index f0e36e09d..5e1ec0d5e 100644 --- a/plugins/extraction/scheme.mli +++ b/plugins/extraction/scheme.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index a57c39eef..466c8054b 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -72,8 +72,6 @@ let mp_length mp = | _ -> 1 in len mp -let visible_con kn = at_toplevel (base_mp (con_modpath kn)) - let rec prefixes_mp mp = match mp with | MPdot (mp',_) -> MPset.add mp (prefixes_mp mp') | _ -> MPset.singleton mp @@ -105,17 +103,30 @@ let labels_of_ref r = (* Theses tables are not registered within coq save/undo mechanism since we reset their contents at each run of Extraction *) -(*s Constants tables. *) +(* We use [constant_body] (resp. [mutual_inductive_body]) as checksum + to ensure that the table contents aren't outdated. *) -let terms = ref (Cmap_env.empty : ml_decl Cmap_env.t) -let init_terms () = terms := Cmap_env.empty -let add_term kn d = terms := Cmap_env.add kn d !terms -let lookup_term kn = Cmap_env.find kn !terms +(*s Constants tables. *) -let types = ref (Cmap_env.empty : ml_schema Cmap_env.t) -let init_types () = types := Cmap_env.empty -let add_type kn s = types := Cmap_env.add kn s !types -let lookup_type kn = Cmap_env.find kn !types +let typedefs = ref (Cmap_env.empty : (constant_body * ml_type) Cmap_env.t) +let init_typedefs () = typedefs := Cmap_env.empty +let add_typedef kn cb t = + typedefs := Cmap_env.add kn (cb,t) !typedefs +let lookup_typedef kn cb = + try + let (cb0,t) = Cmap_env.find kn !typedefs in + if cb0 == cb then Some t else None + with Not_found -> None + +let cst_types = + ref (Cmap_env.empty : (constant_body * ml_schema) Cmap_env.t) +let init_cst_types () = cst_types := Cmap_env.empty +let add_cst_type kn cb s = cst_types := Cmap_env.add kn (cb,s) !cst_types +let lookup_cst_type kn cb = + try + let (cb0,s) = Cmap_env.find kn !cst_types in + if cb0 == cb then Some s else None + with Not_found -> None (*s Inductives table. *) @@ -124,7 +135,14 @@ let inductives = let init_inductives () = inductives := Mindmap_env.empty let add_ind kn mib ml_ind = inductives := Mindmap_env.add kn (mib,ml_ind) !inductives -let lookup_ind kn = Mindmap_env.find kn !inductives +let lookup_ind kn mib = + try + let (mib0,ml_ind) = Mindmap_env.find kn !inductives in + if mib == mib0 then Some ml_ind + else None + with Not_found -> None + +let unsafe_lookup_ind kn = snd (Mindmap_env.find kn !inductives) let inductive_kinds = ref (Mindmap_env.empty : inductive_kind Mindmap_env.t) @@ -244,10 +262,10 @@ let safe_basename_of_global r = | ConstRef kn -> Label.to_id (con_label kn) | IndRef (kn,0) -> Label.to_id (mind_label kn) | IndRef (kn,i) -> - (try (snd (lookup_ind kn)).ind_packets.(i).ip_typename + (try (unsafe_lookup_ind kn).ind_packets.(i).ip_typename with Not_found -> last_chance r) | ConstructRef ((kn,i),j) -> - (try (snd (lookup_ind kn)).ind_packets.(i).ip_consnames.(j-1) + (try (unsafe_lookup_ind kn).ind_packets.(i).ip_consnames.(j-1) with Not_found -> last_chance r) | VarRef _ -> assert false @@ -401,23 +419,41 @@ let error_MPfile_as_mod mp b = "Monolithic Extraction cannot deal with this situation.\n"^ "Please "^s2^"use (Recursive) Extraction Library instead.\n")) -let msg_non_implicit r n id = - let name = match id with - | Anonymous -> "" - | Name id -> "(" ^ Id.to_string id ^ ") " - in - "The " ^ (String.ordinal n) ^ " argument " ^ name ^ "of " ^ (string_of_global r) - -let error_non_implicit msg = - err (str (msg ^ " still occurs after extraction.") ++ - fnl () ++ str "Please check the Extraction Implicit declarations.") +let argnames_of_global r = + let typ = Global.type_of_global_unsafe r in + let rels,_ = + decompose_prod (Reduction.whd_betadeltaiota (Global.env ()) typ) in + List.rev_map fst rels + +let msg_of_implicit = function + | Kimplicit (r,i) -> + let name = match List.nth (argnames_of_global r) (i-1) with + | Anonymous -> "" + | Name id -> "(" ^ Id.to_string id ^ ") " + in + (String.ordinal i)^" argument "^name^"of "^(string_of_global r) + | Ktype | Kprop -> "" + +let error_remaining_implicit k = + let s = msg_of_implicit k in + err (str ("An implicit occurs after extraction : "^s^".") ++ fnl () ++ + str "Please check your Extraction Implicit declarations." ++ fnl() ++ + str "You might also try Unset Extraction SafeImplicits to force" ++ + fnl() ++ str "the extraction of unsafe code and review it manually.") + +let warning_remaining_implicit k = + let s = msg_of_implicit k in + msg_warning + (str ("At least an implicit occurs after extraction : "^s^".") ++ fnl () ++ + str "Extraction SafeImplicits is unset, extracting nonetheless," ++ fnl () + ++ str "but this code is potentially unsafe, please review it manually.") let check_loaded_modfile mp = match base_mp mp with | MPfile dp -> if not (Library.library_is_loaded dp) then begin match base_mp (Lib.current_mp ()) with | MPfile dp' when not (DirPath.equal dp dp') -> - err (str ("Please load library "^(DirPath.to_string dp^" first."))) + err (str "Please load library " ++ pr_dirpath dp ++ str " first.") | _ -> () end | _ -> () @@ -635,32 +671,39 @@ let reset_extraction_inline () = Lib.add_anonymous_leaf (reset_inline ()) (*s Extraction Implicit *) +let safe_implicit = my_bool_option "SafeImplicits" true + +let err_or_warn_remaining_implicit k = + if safe_implicit () then + error_remaining_implicit k + else + warning_remaining_implicit k + type int_or_id = ArgInt of int | ArgId of Id.t let implicits_table = Summary.ref Refmap'.empty ~name:"ExtrImplicit" let implicits_of_global r = - try Refmap'.find r !implicits_table with Not_found -> [] + try Refmap'.find r !implicits_table with Not_found -> Int.Set.empty let add_implicits r l = - let typ = Global.type_of_global_unsafe r in - let rels,_ = - decompose_prod (Reduction.whd_betadeltaiota (Global.env ()) typ) in - let names = List.rev_map fst rels in + let names = argnames_of_global r in let n = List.length names in - let check = function + let add_arg s = function | ArgInt i -> - if 1 <= i && i <= n then i + if 1 <= i && i <= n then Int.Set.add i s else err (int i ++ str " is not a valid argument number for " ++ safe_pr_global r) | ArgId id -> - (try List.index Name.equal (Name id) names - with Not_found -> - err (str "No argument " ++ pr_id id ++ str " for " ++ - safe_pr_global r)) + try + let i = List.index Name.equal (Name id) names in + Int.Set.add i s + with Not_found -> + err (str "No argument " ++ pr_id id ++ str " for " ++ + safe_pr_global r) in - let l' = List.map check l in - implicits_table := Refmap'.add r l' !implicits_table + let ints = List.fold_left add_arg Int.Set.empty l in + implicits_table := Refmap'.add r ints !implicits_table (* Registration of operations for rollback. *) @@ -851,6 +894,6 @@ let extract_inductive r s l optstr = (*s Tables synchronization. *) let reset_tables () = - init_terms (); init_types (); init_inductives (); + init_typedefs (); init_cst_types (); init_inductives (); init_inductive_kinds (); init_recursors (); init_projs (); init_axioms (); init_opaques (); reset_modfile () diff --git a/plugins/extraction/table.mli b/plugins/extraction/table.mli index 648f23211..2b163610e 100644 --- a/plugins/extraction/table.mli +++ b/plugins/extraction/table.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -13,7 +13,7 @@ open Miniml open Declarations module Refset' : CSig.SetS with type elt = global_reference -module Refmap' : Map.S with type key = global_reference +module Refmap' : CSig.MapS with type key = global_reference val safe_basename_of_global : global_reference -> Id.t @@ -38,8 +38,8 @@ val error_MPfile_as_mod : module_path -> bool -> 'a val check_inside_module : unit -> unit val check_inside_section : unit -> unit val check_loaded_modfile : module_path -> unit -val msg_non_implicit : global_reference -> int -> Name.t -> string -val error_non_implicit : string -> 'a +val msg_of_implicit : kill_reason -> string +val err_or_warn_remaining_implicit : kill_reason -> unit val info_file : string -> unit @@ -55,7 +55,6 @@ val string_of_modfile : module_path -> string val file_of_modfile : module_path -> string val is_toplevel : module_path -> bool val at_toplevel : module_path -> bool -val visible_con : constant -> bool val mp_length : module_path -> int val prefixes_mp : module_path -> MPset.t val common_prefix_from_list : @@ -65,14 +64,22 @@ val labels_of_ref : global_reference -> module_path * Label.t list (*s Some table-related operations *) -val add_term : constant -> ml_decl -> unit -val lookup_term : constant -> ml_decl +(* For avoiding repeated extraction of the same constant or inductive, + we use cache functions below. Indexing by constant name isn't enough, + due to modules we could have a same constant name but different + content. So we check that the [constant_body] hasn't changed from + recording time to retrieving time. Same for inductive : we store + [mutual_inductive_body] as checksum. In both case, we should ideally + also check the env *) -val add_type : constant -> ml_schema -> unit -val lookup_type : constant -> ml_schema +val add_typedef : constant -> constant_body -> ml_type -> unit +val lookup_typedef : constant -> constant_body -> ml_type option + +val add_cst_type : constant -> constant_body -> ml_schema -> unit +val lookup_cst_type : constant -> constant_body -> ml_schema option val add_ind : mutual_inductive -> mutual_inductive_body -> ml_ind -> unit -val lookup_ind : mutual_inductive -> mutual_inductive_body * ml_ind +val lookup_ind : mutual_inductive -> mutual_inductive_body -> ml_ind option val add_inductive_kind : mutual_inductive -> inductive_kind -> unit val is_coinductive : global_reference -> bool @@ -166,7 +173,7 @@ val to_keep : global_reference -> bool (*s Table for implicits arguments *) -val implicits_of_global : global_reference -> int list +val implicits_of_global : global_reference -> Int.Set.t (*s Table for user-given custom ML extractions. *) diff --git a/plugins/firstorder/formula.ml b/plugins/firstorder/formula.ml index 62a8605a3..2ed436c6b 100644 --- a/plugins/firstorder/formula.ml +++ b/plugins/firstorder/formula.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -15,6 +15,7 @@ open Tacmach open Util open Declarations open Globnames +open Context.Rel.Declaration let qflag=ref true @@ -139,8 +140,8 @@ let build_atoms gl metagen side cciterm = negative:= unsigned :: !negative end; let v = ind_hyps 0 i l gl in - let g i _ (_,_,t) = - build_rec env polarity (lift i t) in + let g i _ decl = + build_rec env polarity (lift i (get_type decl)) in let f l = List.fold_left_i g (1-(List.length l)) () l in if polarity && (* we have a constant constructor *) @@ -150,8 +151,8 @@ let build_atoms gl metagen side cciterm = | Exists(i,l)-> let var=mkMeta (metagen true) in let v =(ind_hyps 1 i l gl).(0) in - let g i _ (_,_,t) = - build_rec (var::env) polarity (lift i t) in + let g i _ decl = + build_rec (var::env) polarity (lift i (get_type decl)) in List.fold_left_i g (2-(List.length l)) () v | Forall(_,b)-> let var=mkMeta (metagen true) in @@ -224,7 +225,7 @@ let build_formula side nam typ gl metagen= | And(_,_,_) -> Rand | Or(_,_,_) -> Ror | Exists (i,l) -> - let (_,_,d)=List.last (ind_hyps 0 i l gl).(0) in + let d = get_type (List.last (ind_hyps 0 i l gl).(0)) in Rexists(m,d,trivial) | Forall (_,a) -> Rforall | Arrow (a,b) -> Rarrow in diff --git a/plugins/firstorder/formula.mli b/plugins/firstorder/formula.mli index 6c7b09383..0f70d3ea0 100644 --- a/plugins/firstorder/formula.mli +++ b/plugins/firstorder/formula.mli @@ -1,13 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) open Term -open Context open Globnames val qflag : bool ref @@ -27,7 +26,7 @@ type counter = bool -> metavariable val construct_nhyps : pinductive -> Proof_type.goal Tacmach.sigma -> int array val ind_hyps : int -> pinductive -> constr list -> - Proof_type.goal Tacmach.sigma -> rel_context array + Proof_type.goal Tacmach.sigma -> Context.Rel.t array type atoms = {positive:constr list;negative:constr list} diff --git a/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.ml4 index c28da42ae..587d10d1c 100644 --- a/plugins/firstorder/g_ground.ml4 +++ b/plugins/firstorder/g_ground.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -15,6 +15,10 @@ open Goptions open Tacticals open Tacinterp open Libnames +open Constrarg +open Stdarg +open Pcoq.Prim +open Pcoq.Tactic DECLARE PLUGIN "ground_plugin" @@ -52,8 +56,15 @@ let _= in declare_int_option gdopt +let default_intuition_tac = + let tac _ _ = Auto.h_auto None [] None in + let name = { Tacexpr.mltac_plugin = "ground_plugin"; mltac_tactic = "auto_with"; } in + let entry = { Tacexpr.mltac_name = name; mltac_index = 0 } in + Tacenv.register_ml_tactic name [| tac |]; + Tacexpr.TacML (Loc.ghost, entry, []) + let (set_default_solver, default_solver, print_default_solver) = - Tactic_option.declare_tactic_option ~default:(<:tactic<auto with *>>) "Firstorder default solver" + Tactic_option.declare_tactic_option ~default:default_intuition_tac "Firstorder default solver" VERNAC COMMAND EXTEND Firstorder_Set_Solver CLASSIFIED AS SIDEFF | [ "Set" "Firstorder" "Solver" tactic(t) ] -> [ @@ -128,17 +139,17 @@ END TACTIC EXTEND firstorder [ "firstorder" tactic_opt(t) firstorder_using(l) ] -> - [ Proofview.V82.tactic (gen_ground_tac true (Option.map eval_tactic t) l []) ] + [ Proofview.V82.tactic (gen_ground_tac true (Option.map (tactic_of_value ist) t) l []) ] | [ "firstorder" tactic_opt(t) "with" ne_preident_list(l) ] -> - [ Proofview.V82.tactic (gen_ground_tac true (Option.map eval_tactic t) [] l) ] + [ Proofview.V82.tactic (gen_ground_tac true (Option.map (tactic_of_value ist) t) [] l) ] | [ "firstorder" tactic_opt(t) firstorder_using(l) "with" ne_preident_list(l') ] -> - [ Proofview.V82.tactic (gen_ground_tac true (Option.map eval_tactic t) l l') ] + [ Proofview.V82.tactic (gen_ground_tac true (Option.map (tactic_of_value ist) t) l l') ] END TACTIC EXTEND gintuition [ "gintuition" tactic_opt(t) ] -> - [ Proofview.V82.tactic (gen_ground_tac false (Option.map eval_tactic t) [] []) ] + [ Proofview.V82.tactic (gen_ground_tac false (Option.map (tactic_of_value ist) t) [] []) ] END open Proofview.Notations diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml index 2248b6693..3b9f67f66 100644 --- a/plugins/firstorder/ground.ml +++ b/plugins/firstorder/ground.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/firstorder/ground.mli b/plugins/firstorder/ground.mli index 5b3207860..b5669463c 100644 --- a/plugins/firstorder/ground.mli +++ b/plugins/firstorder/ground.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index c80a8081a..0bc40136c 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -22,6 +22,8 @@ open Formula open Sequent open Names open Misctypes +open Sigma.Notations +open Context.Rel.Declaration let compare_instance inst1 inst2= match inst1,inst2 with @@ -116,8 +118,10 @@ let mk_open_instance id idc gl m t= let rec aux n avoid env evmap decls = if Int.equal n 0 then evmap, decls else let nid=(fresh_id avoid var_id gl) in - let evmap, (c, _) = Evarutil.new_type_evar env evmap Evd.univ_flexible in - let decl = (Name nid,None,c) in + let evmap = Sigma.Unsafe.of_evar_map evmap in + let Sigma ((c, _), evmap, _) = Evarutil.new_type_evar env evmap Evd.univ_flexible in + let evmap = Sigma.to_evar_map evmap in + let decl = LocalAssum (Name nid, c) in aux (n-1) (nid::avoid) (Environ.push_rel decl env) evmap (decl::decls) in let evmap, decls = aux m [] env evmap [] in evmap, decls, revt diff --git a/plugins/firstorder/instances.mli b/plugins/firstorder/instances.mli index 2f69ad7b5..ce711f3f9 100644 --- a/plugins/firstorder/instances.mli +++ b/plugins/firstorder/instances.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml index 382d5409b..c05015c53 100644 --- a/plugins/firstorder/rules.ml +++ b/plugins/firstorder/rules.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -19,6 +19,7 @@ open Formula open Sequent open Globnames open Locus +open Context.Named.Declaration type seqtac= (Sequent.t -> tactic) -> Sequent.t -> tactic @@ -34,12 +35,13 @@ let wrap n b continue seq gls= if i<=0 then seq else match nc with []->anomaly (Pp.str "Not the expected number of hyps") - | ((id,_,typ) as nd)::q-> + | nd::q-> + let id = get_id nd in if occur_var env id (pf_concl gls) || List.exists (occur_var_in_decl env id) ctx then (aux (i-1) q (nd::ctx)) else - add_formula Hyp (VarRef id) typ (aux (i-1) q (nd::ctx)) gls in + add_formula Hyp (VarRef id) (get_type nd) (aux (i-1) q (nd::ctx)) gls in let seq1=aux n nc [] in let seq2=if b then add_formula Concl dummy_id (pf_concl gls) seq1 gls else seq1 in @@ -210,6 +212,6 @@ let defined_connectives=lazy let normalize_evaluables= onAllHypsAndConcl (function - None->unfold_in_concl (Lazy.force defined_connectives) + None-> Proofview.V82.of_tactic (unfold_in_concl (Lazy.force defined_connectives)) | Some id -> - unfold_in_hyp (Lazy.force defined_connectives) (id,InHypTypeOnly)) + Proofview.V82.of_tactic (unfold_in_hyp (Lazy.force defined_connectives) (id,InHypTypeOnly))) diff --git a/plugins/firstorder/rules.mli b/plugins/firstorder/rules.mli index 596e8535f..381b7cd87 100644 --- a/plugins/firstorder/rules.mli +++ b/plugins/firstorder/rules.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml index a77af03dc..3e8033da0 100644 --- a/plugins/firstorder/sequent.ml +++ b/plugins/firstorder/sequent.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/firstorder/sequent.mli b/plugins/firstorder/sequent.mli index dc3f05be6..06c9251e7 100644 --- a/plugins/firstorder/sequent.mli +++ b/plugins/firstorder/sequent.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -13,7 +13,7 @@ open Globnames module OrderedConstr: Set.OrderedType with type t=constr -module CM: Map.S with type key=constr +module CM: CSig.MapS with type key=constr type h_item = global_reference * (int*constr) option diff --git a/plugins/firstorder/unify.ml b/plugins/firstorder/unify.ml index 0a1720340..d9ab36ad6 100644 --- a/plugins/firstorder/unify.ml +++ b/plugins/firstorder/unify.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/firstorder/unify.mli b/plugins/firstorder/unify.mli index 153185467..4fe9ad38d 100644 --- a/plugins/firstorder/unify.mli +++ b/plugins/firstorder/unify.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/fourier/Fourier.v b/plugins/fourier/Fourier.v index 1832de85b..1d7ee93ea 100644 --- a/plugins/fourier/Fourier.v +++ b/plugins/fourier/Fourier.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/fourier/Fourier_util.v b/plugins/fourier/Fourier_util.v index 284d220af..d4b0e2e10 100644 --- a/plugins/fourier/Fourier_util.v +++ b/plugins/fourier/Fourier_util.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/fourier/fourier.ml b/plugins/fourier/fourier.ml index 50a5150dd..4919232c9 100644 --- a/plugins/fourier/fourier.ml +++ b/plugins/fourier/fourier.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml index e5c9b2707..8bc84608e 100644 --- a/plugins/fourier/fourierR.ml +++ b/plugins/fourier/fourierR.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -413,13 +413,6 @@ let tac_zero_infeq_false gl (n,d) = (tac_zero_inf_pos gl (-n,d))) ;; -let create_meta () = mkMeta(Evarutil.new_meta());; - -let my_cut c gl= - let concl = pf_concl gl in - apply_type (mkProd(Anonymous,c,concl)) [create_meta()] gl -;; - let exact = exact_check;; let tac_use h = @@ -452,7 +445,11 @@ let is_ineq (h,t) = ;; *) -let list_of_sign s = List.map (fun (x,_,z)->(x,z)) s;; +let list_of_sign s = + let open Context.Named.Declaration in + List.map (function LocalAssum (name, typ) -> name, typ + | LocalDef (name, _, typ) -> name, typ) + s;; let mkAppL a = let l = Array.to_list a in @@ -587,7 +584,7 @@ let rec fourier () = then tac_zero_inf_false gl (rational_to_fraction cres) else tac_zero_infeq_false gl (rational_to_fraction cres) in - tac:=(Tacticals.New.tclTHENS (Proofview.V82.tactic (my_cut ineq)) + tac:=(Tacticals.New.tclTHENS (cut ineq) [Tacticals.New.tclTHEN (change_concl (mkAppL [| get coq_not; ineq|] )) diff --git a/plugins/fourier/g_fourier.ml4 b/plugins/fourier/g_fourier.ml4 index d00f0564f..7c665ae7b 100644 --- a/plugins/fourier/g_fourier.ml4 +++ b/plugins/fourier/g_fourier.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/funind/Recdef.v b/plugins/funind/Recdef.v index a63941f0c..e4433247b 100644 --- a/plugins/funind/Recdef.v +++ b/plugins/funind/Recdef.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index c9dd18a2f..02cd819f4 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -3,18 +3,19 @@ open Errors open Util open Term open Vars -open Context open Namegen open Names open Declarations open Pp open Tacmach +open Termops open Proof_type open Tacticals open Tactics open Indfun_common open Libnames open Globnames +open Context.Rel.Declaration (* let msgnl = Pp.msgnl *) @@ -229,7 +230,7 @@ let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta -let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = +let change_eq env sigma hyp_id (context:Context.Rel.t) x t end_of_type = let nochange ?t' msg = begin observe (str ("Not treating ( "^msg^" )") ++ pr_lconstr t ++ str " " ++ match t' with None -> str "" | Some t -> Printer.pr_lconstr t ); @@ -304,11 +305,11 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = in let new_type_of_hyp,ctxt_size,witness_fun = List.fold_left_i - (fun i (end_of_type,ctxt_size,witness_fun) ((x',b',t') as decl) -> + (fun i (end_of_type,ctxt_size,witness_fun) decl -> try let witness = Int.Map.find i sub in - if not (Option.is_empty b') then anomaly (Pp.str "can not redefine a rel!"); - (Termops.pop end_of_type,ctxt_size,mkLetIn(x',witness,t',witness_fun)) + if is_local_def decl then anomaly (Pp.str "can not redefine a rel!"); + (Termops.pop end_of_type,ctxt_size,mkLetIn (get_name decl, witness, get_type decl, witness_fun)) with Not_found -> (mkProd_or_LetIn decl end_of_type, ctxt_size + 1, mkLambda_or_LetIn decl witness_fun) ) @@ -371,12 +372,12 @@ let isLetIn t = | _ -> false -let h_reduce_with_zeta = - reduce +let h_reduce_with_zeta cl = + Proofview.V82.of_tactic (reduce (Genredexpr.Cbv {Redops.all_flags with Genredexpr.rDelta = false; - }) + }) cl) @@ -536,7 +537,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = (scan_type new_context new_t') with Failure "NoChange" -> (* Last thing todo : push the rel in the context and continue *) - scan_type ((x,None,t_x)::context) t' + scan_type (LocalAssum (x,t_x) :: context) t' end end else @@ -705,9 +706,9 @@ let build_proof in tclTHENSEQ [ - Simple.generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps)); + generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps)); thin dyn_infos.rec_hyps; - pattern_option [Locus.AllOccurrencesBut [1],t] None; + Proofview.V82.of_tactic (pattern_option [Locus.AllOccurrencesBut [1],t] None); (fun g -> observe_tac "toto" ( tclTHENSEQ [Proofview.V82.of_tactic (Simple.case t); (fun g' -> @@ -736,7 +737,8 @@ let build_proof tclTHEN (Proofview.V82.of_tactic intro) (fun g' -> - let (id,_,_) = pf_last_hyp g' in + let open Context.Named.Declaration in + let id = pf_last_hyp g' |> get_id in let new_term = pf_nf_betaiota g' (mkApp(dyn_infos.info,[|mkVar id|])) @@ -921,7 +923,9 @@ let generalize_non_dep hyp g = let env = Global.env () 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) -> + let open Context.Named.Declaration in + Environ.fold_named_context_reverse (fun (clear,keep) decl -> + let hyp = get_id decl in if Id.List.mem hyp hyps || List.exists (Termops.occur_var_in_decl env hyp) keep || Termops.occur_var env hyp hyp_typ @@ -932,11 +936,11 @@ let generalize_non_dep hyp g = in (* observe (str "to_revert := " ++ prlist_with_sep spc Ppconstr.pr_id to_revert); *) tclTHEN - ((* observe_tac "h_generalize" *) (Simple.generalize (List.map mkVar to_revert) )) + ((* observe_tac "h_generalize" *) (generalize (List.map mkVar to_revert) )) ((* observe_tac "thin" *) (thin to_revert)) g -let id_of_decl (na,_,_) = (Nameops.out_name na) +let id_of_decl decl = Nameops.out_name (get_name decl) let var_of_decl decl = mkVar (id_of_decl decl) let revert idl = tclTHEN @@ -1044,7 +1048,8 @@ let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num a ( fun g' -> let just_introduced = nLastDecls nb_intro_to_do g' in - let just_introduced_id = List.map (fun (id,_,_) -> id) just_introduced in + let open Context.Named.Declaration in + let just_introduced_id = List.map get_id just_introduced in tclTHEN (Proofview.V82.of_tactic (Equality.rewriteLR equation_lemma)) (revert just_introduced_id) g' ) @@ -1069,11 +1074,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam (Name new_id) ) in - let fresh_decl = - (fun (na,b,t) -> - (fresh_id na,b,t) - ) - in + let fresh_decl = map_name fresh_id in let princ_info : elim_scheme = { princ_info with params = List.map fresh_decl princ_info.params; @@ -1120,11 +1121,11 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam ) in observe (str "full_params := " ++ - prlist_with_sep spc (fun (na,_,_) -> Ppconstr.pr_id (Nameops.out_name na)) + prlist_with_sep spc (fun decl -> Ppconstr.pr_id (Nameops.out_name (get_name decl))) full_params ); observe (str "princ_params := " ++ - prlist_with_sep spc (fun (na,_,_) -> Ppconstr.pr_id (Nameops.out_name na)) + prlist_with_sep spc (fun decl -> Ppconstr.pr_id (Nameops.out_name (get_name decl))) princ_params ); observe (str "fbody_with_full_params := " ++ @@ -1165,7 +1166,8 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam in let pte_to_fix,rev_info = List.fold_left_i - (fun i (acc_map,acc_info) (pte,_,_) -> + (fun i (acc_map,acc_info) decl -> + let pte = get_name decl in let infos = info_array.(i) in let type_args,_ = decompose_prod infos.types in let nargs = List.length type_args in @@ -1259,7 +1261,8 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam let args = nLastDecls nb_args g in let fix_body = fix_info.body_with_param in (* observe (str "fix_body := "++ pr_lconstr_env (pf_env gl) fix_body); *) - let args_id = List.map (fun (id,_,_) -> id) args in + let open Context.Named.Declaration in + let args_id = List.map get_id args in let dyn_infos = { nb_rec_hyps = -100; @@ -1276,7 +1279,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam (do_replace evd full_params (fix_info.idx + List.length princ_params) - (args_id@(List.map (fun (id,_,_) -> Nameops.out_name id ) princ_params)) + (args_id@(List.map (fun decl -> Nameops.out_name (get_name decl)) princ_params)) (all_funs.(fix_info.num_in_block)) fix_info.num_in_block all_funs @@ -1317,8 +1320,9 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam [ tclDO nb_args (Proofview.V82.of_tactic intro); (fun g -> (* replacement of the function by its body *) - let args = nLastDecls nb_args g in - let args_id = List.map (fun (id,_,_) -> id) args in + let args = nLastDecls nb_args g in + let open Context.Named.Declaration in + let args_id = List.map get_id args in let dyn_infos = { nb_rec_hyps = -100; @@ -1334,7 +1338,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam in let fname = destConst (fst (decompose_app (List.hd (List.rev pte_args)))) in tclTHENSEQ - [unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst fname))]; + [Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst fname))]); let do_prove = build_proof interactive_proof @@ -1403,7 +1407,7 @@ let prove_with_tcc tcc_lemma_constr eqs : tactic = (* let ids = List.filter (fun id -> not (List.mem id ids)) ids' in *) (* rewrite *) (* ) *) - Eauto.gen_eauto (false,5) [] (Some []) + Proofview.V82.of_tactic (Eauto.gen_eauto (false,5) [] (Some [])) ] gls @@ -1460,7 +1464,7 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = (fun g -> if is_mes then - unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference (delayed_force ltof_ref))] g + Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference (delayed_force ltof_ref))]) g else tclIDTAC g ); observe_tac "rew_and_finish" @@ -1472,7 +1476,7 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = tclCOMPLETE( Eauto.eauto_with_bases (true,5) - [Evd.empty,Lazy.force refl_equal] + [{ Tacexpr.delayed = fun _ sigma -> Sigma.here (Lazy.force refl_equal) sigma}] [Hints.Hint_db.empty empty_transparent_state false] ) ) @@ -1520,7 +1524,7 @@ let prove_principle_for_gen avoid := new_id :: !avoid; Name new_id in - let fresh_decl (na,b,t) = (fresh_id na,b,t) in + let fresh_decl = map_name fresh_id in let princ_info : elim_scheme = { princ_info with params = List.map fresh_decl princ_info.params; @@ -1550,11 +1554,11 @@ let prove_principle_for_gen in let rec_arg_id = match List.rev post_rec_arg with - | (Name id,_,_)::_ -> id + | (LocalAssum (Name id,_) | LocalDef (Name id,_,_)) :: _ -> id | _ -> assert false in (* observe (str "rec_arg_id := " ++ pr_lconstr (mkVar rec_arg_id)); *) - let subst_constrs = List.map (fun (na,_,_) -> mkVar (Nameops.out_name na)) (pre_rec_arg@princ_info.params) in + let subst_constrs = List.map (fun decl -> mkVar (Nameops.out_name (get_name decl))) (pre_rec_arg@princ_info.params) in let relation = substl subst_constrs relation in let input_type = substl subst_constrs rec_arg_type in let wf_thm_id = Nameops.out_name (fresh_id (Name (Id.of_string "wf_R"))) in @@ -1562,7 +1566,7 @@ let prove_principle_for_gen Nameops.out_name (fresh_id (Name (Id.of_string ("Acc_"^(Id.to_string rec_arg_id))))) in let revert l = - tclTHEN (Tactics.Simple.generalize (List.map mkVar l)) (clear l) + tclTHEN (Tactics.generalize (List.map mkVar l)) (clear l) in let fix_id = Nameops.out_name (fresh_id (Name hrec_id)) in let prove_rec_arg_acc g = @@ -1582,7 +1586,7 @@ let prove_principle_for_gen ) g in - let args_ids = List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.args in + let args_ids = List.map (fun decl -> Nameops.out_name (get_name decl)) princ_info.args in let lemma = match !tcc_lemma_ref with | None -> error "No tcc proof !!" @@ -1629,7 +1633,7 @@ let prove_principle_for_gen [ observe_tac "start_tac" start_tac; h_intros - (List.rev_map (fun (na,_,_) -> Nameops.out_name na) + (List.rev_map (fun decl -> Nameops.out_name (get_name decl)) (princ_info.args@princ_info.branches@princ_info.predicates@princ_info.params) ); (* observe_tac "" *) Proofview.V82.of_tactic (assert_by @@ -1667,7 +1671,7 @@ let prove_principle_for_gen in let acc_inv = lazy (mkApp(Lazy.force acc_inv, [|mkVar acc_rec_arg_id|])) in let predicates_names = - List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.predicates + List.map (fun decl -> Nameops.out_name (get_name decl)) princ_info.predicates in let pte_info = { proving_tac = @@ -1683,7 +1687,7 @@ let prove_principle_for_gen is_mes acc_inv fix_id (!tcc_list@(List.map - (fun (na,_,_) -> (Nameops.out_name na)) + (fun decl -> (Nameops.out_name (get_name decl))) (princ_info.args@princ_info.params) )@ ([acc_rec_arg_id])) eqs ) @@ -1712,7 +1716,7 @@ let prove_principle_for_gen (* observe_tac "instanciate_hyps_with_args" *) (instanciate_hyps_with_args make_proof - (List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.branches) + (List.map (fun decl -> Nameops.out_name (get_name decl)) princ_info.branches) (List.rev args_ids) ) gl' diff --git a/plugins/funind/functional_principles_proofs.mli b/plugins/funind/functional_principles_proofs.mli index 61fce267a..34ce66967 100644 --- a/plugins/funind/functional_principles_proofs.mli +++ b/plugins/funind/functional_principles_proofs.mli @@ -8,7 +8,7 @@ val prove_princ_for_struct : val prove_principle_for_gen : - constant*constant*constant -> (* name of the function, the fonctionnal and the fixpoint equation *) + constant*constant*constant -> (* name of the function, the functional and the fixpoint equation *) constr option ref -> (* a pointer to the obligation proofs lemma *) bool -> (* is that function uses measure *) int -> (* the number of recursive argument *) diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 64284c6fe..91a826c73 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -3,15 +3,16 @@ open Errors open Util open Term open Vars -open Context open Namegen open Names open Pp open Entries open Tactics +open Context.Rel.Declaration open Indfun_common open Functional_principles_proofs open Misctypes +open Sigma.Notations exception Toberemoved_with_rel of int*constr exception Toberemoved @@ -29,14 +30,16 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let env = Global.env () in let env_with_params = Environ.push_rel_context princ_type_info.params env in let tbl = Hashtbl.create 792 in - let rec change_predicates_names (avoid:Id.t list) (predicates:rel_context) : rel_context = + let rec change_predicates_names (avoid:Id.t list) (predicates:Context.Rel.t) : Context.Rel.t = match predicates with | [] -> [] - |(Name x,v,t)::predicates -> - let id = Namegen.next_ident_away x avoid in - Hashtbl.add tbl id x; - (Name id,v,t)::(change_predicates_names (id::avoid) predicates) - | (Anonymous,_,_)::_ -> anomaly (Pp.str "Anonymous property binder ") + | decl :: predicates -> + (match Context.Rel.Declaration.get_name decl with + | Name x -> + let id = Namegen.next_ident_away x avoid in + Hashtbl.add tbl id x; + set_name (Name id) decl :: change_predicates_names (id::avoid) predicates + | Anonymous -> anomaly (Pp.str "Anonymous property binder ")) in let avoid = (Termops.ids_of_context env_with_params ) in let princ_type_info = @@ -46,15 +49,16 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = in (* observe (str "starting princ_type := " ++ pr_lconstr_env env princ_type); *) (* observe (str "princ_infos : " ++ pr_elim_scheme princ_type_info); *) - let change_predicate_sort i (x,_,t) = + let change_predicate_sort i decl = let new_sort = sorts.(i) in - let args,_ = decompose_prod t in + let args,_ = decompose_prod (get_type decl) in let real_args = if princ_type_info.indarg_in_concl then List.tl args else args in - Nameops.out_name x,None,compose_prod real_args (mkSort new_sort) + Context.Named.Declaration.LocalAssum (Nameops.out_name (Context.Rel.Declaration.get_name decl), + compose_prod real_args (mkSort new_sort)) in let new_predicates = List.map_i @@ -69,7 +73,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = | _ -> error "Not a valid predicate" ) in - let ptes_vars = List.map (fun (id,_,_) -> id) new_predicates in + let ptes_vars = List.map Context.Named.Declaration.get_id new_predicates in let is_pte = let set = List.fold_right Id.Set.add ptes_vars Id.Set.empty in fun t -> @@ -114,7 +118,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = | Rel n -> begin try match Environ.lookup_rel n env with - | _,_,t when is_dom t -> raise Toberemoved + | LocalAssum (_,t) | LocalDef (_,_,t) when is_dom t -> raise Toberemoved | _ -> pre_princ,[] with Not_found -> assert false end @@ -159,7 +163,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = try let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in let new_x : Name.t = get_name (Termops.ids_of_context env) x in - let new_env = Environ.push_rel (x,None,t) env in + let new_env = Environ.push_rel (LocalAssum (x,t)) env in let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b then (Termops.pop new_b), filter_map (eq_constr (mkRel 1)) Termops.pop binders_to_remove_from_b @@ -188,7 +192,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in let new_v,binders_to_remove_from_v = compute_new_princ_type remove env v in let new_x : Name.t = get_name (Termops.ids_of_context env) x in - let new_env = Environ.push_rel (x,Some v,t) env in + let new_env = Environ.push_rel (LocalDef (x,v,t)) env in let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b then (Termops.pop new_b),filter_map (eq_constr (mkRel 1)) Termops.pop binders_to_remove_from_b @@ -227,7 +231,8 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = in it_mkProd_or_LetIn (it_mkProd_or_LetIn - pre_res (List.map (fun (id,t,b) -> Name(Hashtbl.find tbl id), t,b) + pre_res (List.map (function Context.Named.Declaration.LocalAssum (id,b) -> LocalAssum (Name (Hashtbl.find tbl id), b) + | Context.Named.Declaration.LocalDef (id,t,b) -> LocalDef (Name (Hashtbl.find tbl id), t, b)) new_predicates) ) princ_type_info.params @@ -235,10 +240,12 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let change_property_sort evd toSort princ princName = + let open Context.Rel.Declaration in let princ_info = compute_elim_sig princ in - let change_sort_in_predicate (x,v,t) = - (x,None, - let args,ty = decompose_prod t in + let change_sort_in_predicate decl = + LocalAssum + (get_name decl, + let args,ty = decompose_prod (get_type decl) in let s = destSort ty in Global.add_constraints (Univ.enforce_leq (univ_of_sort toSort) (univ_of_sort s) Univ.Constraint.empty); compose_prod args (mkSort toSort) @@ -291,7 +298,7 @@ let build_functional_principle (evd:Evd.evar_map ref) interactive_proof old_prin (* let dur1 = System.time_difference tim1 tim2 in *) (* Pp.msgnl (str ("Time to compute proof: ") ++ str (string_of_float dur1)); *) (* end; *) - get_proof_clean true, Ephemeron.create hook + get_proof_clean true, CEphemeron.create hook end @@ -330,11 +337,11 @@ let generate_functional_principle (evd: Evd.evar_map ref) let evd',value = change_property_sort evd' s new_principle_type new_princ_name 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; @@ -447,7 +454,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 @@ -541,7 +548,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,18 +592,16 @@ 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.from_env (Global.env ()))) in let pconstants = (List.map (fun (_,f,sort) -> @@ -622,14 +627,11 @@ 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 () @@ -653,12 +655,15 @@ let build_case_scheme fa = let this_block_funs_indexes = Array.to_list this_block_funs_indexes in List.assoc_f Constant.equal (fst (destConst funs)) this_block_funs_indexes in - let ind_fun = + let (ind, sf) = let ind = first_fun_kn,funs_indexes in (ind,Univ.Instance.empty)(*FIXME*),prop_sort in - let sigma, scheme = - (fun (ind,sf) -> Indrec.build_case_analysis_scheme_default env sigma ind sf) ind_fun in + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma (scheme, sigma, _) = + Indrec.build_case_analysis_scheme_default env sigma ind sf + in + let sigma = Sigma.to_evar_map sigma in let scheme_type = (Typing.unsafe_type_of env sigma ) scheme in let sorts = (fun (_,_,x) -> diff --git a/plugins/funind/functional_principles_types.mli b/plugins/funind/functional_principles_types.mli index f6e5578d2..3fa2644ca 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-2016 *) +(* \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 045beb37c..e93c395e3 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -16,8 +16,12 @@ open Constrexpr open Indfun_common open Indfun open Genarg +open Constrarg open Tacticals open Misctypes +open Pcoq.Prim +open Pcoq.Constr +open Pcoq.Tactic DECLARE PLUGIN "recdef_plugin" @@ -55,7 +59,9 @@ let pr_with_bindings_typed prc prlc (c,bl) = let pr_fun_ind_using_typed prc prlc _ opt_c = match opt_c with | None -> mt () - | Some b -> spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings_typed prc prlc b.Evd.it) + | Some b -> + let (b, _) = Tactics.run_delayed (Global.env ()) Evd.empty b in + spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings_typed prc prlc b) ARGUMENT EXTEND fun_ind_using @@ -88,7 +94,7 @@ let out_disjunctive = function | loc, IntroAction (IntroOrAndPattern l) -> (loc,l) | _ -> Errors.error "Disjunctive or conjunctive intro pattern expected." -ARGUMENT EXTEND with_names TYPED AS simple_intropattern_opt PRINTED BY pr_intro_as_pat +ARGUMENT EXTEND with_names TYPED AS intropattern_opt PRINTED BY pr_intro_as_pat | [ "as" simple_intropattern(ipat) ] -> [ Some ipat ] | [] ->[ None ] END @@ -144,10 +150,10 @@ module Tactic = Pcoq.Tactic type function_rec_definition_loc_argtype = (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) Loc.located let (wit_function_rec_definition_loc : function_rec_definition_loc_argtype Genarg.uniform_genarg_type) = - Genarg.create_arg None "function_rec_definition_loc" + Genarg.create_arg "function_rec_definition_loc" let function_rec_definition_loc = - Pcoq.create_generic_entry "function_rec_definition_loc" (Genarg.rawwit wit_function_rec_definition_loc) + Pcoq.create_generic_entry Pcoq.utactic "function_rec_definition_loc" (Genarg.rawwit wit_function_rec_definition_loc) GEXTEND Gram GLOBAL: function_rec_definition_loc ; diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 1b12cd42c..8a0a1a064 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -335,15 +335,17 @@ let raw_push_named (na,raw_value,raw_typ) env = | Name id -> 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 open Context.Named.Declaration in + Environ.push_named (of_tuple (id,value,typ)) env let add_pat_variables pat typ env : Environ.env = let rec add_pat_variables env pat typ : Environ.env = + let open Context.Rel.Declaration in 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 + | PatVar(_,na) -> Environ.push_rel (LocalAssum (na,typ)) env | PatCstr(_,c,patl,na) -> let Inductiveops.IndType(indf,indargs) = try Inductiveops.find_rectype env (Evd.from_env env) typ @@ -351,15 +353,16 @@ let add_pat_variables pat typ env : Environ.env = in let constructors = Inductiveops.get_constructors env indf in let constructor : Inductiveops.constructor_summary = List.find (fun cs -> eq_constructor c (fst cs.Inductiveops.cs_cstr)) (Array.to_list constructors) in - let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in + let cs_args_types :types list = List.map get_type constructor.Inductiveops.cs_args in List.fold_left2 add_pat_variables env patl (List.rev cs_args_types) in let new_env = add_pat_variables env pat typ in let res = fst ( - Context.fold_rel_context - (fun (na,v,t) (env,ctxt) -> - match na with + Context.Rel.fold_outside + (fun decl (env,ctxt) -> + let _,v,t = Context.Rel.Declaration.to_tuple decl in + match Context.Rel.Declaration.get_name decl with | Anonymous -> assert false | Name id -> let new_t = substl ctxt t in @@ -370,7 +373,8 @@ let add_pat_variables pat typ env : Environ.env = Option.fold_right (fun v _ -> str "old value := " ++ Printer.pr_lconstr v ++ fnl ()) v (mt ()) ++ Option.fold_right (fun v _ -> str "new value := " ++ Printer.pr_lconstr v ++ fnl ()) new_v (mt ()) ); - (Environ.push_named (id,new_v,new_t) env,mkVar id::ctxt) + let open Context.Named.Declaration in + (Environ.push_named (of_tuple (id,new_v,new_t)) env,mkVar id::ctxt) ) (Environ.rel_context new_env) ~init:(env,[]) @@ -398,7 +402,8 @@ let rec pattern_to_term_and_type env typ = function in let constructors = Inductiveops.get_constructors env indf in let constructor = List.find (fun cs -> eq_constructor (fst cs.Inductiveops.cs_cstr) constr) (Array.to_list constructors) in - let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in + let open Context.Rel.Declaration in + let cs_args_types :types list = List.map get_type constructor.Inductiveops.cs_args in let _,cstl = Inductiveops.dest_ind_family indf in let csta = Array.of_list cstl in let implicit_args = @@ -597,9 +602,10 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = 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 = + let open Context.Named.Declaration in match n with Anonymous -> env - | Name id -> Environ.push_named (id,Some v_as_constr,v_type) env + | Name id -> Environ.push_named (of_tuple (id,Some v_as_constr,v_type)) env in let b_res = build_entry_lc new_env funnames avoid b in combine_results (combine_letin n) v_res b_res @@ -681,7 +687,7 @@ and build_entry_lc_from_case env funname make_discr let case_resl = List.fold_right (fun (case_arg,_) ctxt_argsl -> - let arg_res = build_entry_lc env funname avoid case_arg in + let arg_res = build_entry_lc env funname ctxt_argsl.to_avoid case_arg in combine_results combine_args arg_res ctxt_argsl ) el @@ -875,7 +881,7 @@ exception Continue *) let rec rebuild_cons env nb_args relname args crossed_types depth rt = observe (str "rebuilding : " ++ pr_glob_constr rt); - + let open Context.Rel.Declaration in match rt with | GProd(_,n,k,t,b) -> let not_free_in_t id = not (is_free_in id t) in @@ -895,7 +901,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = mkGApp(mkGVar(mk_rel_id this_relname),args'@[res_rt]) 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_env = Environ.push_rel (LocalAssum (n,t')) env in let new_b,id_to_exclude = rebuild_cons new_env nb_args relname @@ -926,7 +932,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let subst_b = if is_in_b then b else replace_var_by_term id rt b in - let new_env = Environ.push_rel (n,None,t') env in + let new_env = Environ.push_rel (LocalAssum (n,t')) env in let new_b,id_to_exclude = rebuild_cons new_env @@ -970,9 +976,8 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = (fun acc var_as_constr arg -> if isRel var_as_constr then - let (na,_,_) = - Environ.lookup_rel (destRel var_as_constr) env - in + let open Context.Rel.Declaration in + let na = get_name (Environ.lookup_rel (destRel var_as_constr) env) in match na with | Anonymous -> acc | Name id' -> @@ -1010,7 +1015,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = in let new_env = let t',ctx = Pretyping.understand env (Evd.from_env env) eq' in - Environ.push_rel (n,None,t') env + Environ.push_rel (LocalAssum (n,t')) env in let new_b,id_to_exclude = rebuild_cons @@ -1048,7 +1053,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = with Continue -> observe (str "computing new type for prod : " ++ pr_glob_constr rt); 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_env = Environ.push_rel (LocalAssum (n,t')) env in let new_b,id_to_exclude = rebuild_cons new_env nb_args relname @@ -1064,7 +1069,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = | _ -> observe (str "computing new type for prod : " ++ pr_glob_constr rt); 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_env = Environ.push_rel (LocalAssum (n,t')) env in let new_b,id_to_exclude = rebuild_cons new_env nb_args relname @@ -1085,7 +1090,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = 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 + let new_env = Environ.push_rel (LocalAssum (n,t')) env in let new_b,id_to_exclude = rebuild_cons new_env nb_args relname @@ -1108,7 +1113,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = 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_env = Environ.push_rel (LocalDef (n,t',type_t')) env in let new_b,id_to_exclude = rebuild_cons new_env nb_args relname @@ -1132,7 +1137,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = depth 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_env = Environ.push_rel (LocalAssum (na,t')) env in let new_b,id_to_exclude = rebuild_cons new_env nb_args relname @@ -1254,12 +1259,13 @@ let do_build_inductive let relnames = Array.map mk_rel_id funnames in let relnames_as_set = Array.fold_right Id.Set.add relnames Id.Set.empty in (* Construction of the pseudo constructors *) + let open Context.Named.Declaration in let evd,env = Array.fold_right2 (fun id c (evd,env) -> let evd,t = Typing.type_of env evd (mkConstU c) in evd, - Environ.push_named (id,None,t) + Environ.push_named (LocalAssum (id,t)) (* try *) (* Typing.e_type_of env evd (mkConstU c) *) (* with Not_found -> *) @@ -1298,8 +1304,8 @@ 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) rel_ar)) env) env relnames rel_arities + Environ.push_named (LocalAssum (rel_name, + 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 = diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index ab3629f89..84a4d910e 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -1,3 +1,4 @@ +open Context.Rel.Declaration open Errors open Util open Names @@ -13,10 +14,10 @@ open Decl_kinds open Sigma.Notations let is_rec_info scheme_info = - let test_branche min acc (_,_,br) = + let test_branche min acc decl = acc || ( let new_branche = - it_mkProd_or_LetIn mkProp (fst (decompose_prod_assum br)) in + it_mkProd_or_LetIn mkProp (fst (decompose_prod_assum (get_type decl))) in let free_rels_in_br = Termops.free_rels new_branche in let max = min + scheme_info.Tactics.npredicates in Int.Set.exists (fun i -> i >= min && i< max) free_rels_in_br @@ -28,7 +29,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 -> @@ -114,7 +114,7 @@ let functional_induction with_clean c princl pat = in Tacticals.tclTHEN (Tacticals.tclMAP (fun id -> Tacticals.tclTRY (Proofview.V82.of_tactic (Equality.subst_gen (do_rewrite_dependent ()) [id]))) idl ) - (Tactics.reduce flag Locusops.allHypsAndConcl) + (Proofview.V82.of_tactic (Tactics.reduce flag Locusops.allHypsAndConcl)) g else Tacticals.tclIDTAC g in @@ -124,9 +124,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 @@ -156,7 +154,8 @@ let build_newrecursive 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)) + let open Context.Named.Declaration in + (Environ.push_named (LocalAssum (recname,arity)) env, Id.Map.add recname impl impls)) (env0,Constrintern.empty_internalization_env) lnameargsardef in let recdef = (* Declare local notations *) @@ -596,7 +595,7 @@ 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),ctx,_) = 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.from_ctx ctx))) typel in let fixpoint_exprl_with_new_bl = @@ -731,9 +730,9 @@ let rec add_args id new_args b = List.map (fun (e,o) -> add_args id new_args e,o) bl) | CCases(loc,sty,b_option,cel,cal) -> CCases(loc,sty,Option.map (add_args id new_args) b_option, - List.map (fun (b,(na,b_option)) -> + List.map (fun (b,na,b_option) -> add_args id new_args b, - (na, b_option)) cel, + na, b_option) cel, List.map (fun (loc,cpl,e) -> (loc,cpl,add_args id new_args e)) cal ) | CLetTuple(loc,nal,(na,b_option),b1,b2) -> @@ -755,10 +754,8 @@ let rec add_args id new_args b = | CCast(loc,b1,b2) -> CCast(loc,add_args id new_args b1, Miscops.map_cast_type (add_args id new_args) b2) - | CRecord (loc, w, pars) -> - CRecord (loc, - (match w with Some w -> Some (add_args id new_args w) | _ -> None), - List.map (fun (e,o) -> e, add_args id new_args o) pars) + | CRecord (loc, pars) -> + CRecord (loc, List.map (fun (e,o) -> e, add_args id new_args o) pars) | CNotation _ -> anomaly ~label:"add_args " (Pp.str "CNotation") | CGeneralization _ -> anomaly ~label:"add_args " (Pp.str "CGeneralization") | CPrim _ -> b @@ -832,7 +829,6 @@ 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 -> @@ -884,8 +880,7 @@ let make_graph (f_ref:global_reference) = (* We register the infos *) List.iter (fun ((((_,id),_),_,_,_,_),_) -> add_Function false (make_con mp dp (Label.of_id id))) - expr_list); - Dumpglob.continue () + 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 35bd1c36d..2449678a1 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -149,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 @@ -163,7 +163,7 @@ let save with_clean id const (locality,_,kind) hook = (locality, ConstRef kn) in if with_clean then Pfedit.delete_current_proof (); - Ephemeron.iter_opt hook (fun f -> Lemmas.call_hook fix_exn f l r); + CEphemeron.iter_opt hook (fun f -> Lemmas.call_hook fix_exn f l r); definition_message id diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index 10daf6e84..e5c756f56 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -46,15 +46,15 @@ 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 -> - unit Lemmas.declaration_hook Ephemeron.key -> unit +val save : bool -> Id.t -> Safe_typing.private_constants Entries.definition_entry -> Decl_kinds.goal_kind -> + unit Lemmas.declaration_hook CEphemeron.key -> unit (* [get_proof_clean do_reduce] : returns the proof name, definition, kind and hook and abort the proof *) 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 d074bbabd..6a5a5ad53 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -1,10 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) + open Tacexpr open Declarations open Errors @@ -19,6 +20,8 @@ open Tactics open Indfun_common open Tacmach open Misctypes +open Termops +open Context.Rel.Declaration (* Some pretty printing function for debugging purpose *) @@ -133,18 +136,21 @@ let generate_type evd g_to_f f graph i = let fun_ctxt,res_type = match ctxt with | [] | [_] -> anomaly (Pp.str "Not a valid context") - | (_,_,res_type)::fun_ctxt -> fun_ctxt,res_type + | decl :: fun_ctxt -> fun_ctxt, get_type decl in let rec args_from_decl i accu = function | [] -> accu - | (_, Some _, _) :: l -> + | LocalDef _ :: l -> args_from_decl (succ i) accu l | _ :: l -> let t = mkRel i in args_from_decl (succ i) (t :: accu) l in (*i We need to name the vars [res] and [fv] i*) - let filter = function (Name id,_,_) -> Some id | (Anonymous,_,_) -> None in + let filter = fun decl -> match get_name decl with + | Name id -> Some id + | Anonymous -> None + in let named_ctxt = List.map_filter filter fun_ctxt in let res_id = Namegen.next_ident_away_in_goal (Id.of_string "_res") named_ctxt in let fv_id = Namegen.next_ident_away_in_goal (Id.of_string "fv") (res_id :: named_ctxt) in @@ -170,12 +176,12 @@ let generate_type evd g_to_f f graph i = \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, \] i*) let pre_ctxt = - (Name res_id,None,lift 1 res_type)::(Name fv_id,Some (mkApp(f,args_as_rels)),res_type)::fun_ctxt + LocalAssum (Name res_id, lift 1 res_type) :: LocalDef (Name fv_id, mkApp (f,args_as_rels), res_type) :: fun_ctxt in (*i and we can return the solution depending on which lemma type we are defining i*) if g_to_f - then (Anonymous,None,graph_applied)::pre_ctxt,(lift 1 res_eq_f_of_args),graph - else (Anonymous,None,res_eq_f_of_args)::pre_ctxt,(lift 1 graph_applied),graph + then LocalAssum (Anonymous,graph_applied)::pre_ctxt,(lift 1 res_eq_f_of_args),graph + else LocalAssum (Anonymous,res_eq_f_of_args)::pre_ctxt,(lift 1 graph_applied),graph (* @@ -259,10 +265,10 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes (* and built the intro pattern for each of them *) let intro_pats = List.map - (fun (_,_,br_type) -> + (fun decl -> List.map (fun id -> Loc.ghost, IntroNaming (IntroIdentifier id)) - (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum br_type)))) + (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum (get_type decl))))) ) branches in @@ -362,14 +368,14 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes (* unfolding of all the defined variables introduced by this branch *) (* observe_tac "unfolding" pre_tac; *) (* $zeta$ normalizing of the conclusion *) - reduce + Proofview.V82.of_tactic (reduce (Genredexpr.Cbv { Redops.all_flags with Genredexpr.rDelta = false ; Genredexpr.rConst = [] } ) - Locusops.onConcl; + Locusops.onConcl); observe_tac ("toto ") tclIDTAC; (* introducing the the result of the graph and the equality hypothesis *) @@ -389,10 +395,10 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes (fun ((_,(ctxt,concl))) -> match ctxt with | [] | [_] | [_;_] -> anomaly (Pp.str "bad context") - | hres::res::(x,_,t)::ctxt -> + | hres::res::decl::ctxt -> let res = Termops.it_mkLambda_or_LetIn (Termops.it_mkProd_or_LetIn concl [hres;res]) - ((x,None,t)::ctxt) + (LocalAssum (get_name decl, get_type decl) :: ctxt) in res ) @@ -407,8 +413,8 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes let bindings = let params_bindings,avoid = List.fold_left2 - (fun (bindings,avoid) (x,_,_) p -> - let id = Namegen.next_ident_away (Nameops.out_name x) avoid in + (fun (bindings,avoid) decl p -> + let id = Namegen.next_ident_away (Nameops.out_name (get_name decl)) avoid in p::bindings,id::avoid ) ([],pf_ids_of_hyps g) @@ -417,8 +423,8 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes in let lemmas_bindings = List.rev (fst (List.fold_left2 - (fun (bindings,avoid) (x,_,_) p -> - let id = Namegen.next_ident_away (Nameops.out_name x) avoid in + (fun (bindings,avoid) decl p -> + let id = Namegen.next_ident_away (Nameops.out_name (get_name decl)) avoid in (nf_zeta p)::bindings,id::avoid) ([],avoid) princ_infos.predicates @@ -454,10 +460,11 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes generalize every hypothesis which depends of [x] but [hyp] *) let generalize_dependent_of x hyp g = + let open Context.Named.Declaration in tclMAP (function - | (id,None,t) when not (Id.equal id hyp) && - (Termops.occur_var (pf_env g) x t) -> tclTHEN (Tactics.Simple.generalize [mkVar id]) (thin [id]) + | LocalAssum (id,t) when not (Id.equal id hyp) && + (Termops.occur_var (pf_env g) x t) -> tclTHEN (Tactics.generalize [mkVar id]) (thin [id]) | _ -> tclIDTAC ) (pf_hyps g) @@ -467,6 +474,15 @@ let generalize_dependent_of x hyp g = (* [intros_with_rewrite] do the intros in each branch and treat each new hypothesis (unfolding, substituting, destructing cases \ldots) *) +let tauto = + let dp = List.map Id.of_string ["Tauto" ; "Init"; "Coq"] in + let mp = ModPath.MPfile (DirPath.make dp) in + let kn = KerName.make2 mp (Label.make "tauto") in + Proofview.tclBIND (Proofview.tclUNIT ()) begin fun () -> + let body = Tacenv.interp_ltac kn in + Tacinterp.eval_tactic body + end + let rec intros_with_rewrite g = observe_tac "intros_with_rewrite" intros_with_rewrite_aux g and intros_with_rewrite_aux : tactic = @@ -483,15 +499,15 @@ and intros_with_rewrite_aux : tactic = tclTHENSEQ [ Proofview.V82.of_tactic (Simple.intro id); thin [id]; intros_with_rewrite ] g else if isVar args.(1) && (Environ.evaluable_named (destVar args.(1)) (pf_env g)) then tclTHENSEQ[ - unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(1)))]; - tclMAP (fun id -> tclTRY(unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(1)))] ((destVar args.(1)),Locus.InHyp) )) + Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(1)))]); + tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(1)))] ((destVar args.(1)),Locus.InHyp) ))) (pf_ids_of_hyps g); intros_with_rewrite ] g else if isVar args.(2) && (Environ.evaluable_named (destVar args.(2)) (pf_env g)) then tclTHENSEQ[ - unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(2)))]; - tclMAP (fun id -> tclTRY(unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(2)))] ((destVar args.(2)),Locus.InHyp) )) + Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(2)))]); + tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(2)))] ((destVar args.(2)),Locus.InHyp) ))) (pf_ids_of_hyps g); intros_with_rewrite ] g @@ -523,7 +539,7 @@ and intros_with_rewrite_aux : tactic = ] g end | Ind _ when eq_constr t (Coqlib.build_coq_False ()) -> - Proofview.V82.of_tactic Tauto.tauto g + Proofview.V82.of_tactic tauto g | Case(_,_,v,_) -> tclTHENSEQ[ Proofview.V82.of_tactic (simplest_case v); @@ -531,12 +547,12 @@ and intros_with_rewrite_aux : tactic = ] g | LetIn _ -> tclTHENSEQ[ - reduce + Proofview.V82.of_tactic (reduce (Genredexpr.Cbv {Redops.all_flags with Genredexpr.rDelta = false; }) - Locusops.onConcl + Locusops.onConcl) ; intros_with_rewrite ] g @@ -546,12 +562,12 @@ and intros_with_rewrite_aux : tactic = end | LetIn _ -> tclTHENSEQ[ - reduce + Proofview.V82.of_tactic (reduce (Genredexpr.Cbv {Redops.all_flags with Genredexpr.rDelta = false; }) - Locusops.onConcl + Locusops.onConcl) ; intros_with_rewrite ] g @@ -662,10 +678,10 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = let branches = List.rev princ_infos.branches in let intro_pats = List.map - (fun (_,_,br_type) -> + (fun decl -> List.map (fun id -> id) - (generate_fresh_id (Id.of_string "y") ids (nb_prod br_type)) + (generate_fresh_id (Id.of_string "y") ids (nb_prod (get_type decl))) ) branches in @@ -691,18 +707,18 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_lemma)); (* Don't forget to $\zeta$ normlize the term since the principles have been $\zeta$-normalized *) - reduce + Proofview.V82.of_tactic (reduce (Genredexpr.Cbv {Redops.all_flags with Genredexpr.rDelta = false; }) - Locusops.onConcl + Locusops.onConcl) ; - Simple.generalize (List.map mkVar ids); + generalize (List.map mkVar ids); thin ids ] else - unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst (destConst f)))] + Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst (destConst f)))]) in (* The proof of each branche itself *) let ind_number = ref 0 in @@ -737,7 +753,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = tclTHENSEQ [ tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) (args_names@[res;hres]); observe_tac "h_generalize" - (Simple.generalize [mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas)]); + (generalize [mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas)]); Proofview.V82.of_tactic (Simple.intro graph_principle_id); observe_tac "" (tclTHEN_i (observe_tac "elim" (Proofview.V82.of_tactic (elim false None (mkVar hres,NoBindings) (Some (mkVar graph_principle_id,NoBindings))))) @@ -920,7 +936,7 @@ let revert_graph kn post_tac hid g = let f_args,res = Array.chop (Array.length args - 1) args in tclTHENSEQ [ - Simple.generalize [applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid])]; + generalize [applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid])]; thin [hid]; Proofview.V82.of_tactic (Simple.intro hid); post_tac hid @@ -964,7 +980,7 @@ let functional_inversion kn hid fconst f_correct : tactic = in tclTHENSEQ[ pre_tac hid; - Simple.generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])]; + generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])]; thin [hid]; Proofview.V82.of_tactic (Simple.intro hid); Proofview.V82.of_tactic (Inv.inv FullInversion None (NamedHyp hid)); diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml index 60c58730a..c71d9a9ca 100644 --- a/plugins/funind/merge.ml +++ b/plugins/funind/merge.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -19,12 +19,12 @@ open Pp open Names open Term open Vars -open Context open Termops open Declarations open Glob_term open Glob_termops open Decl_kinds +open Context.Rel.Declaration (** {1 Utilities} *) @@ -135,9 +135,9 @@ let showind (id:Id.t) = let cstrid = Constrintern.global_reference id in let ind1,cstrlist = Inductiveops.find_inductive (Global.env()) Evd.empty cstrid in let mib1,ib1 = Inductive.lookup_mind_specif (Global.env()) (fst ind1) in - List.iter (fun (nm, optcstr, tp) -> - print_string (string_of_name nm^":"); - prconstr tp; print_string "\n") + List.iter (fun decl -> + print_string (string_of_name (Context.Rel.Declaration.get_name decl) ^ ":"); + prconstr (get_type decl); print_string "\n") ib1.mind_arity_ctxt; Printf.printf "arity :"; prconstr (Inductiveops.type_of_inductive (Global.env ()) ind1); Array.iteri @@ -258,27 +258,27 @@ type merge_infos = lnk2: int merged_arg array; (** rec params which remain rec param (ie not linked) *) - recprms1: rel_declaration list; - recprms2: rel_declaration list; + recprms1: Context.Rel.Declaration.t list; + recprms2: Context.Rel.Declaration.t list; nrecprms1: int; nrecprms2: int; (** rec parms which became non parm (either linked to something or because after a rec parm that became non parm) *) - otherprms1: rel_declaration list; - otherprms2: rel_declaration list; + otherprms1: Context.Rel.Declaration.t list; + otherprms2: Context.Rel.Declaration.t list; notherprms1:int; notherprms2:int; (** args which remain args in merge *) - args1:rel_declaration list; - args2:rel_declaration list; + args1:Context.Rel.Declaration.t list; + args2:Context.Rel.Declaration.t list; nargs1:int; nargs2:int; (** functional result args *) - funresprms1: rel_declaration list; - funresprms2: rel_declaration list; + funresprms1: Context.Rel.Declaration.t list; + funresprms2: Context.Rel.Declaration.t list; nfunresprms1:int; nfunresprms2:int; } @@ -460,11 +460,12 @@ let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array let recprms2,otherprms2,args2,funresprms2 = bldprms (List.rev oib2.mind_arity_ctxt) mlnk2 in let _ = prstr "\notherprms1:\n" in let _ = - List.iter (fun (x,_,y) -> prstr (string_of_name x^" : ");prconstr y;prstr "\n") + List.iter (fun decl -> prstr (string_of_name (get_name decl) ^ " : "); + prconstr (get_type decl); prstr "\n") otherprms1 in let _ = prstr "\notherprms2:\n" in let _ = - List.iter (fun (x,_,y) -> prstr (string_of_name x^" : ");prconstr y;prstr "\n") + List.iter (fun decl -> prstr (string_of_name (get_name decl) ^ " : "); prconstr (get_type decl); prstr "\n") otherprms2 in { ident=id; @@ -824,9 +825,11 @@ let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) = let concl = Constrextern.extern_constr false (Global.env()) Evd.empty concl in let arity,_ = List.fold_left - (fun (acc,env) (nm,_,c) -> + (fun (acc,env) decl -> + let nm = Context.Rel.Declaration.get_name decl in + let c = get_type decl in let typ = Constrextern.extern_constr false env Evd.empty c in - let newenv = Environ.push_rel (nm,None,c) env in + let newenv = Environ.push_rel (LocalAssum (nm,c)) env in CProdN (Loc.ghost, [[(Loc.ghost,nm)],Constrexpr_ops.default_binder_kind,typ] , acc) , newenv) (concl,Global.env()) (shift.funresprms2 @ shift.funresprms1 @@ -851,12 +854,12 @@ let glob_constr_list_to_inductive_expr prms1 prms2 mib1 mib2 shift lident , bindlist , Some cstr_expr , lcstor_expr -let mkProd_reldecl (rdecl:rel_declaration) (t2:glob_constr) = +let mkProd_reldecl (rdecl:Context.Rel.Declaration.t) (t2:glob_constr) = match rdecl with - | (nme,None,t) -> + | LocalAssum (nme,t) -> let traw = Detyping.detype false [] (Global.env()) Evd.empty t in GProd (Loc.ghost,nme,Explicit,traw,t2) - | (_,Some _,_) -> assert false + | LocalDef _ -> assert false (** [merge_inductive ind1 ind2 lnk] merges two graphs, linking @@ -884,10 +887,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. *) @@ -970,7 +973,7 @@ let funify_branches relinfo nfuns branch = | Rel i -> let reali = i-shift in (reali>=0 && reali<relinfo.nbranches) | _ -> false in (* FIXME: *) - (Anonymous,Some mkProp,mkProp) + LocalDef (Anonymous,mkProp,mkProp) let relprinctype_to_funprinctype relprinctype nfuns = diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index aaeb577d3..046c7aa43 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -29,6 +29,7 @@ open Proof_type open Pfedit open Glob_term open Pretyping +open Termops open Constrintern open Misctypes open Genredexpr @@ -38,7 +39,8 @@ open Auto open Eauto open Indfun_common - +open Sigma.Notations +open Context.Rel.Declaration (* Ugly things which should not be here *) @@ -179,7 +181,7 @@ let (value_f:constr list -> global_reference -> constr) = ) in let context = List.map - (fun (x, c) -> Name x, None, c) (List.combine rev_x_id_l (List.rev al)) + (fun (x, c) -> LocalAssum (Name x, c)) (List.combine rev_x_id_l (List.rev al)) in let env = Environ.push_rel_context context (Global.env ()) in let glob_body = @@ -203,7 +205,7 @@ let (declare_f : Id.t -> logical_kind -> constr list -> global_reference -> glob -(* Debuging mechanism *) +(* Debugging mechanism *) let debug_queue = Stack.create () let rec print_debug_queue b e = @@ -274,8 +276,8 @@ let tclUSER tac is_mes l g = if is_mes then observe_tclTHENLIST (str "tclUSER2") [ - unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference - (delayed_force Indfun_common.ltof_ref))]; + Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference + (delayed_force Indfun_common.ltof_ref))]); tac ] else tac @@ -291,9 +293,9 @@ let tclUSER_if_not_mes concl_tac is_mes names_to_suppress = -(* Travelling term. +(* Traveling term. Both definitions of [f_terminate] and [f_equation] use the same generic - travelling mechanism. + traveling mechanism. *) (* [check_not_nested forbidden e] checks that [e] does not contains any variable @@ -327,7 +329,7 @@ let check_not_nested forbidden e = with UserError(_,p) -> errorlabstrm "_" (str "on expr : " ++ Printer.pr_lconstr e ++ str " " ++ p) -(* ['a info] contains the local information for travelling *) +(* ['a info] contains the local information for traveling *) type 'a infos = { nb_arg : int; (* function number of arguments *) concl_tac : tactic; (* final tactic to finish proofs *) @@ -337,7 +339,7 @@ type 'a infos = f_id : Id.t; (* function name *) f_constr : constr; (* function term *) f_terminate : constr; (* termination proof term *) - func : global_reference; (* functionnal reference *) + func : global_reference; (* functional reference *) info : 'a; is_main_branch : bool; (* on the main branch or on a matched expression *) is_final : bool; (* final first order term or not *) @@ -357,7 +359,7 @@ type ('a,'b) journey_info_tac = 'b infos -> (* argument of the tactic *) tactic -(* journey_info : specifies the actions to do on the different term constructors during the travelling of the term +(* journey_info : specifies the actions to do on the different term constructors during the traveling of the term *) type journey_info = { letiN : ((Name.t*constr*types*constr),constr) journey_info_tac; @@ -560,10 +562,10 @@ let rec destruct_bounds_aux infos (bound,hyple,rechyps) lbounds g = observe_tclTHENLIST (str "destruct_bounds_aux2")[ observe_tac (str "clearing k ") (clear [id]); h_intros [k;h';def]; - observe_tac (str "simple_iter") (simpl_iter Locusops.onConcl); + observe_tac (str "simple_iter") (Proofview.V82.of_tactic (simpl_iter Locusops.onConcl)); observe_tac (str "unfold functional") - (unfold_in_concl[(Locus.OnlyOccurrences [1], - evaluable_of_global_reference infos.func)]); + (Proofview.V82.of_tactic (unfold_in_concl[(Locus.OnlyOccurrences [1], + evaluable_of_global_reference infos.func)])); ( observe_tclTHENLIST (str "test")[ list_rewrite true @@ -676,8 +678,10 @@ let mkDestructEq : let hyps = pf_hyps g in let to_revert = Util.List.map_filter - (fun (id, _, t) -> - if Id.List.mem id not_on_hyp || not (Termops.occur_term expr t) + (fun decl -> + let open Context.Named.Declaration in + let id = get_id decl in + if Id.List.mem id not_on_hyp || not (Termops.occur_term expr (get_type decl)) then None else Some id) hyps in let to_revert_constr = List.rev_map mkVar to_revert in let type_of_expr = pf_unsafe_type_of g expr in @@ -685,11 +689,13 @@ let mkDestructEq : to_revert_constr in pf_typel new_hyps (fun _ -> observe_tclTHENLIST (str "mkDestructEq") - [Simple.generalize new_hyps; + [generalize new_hyps; (fun g2 -> - Proofview.V82.of_tactic (change_in_concl None - (fun patvars sigma -> - pattern_occs [Locus.AllOccurrencesBut [1], expr] (pf_env g2) sigma (pf_concl g2))) g2); + let changefun patvars = { run = fun sigma -> + let redfun = pattern_occs [Locus.AllOccurrencesBut [1], expr] in + redfun.Reductionops.e_redfun (pf_env g2) sigma (pf_concl g2) + } in + Proofview.V82.of_tactic (change_in_concl None changefun) g2); Proofview.V82.of_tactic (simplest_case expr)]), to_revert @@ -897,10 +903,10 @@ let make_rewrite expr_info l hp max = [observe_tac(str "make_rewrite finalize") ( (* tclORELSE( h_reflexivity) *) (observe_tclTHENLIST (str "make_rewrite")[ - simpl_iter Locusops.onConcl; + Proofview.V82.of_tactic (simpl_iter Locusops.onConcl); observe_tac (str "unfold functional") - (unfold_in_concl[(Locus.OnlyOccurrences [1], - evaluable_of_global_reference expr_info.func)]); + (Proofview.V82.of_tactic (unfold_in_concl[(Locus.OnlyOccurrences [1], + evaluable_of_global_reference expr_info.func)])); (list_rewrite true (List.map (fun e -> mkVar e,true) expr_info.eqs)); @@ -1110,7 +1116,7 @@ let termination_proof_header is_mes input_type ids args_id relation [observe_tac (str "generalize") (onNLastHypsId (nargs+1) (tclMAP (fun id -> - tclTHEN (Tactics.Simple.generalize [mkVar id]) (clear [id])) + tclTHEN (Tactics.generalize [mkVar id]) (clear [id])) )) ; observe_tac (str "fix") (fix (Some hrec) (nargs+1)); @@ -1248,7 +1254,7 @@ let clear_goals = then Termops.pop b' else if b' == b then t else mkProd(na,t',b') - | _ -> map_constr clear_goal t + | _ -> Term.map_constr clear_goal t in List.map clear_goal @@ -1300,7 +1306,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in observe_tclTHENLIST (str "") [ - Simple.generalize [lemma]; + generalize [lemma]; Proofview.V82.of_tactic (Simple.intro hid); (fun g -> let ids = pf_ids_of_hyps g in @@ -1330,7 +1336,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp (Proofview.V82.of_tactic e_assumption); Eauto.eauto_with_bases (true,5) - [Evd.empty,Lazy.force refl_equal] + [{ Tacexpr.delayed = fun _ sigma -> Sigma.here (Lazy.force refl_equal) sigma}] [Hints.Hint_db.empty empty_transparent_state false] ] ) @@ -1420,7 +1426,7 @@ let start_equation (f:global_reference) (term_f:global_reference) let x = n_x_id ids nargs in observe_tac (str "start_equation") (observe_tclTHENLIST (str "start_equation") [ h_intros x; - unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference f)]; + Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference f)]); observe_tac (str "simplest_case") (Proofview.V82.of_tactic (simplest_case (mkApp (terminate_constr, Array.of_list (List.map mkVar x))))); @@ -1484,7 +1490,7 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let env = Global.env() in let evd = ref (Evd.from_env env) in let function_type = interp_type_evars env evd type_of_f in - let env = push_named (function_name,None,function_type) env in + let env = push_named (Context.Named.Declaration.LocalAssum (function_name,function_type)) env in (* Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type); *) let ty = interp_type_evars env evd ~impls:rec_impls eq in let evm, nf = Evarutil.nf_evars_and_universes !evd in @@ -1492,7 +1498,7 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let function_type = nf function_type in (* Pp.msgnl (str "lemma type := " ++ Printer.pr_lconstr equation_lemma_type ++ fnl ()); *) let res_vars,eq' = decompose_prod equation_lemma_type in - let env_eq' = Environ.push_rel_context (List.map (fun (x,y) -> (x,None,y)) res_vars) env in + let env_eq' = Environ.push_rel_context (List.map (fun (x,y) -> LocalAssum (x,y)) res_vars) env in let eq' = nf_zeta env_eq' eq' in let res = (* Pp.msgnl (str "res_var :=" ++ Printer.pr_lconstr_env (push_rel_context (List.map (function (x,t) -> (x,None,t)) res_vars) env) eq'); *) @@ -1509,8 +1515,8 @@ 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 env_with_pre_rec_args = push_rel_context(List.map (function (x,t) -> (x,None,t)) pre_rec_args) env 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) -> LocalAssum (x,t)) pre_rec_args) env in let relation = fst (*FIXME*)(interp_constr env_with_pre_rec_args diff --git a/plugins/micromega/Env.v b/plugins/micromega/Env.v index dd4d596f2..a19e9df90 100644 --- a/plugins/micromega/Env.v +++ b/plugins/micromega/Env.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/micromega/EnvRing.v b/plugins/micromega/EnvRing.v index 62a7333d5..fd4bb248b 100644 --- a/plugins/micromega/EnvRing.v +++ b/plugins/micromega/EnvRing.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/micromega/Lia.v b/plugins/micromega/Lia.v index 724255855..3e58e81ac 100644 --- a/plugins/micromega/Lia.v +++ b/plugins/micromega/Lia.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/micromega/MExtraction.v b/plugins/micromega/MExtraction.v index 8b959c278..0a41af454 100644 --- a/plugins/micromega/MExtraction.v +++ b/plugins/micromega/MExtraction.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/micromega/OrderedRing.v b/plugins/micromega/OrderedRing.v index 34b8bbdd3..72b4dcb6e 100644 --- a/plugins/micromega/OrderedRing.v +++ b/plugins/micromega/OrderedRing.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/micromega/Psatz.v b/plugins/micromega/Psatz.v index 31d051cb4..ba1f8956e 100644 --- a/plugins/micromega/Psatz.v +++ b/plugins/micromega/Psatz.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -69,7 +69,7 @@ Ltac xpsatz dom d := end in tac. Tactic Notation "psatz" constr(dom) int_or_var(n) := xpsatz dom n. -Tactic Notation "psatz" constr(dom) := xpsatz dom ltac:-1. +Tactic Notation "psatz" constr(dom) := xpsatz dom ltac:(-1). Ltac psatzl dom := let tac := lazymatch dom with diff --git a/plugins/micromega/QMicromega.v b/plugins/micromega/QMicromega.v index 6c157def8..432683635 100644 --- a/plugins/micromega/QMicromega.v +++ b/plugins/micromega/QMicromega.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/micromega/RMicromega.v b/plugins/micromega/RMicromega.v index e9ab69626..72353a99e 100644 --- a/plugins/micromega/RMicromega.v +++ b/plugins/micromega/RMicromega.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/micromega/Refl.v b/plugins/micromega/Refl.v index 499a8c4c4..32ddb3cf4 100644 --- a/plugins/micromega/Refl.v +++ b/plugins/micromega/Refl.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/micromega/RingMicromega.v b/plugins/micromega/RingMicromega.v index a0545637d..751a81df1 100644 --- a/plugins/micromega/RingMicromega.v +++ b/plugins/micromega/RingMicromega.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/micromega/Tauto.v b/plugins/micromega/Tauto.v index 39d0c6b19..391231afd 100644 --- a/plugins/micromega/Tauto.v +++ b/plugins/micromega/Tauto.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/micromega/VarMap.v b/plugins/micromega/VarMap.v index 6e1fe2220..4981ddb30 100644 --- a/plugins/micromega/VarMap.v +++ b/plugins/micromega/VarMap.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/micromega/ZCoeff.v b/plugins/micromega/ZCoeff.v index 4c4b81a07..bd425e6bb 100644 --- a/plugins/micromega/ZCoeff.v +++ b/plugins/micromega/ZCoeff.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/micromega/ZMicromega.v b/plugins/micromega/ZMicromega.v index 84a8d13c2..d7ddef2be 100644 --- a/plugins/micromega/ZMicromega.v +++ b/plugins/micromega/ZMicromega.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml index 63485ab26..914881db0 100644 --- a/plugins/micromega/certificate.ml +++ b/plugins/micromega/certificate.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 470e21c82..27daa7e3c 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -82,10 +82,10 @@ let _ = optread = (fun () -> !lia_enum); optwrite = (fun x -> lia_enum := x) } in - ignore (declare_int_option (int_opt ["Lra"; "Depth"] lra_proof_depth)) ; - ignore (declare_int_option (int_opt ["Lia"; "Depth"] lia_proof_depth)) ; - ignore (declare_bool_option lia_enum_opt) - + let _ = declare_int_option (int_opt ["Lra"; "Depth"] lra_proof_depth) in + let _ = declare_int_option (int_opt ["Lia"; "Depth"] lia_proof_depth) in + let _ = declare_bool_option lia_enum_opt in + () (** * Initialize a tag type to the Tag module declaration (see Mutils). @@ -1170,7 +1170,7 @@ struct let is_prop term = let ty = Typing.unsafe_type_of (Tacmach.pf_env gl) (Tacmach.project gl) term in - let sort = Typing.sort_of (Tacmach.pf_env gl) (ref (Tacmach.project gl)) ty in + let sort = Typing.e_sort_of (Tacmach.pf_env gl) (ref (Tacmach.project gl)) ty in Term.is_prop_sort sort in let rec xparse_formula env tg term = diff --git a/plugins/micromega/csdpcert.ml b/plugins/micromega/csdpcert.ml index b41f29c98..2536005ed 100644 --- a/plugins/micromega/csdpcert.ml +++ b/plugins/micromega/csdpcert.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/micromega/g_micromega.ml4 b/plugins/micromega/g_micromega.ml4 index 62f0ae503..bca1c2feb 100644 --- a/plugins/micromega/g_micromega.ml4 +++ b/plugins/micromega/g_micromega.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -18,15 +18,15 @@ open Errors open Misctypes +open Stdarg +open Constrarg +open Pcoq.Prim +open Pcoq.Tactic DECLARE PLUGIN "micromega_plugin" -let out_arg = function - | ArgVar _ -> anomaly (Pp.str "Unevaluated or_var variable") - | ArgArg x -> x - TACTIC EXTEND PsatzZ -| [ "psatz_Z" int_or_var(i) ] -> [ (Coq_micromega.psatz_Z (out_arg i)) ] +| [ "psatz_Z" int_or_var(i) ] -> [ (Coq_micromega.psatz_Z i) ] | [ "psatz_Z" ] -> [ (Coq_micromega.psatz_Z (-1)) ] END @@ -63,12 +63,12 @@ TACTIC EXTEND LRA_R END TACTIC EXTEND PsatzR -| [ "psatz_R" int_or_var(i) ] -> [ (Coq_micromega.psatz_R (out_arg i)) ] +| [ "psatz_R" int_or_var(i) ] -> [ (Coq_micromega.psatz_R i) ] | [ "psatz_R" ] -> [ (Coq_micromega.psatz_R (-1)) ] END TACTIC EXTEND PsatzQ -| [ "psatz_Q" int_or_var(i) ] -> [ (Coq_micromega.psatz_Q (out_arg i)) ] +| [ "psatz_Q" int_or_var(i) ] -> [ (Coq_micromega.psatz_Q i) ] | [ "psatz_Q" ] -> [ (Coq_micromega.psatz_Q (-1)) ] END diff --git a/plugins/micromega/mfourier.ml b/plugins/micromega/mfourier.ml index 0261d7349..e22fe5843 100644 --- a/plugins/micromega/mfourier.ml +++ b/plugins/micromega/mfourier.ml @@ -120,7 +120,7 @@ and cstr_info = { (** A system of constraints has the form [\{sys = s ; vars = v\}]. [s] is a hashtable mapping a normalised vector to a [cstr_info] record where - [bound] is an interval - - [prf_idx] is the set of hypothese indexes (i.e. constraints in the initial system) used to obtain the current constraint. + - [prf_idx] is the set of hypothesis indexes (i.e. constraints in the initial system) used to obtain the current constraint. In the initial system, each constraint is given an unique singleton proof_idx. When a new constraint c is computed by a function f(c1,...,cn), its proof_idx is ISet.fold union (List.map (fun x -> x.proof_idx) [c1;...;cn] - [pos] is the number of positive values of the vector @@ -872,7 +872,7 @@ let mk_proof hyps prf = | Elim(v,prf1,prf2) -> let prfsl = mk_proof prf1 and prfsr = mk_proof prf2 in - (* I take only the pairs for which the elimination is meaningfull *) + (* I take only the pairs for which the elimination is meaningful *) forall_pairs (pivot v) prfsl prfsr | And(prf1,prf2) -> let prfsl1 = mk_proof prf1 diff --git a/plugins/micromega/mutils.ml b/plugins/micromega/mutils.ml index 465c7afce..c13e8fc28 100644 --- a/plugins/micromega/mutils.ml +++ b/plugins/micromega/mutils.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/micromega/persistent_cache.ml b/plugins/micromega/persistent_cache.ml index 2dc0d0032..6a03e2d61 100644 --- a/plugins/micromega/persistent_cache.ml +++ b/plugins/micromega/persistent_cache.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/micromega/polynomial.ml b/plugins/micromega/polynomial.ml index b8b42a3f2..90a108a3b 100644 --- a/plugins/micromega/polynomial.ml +++ b/plugins/micromega/polynomial.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/micromega/sos.mli b/plugins/micromega/sos.mli index fc0b2fd46..1ca27ea20 100644 --- a/plugins/micromega/sos.mli +++ b/plugins/micromega/sos.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/micromega/sos_types.ml b/plugins/micromega/sos_types.ml index e95437141..615ac5a2f 100644 --- a/plugins/micromega/sos_types.ml +++ b/plugins/micromega/sos_types.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/nsatz/Nsatz.v b/plugins/nsatz/Nsatz.v index eaf95e946..3068b5347 100644 --- a/plugins/nsatz/Nsatz.v +++ b/plugins/nsatz/Nsatz.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/MMaps/MMaps.v b/plugins/nsatz/g_nsatz.ml4 index 054d07225..0da630530 100644 --- a/theories/MMaps/MMaps.v +++ b/plugins/nsatz/g_nsatz.ml4 @@ -1,16 +1,17 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) -(* \VV/ *************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(***********************************************************************) +DECLARE PLUGIN "nsatz_plugin" +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) -Require Export Orders OrdersEx OrdersAlt. -Require Export Equalities. -Require Export MMapInterface. -Require Export MMapFacts. -Require Export MMapWeakList. -Require Export MMapList. -Require Export MMapPositive. +(*i camlp4deps: "grammar/grammar.cma" i*) + +DECLARE PLUGIN "nsatz_plugin" + +TACTIC EXTEND nsatz_compute +| [ "nsatz_compute" constr(lt) ] -> [ Proofview.V82.tactic (Nsatz.nsatz_compute lt) ] +END diff --git a/plugins/nsatz/ideal.ml b/plugins/nsatz/ideal.ml index 8ff824542..482ce5053 100644 --- a/plugins/nsatz/ideal.ml +++ b/plugins/nsatz/ideal.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/nsatz/nsatz.ml4 b/plugins/nsatz/nsatz.ml index b4eb57eca..ee1904a66 100644 --- a/plugins/nsatz/nsatz.ml4 +++ b/plugins/nsatz/nsatz.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4deps: "grammar/grammar.cma" i*) - open Errors open Util open Term @@ -17,8 +15,6 @@ open Coqlib open Num open Utile -DECLARE PLUGIN "nsatz_plugin" - (*********************************************************************** Operations on coefficients *) @@ -591,8 +587,4 @@ let nsatz_compute t = error "nsatz cannot solve this problem" in return_term lpol -TACTIC EXTEND nsatz_compute -| [ "nsatz_compute" constr(lt) ] -> [ Proofview.V82.tactic (nsatz_compute lt) ] -END - diff --git a/plugins/nsatz/nsatz_plugin.mllib b/plugins/nsatz/nsatz_plugin.mllib index a25e649d0..e991fb76f 100644 --- a/plugins/nsatz/nsatz_plugin.mllib +++ b/plugins/nsatz/nsatz_plugin.mllib @@ -2,4 +2,5 @@ Utile Polynom Ideal Nsatz +G_nsatz Nsatz_plugin_mod diff --git a/plugins/nsatz/polynom.ml b/plugins/nsatz/polynom.ml index a96513043..dbd9005cb 100644 --- a/plugins/nsatz/polynom.ml +++ b/plugins/nsatz/polynom.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/nsatz/polynom.mli b/plugins/nsatz/polynom.mli index 9d46cd991..433ab5914 100644 --- a/plugins/nsatz/polynom.mli +++ b/plugins/nsatz/polynom.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/omega/Omega.v b/plugins/omega/Omega.v index a5f90dd66..9988c8588 100644 --- a/plugins/omega/Omega.v +++ b/plugins/omega/Omega.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/omega/OmegaPlugin.v b/plugins/omega/OmegaPlugin.v index 9f101dbf2..cd1624984 100644 --- a/plugins/omega/OmegaPlugin.v +++ b/plugins/omega/OmegaPlugin.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/omega/OmegaTactic.v b/plugins/omega/OmegaTactic.v index 9f101dbf2..cd1624984 100644 --- a/plugins/omega/OmegaTactic.v +++ b/plugins/omega/OmegaTactic.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/omega/PreOmega.v b/plugins/omega/PreOmega.v index ee0f841c5..5f5f548f8 100644 --- a/plugins/omega/PreOmega.v +++ b/plugins/omega/PreOmega.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 976ab949c..1f420cf6a 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -28,6 +28,7 @@ open Nametab open Contradiction open Misctypes open Proofview.Notations +open Context.Named.Declaration module OmegaSolver = Omega.MakeOmegaSolver (Bigint) open OmegaSolver @@ -927,15 +928,15 @@ let rec transform p t = transform p (mkApp (Lazy.force coq_Zplus, [| t1; (mkApp (Lazy.force coq_Zopp, [| t2 |])) |])) in - unfold sp_Zminus :: tac,t + Proofview.V82.of_tactic (unfold sp_Zminus) :: tac,t | Kapp(Zsucc,[t1]) -> let tac,t = transform p (mkApp (Lazy.force coq_Zplus, [| t1; mk_integer one |])) in - unfold sp_Zsucc :: tac,t + Proofview.V82.of_tactic (unfold sp_Zsucc) :: tac,t | Kapp(Zpred,[t1]) -> let tac,t = transform p (mkApp (Lazy.force coq_Zplus, [| t1; mk_integer negone |])) in - unfold sp_Zpred :: tac,t + Proofview.V82.of_tactic (unfold sp_Zpred) :: tac,t | Kapp(Zmult,[t1;t2]) -> let tac1,t1' = transform (P_APP 1 :: p) t1 and tac2,t2' = transform (P_APP 2 :: p) t2 in @@ -1091,8 +1092,8 @@ let replay_history tactic_normalisation = in Tacticals.New.tclTHENS (Tacticals.New.tclTHENLIST [ - Proofview.V82.tactic (unfold sp_Zle); - Proofview.V82.tactic (simpl_in_concl); + unfold sp_Zle; + simpl_in_concl; intro; (absurd not_sup_sup) ]) [ assumption ; reflexivity ] @@ -1135,10 +1136,10 @@ let replay_history tactic_normalisation = (intros_using [id]); (loop l) ]; Tacticals.New.tclTHENLIST [ - (Proofview.V82.tactic (unfold sp_Zgt)); - (Proofview.V82.tactic simpl_in_concl); + (unfold sp_Zgt); + simpl_in_concl; reflexivity ] ]; - Tacticals.New.tclTHENLIST [ Proofview.V82.tactic (unfold sp_Zgt); Proofview.V82.tactic simpl_in_concl; reflexivity ] + Tacticals.New.tclTHENLIST [ unfold sp_Zgt; simpl_in_concl; reflexivity ] ]; Tacticals.New.tclTHEN (Proofview.V82.tactic (mk_then tac)) reflexivity ] @@ -1160,18 +1161,18 @@ let replay_history tactic_normalisation = [mkApp (Lazy.force coq_OMEGA4, [| dd;kk;eq2;mkVar aux1; mkVar aux2 |])]); Proofview.V82.tactic (clear [aux1;aux2]); - Proofview.V82.tactic (unfold sp_not); + unfold sp_not; (intros_using [aux]); Proofview.V82.tactic (resolve_id aux); Proofview.V82.tactic (mk_then tac); assumption ] ; Tacticals.New.tclTHENLIST [ - Proofview.V82.tactic (unfold sp_Zgt); - Proofview.V82.tactic simpl_in_concl; + unfold sp_Zgt; + simpl_in_concl; reflexivity ] ]; Tacticals.New.tclTHENLIST [ - Proofview.V82.tactic (unfold sp_Zgt); - Proofview.V82.tactic simpl_in_concl; + unfold sp_Zgt; + simpl_in_concl; reflexivity ] ] | EXACT_DIVIDE (e1,k) :: l -> let id = hyp_of_tag e1.id in @@ -1208,8 +1209,8 @@ let replay_history tactic_normalisation = (intros_using [id]); (loop l) ]; Tacticals.New.tclTHENLIST [ - Proofview.V82.tactic (unfold sp_Zgt); - Proofview.V82.tactic simpl_in_concl; + unfold sp_Zgt; + simpl_in_concl; reflexivity ] ]; Tacticals.New.tclTHEN (Proofview.V82.tactic (mk_then tac)) reflexivity ] | (MERGE_EQ(e3,e1,e2)) :: l -> @@ -1329,12 +1330,12 @@ let replay_history tactic_normalisation = (intros_using [id]); (loop l) ]; Tacticals.New.tclTHENLIST [ - Proofview.V82.tactic (unfold sp_Zgt); - Proofview.V82.tactic simpl_in_concl; + unfold sp_Zgt; + simpl_in_concl; reflexivity ] ]; Tacticals.New.tclTHENLIST [ - Proofview.V82.tactic (unfold sp_Zgt); - Proofview.V82.tactic simpl_in_concl; + unfold sp_Zgt; + simpl_in_concl; reflexivity ] ] | CONSTANT_NOT_NUL(e,k) :: l -> Tacticals.New.tclTHEN (Proofview.V82.tactic (generalize_tac [mkVar (hyp_of_tag e)])) Equality.discrConcl @@ -1343,9 +1344,9 @@ let replay_history tactic_normalisation = | CONSTANT_NEG(e,k) :: l -> Tacticals.New.tclTHENLIST [ Proofview.V82.tactic (generalize_tac [mkVar (hyp_of_tag e)]); - Proofview.V82.tactic (unfold sp_Zle); - Proofview.V82.tactic simpl_in_concl; - Proofview.V82.tactic (unfold sp_not); + unfold sp_Zle; + simpl_in_concl; + unfold sp_not; (intros_using [aux]); Proofview.V82.tactic (resolve_id aux); reflexivity @@ -1695,25 +1696,26 @@ let destructure_hyps = let pf_nf = Tacmach.New.of_old pf_nf gl in let rec loop = function | [] -> (Tacticals.New.tclTHEN nat_inject coq_omega) - | (i,body,t)::lit -> + | decl::lit -> + let (i,_,t) = to_tuple decl in begin try match destructurate_prop t with | Kapp(False,[]) -> elim_id i | Kapp((Zle|Zge|Zgt|Zlt|Zne),[t1;t2]) -> loop lit | Kapp(Or,[t1;t2]) -> (Tacticals.New.tclTHENS (elim_id i) - [ onClearedName i (fun i -> (loop ((i,None,t1)::lit))); - onClearedName i (fun i -> (loop ((i,None,t2)::lit))) ]) + [ onClearedName i (fun i -> (loop (LocalAssum (i,t1)::lit))); + onClearedName i (fun i -> (loop (LocalAssum (i,t2)::lit))) ]) | Kapp(And,[t1;t2]) -> Tacticals.New.tclTHEN (elim_id i) (onClearedName2 i (fun i1 i2 -> - loop ((i1,None,t1)::(i2,None,t2)::lit))) + loop (LocalAssum (i1,t1) :: LocalAssum (i2,t2) :: lit))) | Kapp(Iff,[t1;t2]) -> Tacticals.New.tclTHEN (elim_id i) (onClearedName2 i (fun i1 i2 -> - loop ((i1,None,mkArrow t1 t2)::(i2,None,mkArrow t2 t1)::lit))) + loop (LocalAssum (i1,mkArrow t1 t2) :: LocalAssum (i2,mkArrow t2 t1) :: lit))) | Kimp(t1,t2) -> (* t1 and t2 might be in Type rather than Prop. For t1, the decidability check will ensure being Prop. *) @@ -1724,7 +1726,7 @@ let destructure_hyps = Proofview.V82.tactic (generalize_tac [mkApp (Lazy.force coq_imp_simp, [| t1; t2; d1; mkVar i|])]); (onClearedName i (fun i -> - (loop ((i,None,mk_or (mk_not t1) t2)::lit)))) + (loop (LocalAssum (i,mk_or (mk_not t1) t2) :: lit)))) ] else loop lit @@ -1735,7 +1737,7 @@ let destructure_hyps = Proofview.V82.tactic (generalize_tac [mkApp (Lazy.force coq_not_or,[| t1; t2; mkVar i |])]); (onClearedName i (fun i -> - (loop ((i,None,mk_and (mk_not t1) (mk_not t2)):: lit)))) + (loop (LocalAssum (i,mk_and (mk_not t1) (mk_not t2)) :: lit)))) ] | Kapp(And,[t1;t2]) -> let d1 = decidability t1 in @@ -1744,7 +1746,7 @@ let destructure_hyps = [mkApp (Lazy.force coq_not_and, [| t1; t2; d1; mkVar i |])]); (onClearedName i (fun i -> - (loop ((i,None,mk_or (mk_not t1) (mk_not t2))::lit)))) + (loop (LocalAssum (i,mk_or (mk_not t1) (mk_not t2)) :: lit)))) ] | Kapp(Iff,[t1;t2]) -> let d1 = decidability t1 in @@ -1754,9 +1756,8 @@ let destructure_hyps = [mkApp (Lazy.force coq_not_iff, [| t1; t2; d1; d2; mkVar i |])]); (onClearedName i (fun i -> - (loop ((i,None, - mk_or (mk_and t1 (mk_not t2)) - (mk_and (mk_not t1) t2))::lit)))) + (loop (LocalAssum (i, mk_or (mk_and t1 (mk_not t2)) + (mk_and (mk_not t1) t2)) :: lit)))) ] | Kimp(t1,t2) -> (* t2 must be in Prop otherwise ~(t1->t2) wouldn't be ok. @@ -1767,14 +1768,14 @@ let destructure_hyps = [mkApp (Lazy.force coq_not_imp, [| t1; t2; d1; mkVar i |])]); (onClearedName i (fun i -> - (loop ((i,None,mk_and t1 (mk_not t2)) :: lit)))) + (loop (LocalAssum (i,mk_and t1 (mk_not t2)) :: lit)))) ] | Kapp(Not,[t]) -> let d = decidability t in Tacticals.New.tclTHENLIST [ Proofview.V82.tactic (generalize_tac [mkApp (Lazy.force coq_not_not, [| t; d; mkVar i |])]); - (onClearedName i (fun i -> (loop ((i,None,t)::lit)))) + (onClearedName i (fun i -> (loop (LocalAssum (i,t) :: lit)))) ] | Kapp(op,[t1;t2]) -> (try @@ -1807,15 +1808,13 @@ let destructure_hyps = match destructurate_type (pf_nf typ) with | Kapp(Nat,_) -> (Tacticals.New.tclTHEN - (convert_hyp_no_check - (i,body, - (mkApp (Lazy.force coq_neq, [| t1;t2|])))) + (convert_hyp_no_check (set_type (mkApp (Lazy.force coq_neq, [| t1;t2|])) + decl)) (loop lit)) | Kapp(Z,_) -> (Tacticals.New.tclTHEN - (convert_hyp_no_check - (i,body, - (mkApp (Lazy.force coq_Zne, [| t1;t2|])))) + (convert_hyp_no_check (set_type (mkApp (Lazy.force coq_Zne, [| t1;t2|])) + decl)) (loop lit)) | _ -> loop lit end @@ -1839,7 +1838,7 @@ let destructure_goal = match destructurate_prop t with | Kapp(Not,[t]) -> (Tacticals.New.tclTHEN - (Tacticals.New.tclTHEN (Proofview.V82.tactic (unfold sp_not)) intro) + (Tacticals.New.tclTHEN (unfold sp_not) intro) destructure_hyps) | Kimp(a,b) -> (Tacticals.New.tclTHEN intro (loop b)) | Kapp(False,[]) -> destructure_hyps diff --git a/plugins/omega/g_omega.ml4 b/plugins/omega/g_omega.ml4 index 46bbe2fd2..b314e0d85 100644 --- a/plugins/omega/g_omega.ml4 +++ b/plugins/omega/g_omega.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -17,15 +17,24 @@ DECLARE PLUGIN "omega_plugin" +open Names open Coq_omega +open Constrarg +open Pcoq.Prim + +let eval_tactic name = + let dp = DirPath.make (List.map Id.of_string ["PreOmega"; "omega"; "Coq"]) in + let kn = KerName.make2 (MPfile dp) (Label.make name) in + let tac = Tacenv.interp_ltac kn in + Tacinterp.eval_tactic tac let omega_tactic l = let tacs = List.map (function - | "nat" -> Tacinterp.interp <:tactic<zify_nat>> - | "positive" -> Tacinterp.interp <:tactic<zify_positive>> - | "N" -> Tacinterp.interp <:tactic<zify_N>> - | "Z" -> Tacinterp.interp <:tactic<zify_op>> + | "nat" -> eval_tactic "zify_nat" + | "positive" -> eval_tactic "zify_positive" + | "N" -> eval_tactic "zify_N" + | "Z" -> eval_tactic "zify_op" | s -> Errors.error ("No Omega knowledge base for type "^s)) (Util.List.sort_uniquize String.compare l) in diff --git a/plugins/omega/omega.ml b/plugins/omega/omega.ml index 67a1ff960..bd991a955 100644 --- a/plugins/omega/omega.ml +++ b/plugins/omega/omega.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/quote/Quote.v b/plugins/quote/Quote.v index ca1a18e80..2d154adc5 100644 --- a/plugins/quote/Quote.v +++ b/plugins/quote/Quote.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/quote/g_quote.ml4 b/plugins/quote/g_quote.ml4 index e27fe7f45..a15b0eb05 100644 --- a/plugins/quote/g_quote.ml4 +++ b/plugins/quote/g_quote.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -13,19 +13,22 @@ open Misctypes open Tacexpr open Geninterp open Quote +open Constrarg +open Pcoq.Prim +open Pcoq.Constr +open Pcoq.Tactic DECLARE PLUGIN "quote_plugin" let loc = Loc.ghost -let cont = (loc, Id.of_string "cont") -let x = (loc, Id.of_string "x") +let cont = Id.of_string "cont" +let x = Id.of_string "x" -let make_cont (k : glob_tactic_expr) (c : Constr.t) = +let make_cont (k : Genarg.Val.t) (c : Constr.t) = let c = Tacinterp.Value.of_constr c in - let tac = TacCall (loc, ArgVar cont, [Reference (ArgVar x)]) in - let tac = TacLetIn (false, [(cont, Tacexp k)], TacArg (loc, tac)) in - let ist = { lfun = Id.Map.singleton (snd x) c; extra = TacStore.empty; } in - Tacinterp.eval_tactic_ist ist tac + let tac = TacCall (loc, ArgVar (loc, cont), [Reference (ArgVar (loc, x))]) in + let ist = { lfun = Id.Map.add cont k (Id.Map.singleton x c); extra = TacStore.empty; } in + Tacinterp.eval_tactic_ist ist (TacArg (loc, tac)) TACTIC EXTEND quote [ "quote" ident(f) ] -> [ quote f [] ] diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml index 04936cd83..dbd7460e2 100644 --- a/plugins/quote/quote.ml +++ b/plugins/quote/quote.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -212,9 +212,9 @@ let compute_rhs bodyi index_of_f = let i = destRel (Array.last args) in PMeta (Some (coerce_meta_in i)) | App (f,args) -> - PApp (pi3 (pattern_of_constr (Global.env()) Evd.empty f), Array.map aux args) + PApp (pattern_of_constr (Global.env()) Evd.empty f, Array.map aux args) | Cast (c,_,_) -> aux c - | _ -> pi3 (pattern_of_constr (Global.env())(*FIXME*) Evd.empty c) + | _ -> pattern_of_constr (Global.env())(*FIXME*) Evd.empty c in aux bodyi diff --git a/plugins/romega/ReflOmegaCore.v b/plugins/romega/ReflOmegaCore.v index b84cf2540..36511386a 100644 --- a/plugins/romega/ReflOmegaCore.v +++ b/plugins/romega/ReflOmegaCore.v @@ -1492,7 +1492,7 @@ with Simplify := match goal with end. Ltac prove_stable x th := - match constr:x with + match constr:(x) with | ?X1 => unfold term_stable, X1; intros; Simplify; simpl; apply th diff --git a/plugins/romega/g_romega.ml4 b/plugins/romega/g_romega.ml4 index 0a99a26b3..61efa9f54 100644 --- a/plugins/romega/g_romega.ml4 +++ b/plugins/romega/g_romega.ml4 @@ -10,15 +10,24 @@ DECLARE PLUGIN "romega_plugin" +open Names open Refl_omega +open Constrarg +open Pcoq.Prim + +let eval_tactic name = + let dp = DirPath.make (List.map Id.of_string ["PreOmega"; "omega"; "Coq"]) in + let kn = KerName.make2 (MPfile dp) (Label.make name) in + let tac = Tacenv.interp_ltac kn in + Tacinterp.eval_tactic tac let romega_tactic l = let tacs = List.map (function - | "nat" -> Tacinterp.interp <:tactic<zify_nat>> - | "positive" -> Tacinterp.interp <:tactic<zify_positive>> - | "N" -> Tacinterp.interp <:tactic<zify_N>> - | "Z" -> Tacinterp.interp <:tactic<zify_op>> + | "nat" -> eval_tactic "zify_nat" + | "positive" -> eval_tactic "zify_positive" + | "N" -> eval_tactic "zify_N" + | "Z" -> eval_tactic "zify_op" | s -> Errors.error ("No ROmega knowledge base for type "^s)) (Util.List.sort_uniquize String.compare l) in diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index 95407c5ff..177c870b3 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -46,7 +46,7 @@ let occ_step_eq s1 s2 = match s1, s2 with d'une liste de pas à partir de la racine de l'hypothèse *) type occurrence = {o_hyp : Names.Id.t; o_path : occ_path} -(* \subsection{refiable formulas} *) +(* \subsection{reifiable formulas} *) type oformula = (* integer *) | Oint of Bigint.bigint @@ -55,7 +55,7 @@ type oformula = | Omult of oformula * oformula | Ominus of oformula * oformula | Oopp of oformula - (* an atome in the environment *) + (* an atom in the environment *) | Oatom of int (* weird expression that cannot be translated *) | Oufo of oformula @@ -75,7 +75,7 @@ type oproposition = | Pimp of int * oproposition * oproposition | Pprop of Term.constr -(* Les équations ou proposiitions atomiques utiles du calcul *) +(* Les équations ou propositions atomiques utiles du calcul *) and oequation = { e_comp: comparaison; (* comparaison *) e_left: oformula; (* formule brute gauche *) @@ -1266,7 +1266,7 @@ let resolution env full_reified_goal systems_list = | (O_right :: l) -> app coq_p_right [| loop l |] in let correct_index = let i = List.index0 Names.Id.equal e.e_origin.o_hyp l_hyps in - (* PL: it seems that additionnally introduced hyps are in the way during + (* PL: it seems that additionally introduced hyps are in the way during normalization, hence this index shifting... *) if Int.equal i 0 then 0 else Pervasives.(+) i (List.length to_introduce) in @@ -1285,7 +1285,7 @@ let resolution env full_reified_goal systems_list = Proofview.V82.of_tactic (Tactics.change_concl reified) >> Proofview.V82.of_tactic (Tactics.apply (app coq_do_omega [|decompose_tactic; normalization_trace|])) >> show_goal >> - Tactics.normalise_vm_in_concl >> + Proofview.V82.of_tactic (Tactics.normalise_vm_in_concl) >> (*i Alternatives to the previous line: - Normalisation without VM: Tactics.normalise_in_concl diff --git a/plugins/rtauto/Bintree.v b/plugins/rtauto/Bintree.v index 267cd4723..7394cebde 100644 --- a/plugins/rtauto/Bintree.v +++ b/plugins/rtauto/Bintree.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/rtauto/Rtauto.v b/plugins/rtauto/Rtauto.v index 61a160b2c..0dc6e31b8 100644 --- a/plugins/rtauto/Rtauto.v +++ b/plugins/rtauto/Rtauto.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/rtauto/g_rtauto.ml4 b/plugins/rtauto/g_rtauto.ml4 index 7fefab3ed..d27b04834 100644 --- a/plugins/rtauto/g_rtauto.ml4 +++ b/plugins/rtauto/g_rtauto.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/rtauto/proof_search.ml b/plugins/rtauto/proof_search.ml index 23510117b..3ba92b9f2 100644 --- a/plugins/rtauto/proof_search.ml +++ b/plugins/rtauto/proof_search.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/rtauto/proof_search.mli b/plugins/rtauto/proof_search.mli index 86a2fb666..31f8e7b51 100644 --- a/plugins/rtauto/proof_search.mli +++ b/plugins/rtauto/proof_search.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml index 4ffc1f331..2f3a3e551 100644 --- a/plugins/rtauto/refl_tauto.ml +++ b/plugins/rtauto/refl_tauto.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -13,6 +13,7 @@ open Util open Term open Tacmach open Proof_search +open Context.Named.Declaration let force count lazc = incr count;Lazy.force lazc @@ -128,9 +129,9 @@ let rec make_form atom_env gls term = let rec make_hyps atom_env gls lenv = function [] -> [] - | (_,Some body,typ)::rest -> + | LocalDef (_,body,typ)::rest -> make_hyps atom_env gls (typ::body::lenv) rest - | (id,None,typ)::rest -> + | LocalAssum (id,typ)::rest -> let hrec= make_hyps atom_env gls (typ::lenv) rest in if List.exists (Termops.dependent (mkVar id)) lenv || diff --git a/plugins/rtauto/refl_tauto.mli b/plugins/rtauto/refl_tauto.mli index 45fb50dcc..9a14ac6c7 100644 --- a/plugins/rtauto/refl_tauto.mli +++ b/plugins/rtauto/refl_tauto.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -18,7 +18,7 @@ val make_hyps : atom_env -> Proof_type.goal Tacmach.sigma -> Term.types list -> - (Names.Id.t * Term.types option * Term.types) list -> + Context.Named.t -> (Names.Id.t * Proof_search.form) list val rtauto_tac : Proof_type.tactic diff --git a/plugins/setoid_ring/ArithRing.v b/plugins/setoid_ring/ArithRing.v index e7d0cd8e7..5f5b97925 100644 --- a/plugins/setoid_ring/ArithRing.v +++ b/plugins/setoid_ring/ArithRing.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -32,13 +32,13 @@ Qed. Ltac natcst t := match isnatcst t with true => constr:(N.of_nat t) - | _ => constr:InitialRing.NotConstant + | _ => constr:(InitialRing.NotConstant) end. Ltac Ss_to_add f acc := match f with | S ?f1 => Ss_to_add f1 (S acc) - | _ => constr:(acc + f)%nat + | _ => constr:((acc + f)%nat) end. Ltac natprering := diff --git a/plugins/setoid_ring/BinList.v b/plugins/setoid_ring/BinList.v index 5dd1b86dd..d639f6085 100644 --- a/plugins/setoid_ring/BinList.v +++ b/plugins/setoid_ring/BinList.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/setoid_ring/Cring.v b/plugins/setoid_ring/Cring.v index 4872c7764..17a57e62a 100644 --- a/plugins/setoid_ring/Cring.v +++ b/plugins/setoid_ring/Cring.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/setoid_ring/Field.v b/plugins/setoid_ring/Field.v index 4de2efe37..73a131398 100644 --- a/plugins/setoid_ring/Field.v +++ b/plugins/setoid_ring/Field.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/setoid_ring/Field_tac.v b/plugins/setoid_ring/Field_tac.v index f867c6d08..babbb86a9 100644 --- a/plugins/setoid_ring/Field_tac.v +++ b/plugins/setoid_ring/Field_tac.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/setoid_ring/Field_theory.v b/plugins/setoid_ring/Field_theory.v index 0f5c49b0f..2932d379e 100644 --- a/plugins/setoid_ring/Field_theory.v +++ b/plugins/setoid_ring/Field_theory.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/setoid_ring/InitialRing.v b/plugins/setoid_ring/InitialRing.v index b92b847be..8fcc07716 100644 --- a/plugins/setoid_ring/InitialRing.v +++ b/plugins/setoid_ring/InitialRing.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -155,7 +155,7 @@ Section ZMORPHISM. Ltac norm := gen_srewrite Rsth Reqe ARth. Ltac add_push := gen_add_push radd Rsth Reqe ARth. -(*morphisms are extensionaly equal*) +(*morphisms are extensionally equal*) Lemma same_genZ : forall x, [x] == gen_phiZ1 x. Proof. destruct x;simpl; try rewrite (same_gen ARth);rrefl. @@ -246,7 +246,7 @@ Proof (SRth_ARth Nsth Nth). Lemma Neqb_ok : forall x y, N.eqb x y = true -> x = y. Proof. exact (fun x y => proj1 (N.eqb_eq x y)). Qed. -(**Same as above : definition of two,extensionaly equal, generic morphisms *) +(**Same as above : definition of two, extensionally equal, generic morphisms *) (**from N to any semi-ring*) Section NMORPHISM. Variable R : Type. @@ -612,32 +612,32 @@ End GEN_DIV. Ltac inv_gen_phi_pos rI add mul t := let rec inv_cst t := match t with - rI => constr:1%positive - | (add rI rI) => constr:2%positive - | (add rI (add rI rI)) => constr:3%positive + rI => constr:(1%positive) + | (add rI rI) => constr:(2%positive) + | (add rI (add rI rI)) => constr:(3%positive) | (mul (add rI rI) ?p) => (* 2p *) match inv_cst p with - NotConstant => constr:NotConstant - | 1%positive => constr:NotConstant (* 2*1 is not convertible to 2 *) + NotConstant => constr:(NotConstant) + | 1%positive => constr:(NotConstant) (* 2*1 is not convertible to 2 *) | ?p => constr:(xO p) end | (add rI (mul (add rI rI) ?p)) => (* 1+2p *) match inv_cst p with - NotConstant => constr:NotConstant - | 1%positive => constr:NotConstant + NotConstant => constr:(NotConstant) + | 1%positive => constr:(NotConstant) | ?p => constr:(xI p) end - | _ => constr:NotConstant + | _ => constr:(NotConstant) end in inv_cst t. (* The (partial) inverse of gen_phiNword *) Ltac inv_gen_phiNword rO rI add mul opp t := match t with - rO => constr:NwO + rO => constr:(NwO) | _ => match inv_gen_phi_pos rI add mul t with - NotConstant => constr:NotConstant + NotConstant => constr:(NotConstant) | ?p => constr:(Npos p::nil) end end. @@ -646,10 +646,10 @@ End GEN_DIV. (* The inverse of gen_phiN *) Ltac inv_gen_phiN rO rI add mul t := match t with - rO => constr:0%N + rO => constr:(0%N) | _ => match inv_gen_phi_pos rI add mul t with - NotConstant => constr:NotConstant + NotConstant => constr:(NotConstant) | ?p => constr:(Npos p) end end. @@ -657,21 +657,21 @@ End GEN_DIV. (* The inverse of gen_phiZ *) Ltac inv_gen_phiZ rO rI add mul opp t := match t with - rO => constr:0%Z + rO => constr:(0%Z) | (opp ?p) => match inv_gen_phi_pos rI add mul p with - NotConstant => constr:NotConstant + NotConstant => constr:(NotConstant) | ?p => constr:(Zneg p) end | _ => match inv_gen_phi_pos rI add mul t with - NotConstant => constr:NotConstant + NotConstant => constr:(NotConstant) | ?p => constr:(Zpos p) end end. (* A simple tactic recognizing only 0 and 1. The inv_gen_phiX above - are only optimisations that directly returns the reifid constant + are only optimisations that directly returns the reified constant instead of resorting to the constant propagation of the simplification algorithm. *) Ltac inv_gen_phi rO rI cO cI t := @@ -681,7 +681,7 @@ Ltac inv_gen_phi rO rI cO cI t := end. (* A simple tactic recognizing no constant *) - Ltac inv_morph_nothing t := constr:NotConstant. + Ltac inv_morph_nothing t := constr:(NotConstant). Ltac coerce_to_almost_ring set ext rspec := match type of rspec with @@ -825,31 +825,31 @@ Ltac ring_elements set ext rspec pspec sspec dspec rk := (* Tactic for constant *) Ltac isnatcst t := match t with - O => constr:true + O => constr:(true) | S ?p => isnatcst p - | _ => constr:false + | _ => constr:(false) end. Ltac isPcst t := match t with | xI ?p => isPcst p | xO ?p => isPcst p - | xH => constr:true + | xH => constr:(true) (* nat -> positive *) | Pos.of_succ_nat ?n => isnatcst n - | _ => constr:false + | _ => constr:(false) end. Ltac isNcst t := match t with - N0 => constr:true + N0 => constr:(true) | Npos ?p => isPcst p - | _ => constr:false + | _ => constr:(false) end. Ltac isZcst t := match t with - Z0 => constr:true + Z0 => constr:(true) | Zpos ?p => isPcst p | Zneg ?p => isPcst p (* injection nat -> Z *) @@ -857,7 +857,7 @@ Ltac isZcst t := (* injection N -> Z *) | Z.of_N ?n => isNcst n (* *) - | _ => constr:false + | _ => constr:(false) end. diff --git a/plugins/setoid_ring/NArithRing.v b/plugins/setoid_ring/NArithRing.v index a10eeecce..54e2789ba 100644 --- a/plugins/setoid_ring/NArithRing.v +++ b/plugins/setoid_ring/NArithRing.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -15,7 +15,7 @@ Set Implicit Arguments. Ltac Ncst t := match isNcst t with true => t - | _ => constr:NotConstant + | _ => constr:(NotConstant) end. Add Ring Nr : Nth (decidable Neqb_ok, constants [Ncst]). diff --git a/plugins/setoid_ring/Ncring.v b/plugins/setoid_ring/Ncring.v index 2dc3197d1..cd3bef435 100644 --- a/plugins/setoid_ring/Ncring.v +++ b/plugins/setoid_ring/Ncring.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/setoid_ring/Ncring_initial.v b/plugins/setoid_ring/Ncring_initial.v index c40e0ffba..96885d2f7 100644 --- a/plugins/setoid_ring/Ncring_initial.v +++ b/plugins/setoid_ring/Ncring_initial.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -42,7 +42,7 @@ Defined. (*Instance ZEquality: @Equality Z:= (@eq Z).*) -(** Two generic morphisms from Z to (abrbitrary) rings, *) +(** Two generic morphisms from Z to (arbitrary) rings, *) (**second one is more convenient for proofs but they are ext. equal*) Section ZMORPHISM. Context {R:Type}`{Ring R}. @@ -130,7 +130,7 @@ Ltac rsimpl := simpl. Qed. -(*morphisms are extensionaly equal*) +(*morphisms are extensionally equal*) Lemma same_genZ : forall x, [x] == gen_phiZ1 x. Proof. destruct x;rsimpl; try rewrite same_gen; reflexivity. diff --git a/plugins/setoid_ring/Ncring_polynom.v b/plugins/setoid_ring/Ncring_polynom.v index 5845b6298..109808ee0 100644 --- a/plugins/setoid_ring/Ncring_polynom.v +++ b/plugins/setoid_ring/Ncring_polynom.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/setoid_ring/Ncring_tac.v b/plugins/setoid_ring/Ncring_tac.v index 31c9e54d9..5e30a1300 100644 --- a/plugins/setoid_ring/Ncring_tac.v +++ b/plugins/setoid_ring/Ncring_tac.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/setoid_ring/Ring.v b/plugins/setoid_ring/Ring.v index b2417db6f..77576cb93 100644 --- a/plugins/setoid_ring/Ring.v +++ b/plugins/setoid_ring/Ring.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -36,9 +36,9 @@ Qed. Ltac bool_cst t := let t := eval hnf in t in match t with - true => constr:true - | false => constr:false - | _ => constr:NotConstant + true => constr:(true) + | false => constr:(false) + | _ => constr:(NotConstant) end. Add Ring bool_ring : BoolTheory (decidable bool_eq_ok, constants [bool_cst]). diff --git a/plugins/setoid_ring/Ring_base.v b/plugins/setoid_ring/Ring_base.v index 9508b8e78..dc7c10cc5 100644 --- a/plugins/setoid_ring/Ring_base.v +++ b/plugins/setoid_ring/Ring_base.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/setoid_ring/Ring_polynom.v b/plugins/setoid_ring/Ring_polynom.v index 2d2756b1c..760ad4da1 100644 --- a/plugins/setoid_ring/Ring_polynom.v +++ b/plugins/setoid_ring/Ring_polynom.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/setoid_ring/Ring_theory.v b/plugins/setoid_ring/Ring_theory.v index 4f05f0d4a..7fcd6c08a 100644 --- a/plugins/setoid_ring/Ring_theory.v +++ b/plugins/setoid_ring/Ring_theory.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/setoid_ring/ZArithRing.v b/plugins/setoid_ring/ZArithRing.v index 848e06a7b..23784cf33 100644 --- a/plugins/setoid_ring/ZArithRing.v +++ b/plugins/setoid_ring/ZArithRing.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -17,14 +17,14 @@ Set Implicit Arguments. Ltac Zcst t := match isZcst t with true => t - | _ => constr:NotConstant + | _ => constr:(NotConstant) end. Ltac isZpow_coef t := match t with | Zpos ?p => isPcst p - | Z0 => constr:true - | _ => constr:false + | Z0 => constr:(true) + | _ => constr:(false) end. Notation N_of_Z := Z.to_N (only parsing). @@ -32,7 +32,7 @@ Notation N_of_Z := Z.to_N (only parsing). Ltac Zpow_tac t := match isZpow_coef t with | true => constr:(N_of_Z t) - | _ => constr:NotConstant + | _ => constr:(NotConstant) end. Ltac Zpower_neg := diff --git a/plugins/setoid_ring/g_newring.ml4 b/plugins/setoid_ring/g_newring.ml4 index 856ec0db5..1ebb6e6b7 100644 --- a/plugins/setoid_ring/g_newring.ml4 +++ b/plugins/setoid_ring/g_newring.ml4 @@ -14,6 +14,11 @@ open Libnames open Printer open Newring_ast open Newring +open Stdarg +open Constrarg +open Pcoq.Prim +open Pcoq.Constr +open Pcoq.Tactic DECLARE PLUGIN "newring_plugin" @@ -46,9 +51,14 @@ VERNAC ARGUMENT EXTEND ring_mod | [ "div" constr(div_spec) ] -> [ Div_spec div_spec ] END +VERNAC ARGUMENT EXTEND ring_mods + | [ "(" ne_ring_mod_list_sep(mods, ",") ")" ] -> [ mods ] +END + VERNAC COMMAND EXTEND AddSetoidRing CLASSIFIED AS SIDEFF - | [ "Add" "Ring" ident(id) ":" constr(t) ring_mods(l) ] -> - [ let (k,set,cst,pre,post,power,sign, div) = process_ring_mods l in + | [ "Add" "Ring" ident(id) ":" constr(t) ring_mods_opt(l) ] -> + [ let l = match l with None -> [] | Some l -> l in + let (k,set,cst,pre,post,power,sign, div) = process_ring_mods l in add_theory id (ic t) set k cst (pre,post) power sign div] | [ "Print" "Rings" ] => [Vernac_classifier.classify_as_query] -> [ msg_notice (strbrk "The following ring structures have been declared:"); @@ -70,9 +80,14 @@ VERNAC ARGUMENT EXTEND field_mod | [ "completeness" constr(inj) ] -> [ Inject inj ] END +VERNAC ARGUMENT EXTEND field_mods + | [ "(" ne_field_mod_list_sep(mods, ",") ")" ] -> [ mods ] +END + VERNAC COMMAND EXTEND AddSetoidField CLASSIFIED AS SIDEFF -| [ "Add" "Field" ident(id) ":" constr(t) field_mods(l) ] -> - [ let (k,set,inj,cst_tac,pre,post,power,sign,div) = process_field_mods l in +| [ "Add" "Field" ident(id) ":" constr(t) field_mods_opt(l) ] -> + [ let l = match l with None -> [] | Some l -> l in + let (k,set,inj,cst_tac,pre,post,power,sign,div) = process_field_mods l in add_field_theory id (ic t) set k cst_tac inj (pre,post) power sign div] | [ "Print" "Fields" ] => [Vernac_classifier.classify_as_query] -> [ msg_notice (strbrk "The following field structures have been declared:"); diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index dbe7710eb..7ef89b7a0 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4deps: "grammar/grammar.cma" i*) - open Pp open Errors open Util @@ -99,10 +97,10 @@ let protect_red map env sigma c = (mk_clos_but (lookup_map map c) (Esubst.subs_id 0) c);; let protect_tac map = - Tactics.reduct_option (protect_red map,DEFAULTcast) None ;; + Proofview.V82.of_tactic (Tactics.reduct_option (protect_red map,DEFAULTcast) None);; let protect_tac_in map id = - Tactics.reduct_option (protect_red map,DEFAULTcast) (Some(id, Locus.InHyp));; + Proofview.V82.of_tactic (Tactics.reduct_option (protect_red map,DEFAULTcast) (Some(id, Locus.InHyp)));; (****************************************************************************) @@ -137,8 +135,8 @@ let closed_term_ast l = let l = List.map (fun gr -> ArgArg(Loc.ghost,gr)) l in TacFun([Some(Id.of_string"t")], TacML(Loc.ghost,tacname, - [Genarg.in_gen (Genarg.glbwit Constrarg.wit_constr) (GVar(Loc.ghost,Id.of_string"t"),None); - Genarg.in_gen (Genarg.glbwit (Genarg.wit_list Constrarg.wit_ref)) l])) + [TacGeneric (Genarg.in_gen (Genarg.glbwit Constrarg.wit_constr) (GVar(Loc.ghost,Id.of_string"t"),None)); + TacGeneric (Genarg.in_gen (Genarg.glbwit (Genarg.wit_list Constrarg.wit_ref)) l)])) (* let _ = add_tacdef false ((Loc.ghost,Id.of_string"ring_closed_term" *) @@ -176,19 +174,20 @@ let ltac_call tac (args:glob_tactic_arg list) = let ltac_lcall tac args = TacArg(Loc.ghost,TacCall(Loc.ghost, ArgVar(Loc.ghost, Id.of_string tac),args)) -let ltac_letin (x, e1) e2 = - TacLetIn(false,[(Loc.ghost,Id.of_string x),e1],e2) - -let ltac_apply (f:glob_tactic_expr) (args:glob_tactic_arg list) = - Tacinterp.eval_tactic - (ltac_letin ("F", Tacexp f) (ltac_lcall "F" args)) +let ltac_apply (f : Value.t) (args: Tacinterp.Value.t list) = + let fold arg (i, vars, lfun) = + let id = Id.of_string ("x" ^ string_of_int i) in + let x = Reference (ArgVar (Loc.ghost, id)) in + (succ i, x :: vars, Id.Map.add id arg lfun) + in + let (_, args, lfun) = List.fold_right fold args (0, [], Id.Map.empty) in + let lfun = Id.Map.add (Id.of_string "F") f lfun in + let ist = { (Tacinterp.default_ist ()) with Tacinterp.lfun = lfun; } in + Tacinterp.eval_tactic_ist ist (ltac_lcall "F" args) let ltac_record flds = TacFun([Some(Id.of_string"proj")], ltac_lcall "proj" flds) - -let carg c = TacDynamic(Loc.ghost,Pretyping.constr_in c) - let dummy_goal env sigma = let (gl,_,sigma) = Goal.V82.mk_goal sigma (named_context_val env) mkProp Evd.Store.empty in @@ -198,20 +197,39 @@ let constr_of v = match Value.to_constr v with | Some c -> c | None -> failwith "Ring.exec_tactic: anomaly" +let tactic_res = ref [||] + +let get_res = + let open Tacexpr in + let name = { mltac_plugin = "newring_plugin"; mltac_tactic = "get_res"; } in + let entry = { mltac_name = name; mltac_index = 0 } in + let tac args ist = + let n = Tacinterp.Value.cast (Genarg.topwit Stdarg.wit_int) (List.hd args) in + let init i = Id.Map.find (Id.of_string ("x" ^ string_of_int i)) ist.lfun in + tactic_res := Array.init n init; + Proofview.tclUNIT () + in + Tacenv.register_ml_tactic name [| tac |]; + entry + let exec_tactic env evd n f args = + let fold arg (i, vars, lfun) = + let id = Id.of_string ("x" ^ string_of_int i) in + let x = Reference (ArgVar (Loc.ghost, id)) in + (succ i, x :: vars, Id.Map.add id (Value.of_constr arg) lfun) + in + let (_, args, lfun) = List.fold_right fold args (0, [], Id.Map.empty) in + let ist = { (Tacinterp.default_ist ()) with Tacinterp.lfun = lfun; } in + (** Build the getter *) let lid = List.init n (fun i -> Id.of_string("x"^string_of_int i)) in - let res = ref [||] in - let get_res ist = - let l = List.map (fun id -> Id.Map.find id ist.lfun) lid in - res := Array.of_list l; - TacId[] in - let getter = - Tacexp(TacFun(List.map(fun id -> Some id) lid, - Tacintern.glob_tactic(tacticIn get_res))) in + let n = Genarg.in_gen (Genarg.glbwit Stdarg.wit_int) n in + let get_res = TacML (Loc.ghost, get_res, [TacGeneric n]) in + let getter = Tacexp (TacFun (List.map (fun id -> Some id) lid, get_res)) in + (** Evaluate the whole result *) let gl = dummy_goal env evd in - let gls = Proofview.V82.of_tactic (Tacinterp.eval_tactic(ltac_call f (args@[getter]))) gl in + let gls = Proofview.V82.of_tactic (Tacinterp.eval_tactic_ist ist (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)) !tactic_res, snd (Evd.universe_context evd) let stdlib_modules = [["Coq";"Setoids";"Setoid"]; @@ -504,8 +522,8 @@ let ring_equality env evd (r,add,mul,opp,req) = match opp with Some opp -> plapp evd coq_eq_morph [|r;add;mul;opp|] | None -> plapp evd coq_eq_smorph [|r;add;mul|] in - let setoid = Typing.solve_evars env evd setoid in - let op_morph = Typing.solve_evars env evd op_morph in + let setoid = Typing.e_solve_evars env evd setoid in + let op_morph = Typing.e_solve_evars env evd op_morph in (setoid,op_morph) | _ -> let setoid = setoid_of_relation (Global.env ()) evd r req in @@ -604,7 +622,7 @@ let make_hyp_list env evd lH = (fun c l -> plapp evd coq_cons [|carrier; (make_hyp env evd c); l|]) lH (plapp evd coq_nil [|carrier|]) in - let l' = Typing.solve_evars env evd l in + let l' = Typing.e_solve_evars env evd l in Evarutil.nf_evars_universes !evd l' let interp_power env evd pow = @@ -652,7 +670,7 @@ let add_theory name (sigma,rth) eqth morphth cst_tac (pre,post) power sign div = let rk = reflect_coeff morphth in let params,ctx = exec_tactic env !evd 5 (zltac "ring_lemmas") - (List.map carg[sth;ext;rth;pspec;sspec;dspec;rk]) in + [sth;ext;rth;pspec;sspec;dspec;rk] in let lemma1 = params.(3) in let lemma2 = params.(4) in @@ -730,7 +748,11 @@ let make_term_list env evd carrier rl = let l = List.fold_right (fun x l -> plapp evd coq_cons [|carrier;x;l|]) rl (plapp evd coq_nil [|carrier|]) - in Typing.solve_evars env evd l + in Typing.e_solve_evars env evd l + +let carg = Tacinterp.Value.of_constr +let tacarg expr = + Tacinterp.Value.of_closure (Tacinterp.default_ist ()) expr let ltac_ring_structure e = let req = carg e.ring_req in @@ -738,16 +760,16 @@ let ltac_ring_structure e = let ext = carg e.ring_ext in let morph = carg e.ring_morph in let th = carg e.ring_th in - let cst_tac = Tacexp e.ring_cst_tac in - let pow_tac = Tacexp e.ring_pow_tac in + let cst_tac = tacarg e.ring_cst_tac in + let pow_tac = tacarg e.ring_pow_tac in let lemma1 = carg e.ring_lemma1 in let lemma2 = carg e.ring_lemma2 in - let pretac = Tacexp(TacFun([None],e.ring_pre_tac)) in - let posttac = Tacexp(TacFun([None],e.ring_post_tac)) in + let pretac = tacarg (TacFun([None],e.ring_pre_tac)) in + let posttac = tacarg (TacFun([None],e.ring_post_tac)) in [req;sth;ext;morph;th;cst_tac;pow_tac; lemma1;lemma2;pretac;posttac] -let ring_lookup (f:glob_tactic_expr) lH rl t = +let ring_lookup (f : Value.t) lH rl t = Proofview.Goal.enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in @@ -937,7 +959,7 @@ let add_field_theory name (sigma,fth) eqth morphth cst_tac inj (pre,post) power let rk = reflect_coeff morphth in let params,ctx = exec_tactic env !evd 9 (field_ltac"field_lemmas") - (List.map carg[sth;ext;inv_m;fth;pspec;sspec;dspec;rk]) in + [sth;ext;inv_m;fth;pspec;sspec;dspec;rk] in let lemma1 = params.(3) in let lemma2 = params.(4) in let lemma3 = params.(5) in @@ -1007,19 +1029,19 @@ let process_field_mods l = let ltac_field_structure e = let req = carg e.field_req in - let cst_tac = Tacexp e.field_cst_tac in - let pow_tac = Tacexp e.field_pow_tac in + let cst_tac = tacarg e.field_cst_tac in + let pow_tac = tacarg e.field_pow_tac in let field_ok = carg e.field_ok in let field_simpl_ok = carg e.field_simpl_ok in let field_simpl_eq_ok = carg e.field_simpl_eq_ok in let field_simpl_eq_in_ok = carg e.field_simpl_eq_in_ok in let cond_ok = carg e.field_cond in - let pretac = Tacexp(TacFun([None],e.field_pre_tac)) in - let posttac = Tacexp(TacFun([None],e.field_post_tac)) in + let pretac = tacarg (TacFun([None],e.field_pre_tac)) in + let posttac = tacarg (TacFun([None],e.field_post_tac)) in [req;cst_tac;pow_tac;field_ok;field_simpl_ok;field_simpl_eq_ok; field_simpl_eq_in_ok;cond_ok;pretac;posttac] -let field_lookup (f:glob_tactic_expr) lH rl t = +let field_lookup (f : Value.t) lH rl t = Proofview.Goal.enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in diff --git a/plugins/setoid_ring/newring.mli b/plugins/setoid_ring/newring.mli index 4bd3383d6..07a1ae833 100644 --- a/plugins/setoid_ring/newring.mli +++ b/plugins/setoid_ring/newring.mli @@ -45,7 +45,7 @@ val ic : constr_expr -> Evd.evar_map * constr val from_name : ring_info Spmap.t ref val ring_lookup : - glob_tactic_expr -> + Genarg.Val.t -> constr list -> constr list -> constr -> unit Proofview.tactic @@ -73,6 +73,6 @@ val add_field_theory : val field_from_name : field_info Spmap.t ref val field_lookup : - glob_tactic_expr -> + Genarg.Val.t -> constr list -> constr list -> constr -> unit Proofview.tactic diff --git a/plugins/syntax/nat_syntax.ml b/plugins/syntax/nat_syntax.ml index 0f280aadb..5f44904c3 100644 --- a/plugins/syntax/nat_syntax.ml +++ b/plugins/syntax/nat_syntax.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/syntax/numbers_syntax.ml b/plugins/syntax/numbers_syntax.ml index b990c0d25..fe9f1319e 100644 --- a/plugins/syntax/numbers_syntax.ml +++ b/plugins/syntax/numbers_syntax.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml index 2c195755b..05d73f9ec 100644 --- a/plugins/syntax/r_syntax.ml +++ b/plugins/syntax/r_syntax.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/syntax/z_syntax.ml b/plugins/syntax/z_syntax.ml index e3721362a..53c1b5d7a 100644 --- a/plugins/syntax/z_syntax.ml +++ b/plugins/syntax/z_syntax.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/xml/README b/plugins/xml/README index e3bcdaf05..312818992 100644 --- a/plugins/xml/README +++ b/plugins/xml/README @@ -1,15 +1,4 @@ -The xml export plugin for Coq has been discontinued for lack of users: -it was most certainly broken while imposing a non-negligible cost on -Coq development. Its purpose was to give export Coq's kernel objects -in xml form for treatment by external tools. - -If you are looking for such a tool, you may want to look at commit -7cfe0a70eda671ada6a46cd779ef9308f7e0fdb9 responsible for the deletion -of this plugin (for instance, git checkout -7cfe0a70eda671ada6a46cd779ef9308f7e0fdb9^ including the "^", will lead -you to the last commit before the xml plugin was deleted). - -Bear in mind, however, that the plugin was not working properly at the -time. You may want instead to write to the original author of the -plugin, Claudio Sacerdoti-Coen at sacerdot@cs.unibo.it. He has a -stable version of the plugin for an old version of Coq. +The xml export plugin for Coq has been removed from the sources. +A backward compatible plug-in will be provided as a third-party plugin. +For more informations, contact +Claudio Sacerdoti Coen <claudio.sacerdoticoen@unibo.it>. diff --git a/pretyping/arguments_renaming.ml b/pretyping/arguments_renaming.ml index 3cfc0dc85..ca1d0b7fb 100644 --- a/pretyping/arguments_renaming.ml +++ b/pretyping/arguments_renaming.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/pretyping/arguments_renaming.mli b/pretyping/arguments_renaming.mli index 290bfc59f..a33405501 100644 --- a/pretyping/arguments_renaming.mli +++ b/pretyping/arguments_renaming.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/pretyping/cases.ml b/pretyping/cases.ml index a5a7ace22..c3968f896 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -13,7 +13,6 @@ open Names open Nameops open Term open Vars -open Context open Termops open Namegen open Declarations @@ -26,9 +25,12 @@ open Glob_ops open Retyping open Pretype_errors open Evarutil +open Evardefine open Evarsolve open Evarconv open Evd +open Sigma.Notations +open Context.Rel.Declaration (* Pattern-matching errors *) @@ -131,7 +133,7 @@ type tomatch_status = | Pushed of (bool*((constr * tomatch_type) * int list * Name.t)) | Alias of (bool*(Name.t * constr * (constr * types))) | NonDepAlias - | Abstract of int * rel_declaration + | Abstract of int * Context.Rel.Declaration.t type tomatch_stack = tomatch_status list @@ -273,13 +275,13 @@ let inductive_template evdref env tmloc ind = | None -> fun _ -> (Loc.ghost, Evar_kinds.InternalHole) in let (_,evarl,_) = List.fold_right - (fun (na,b,ty) (subst,evarl,n) -> - match b with - | None -> + (fun decl (subst,evarl,n) -> + match decl with + | LocalAssum (na,ty) -> let ty' = substl subst ty in let e = e_new_evar env evdref ~src:(hole_source n) ty' in (e::subst,e::evarl,n+1) - | Some b -> + | LocalDef (na,b,ty) -> (substl subst b::subst,evarl,n+1)) arsign ([],[],1) in applist (mkIndU indu,List.rev evarl) @@ -307,15 +309,15 @@ let binding_vars_of_inductive = function | NotInd _ -> [] | IsInd (_,IndType(_,realargs),_) -> List.filter isRel realargs -let extract_inductive_data env sigma (_,b,t) = - match b with - | None -> +let extract_inductive_data env sigma decl = + match decl with + | LocalAssum (_,t) -> let tmtyp = try try_find_ind env sigma t None with Not_found -> NotInd (None,t) in let tmtypvars = binding_vars_of_inductive tmtyp in (tmtyp,tmtypvars) - | Some _ -> + | LocalDef (_,_,t) -> (NotInd (None, t), []) let unify_tomatch_with_patterns evdref env loc typ pats realnames = @@ -428,7 +430,7 @@ let remove_current_pattern eqn = let push_current_pattern (cur,ty) eqn = match eqn.patterns with | pat::pats -> - let rhs_env = push_rel (alias_of_pat pat,Some cur,ty) eqn.rhs.rhs_env in + let rhs_env = push_rel (LocalDef (alias_of_pat pat,cur,ty)) eqn.rhs.rhs_env in { eqn with rhs = { eqn.rhs with rhs_env = rhs_env }; patterns = pats } @@ -455,9 +457,9 @@ let prepend_pattern tms eqn = {eqn with patterns = tms@eqn.patterns } exception NotAdjustable let rec adjust_local_defs loc = function - | (pat :: pats, (_,None,_) :: decls) -> + | (pat :: pats, LocalAssum _ :: decls) -> pat :: adjust_local_defs loc (pats,decls) - | (pats, (_,Some _,_) :: decls) -> + | (pats, LocalDef _ :: decls) -> PatVar (loc, Anonymous) :: adjust_local_defs loc (pats,decls) | [], [] -> [] | _ -> raise NotAdjustable @@ -529,9 +531,10 @@ let dependencies_in_pure_rhs nargs eqns = let deps_columns = matrix_transpose deps_rows in List.map (List.exists (fun x -> x)) deps_columns -let dependent_decl a = function - | (na,None,t) -> dependent a t - | (na,Some c,t) -> dependent a t || dependent a c +let dependent_decl a = + function + | LocalAssum (na,t) -> dependent a t + | LocalDef (na,c,t) -> dependent a t || dependent a c let rec dep_in_tomatch n = function | (Pushed _ | Alias _ | NonDepAlias) :: l -> dep_in_tomatch n l @@ -602,7 +605,7 @@ let relocate_index_tomatch n1 n2 = NonDepAlias :: genrec depth rest | Abstract (i,d) :: rest -> let i = relocate_rel n1 n2 depth i in - Abstract (i,map_rel_declaration (relocate_index n1 n2 depth) d) + Abstract (i, map_constr (relocate_index n1 n2 depth) d) :: genrec (depth+1) rest in genrec 0 @@ -635,7 +638,7 @@ let replace_tomatch n c = | NonDepAlias :: rest -> NonDepAlias :: replrec depth rest | Abstract (i,d) :: rest -> - Abstract (i,map_rel_declaration (replace_term n c depth) d) + Abstract (i, map_constr (replace_term n c depth) d) :: replrec (depth+1) rest in replrec 0 @@ -660,7 +663,7 @@ let rec liftn_tomatch_stack n depth = function NonDepAlias :: liftn_tomatch_stack n depth rest | Abstract (i,d)::rest -> let i = if i<depth then i else i+n in - Abstract (i,map_rel_declaration (liftn n depth) d) + Abstract (i, map_constr (liftn n depth) d) ::(liftn_tomatch_stack n (depth+1) rest) let lift_tomatch_stack n = liftn_tomatch_stack n 1 @@ -696,7 +699,7 @@ let merge_name get_name obj = function let merge_names get_name = List.map2 (merge_name get_name) let get_names env sign eqns = - let names1 = List.make (List.length sign) Anonymous in + let names1 = List.make (Context.Rel.length sign) Anonymous in (* If any, we prefer names used in pats, from top to bottom *) let names2,aliasname = List.fold_right @@ -714,7 +717,7 @@ let get_names env sign eqns = (fun (l,avoid) d na -> let na = merge_name - (fun (na,_,t) -> Name (next_name_away (named_hd env t na) avoid)) + (fun (LocalAssum (na,t) | LocalDef (na,_,t)) -> Name (next_name_away (named_hd env t na) avoid)) d na in (na::l,(out_name na)::avoid)) @@ -728,18 +731,16 @@ let get_names env sign eqns = (* We now replace the names y1 .. yn y by the actual names *) (* xi1 .. xin xi to be found in the i-th clause of the matrix *) -let set_declaration_name x (_,c,t) = (x,c,t) - -let recover_initial_subpattern_names = List.map2 set_declaration_name +let recover_initial_subpattern_names = List.map2 set_name let recover_and_adjust_alias_names names sign = let rec aux = function | [],[] -> [] - | x::names, (_,None,t)::sign -> - (x,(alias_of_pat x,None,t)) :: aux (names,sign) - | names, (na,(Some _ as c),t)::sign -> - (PatVar (Loc.ghost,na),(na,c,t)) :: aux (names,sign) + | x::names, LocalAssum (_,t)::sign -> + (x, LocalAssum (alias_of_pat x,t)) :: aux (names,sign) + | names, (LocalDef (na,_,_) as decl)::sign -> + (PatVar (Loc.ghost,na), decl) :: aux (names,sign) | _ -> assert false in List.split (aux (names,sign)) @@ -754,11 +755,12 @@ let push_rels_eqn_with_names sign eqn = let sign = recover_initial_subpattern_names subpatnames sign in push_rels_eqn sign eqn -let push_generalized_decl_eqn env n (na,c,t) eqn = - let na = match na with - | Anonymous -> Anonymous - | Name id -> pi1 (Environ.lookup_rel n eqn.rhs.rhs_env) in - push_rels_eqn [(na,c,t)] eqn +let push_generalized_decl_eqn env n decl eqn = + match get_name decl with + | Anonymous -> + push_rels_eqn [decl] eqn + | Name _ -> + push_rels_eqn [set_name (get_name (Environ.lookup_rel n eqn.rhs.rhs_env)) decl] eqn let drop_alias_eqn eqn = { eqn with alias_stack = List.tl eqn.alias_stack } @@ -766,7 +768,7 @@ let drop_alias_eqn eqn = let push_alias_eqn alias eqn = let aliasname = List.hd eqn.alias_stack in let eqn = drop_alias_eqn eqn in - let alias = set_declaration_name aliasname alias in + let alias = set_name aliasname alias in push_rels_eqn [alias] eqn (**********************************************************************) @@ -837,10 +839,10 @@ let regeneralize_index_predicate n = map_predicate (relocate_index n 1) 0 let substnl_predicate sigma = map_predicate (substnl sigma) (* This is parallel bindings *) -let subst_predicate (args,copt) ccl tms = +let subst_predicate (subst,copt) ccl tms = let sigma = match copt with - | None -> List.rev args - | Some c -> c::(List.rev args) in + | None -> subst + | Some c -> c::subst in substnl_predicate sigma 0 ccl tms let specialize_predicate_var (cur,typ,dep) tms ccl = @@ -921,7 +923,7 @@ let abstract_predicate env sigma indf cur realargs (names,na) tms ccl = let tms = List.fold_right2 (fun par arg tomatch -> match kind_of_term par with | Rel i -> relocate_index_tomatch (i+n) (destRel arg) tomatch - | _ -> tomatch) (realargs@[cur]) (extended_rel_list 0 sign) + | _ -> tomatch) (realargs@[cur]) (Context.Rel.to_extended_list 0 sign) (lift_tomatch_stack n tms) in (* Pred is already dependent in the current term to match (if *) (* (na<>Anonymous) and its realargs; we just need to adjust it to *) @@ -932,7 +934,7 @@ let abstract_predicate env sigma indf cur realargs (names,na) tms ccl = in let pred = extract_predicate ccl tms in (* Build the predicate properly speaking *) - let sign = List.map2 set_declaration_name (na::names) sign in + let sign = List.map2 set_name (na::names) sign in it_mkLambda_or_LetIn_name env pred sign (* [expand_arg] is used by [specialize_predicate] @@ -1018,7 +1020,7 @@ let specialize_predicate newtomatchs (names,depna) arsign cs tms ccl = (* We prepare the substitution of X and x:I(X) *) let realargsi = if not (Int.equal nrealargs 0) then - adjust_subst_to_rel_context arsign (Array.to_list cs.cs_concl_realargs) + subst_of_rel_context_instance arsign (Array.to_list cs.cs_concl_realargs) else [] in let copti = match depna with @@ -1118,14 +1120,14 @@ let postprocess_dependencies evd tocheck brs tomatch pred deps cs = let rec aux k brs tomatch pred tocheck deps = match deps, tomatch with | [], _ -> brs,tomatch,pred,[] | n::deps, Abstract (i,d) :: tomatch -> - let d = map_rel_declaration (nf_evar evd) d in - let is_d = match d with (_, None, _) -> false | _ -> true in + let d = map_constr (nf_evar evd) d in + let is_d = match d with LocalAssum _ -> false | LocalDef _ -> true in if is_d || List.exists (fun c -> dependent_decl (lift k c) d) tocheck && Array.exists (is_dependent_branch k) brs then (* Dependency in the current term to match and its dependencies is real *) let brs,tomatch,pred,inst = aux (k+1) brs tomatch pred (mkRel n::tocheck) deps in let inst = match d with - | (_, None, _) -> mkRel n :: inst + | LocalAssum _ -> mkRel n :: inst | _ -> inst in brs, Abstract (i,d) :: tomatch, pred, inst @@ -1187,12 +1189,13 @@ let group_equations pb ind current cstrs mat = let rec generalize_problem names pb = function | [] -> pb, [] | i::l -> - let (na,b,t as d) = map_rel_declaration (lift i) (Environ.lookup_rel i pb.env) in let pb',deps = generalize_problem names pb l in - begin match (na, b) with - | Anonymous, Some _ -> pb', deps + let d = map_constr (lift i) (Environ.lookup_rel i pb.env) in + begin match d with + | LocalDef (Anonymous,_,_) -> pb', deps | _ -> - let d = on_pi3 (whd_betaiota !(pb.evdref)) d in (* for better rendering *) + (* for better rendering *) + let d = map_type (whd_betaiota !(pb.evdref)) d in let tomatch = lift_tomatch_stack 1 pb'.tomatch in let tomatch = relocate_index_tomatch (i+1) 1 tomatch in { pb' with @@ -1220,7 +1223,8 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn (* that had matched constructor C *) let cs_args = const_info.cs_args in let names,aliasname = get_names pb.env cs_args eqns in - let typs = List.map2 (fun (_,c,t) na -> (na,c,t)) cs_args names in + let typs = List.map2 set_name names cs_args + in (* We build the matrix obtained by expanding the matching on *) (* "C x1..xn as x" followed by a residual matching on eqn into *) @@ -1230,7 +1234,7 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn (* We adjust the terms to match in the context they will be once the *) (* context [x1:T1,..,xn:Tn] will have been pushed on the current env *) let typs' = - List.map_i (fun i d -> (mkRel i,map_rel_declaration (lift i) d)) 1 typs in + List.map_i (fun i d -> (mkRel i, map_constr (lift i) d)) 1 typs in let extenv = push_rel_context typs pb.env in @@ -1268,7 +1272,8 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn let typs' = List.map2 - (fun (tm,(tmtyp,_),(na,_,_)) deps -> + (fun (tm, (tmtyp,_), decl) deps -> + let na = get_name decl in let na = match curname, na with | Name _, Anonymous -> curname | Name _, Name _ -> na @@ -1392,7 +1397,7 @@ and shift_problem ((current,t),_,na) pb = let pred = specialize_predicate_var (current,t,na) pb.tomatch pb.pred in let pb = { pb with - env = push_rel (na,Some current,ty) pb.env; + env = push_rel (LocalDef (na,current,ty)) pb.env; tomatch = tomatch; pred = lift_predicate 1 pred tomatch; history = pop_history pb.history; @@ -1440,7 +1445,7 @@ and compile_generalization pb i d rest = ([false]). *) and compile_alias initial pb (na,orig,(expanded,expanded_typ)) rest = let f c t = - let alias = (na,Some c,t) in + let alias = LocalDef (na,c,t) in let pb = { pb with env = push_rel alias pb.env; @@ -1560,8 +1565,8 @@ let matx_of_eqns env eqns = *) let adjust_to_extended_env_and_remove_deps env extenv subst t = - let n = rel_context_length (rel_context env) in - let n' = rel_context_length (rel_context extenv) in + let n = Context.Rel.length (rel_context env) in + let n' = Context.Rel.length (rel_context extenv) in (* We first remove the bindings that are dependently typed (they are difficult to manage and it is not sure these are so useful in practice); Notes: @@ -1576,9 +1581,9 @@ let adjust_to_extended_env_and_remove_deps env extenv subst t = (* \--------------extenv------------/ *) let (p, _, _) = lookup_rel_id x (rel_context extenv) in let rec traverse_local_defs p = - match pi2 (lookup_rel p extenv) with - | Some c -> assert (isRel c); traverse_local_defs (p + destRel c) - | None -> p in + match lookup_rel p extenv with + | LocalDef (_,c,_) -> assert (isRel c); traverse_local_defs (p + destRel c) + | LocalAssum _ -> p in let p = traverse_local_defs p in let u = lift (n' - n) u in try Some (p, u, expand_vars_in_term extenv u) @@ -1623,7 +1628,7 @@ let abstract_tycon loc env evdref subst tycon extenv t = convertible subterms of the substitution *) let rec aux (k,env,subst as x) t = let t = whd_evar !evdref t in match kind_of_term t with - | Rel n when pi2 (lookup_rel n env) != None -> t + | Rel n when is_local_def (lookup_rel n env) -> t | Evar ev -> let ty = get_type_of env !evdref t in let ty = Evarutil.evd_comb1 (refresh_universes (Some false) env) evdref ty in @@ -1659,7 +1664,8 @@ let abstract_tycon loc env evdref subst tycon extenv t = List.map (fun a -> not (isRel a) || dependent a u || Int.Set.mem (destRel a) depvl) inst in let named_filter = - List.map (fun (id,_,_) -> dependent (mkVar id) u) + let open Context.Named.Declaration in + List.map (fun d -> dependent (mkVar (get_id d)) u) (named_context extenv) in let filter = Filter.make (rel_filter @ named_filter) in let candidates = u :: List.map mkRel vl in @@ -1673,8 +1679,8 @@ let build_tycon loc env tycon_env s subst tycon extenv evdref t = | None -> (* This is the situation we are building a return predicate and we are in an impossible branch *) - let n = rel_context_length (rel_context env) in - let n' = rel_context_length (rel_context tycon_env) in + let n = Context.Rel.length (rel_context env) in + let n' = Context.Rel.length (rel_context tycon_env) in let impossible_case_type, u = e_new_type_evar (reset_context env) evdref univ_flexible_alg ~src:(loc,Evar_kinds.ImpossibleCase) in (lift (n'-n) impossible_case_type, mkSort u) @@ -1727,7 +1733,7 @@ let build_inversion_problem loc env sigma tms t = List.rev_append patl patl',acc_sign,acc | (t, NotInd (bo,typ)) :: tms -> let pat,acc = make_patvar t acc in - let d = (alias_of_pat pat,None,typ) in + let d = LocalAssum (alias_of_pat pat,typ) in let patl,acc_sign,acc = aux (n+1) (push_rel d env) (d::acc_sign) tms acc in pat::patl,acc_sign,acc in let avoid0 = ids_of_context env in @@ -1744,7 +1750,7 @@ let build_inversion_problem loc env sigma tms t = let n = List.length sign in let decls = - List.map_i (fun i d -> (mkRel i,map_rel_declaration (lift i) d)) 1 sign in + List.map_i (fun i d -> (mkRel i, map_constr (lift i) d)) 1 sign in let pb_env = push_rel_context sign env in let decls = @@ -1754,8 +1760,8 @@ let build_inversion_problem loc env sigma tms t = let dep_sign = find_dependencies_signature (List.make n true) decls in let sub_tms = - List.map2 (fun deps (tm,(tmtyp,_),(na,b,t)) -> - let na = if List.is_empty deps then Anonymous else force_name na in + List.map2 (fun deps (tm, (tmtyp,_), decl) -> + let na = if List.is_empty deps then Anonymous else force_name (get_name decl) in Pushed (true,((tm,tmtyp),deps,na))) dep_sign decls in let subst = List.map (fun (na,t) -> (na,lift n t)) subst in @@ -1816,7 +1822,8 @@ let build_inversion_problem loc env sigma tms t = let build_initial_predicate arsign pred = let rec buildrec n pred tmnames = function | [] -> List.rev tmnames,pred - | ((na,c,t)::realdecls)::lnames -> + | (decl::realdecls)::lnames -> + let na = get_name decl in let n' = n + List.length realdecls in buildrec (n'+1) pred (force_name na::tmnames) lnames | _ -> assert false @@ -1828,7 +1835,9 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = match tm with | NotInd (bo,typ) -> (match t with - | None -> [na,Option.map (lift n) bo,lift n typ] + | None -> (match bo with + | None -> [LocalAssum (na, lift n typ)] + | Some b -> [LocalDef (na, lift n b, lift n typ)]) | Some (loc,_,_) -> user_err_loc (loc,"", str"Unexpected type annotation for a term of non inductive type.")) @@ -1846,8 +1855,8 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = anomaly (Pp.str "Ill-formed 'in' clause in cases"); List.rev realnal | None -> List.make nrealargs_ctxt Anonymous in - (na,None,build_dependent_inductive env0 indf') - ::(List.map2 (fun x (_,c,t) ->(x,c,t)) realnal arsign) in + LocalAssum (na, build_dependent_inductive env0 indf') + ::(List.map2 set_name realnal arsign) in let rec buildrec n = function | [],[] -> [] | (_,tm)::ltm, (_,x)::tmsign -> @@ -1948,8 +1957,10 @@ let prepare_predicate loc typing_fun env sigma tomatchs arsign tycon pred = let sigma,t = match tycon with | Some t -> sigma,t | None -> - let sigma, (t, _) = + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma ((t, _), sigma, _) = new_type_evar env sigma univ_flexible_alg ~src:(loc, Evar_kinds.CasesType false) in + let sigma = Sigma.to_evar_map sigma in sigma, t in (* First strategy: we build an "inversion" predicate *) @@ -2028,7 +2039,7 @@ let constr_of_pat env evdref arsign pat avoid = let previd, id = prime avoid (Name (Id.of_string "wildcard")) in Name id, id :: avoid in - (PatVar (l, name), [name, None, ty] @ realargs, mkRel 1, ty, + (PatVar (l, name), [LocalAssum (name, ty)] @ realargs, mkRel 1, ty, (List.map (fun x -> mkRel 1) realargs), 1, avoid) | PatCstr (l,((_, i) as cstr),args,alias) -> let cind = inductive_of_constructor cstr in @@ -2045,7 +2056,8 @@ let constr_of_pat env evdref arsign pat avoid = assert (Int.equal nb_args_constr (List.length args)); let patargs, args, sign, env, n, m, avoid = List.fold_right2 - (fun (na, c, t) ua (patargs, args, sign, env, n, m, avoid) -> + (fun decl ua (patargs, args, sign, env, n, m, avoid) -> + let t = get_type decl in let pat', sign', arg', typ', argtypargs, n', avoid = let liftt = liftn (List.length sign) (succ (List.length args)) t in typ env (substl args liftt, []) ua avoid @@ -2067,7 +2079,7 @@ let constr_of_pat env evdref arsign pat avoid = Anonymous -> pat', sign, app, apptype, realargs, n, avoid | Name id -> - let sign = (alias, None, lift m ty) :: sign in + let sign = LocalAssum (alias, lift m ty) :: sign in let avoid = id :: avoid in let sign, i, avoid = try @@ -2079,14 +2091,14 @@ let constr_of_pat env evdref arsign pat avoid = (lift 1 app) (* aliased term *) in let neq = eq_id avoid id in - (Name neq, Some (mkRel 0), eq_t) :: sign, 2, neq :: avoid + LocalDef (Name neq, mkRel 0, eq_t) :: sign, 2, neq :: avoid with Reduction.NotConvertible -> sign, 1, avoid in (* Mark the equality as a hole *) pat', sign, lift i app, lift i apptype, realargs, n + i, avoid in - let pat', sign, patc, patty, args, z, avoid = typ env (pi3 (List.hd arsign), List.tl arsign) pat avoid in - pat', (sign, patc, (pi3 (List.hd arsign), args), pat'), avoid + let pat', sign, patc, patty, args, z, avoid = typ env (get_type (List.hd arsign), List.tl arsign) pat avoid in + pat', (sign, patc, (get_type (List.hd arsign), args), pat'), avoid (* shadows functional version *) @@ -2101,23 +2113,23 @@ match kind_of_term t with | Rel 0 -> true | _ -> false -let rels_of_patsign l = - List.map (fun ((na, b, t) as x) -> - match b with - | Some t' when is_topvar t' -> (na, None, t) - | _ -> x) l +let rels_of_patsign = + List.map (fun decl -> + match decl with + | LocalDef (na,t',t) when is_topvar t' -> LocalAssum (na,t) + | _ -> decl) let vars_of_ctx ctx = let _, y = - List.fold_right (fun (na, b, t) (prev, vars) -> - match b with - | Some t' when is_topvar t' -> + List.fold_right (fun decl (prev, vars) -> + match decl with + | LocalDef (na,t',t) when is_topvar t' -> prev, (GApp (Loc.ghost, (GRef (Loc.ghost, delayed_force coq_eq_refl_ref, None)), [hole; GVar (Loc.ghost, prev)])) :: vars | _ -> - match na with + match get_name decl with Anonymous -> invalid_arg "vars_of_ctx" | Name n -> n, GVar (Loc.ghost, n) :: vars) ctx (Id.of_string "vars_of_ctx_error", []) @@ -2226,7 +2238,7 @@ let constrs_of_pats typing_fun env evdref eqns tomatchs sign neqs arity = match ineqs with | None -> [], arity | Some ineqs -> - [Anonymous, None, ineqs], lift 1 arity + [LocalAssum (Anonymous, ineqs)], lift 1 arity in let eqs_rels, arity = decompose_prod_n_assum neqs arity in eqs_rels @ neqs_rels @ rhs_rels', arity @@ -2237,7 +2249,7 @@ let constrs_of_pats typing_fun env evdref eqns tomatchs sign neqs arity = and btype = it_mkProd_or_LetIn j.uj_type rhs_rels' 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_decl = LocalDef (Name branch_name, lift !i bbody, lift !i btype) in let branch = let bref = GVar (Loc.ghost, branch_name) in match vars_of_ctx rhs_rels with @@ -2286,7 +2298,7 @@ let abstract_tomatch env tomatchs tycon = (fun t -> subst_term (lift 1 c) (lift 1 t)) tycon in let name = next_ident_away (Id.of_string "filtered_var") names in (mkRel 1, lift_tomatch_type (succ lenctx) t) :: lift_ctx 1 prev, - (Name name, Some (lift lenctx c), lift lenctx $ type_of_tomatch t) :: ctx, + LocalDef (Name name, lift lenctx c, lift lenctx $ type_of_tomatch t) :: ctx, name :: names, tycon) ([], [], [], tycon) tomatchs in List.rev prev, ctx, tycon @@ -2294,7 +2306,7 @@ let abstract_tomatch env tomatchs tycon = let build_dependent_signature env evdref avoid tomatchs arsign = let avoid = ref avoid in let arsign = List.rev arsign in - let allnames = List.rev_map (List.map pi1) arsign in + let allnames = List.rev_map (List.map get_name) arsign in let nar = List.fold_left (fun n names -> List.length names + n) 0 allnames in let eqs, neqs, refls, slift, arsign' = List.fold_left2 @@ -2310,11 +2322,15 @@ let build_dependent_signature env evdref avoid tomatchs arsign = (* Build the arity signature following the names in matched terms as much as possible *) let argsign = List.tl arsign in (* arguments in inverse application order *) - let (appn, appb, appt) as _appsign = List.hd arsign in (* The matched argument *) + let app_decl = List.hd arsign in (* The matched argument *) + let appn = get_name app_decl in + let appt = get_type app_decl in let argsign = List.rev argsign in (* arguments in application order *) let env', nargeqs, argeqs, refl_args, slift, argsign' = List.fold_left2 - (fun (env, nargeqs, argeqs, refl_args, slift, argsign') arg (name, b, t) -> + (fun (env, nargeqs, argeqs, refl_args, slift, argsign') arg decl -> + let name = get_name decl in + let t = get_type decl in let argt = Retyping.get_type_of env !evdref arg in let eq, refl_arg = if Reductionops.is_conv env !evdref argt t then @@ -2332,16 +2348,16 @@ let build_dependent_signature env evdref avoid tomatchs arsign = let previd, id = let name = match kind_of_term arg with - Rel n -> pi1 (lookup_rel n env) + Rel n -> get_name (lookup_rel n env) | _ -> name in make_prime avoid name in (env, succ nargeqs, - (Name (eq_id avoid previd), None, eq) :: argeqs, + (LocalAssum (Name (eq_id avoid previd), eq)) :: argeqs, refl_arg :: refl_args, pred slift, - (Name id, b, t) :: argsign')) + set_name (Name id) decl :: argsign')) (env, neqs, [], [], slift, []) args argsign in let eq = mk_JMeq evdref @@ -2352,22 +2368,23 @@ let build_dependent_signature env evdref avoid tomatchs arsign = in let refl_eq = mk_JMeq_refl evdref ty tm in let previd, id = make_prime avoid appn in - (((Name (eq_id avoid previd), None, eq) :: argeqs) :: eqs, + ((LocalAssum (Name (eq_id avoid previd), eq) :: argeqs) :: eqs, succ nargeqs, refl_eq :: refl_args, pred slift, - (((Name id, appb, appt) :: argsign') :: arsigns)) + ((set_name (Name id) app_decl :: argsign') :: arsigns)) | _ -> (* Non dependent inductive or not inductive, just use a regular equality *) - let (name, b, typ) = match arsign with [x] -> x | _ -> assert(false) in + let decl = match arsign with [x] -> x | _ -> assert(false) in + let name = get_name decl in let previd, id = make_prime avoid name in - let arsign' = (Name id, b, typ) in + let arsign' = set_name (Name id) decl in let tomatch_ty = type_of_tomatch ty in let eq = mk_eq evdref (lift nar tomatch_ty) (mkRel slift) (lift nar tm) in - ([(Name (eq_id avoid previd), None, eq)] :: eqs, succ neqs, + ([LocalAssum (Name (eq_id avoid previd), eq)] :: eqs, succ neqs, (mk_eq_refl evdref tomatch_ty tm) :: refl_args, pred slift, (arsign' :: []) :: arsigns)) ([], 0, [], nar, []) tomatchs arsign @@ -2441,7 +2458,9 @@ let compile_program_cases loc style (typing_function, evdref) tycon env (* We push the initial terms to match and push their alias to rhs' envs *) (* names of aliases will be recovered from patterns (hence Anonymous here) *) - let out_tmt na = function NotInd (c,t) -> (na,c,t) | IsInd (typ,_,_) -> (na,None,typ) in + let out_tmt na = function NotInd (None,t) -> LocalAssum (na,t) + | NotInd (Some b, t) -> LocalDef (na,b,t) + | IsInd (typ,_,_) -> LocalAssum (na,typ) in let typs = List.map2 (fun na (tm,tmt) -> (tm,out_tmt na tmt)) nal tomatchs in let typs = @@ -2514,7 +2533,9 @@ let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, e (* names of aliases will be recovered from patterns (hence Anonymous *) (* here) *) - let out_tmt na = function NotInd (c,t) -> (na,c,t) | IsInd (typ,_,_) -> (na,None,typ) in + let out_tmt na = function NotInd (None,t) -> LocalAssum (na,t) + | NotInd (Some b,t) -> LocalDef (na,b,t) + | IsInd (typ,_,_) -> LocalAssum (na,typ) in let typs = List.map2 (fun na (tm,tmt) -> (tm,out_tmt na tmt)) nal tomatchs in let typs = diff --git a/pretyping/cases.mli b/pretyping/cases.mli index c599766ab..257d1e578 100644 --- a/pretyping/cases.mli +++ b/pretyping/cases.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,7 +8,6 @@ open Names open Term -open Context open Evd open Environ open Inductiveops @@ -45,11 +44,11 @@ val compile_cases : val constr_of_pat : Environ.env -> Evd.evar_map ref -> - rel_declaration list -> + Context.Rel.Declaration.t list -> Glob_term.cases_pattern -> Names.Id.t list -> Glob_term.cases_pattern * - (rel_declaration list * Term.constr * + (Context.Rel.Declaration.t list * Term.constr * (Term.types * Term.constr list) * Glob_term.cases_pattern) * Names.Id.t list @@ -83,7 +82,7 @@ type tomatch_status = | Pushed of (bool*((constr * tomatch_type) * int list * Name.t)) | Alias of (bool * (Name.t * constr * (constr * types))) | NonDepAlias - | Abstract of int * rel_declaration + | Abstract of int * Context.Rel.Declaration.t type tomatch_stack = tomatch_status list @@ -117,7 +116,7 @@ val prepare_predicate : Loc.t -> Environ.env -> Evd.evar_map -> (Term.types * tomatch_type) list -> - Context.rel_context list -> + Context.Rel.t list -> Constr.constr option -> 'a option -> (Evd.evar_map * Names.name list * Term.constr) list diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml index 21bbede09..43062a0e8 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/pretyping/cbv.mli b/pretyping/cbv.mli index bde85383d..de37d1fc5 100644 --- a/pretyping/cbv.mli +++ b/pretyping/cbv.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/pretyping/classops.ml b/pretyping/classops.ml index 055996de5..ece92b66b 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/pretyping/classops.mli b/pretyping/classops.mli index e2bb2d1a0..cf88be629 100644 --- a/pretyping/classops.mli +++ b/pretyping/classops.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index e61e52c17..5c7adf1aa 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -129,7 +129,7 @@ let mu env evdref t = let rec aux v = let v' = hnf env !evdref v in match disc_subset v' with - Some (u, p) -> + | Some (u, p) -> let f, ct = aux u in let p = hnf_nodelta env !evdref p in (Some (fun x -> @@ -142,6 +142,7 @@ let mu env evdref t = and coerce loc env evdref (x : Term.constr) (y : Term.constr) : (Term.constr -> Term.constr) option = + let open Context.Rel.Declaration in let rec coerce_unify env x y = let x = hnf env !evdref x and y = hnf env !evdref y in try @@ -151,8 +152,9 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) and coerce' env x y : (Term.constr -> Term.constr) option = let subco () = subset_coerce env evdref x y in let dest_prod c = + let open Context.Rel.Declaration in match Reductionops.splay_prod_n env ( !evdref) 1 c with - | [(na,b,t)], c -> (na,t), c + | [LocalAssum (na,t) | LocalDef (na,_,t)], c -> (na,t), c | _ -> raise NoSubtacCoercion in let coerce_application typ typ' c c' l l' = @@ -187,7 +189,7 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) (subst1 hdy restT') (succ i) (fun x -> eq_app (co x)) else Some (fun x -> let term = co x in - Typing.solve_evars env evdref term) + Typing.e_solve_evars env evdref term) in if isEvar c || isEvar c' then (* Second-order unification needed. *) @@ -205,7 +207,7 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) let name' = Name (Namegen.next_ident_away Namegen.default_dependent_ident (Termops.ids_of_context env)) in - let env' = push_rel (name', None, a') env in + let env' = push_rel (LocalAssum (name', a')) env in let c1 = coerce_unify env' (lift 1 a') (lift 1 a) in (* env, x : a' |- c1 : lift 1 a' > lift 1 a *) let coec1 = app_opt env' evdref c1 (mkRel 1) in @@ -241,9 +243,8 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) let remove_head a c = match kind_of_term c with | Lambda (n, t, t') -> c, t' - (*| Prod (n, t, t') -> t'*) | Evar (k, args) -> - let (evs, t) = Evarutil.define_evar_as_lambda env !evdref (k,args) in + let (evs, t) = Evardefine.define_evar_as_lambda env !evdref (k,args) in evdref := evs; let (n, dom, rng) = destLambda t in let dom = whd_evar !evdref dom in @@ -255,7 +256,7 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) | _ -> raise NoSubtacCoercion in let (pb, b), (pb', b') = remove_head a pb, remove_head a' pb' in - let env' = push_rel (Name Namegen.default_dependent_ident, None, a) env in + let env' = push_rel (LocalAssum (Name Namegen.default_dependent_ident, a)) env in let c2 = coerce_unify env' b b' in match c1, c2 with | None, None -> None @@ -297,9 +298,7 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) with NoSubtacCoercion -> 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 () *) else subco () | x, y when Constr.equal c c' -> @@ -307,9 +306,7 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) let evm = !evdref 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 () *) else subco () | _ -> subco ()) | _, _ -> subco () @@ -335,15 +332,22 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) raise NoSubtacCoercion in coerce_unify env x y +let app_coercion env evdref coercion v = + match coercion with + | None -> v + | Some f -> + let v' = Typing.e_solve_evars env evdref (f v) in + whd_betaiota !evdref v' + let coerce_itf loc env evd v t c1 = let evdref = ref evd in let coercion = coerce loc env evdref t c1 in - let t = Option.map (app_opt env evdref coercion) v in + let t = Option.map (app_coercion env evdref coercion) v in !evdref, t let saturate_evd env evd = Typeclasses.resolve_typeclasses - ~filter:Typeclasses.no_goals ~split:false ~fail:false env evd + ~filter:Typeclasses.no_goals ~split:true ~fail:false env evd (* Apply coercion path from p to hj; raise NoCoercion if not applicable *) let apply_coercion env sigma p hj typ_cl = @@ -373,7 +377,7 @@ let inh_app_fun_core env evd j = match kind_of_term t with | Prod (_,_,_) -> (evd,j) | Evar ev -> - let (evd',t) = define_evar_as_product evd ev in + let (evd',t) = Evardefine.define_evar_as_product evd ev in (evd',{ uj_val = j.uj_val; uj_type = t }) | _ -> try let t,p = @@ -414,7 +418,7 @@ let inh_coerce_to_sort loc env evd j = match kind_of_term typ with | Sort s -> (evd,{ utj_val = j.uj_val; utj_type = s }) | Evar ev when not (is_defined evd (fst ev)) -> - let (evd',s) = define_evar_as_sort env evd ev in + let (evd',s) = Evardefine.define_evar_as_sort env evd ev in (evd',{ utj_val = j.uj_val; utj_type = s }) | _ -> inh_tosort_force loc env evd j @@ -424,7 +428,7 @@ let inh_coerce_to_base loc env evd j = let evdref = ref evd in let ct, typ' = mu env evdref j.uj_type in let res = - { uj_val = app_opt env evdref ct j.uj_val; + { uj_val = app_coercion env evdref ct j.uj_val; uj_type = typ' } in !evdref, res else (evd, j) @@ -475,7 +479,8 @@ let rec inh_conv_coerce_to_fail loc env evd rigidonly v t c1 = let name = match name with | Anonymous -> Name Namegen.default_dependent_ident | _ -> name in - let env1 = push_rel (name,None,u1) env in + let open Context.Rel.Declaration in + let env1 = push_rel (LocalAssum (name,u1)) env in let (evd', v1) = inh_conv_coerce_to_fail loc env1 evd rigidonly (Some (mkRel 1)) (lift 1 u1) (lift 1 t1) in diff --git a/pretyping/coercion.mli b/pretyping/coercion.mli index f511f977c..68f9a2e68 100644 --- a/pretyping/coercion.mli +++ b/pretyping/coercion.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index 3fa037ffd..4fb411202 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -17,10 +17,10 @@ open Termops open Reductionops open Term open Vars -open Context open Pattern open Patternops open Misctypes +open Context.Rel.Declaration (*i*) (* Given a term with second-order variables in it, @@ -255,24 +255,24 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels sorec ctx env subst c1 c2 | PProd (na1,c1,d1), Prod(na2,c2,d2) -> - sorec ((na1,na2,c2)::ctx) (Environ.push_rel (na2,None,c2) env) + sorec ((na1,na2,c2)::ctx) (Environ.push_rel (LocalAssum (na2,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)::ctx) (Environ.push_rel (na2,None,c2) env) + sorec ((na1,na2,c2)::ctx) (Environ.push_rel (LocalAssum (na2,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)::ctx) (Environ.push_rel (na2,Some c2,t2) env) + sorec ((na1,na2,t2)::ctx) (Environ.push_rel (LocalDef (na2,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,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 + let n = Context.Rel.length ctx_b2 in + let n' = Context.Rel.length ctx_b2' in if noccur_between 1 n b2 && noccur_between 1 n' b2' then - let f l (na,_,t) = (Anonymous,na,t)::l in + let f l (LocalAssum (na,t) | LocalDef (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 @@ -368,21 +368,21 @@ let sub_match ?(partial_app=false) ?(closed=true) env sigma pat c = | [c1; c2] -> mk_ctx (mkLambda (x, c1, c2)) | _ -> assert false in - let env' = Environ.push_rel (x,None,c1) env in + let env' = Environ.push_rel (LocalAssum (x,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 env' = Environ.push_rel (x,None,c1) env in + let env' = Environ.push_rel (LocalAssum (x,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 env' = Environ.push_rel (x,Some c1,t) env in + let env' = Environ.push_rel (LocalDef (x,c1,t)) env in try_aux [(env, c1); (env', c2)] next_mk_ctx next | App (c1,lc) -> let topdown = true in @@ -413,25 +413,12 @@ 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 - | Case (ci,p,c,brs) -> - (* Warning: this assumes predicate and branches to be - in canonical form using let and fun of the signature *) - let nardecls = List.length ci.ci_pp_info.ind_tags in - let sign_p,p = decompose_lam_n_decls (nardecls + 1) p in - let env_p = Environ.push_rel_context sign_p env in - let brs = Array.map2 decompose_lam_n_decls ci.ci_cstr_ndecls brs in - let sign_brs = Array.map fst brs in - let f (sign,br) = (Environ.push_rel_context sign env, br) in - let sub_br = Array.map f brs in + | Case (ci,hd,c1,lc) -> let next_mk_ctx = function - | c :: p :: brs -> - let p = it_mkLambda_or_LetIn p sign_p in - let brs = - Array.map2 it_mkLambda_or_LetIn (Array.of_list brs) sign_brs in - mk_ctx (mkCase (ci,p,c,brs)) + | c1 :: hd :: lc -> mk_ctx (mkCase (ci,hd,c1,Array.of_list lc)) | _ -> assert false in - let sub = (env, c) :: (env_p, p) :: Array.to_list sub_br in + 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 diff --git a/pretyping/constr_matching.mli b/pretyping/constr_matching.mli index b9dcb0af2..8d8166f22 100644 --- a/pretyping/constr_matching.mli +++ b/pretyping/constr_matching.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index b5228094a..c973e1cef 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -12,7 +12,6 @@ open Util open Names open Term open Vars -open Context open Inductiveops open Environ open Glob_term @@ -25,6 +24,7 @@ open Nametab open Mod_subst open Misctypes open Decl_kinds +open Context.Named.Declaration let dl = Loc.ghost @@ -34,8 +34,15 @@ let print_universes = Flags.univ_print (** If true, prints local context of evars, whatever print_arguments *) let print_evar_arguments = ref false -let add_name na b t (nenv, env) = add_name na nenv, push_rel (na, b, t) env -let add_name_opt na b t (nenv, env) = +let add_name na b t (nenv, env) = + let open Context.Rel.Declaration in + add_name na nenv, push_rel (match b with + | None -> LocalAssum (na,t) + | Some b -> LocalDef (na,b,t) + ) + env + +let add_name_opt na b t (nenv, env) = match t with | None -> Termops.add_name na nenv, env | Some t -> add_name na b t (nenv, env) @@ -166,6 +173,18 @@ let _ = declare_bool_option optread = print_primproj_params; optwrite = (:=) print_primproj_params_value } +let print_primproj_compatibility_value = ref true +let print_primproj_compatibility () = !print_primproj_compatibility_value + +let _ = declare_bool_option + { optsync = true; + optdepr = false; + optname = "backwards-compatible printing of primitive projections"; + optkey = ["Printing";"Primitive";"Projection";"Compatibility"]; + optread = print_primproj_compatibility; + optwrite = (:=) print_primproj_compatibility_value } + + (* Auxiliary function for MutCase printing *) (* [computable] tries to tell if the predicate typing the result is inferable*) @@ -187,7 +206,7 @@ let computable p k = engendrera un prédicat non dépendant) *) let sign,ccl = decompose_lam_assum p in - Int.equal (rel_context_length sign) (k + 1) + Int.equal (Context.Rel.length sign) (k + 1) && noccur_between 1 (k+1) ccl @@ -303,7 +322,7 @@ let is_nondep_branch c l = try (* FIXME: do better using tags from l *) let sign,ccl = decompose_lam_n_decls (List.length l) c in - noccur_between 1 (rel_context_length sign) ccl + noccur_between 1 (Context.Rel.length sign) ccl with e when Errors.noncritical e -> (* Not eta-expanded or not reduced *) false @@ -476,7 +495,7 @@ let rec detype flags avoid env sigma t = GApp (dl, GRef (dl, ConstRef (Projection.constant p), None), [detype flags avoid env sigma c]) else - if Projection.unfolded p then + if print_primproj_compatibility () && Projection.unfolded p then (** Print the compatibility match version *) let c' = try @@ -499,14 +518,20 @@ let rec detype flags avoid env sigma t = else noparams () | Evar (evk,cl) -> - let bound_to_itself_or_letin (id,b,_) c = - b != None || - try let n = List.index Name.equal (Name id) (fst env) in - isRelN n c - with Not_found -> isVarId id c in + let bound_to_itself_or_letin decl c = + match decl with + | LocalDef _ -> true + | LocalAssum (id,_) -> + try let n = List.index Name.equal (Name id) (fst env) in + isRelN n c + with Not_found -> isVarId id c + in let id,l = try - let id = Evd.evar_ident evk sigma in + let id = match Evd.evar_ident evk sigma with + | None -> Evd.pr_evar_suggested_name evk sigma + | Some id -> id + in let l = Evd.evar_instance_array bound_to_itself_or_letin (Evd.find sigma evk) cl in let fvs,rels = List.fold_left (fun (fvs,rels) (_,c) -> match kind_of_term c with Rel n -> (fvs,Int.Set.add n rels) | Var id -> (Id.Set.add id fvs,rels) | _ -> (fvs,rels)) (Id.Set.empty,Int.Set.empty) l in let l = Evd.evar_instance_array (fun d c -> not !print_evar_arguments && (bound_to_itself_or_letin d c && not (isRel c && Int.Set.mem (destRel c) rels || isVar c && (Id.Set.mem (destVar c) fvs)))) (Evd.find sigma evk) cl in @@ -661,23 +686,36 @@ and detype_binder (lax,isgoal as flags) bk avoid env sigma na body ty c = match bk with | BProd -> GProd (dl, na',Explicit,detype (lax,false) avoid env sigma ty, r) | BLambda -> GLambda (dl, na',Explicit,detype (lax,false) avoid env sigma ty, r) - | BLetIn -> GLetIn (dl, na',detype (lax,false) avoid env sigma (Option.get body), r) + | BLetIn -> + let c = detype (lax,false) avoid env sigma (Option.get body) in + (* Heuristic: we display the type if in Prop *) + let s = Retyping.get_sort_family_of (snd env) sigma ty in + let c = if s != InProp then c else + GCast (dl, c, CastConv (detype (lax,false) avoid env sigma ty)) in + GLetIn (dl, na', c, r) let detype_rel_context ?(lax=false) where avoid env sigma sign = let where = Option.map (fun c -> it_mkLambda_or_LetIn c sign) where in let rec aux avoid env = function | [] -> [] - | (na,b,t)::rest -> + | decl::rest -> + let open Context.Rel.Declaration in + let na = get_name decl in + let t = get_type decl in let na',avoid' = match where with | None -> na,avoid | Some c -> - if b != None then + if is_local_def decl then compute_displayed_let_name_in (RenamingElsewhereFor (fst env,c)) avoid na c else compute_displayed_name_in (RenamingElsewhereFor (fst env,c)) avoid na c in + let b = match decl with + | LocalAssum _ -> None + | LocalDef (_,b,_) -> Some b + in let b' = Option.map (detype (lax,false) avoid env sigma) b in let t' = detype (lax,false) avoid env sigma t in (na',Explicit,b',t') :: aux avoid' (add_name na' b t env) rest diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli index eb158686a..c51cb0f44 100644 --- a/pretyping/detyping.mli +++ b/pretyping/detyping.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,7 +8,6 @@ open Names open Term -open Context open Environ open Glob_term open Termops @@ -46,7 +45,7 @@ val detype_case : val detype_sort : evar_map -> sorts -> glob_sort val detype_rel_context : ?lax:bool -> constr option -> Id.t list -> (names_context * env) -> - evar_map -> rel_context -> glob_decl list + evar_map -> Context.Rel.t -> glob_decl list val detype_closed_glob : ?lax:bool -> bool -> Id.t list -> env -> evar_map -> closed_glob_constr -> glob_constr diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 60d92f4be..08973a05c 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -18,11 +18,13 @@ open Termops open Environ open Recordops open Evarutil +open Evardefine open Evarsolve open Globnames open Evd open Pretype_errors open Sigma.Notations +open Context.Rel.Declaration type unify_fun = transparent_state -> env -> evar_map -> conv_pb -> constr -> constr -> Evarsolve.unification_result @@ -55,12 +57,15 @@ let eval_flexible_term ts env evd c = then constant_opt_value_in env cu else None | Rel n -> - (try let (_,v,_) = lookup_rel n env in Option.map (lift n) v - with Not_found -> None) + (try match lookup_rel n env with + | LocalAssum _ -> None + | LocalDef (_,v,_) -> Some (lift n v) + with Not_found -> None) | Var id -> (try if is_transparent_variable ts id then - let (_,v,_) = lookup_named id env in v + let open Context.Named.Declaration in + lookup_named id env |> get_value else None with Not_found -> None) | LetIn (_,b,_,c) -> Some (subst1 b c) @@ -139,6 +144,7 @@ let check_conv_record env sigma (t1,sk1) (t2,sk2) = try match kind_of_term t2 with Prod (_,a,b) -> (* assert (l2=[]); *) + let _, a, b = destProd (Evarutil.nf_evar sigma t2) in if dependent (mkRel 1) b then raise Not_found else lookup_canonical_conversion (proji, Prod_cs), (Stack.append_app [|a;pop b|] Stack.empty) @@ -318,25 +324,22 @@ let rec evar_conv_x ts env evd pbty term1 term2 = Note: incomplete heuristic... *) let ground_test = if is_ground_term evd term1 && is_ground_term evd term2 then ( - let evd, e = + let e = try let evd, b = infer_conv ~catch_incon:false ~pb:pbty ~ts:(fst ts) env evd term1 term2 in - if b then evd, None - else evd, Some (ConversionFailed (env,term1,term2)) - with Univ.UniverseInconsistency e -> evd, Some (UnifUnivInconsistency e) + if b then Success evd + else UnifFailure (evd, ConversionFailed (env,term1,term2)) + with Univ.UniverseInconsistency e -> UnifFailure (evd, UnifUnivInconsistency e) in match e with - | None -> Some (evd, e) - | Some e -> - if is_ground_env evd env then Some (evd, Some e) - else None) + | UnifFailure (evd, e) when not (is_ground_env evd env) -> None + | _ -> Some e) else None in match ground_test with - | Some (evd, None) -> Success evd - | Some (evd, Some e) -> UnifFailure (evd,e) + | Some result -> result | None -> (* Until pattern-unification is used consistently, use nohdbeta to not destroy beta-redexes that can be used for 1st-order unification *) @@ -394,7 +397,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty assert (match sk with [] -> true | _ -> false); let (na,c1,c'1) = destLambda term in let c = nf_evar evd c1 in - let env' = push_rel (na,None,c) env in + let env' = push_rel (LocalAssum (na,c)) env in let out1 = whd_betaiota_deltazeta_for_iota_state (fst ts) env' evd Cst_stack.empty (c'1, Stack.empty) in let out2 = whd_nored_state evd @@ -561,7 +564,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty 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); + evar_conv_x ts (push_rel (LocalDef (na,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 = let out1 = whd_betaiota_deltazeta_for_iota_state (fst ts) env i csts1 (v1,sk1) @@ -676,7 +679,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty (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)] + evar_conv_x ts (push_rel (LocalAssum (na,c)) env) i CONV c'1 c'2)] | Flexible ev1, Rigid -> flex_rigid true ev1 appr1 appr2 | Rigid, Flexible ev2 -> flex_rigid false ev2 appr2 appr1 @@ -735,7 +738,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty (fun i -> let c = nf_evar i c1 in let na = Nameops.name_max n1 n2 in - evar_conv_x ts (push_rel (na,None,c) env) i pbty c'1 c'2)] + evar_conv_x ts (push_rel (LocalAssum (na,c)) env) i pbty c'1 c'2)] | Rel x1, Rel x2 -> if Int.equal x1 x2 then @@ -857,7 +860,7 @@ and conv_record trs env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2) and eta_constructor ts env evd sk1 ((ind, i), u) sk2 term2 = let mib = lookup_mind (fst ind) env in match mib.Declarations.mind_record with - | Some (Some (id, projs, pbs)) when mib.Declarations.mind_finite <> Decl_kinds.CoFinite -> + | Some (Some (id, projs, pbs)) when mib.Declarations.mind_finite == Decl_kinds.BiFinite -> let pars = mib.Declarations.mind_nparams in (try let l1' = Stack.tail pars sk1 in @@ -912,6 +915,7 @@ let choose_less_dependent_instance evk evd term args = | [] -> None | (id, _) :: _ -> Some (Evd.define evk (mkVar id) evd) +open Context.Named.Declaration let apply_on_subterm env evdref f c t = let rec applyrec (env,(k,c) as acc) t = (* By using eq_constr, we make an approximation, for instance, we *) @@ -922,7 +926,7 @@ let apply_on_subterm env evdref f c t = match kind_of_term t with | Evar (evk,args) when Evd.is_undefined !evdref evk -> let ctx = evar_filtered_context (Evd.find_undefined !evdref evk) in - let g (_,b,_) a = if Option.is_empty b then applyrec acc a else a in + let g decl a = if is_local_assum decl then applyrec acc a else a in mkEvar (evk, Array.of_list (List.map2 g ctx (Array.to_list args))) | _ -> map_constr_with_binders_left_to_right @@ -939,17 +943,17 @@ let filter_possible_projections c ty ctxt args = let fv2 = collect_vars (mkApp (c,args)) in let len = Array.length args in let tyvars = collect_vars ty in - List.map_i (fun i (id,b,_) -> + List.map_i (fun i decl -> let () = assert (i < len) in let a = Array.unsafe_get args i in - (match b with None -> false | Some c -> not (isRel c || isVar c)) || + (match decl with LocalAssum _ -> false | LocalDef (_,c,_) -> not (isRel c || isVar c)) || a == c || (* Here we make an approximation, for instance, we could also be *) (* interested in finding a term u convertible to c such that a occurs *) (* in u *) isRel a && Int.Set.mem (destRel a) fv1 || isVar a && Id.Set.mem (destVar a) fv2 || - Id.Set.mem id tyvars) + Id.Set.mem (get_id decl) tyvars) 0 ctxt let solve_evars = ref (fun _ -> failwith "solve_evars not installed") @@ -980,17 +984,18 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs = let env_evar = evar_filtered_env evi in let sign = named_context_val env_evar in let ctxt = evar_filtered_context evi in - let instance = List.map mkVar (List.map pi1 ctxt) in + let instance = List.map mkVar (List.map get_id ctxt) in let rec make_subst = function - | (id,_,t)::ctxt', c::l, occs::occsl when isVarId id c -> + | decl'::ctxt', c::l, occs::occsl when isVarId (get_id decl') c -> begin match occs with | Some _ -> error "Cannot force abstraction on identity instance." | None -> make_subst (ctxt',l,occsl) end - | (id,_,t)::ctxt', c::l, occs::occsl -> + | decl'::ctxt', c::l, occs::occsl -> + let (id,_,t) = to_tuple decl' in let evs = ref [] in let ty = Retyping.get_type_of env_rhs evd c in let filter' = filter_possible_projections c ty ctxt args in @@ -1007,7 +1012,9 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs = | None -> let evty = set_holes evdref cty subst in let instance = Filter.filter_list filter instance in - let evd,ev = new_evar_instance sign !evdref evty ~filter instance in + let evd = Sigma.Unsafe.of_evar_map !evdref in + let Sigma (ev, evd, _) = new_evar_instance sign evd evty ~filter instance in + let evd = Sigma.to_evar_map evd in evdref := evd; evsref := (fst (destEvar ev),evty)::!evsref; ev in @@ -1099,7 +1106,7 @@ let apply_conversion_problem_heuristic ts env evd pbty t1 t2 = | Some evd -> Success evd | None -> UnifFailure (evd, ConversionFailed (env,term1,term2))) | Evar (evk1,args1), Evar (evk2,args2) when Evar.equal evk1 evk2 -> - let f env evd pbty x y = is_trans_fconv pbty ts env evd x y in + let f env evd pbty x y = is_fconv ~reds:ts pbty env evd x y in Success (solve_refl ~can_drop:true f env evd (position_problem true pbty) evk1 args1 args2) | Evar ev1, Evar ev2 -> diff --git a/pretyping/evarconv.mli b/pretyping/evarconv.mli index 8bc30a717..14947c892 100644 --- a/pretyping/evarconv.mli +++ b/pretyping/evarconv.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml new file mode 100644 index 000000000..ef3a3f525 --- /dev/null +++ b/pretyping/evardefine.ml @@ -0,0 +1,209 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Errors +open Util +open Pp +open Names +open Term +open Vars +open Termops +open Namegen +open Pre_env +open Environ +open Evd +open Evarutil +open Pretype_errors +open Sigma.Notations + +let new_evar_unsafe env evd ?src ?filter ?candidates ?store ?naming ?principal typ = + let evd = Sigma.Unsafe.of_evar_map evd in + let Sigma (evk, evd, _) = new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ in + (Sigma.to_evar_map evd, evk) + +let env_nf_evar sigma env = + let open Context.Rel.Declaration in + process_rel_context + (fun d e -> push_rel (map_constr (nf_evar sigma) d) e) env + +let env_nf_betaiotaevar sigma env = + let open Context.Rel.Declaration in + process_rel_context + (fun d e -> + push_rel (map_constr (Reductionops.nf_betaiota sigma) d) e) env + +(****************************************) +(* Operations on value/type constraints *) +(****************************************) + +type type_constraint = types option + +type val_constraint = constr option + +(* Old comment... + * Basically, we have the following kind of constraints (in increasing + * strength order): + * (false,(None,None)) -> no constraint at all + * (true,(None,None)) -> we must build a judgement which _TYPE is a kind + * (_,(None,Some ty)) -> we must build a judgement which _TYPE is ty + * (_,(Some v,_)) -> we must build a judgement which _VAL is v + * Maybe a concrete datatype would be easier to understand. + * We differentiate (true,(None,None)) from (_,(None,Some Type)) + * because otherwise Case(s) would be misled, as in + * (n:nat) Case n of bool [_]nat end would infer the predicate Type instead + * of Set. + *) + +(* The empty type constraint *) +let empty_tycon = None + +(* Builds a type constraint *) +let mk_tycon ty = Some ty + +(* Constrains the value of a type *) +let empty_valcon = None + +(* Builds a value constraint *) +let mk_valcon c = Some c + +let idx = Namegen.default_dependent_ident + +(* Refining an evar to a product *) + +let define_pure_evar_as_product evd evk = + let open Context.Named.Declaration in + 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 = Reductionops.whd_betadeltaiota evenv evd evi.evar_concl in + let s = destSort concl in + let evd1,(dom,u1) = + let evd = Sigma.Unsafe.of_evar_map evd in + let Sigma (e, evd1, _) = new_type_evar evenv evd univ_flexible_alg ~filter:(evar_filter evi) in + (Sigma.to_evar_map evd1, e) + in + let evd2,rng = + let newenv = push_named (LocalAssum (id, dom)) evenv in + let src = evar_source evk evd1 in + let filter = Filter.extend 1 (evar_filter evi) in + if is_prop_sort s then + (* Impredicative product, conclusion must fall in [Prop]. *) + new_evar_unsafe newenv evd1 concl ~src ~filter + else + let status = univ_flexible_alg in + let evd3, (rng, srng) = + let evd1 = Sigma.Unsafe.of_evar_map evd1 in + let Sigma (e, evd3, _) = new_type_evar newenv evd1 status ~src ~filter in + (Sigma.to_evar_map evd3, e) + 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 + in + let prod = mkProd (Name id, dom, subst_var id rng) in + let evd3 = Evd.define evk prod evd2 in + evd3,prod + +(* Refine an applied evar to a product and returns its instantiation *) + +let define_evar_as_product evd (evk,args) = + let evd,prod = define_pure_evar_as_product evd evk in + (* Quick way to compute the instantiation of evk with args *) + let na,dom,rng = destProd prod in + let evdom = mkEvar (fst (destEvar dom), args) in + let evrngargs = Array.cons (mkRel 1) (Array.map (lift 1) args) in + let evrng = mkEvar (fst (destEvar rng), evrngargs) in + evd,mkProd (na, evdom, evrng) + +(* Refine an evar with an abstraction + + I.e., solve x1..xq |- ?e:T(x1..xq) with e:=λy:A.?e'[x1..xq,y] where: + - either T(x1..xq) = πy:A(x1..xq).B(x1..xq,y) + or T(x1..xq) = ?d[x1..xq] and we define ?d := πy:?A.?B + with x1..xq |- ?A:Type and x1..xq,y |- ?B:Type + - x1..xq,y:A |- ?e':B +*) + +let define_pure_evar_as_lambda env evd evk = + let open Context.Named.Declaration in + let evi = Evd.find_undefined evd evk in + let evenv = evar_env evi in + let typ = Reductionops.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 + | _ -> error_not_product_loc Loc.ghost env evd typ in + let avoid = ids_of_named_context (evar_context evi) in + let id = + next_name_away_with_default_using_types "x" na avoid (Reductionops.whd_evar evd dom) in + let newenv = push_named (LocalAssum (id, dom)) evenv in + let filter = Filter.extend 1 (evar_filter evi) in + let src = evar_source evk evd1 in + let evd2,body = new_evar_unsafe newenv evd1 ~src (subst1 (mkVar id) rng) ~filter in + let lam = mkLambda (Name id, dom, subst_var id body) in + Evd.define evk lam evd2, lam + +let define_evar_as_lambda env evd (evk,args) = + let evd,lam = define_pure_evar_as_lambda env evd evk in + (* Quick way to compute the instantiation of evk with args *) + let na,dom,body = destLambda lam in + let evbodyargs = Array.cons (mkRel 1) (Array.map (lift 1) args) in + let evbody = mkEvar (fst (destEvar body), evbodyargs) in + evd,mkLambda (na, dom, evbody) + +let rec evar_absorb_arguments env evd (evk,args as ev) = function + | [] -> evd,ev + | a::l -> + (* TODO: optimize and avoid introducing intermediate evars *) + let evd,lam = define_pure_evar_as_lambda env evd evk in + let _,_,body = destLambda lam in + let evk = fst (destEvar body) in + evar_absorb_arguments env evd (evk, Array.cons a args) l + +(* Refining an evar to a sort *) + +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 = Reductionops.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)) sort, s + +(* Propagation of constraints through application and abstraction: + Given a type constraint on a functional term, returns the type + constraint on its domain and codomain. If the input constraint is + an evar instantiate it with the product of 2 new evars. *) + +let split_tycon loc env evd tycon = + let rec real_split evd c = + let t = Reductionops.whd_betadeltaiota env evd c in + match kind_of_term t with + | Prod (na,dom,rng) -> evd, (na, dom, rng) + | Evar ev (* ev is undefined because of whd_betadeltaiota *) -> + let (evd',prod) = define_evar_as_product evd ev in + let (_,dom,rng) = destProd prod in + evd',(Anonymous, dom, rng) + | App (c,args) when isEvar c -> + let (evd',lam) = define_evar_as_lambda env evd (destEvar c) in + real_split evd' (mkApp (lam,args)) + | _ -> error_not_product_loc loc env evd c + in + match tycon with + | None -> evd,(Anonymous,None,None) + | Some c -> + let evd', (n, dom, rng) = real_split evd c in + evd', (n, mk_tycon dom, mk_tycon rng) + +let valcon_of_tycon x = x +let lift_tycon n = Option.map (lift n) + +let pr_tycon env = function + None -> str "None" + | Some t -> Termops.print_constr_env env t diff --git a/pretyping/evardefine.mli b/pretyping/evardefine.mli new file mode 100644 index 000000000..07b0e69d9 --- /dev/null +++ b/pretyping/evardefine.mli @@ -0,0 +1,46 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Names +open Term +open Evd +open Environ + +val env_nf_evar : evar_map -> env -> env +val env_nf_betaiotaevar : evar_map -> env -> env + +type type_constraint = types option +type val_constraint = constr option + +val empty_tycon : type_constraint +val mk_tycon : constr -> type_constraint +val empty_valcon : val_constraint +val mk_valcon : constr -> val_constraint + +(** Instantiate an evar by as many lambda's as needed so that its arguments + are moved to the evar substitution (i.e. turn [?x[vars1:=args1] args] into + [?y[vars1:=args1,vars:=args]] with + [vars1 |- ?x:=\vars.?y[vars1:=vars1,vars:=vars]] *) +val evar_absorb_arguments : env -> evar_map -> existential -> constr list -> + evar_map * existential + +val split_tycon : + Loc.t -> env -> evar_map -> type_constraint -> + evar_map * (Name.t * type_constraint * type_constraint) + +val valcon_of_tycon : type_constraint -> val_constraint +val lift_tycon : int -> type_constraint -> type_constraint + +val define_evar_as_product : evar_map -> existential -> evar_map * types +val define_evar_as_lambda : env -> evar_map -> existential -> evar_map * types +val define_evar_as_sort : env -> evar_map -> existential -> evar_map * sorts + +(** {6 debug pretty-printer:} *) + +val pr_tycon : env -> type_constraint -> Pp.std_ppcmds + diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index f06207c3b..3d1822102 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -11,7 +11,6 @@ open Errors open Names open Term open Vars -open Context open Environ open Termops open Evd @@ -20,6 +19,8 @@ open Retyping open Reductionops open Evarutil open Pretype_errors +open Sigma.Notations +open Context.Rel.Declaration let normalize_evar evd ev = match kind_of_term (whd_evar evd (mkEvar ev)) with @@ -42,21 +43,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 refresh_universes ?(status=univ_rigid) ?(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 +64,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,11 +77,11 @@ 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 () - | _ -> iter_constr (refresh_term_evars onevars false) t + | _ -> Constr.iter (refresh_term_evars onevars false) t and refresh_polymorphic_positions args pos = let rec aux i = function | Some l :: ls -> @@ -99,7 +99,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 status dir t) else (refresh_term_evars false true t; t) in if !modified then !evdref, t' else !evdref, t @@ -164,7 +164,8 @@ type 'a update = | UpdateWith of 'a | NoUpdate -let inst_of_vars sign = Array.map_of_list (fun (id,_,_) -> mkVar id) sign +open Context.Named.Declaration +let inst_of_vars sign = Array.map_of_list (mkVar % get_id) sign let restrict_evar_key evd evk filter candidates = match filter, candidates with @@ -182,7 +183,9 @@ let restrict_evar_key evd evk filter candidates = let candidates = match candidates with | NoUpdate -> evi.evar_candidates | UpdateWith c -> Some c in - restrict_evar evd evk filter candidates + let sigma = Sigma.Unsafe.of_evar_map evd in + let Sigma (evk, sigma, _) = restrict_evar sigma evk filter candidates in + (Sigma.to_evar_map sigma, evk) end (* Restrict an applied evar and returns its restriction in the same context *) @@ -207,6 +210,7 @@ let restrict_instance evd evk filter argsv = let evi = Evd.find evd evk in Filter.filter_array (Filter.compose (evar_filter evi) filter) argsv +open Context.Rel.Declaration let noccur_evar env evd evk c = let cache = ref Int.Set.empty (* cache for let-ins *) in let rec occur_rec (k, env as acc) c = @@ -219,9 +223,9 @@ let noccur_evar env evd evk c = else Array.iter (occur_rec acc) args') | Rel i when i > k -> if not (Int.Set.mem (i-k) !cache) then - (match pi2 (Environ.lookup_rel i env) with - | None -> () - | Some b -> cache := Int.Set.add (i-k) !cache; occur_rec acc (lift i b)) + (match Environ.lookup_rel i env with + | LocalAssum _ -> () + | LocalDef (_,b,_) -> cache := Int.Set.add (i-k) !cache; occur_rec acc (lift i b)) | Proj (p,c) -> let c = try Retyping.expand_projection env evd p c [] @@ -243,9 +247,11 @@ let noccur_evar env evd evk c = variable in its family of aliased variables *) let compute_var_aliases sign = - List.fold_right (fun (id,b,c) aliases -> - match b with - | Some t -> + let open Context.Named.Declaration in + List.fold_right (fun decl aliases -> + let id = get_id decl in + match decl with + | LocalDef (_,t,_) -> (match kind_of_term t with | Var id' -> let aliases_of_id = @@ -253,27 +259,30 @@ let compute_var_aliases sign = Id.Map.add id (aliases_of_id@[t]) aliases | _ -> Id.Map.add id [t] aliases) - | None -> aliases) + | LocalAssum _ -> aliases) sign Id.Map.empty let compute_rel_aliases var_aliases rels = - snd (List.fold_right (fun (_,b,u) (n,aliases) -> - (n-1, - match b with - | Some t -> - (match kind_of_term t with - | Var id' -> - let aliases_of_n = - try Id.Map.find id' var_aliases with Not_found -> [] in - Int.Map.add n (aliases_of_n@[t]) aliases - | Rel p -> - let aliases_of_n = - try Int.Map.find (p+n) aliases with Not_found -> [] in - Int.Map.add n (aliases_of_n@[mkRel (p+n)]) aliases - | _ -> - Int.Map.add n [lift n (mkCast(t,DEFAULTcast,u))] aliases) - | None -> aliases)) - rels (List.length rels,Int.Map.empty)) + snd (List.fold_right + (fun decl (n,aliases) -> + (n-1, + match decl with + | LocalDef (_,t,u) -> + (match kind_of_term t with + | Var id' -> + let aliases_of_n = + try Id.Map.find id' var_aliases with Not_found -> [] in + Int.Map.add n (aliases_of_n@[t]) aliases + | Rel p -> + let aliases_of_n = + try Int.Map.find (p+n) aliases with Not_found -> [] in + Int.Map.add n (aliases_of_n@[mkRel (p+n)]) aliases + | _ -> + Int.Map.add n [lift n (mkCast(t,DEFAULTcast,u))] aliases) + | LocalAssum _ -> aliases) + ) + rels + (List.length rels,Int.Map.empty)) let make_alias_map env = (* We compute the chain of aliases for each var and rel *) @@ -307,13 +316,13 @@ let normalize_alias aliases x = let normalize_alias_var var_aliases id = destVar (normalize_alias (var_aliases,Int.Map.empty) (mkVar id)) -let extend_alias (_,b,_) (var_aliases,rel_aliases) = +let extend_alias decl (var_aliases,rel_aliases) = let rel_aliases = Int.Map.fold (fun n l -> Int.Map.add (n+1) (List.map (lift 1) l)) rel_aliases Int.Map.empty in let rel_aliases = - match b with - | Some t -> + match decl with + | LocalDef(_,t,_) -> (match kind_of_term t with | Var id' -> let aliases_of_binder = @@ -325,7 +334,7 @@ let extend_alias (_,b,_) (var_aliases,rel_aliases) = Int.Map.add 1 (aliases_of_binder@[mkRel (p+1)]) rel_aliases | _ -> Int.Map.add 1 [lift 1 t] rel_aliases) - | None -> rel_aliases in + | LocalAssum _ -> rel_aliases in (var_aliases, rel_aliases) let expand_alias_once aliases x = @@ -431,16 +440,17 @@ let get_actual_deps aliases l t = | Rel n -> Int.Set.mem n fv_rels | _ -> assert false) l +open Context.Named.Declaration let remove_instance_local_defs evd evk args = let evi = Evd.find evd evk in let len = Array.length args in let rec aux sign i = match sign with | [] -> let () = assert (i = len) in [] - | (_, None, _) :: sign -> + | LocalAssum _ :: sign -> let () = assert (i < len) in (Array.unsafe_get args i) :: aux sign (succ i) - | (_, Some _, _) :: sign -> + | LocalDef _ :: sign -> aux sign (succ i) in aux (evar_filtered_context evi) 0 @@ -502,7 +512,8 @@ let solve_pattern_eqn env l c = match kind_of_term a with (* Rem: if [a] links to a let-in, do as if it were an assumption *) | Rel n -> - let d = map_rel_declaration (lift n) (lookup_rel n env) in + let open Context.Rel.Declaration in + let d = map_constr (lift n) (lookup_rel n env) in mkLambda_or_LetIn d c' | Var id -> let d = lookup_named id env in mkNamedLambda_or_LetIn d c' @@ -531,9 +542,9 @@ let make_projectable_subst aliases sigma evi args = let evar_aliases = compute_var_aliases sign in let (_,full_subst,cstr_subst) = List.fold_right - (fun (id,b,c) (args,all,cstrs) -> - match b,args with - | None, a::rest -> + (fun decl (args,all,cstrs) -> + match decl,args with + | LocalAssum (id,c), a::rest -> let a = whd_evar sigma a in let cstrs = let a',args = decompose_app_vect a in @@ -543,7 +554,7 @@ let make_projectable_subst aliases sigma evi args = Constrmap.add (fst cstr) ((args,id)::l) cstrs | _ -> cstrs in (rest,Id.Map.add id [a,normalize_alias_opt aliases a,id] all,cstrs) - | Some c, a::rest -> + | LocalDef (id,c,_), a::rest -> let a = whd_evar sigma a in (match kind_of_term c with | Var id' -> @@ -572,7 +583,9 @@ let make_projectable_subst aliases sigma evi args = *) let define_evar_from_virtual_equation define_fun env evd src t_in_env ty_t_in_sign sign filter inst_in_env = - let evd,evar_in_env = new_evar_instance sign evd ty_t_in_sign ~filter ~src inst_in_env in + let evd = Sigma.Unsafe.of_evar_map evd in + let Sigma (evar_in_env, evd, _) = new_evar_instance sign evd ty_t_in_sign ~filter ~src inst_in_env in + let evd = Sigma.to_evar_map evd in let t_in_env = whd_evar evd t_in_env in let evd = define_fun env evd None (destEvar evar_in_env) t_in_env in let ctxt = named_context_of_val sign in @@ -603,23 +616,26 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = let sign1 = evar_hyps evi1 in let filter1 = evar_filter evi1 in let src = subterm_source evk1 evi1.evar_source in - let ids1 = List.map pi1 (named_context_of_val sign1) in + let ids1 = List.map get_id (named_context_of_val sign1) in let inst_in_sign = List.map mkVar (Filter.filter_list filter1 ids1) in + let open Context.Rel.Declaration in let (sign2,filter2,inst2_in_env,inst2_in_sign,_,evd,_) = - List.fold_right (fun (na,b,t_in_env as d) (sign,filter,inst_in_env,inst_in_sign,env,evd,avoid) -> + List.fold_right (fun d (sign,filter,inst_in_env,inst_in_sign,env,evd,avoid) -> + let LocalAssum (na,t_in_env) | LocalDef (na,_,t_in_env) = d in let id = next_name_away na avoid in let evd,t_in_sign = let s = Retyping.get_sort_of env evd t_in_env in - let evd,ty_t_in_sign = refresh_universes ~inferred:true (Some false) env evd (mkSort s) in + let evd,ty_t_in_sign = refresh_universes + ~status:univ_flexible (Some false) env evd (mkSort s) in define_evar_from_virtual_equation define_fun env evd src t_in_env ty_t_in_sign sign filter inst_in_env in - let evd,b_in_sign = match b with - | None -> evd,None - | Some b -> + let evd,b_in_sign = match d with + | LocalAssum _ -> evd,None + | LocalDef (_,b,_) -> let evd,b = define_evar_from_virtual_equation define_fun env evd src b t_in_sign sign filter inst_in_env in evd,Some b in - (push_named_context_val (id,b_in_sign,t_in_sign) sign, Filter.extend 1 filter, + (push_named_context_val (Context.Named.Declaration.of_tuple (id,b_in_sign,t_in_sign)) sign, Filter.extend 1 filter, (mkRel 1)::(List.map (lift 1) inst_in_env), (mkRel 1)::(List.map (lift 1) inst_in_sign), push_rel d env,evd,id::avoid)) @@ -628,11 +644,14 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = in let evd,ev2ty_in_sign = let s = Retyping.get_sort_of env evd ty_in_env in - let evd,ty_t_in_sign = refresh_universes ~inferred:true (Some false) env evd (mkSort s) in + let evd,ty_t_in_sign = refresh_universes + ~status:univ_flexible (Some false) env evd (mkSort s) in define_evar_from_virtual_equation define_fun env evd src ty_in_env ty_t_in_sign sign2 filter2 inst2_in_env in - let evd,ev2_in_sign = + let evd = Sigma.Unsafe.of_evar_map evd in + let Sigma (ev2_in_sign, evd, _) = new_evar_instance sign2 evd ev2ty_in_sign ~filter:filter2 ~src inst2_in_sign in + let evd = Sigma.to_evar_map evd in let ev2_in_env = (fst (destEvar ev2_in_sign), Array.of_list inst2_in_env) in (evd, ev2_in_sign, ev2_in_env) @@ -756,9 +775,10 @@ let project_with_effects aliases sigma effects t subst = effects := p :: !effects; c +open Context.Named.Declaration let rec find_solution_type evarenv = function - | (id,ProjectVar)::l -> pi3 (lookup_named id evarenv) - | [id,ProjectEvar _] -> (* bugged *) pi3 (lookup_named id evarenv) + | (id,ProjectVar)::l -> get_type (lookup_named id evarenv) + | [id,ProjectEvar _] -> (* bugged *) get_type (lookup_named id evarenv) | (id,ProjectEvar _)::l -> find_solution_type evarenv l | [] -> assert false @@ -892,7 +912,7 @@ let invert_invertible_arg fullenv evd aliases k (evk,argsv) args' = *) let set_of_evctx l = - List.fold_left (fun s (id,_,_) -> Id.Set.add id s) Id.Set.empty l + List.fold_left (fun s decl -> Id.Set.add (get_id decl) s) Id.Set.empty l let filter_effective_candidates evi filter candidates = match filter with @@ -924,7 +944,13 @@ let closure_of_filter evd evk = function | Some filter -> let evi = Evd.find_undefined evd evk in 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 test b decl = b || Idset.mem (get_id decl) vars || + match decl with + | LocalAssum _ -> + false + | LocalDef (_,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 @@ -1006,21 +1032,6 @@ let postpone_non_unique_projection env evd pbty (evk,argsv as ev) sols rhs = * Note: argument f is the function used to instantiate evars. *) -let are_canonical_instances args1 args2 env = - let n1 = Array.length args1 in - let n2 = Array.length args2 in - let rec aux n = function - | (id,_,c)::sign - when n < n1 && isVarId id args1.(n) && isVarId id args2.(n) -> - aux (n+1) sign - | [] -> - let rec aux2 n = - Int.equal n n1 || - (isRelN (n1-n) args1.(n) && isRelN (n1-n) args2.(n) && aux2 (n+1)) - in aux2 n - | _ -> false in - Int.equal n1 n2 && aux 0 (named_context env) - let filter_compatible_candidates conv_algo env evd evi args rhs c = let c' = instantiate_evar_array evi c args in match conv_algo env evd Reduction.CONV rhs c' with @@ -1275,18 +1286,27 @@ 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 seen = ref Evar.Set.empty in 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 + | Evar (sp,args as e) -> + if Evar.Set.mem sp !seen then + Array.iter occur_rec args + else ( + seen := Evar.Set.add sp !seen; + Option.iter occur_rec (existential_opt_value sigma e); + occur_rec (existential_type sigma e)) + | _ -> Constr.iter occur_rec c in try occur_rec c; false with Occur -> true @@ -1371,15 +1391,16 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = let t = whd_evar !evdref t in match kind_of_term t with | Rel i when i>k -> - (match pi2 (Environ.lookup_rel (i-k) env') with - | None -> project_variable (mkRel (i-k)) - | Some b -> + let open Context.Rel.Declaration in + (match Environ.lookup_rel (i-k) env' with + | LocalAssum _ -> project_variable (mkRel (i-k)) + | LocalDef (_,b,_) -> try project_variable (mkRel (i-k)) with NotInvertibleUsingOurAlgorithm _ -> imitate envk (lift i b)) | Var id -> - (match pi2 (Environ.lookup_named id env') with - | None -> project_variable t - | Some b -> + (match Environ.lookup_named id env' with + | LocalAssum _ -> project_variable t + | LocalDef (_,b,_) -> try project_variable t with NotInvertibleUsingOurAlgorithm _ -> imitate envk b) | LetIn (na,b,u,c) -> @@ -1459,7 +1480,8 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = let names = ref Idset.empty in let rec is_id_subst ctxt s = match ctxt, s with - | ((id, _, _) :: ctxt'), (c :: s') -> + | (decl :: ctxt'), (c :: s') -> + let id = get_id decl in names := Idset.add id !names; isVarId id c && is_id_subst ctxt' s' | [], [] -> true diff --git a/pretyping/evarsolve.mli b/pretyping/evarsolve.mli index 21d976091..918ba12f0 100644 --- a/pretyping/evarsolve.mli +++ b/pretyping/evarsolve.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -34,7 +34,8 @@ type conv_fun_bool = val evar_define : conv_fun -> ?choose:bool -> env -> evar_map -> bool option -> existential -> constr -> evar_map -val refresh_universes : ?inferred:bool -> ?onlyalg:bool (* Only algebraic universes *) -> +val refresh_universes : ?status:Evd.rigid -> + ?onlyalg:bool (* Only algebraic universes *) -> bool option (* direction: true for levels lower than the existing levels *) -> env -> evar_map -> types -> evar_map * types diff --git a/pretyping/find_subterm.ml b/pretyping/find_subterm.ml index 95a6ba79d..ae8b91c34 100644 --- a/pretyping/find_subterm.ml +++ b/pretyping/find_subterm.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -59,19 +59,22 @@ let proceed_with_occurrences f occs x = (** Applying a function over a named_declaration with an hypothesis location request *) -let map_named_declaration_with_hyploc f hyploc acc (id,bodyopt,typ) = - let f = f (Some (id,hyploc)) in - match bodyopt,hyploc with - | None, InHypValueOnly -> +let map_named_declaration_with_hyploc f hyploc acc decl = + let open Context.Named.Declaration in + let f = f (Some (get_id decl, hyploc)) in + match decl,hyploc with + | LocalAssum (id,_), InHypValueOnly -> error_occurrences_error (IncorrectInValueOccurrence id) - | None, _ | Some _, InHypTypeOnly -> - let acc,typ = f acc typ in acc,(id,bodyopt,typ) - | Some body, InHypValueOnly -> - let acc,body = f acc body in acc,(id,Some body,typ) - | Some body, InHyp -> + | LocalAssum (id,typ), _ -> + let acc,typ = f acc typ in acc, LocalAssum (id,typ) + | LocalDef (id,body,typ), InHypTypeOnly -> + let acc,typ = f acc typ in acc, LocalDef (id,body,typ) + | LocalDef (id,body,typ), InHypValueOnly -> + let acc,body = f acc body in acc, LocalDef (id,body,typ) + | LocalDef (id,body,typ), InHyp -> let acc,body = f acc body in let acc,typ = f acc typ in - acc,(id,Some body,typ) + acc, LocalDef (id,body,typ) (** Finding a subterm up to some testing function *) diff --git a/pretyping/find_subterm.mli b/pretyping/find_subterm.mli index 47d9654e5..c741ab048 100644 --- a/pretyping/find_subterm.mli +++ b/pretyping/find_subterm.mli @@ -1,13 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) open Locus -open Context open Term open Evd open Pretype_errors @@ -50,7 +49,7 @@ val replace_term_occ_modulo : occurrences or_like_first -> val replace_term_occ_decl_modulo : (occurrences * hyp_location_flag) or_like_first -> 'a testing_function -> (unit -> constr) -> - named_declaration -> named_declaration + Context.Named.Declaration.t -> Context.Named.Declaration.t (** [subst_closed_term_occ occl c d] replaces occurrences of closed [c] at positions [occl] by [Rel 1] in [d] (see also Note OCC), @@ -62,7 +61,7 @@ val subst_closed_term_occ : env -> evar_map -> occurrences or_like_first -> closed [c] at positions [occl] by [Rel 1] in [decl]. *) val subst_closed_term_occ_decl : env -> evar_map -> (occurrences * hyp_location_flag) or_like_first -> - constr -> named_declaration -> named_declaration * evar_map + constr -> Context.Named.Declaration.t -> Context.Named.Declaration.t * evar_map (** Miscellaneous *) val error_invalid_occurrence : int list -> 'a diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index 3a76e8bd7..c9860864a 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/pretyping/glob_ops.mli b/pretyping/glob_ops.mli index 25746323f..45444234a 100644 --- a/pretyping/glob_ops.mli +++ b/pretyping/glob_ops.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index 54d47fbe0..713c99597 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -19,7 +19,6 @@ open Globnames open Nameops open Term open Vars -open Context open Namegen open Declarations open Declareops @@ -28,6 +27,8 @@ open Inductiveops open Environ open Reductionops open Nametab +open Sigma.Notations +open Context.Rel.Declaration type dep_flag = bool @@ -60,7 +61,7 @@ let check_privacy_block mib = let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind = let lnamespar = Vars.subst_instance_context u mib.mind_params_ctxt in - let indf = make_ind_family(pind, Termops.extended_rel_list 0 lnamespar) in + let indf = make_ind_family(pind, Context.Rel.to_extended_list 0 lnamespar) in let constrs = get_constructors env indf in let projs = get_projections env indf in @@ -77,7 +78,6 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind = (* mais pas très joli ... (mais manque get_sort_of à ce niveau) *) let env' = push_rel_context lnamespar env in - let rec add_branch env k = if Int.equal k (Array.length mip.mind_consnames) then let nbprod = k+1 in @@ -85,14 +85,14 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind = let indf' = lift_inductive_family nbprod indf in let arsign,_ = get_arity env indf' in let depind = build_dependent_inductive env indf' in - let deparsign = (Anonymous,None,depind)::arsign in + let deparsign = LocalAssum (Anonymous,depind)::arsign in let ci = make_case_info env (fst pind) RegularStyle in let pbody = appvect (mkRel (ndepar + nbprod), - if dep then Termops.extended_rel_vect 0 deparsign - else Termops.extended_rel_vect 1 arsign) in + if dep then Context.Rel.to_extended_vect 0 deparsign + else Context.Rel.to_extended_vect 1 arsign) in let p = it_mkLambda_or_LetIn_name env' ((if dep then mkLambda_name env' else mkLambda) @@ -118,15 +118,16 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind = let cs = lift_constructor (k+1) constrs.(k) in let t = build_branch_type env dep (mkRel (k+1)) cs in mkLambda_string "f" t - (add_branch (push_rel (Anonymous, None, t) env) (k+1)) + (add_branch (push_rel (LocalAssum (Anonymous, t)) env) (k+1)) in - let sigma, s = Evd.fresh_sort_in_family ~rigid:Evd.univ_flexible_alg env sigma kind in + let Sigma (s, sigma, p) = Sigma.fresh_sort_in_family ~rigid:Evd.univ_flexible_alg env sigma kind in let typP = make_arity env' dep indf s in let c = it_mkLambda_or_LetIn_name env (mkLambda_string "P" typP - (add_branch (push_rel (Anonymous,None,typP) env') 0)) lnamespar - in sigma, c + (add_branch (push_rel (LocalAssum (Anonymous,typP)) env') 0)) lnamespar + in + Sigma (c, sigma, p) (* check if the type depends recursively on one of the inductive scheme *) @@ -153,20 +154,23 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs = let p',largs = whd_betadeltaiota_nolet_stack env sigma p in match kind_of_term p' with | Prod (n,t,c) -> - let d = (n,None,t) in + let d = LocalAssum (n,t) in make_prod env (n,t,prec (push_rel d env) (i+1) (d::sign) c) - | LetIn (n,b,t,c) -> - let d = (n,Some b,t) in + | LetIn (n,b,t,c) when List.is_empty largs -> + let d = LocalDef (n,b,t) in mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::sign) c) | Ind (_,_) -> let realargs = List.skipn nparams largs in let base = applist (lift i pk,realargs) in if depK then Reduction.beta_appvect - base [|applist (mkRel (i+1), Termops.extended_rel_list 0 sign)|] + base [|applist (mkRel (i+1), Context.Rel.to_extended_list 0 sign)|] else base - | _ -> assert false + | _ -> + let t' = whd_betadeltaiota env sigma p in + if Term.eq_constr p' t' then assert false + else prec env i sign t' in prec env 0 [] in @@ -188,22 +192,22 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs = | None -> make_prod env (n,t, - process_constr (push_rel (n,None,t) env) (i+1) c_0 rest + process_constr (push_rel (LocalAssum (n,t)) env) (i+1) c_0 rest (nhyps-1) (i::li)) | Some(dep',p) -> let nP = lift (i+1+decP) p in - let env' = push_rel (n,None,t) env in + let env' = push_rel (LocalAssum (n,t)) env in let t_0 = process_pos env' dep' nP (lift 1 t) in make_prod_dep (dep || dep') env (n,t, mkArrow t_0 (process_constr - (push_rel (Anonymous,None,t_0) env') + (push_rel (LocalAssum (Anonymous,t_0)) env') (i+2) (lift 1 c_0) rest (nhyps-1) (i::li)))) | LetIn (n,b,t,c_0) -> mkLetIn (n,b,t, process_constr - (push_rel (n,Some b,t) env) + (push_rel (LocalDef (n,b,t)) env) (i+1) c_0 recargs (nhyps-1) li) | _ -> assert false else @@ -228,22 +232,25 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs = let p',largs = whd_betadeltaiota_nolet_stack env sigma p in match kind_of_term p' with | Prod (n,t,c) -> - let d = (n,None,t) in + let d = LocalAssum (n,t) in mkLambda_name env (n,t,prec (push_rel d env) (i+1) (d::hyps) c) - | LetIn (n,b,t,c) -> - let d = (n,Some b,t) in + | LetIn (n,b,t,c) when List.is_empty largs -> + let d = LocalDef (n,b,t) in mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::hyps) c) | Ind _ -> let realargs = List.skipn nparrec largs - and arg = appvect (mkRel (i+1), Termops.extended_rel_vect 0 hyps) in + and arg = appvect (mkRel (i+1), Context.Rel.to_extended_vect 0 hyps) in applist(lift i fk,realargs@[arg]) - | _ -> assert false + | _ -> + let t' = whd_betadeltaiota env sigma p in + if Term.eq_constr t' p' then assert false + else prec env i hyps t' in prec env 0 [] in (* ici, cstrprods est la liste des produits du constructeur instantié *) let rec process_constr env i f = function - | (n,None,t as d)::cprest, recarg::rest -> + | (LocalAssum (n,t) as d)::cprest, recarg::rest -> let optionpos = match dest_recarg recarg with | Norec -> None @@ -264,7 +271,7 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs = (n,t,process_constr env' (i+1) (whd_beta Evd.empty (applist (lift 1 f, [(mkRel 1); arg]))) (cprest,rest))) - | (n,Some c,t as d)::cprest, rest -> + | (LocalDef (n,c,t) as d)::cprest, rest -> mkLetIn (n,c,t, process_constr (push_rel d env) (i+1) (lift 1 f) @@ -275,24 +282,13 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs = in process_constr env 0 f (List.rev cstr.cs_args, recargs) - -(* Cut a context ctx in 2 parts (ctx1,ctx2) with ctx1 containing k - variables *) -let context_chop k ctx = - let rec chop_aux acc = function - | (0, l2) -> (List.rev acc, l2) - | (n, ((_,Some _,_ as h)::t)) -> chop_aux (h::acc) (n, t) - | (n, (h::t)) -> chop_aux (h::acc) (pred n, t) - | (_, []) -> failwith "context_chop" - in chop_aux [] (k,ctx) - (* Main function *) let mis_make_indrec env sigma listdepkind mib u = let nparams = mib.mind_nparams in let nparrec = mib.mind_nparams_rec in let evdref = ref sigma in let lnonparrec,lnamesparrec = - context_chop (nparams-nparrec) (Vars.subst_instance_context u mib.mind_params_ctxt) in + Termops.context_chop (nparams-nparrec) (Vars.subst_instance_context u mib.mind_params_ctxt) in let nrec = List.length listdepkind in let depPvec = Array.make mib.mind_ntypes (None : (bool * constr) option) in @@ -321,29 +317,29 @@ let mis_make_indrec env sigma listdepkind mib u = (* arity in the context of the fixpoint, i.e. P1..P_nrec f1..f_nbconstruct *) - let args = Termops.extended_rel_list (nrec+nbconstruct) lnamesparrec in + let args = Context.Rel.to_extended_list (nrec+nbconstruct) lnamesparrec in let indf = make_ind_family((indi,u),args) in let arsign,_ = get_arity env indf in let depind = build_dependent_inductive env indf in - let deparsign = (Anonymous,None,depind)::arsign in + let deparsign = LocalAssum (Anonymous,depind)::arsign in - let nonrecpar = rel_context_length lnonparrec in - let larsign = rel_context_length deparsign in + let nonrecpar = Context.Rel.length lnonparrec in + let larsign = Context.Rel.length deparsign in let ndepar = larsign - nonrecpar in let dect = larsign+nrec+nbconstruct in (* constructors in context of the Cases expr, i.e. P1..P_nrec f1..f_nbconstruct F_1..F_nrec a_1..a_nar x:I *) - let args' = Termops.extended_rel_list (dect+nrec) lnamesparrec in - let args'' = Termops.extended_rel_list ndepar lnonparrec in + let args' = Context.Rel.to_extended_list (dect+nrec) lnamesparrec in + let args'' = Context.Rel.to_extended_list ndepar lnonparrec in let indf' = make_ind_family((indi,u),args'@args'') in let branches = let constrs = get_constructors env indf' in let fi = Termops.rel_vect (dect-i-nctyi) nctyi in let vecfi = Array.map - (fun f -> appvect (f, Termops.extended_rel_vect ndepar lnonparrec)) + (fun f -> appvect (f, Context.Rel.to_extended_vect ndepar lnonparrec)) fi in Array.map3 @@ -361,12 +357,12 @@ let mis_make_indrec env sigma listdepkind mib u = let depind' = build_dependent_inductive env indf' in let arsign',_ = get_arity env indf' in - let deparsign' = (Anonymous,None,depind')::arsign' in + let deparsign' = LocalAssum (Anonymous,depind')::arsign' in let pargs = - let nrpar = Termops.extended_rel_list (2*ndepar) lnonparrec - and nrar = if dep then Termops.extended_rel_list 0 deparsign' - else Termops.extended_rel_list 1 arsign' + let nrpar = Context.Rel.to_extended_list (2*ndepar) lnonparrec + and nrar = if dep then Context.Rel.to_extended_list 0 deparsign' + else Context.Rel.to_extended_list 1 arsign' in nrpar@nrar in @@ -391,11 +387,13 @@ let mis_make_indrec env sigma listdepkind mib u = let branch = branches.(0) in let ctx, br = decompose_lam_assum branch in let n, subst = - List.fold_right (fun (na,b,t) (i, subst) -> - if b == None then - let t = mkProj (Projection.make ps.(i) true, mkRel 1) in - (i + 1, t :: subst) - else (i, mkRel 0 :: subst)) + List.fold_right (fun decl (i, subst) -> + match decl with + | LocalAssum (na,t) -> + let t = mkProj (Projection.make ps.(i) true, mkRel 1) in + i + 1, t :: subst + | LocalDef (na,b,t) -> + i, mkRel 0 :: subst) ctx (0, []) in let term = substl subst br in @@ -409,14 +407,14 @@ let mis_make_indrec env sigma listdepkind mib u = let typtyi = let concl = - let pargs = if dep then Termops.extended_rel_vect 0 deparsign - else Termops.extended_rel_vect 1 arsign + let pargs = if dep then Context.Rel.to_extended_vect 0 deparsign + else Context.Rel.to_extended_vect 1 arsign in appvect (mkRel (nbconstruct+ndepar+nonrecpar+j),pargs) in it_mkProd_or_LetIn_name env concl deparsign in - mrec (i+nctyi) (rel_context_nhyps arsign ::ln) (typtyi::ltyp) + mrec (i+nctyi) (Context.Rel.nhyps arsign ::ln) (typtyi::ltyp) (deftyi::ldef) rest | [] -> let fixn = Array.of_list (List.rev ln) in @@ -437,28 +435,28 @@ let mis_make_indrec env sigma listdepkind mib u = else let recarg = (dest_subterms recargsvec.(tyi)).(j) in let recarg = recargpar@recarg in - let vargs = Termops.extended_rel_list (nrec+i+j) lnamesparrec in + let vargs = Context.Rel.to_extended_list (nrec+i+j) lnamesparrec in let cs = get_constructor ((indi,u),mibi,mipi,vargs) (j+1) in let p_0 = type_rec_branch true dep env !evdref (vargs,depPvec,i+j) tyi cs recarg in mkLambda_string "f" p_0 - (onerec (push_rel (Anonymous,None,p_0) env) (j+1)) + (onerec (push_rel (LocalAssum (Anonymous,p_0)) env) (j+1)) in onerec env 0 | [] -> makefix i listdepkind in let rec put_arity env i = function | ((indi,u),_,_,dep,kinds)::rest -> - let indf = make_ind_family ((indi,u), Termops.extended_rel_list i lnamesparrec) in + let indf = make_ind_family ((indi,u), Context.Rel.to_extended_list i lnamesparrec) in let s = Evarutil.evd_comb1 (Evd.fresh_sort_in_family ~rigid:Evd.univ_flexible_alg env) evdref kinds in let typP = make_arity env dep indf s in mkLambda_string "P" typP - (put_arity (push_rel (Anonymous,None,typP) env) (i+1) rest) + (put_arity (push_rel (LocalAssum (Anonymous,typP)) env) (i+1) rest) | [] -> make_branch env 0 listdepkind in @@ -474,7 +472,9 @@ let mis_make_indrec env sigma listdepkind mib u = it_mkLambda_or_LetIn_name env (put_arity env' 0 listdepkind) lnamesparrec else - let evd', c = mis_make_case_com dep env !evdref (indi,u) (mibi,mipi) kind in + let sigma = Sigma.Unsafe.of_evar_map !evdref in + let Sigma (c, sigma, _) = mis_make_case_com dep env sigma (indi,u) (mibi,mipi) kind in + let evd' = Sigma.to_evar_map sigma in evdref := evd'; c in (* Body of mis_make_indrec *) diff --git a/pretyping/indrec.mli b/pretyping/indrec.mli index f616c9679..f0736d2dd 100644 --- a/pretyping/indrec.mli +++ b/pretyping/indrec.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -25,13 +25,13 @@ type dep_flag = bool (** Build a case analysis elimination scheme in some sort family *) -val build_case_analysis_scheme : env -> evar_map -> pinductive -> - dep_flag -> sorts_family -> evar_map * constr +val build_case_analysis_scheme : env -> 'r Sigma.t -> pinductive -> + dep_flag -> sorts_family -> (constr, 'r) Sigma.sigma (** Build a dependent case elimination predicate unless type is in Prop *) -val build_case_analysis_scheme_default : env -> evar_map -> pinductive -> - sorts_family -> evar_map * constr +val build_case_analysis_scheme_default : env -> 'r Sigma.t -> pinductive -> + sorts_family -> (constr, 'r) Sigma.sigma (** Builds a recursive induction scheme (Peano-induction style) in the same sort family as the inductive family; it is dependent if not in Prop *) diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index cb091f2d6..80f1988a9 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -12,12 +12,12 @@ open Names open Univ open Term open Vars -open Context open Termops open Declarations open Declareops open Environ open Reductionops +open Context.Rel.Declaration (* The following three functions are similar to the ones defined in Inductive, but they expect an env *) @@ -142,12 +142,12 @@ let constructor_nallargs_env env ((kn,i),j) = let constructor_nalldecls (indsp,j) = (* TOCHANGE en decls *) let (mib,mip) = Global.lookup_inductive indsp in - mip.mind_consnrealdecls.(j-1) + rel_context_length (mib.mind_params_ctxt) + mip.mind_consnrealdecls.(j-1) + Context.Rel.length (mib.mind_params_ctxt) let constructor_nalldecls_env env ((kn,i),j) = (* TOCHANGE en decls *) let mib = Environ.lookup_mind kn env in let mip = mib.mind_packets.(i) in - mip.mind_consnrealdecls.(j-1) + rel_context_length (mib.mind_params_ctxt) + mip.mind_consnrealdecls.(j-1) + Context.Rel.length (mib.mind_params_ctxt) (* Arity of constructors excluding params, excluding local defs *) @@ -213,21 +213,21 @@ let inductive_nparams_env env ind = let inductive_nparamdecls ind = let (mib,mip) = Global.lookup_inductive ind in - rel_context_length mib.mind_params_ctxt + Context.Rel.length mib.mind_params_ctxt let inductive_nparamdecls_env env ind = let (mib,mip) = Inductive.lookup_mind_specif env ind in - rel_context_length mib.mind_params_ctxt + Context.Rel.length mib.mind_params_ctxt (* Full length of arity (with local defs) *) let inductive_nalldecls ind = let (mib,mip) = Global.lookup_inductive ind in - rel_context_length (mib.mind_params_ctxt) + mip.mind_nrealdecls + Context.Rel.length (mib.mind_params_ctxt) + mip.mind_nrealdecls let inductive_nalldecls_env env ind = let (mib,mip) = Inductive.lookup_mind_specif env ind in - rel_context_length (mib.mind_params_ctxt) + mip.mind_nrealdecls + Context.Rel.length (mib.mind_params_ctxt) + mip.mind_nrealdecls (* Others *) @@ -249,13 +249,13 @@ let inductive_alldecls_env env (ind,u) = let constructor_has_local_defs (indsp,j) = let (mib,mip) = Global.lookup_inductive indsp in - let l1 = mip.mind_consnrealdecls.(j-1) + rel_context_length (mib.mind_params_ctxt) in + let l1 = mip.mind_consnrealdecls.(j-1) + Context.Rel.length (mib.mind_params_ctxt) in let l2 = recarg_length mip.mind_recargs j + mib.mind_nparams in not (Int.equal l1 l2) let inductive_has_local_defs ind = let (mib,mip) = Global.lookup_inductive ind in - let l1 = rel_context_length (mib.mind_params_ctxt) + mip.mind_nrealdecls in + let l1 = Context.Rel.length (mib.mind_params_ctxt) + mip.mind_nrealdecls in let l2 = mib.mind_nparams + mip.mind_nrealargs in not (Int.equal l1 l2) @@ -273,11 +273,11 @@ let projection_nparams p = projection_nparams_env (Global.env ()) p let make_case_info env ind style = let (mib,mip) = Inductive.lookup_mind_specif env ind in let ind_tags = - rel_context_tags (List.firstn mip.mind_nrealdecls mip.mind_arity_ctxt) in + Context.Rel.to_tags (List.firstn mip.mind_nrealdecls mip.mind_arity_ctxt) in let cstr_tags = Array.map2 (fun c n -> let d,_ = decompose_prod_assum c in - rel_context_tags (List.firstn n d)) + Context.Rel.to_tags (List.firstn n d)) mip.mind_nf_lc mip.mind_consnrealdecls in let print_info = { ind_tags; cstr_tags; style } in { ci_ind = ind; @@ -292,7 +292,7 @@ type constructor_summary = { cs_cstr : pconstructor; cs_params : constr list; cs_nargs : int; - cs_args : rel_context; + cs_args : Context.Rel.t; cs_concl_realargs : constr array } @@ -303,21 +303,15 @@ let lift_constructor n cs = { cs_args = lift_rel_context n cs.cs_args; cs_concl_realargs = Array.map (liftn n (cs.cs_nargs+1)) cs.cs_concl_realargs } -(* Accept less parameters than in the signature *) - -let instantiate_params t args sign = - let rec inst s t = function - | ((_,None,_)::ctxt,a::args) -> - (match kind_of_term t with - | Prod(_,_,t) -> inst (a::s) t (ctxt,args) - | _ -> anomaly ~label:"instantiate_params" (Pp.str "type, ctxt and args mismatch")) - | ((_,(Some b),_)::ctxt,args) -> - (match kind_of_term t with - | LetIn(_,_,_,t) -> inst ((substl s b)::s) t (ctxt,args) - | _ -> anomaly ~label:"instantiate_params" (Pp.str "type, ctxt and args mismatch")) - | _, [] -> substl s t - | _ -> anomaly ~label:"instantiate_params" (Pp.str "type, ctxt and args mismatch") - in inst [] t (List.rev sign,args) + +(* Accept either all parameters or only recursively uniform ones *) +let instantiate_params t params sign = + let nnonrecpar = Context.Rel.nhyps sign - List.length params in + (* Adjust the signature if recursively non-uniform parameters are not here *) + let _,sign = context_chop nnonrecpar sign in + let _,t = decompose_prod_n_assum (Context.Rel.length sign) t in + let subst = subst_of_rel_context_instance sign params in + substl subst t let get_constructor ((ind,u as indu),mib,mip,params) j = assert (j <= Array.length mip.mind_consnames); @@ -329,7 +323,7 @@ let get_constructor ((ind,u as indu),mib,mip,params) j = let vargs = List.skipn (List.length params) allargs in { cs_cstr = (ith_constructor_of_inductive ind j,u); cs_params = params; - cs_nargs = rel_context_length args; + cs_nargs = Context.Rel.length args; cs_args = args; cs_concl_realargs = Array.of_list vargs } @@ -354,14 +348,6 @@ let substnl_rel_context subst n sign = let substl_rel_context subst = substnl_rel_context subst 0 -let instantiate_context sign args = - let rec aux subst = function - | (_,None,_)::sign, a::args -> aux (a::subst) (sign,args) - | (_,Some b,_)::sign, args -> aux (substl subst b::subst) (sign,args) - | [], [] -> subst - | _ -> anomaly (Pp.str "Signature/instance mismatch in inductive family") - in aux [] (List.rev sign,args) - let get_arity env ((ind,u),params) = let (mib,mip) = Inductive.lookup_mind_specif env ind in let parsign = @@ -379,7 +365,7 @@ let get_arity env ((ind,u),params) = let parsign = Vars.subst_instance_context u parsign in let arproperlength = List.length mip.mind_arity_ctxt - List.length parsign in let arsign,_ = List.chop arproperlength mip.mind_arity_ctxt in - let subst = instantiate_context parsign params in + let subst = subst_of_rel_context_instance parsign params in let arsign = Vars.subst_instance_context u arsign in (substl_rel_context subst arsign, Inductive.inductive_sort_family mip) @@ -388,14 +374,14 @@ let build_dependent_constructor cs = applist (mkConstructU cs.cs_cstr, (List.map (lift cs.cs_nargs) cs.cs_params) - @(extended_rel_list 0 cs.cs_args)) + @(Context.Rel.to_extended_list 0 cs.cs_args)) let build_dependent_inductive env ((ind, params) as indf) = let arsign,_ = get_arity env indf in let nrealargs = List.length arsign in applist (mkIndU ind, - (List.map (lift nrealargs) params)@(extended_rel_list 0 arsign)) + (List.map (lift nrealargs) params)@(Context.Rel.to_extended_list 0 arsign)) (* builds the arity of an elimination predicate in sort [s] *) @@ -404,7 +390,7 @@ let make_arity_signature env dep indf = if dep then (* We need names everywhere *) Namegen.name_context env - ((Anonymous,None,build_dependent_inductive env indf)::arsign) + ((LocalAssum (Anonymous,build_dependent_inductive env indf))::arsign) (* Costly: would be better to name once for all at definition time *) else (* No need to enforce names *) @@ -430,12 +416,15 @@ let extract_mrectype t = | Ind ind -> (ind, l) | _ -> raise Not_found -let find_mrectype env sigma c = - let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in +let find_mrectype_vect env sigma c = + let (t, l) = decompose_appvect (whd_betadeltaiota env sigma c) in match kind_of_term t with | Ind ind -> (ind, l) | _ -> raise Not_found +let find_mrectype env sigma c = + let (ind, v) = find_mrectype_vect env sigma c in (ind, Array.to_list v) + let find_rectype env sigma c = let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in match kind_of_term t with @@ -471,7 +460,7 @@ let is_predicate_explicitly_dep env pred arsign = let rec srec env pval arsign = let pv' = whd_betadeltaiota env Evd.empty pval in match kind_of_term pv', arsign with - | Lambda (na,t,b), (_,None,_)::arsign -> + | Lambda (na,t,b), (LocalAssum _)::arsign -> srec (push_rel_assum (na,t) env) b arsign | Lambda (na,_,t), _ -> @@ -517,7 +506,7 @@ let set_pattern_names env ind brv = let arities = Array.map (fun c -> - rel_context_length ((prod_assum c)) - + Context.Rel.length ((prod_assum c)) - mib.mind_nparams) mip.mind_nf_lc in Array.map2 (set_names env) arities brv @@ -529,7 +518,7 @@ let type_case_branches_with_names env indspec p c = let (params,realargs) = List.chop nparams args in let lbrty = Inductive.build_branches_type ind specif params p in (* Build case type *) - let conclty = Reduction.betazeta_appvect (mip.mind_nrealdecls+1) p (Array.of_list (realargs@[c])) in + let conclty = lambda_appvect_assum (mip.mind_nrealdecls+1) p (Array.of_list (realargs@[c])) in (* Adjust names *) if is_elim_predicate_explicitly_dependent env p (ind,params) then (set_pattern_names env (fst ind) lbrty, conclty) @@ -551,11 +540,11 @@ let arity_of_case_predicate env (ind,params) dep k = that appear in the type of the inductive by the sort of the conclusion, and the other ones by fresh universes. *) let rec instantiate_universes env evdref scl is = function - | (_,Some _,_ as d)::sign, exp -> + | (LocalDef _ as d)::sign, exp -> d :: instantiate_universes env evdref scl is (sign, exp) | d::sign, None::exp -> d :: instantiate_universes env evdref scl is (sign, exp) - | (na,None,ty)::sign, Some l::exp -> + | (LocalAssum (na,ty))::sign, Some l::exp -> let ctx,_ = Reduction.dest_arity env ty in let u = Univ.Universe.make l in let s = @@ -569,7 +558,7 @@ let rec instantiate_universes env evdref scl is = function let evm = Evd.set_leq_sort env evm s (Sorts.sort_of_univ u) in evdref := evm; s in - (na,None,mkArity(ctx,s)):: instantiate_universes env evdref scl is (sign, exp) + (LocalAssum (na,mkArity(ctx,s))) :: instantiate_universes env evdref scl is (sign, exp) | sign, [] -> sign (* Uniform parameters are exhausted *) | [], _ -> assert false diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index 757599a3c..d25f8a837 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,7 +8,6 @@ open Names open Term -open Context open Declarations open Environ open Evd @@ -92,12 +91,12 @@ val inductive_nparamdecls : inductive -> int val inductive_nparamdecls_env : env -> inductive -> int (** @return params context *) -val inductive_paramdecls : pinductive -> rel_context -val inductive_paramdecls_env : env -> pinductive -> rel_context +val inductive_paramdecls : pinductive -> Context.Rel.t +val inductive_paramdecls_env : env -> pinductive -> Context.Rel.t (** @return full arity context, hence with letin *) -val inductive_alldecls : pinductive -> rel_context -val inductive_alldecls_env : env -> pinductive -> rel_context +val inductive_alldecls : pinductive -> Context.Rel.t +val inductive_alldecls_env : env -> pinductive -> Context.Rel.t (** {7 Extract information from a constructor name} *) @@ -133,9 +132,9 @@ val type_of_projection_knowing_arg : env -> evar_map -> Projection.t -> type constructor_summary = { cs_cstr : pconstructor; (* internal name of the constructor plus universes *) - cs_params : constr list; (* parameters of the constructor in current ctx *) - cs_nargs : int; (* length of arguments signature (letin included) *) - cs_args : rel_context; (* signature of the arguments (letin included) *) + cs_params : constr list; (* parameters of the constructor in current ctx *) + cs_nargs : int; (* length of arguments signature (letin included) *) + cs_args : Context.Rel.t; (* signature of the arguments (letin included) *) cs_concl_realargs : constr array; (* actual realargs in the concl of cstr *) } val lift_constructor : int -> constructor_summary -> constructor_summary @@ -148,17 +147,18 @@ val get_projections : env -> inductive_family -> constant array option (** [get_arity] returns the arity of the inductive family instantiated with the parameters; if recursively non-uniform parameters are not part of the inductive family, they appears in the arity *) -val get_arity : env -> inductive_family -> rel_context * sorts_family +val get_arity : env -> inductive_family -> Context.Rel.t * sorts_family val build_dependent_constructor : constructor_summary -> constr val build_dependent_inductive : env -> inductive_family -> constr -val make_arity_signature : env -> bool -> inductive_family -> rel_context +val make_arity_signature : env -> bool -> inductive_family -> Context.Rel.t val make_arity : env -> bool -> inductive_family -> sorts -> types val build_branch_type : env -> bool -> constr -> constructor_summary -> types (** Raise [Not_found] if not given a valid inductive type *) val extract_mrectype : constr -> pinductive * constr list val find_mrectype : env -> evar_map -> types -> pinductive * constr list +val find_mrectype_vect : env -> evar_map -> types -> pinductive * constr array val find_rectype : env -> evar_map -> types -> inductive_type val find_inductive : env -> evar_map -> types -> pinductive * constr list val find_coinductive : env -> evar_map -> types -> pinductive * constr list diff --git a/pretyping/locusops.ml b/pretyping/locusops.ml index 4a5e11f0d..d89aeccd8 100644 --- a/pretyping/locusops.ml +++ b/pretyping/locusops.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/pretyping/locusops.mli b/pretyping/locusops.mli index 79dc37343..c7661239e 100644 --- a/pretyping/locusops.mli +++ b/pretyping/locusops.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/pretyping/miscops.ml b/pretyping/miscops.ml index a0ec1baae..142e430ff 100644 --- a/pretyping/miscops.ml +++ b/pretyping/miscops.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/pretyping/miscops.mli b/pretyping/miscops.mli index 453648d4d..337473a6f 100644 --- a/pretyping/miscops.mli +++ b/pretyping/miscops.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index dafe88d8d..8ddfeaf2f 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -19,6 +19,7 @@ open Util open Nativecode open Nativevalues open Nativelambda +open Context.Rel.Declaration (** This module implements normalization by evaluation to OCaml code *) @@ -53,8 +54,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 @@ -68,13 +69,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) @@ -90,12 +91,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 @@ -121,9 +122,8 @@ let build_case_type dep p realargs c = else mkApp(p, realargs) (* TODO move this function *) -let type_of_rel env n = - let (_,_,ty) = lookup_rel n env in - lift n ty +let type_of_rel env n = + lookup_rel n env |> get_type |> lift n let type_of_prop = mkSort type1_sort @@ -132,8 +132,9 @@ let type_of_sort s = | Prop _ -> type_of_prop | Type u -> mkType (Univ.super u) -let type_of_var env id = - try let (_,_,ty) = lookup_named id env in ty +let type_of_var env id = + let open Context.Named.Declaration in + try lookup_named id env |> get_type with Not_found -> anomaly ~label:"type_of_var" (str "variable " ++ Id.print id ++ str " unbound") @@ -181,7 +182,7 @@ let rec nf_val env v typ = Errors.anomaly (Pp.strbrk "Returned a functional value in a type not recognized as a product type.") in - let env = push_rel (name,None,dom) env in + let env = push_rel (LocalAssum (name,dom)) env in let body = nf_val env (f (mk_rel_accu lvl)) codom in mkLambda(name,dom,body) | Vconst n -> construct_of_constr_const env n typ @@ -257,7 +258,7 @@ and nf_atom env atom = | Aprod(n,dom,codom) -> let dom = nf_type env dom in let vn = mk_rel_accu (nb_rel env) in - let env = push_rel (n,None,dom) env in + let env = push_rel (LocalAssum (n,dom)) env in let codom = nf_type env (codom vn) in mkProd(n,dom,codom) | Ameta (mv,_) -> mkMeta mv @@ -292,7 +293,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 = @@ -328,7 +329,7 @@ and nf_atom_type env atom = | Aprod(n,dom,codom) -> let dom,s1 = nf_type_sort env dom in let vn = mk_rel_accu (nb_rel env) in - let env = push_rel (n,None,dom) env in + let env = push_rel (LocalAssum (n,dom)) env in let codom,s2 = nf_type_sort env (codom vn) in mkProd(n,dom,codom), mkSort (sort_of_product env s1 s2) | Aevar(ev,ty) -> @@ -356,7 +357,7 @@ and nf_predicate env ind mip params v pT = (Pp.strbrk "Returned a functional value in a type not recognized as a product type.") in let dep,body = - nf_predicate (push_rel (name,None,dom) env) ind mip params vb codom in + nf_predicate (push_rel (LocalAssum (name,dom)) env) ind mip params vb codom in dep, mkLambda(name,dom,body) | Vfun f, _ -> let k = nb_rel env in @@ -366,7 +367,7 @@ and nf_predicate env ind mip params v pT = let rargs = Array.init n (fun i -> mkRel (n-i)) in let params = if Int.equal n 0 then params else Array.map (lift n) params in let dom = mkApp(mkIndU ind,Array.append params rargs) in - let body = nf_type (push_rel (name,None,dom) env) vb in + let body = nf_type (push_rel (LocalAssum (name,dom)) env) vb in true, mkLambda(name,dom,body) | _, _ -> false, nf_type env v diff --git a/pretyping/nativenorm.mli b/pretyping/nativenorm.mli index 035203838..0b1ce8e51 100644 --- a/pretyping/nativenorm.mli +++ b/pretyping/nativenorm.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,7 +8,6 @@ open Term open Environ open Evd -open Nativelambda (** This module implements normalization by evaluation to OCaml code *) diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index fb629d049..827071054 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -122,10 +122,8 @@ let head_of_constr_reference c = match kind_of_term c with | _ -> anomaly (Pp.str "Not a rigid reference") let pattern_of_constr env sigma t = - let ctx = ref [] in - let keep = ref Evar.Set.empty in - let remove = ref Evar.Set.empty in let rec pattern_of_constr env t = + let open Context.Rel.Declaration in match kind_of_term t with | Rel n -> PRel n | Meta n -> PMeta (Some (Id.of_string ("META" ^ string_of_int n))) @@ -135,22 +133,17 @@ let pattern_of_constr env sigma t = | Sort (Type _) -> PSort (GType []) | Cast (c,_,_) -> pattern_of_constr env c | LetIn (na,c,t,b) -> PLetIn (na,pattern_of_constr env c, - pattern_of_constr (push_rel (na,Some c,t) env) b) + pattern_of_constr (push_rel (LocalDef (na,c,t)) env) b) | Prod (na,c,b) -> PProd (na,pattern_of_constr env c, - pattern_of_constr (push_rel (na, None, c) env) b) + pattern_of_constr (push_rel (LocalAssum (na, c)) env) b) | Lambda (na,c,b) -> PLambda (na,pattern_of_constr env c, - pattern_of_constr (push_rel (na, None, c) env) b) + pattern_of_constr (push_rel (LocalAssum (na, c)) env) b) | App (f,a) -> (match match kind_of_term f with - | Evar (evk,args as ev) -> + | Evar (evk,args) -> (match snd (Evd.evar_source evk sigma) with - Evar_kinds.MatchingVar (true,id) -> - let ty = Evarutil.nf_evar sigma (existential_type sigma ev) in - ctx := (id,None,ty)::!ctx; - keep := Evar.Set.union (evars_of_term ty) !keep; - remove := Evar.Set.add evk !remove; - Some id + Evar_kinds.MatchingVar (true,id) -> Some id | _ -> None) | _ -> None with @@ -162,13 +155,11 @@ let pattern_of_constr env sigma t = | Proj (p, c) -> pattern_of_constr env (Retyping.expand_projection env sigma p c []) | Evar (evk,ctxt as ev) -> - remove := Evar.Set.add evk !remove; (match snd (Evd.evar_source evk sigma) with | Evar_kinds.MatchingVar (b,id) -> let ty = Evarutil.nf_evar sigma (existential_type sigma ev) in - ctx := (id,None,ty)::!ctx; - let () = ignore (pattern_of_constr env ty) in - assert (not b); PMeta (Some id) + let () = ignore (pattern_of_constr env ty) in + assert (not b); PMeta (Some id) | Evar_kinds.GoalEvar -> PEvar (evk,Array.map (pattern_of_constr env) ctxt) | _ -> @@ -189,12 +180,7 @@ let pattern_of_constr env sigma t = Array.to_list (Array.mapi branch_of_constr br)) | Fix f -> PFix f | CoFix f -> PCoFix f in - let p = pattern_of_constr env t in - let remove = Evar.Set.diff !remove !keep in - let sigma = Evar.Set.fold (fun ev acc -> Evd.remove acc ev) remove sigma in - (* side-effect *) - (* Warning: the order of dependencies in ctx is not ensured *) - (sigma,!ctx,p) + pattern_of_constr env t (* To process patterns, we need a translation without typing at all. *) @@ -234,7 +220,7 @@ let instantiate_pattern env sigma lvar c = ctx in let c = substl inst c in - pi3 (pattern_of_constr env sigma c) + pattern_of_constr env sigma c with Not_found (* List.index failed *) -> let vars = List.map_filter (function Name id -> Some id | _ -> None) vars in @@ -259,7 +245,7 @@ let rec subst_pattern subst pat = | PRef ref -> let ref',t = subst_global subst ref in if ref' == ref then pat else - pi3 (pattern_of_constr (Global.env()) Evd.empty t) + pattern_of_constr (Global.env()) Evd.empty t | PVar _ | PEvar _ | PRel _ -> pat diff --git a/pretyping/patternops.mli b/pretyping/patternops.mli index 9e72280fe..1f63565d6 100644 --- a/pretyping/patternops.mli +++ b/pretyping/patternops.mli @@ -1,12 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Context open Term open Globnames open Glob_term @@ -39,8 +38,7 @@ val head_of_constr_reference : Term.constr -> global_reference a pattern; currently, no destructor (Cases, Fix, Cofix) and no existential variable are allowed in [c] *) -val pattern_of_constr : Environ.env -> Evd.evar_map -> constr -> - Evd.evar_map * named_context * constr_pattern +val pattern_of_constr : Environ.env -> Evd.evar_map -> constr -> constr_pattern (** [pattern_of_glob_constr l c] translates a term [c] with metavariables into a pattern; variables bound in [l] are replaced by the pattern to which they diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml index 030b4a11c..cf5b08c58 100644 --- a/pretyping/pretype_errors.ml +++ b/pretyping/pretype_errors.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli index 8fcfb59b3..f617df9ee 100644 --- a/pretyping/pretype_errors.mli +++ b/pretyping/pretype_errors.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index c2cf1f83d..8baa668c7 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -28,7 +28,6 @@ open Names open Evd open Term open Vars -open Context open Termops open Reductionops open Environ @@ -37,17 +36,20 @@ open Typeops open Globnames open Nameops open Evarutil +open Evardefine open Pretype_errors open Glob_term open Glob_ops open Evarconv open Pattern open Misctypes +open Sigma.Notations +open Context.Named.Declaration type typing_constraint = OfType of types | IsType | WithoutTypeConstraint type var_map = constr_under_binders Id.Map.t type uconstr_var_map = Glob_term.closed_glob_constr Id.Map.t -type unbound_ltac_var_map = Genarg.tlevel Genarg.generic_argument Id.Map.t +type unbound_ltac_var_map = Genarg.Val.t Id.Map.t type ltac_var_map = { ltac_constrs : var_map; ltac_uconstrs : uconstr_var_map; @@ -56,6 +58,8 @@ type ltac_var_map = { } type glob_constr_ltac_closure = ltac_var_map * glob_constr type pure_open_constr = evar_map * constr +type 'a delayed_open = + { delayed : 'r. Environ.env -> 'r Sigma.t -> ('a, 'r) Sigma.sigma } (************************************************************************) (* This concerns Cases *) @@ -95,10 +99,6 @@ let search_guard loc env possible_indexes fixdefs = user_err_loc (loc,"search_guard", Pp.str errmsg) with Found indexes -> indexes) -(* To embed constr in glob_constr *) -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 @@ -118,7 +118,7 @@ let _ = { optsync = true; optdepr = false; optname = "minimization to Set"; - optkey = ["Universe";"set";"Minimization"]; + optkey = ["Universe";"Minimization";"ToSet"]; optread = Universes.is_set_minimization; optwrite = (:=) Universes.set_minimization }) @@ -138,20 +138,20 @@ let interp_universe_level_name evd (loc,s) = in evd, level else try - let id = - try Id.of_string s with _ -> raise Not_found in - evd, Idmap.find id names + let level = Evd.universe_of_name evd s in + evd, level with Not_found -> - try let level = Evd.universe_of_name evd s in - evd, level + try + let id = try Id.of_string s with _ -> raise Not_found in + evd, Idmap.find id names with Not_found -> if not (is_strict_universe_declarations ()) then - new_univ_level_variable ~name:s univ_rigid evd + new_univ_level_variable ~loc ~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 +let interp_universe ?loc evd = function + | [] -> let evd, l = new_univ_level_variable ?loc univ_rigid evd in evd, Univ.Universe.make l | l -> List.fold_left (fun (evd, u) l -> @@ -159,15 +159,15 @@ let interp_universe evd = function (evd', Univ.sup u (Univ.Universe.make l))) (evd, Univ.Universe.type0m) l -let interp_universe_level evd = function - | None -> new_univ_level_variable univ_rigid evd +let interp_universe_level loc evd = function + | None -> new_univ_level_variable ~loc univ_rigid evd | Some (loc,s) -> interp_universe_level_name evd (loc,s) -let interp_sort evd = function +let interp_sort ?loc evd = function | GProp -> evd, Prop Null | GSet -> evd, Prop Pos | GType n -> - let evd, u = interp_universe evd n in + let evd, u = interp_universe ?loc evd n in evd, Type u let interp_elimination_sort = function @@ -183,22 +183,26 @@ type inference_flags = { expand_evars : bool } +let frozen_holes (sigma, sigma') = + let fold evk _ accu = Evar.Set.add evk accu in + Evd.fold_undefined fold sigma Evar.Set.empty + let pending_holes (sigma, sigma') = let fold evk _ accu = if not (Evd.mem sigma evk) then Evar.Set.add evk accu else accu in Evd.fold_undefined fold sigma' Evar.Set.empty -let apply_typeclasses env evdref pending fail_evar = - let filter_pending evk = Evar.Set.mem evk pending in +let apply_typeclasses env evdref frozen fail_evar = + let filter_frozen evk = Evar.Set.mem evk frozen in evdref := Typeclasses.resolve_typeclasses ~filter:(if Flags.is_program_mode () - then (fun evk evi -> Typeclasses.no_goals_or_obligations evk evi && filter_pending evk) - else (fun evk evi -> Typeclasses.no_goals evk evi && filter_pending evk)) + then (fun evk evi -> Typeclasses.no_goals_or_obligations evk evi && not (filter_frozen evk)) + else (fun evk evi -> Typeclasses.no_goals evk evi && not (filter_frozen evk))) ~split:true ~fail:fail_evar env !evdref; if Flags.is_program_mode () then (* Try optionally solving the obligations *) evdref := Typeclasses.resolve_typeclasses - ~filter:(fun evk evi -> Typeclasses.all_evars evk evi && filter_pending evk) ~split:true ~fail:false env !evdref + ~filter:(fun evk evi -> Typeclasses.all_evars evk evi && not (filter_frozen evk)) ~split:true ~fail:false env !evdref let apply_inference_hook hook evdref pending = evdref := Evar.Set.fold (fun evk sigma -> @@ -219,9 +223,9 @@ let apply_heuristics env evdref fail_evar = with e when Errors.noncritical e -> let e = Errors.push e in if fail_evar then iraise e -let check_typeclasses_instances_are_solved env current_sigma pending = +let check_typeclasses_instances_are_solved env current_sigma frozen = (* Naive way, call resolution again with failure flag *) - apply_typeclasses env (ref current_sigma) pending true + apply_typeclasses env (ref current_sigma) frozen true let check_extra_evars_are_solved env current_sigma pending = Evar.Set.iter @@ -233,26 +237,45 @@ let check_extra_evars_are_solved env current_sigma pending = | _ -> error_unsolvable_implicit loc env current_sigma evk None) pending -let check_evars_are_solved env current_sigma pending = - check_typeclasses_instances_are_solved env current_sigma pending; +(* [check_evars] fails if some unresolved evar remains *) + +let check_evars env initial_sigma sigma c = + let rec proc_rec c = + match kind_of_term c with + | Evar (evk,_ as ev) -> + (match existential_opt_value sigma ev with + | Some c -> proc_rec c + | None -> + if not (Evd.mem initial_sigma evk) then + let (loc,k) = evar_source evk sigma in + match k with + | Evar_kinds.ImplicitArg (gr, (i, id), false) -> () + | _ -> Pretype_errors.error_unsolvable_implicit loc env sigma evk None) + | _ -> Constr.iter proc_rec c + in proc_rec c + +let check_evars_are_solved env current_sigma frozen pending = + check_typeclasses_instances_are_solved env current_sigma frozen; check_problems_are_solved env current_sigma; check_extra_evars_are_solved env current_sigma pending (* Try typeclasses, hooks, unification heuristics ... *) let solve_remaining_evars flags env current_sigma pending = + let frozen = frozen_holes pending in let pending = pending_holes pending in let evdref = ref current_sigma in - if flags.use_typeclasses then apply_typeclasses env evdref pending false; + if flags.use_typeclasses then apply_typeclasses env evdref frozen false; if Option.has_some flags.use_hook then apply_inference_hook (Option.get flags.use_hook env) evdref pending; if flags.use_unif_heuristics then apply_heuristics env evdref false; - if flags.fail_evar then check_evars_are_solved env !evdref pending; + if flags.fail_evar then check_evars_are_solved env !evdref frozen pending; !evdref let check_evars_are_solved env current_sigma pending = + let frozen = frozen_holes pending in let pending = pending_holes pending in - check_evars_are_solved env current_sigma pending + check_evars_are_solved env current_sigma frozen pending let process_inference_flags flags env initial_sigma (sigma,c) = let sigma = solve_remaining_evars flags env sigma (initial_sigma, sigma) in @@ -315,10 +338,10 @@ let ltac_interp_name_env k0 lvar env = 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 n = Context.Rel.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 + let ctxt = List.map (Context.Rel.Declaration.map_name (ltac_interp_name lvar)) ctxt in push_rel_context ctxt env let invert_ltac_bound_name lvar env id0 id = @@ -371,8 +394,7 @@ let pretype_id pretype k0 loc env evdref lvar id = str "Variable " ++ pr_id id ++ str " should be bound to a term."); (* Check if [id] is a section or goal variable *) try - let (_,_,typ) = lookup_named id env in - { uj_val = mkVar id; uj_type = typ } + { uj_val = mkVar id; uj_type = (get_type (lookup_named id env)) } with Not_found -> (* [id] not found, standard error message *) error_var_not_found_loc loc id @@ -383,38 +405,41 @@ let evar_kind_of_term sigma c = (*************************************************************************) (* Main pretyping function *) -let interp_universe_level_name evd l = +let interp_universe_level_name loc evd l = match l with | GProp -> evd, Univ.Level.prop | GSet -> evd, Univ.Level.set - | GType s -> interp_universe_level evd s + | GType s -> interp_universe_level loc evd s let pretype_global loc rigid env evd gr us = let evd, instance = match us with | None -> evd, None | Some l -> - let _, ctx = Universes.unsafe_constr_of_global gr in - let arr = Univ.Instance.to_array (Univ.UContext.instance ctx) in - let len = Array.length arr in - if len != List.length l then - user_err_loc (loc, "pretype", - str "Universe instance should have length " ++ int len) - else - let evd, l' = List.fold_left (fun (evd, univs) l -> - let evd, l = interp_universe_level_name evd l in + let _, ctx = Universes.unsafe_constr_of_global gr in + let arr = Univ.Instance.to_array (Univ.UContext.instance ctx) in + let len = Array.length arr in + if len != List.length l then + user_err_loc (loc, "pretype", + str "Universe instance should have length " ++ int len) + else + let evd, l' = List.fold_left (fun (evd, univs) l -> + let evd, l = interp_universe_level_name loc evd l in (evd, l :: univs)) (evd, []) l - in - evd, Some (Univ.Instance.of_array (Array.of_list (List.rev l'))) + in + if List.exists (fun l -> Univ.Level.is_prop l) l' then + user_err_loc (loc, "pretype", + str "Universe instances cannot contain Prop, polymorphic" ++ + str " universe instances must be greater or equal to Set."); + evd, Some (Univ.Instance.of_array (Array.of_list (List.rev l'))) in - Evd.fresh_global ~rigid ?names:instance env evd gr + Evd.fresh_global ~loc ~rigid ?names:instance env evd gr let pretype_ref loc evdref env ref us = match ref with | VarRef id -> (* Section variable *) - (try let (_,_,ty) = lookup_named id env in - make_judge (mkVar id) ty + (try make_judge (mkVar id) (get_type (lookup_named id env)) with Not_found -> (* This may happen if env is a goal env and section variables have been cleared - section variables should be different from goal @@ -426,29 +451,26 @@ let pretype_ref loc evdref env ref us = let ty = Typing.unsafe_type_of env evd c in make_judge c ty -let judge_of_Type evd s = - let evd, s = interp_universe evd s in +let judge_of_Type loc evd s = + let evd, s = interp_universe ~loc evd s in let judge = { uj_val = mkSort (Type s); uj_type = mkSort (Type (Univ.super s)) } in evd, judge -let pretype_sort evdref = function +let pretype_sort loc evdref = function | GProp -> judge_of_prop | GSet -> judge_of_set - | GType s -> evd_comb1 judge_of_Type evdref s + | GType s -> evd_comb1 (judge_of_Type loc) evdref s let new_type_evar env evdref loc = - let e, s = - evd_comb0 (fun evd -> Evarutil.new_type_evar env evd univ_flexible_alg ~src:(loc,Evar_kinds.InternalHole)) evdref - in e - -let get_projection env cst = - let cb = lookup_constant cst env in - match cb.Declarations.const_proj with - | Some {Declarations.proj_ind = mind; proj_npars = n; proj_arg = m; proj_type = ty} -> - (cst,mind,n,m,ty) - | None -> raise Not_found + let sigma = Sigma.Unsafe.of_evar_map !evdref in + let Sigma ((e, _), sigma, _) = + Evarutil.new_type_evar env sigma + univ_flexible_alg ~src:(loc,Evar_kinds.InternalHole) + in + evdref := Sigma.to_evar_map sigma; + e let (f_genarg_interp, genarg_interp_hook) = Hook.make () @@ -456,16 +478,11 @@ let (f_genarg_interp, genarg_interp_hook) = Hook.make () (* in environment [env], with existential variables [evdref] and *) (* the type constraint tycon *) -let is_GHole = function - | GHole _ -> true - | _ -> false - -let evars = ref Id.Map.empty - 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 k0 resolve_tc in let pretype = pretype k0 resolve_tc in + let open Context.Rel.Declaration in match t with | GRef (loc,ref,u) -> inh_conv_coerce_to_tycon loc env evdref @@ -525,16 +542,16 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_ [] -> ctxt | (na,bk,None,ty)::bl -> let ty' = pretype_type empty_valcon env evdref lvar ty in - let dcl = (na,None,ty'.utj_val) in - let dcl' = (ltac_interp_name lvar na,None,ty'.utj_val) in - type_bl (push_rel dcl env) (add_rel_decl dcl' ctxt) bl + let dcl = LocalAssum (na, ty'.utj_val) in + let dcl' = LocalAssum (ltac_interp_name lvar na,ty'.utj_val) in + type_bl (push_rel dcl env) (Context.Rel.add 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 - 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 dcl = LocalDef (na, bd'.uj_val, ty'.utj_val) in + let dcl' = LocalDef (ltac_interp_name lvar na, bd'.uj_val, ty'.utj_val) in + type_bl (push_rel dcl env) (Context.Rel.add dcl' ctxt) bl in + let ctxtv = Array.map (type_bl env Context.Rel.empty) bl in let larj = Array.map2 (fun e ar -> @@ -561,7 +578,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_ (* we lift nbfix times the type in tycon, because of * the nbfix variables pushed to newenv *) let (ctxt,ty) = - decompose_prod_n_assum (rel_context_length ctxt) + decompose_prod_n_assum (Context.Rel.length ctxt) (lift nbfix ftys.(i)) in let nenv = push_rel_context ctxt newenv in let j = pretype (mk_tycon ty) nenv evdref lvar def in @@ -601,7 +618,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_ inh_conv_coerce_to_tycon loc env evdref fixj tycon | GSort (loc,s) -> - let j = pretype_sort evdref s in + let j = pretype_sort loc evdref s in inh_conv_coerce_to_tycon loc env evdref j tycon | GApp (loc,f,args) -> @@ -701,7 +718,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_ (* 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 var = (name,None,j.utj_val) in + let var = LocalAssum (name, 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 @@ -739,11 +756,13 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_ pretype (mk_tycon tj.utj_val) env evdref lvar c | _ -> pretype empty_tycon env evdref lvar c1 in - let t = j.uj_type in + let t = evd_comb1 (Evarsolve.refresh_universes + ~onlyalg:true ~status:Evd.univ_flexible (Some false) env) + evdref j.uj_type in (* 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 var = (name,Some j.uj_val,t) in + let var = LocalDef (name, 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 @@ -768,17 +787,17 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_ int cs.cs_nargs ++ str " variables."); let fsign, record = match get_projections env indf with - | None -> List.map2 (fun na (_,c,t) -> (na,c,t)) - (List.rev nal) cs.cs_args, false + | None -> + List.map2 set_name (List.rev nal) cs.cs_args, false | Some ps -> let rec aux n k names l = match names, l with - | na :: names, ((_, None, t) :: l) -> + | na :: names, (LocalAssum (_,t) :: l) -> let proj = Projection.make ps.(cs.cs_nargs - k) true in - (na, Some (lift (cs.cs_nargs - n) (mkProj (proj, cj.uj_val))), t) + LocalDef (na, lift (cs.cs_nargs - n) (mkProj (proj, cj.uj_val)), t) :: aux (n+1) (k + 1) names l - | na :: names, ((_, c, t) :: l) -> - (na, c, t) :: aux (n+1) k names l + | na :: names, (decl :: l) -> + set_name na decl :: aux (n+1) k names l | [], [] -> [] | _ -> assert false in aux 1 1 (List.rev nal) cs.cs_args, true in @@ -786,7 +805,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_ 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 fsign = List.map2 set_name 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|]) @@ -797,10 +816,10 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_ let arsgn = let arsgn,_ = get_arity env indf in if not !allow_anonymous_refs then - List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn + List.map (set_name Anonymous) arsgn else arsgn in - let psign = (na,None,build_dependent_inductive env indf)::arsgn in + let psign = LocalAssum (na, build_dependent_inductive env indf) :: arsgn in let nar = List.length arsgn in (match po with | Some p -> @@ -856,11 +875,11 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_ let arsgn,_ = get_arity env indf in if not !allow_anonymous_refs then (* Make dependencies from arity signature impossible *) - List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn + List.map (set_name Anonymous) arsgn else arsgn in let nar = List.length arsgn in - let psign = (na,None,build_dependent_inductive env indf)::arsgn in + let psign = LocalAssum (na, build_dependent_inductive env indf) :: arsgn in let pred,p = match po with | Some p -> let env_p = push_rel_context psign env in @@ -880,19 +899,16 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_ let pred = nf_evar !evdref pred in let p = nf_evar !evdref p in let f cs b = - let n = rel_context_length cs.cs_args in + let n = Context.Rel.length cs.cs_args in let pi = lift n pred in (* liftn n 2 pred ? *) let pi = beta_applist (pi, [build_dependent_constructor cs]) in let csgn = if not !allow_anonymous_refs then - List.map (fun (_,b,t) -> (Anonymous,b,t)) cs.cs_args + List.map (set_name Anonymous) cs.cs_args else - List.map - (fun (n, b, t) -> - match n with - Name _ -> (n, b, t) - | Anonymous -> (Name Namegen.default_non_dependent_ident, b, t)) - cs.cs_args + List.map (map_name (function Name _ as n -> n + | Anonymous -> Name Namegen.default_non_dependent_ident)) + cs.cs_args in let env_c = push_rel_context csgn env in let bj = pretype (mk_tycon pi) env_c evdref lvar b in @@ -954,8 +970,9 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_ in inh_conv_coerce_to_tycon loc env evdref cj tycon 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 f decl (subst,update) = + let id = get_id decl in + let t = replace_vars subst (get_type decl) in let c, update = try let c = List.assoc id update in @@ -967,7 +984,7 @@ and pretype_instance k0 resolve_tc env evdref lvar loc hyps evk update = if is_conv env !evdref t t' then mkRel n, update else raise Not_found with Not_found -> try - let (_,_,t') = lookup_named id env in + let t' = lookup_named id env |> get_type in if is_conv env !evdref t t' then mkVar id, update else raise Not_found with Not_found -> user_err_loc (loc,"",str "Cannot interpret " ++ @@ -1013,7 +1030,7 @@ and pretype_type k0 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 k0 = Context.Rel.length (rel_context env) in let c' = match kind with | WithoutTypeConstraint -> (pretype k0 flags.use_typeclasses empty_tycon env evdref lvar c).uj_val @@ -1055,7 +1072,7 @@ let on_judgment f j = let understand_judgment env sigma c = let evdref = ref sigma in - let k0 = rel_context_length (rel_context env) in + let k0 = Context.Rel.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 @@ -1063,7 +1080,7 @@ let understand_judgment env sigma c = in j, Evd.evar_universe_context !evdref let understand_judgment_tcc env evdref c = - let k0 = rel_context_length (rel_context env) in + let k0 = Context.Rel.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 @@ -1092,3 +1109,26 @@ let understand_tcc_evars ?(flags=all_no_fail_flags) env evdref ?(expected_type=W let understand_ltac flags env sigma lvar kind c = ise_pretype_gen flags env sigma lvar kind c + +let constr_flags = { + use_typeclasses = true; + use_unif_heuristics = true; + use_hook = None; + fail_evar = true; + expand_evars = true } + +(* Fully evaluate an untyped constr *) +let type_uconstr ?(flags = constr_flags) + ?(expected_type = WithoutTypeConstraint) ist c = + { delayed = begin fun env sigma -> + let { closure; term } = c in + let vars = { + ltac_constrs = closure.typed; + ltac_uconstrs = closure.untyped; + ltac_idents = closure.idents; + ltac_genargs = ist.Geninterp.lfun; + } in + let sigma = Sigma.to_evar_map sigma in + let (sigma, c) = understand_ltac flags env sigma vars expected_type term in + Sigma.Unsafe.of_pair (c, sigma) + end } diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index a6aa08657..91320f20a 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -29,7 +29,7 @@ type typing_constraint = OfType of types | IsType | WithoutTypeConstraint type var_map = Pattern.constr_under_binders Id.Map.t type uconstr_var_map = Glob_term.closed_glob_constr Id.Map.t -type unbound_ltac_var_map = Genarg.tlevel Genarg.generic_argument Id.Map.t +type unbound_ltac_var_map = Genarg.Val.t Id.Map.t type ltac_var_map = { ltac_constrs : var_map; @@ -55,6 +55,9 @@ type inference_flags = { expand_evars : bool } +type 'a delayed_open = + { delayed : 'r. Environ.env -> 'r Sigma.t -> ('a, 'r) Sigma.sigma } + val default_inference_flags : bool -> inference_flags val no_classes_no_fail_inference_flags : inference_flags @@ -66,9 +69,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 +98,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 +113,18 @@ 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 +val type_uconstr : + ?flags:inference_flags -> + ?expected_type:typing_constraint -> + Geninterp.interp_sign -> Glob_term.closed_glob_constr -> constr delayed_open + (** 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,11 +132,16 @@ 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 +(** [check_evars env initial_sigma extended_sigma c] fails if some + new unresolved evar remains in [c] *) +val check_evars : env -> evar_map -> evar_map -> constr -> unit + (**/**) (** Internal of Pretyping... *) val pretype : @@ -138,12 +160,9 @@ val ise_pretype_gen : (** To embed constr in glob_constr *) -val constr_in : constr -> Dyn.t -val constr_out : Dyn.t -> constr - -val interp_sort : evar_map -> glob_sort -> evar_map * sorts +val interp_sort : ?loc:Loc.t -> evar_map -> glob_sort -> evar_map * sorts val interp_elimination_sort : glob_sort -> sorts_family val genarg_interp_hook : - (types -> env -> evar_map -> Genarg.typed_generic_argument Id.Map.t -> + (types -> env -> evar_map -> unbound_ltac_var_map -> Genarg.glob_generic_argument -> constr * evar_map) Hook.t diff --git a/pretyping/pretyping.mllib b/pretyping/pretyping.mllib index b59589bda..c8b3307d7 100644 --- a/pretyping/pretyping.mllib +++ b/pretyping/pretyping.mllib @@ -1,4 +1,5 @@ Locusops +Pretype_errors Reductionops Inductiveops Vnorm @@ -6,9 +7,8 @@ Arguments_renaming Nativenorm Retyping Cbv -Pretype_errors Find_subterm -Evarutil +Evardefine Evarsolve Recordops Evarconv diff --git a/pretyping/program.ml b/pretyping/program.ml index cac8a6a36..0bd121f6f 100644 --- a/pretyping/program.ml +++ b/pretyping/program.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/pretyping/program.mli b/pretyping/program.mli index 3844f3754..b7ebcbc95 100644 --- a/pretyping/program.mli +++ b/pretyping/program.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index 7fde7b7ac..6499ddd53 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -299,7 +299,7 @@ let check_and_decompose_canonical_structure ref = | Construct ((indsp,1),u) -> indsp | _ -> error_not_structure ref in let s = try lookup_structure indsp with Not_found -> error_not_structure ref in - let ntrue_projs = List.length (List.filter (fun (_, x) -> x) s.s_PROJKIND) in + let ntrue_projs = List.count snd s.s_PROJKIND in if s.s_EXPECTEDPARAM + ntrue_projs > Array.length args then error_not_structure ref; (sp,indsp) diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli index 37d5b4c27..a6a90c751 100644 --- a/pretyping/recordops.mli +++ b/pretyping/recordops.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/pretyping/redops.ml b/pretyping/redops.ml index 92782737e..c188995a8 100644 --- a/pretyping/redops.ml +++ b/pretyping/redops.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/pretyping/redops.mli b/pretyping/redops.mli index 89c68ff32..f6d4d8086 100644 --- a/pretyping/redops.mli +++ b/pretyping/redops.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index bb1bc7d2e..7f4249c5b 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -11,11 +11,11 @@ open Util open Names open Term open Vars -open Context open Termops open Univ open Evd open Environ +open Context.Rel.Declaration exception Elimconst @@ -573,7 +573,7 @@ type state = constr * constr Stack.t type contextual_reduction_function = env -> evar_map -> constr -> constr type reduction_function = contextual_reduction_function type local_reduction_function = evar_map -> constr -> constr -type e_reduction_function = env -> evar_map -> constr -> evar_map * constr +type e_reduction_function = { e_redfun : 'r. env -> 'r Sigma.t -> constr -> (constr, 'r) Sigma.sigma } type contextual_stack_reduction_function = env -> evar_map -> constr -> constr * constr list @@ -594,9 +594,7 @@ let pr_state (tm,sk) = (*** Reduction Functions Operators ***) (*************************************) -let safe_evar_value sigma ev = - try Some (Evd.existential_value sigma ev) - with NotInstantiatedEvar | Not_found -> None +let safe_evar_value = Evarutil.safe_evar_value let safe_meta_value sigma ev = try Some (Evd.meta_value sigma ev) @@ -608,7 +606,7 @@ let strong whdfun env sigma t = strongrec env t let local_strong whdfun sigma = - let rec strongrec t = map_constr strongrec (whdfun sigma t) in + let rec strongrec t = Constr.map strongrec (whdfun sigma t) in strongrec let rec strong_prodspine redfun sigma c = @@ -800,6 +798,7 @@ let equal_stacks (x, l) (y, l') = | Some (lft1,lft2) -> f_equal (x, lft1) (y, lft2) let rec whd_state_gen ?csts tactic_mode flags env sigma = + let open Context.Named.Declaration in let rec whrec cst_l (x, stack as s) = let () = if !debug_RAKAM then let open Pp in @@ -816,11 +815,11 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma = match kind_of_term x with | Rel n when Closure.RedFlags.red_set flags Closure.RedFlags.fDELTA -> (match lookup_rel n env with - | (_,Some body,_) -> whrec Cst_stack.empty (lift n body, stack) + | LocalDef (_,body,_) -> whrec Cst_stack.empty (lift n body, stack) | _ -> fold ()) | Var id when Closure.RedFlags.red_set flags (Closure.RedFlags.fVAR id) -> (match lookup_named id env with - | (_,Some body,_) -> whrec (Cst_stack.add_cst (mkVar id) cst_l) (body, stack) + | LocalDef (_,body,_) -> whrec (Cst_stack.add_cst (mkVar id) cst_l) (body, stack) | _ -> fold ()) | Evar ev -> (match safe_evar_value sigma ev with @@ -923,7 +922,7 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma = | Some _ when Closure.RedFlags.red_set flags Closure.RedFlags.fBETA -> apply_subst whrec [] cst_l x stack | None when Closure.RedFlags.red_set flags Closure.RedFlags.fETA -> - let env' = push_rel (na,None,t) env in + let env' = push_rel (LocalAssum (na,t)) env in let whrec' = whd_state_gen tactic_mode flags env' sigma in (match kind_of_term (Stack.zip ~refold:true (fst (whrec' (c, Stack.empty)))) with | App (f,cl) -> @@ -1182,30 +1181,8 @@ let whd_zeta c = Stack.zip (local_whd_state_gen zeta Evd.empty (c,Stack.empty)) (****************************************************************************) (* Replacing defined evars for error messages *) -let rec whd_evar sigma c = - match kind_of_term c with - | Evar ev -> - let (evk, args) = ev in - let args = Array.map (fun c -> whd_evar sigma c) args in - (match safe_evar_value sigma (evk, args) with - Some c -> whd_evar sigma c - | None -> c) - | Sort (Type u) -> - let u' = Evd.normalize_universe sigma u in - if u' == u then c else mkSort (Sorts.sort_of_univ u') - | Const (c', u) when not (Univ.Instance.is_empty u) -> - let u' = Evd.normalize_universe_instance sigma u in - if u' == u then c else mkConstU (c', u') - | Ind (i, u) when not (Univ.Instance.is_empty u) -> - let u' = Evd.normalize_universe_instance sigma u in - if u' == u then c else mkIndU (i, u') - | Construct (co, u) when not (Univ.Instance.is_empty u) -> - let u' = Evd.normalize_universe_instance sigma u in - if u' == u then c else mkConstructU (co, u') - | _ -> c - -let nf_evar = - local_strong whd_evar +let whd_evar = Evarutil.whd_evar +let nf_evar = Evarutil.nf_evar (* lazy reduction functions. The infos must be created for each term *) (* Note by HH [oct 08] : why would it be the job of clos_norm_flags to add @@ -1251,38 +1228,41 @@ let pb_equal = function | Reduction.CUMUL -> Reduction.CONV | Reduction.CONV -> Reduction.CONV -let test_trans_conversion (f: ?l2r:bool-> ?evars:'a->'b) reds env sigma x y = +let report_anomaly _ = + let e = UserError ("", Pp.str "Conversion test raised an anomaly") in + let e = Errors.push e in + iraise e + +let test_trans_conversion (f: constr Reduction.extended_conversion_function) reds env sigma x y = try let evars ev = safe_evar_value sigma ev in - let _ = f ~evars reds env (Evd.universes sigma) x y in + let _ = f ~reds env ~evars:(evars, Evd.universes sigma) x y in true with Reduction.NotConvertible -> false - | e when is_anomaly e -> error "Conversion test raised an anomaly" + | e when is_anomaly e -> report_anomaly e -let is_trans_conv reds env sigma = test_trans_conversion Reduction.trans_conv_universes reds env sigma -let is_trans_conv_leq reds env sigma = test_trans_conversion Reduction.trans_conv_leq_universes reds env sigma -let is_trans_fconv = function Reduction.CONV -> is_trans_conv | Reduction.CUMUL -> is_trans_conv_leq - -let is_conv = is_trans_conv full_transparent_state -let is_conv_leq = is_trans_conv_leq full_transparent_state -let is_fconv = function | Reduction.CONV -> is_conv | Reduction.CUMUL -> is_conv_leq +let is_conv ?(reds=full_transparent_state) env sigma = test_trans_conversion Reduction.conv reds env sigma +let is_conv_leq ?(reds=full_transparent_state) env sigma = test_trans_conversion Reduction.conv_leq reds env sigma +let is_fconv ?(reds=full_transparent_state) = function + | Reduction.CONV -> is_conv ~reds + | Reduction.CUMUL -> is_conv_leq ~reds let check_conv ?(pb=Reduction.CUMUL) ?(ts=full_transparent_state) env sigma x y = let f = match pb with - | Reduction.CONV -> Reduction.trans_conv_universes - | Reduction.CUMUL -> Reduction.trans_conv_leq_universes + | Reduction.CONV -> Reduction.conv + | Reduction.CUMUL -> Reduction.conv_leq in - try f ~evars:(safe_evar_value sigma) ts env (Evd.universes sigma) x y; true + try f ~reds:ts env ~evars:(safe_evar_value sigma, Evd.universes sigma) x y; true with Reduction.NotConvertible -> false | Univ.UniverseInconsistency _ -> false - | e when is_anomaly e -> error "Conversion test raised an anomaly" + | e when is_anomaly e -> report_anomaly e let sigma_compare_sorts env pb s0 s1 sigma = match pb with | Reduction.CONV -> Evd.set_eq_sort env sigma s0 s1 | Reduction.CUMUL -> Evd.set_leq_sort env sigma s0 s1 -let sigma_compare_instances flex i0 i1 sigma = +let sigma_compare_instances ~flex i0 i1 sigma = try Evd.set_eq_instances ~flex sigma i0 i1 with Evd.UniversesDiffer | Univ.UniverseInconsistency _ -> @@ -1294,18 +1274,21 @@ let sigma_univ_state = let infer_conv_gen conv_fun ?(catch_incon=true) ?(pb=Reduction.CUMUL) ?(ts=full_transparent_state) env sigma x y = - try + try + let fold cstr sigma = + try Some (Evd.add_universe_constraints sigma cstr) + with Univ.UniverseInconsistency _ | Evd.UniversesDiffer -> None + in let b, sigma = - let b, cstrs = + let ans = if pb == Reduction.CUMUL then - Universes.leq_constr_univs_infer (Evd.universes sigma) x y + Universes.leq_constr_univs_infer (Evd.universes sigma) fold x y sigma else - Universes.eq_constr_univs_infer (Evd.universes sigma) x y + Universes.eq_constr_univs_infer (Evd.universes sigma) fold x y sigma in - if b then - try true, Evd.add_universe_constraints sigma cstrs - with Univ.UniverseInconsistency _ | Evd.UniversesDiffer -> false, sigma - else false, sigma + match ans with + | None -> false, sigma + | Some sigma -> true, sigma in if b then sigma, true else @@ -1316,7 +1299,7 @@ let infer_conv_gen conv_fun ?(catch_incon=true) ?(pb=Reduction.CUMUL) with | Reduction.NotConvertible -> sigma, false | Univ.UniverseInconsistency _ when catch_incon -> sigma, false - | e when is_anomaly e -> error "Conversion test raised an anomaly" + | e when is_anomaly e -> report_anomaly e let infer_conv = infer_conv_gen (fun pb ~l2r sigma -> Reduction.generic_conv pb ~l2r (safe_evar_value sigma)) @@ -1437,7 +1420,7 @@ let splay_prod env sigma = let t = whd_betadeltaiota env sigma c in match kind_of_term t with | Prod (n,a,c0) -> - decrec (push_rel (n,None,a) env) + decrec (push_rel (LocalAssum (n,a)) env) ((n,a)::m) c0 | _ -> m,t in @@ -1448,7 +1431,7 @@ let splay_lam env sigma = let t = whd_betadeltaiota env sigma c in match kind_of_term t with | Lambda (n,a,c0) -> - decrec (push_rel (n,None,a) env) + decrec (push_rel (LocalAssum (n,a)) env) ((n,a)::m) c0 | _ -> m,t in @@ -1459,18 +1442,18 @@ let splay_prod_assum env sigma = let t = whd_betadeltaiota_nolet env sigma c in match kind_of_term t with | Prod (x,t,c) -> - prodec_rec (push_rel (x,None,t) env) - (add_rel_decl (x, None, t) l) c + prodec_rec (push_rel (LocalAssum (x,t)) env) + (Context.Rel.add (LocalAssum (x,t)) l) c | LetIn (x,b,t,c) -> - prodec_rec (push_rel (x, Some b, t) env) - (add_rel_decl (x, Some b, t) l) c + prodec_rec (push_rel (LocalDef (x,b,t)) env) + (Context.Rel.add (LocalDef (x,b,t)) l) c | Cast (c,_,_) -> prodec_rec env l c | _ -> let t' = whd_betadeltaiota env sigma t in if Term.eq_constr t t' then l,t else prodec_rec env l t' in - prodec_rec env empty_rel_context + prodec_rec env Context.Rel.empty let splay_arity env sigma c = let l, c = splay_prod env sigma c in @@ -1484,21 +1467,21 @@ let splay_prod_n env sigma n = let rec decrec env m ln c = if Int.equal m 0 then (ln,c) else match kind_of_term (whd_betadeltaiota env sigma c) with | Prod (n,a,c0) -> - decrec (push_rel (n,None,a) env) - (m-1) (add_rel_decl (n,None,a) ln) c0 + decrec (push_rel (LocalAssum (n,a)) env) + (m-1) (Context.Rel.add (LocalAssum (n,a)) ln) c0 | _ -> invalid_arg "splay_prod_n" in - decrec env n empty_rel_context + decrec env n Context.Rel.empty let splay_lam_n env sigma n = let rec decrec env m ln c = if Int.equal m 0 then (ln,c) else match kind_of_term (whd_betadeltaiota env sigma c) with | Lambda (n,a,c0) -> - decrec (push_rel (n,None,a) env) - (m-1) (add_rel_decl (n,None,a) ln) c0 + decrec (push_rel (LocalAssum (n,a)) env) + (m-1) (Context.Rel.add (LocalAssum (n,a)) ln) c0 | _ -> invalid_arg "splay_lam_n" in - decrec env n empty_rel_context + decrec env n Context.Rel.empty let is_sort env sigma t = match kind_of_term (whd_betadeltaiota env sigma t) with @@ -1533,8 +1516,8 @@ let find_conclusion env sigma = let rec decrec env c = let t = whd_betadeltaiota env sigma c in match kind_of_term t with - | Prod (x,t,c0) -> decrec (push_rel (x,None,t) env) c0 - | Lambda (x,t,c0) -> decrec (push_rel (x,None,t) env) c0 + | Prod (x,t,c0) -> decrec (push_rel (LocalAssum (x,t)) env) c0 + | Lambda (x,t,c0) -> decrec (push_rel (LocalAssum (x,t)) env) c0 | t -> t in decrec env @@ -1618,7 +1601,7 @@ let meta_reducible_instance evd b = with | Some g -> irec (mkProj (p,g)) | None -> mkProj (p,c)) - | _ -> map_constr irec u + | _ -> Constr.map irec u in if Metaset.is_empty fm then (* nf_betaiota? *) b.rebus else irec b.rebus @@ -1646,7 +1629,7 @@ let betazetaevar_applist sigma n c l = if Int.equal n 0 then applist (substl env t, stack) else match kind_of_term t, stack with | Lambda(_,_,c), arg::stacktl -> stacklam (n-1) (arg::env) c stacktl - | LetIn(_,b,_,c), _ -> stacklam (n-1) (b::env) c stack + | LetIn(_,b,_,c), _ -> stacklam (n-1) (substl env b::env) c stack | Evar ev, _ -> (match safe_evar_value sigma ev with | Some body -> stacklam n env body stack diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index d5a844847..b38252e97 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,7 +8,6 @@ open Names open Term -open Context open Univ open Evd open Environ @@ -109,7 +108,7 @@ type contextual_reduction_function = env -> evar_map -> constr -> constr type reduction_function = contextual_reduction_function type local_reduction_function = evar_map -> constr -> constr -type e_reduction_function = env -> evar_map -> constr -> evar_map * constr +type e_reduction_function = { e_redfun : 'r. env -> 'r Sigma.t -> constr -> (constr, 'r) Sigma.sigma } type contextual_stack_reduction_function = env -> evar_map -> constr -> constr * constr list @@ -218,11 +217,10 @@ val splay_prod : env -> evar_map -> constr -> (Name.t * constr) list * constr val splay_lam : env -> evar_map -> constr -> (Name.t * constr) list * constr val splay_arity : env -> evar_map -> constr -> (Name.t * constr) list * sorts val sort_of_arity : env -> evar_map -> constr -> sorts -val splay_prod_n : env -> evar_map -> int -> constr -> rel_context * constr -val splay_lam_n : env -> evar_map -> int -> constr -> rel_context * constr +val splay_prod_n : env -> evar_map -> int -> constr -> Context.Rel.t * constr +val splay_lam_n : env -> evar_map -> int -> constr -> Context.Rel.t * constr val splay_prod_assum : - env -> evar_map -> constr -> rel_context * constr -val is_sort : env -> evar_map -> types -> bool + env -> evar_map -> constr -> Context.Rel.t * constr type 'a miota_args = { mP : constr; (** the result type *) @@ -251,13 +249,9 @@ type conversion_test = constraints -> constraints val pb_is_equal : conv_pb -> bool val pb_equal : conv_pb -> conv_pb -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 - -val is_trans_conv : transparent_state -> env -> evar_map -> constr -> constr -> bool -val is_trans_conv_leq : transparent_state -> env -> evar_map -> constr -> constr -> bool -val is_trans_fconv : conv_pb -> transparent_state -> env -> evar_map -> constr -> constr -> bool +val is_conv : ?reds:transparent_state -> env -> evar_map -> constr -> constr -> bool +val is_conv_leq : ?reds:transparent_state -> env -> evar_map -> constr -> constr -> bool +val is_fconv : ?reds:transparent_state -> conv_pb -> env -> evar_map -> constr -> constr -> bool (** [check_conv] Checks universe constraints only. pb defaults to CUMUL and ts to a full transparent state. diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index fb5526552..1a6f7832a 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -18,6 +18,7 @@ open Reductionops open Environ open Termops open Arguments_renaming +open Context.Rel.Declaration type retype_error = | NotASort @@ -71,13 +72,14 @@ let rec subst_type env sigma typ = function let sort_of_atomic_type env sigma ft args = let rec concl_of_arity env n ar args = match kind_of_term (whd_betadeltaiota env sigma ar), args with - | Prod (na, t, b), h::l -> concl_of_arity (push_rel (na,Some (lift n h),t) env) (n + 1) b l + | Prod (na, t, b), h::l -> concl_of_arity (push_rel (LocalDef (na, lift n h, t)) env) (n + 1) b l | Sort s, [] -> s | _ -> retype_error NotASort in concl_of_arity env 0 ft (Array.to_list args) let type_of_var env id = - try let (_,_,ty) = lookup_named id env in ty + let open Context.Named.Declaration in + try get_type (lookup_named id env) with Not_found -> retype_error (BadVariable id) let decomp_sort env sigma t = @@ -86,13 +88,13 @@ let decomp_sort env sigma t = | _ -> retype_error NotASort let retype ?(polyprop=true) sigma = - let rec type_of env cstr= + let rec type_of env cstr = match kind_of_term cstr with | Meta n -> (try strip_outer_cast (Evd.meta_ftype sigma n).Evd.rebus with Not_found -> retype_error (BadMeta n)) | Rel n -> - let (_,_,ty) = lookup_rel n env in + let ty = get_type (lookup_rel n env) in lift n ty | Var id -> type_of_var env id | Const cst -> rename_type_of_constant env cst @@ -115,9 +117,9 @@ let retype ?(polyprop=true) sigma = | Prod _ -> whd_beta sigma (applist (t, [c])) | _ -> t) | Lambda (name,c1,c2) -> - mkProd (name, c1, type_of (push_rel (name,None,c1) env) c2) + mkProd (name, c1, type_of (push_rel (LocalAssum (name,c1)) env) c2) | LetIn (name,b,c1,c2) -> - subst1 b (type_of (push_rel (name,Some b,c1) env) c2) + subst1 b (type_of (push_rel (LocalDef (name,b,c1)) env) c2) | Fix ((_,i),(_,tys,_)) -> tys.(i) | CoFix (i,(_,tys,_)) -> tys.(i) | App(f,args) when is_template_polymorphic env f -> @@ -140,7 +142,7 @@ let retype ?(polyprop=true) sigma = | Sort (Prop c) -> type1_sort | Sort (Type u) -> Type (Univ.super u) | Prod (name,t,c2) -> - (match (sort_of env t, sort_of (push_rel (name,None,t) env) c2) with + (match (sort_of env t, sort_of (push_rel (LocalAssum (name,t)) env) c2) with | _, (Prop Null as s) -> s | Prop _, (Prop Pos as s) -> s | Type _, (Prop Pos as s) when is_impredicative_set env -> s @@ -161,7 +163,7 @@ let retype ?(polyprop=true) sigma = | Sort (Prop c) -> InType | Sort (Type u) -> InType | Prod (name,t,c2) -> - let s2 = sort_family_of (push_rel (name,None,t) env) c2 in + let s2 = sort_family_of (push_rel (LocalAssum (name,t)) env) c2 in if not (is_impredicative_set env) && s2 == InSet && sort_family_of env t == InType then InType else s2 | App(f,args) when is_template_polymorphic env f -> @@ -235,9 +237,9 @@ let get_judgment_of env evc c = { uj_val = c; uj_type = get_type_of env evc c } let sorts_of_context env evc ctxt = let rec aux = function | [] -> env,[] - | (_,_,t as d)::ctxt -> + | d :: ctxt -> let env,sorts = aux ctxt in - let s = get_sort_of env evc t in + let s = get_sort_of env evc (get_type d) in (push_rel d env,s::sorts) in snd (aux ctxt) diff --git a/pretyping/retyping.mli b/pretyping/retyping.mli index 89ba46dbc..e4cca2679 100644 --- a/pretyping/retyping.mli +++ b/pretyping/retyping.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,7 +8,6 @@ open Term open Evd -open Context open Environ (** This family of functions assumes its constr argument is known to be @@ -44,6 +43,6 @@ val type_of_global_reference_knowing_parameters : env -> evar_map -> constr -> val type_of_global_reference_knowing_conclusion : env -> evar_map -> constr -> types -> evar_map * types -val sorts_of_context : env -> evar_map -> rel_context -> sorts list +val sorts_of_context : env -> evar_map -> Context.Rel.t -> sorts list val expand_projection : env -> evar_map -> Names.projection -> constr -> constr list -> constr diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 48911a5a9..7d2504004 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -23,6 +23,7 @@ open Reductionops open Cbv open Patternops open Locus +open Sigma.Notations (* Errors *) @@ -53,12 +54,13 @@ let is_evaluable env = function | EvalVarRef id -> is_evaluable_var env id let value_of_evaluable_ref env evref u = + let open Context.Named.Declaration in match evref with | EvalConstRef con -> (try constant_value_in env (con,u) with NotEvaluableConst IsProj -> raise (Invalid_argument "value_of_evaluable_ref")) - | EvalVarRef id -> Option.get (pi2 (lookup_named id env)) + | EvalVarRef id -> lookup_named id env |> get_value |> Option.get let evaluable_of_global_reference env = function | ConstRef cst when is_evaluable_const env cst -> EvalConstRef cst @@ -103,29 +105,29 @@ let destEvalRefU c = match kind_of_term c with | Evar ev -> (EvalEvar ev, Univ.Instance.empty) | _ -> anomaly (Pp.str "Not an unfoldable reference") -let unsafe_reference_opt_value env sigma eval = +let unsafe_reference_opt_value env sigma eval = match eval with | EvalConst cst -> (match (lookup_constant cst env).Declarations.const_body with | Declarations.Def c -> Some (Mod_subst.force_constr c) | _ -> None) | EvalVar id -> - let (_,v,_) = lookup_named id env in - v + let open Context.Named.Declaration in + lookup_named id env |> get_value | EvalRel n -> - let (_,v,_) = lookup_rel n env in - Option.map (lift n) v + let open Context.Rel.Declaration in + lookup_rel n env |> map_value (lift n) |> get_value | EvalEvar ev -> Evd.existential_opt_value sigma ev let reference_opt_value env sigma eval u = match eval with | EvalConst cst -> constant_opt_value_in env (cst,u) | EvalVar id -> - let (_,v,_) = lookup_named id env in - v + let open Context.Named.Declaration in + lookup_named id env |> get_value | EvalRel n -> - let (_,v,_) = lookup_rel n env in - Option.map (lift n) v + let open Context.Rel.Declaration in + lookup_rel n env |> map_value (lift n) |> get_value | EvalEvar ev -> Evd.existential_opt_value sigma ev exception NotEvaluable @@ -258,7 +260,8 @@ let compute_consteval_direct env sigma ref = let c',l = whd_betadelta_stack env sigma c in match kind_of_term c' with | Lambda (id,t,g) when List.is_empty l && not onlyproj -> - srec (push_rel (id,None,t) env) (n+1) (t::labs) onlyproj g + let open Context.Rel.Declaration in + srec (push_rel (LocalAssum (id,t)) env) (n+1) (t::labs) onlyproj g | Fix fix when not onlyproj -> (try check_fix_reversibility labs l fix with Elimconst -> NotAnElimination) @@ -277,7 +280,8 @@ let compute_consteval_mutual_fix env sigma ref = let nargs = List.length l in match kind_of_term c' with | Lambda (na,t,g) when List.is_empty l -> - srec (push_rel (na,None,t) env) (minarg+1) (t::labs) ref g + let open Context.Rel.Declaration in + srec (push_rel (LocalAssum (na,t)) env) (minarg+1) (t::labs) ref g | Fix ((lv,i),(names,_,_)) -> (* Last known constant wrapping Fix is ref = [labs](Fix l) *) (match compute_consteval_direct env sigma ref with @@ -371,7 +375,8 @@ let make_elim_fun (names,(nbfix,lv,n)) u largs = let dummy = mkProp let vfx = Id.of_string "_expanded_fix_" let vfun = Id.of_string "_eliminator_function_" -let venv = val_of_named_context [(vfx, None, dummy); (vfun, None, dummy)] +let venv = let open Context.Named.Declaration in + val_of_named_context [LocalAssum (vfx, dummy); LocalAssum (vfun, dummy)] (* Mark every occurrence of substituted vars (associated to a function) as a problem variable: an evar that can be instantiated either by @@ -385,7 +390,9 @@ let substl_with_function subst sigma constr = if i <= k + Array.length v then match v.(i-k-1) with | (fx, Some (min, ref)) -> - let (sigma, evk) = Evarutil.new_pure_evar venv !evd dummy in + let sigma = Sigma.Unsafe.of_evar_map !evd in + let Sigma (evk, sigma, _) = Evarutil.new_pure_evar venv sigma dummy in + let sigma = Sigma.to_evar_map sigma in evd := sigma; minargs := Evar.Map.add evk min !minargs; lift k (mkEvar (evk, [|fx;ref|])) @@ -534,9 +541,11 @@ let match_eval_ref_value env sigma constr = | Const (sp, u) when is_evaluable env (EvalConstRef sp) -> Some (constant_value_in env (sp, u)) | Var id when is_evaluable env (EvalVarRef id) -> - let (_,v,_) = lookup_named id env in v - | Rel n -> let (_,v,_) = lookup_rel n env in - Option.map (lift n) v + let open Context.Named.Declaration in + lookup_named id env |> get_value + | Rel n -> + let open Context.Rel.Declaration in + lookup_rel n env |> map_value (lift n) |> get_value | Evar ev -> Evd.existential_opt_value sigma ev | _ -> None @@ -601,12 +610,14 @@ let whd_nothing_for_iota env sigma s = let rec whrec (x, stack as s) = match kind_of_term x with | Rel n -> + let open Context.Rel.Declaration in (match lookup_rel n env with - | (_,Some body,_) -> whrec (lift n body, stack) + | LocalDef (_,body,_) -> whrec (lift n body, stack) | _ -> s) | Var id -> + let open Context.Named.Declaration in (match lookup_named id env with - | (_,Some body,_) -> whrec (body, stack) + | LocalDef (_,body,_) -> whrec (body, stack) | _ -> s) | Evar ev -> (try whrec (Evd.existential_value sigma ev, stack) @@ -809,7 +820,9 @@ let try_red_product env sigma c = simpfun (Stack.zip (f,stack'))) | _ -> simpfun (appvect (redrec env f, l))) | Cast (c,_,_) -> redrec env c - | Prod (x,a,b) -> mkProd (x, a, redrec (push_rel (x,None,a) env) b) + | Prod (x,a,b) -> + let open Context.Rel.Declaration in + mkProd (x, a, redrec (push_rel (LocalAssum (x,a)) env) b) | LetIn (x,a,b,t) -> redrec env (subst1 a t) | Case (ci,p,d,lf) -> simpfun (mkCase (ci,p,redrec env d,lf)) | Proj (p, c) -> @@ -940,8 +953,6 @@ let matches_head env sigma c t = | Proj (p, _) -> Constr_matching.matches env sigma c (mkConst (Projection.constant p)) | _ -> raise Constr_matching.PatternMatchingFailure -let is_pattern_meta = function Pattern.PMeta _ -> true | _ -> false - (** FIXME: Specific function to handle projections: it ignores what happens on the parameters. This is a temporary fix while rewrite etc... are not up to equivalence of the projection and its eta expanded form. @@ -962,10 +973,12 @@ let change_map_constr_with_binders_left_to_right g f (env, l as acc) sigma c = | _ -> mkApp (app', [| a' |])) | _ -> map_constr_with_binders_left_to_right g f acc c -let e_contextually byhead (occs,c) f env sigma t = +let e_contextually byhead (occs,c) f = { e_redfun = begin fun env sigma t -> let (nowhere_except_in,locs) = Locusops.convert_occs occs in let maxocc = List.fold_right max locs 0 in let pos = ref 1 in + let sigma = Sigma.to_evar_map sigma in + (** FIXME: we do suspicious things with this evarmap *) let evd = ref sigma in let rec traverse nested (env,c as envc) t = if nowhere_except_in && (!pos > maxocc) then (* Shortcut *) t @@ -984,8 +997,8 @@ let e_contextually byhead (occs,c) f env sigma t = (* Skip inner occurrences for stable counting of occurrences *) if locs != [] then ignore (traverse_below (Some (!pos-1)) envc t); - let evm, t = f subst env !evd t in - (evd := evm; t) + let Sigma (t, evm, _) = (f subst).e_redfun env (Sigma.Unsafe.of_evar_map !evd) t in + (evd := Sigma.to_evar_map evm; t) end else traverse_below nested envc t @@ -1004,11 +1017,15 @@ let e_contextually byhead (occs,c) f env sigma t = in let t' = traverse None (env,c) t in if List.exists (fun o -> o >= !pos) locs then error_invalid_occurrence locs; - !evd, t' + Sigma.Unsafe.of_pair (t', !evd) + end } let contextually byhead occs f env sigma t = - let f' subst env sigma t = sigma, f subst env sigma t in - snd (e_contextually byhead occs f' env sigma t) + let f' subst = { e_redfun = begin fun env sigma t -> + Sigma.here (f subst env (Sigma.to_evar_map sigma) t) sigma + end } in + let Sigma (c, _, _) = (e_contextually byhead occs f').e_redfun env (Sigma.Unsafe.of_evar_map sigma) t in + c (* linear bindings (following pretty-printer) of the value of name in c. * n is the number of the next occurrence of name. @@ -1055,10 +1072,6 @@ let unfold env sigma name = else error (string_of_evaluable_ref env name^" is opaque.") -let is_projection env = function - | EvalVarRef _ -> false - | EvalConstRef c -> Environ.is_projection c env - (* [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 occurrences. @@ -1131,13 +1144,15 @@ let abstract_scheme env (locc,a) (c, sigma) = let c', sigma' = subst_closed_term_occ env sigma (AtOccs locc) a c in mkLambda (na,ta,c'), sigma' -let pattern_occs loccs_trm env sigma c = +let pattern_occs loccs_trm = { e_redfun = begin fun env sigma c -> + let sigma = Sigma.to_evar_map sigma in let abstr_trm, sigma = List.fold_right (abstract_scheme env) loccs_trm (c,sigma) in try let _ = Typing.unsafe_type_of env sigma abstr_trm in - sigma, applist(abstr_trm, List.map snd loccs_trm) + Sigma.Unsafe.of_pair (applist(abstr_trm, List.map snd loccs_trm), sigma) with Type_errors.TypeError (env',t) -> raise (ReductionTacticError (InvalidAbstraction (env,sigma,abstr_trm,(env',t)))) + end } (* Used in several tactics. *) @@ -1163,8 +1178,9 @@ let reduce_to_ind_gen allow_product env sigma t = match kind_of_term (fst (decompose_app t)) with | Ind ind-> (check_privacy env ind, it_mkProd_or_LetIn t l) | Prod (n,ty,t') -> + let open Context.Rel.Declaration in if allow_product then - elimrec (push_rel (n,None,ty) env) t' ((n,None,ty)::l) + elimrec (push_rel (LocalAssum (n,ty)) env) t' ((LocalAssum (n,ty))::l) else errorlabstrm "" (str"Not an inductive definition.") | _ -> @@ -1241,7 +1257,8 @@ let reduce_to_ref_gen allow_product env sigma ref t = match kind_of_term c with | Prod (n,ty,t') -> if allow_product then - elimrec (push_rel (n,None,t) env) t' ((n,None,ty)::l) + let open Context.Rel.Declaration in + elimrec (push_rel (LocalAssum (n,t)) env) t' ((LocalAssum (n,ty))::l) else error_cannot_recognize ref | _ -> diff --git a/pretyping/tacred.mli b/pretyping/tacred.mli index 03c4cb41c..195b21bbf 100644 --- a/pretyping/tacred.mli +++ b/pretyping/tacred.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -61,8 +61,7 @@ val unfoldn : val fold_commands : constr list -> reduction_function (** Pattern *) -val pattern_occs : (occurrences * constr) list -> env -> evar_map -> constr -> - evar_map * constr +val pattern_occs : (occurrences * constr) list -> e_reduction_function (** Rem: Lazy strategies are defined in Reduction *) diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index 2ef289650..3a5796fe1 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -12,11 +12,11 @@ open Globnames open Decl_kinds open Term open Vars -open Context open Evd open Util open Typeclasses_errors open Libobject +open Context.Rel.Declaration (*i*) let typeclasses_unique_solutions = ref false @@ -59,10 +59,10 @@ type typeclass = { cl_impl : global_reference; (* Context in which the definitions are typed. Includes both typeclass parameters and superclasses. *) - cl_context : (global_reference * bool) option list * rel_context; + cl_context : (global_reference * bool) option list * Context.Rel.t; (* Context of definitions and properties on defs, will not be shared *) - cl_props : rel_context; + cl_props : Context.Rel.t; (* The method implementaions as projections. *) cl_projs : (Name.t * (direction * int option) option * constant option) list; @@ -127,7 +127,7 @@ let typeclass_univ_instance (cl,u') = in Array.fold_left2 (fun subst u u' -> Univ.LMap.add u u' subst) Univ.LMap.empty (Univ.Instance.to_array u) (Univ.Instance.to_array u') in - let subst_ctx = Context.map_rel_context (subst_univs_level_constr subst) in + let subst_ctx = Context.Rel.map (subst_univs_level_constr subst) in { cl with cl_context = fst cl.cl_context, subst_ctx (snd cl.cl_context); cl_props = subst_ctx cl.cl_props}, u' @@ -181,9 +181,7 @@ let subst_class (subst,cl) = let do_subst_con c = Mod_subst.subst_constant subst c and do_subst c = Mod_subst.subst_mps subst c and do_subst_gr gr = fst (subst_global subst gr) in - let do_subst_ctx ctx = List.smartmap - (fun (na, b, t) -> (na, Option.smartmap do_subst b, do_subst t)) - ctx in + let do_subst_ctx = List.smartmap (map_constr do_subst) in let do_subst_context (grs,ctx) = List.smartmap (Option.smartmap (fun (gr,b) -> do_subst_gr gr, b)) grs, do_subst_ctx ctx in @@ -200,15 +198,19 @@ let discharge_class (_,cl) = let repl = Lib.replacement_context () in let rel_of_variable_context ctx = List.fold_right ( fun (n,_,b,t) (ctx', subst) -> - let decl = (Name n, Option.map (substn_vars 1 subst) b, substn_vars 1 subst t) in + let decl = match b with + | None -> LocalAssum (Name n, substn_vars 1 subst t) + | Some b -> LocalDef (Name n, substn_vars 1 subst b, substn_vars 1 subst t) + in (decl :: ctx', n :: subst) ) ctx ([], []) in let discharge_rel_context subst n rel = - let rel = map_rel_context (Cooking.expmod_constr repl) rel in + let rel = Context.Rel.map (Cooking.expmod_constr repl) rel in let ctx, _ = List.fold_right - (fun (id, b, t) (ctx, k) -> - (id, Option.smartmap (substn_vars k subst) b, substn_vars k subst t) :: ctx, succ k) + (fun decl (ctx, k) -> + map_constr (substn_vars k subst) decl :: ctx, succ k + ) rel ([], n) in ctx in @@ -218,15 +220,15 @@ let discharge_class (_,cl) = | ConstRef cst -> Lib.section_segment_of_constant cst | IndRef (ind,_) -> Lib.section_segment_of_mutual_inductive ind in let discharge_context ctx' subst (grs, ctx) = - let grs' = - let newgrs = List.map (fun (_, _, t) -> - match class_of_constr t with - | None -> None - | Some (_, ((tc,_), _)) -> Some (tc.cl_impl, true)) - ctx' + let grs' = + let newgrs = List.map (fun decl -> + match decl |> get_type |> class_of_constr with + | None -> None + | Some (_, ((tc,_), _)) -> Some (tc.cl_impl, true)) + ctx' in - List.smartmap (Option.smartmap (fun (gr, b) -> Lib.discharge_global gr, b)) grs - @ newgrs + List.smartmap (Option.smartmap (fun (gr, b) -> Lib.discharge_global gr, b)) grs + @ newgrs in grs', discharge_rel_context subst 1 ctx @ ctx' in let cl_impl' = Lib.discharge_global cl.cl_impl in if cl_impl' == cl.cl_impl then cl else @@ -287,7 +289,7 @@ let build_subclasses ~check env sigma glob pri = | None -> [] | Some (rels, ((tc,u), args)) -> let instapp = - Reductionops.whd_beta sigma (appvectc c (Termops.extended_rel_vect 0 rels)) + Reductionops.whd_beta sigma (appvectc c (Context.Rel.to_extended_vect 0 rels)) in let projargs = Array.of_list (args @ [instapp]) in let projs = List.map_filter @@ -432,11 +434,7 @@ let add_class cl = *) let instance_constructor (cl,u) args = - let filter (_, b, _) = match b with - | None -> true - | Some _ -> false - in - let lenpars = List.length (List.filter filter (snd cl.cl_context)) in + let lenpars = List.count is_local_assum (snd cl.cl_context) in let pars = fst (List.chop lenpars args) in match cl.cl_impl with | IndRef ind -> @@ -492,18 +490,21 @@ let is_instance = function Nota: we will only check the resolvability status of undefined evars. *) -let resolvable = Store.field () +let resolvable = Proofview.Unsafe.typeclass_resolvable let set_resolvable s b = - Store.set s resolvable b + if b then Store.remove s resolvable + else Store.set s resolvable () let is_resolvable evi = assert (match evi.evar_body with Evar_empty -> true | _ -> false); - Option.default true (Store.get evi.evar_extra resolvable) + Option.is_empty (Store.get evi.evar_extra resolvable) let mark_resolvability_undef b evi = - let t = Store.set evi.evar_extra resolvable b in - { evi with evar_extra = t } + if is_resolvable evi = b then evi + else + let t = set_resolvable evi.evar_extra b in + { evi with evar_extra = t } let mark_resolvability b evi = assert (match evi.evar_body with Evar_empty -> true | _ -> false); diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli index b3170b970..7bb0ef3ab 100644 --- a/pretyping/typeclasses.mli +++ b/pretyping/typeclasses.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -9,7 +9,6 @@ open Names open Globnames open Term -open Context open Evd open Environ @@ -24,10 +23,10 @@ type typeclass = { (** Context in which the definitions are typed. Includes both typeclass parameters and superclasses. The boolean indicates if the typeclass argument is a direct superclass and the global reference gives a direct link to the class itself. *) - cl_context : (global_reference * bool) option list * rel_context; + cl_context : (global_reference * bool) option list * Context.Rel.t; (** Context of definitions and properties on defs, will not be shared *) - cl_props : rel_context; + cl_props : Context.Rel.t; (** The methods implementations of the typeclass as projections. Some may be undefinable due to sorting restrictions or simply undefined if @@ -68,7 +67,7 @@ val dest_class_app : env -> constr -> typeclass puniverses * constr list val typeclass_univ_instance : typeclass puniverses -> typeclass puniverses (** Just return None if not a class *) -val class_of_constr : constr -> (rel_context * (typeclass puniverses * constr list)) option +val class_of_constr : constr -> (Context.Rel.t * (typeclass puniverses * constr list)) option val instance_impl : instance -> global_reference diff --git a/pretyping/typeclasses_errors.ml b/pretyping/typeclasses_errors.ml index 585f066db..b1dfb19a0 100644 --- a/pretyping/typeclasses_errors.ml +++ b/pretyping/typeclasses_errors.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -9,7 +9,6 @@ (*i*) open Names open Term -open Context open Environ open Constrexpr open Globnames @@ -20,7 +19,7 @@ type contexts = Parameters | Properties type typeclass_error = | NotAClass of constr | UnboundMethod of global_reference * Id.t Loc.located (* Class name, method *) - | MismatchedContextInstance of contexts * constr_expr list * rel_context (* found, expected *) + | MismatchedContextInstance of contexts * constr_expr list * Context.Rel.t (* found, expected *) exception TypeClassError of env * typeclass_error diff --git a/pretyping/typeclasses_errors.mli b/pretyping/typeclasses_errors.mli index 7982fc852..ee76f6383 100644 --- a/pretyping/typeclasses_errors.mli +++ b/pretyping/typeclasses_errors.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -9,7 +9,6 @@ open Loc open Names open Term -open Context open Environ open Constrexpr open Globnames @@ -19,7 +18,7 @@ type contexts = Parameters | Properties type typeclass_error = | NotAClass of constr | UnboundMethod of global_reference * Id.t located (** Class name, method *) - | MismatchedContextInstance of contexts * constr_expr list * rel_context (** found, expected *) + | MismatchedContextInstance of contexts * constr_expr list * Context.Rel.t (** found, expected *) exception TypeClassError of env * typeclass_error @@ -27,5 +26,5 @@ val not_a_class : env -> constr -> 'a val unbound_method : env -> global_reference -> Id.t located -> 'a -val mismatched_ctx_inst : env -> contexts -> constr_expr list -> rel_context -> 'a +val mismatched_ctx_inst : env -> contexts -> constr_expr list -> Context.Rel.t -> 'a diff --git a/pretyping/typing.ml b/pretyping/typing.ml index fb5927dbf..52afa7f83 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -18,6 +18,7 @@ open Inductive open Inductiveops open Typeops open Arguments_renaming +open Context.Rel.Declaration let meta_type evd mv = let ty = @@ -38,7 +39,7 @@ let e_type_judgment env evdref j = match kind_of_term (whd_betadeltaiota env !evdref j.uj_type) with | Sort s -> {utj_val = j.uj_val; utj_type = s } | Evar ev -> - let (evd,s) = Evarutil.define_evar_as_sort env !evdref ev in + let (evd,s) = Evardefine.define_evar_as_sort env !evdref ev in evdref := evd; { utj_val = j.uj_val; utj_type = s } | _ -> error_not_type env j @@ -60,7 +61,7 @@ let e_judge_of_apply env evdref funj argjv = else error_cant_apply_bad_type env (n,c1, hj.uj_type) funj argjv | Evar ev -> - let (evd',t) = Evarutil.define_evar_as_product !evdref ev in + let (evd',t) = Evardefine.define_evar_as_product !evdref ev in evdref := evd'; let (_,_,c2) = destProd t in apply_rec (n+1) (subst1 hj.uj_val c2) restjl @@ -88,16 +89,16 @@ let e_is_correct_arity env evdref c pj ind specif params = let rec srec env pt ar = let pt' = whd_betadeltaiota env !evdref pt in match kind_of_term pt', ar with - | Prod (na1,a1,t), (_,None,a1')::ar' -> + | Prod (na1,a1,t), (LocalAssum (_,a1'))::ar' -> if not (Evarconv.e_cumul env evdref a1 a1') then error (); - srec (push_rel (na1,None,a1) env) t ar' + srec (push_rel (LocalAssum (na1,a1)) env) t ar' | Sort s, [] -> if not (Sorts.List.mem (Sorts.family s) allowed_sorts) then error () | Evar (ev,_), [] -> let evd, s = Evd.fresh_sort_in_family env !evdref (max_sort allowed_sorts) in evdref := Evd.define ev (mkSort s) evd - | _, (_,Some _,_ as d)::ar' -> + | _, (LocalDef _ as d)::ar' -> srec (push_rel d env) (lift 1 pt') ar' | _ -> error () @@ -111,9 +112,8 @@ let e_type_case_branches env evdref (ind,largs) pj c = let p = pj.uj_val in let univ = e_is_correct_arity env evdref c pj ind specif params in let lc = build_branches_type ind specif params p in - let n = (snd specif).Declarations.mind_nrealargs in - let ty = - whd_betaiota !evdref (Reduction.betazeta_appvect (n+1) p (Array.of_list (realargs@[c]))) in + let n = (snd specif).Declarations.mind_nrealdecls in + let ty = whd_betaiota !evdref (lambda_applist_assum (n+1) p (realargs@[c])) in (lc, ty, univ) let e_judge_of_case env evdref ci pj cj lfj = @@ -144,8 +144,13 @@ let e_judge_of_cast env evdref cj k tj = { uj_val = mkCast (cj.uj_val, k, expected_type); uj_type = expected_type } -(* The typing machine without information, without universes but with - existential variables. *) +let enrich_env env evdref = + let penv = Environ.pre_env env in + let penv' = Pre_env.({ penv with env_stratification = + { penv.env_stratification with env_universes = Evd.universes !evdref } }) in + Environ.env_of_pre_env penv' + +(* The typing machine with universes and existential variables. *) (* cstr must be in n.f. w.r.t. evars and execute returns a judgement where both the term and type are in n.f. *) @@ -225,14 +230,14 @@ let rec execute env evdref cstr = | Lambda (name,c1,c2) -> let j = execute env evdref c1 in let var = e_type_judgment env evdref j in - let env1 = push_rel (name,None,var.utj_val) env in + let env1 = push_rel (LocalAssum (name, var.utj_val)) env in let j' = execute env1 evdref c2 in judge_of_abstraction env1 name var j' | Prod (name,c1,c2) -> let j = execute env evdref c1 in let varj = e_type_judgment env evdref j in - let env1 = push_rel (name,None,varj.utj_val) env in + let env1 = push_rel (LocalAssum (name, varj.utj_val)) env in let j' = execute env1 evdref c2 in let varj' = e_type_judgment env1 evdref j' in judge_of_product env name varj varj' @@ -242,7 +247,7 @@ let rec execute env evdref cstr = let j2 = execute env evdref c2 in let j2 = e_type_judgment env evdref j2 in let _ = e_judge_of_cast env evdref j1 DEFAULTcast j2 in - let env1 = push_rel (name,Some j1.uj_val,j2.utj_val) env in + let env1 = push_rel (LocalDef (name, j1.uj_val, j2.utj_val)) env in let j3 = execute env1 evdref c3 in judge_of_letin env name j1 j2 j3 @@ -263,7 +268,8 @@ and execute_recdef env evdref (names,lar,vdef) = and execute_array env evdref = Array.map (execute env evdref) -let check env evdref c t = +let e_check env evdref c t = + let env = enrich_env env evdref in let j = execute env evdref c in if not (Evarconv.e_cumul env evdref j.uj_type t) then error_actual_type env j (nf_evar !evdref t) @@ -271,12 +277,15 @@ let check env evdref c t = (* Type of a constr *) let unsafe_type_of env evd c = - let j = execute env (ref evd) c in + let evdref = ref evd in + let env = enrich_env env evdref in + let j = execute env evdref c in j.uj_type (* Sort of a type *) -let sort_of env evdref c = +let e_sort_of env evdref c = + let env = enrich_env env evdref in let j = execute env evdref c in let a = e_type_judgment env evdref j in a.utj_type @@ -285,6 +294,7 @@ let sort_of env evdref c = let type_of ?(refresh=false) env evd c = let evdref = ref evd in + let env = enrich_env env evdref in let j = execute env evdref c in (* side-effect on evdref *) if refresh then @@ -292,6 +302,7 @@ let type_of ?(refresh=false) env evd c = else !evdref, j.uj_type let e_type_of ?(refresh=false) env evdref c = + let env = enrich_env env evdref in let j = execute env evdref c in (* side-effect on evdref *) if refresh then @@ -300,9 +311,10 @@ let e_type_of ?(refresh=false) env evdref c = c else j.uj_type -let solve_evars env evdref c = +let e_solve_evars env evdref c = + let env = enrich_env env evdref in let c = (execute env evdref c).uj_val in (* side-effect on evdref *) nf_evar !evdref c -let _ = Evarconv.set_solve_evars solve_evars +let _ = Evarconv.set_solve_evars e_solve_evars diff --git a/pretyping/typing.mli b/pretyping/typing.mli index bfae46ff8..e524edcca 100644 --- a/pretyping/typing.mli +++ b/pretyping/typing.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -24,16 +24,16 @@ val type_of : ?refresh:bool -> env -> evar_map -> constr -> evar_map * types 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 +val e_sort_of : env -> evar_map ref -> types -> sorts (** Typecheck a term has a given type (assuming the type is OK) *) -val check : env -> evar_map ref -> constr -> types -> unit +val e_check : env -> evar_map ref -> constr -> types -> unit (** Returns the instantiated type of a metavariable *) val meta_type : evar_map -> metavariable -> types (** Solve existential variables using typing *) -val solve_evars : env -> evar_map ref -> constr -> constr +val e_solve_evars : env -> evar_map ref -> constr -> constr (** Raise an error message if incorrect elimination for this inductive *) (** (first constr is term to match, second is return predicate) *) diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 269c723e3..a4a386530 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -19,6 +19,7 @@ open Evd open Reduction open Reductionops open Evarutil +open Evardefine open Evarsolve open Pretype_errors open Retyping @@ -28,6 +29,7 @@ open Locus open Locusops open Find_subterm open Sigma.Notations +open Context.Named.Declaration let keyed_unification = ref (false) let _ = Goptions.declare_bool_option { @@ -38,6 +40,8 @@ let _ = Goptions.declare_bool_option { Goptions.optwrite = (fun a -> keyed_unification:=a); } +let is_keyed_unification () = !keyed_unification + let debug_unification = ref (false) let _ = Goptions.declare_bool_option { Goptions.optsync = true; Goptions.optdepr = false; @@ -56,7 +60,7 @@ let occur_meta_or_undefined_evar evd c = | Evar_defined c -> occrec c; Array.iter occrec args | Evar_empty -> raise Occur) - | _ -> iter_constr occrec c + | _ -> Constr.iter occrec c in try occrec c; false with Occur | Not_found -> true let occur_meta_evd sigma mv c = @@ -65,7 +69,7 @@ let occur_meta_evd sigma mv c = let c = whd_evar sigma (whd_meta sigma c) in match kind_of_term c with | Meta mv' when Int.equal mv mv' -> raise Occur - | _ -> iter_constr occrec c + | _ -> Constr.iter occrec c in try occrec c; false with Occur -> true (* if lname_typ is [xn,An;..;x1,A1] and l is a list of terms, @@ -73,7 +77,10 @@ let occur_meta_evd sigma mv c = let abstract_scheme env evd c l lname_typ = List.fold_left2 - (fun (t,evd) (locc,a) (na,_,ta) -> + (fun (t,evd) (locc,a) decl -> + let open Context.Rel.Declaration in + let na = get_name decl in + let ta = get_type decl in let na = match kind_of_term a with Var id -> Name id | _ -> na in (* [occur_meta ta] test removed for support of eelim/ecase but consequences are unclear... @@ -144,7 +151,7 @@ let rec subst_meta_instances bl c = | Meta i -> let select (j,_,_) = Int.equal i j in (try pi2 (List.find select bl) with Not_found -> c) - | _ -> map_constr (subst_meta_instances bl) c + | _ -> Constr.map (subst_meta_instances bl) c (** [env] should be the context in which the metas live *) @@ -162,7 +169,7 @@ let pose_all_metas_as_evars env evd t = evdref := meta_assign mv (ev,(Conv,TypeNotProcessed)) !evdref; ev) | _ -> - map_constr aux t in + Constr.map aux t in let c = aux t in (* side-effect *) (!evdref, c) @@ -357,6 +364,22 @@ let set_no_delta_flags flags = { resolve_evars = flags.resolve_evars } +(* For the first phase of keyed unification, restrict + to conversion (including beta-iota) only on closed terms *) +let set_no_delta_open_core_flags flags = { flags with + modulo_delta = empty_transparent_state; + modulo_betaiota = false; +} + +let set_no_delta_open_flags flags = { + core_unify_flags = set_no_delta_open_core_flags flags.core_unify_flags; + merge_unify_flags = set_no_delta_open_core_flags flags.merge_unify_flags; + subterm_unify_flags = set_no_delta_open_core_flags flags.subterm_unify_flags; + allow_K_in_toplevel_higher_order_unification = + flags.allow_K_in_toplevel_higher_order_unification; + resolve_evars = flags.resolve_evars +} + (* Default flag for the "simple apply" version of unification of a *) (* type against a type (e.g. apply) *) (* We set only the flags available at the time the new "apply" extended *) @@ -482,7 +505,8 @@ let key_of env b flags f = Id.Pred.mem id (fst flags.modulo_delta) -> Some (IsKey (VarKey id)) | Proj (p, c) when Projection.unfolded p - || Cpred.mem (Projection.constant p) (snd flags.modulo_delta) -> + || (is_transparent env (ConstKey (Projection.constant p)) && + (Cpred.mem (Projection.constant p) (snd flags.modulo_delta))) -> Some (IsProj (p, c)) | _ -> None @@ -566,8 +590,8 @@ let subst_defined_metas_evars (bl,el) c = | Evar (evk,args) -> let select (_,(evk',args'),_) = Evar.equal evk evk' && Array.equal Constr.equal args args' in (try substrec (pi3 (List.find select el)) - with Not_found -> map_constr substrec c) - | _ -> map_constr substrec c + with Not_found -> Constr.map substrec c) + | _ -> Constr.map substrec c in try Some (substrec c) with Not_found -> None let check_compatibility env pbty flags (sigma,metasubst,evarsubst) tyM tyN = @@ -606,7 +630,7 @@ let is_eta_constructor_app env ts f l1 term = | Construct (((_, i as ind), j), u) when i == 0 && j == 1 -> let mib = lookup_mind (fst ind) env in (match mib.Declarations.mind_record with - | Some (Some (_,exp,projs)) when mib.Declarations.mind_finite <> Decl_kinds.CoFinite && + | Some (Some (_,exp,projs)) when mib.Declarations.mind_finite == Decl_kinds.BiFinite && Array.length projs == Array.length l1 - mib.Declarations.mind_nparams -> (** Check that the other term is neutral *) is_neutral env ts term @@ -920,8 +944,18 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb match subst_defined_metas_evars subst cN with | None -> (* some undefined Metas in cN *) None | Some n1 -> - (* No subterm restriction there, too much incompatibilities *) - let sigma, b = infer_conv ~pb ~ts:convflags curenv sigma m1 n1 in + (* No subterm restriction there, too much incompatibilities *) + let sigma = + if opt.with_types then + try (* Ensure we call conversion on terms of the same type *) + let tyM = get_type_of curenv ~lax:true sigma m1 in + let tyN = get_type_of curenv ~lax:true sigma n1 in + check_compatibility curenv CUMUL flags substn tyM tyN + with RetypeError _ -> + (* Renounce, maybe metas/evars prevents typing *) sigma + else sigma + in + let sigma, b = infer_conv ~pb ~ts:convflags curenv sigma m1 n1 in if b then Some (sigma, metasubst, evarsubst) else if is_ground_term sigma m1 && is_ground_term sigma n1 then @@ -1436,10 +1470,10 @@ let indirectly_dependent c d decls = it is needed otherwise, as e.g. when abstracting over "2" in "forall H:0=2, H=H:>(0=1+1) -> 0=2." where there is now obvious way to see that the second hypothesis depends indirectly over 2 *) - List.exists (fun (id,_,_) -> dependent_in_decl (mkVar id) d) decls + List.exists (fun d' -> dependent_in_decl (mkVar (get_id d')) d) decls let indirect_dependency d decls = - pi1 (List.hd (List.filter (fun (id,_,_) -> dependent_in_decl (mkVar id) d) decls)) + decls |> List.filter (fun d' -> dependent_in_decl (mkVar (get_id d')) d) |> List.hd |> get_id let finish_evar_resolution ?(flags=Pretyping.all_and_fail_flags) env current_sigma (pending,c) = let current_sigma = Sigma.to_evar_map current_sigma in @@ -1457,9 +1491,7 @@ let default_matching_core_flags sigma = check_applied_meta_types = true; use_pattern_unification = false; use_meta_bound_pattern_unification = false; - frozen_evars = - fold_undefined (fun evk _ evars -> Evar.Set.add evk evars) - sigma Evar.Set.empty; + frozen_evars = Evar.Map.domain (Evd.undefined_map sigma); restrict_conv_on_strict_subterms = false; modulo_betaiota = false; modulo_eta = false; @@ -1524,8 +1556,9 @@ let make_pattern_test from_prefix_of_ind is_correct_type env sigma (pending,c) = | e when Errors.noncritical e -> raise (NotUnifiable None) in let merge_fun c1 c2 = match c1, c2 with - | Some (evd,c1,_) as x, Some (_,c2,_) -> - if is_conv env sigma c1 c2 then x else raise (NotUnifiable None) + | Some (evd,c1,x), Some (_,c2,_) -> + let (evd,b) = infer_conv ~pb:CONV env evd c1 c2 in + if b then Some (evd, c1, x) else raise (NotUnifiable None) | Some _, None -> c1 | None, Some _ -> c2 | None, None -> None in @@ -1558,7 +1591,8 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = in let likefirst = clause_with_generic_occurrences occs in let mkvarid () = mkVar id in - let compute_dependency _ (hyp,_,_ as d) (sign,depdecls) = + let compute_dependency _ d (sign,depdecls) = + let hyp = get_id d in match occurrences_of_hyp hyp occs with | NoOccurrences, InHyp -> if indirectly_dependent c d depdecls then @@ -1572,7 +1606,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = | AllOccurrences, InHyp as occ -> let occ = if likefirst then LikeFirst else AtOccs occ in let newdecl = replace_term_occ_decl_modulo occ test mkvarid d in - if Context.eq_named_declaration d newdecl + if Context.Named.Declaration.equal d newdecl && not (indirectly_dependent c d depdecls) then if check_occs && not (in_every_hyp occs) @@ -1595,7 +1629,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = replace_term_occ_modulo occ test mkvarid concl in let lastlhyp = - if List.is_empty depdecls then None else Some (pi1(List.last depdecls)) in + if List.is_empty depdecls then None else Some (get_id (List.last depdecls)) in let res = match out test with | None -> None | Some (sigma, c) -> Some (Sigma.Unsafe.of_pair (c, sigma)) @@ -1624,7 +1658,7 @@ type abstraction_request = type 'r abstraction_result = Names.Id.t * named_context_val * - Context.named_declaration list * Names.Id.t option * + Context.Named.Declaration.t list * Names.Id.t option * types * (constr, 'r) Sigma.sigma option let make_abstraction env evd ccl abs = @@ -1661,8 +1695,13 @@ let w_unify_to_subterm env evd ?(flags=default_unify_flags ()) (op,cl) = let cl = strip_outer_cast cl in (try if closed0 cl && not (isEvar cl) && keyed_unify env evd kop cl then - (try w_typed_unify env evd CONV flags op cl,cl - with ex when Pretype_errors.unsatisfiable_exception ex -> + (try + if !keyed_unification then + let f1, l1 = decompose_app_vect op in + let f2, l2 = decompose_app_vect cl in + w_typed_unify_array env evd flags f1 l1 f2 l2,cl + else w_typed_unify env evd CONV flags op cl,cl + with ex when Pretype_errors.unsatisfiable_exception ex -> bestexn := Some ex; error "Unsat") else error "Bound 1" with ex when precatchable_exception ex -> @@ -1798,17 +1837,25 @@ let w_unify_to_subterm_list env evd flags hdmeta oplist t = let allow_K = flags.allow_K_in_toplevel_higher_order_unification in let flags = if occur_meta_or_existential op || !keyed_unification then + (* This is up to delta for subterms w/o metas ... *) flags else (* up to Nov 2014, unification was bypassed on evar/meta-free terms; now it is called in a minimalistic way, at least to possibly unify pre-existing non frozen evars of the goal or of the pattern *) - set_no_delta_flags flags in + set_no_delta_flags flags in + let t' = (strip_outer_cast op,t) in let (evd',cl) = try - (* This is up to delta for subterms w/o metas ... *) - w_unify_to_subterm env evd ~flags (strip_outer_cast op,t) + if is_keyed_unification () then + try (* First try finding a subterm w/o conversion on open terms *) + let flags = set_no_delta_open_flags flags in + w_unify_to_subterm env evd ~flags t' + with e -> + (* If this fails, try with full conversion *) + w_unify_to_subterm env evd ~flags t' + else w_unify_to_subterm env evd ~flags t' with PretypeError (env,_,NoOccurrenceFound _) when allow_K || (* w_unify_to_subterm does not go through evars, so diff --git a/pretyping/unification.mli b/pretyping/unification.mli index 51a51f375..0ad882a9f 100644 --- a/pretyping/unification.mli +++ b/pretyping/unification.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -42,6 +42,8 @@ val default_no_delta_unify_flags : unit -> unify_flags val elim_flags : unit -> unify_flags val elim_no_delta_flags : unit -> unify_flags +val is_keyed_unification : unit -> bool + (** The "unique" unification fonction *) val w_unify : env -> evar_map -> conv_pb -> ?flags:unify_flags -> constr -> constr -> evar_map @@ -77,7 +79,7 @@ val finish_evar_resolution : ?flags:Pretyping.inference_flags -> type 'r abstraction_result = Names.Id.t * named_context_val * - Context.named_declaration list * Names.Id.t option * + Context.Named.Declaration.t list * Names.Id.t option * types * (constr, 'r) Sigma.sigma option val make_abstraction : env -> 'r Sigma.t -> constr -> diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index 46af784dd..7ea9b9063 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -15,6 +15,7 @@ open Environ open Inductive open Reduction open Vm +open Context.Rel.Declaration (*******************************************) (* Calcul de la forme normal d'un terme *) @@ -45,13 +46,7 @@ let invert_tag cst tag reloc_tbl = with Find_at j -> (j+1) (* Argggg, ces constructeurs de ... qui commencent a 1*) -let find_rectype_a env c = - let (t, l) = - let t = whd_betadeltaiota env c in - try destApp t with DestKO -> (t,[||]) in - match kind_of_term t with - | Ind ind -> (ind, l) - | _ -> raise Not_found +let find_rectype_a env c = Inductiveops.find_mrectype_vect env Evd.empty c (* Instantiate inductives and parameters in constructor type *) @@ -59,11 +54,12 @@ let type_constructor mind mib u typ params = let s = ind_subst mind mib u in let ctyp = substl s typ in let ctyp = subst_instance_constr u ctyp in - let nparams = Array.length params in - if Int.equal nparams 0 then ctyp + let ndecls = Context.Rel.length mib.mind_params_ctxt in + if Int.equal ndecls 0 then ctyp else - let _,ctyp = decompose_prod_n nparams ctyp in - substl (Array.rev_to_list params) ctyp + let _,ctyp = decompose_prod_n_assum ndecls ctyp in + substl (List.rev (adjust_subst_to_rel_context mib.mind_params_ctxt (Array.to_list params))) + ctyp @@ -93,19 +89,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) @@ -152,7 +135,7 @@ and nf_whd env whd typ = let dom = nf_vtype env (dom p) in let name = Name (Id.of_string "x") in let vc = body_of_vfun (nb_rel env) (codom p) in - let codom = nf_vtype (push_rel (name,None,dom) env) vc in + let codom = nf_vtype (push_rel (LocalAssum (name,dom)) env) vc in mkProd(name,dom,codom) | Vfun f -> nf_fun env f typ | Vfix(f,None) -> nf_fix env f @@ -164,7 +147,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,22 +161,73 @@ 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(Aind ind, stk) -> - nf_stk env (mkIndU ind) (type_of_ind env ind) 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 open Context.Named.Declaration in + let ty = get_type (lookup_named id env) in + nf_stk env (mkVar id) ty stk + | RelKey i -> + let n = (nb_rel env - i) in + let ty = get_type (lookup_rel n env) in + nf_stk env (mkRel n) (lift n ty) stk -and nf_stk env c t 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 @@ -215,6 +250,7 @@ and nf_stk env c t stk = 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 @@ -226,7 +262,7 @@ and nf_predicate env ind mip params v pT = let vb = body_of_vfun k f in let name,dom,codom = decompose_prod env pT in let dep,body = - nf_predicate (push_rel (name,None,dom) env) ind mip params vb codom in + nf_predicate (push_rel (LocalAssum (name,dom)) env) ind mip params vb codom in dep, mkLambda(name,dom,body) | Vfun f, _ -> let k = nb_rel env in @@ -236,18 +272,18 @@ and nf_predicate env ind mip params v pT = let rargs = Array.init n (fun i -> mkRel (n-i)) in let params = if Int.equal n 0 then params else Array.map (lift n) params in let dom = mkApp(mkIndU ind,Array.append params rargs) in - let body = nf_vtype (push_rel (name,None,dom) env) vb in + let body = nf_vtype (push_rel (LocalAssum (name,dom)) env) vb in 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 @@ -272,7 +308,7 @@ and nf_fun env f typ = Errors.anomaly (Pp.strbrk "Returned a functional value in a type not recognized as a product type.") in - let body = nf_val (push_rel (name,None,dom) env) vb codom in + let body = nf_val (push_rel (LocalAssum (name,dom)) env) vb codom in mkLambda(name,dom,body) and nf_fix env f = diff --git a/pretyping/vnorm.mli b/pretyping/vnorm.mli index 9421b2d85..58f5b14e1 100644 --- a/pretyping/vnorm.mli +++ b/pretyping/vnorm.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,7 +8,6 @@ open Term open Environ -open Evd (** {6 Reduction functions } *) val cbv_vm : env -> constr -> types -> constr diff --git a/printing/genprint.ml b/printing/genprint.ml index ade69ef83..0ec35e07b 100644 --- a/printing/genprint.ml +++ b/printing/genprint.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -19,8 +19,9 @@ module PrintObj = struct type ('raw, 'glb, 'top) obj = ('raw, 'glb, 'top) printer let name = "printer" - let default wit = match unquote (rawwit wit) with - | ExtraArgType name -> + let default wit = match wit with + | ExtraArg tag -> + let name = ArgT.repr tag in let printer = { raw = (fun _ -> str "<genarg:" ++ str name ++ str ">"); glb = (fun _ -> str "<genarg:" ++ str name ++ str ">"); @@ -40,6 +41,6 @@ let raw_print wit v = (Print.obj wit).raw v let glb_print wit v = (Print.obj wit).glb v let top_print wit v = (Print.obj wit).top v -let generic_raw_print v = unpack { unpacker = fun w v -> raw_print w (raw v); } v -let generic_glb_print v = unpack { unpacker = fun w v -> glb_print w (glb v); } v -let generic_top_print v = unpack { unpacker = fun w v -> top_print w (top v); } v +let generic_raw_print (GenArg (Rawwit w, v)) = raw_print w v +let generic_glb_print (GenArg (Glbwit w, v)) = glb_print w v +let generic_top_print (GenArg (Topwit w, v)) = top_print w v diff --git a/printing/genprint.mli b/printing/genprint.mli index 5b91d6d21..6e6626f2f 100644 --- a/printing/genprint.mli +++ b/printing/genprint.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/printing/miscprint.ml b/printing/miscprint.ml index d09af6d2a..5e86c6bd7 100644 --- a/printing/miscprint.ml +++ b/printing/miscprint.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -33,9 +33,9 @@ and pr_intro_pattern_action prc = function | IntroRewrite false -> str "<-" and pr_or_and_intro_pattern prc = function - | [pl] -> + | IntroAndPattern pl -> str "(" ++ hv 0 (prlist_with_sep pr_comma (pr_intro_pattern prc) pl) ++ str ")" - | pll -> + | IntroOrPattern pll -> str "[" ++ hv 0 (prlist_with_sep pr_bar (prlist_with_sep spc (pr_intro_pattern prc)) pll) ++ str "]" diff --git a/printing/miscprint.mli b/printing/miscprint.mli index 1d915ef8c..fe8c779ff 100644 --- a/printing/miscprint.mli +++ b/printing/miscprint.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/printing/ppannotation.ml b/printing/ppannotation.ml index 4f26b8242..df7f925b7 100644 --- a/printing/ppannotation.ml +++ b/printing/ppannotation.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/printing/ppannotation.mli b/printing/ppannotation.mli index bc345c347..84724053e 100644 --- a/printing/ppannotation.mli +++ b/printing/ppannotation.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index ea705e335..1866ca504 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -136,8 +136,6 @@ end) = struct let pr_sep_com sep f c = pr_with_comments (constr_loc c) (sep() ++ f c) - let pr_in_comment pr x = str "(* " ++ pr x ++ str " *)" - let pr_univ l = match l with | [_,x] -> str x @@ -153,11 +151,11 @@ end) = struct let pr_qualid sp = let (sl, id) = repr_qualid sp in - let id = tag_ref (str (Id.to_string id)) in + let id = tag_ref (pr_id id) in let sl = match List.rev (DirPath.repr sl) with | [] -> mt () | sl -> - let pr dir = tag_path (str (Id.to_string dir)) ++ str "." in + let pr dir = tag_path (pr_id dir) ++ str "." in prlist pr sl in sl ++ id @@ -182,7 +180,7 @@ end) = struct let pr_reference = function | Qualid (_, qid) -> pr_qualid qid - | Ident (_, id) -> tag_var (str (Id.to_string id)) + | Ident (_, id) -> tag_var (pr_id id) let pr_cref ref us = pr_reference ref ++ pr_universe_instance us @@ -246,16 +244,16 @@ end) = struct | CPatAlias (_, p, id) -> pr_patt mt (las,E) p ++ str " as " ++ pr_id id, las - | CPatCstr (_,c, [], []) -> + | CPatCstr (_,c, None, []) -> pr_reference c, latom - | CPatCstr (_, c, [], args) -> + | CPatCstr (_, c, None, args) -> pr_reference c ++ prlist (pr_patt spc (lapp,L)) args, lapp - | CPatCstr (_, c, args, []) -> + | CPatCstr (_, c, Some args, []) -> str "@" ++ pr_reference c ++ prlist (pr_patt spc (lapp,L)) args, lapp - | CPatCstr (_, c, expl_args, extra_args) -> + | CPatCstr (_, c, Some expl_args, extra_args) -> surround (str "@" ++ pr_reference c ++ prlist (pr_patt spc (lapp,L)) expl_args) ++ prlist (pr_patt spc (lapp,L)) extra_args, lapp @@ -457,7 +455,7 @@ end) = struct (pr_decl true) dl ++ fnl() ++ keyword "for" ++ spc () ++ pr_id id - let pr_asin pr (na,indnalopt) = + let pr_asin pr na indnalopt = (match na with (* Decision of printing "_" or not moved to constrextern.ml *) | Some na -> spc () ++ keyword "as" ++ spc () ++ pr_lname na | None -> mt ()) ++ @@ -465,8 +463,8 @@ end) = struct | None -> mt () | Some t -> spc () ++ keyword "in" ++ spc () ++ pr_patt lsimplepatt t) - let pr_case_item pr (tm,asin) = - hov 0 (pr (lcast,E) tm ++ pr_asin pr asin) + let pr_case_item pr (tm,as_clause, in_clause) = + hov 0 (pr (lcast,E) tm ++ pr_asin pr as_clause in_clause) let pr_case_type pr po = match po with @@ -595,28 +593,20 @@ end) = struct return (p, lproj) | CApp (_,(None,a),l) -> return (pr_app (pr mt) a l, lapp) - | CRecord (_,w,l) -> - let beg = - match w with - | None -> - spc () - | Some t -> - spc () ++ pr spc ltop t ++ spc () - ++ keyword "with" ++ spc () - in + | CRecord (_,l) -> return ( - hv 0 (str"{|" ++ beg ++ + hv 0 (str"{|" ++ spc () ++ prlist_with_sep pr_semicolon (fun (id, c) -> h 1 (pr_reference id ++ spc () ++ str":=" ++ pr spc ltop c)) l ++ str" |}"), latom ) - | CCases (_,LetPatternStyle,rtntypopt,[c,asin],[(_,[(loc,[p])],b)]) -> + | CCases (_,LetPatternStyle,rtntypopt,[c,as_clause,in_clause],[(_,[(loc,[p])],b)]) -> return ( hv 0 ( keyword "let" ++ spc () ++ str"'" ++ hov 0 (pr_patt ltop p ++ - pr_asin (pr_dangling_with_for mt pr) asin ++ + pr_asin (pr_dangling_with_for mt pr) as_clause in_clause ++ str " :=" ++ pr spc ltop c ++ pr_case_type (pr_dangling_with_for mt pr) rtntypopt ++ spc () ++ keyword "in" ++ pr spc ltop b)), @@ -638,13 +628,13 @@ end) = struct | CLetTuple (_,nal,(na,po),c,b) -> return ( hv 0 ( - keyword "let" ++ spc () ++ - hov 0 (str "(" ++ + hov 2 (keyword "let" ++ spc () ++ + hov 1 (str "(" ++ prlist_with_sep sep_v pr_lname nal ++ str ")" ++ - pr_simple_return_type (pr mt) na po ++ str " :=" ++ - pr spc ltop c ++ spc () - ++ keyword "in") ++ + pr_simple_return_type (pr mt) na po ++ str " :=") ++ + pr spc ltop c + ++ keyword " in") ++ pr spc ltop b), lletin ) diff --git a/printing/ppconstr.mli b/printing/ppconstr.mli index 6e8d3b04c..0241633c6 100644 --- a/printing/ppconstr.mli +++ b/printing/ppconstr.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/printing/ppconstrsig.mli b/printing/ppconstrsig.mli index b7eb9b1ff..c711dd8f7 100644 --- a/printing/ppconstrsig.mli +++ b/printing/ppconstrsig.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/printing/pptactic.ml b/printing/pptactic.ml index 72d2eedcc..982c18ec6 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -26,11 +26,11 @@ open Printer let pr_global x = Nametab.pr_global_env Id.Set.empty x -type grammar_terminals = string option list +type grammar_terminals = Tacexpr.raw_tactic_expr Egramml.grammar_prod_item list type pp_tactic = { - pptac_args : argument_type list; - pptac_prods : int * grammar_terminals; + pptac_level : int; + pptac_prods : grammar_terminals; } (* ML Extensions *) @@ -61,14 +61,14 @@ type 'a glob_extra_genarg_printer = type 'a extra_genarg_printer = (Term.constr -> std_ppcmds) -> (Term.constr -> std_ppcmds) -> - (tolerability -> glob_tactic_expr -> std_ppcmds) -> + (tolerability -> Val.t -> std_ppcmds) -> 'a -> std_ppcmds let genarg_pprule = ref String.Map.empty let declare_extra_genarg_pprule wit f g h = - let s = match unquote (topwit wit) with - | ExtraArgType s -> s + let s = match wit with + | ExtraArg s -> ArgT.repr s | _ -> error "Can declare a pretty-printing rule only for extra argument types." in @@ -106,6 +106,8 @@ module Make let keyword x = tag_keyword (str x) let primitive x = tag_primitive (str x) + let pr_value _ _ = str "(* FIXME *)" + let pr_with_occurrences pr (occs,c) = match occs with | AllOccurrences -> @@ -265,149 +267,89 @@ module Make let with_evars ev s = if ev then "e" ^ s else s - let rec pr_raw_generic prc prlc prtac prpat prref (x:Genarg.rlevel Genarg.generic_argument) = - match Genarg.genarg_tag x with - | IntOrVarArgType -> pr_or_var int (out_gen (rawwit wit_int_or_var) x) - | IdentArgType -> pr_id (out_gen (rawwit wit_ident) x) - | VarArgType -> pr_located pr_id (out_gen (rawwit wit_var) x) - | GenArgType -> pr_raw_generic prc prlc prtac prpat prref (out_gen (rawwit wit_genarg) x) - | ConstrArgType -> prc (out_gen (rawwit wit_constr) x) - | ConstrMayEvalArgType -> - pr_may_eval prc prlc (pr_or_by_notation prref) prpat - (out_gen (rawwit wit_constr_may_eval) x) - | QuantHypArgType -> pr_quantified_hypothesis (out_gen (rawwit wit_quant_hyp) x) - | RedExprArgType -> - pr_red_expr (prc,prlc,pr_or_by_notation prref,prpat) - (out_gen (rawwit wit_red_expr) x) - | OpenConstrArgType -> prc (snd (out_gen (rawwit wit_open_constr) x)) - | ConstrWithBindingsArgType -> - pr_with_bindings prc prlc (out_gen (rawwit wit_constr_with_bindings) x) - | BindingsArgType -> - pr_bindings_no_with prc prlc (out_gen (rawwit wit_bindings) x) - | ListArgType _ -> - let list_unpacker wit l = - let map x = pr_raw_generic prc prlc prtac prpat prref (in_gen (rawwit wit) x) in - pr_sequence map (raw l) - in - hov 0 (list_unpack { list_unpacker } x) - | OptArgType _ -> - let opt_unpacker wit o = match raw o with + let rec pr_raw_generic_rec prc prlc prtac prpat prref (GenArg (Rawwit wit, x)) = + match wit with + | ListArg wit -> + let map x = pr_raw_generic_rec prc prlc prtac prpat prref (in_gen (rawwit wit) x) in + let ans = pr_sequence map x in + hov 0 ans + | OptArg wit -> + let ans = match x with | None -> mt () - | Some x -> pr_raw_generic prc prlc prtac prpat prref (in_gen (rawwit wit) x) + | Some x -> pr_raw_generic_rec prc prlc prtac prpat prref (in_gen (rawwit wit) x) in - hov 0 (opt_unpack { opt_unpacker } x) - | PairArgType _ -> - let pair_unpacker wit1 wit2 o = - let p, q = raw o in - let p = in_gen (rawwit wit1) p in - let q = in_gen (rawwit wit2) q in - pr_sequence (pr_raw_generic prc prlc prtac prpat prref) [p; q] - in - hov 0 (pair_unpack { pair_unpacker } x) - | ExtraArgType s -> - try pi1 (String.Map.find s !genarg_pprule) prc prlc prtac x - with Not_found -> Genprint.generic_raw_print x - - - let rec pr_glb_generic prc prlc prtac prpat x = - match Genarg.genarg_tag x with - | IntOrVarArgType -> pr_or_var int (out_gen (glbwit wit_int_or_var) x) - | IdentArgType -> pr_id (out_gen (glbwit wit_ident) x) - | VarArgType -> pr_located pr_id (out_gen (glbwit wit_var) x) - | GenArgType -> pr_glb_generic prc prlc prtac prpat (out_gen (glbwit wit_genarg) x) - | ConstrArgType -> prc (out_gen (glbwit wit_constr) x) - | ConstrMayEvalArgType -> - pr_may_eval prc prlc - (pr_or_var (pr_and_short_name pr_evaluable_reference)) prpat - (out_gen (glbwit wit_constr_may_eval) x) - | QuantHypArgType -> - pr_quantified_hypothesis (out_gen (glbwit wit_quant_hyp) x) - | RedExprArgType -> - pr_red_expr - (prc,prlc,pr_or_var (pr_and_short_name pr_evaluable_reference),prpat) - (out_gen (glbwit wit_red_expr) x) - | OpenConstrArgType -> prc (snd (out_gen (glbwit wit_open_constr) x)) - | ConstrWithBindingsArgType -> - pr_with_bindings prc prlc (out_gen (glbwit wit_constr_with_bindings) x) - | BindingsArgType -> - pr_bindings_no_with prc prlc (out_gen (glbwit wit_bindings) x) - | ListArgType _ -> - let list_unpacker wit l = - let map x = pr_glb_generic prc prlc prtac prpat (in_gen (glbwit wit) x) in - pr_sequence map (glb l) - in - hov 0 (list_unpack { list_unpacker } x) - | OptArgType _ -> - let opt_unpacker wit o = match glb o with + hov 0 ans + | PairArg (wit1, wit2) -> + let p, q = x in + let p = in_gen (rawwit wit1) p in + let q = in_gen (rawwit wit2) q in + hov 0 (pr_sequence (pr_raw_generic_rec prc prlc prtac prpat prref) [p; q]) + | ExtraArg s -> + try pi1 (String.Map.find (ArgT.repr s) !genarg_pprule) prc prlc prtac (in_gen (rawwit wit) x) + with Not_found -> Genprint.generic_raw_print (in_gen (rawwit wit) x) + + + let rec pr_glb_generic_rec prc prlc prtac prpat (GenArg (Glbwit wit, x)) = + match wit with + | ListArg wit -> + let map x = pr_glb_generic_rec prc prlc prtac prpat (in_gen (glbwit wit) x) in + let ans = pr_sequence map x in + hov 0 ans + | OptArg wit -> + let ans = match x with | None -> mt () - | Some x -> pr_glb_generic prc prlc prtac prpat (in_gen (glbwit wit) x) - in - hov 0 (opt_unpack { opt_unpacker } x) - | PairArgType _ -> - let pair_unpacker wit1 wit2 o = - let p, q = glb o in - let p = in_gen (glbwit wit1) p in - let q = in_gen (glbwit wit2) q in - pr_sequence (pr_glb_generic prc prlc prtac prpat) [p; q] + | Some x -> pr_glb_generic_rec prc prlc prtac prpat (in_gen (glbwit wit) x) in - hov 0 (pair_unpack { pair_unpacker } x) - | ExtraArgType s -> - try pi2 (String.Map.find s !genarg_pprule) prc prlc prtac x - with Not_found -> Genprint.generic_glb_print x - - let rec pr_top_generic prc prlc prtac prpat x = - match Genarg.genarg_tag x with - | IntOrVarArgType -> pr_or_var int (out_gen (topwit wit_int_or_var) x) - | IdentArgType -> pr_id (out_gen (topwit wit_ident) x) - | VarArgType -> pr_id (out_gen (topwit wit_var) x) - | GenArgType -> pr_top_generic prc prlc prtac prpat (out_gen (topwit wit_genarg) x) - | ConstrArgType -> prc (out_gen (topwit wit_constr) x) - | ConstrMayEvalArgType -> prc (out_gen (topwit wit_constr_may_eval) x) - | QuantHypArgType -> pr_quantified_hypothesis (out_gen (topwit wit_quant_hyp) x) - | RedExprArgType -> - pr_red_expr (prc,prlc,pr_evaluable_reference,prpat) - (out_gen (topwit wit_red_expr) x) - | OpenConstrArgType -> prc (snd (out_gen (topwit wit_open_constr) x)) - | ConstrWithBindingsArgType -> - let (c,b) = (out_gen (topwit wit_constr_with_bindings) x).Evd.it in - pr_with_bindings prc prlc (c,b) - | BindingsArgType -> - pr_bindings_no_with prc prlc (out_gen (topwit wit_bindings) x).Evd.it - | ListArgType _ -> - let list_unpacker wit l = - let map x = pr_top_generic prc prlc prtac prpat (in_gen (topwit wit) x) in - pr_sequence map (top l) - in - hov 0 (list_unpack { list_unpacker } x) - | OptArgType _ -> - let opt_unpacker wit o = match top o with + hov 0 ans + | PairArg (wit1, wit2) -> + let p, q = x in + let p = in_gen (glbwit wit1) p in + let q = in_gen (glbwit wit2) q in + let ans = pr_sequence (pr_glb_generic_rec prc prlc prtac prpat) [p; q] in + hov 0 ans + | ExtraArg s -> + try pi2 (String.Map.find (ArgT.repr s) !genarg_pprule) prc prlc prtac (in_gen (glbwit wit) x) + with Not_found -> Genprint.generic_glb_print (in_gen (glbwit wit) x) + + let rec pr_top_generic_rec prc prlc prtac prpat (GenArg (Topwit wit, x)) = + match wit with + | ListArg wit -> + let map x = pr_top_generic_rec prc prlc prtac prpat (in_gen (topwit wit) x) in + let ans = pr_sequence map x in + hov 0 ans + | OptArg wit -> + let ans = match x with | None -> mt () - | Some x -> pr_top_generic prc prlc prtac prpat (in_gen (topwit wit) x) - in - hov 0 (opt_unpack { opt_unpacker } x) - | PairArgType _ -> - let pair_unpacker wit1 wit2 o = - let p, q = top o in - let p = in_gen (topwit wit1) p in - let q = in_gen (topwit wit2) q in - pr_sequence (pr_top_generic prc prlc prtac prpat) [p; q] + | Some x -> pr_top_generic_rec prc prlc prtac prpat (in_gen (topwit wit) x) in - hov 0 (pair_unpack { pair_unpacker } x) - | ExtraArgType s -> - try pi3 (String.Map.find s !genarg_pprule) prc prlc prtac x - with Not_found -> Genprint.generic_top_print x + hov 0 ans + | PairArg (wit1, wit2) -> + let p, q = x in + let p = in_gen (topwit wit1) p in + let q = in_gen (topwit wit2) q in + let ans = pr_sequence (pr_top_generic_rec prc prlc prtac prpat) [p; q] in + hov 0 ans + | ExtraArg s -> + try pi3 (String.Map.find (ArgT.repr s) !genarg_pprule) prc prlc prtac (in_gen (topwit wit) x) + with Not_found -> Genprint.generic_top_print (in_gen (topwit wit) x) let rec tacarg_using_rule_token pr_gen = function - | Some s :: l, al -> keyword s :: tacarg_using_rule_token pr_gen (l,al) - | None :: l, a :: al -> + | Egramml.GramTerminal s :: l, al -> keyword s :: tacarg_using_rule_token pr_gen (l,al) + | Egramml.GramNonTerminal _ :: l, a :: al -> let r = tacarg_using_rule_token pr_gen (l,al) in pr_gen a :: r | [], [] -> [] | _ -> failwith "Inconsistent arguments of extended tactic" + type any_arg = AnyArg : 'a Genarg.raw_abstract_argument_type -> any_arg + + let filter_arg = function + | Egramml.GramTerminal _ -> None + | Egramml.GramNonTerminal (_, t, _) -> Some (AnyArg t) + let pr_tacarg_using_rule pr_gen l = let l = match l with - | (Some s :: l, al) -> + | (Egramml.GramTerminal s :: l, al) -> (** First terminal token should be considered as the name of the tactic, so we tag it differently than the other terminal tokens. *) primitive s :: (tacarg_using_rule_token pr_gen (l, al)) @@ -415,13 +357,14 @@ module Make in pr_sequence (fun x -> x) l - let pr_extend_gen pr_gen lev { mltac_name = s; mltac_index = i } l = + let pr_extend_gen check pr_gen lev { mltac_name = s; mltac_index = i } l = try let pp_rules = Hashtbl.find prtac_tab s in let pp = pp_rules.(i) in - let (lev', pl) = pp.pptac_prods in - let p = pr_tacarg_using_rule pr_gen (pl,l) in - if lev' > lev then surround p else p + let args = List.map_filter filter_arg pp.pptac_prods in + let () = if not (List.for_all2eq check args l) then raise Not_found in + let p = pr_tacarg_using_rule pr_gen (pp.pptac_prods, l) in + if pp.pptac_level > lev then surround p else p with Not_found -> let name = str s.mltac_plugin ++ str "::" ++ str s.mltac_tactic ++ @@ -433,28 +376,35 @@ module Make in str "<" ++ name ++ str ">" ++ args - let pr_alias_gen pr_gen lev key l = + let pr_alias_gen check pr_gen lev key l = try let pp = KNmap.find key !prnotation_tab in - let (lev', pl) = pp.pptac_prods in - let p = pr_tacarg_using_rule pr_gen (pl, l) in - if lev' > lev then surround p else p + let args = List.map_filter filter_arg pp.pptac_prods in + let () = if not (List.for_all2eq check args l) then raise Not_found in + let p = pr_tacarg_using_rule pr_gen (pp.pptac_prods, l) in + if pp.pptac_level > lev then surround p else p with Not_found -> KerName.print key ++ spc() ++ pr_sequence pr_gen l ++ str" (* Generic printer *)" - let pr_raw_extend prc prlc prtac prpat = - pr_extend_gen (pr_raw_generic prc prlc prtac prpat pr_reference) - let pr_glob_extend prc prlc prtac prpat = - pr_extend_gen (pr_glb_generic prc prlc prtac prpat) - let pr_extend prc prlc prtac prpat = - pr_extend_gen (pr_top_generic prc prlc prtac prpat) + let check_type t arg = match t, arg with + | AnyArg t, TacGeneric arg -> argument_type_eq (unquote t) (genarg_tag arg) + | _ -> false + + let unwrap_gen f = function TacGeneric x -> f x | _ -> assert false + + let pr_raw_extend_rec prc prlc prtac prpat = + pr_extend_gen check_type (unwrap_gen (pr_raw_generic_rec prc prlc prtac prpat pr_reference)) + let pr_glob_extend_rec prc prlc prtac prpat = + pr_extend_gen check_type (unwrap_gen (pr_glb_generic_rec prc prlc prtac prpat)) + let pr_extend_rec prc prlc prtac prpat = + pr_extend_gen check_type (unwrap_gen (pr_top_generic_rec prc prlc prtac prpat)) let pr_raw_alias prc prlc prtac prpat = - pr_alias_gen (pr_raw_generic prc prlc prtac prpat pr_reference) + pr_alias_gen check_type (unwrap_gen (pr_raw_generic_rec prc prlc prtac prpat pr_reference)) let pr_glob_alias prc prlc prtac prpat = - pr_alias_gen (pr_glb_generic prc prlc prtac prpat) + pr_alias_gen check_type (unwrap_gen (pr_glb_generic_rec prc prlc prtac prpat)) let pr_alias prc prlc prtac prpat = - pr_alias_gen (pr_top_generic prc prlc prtac prpat) + pr_alias_gen check_type (unwrap_gen (pr_top_generic_rec prc prlc prtac prpat)) (**********************************************************************) (* The tactic printer *) @@ -586,8 +536,7 @@ module Make let pr_in_hyp_as prc pr_id = function | None -> mt () - | Some (clear,id,ipat) -> - pr_in (spc () ++ pr_clear_flag clear pr_id id) ++ pr_as_ipat prc ipat + | Some (id,ipat) -> pr_in (spc () ++ pr_id id) ++ pr_as_ipat prc ipat let pr_clauses default_is_concl pr_id = function | { onhyps=Some []; concl_occs=occs } @@ -722,11 +671,6 @@ module Make | l -> spc () ++ hov 2 (keyword "using" ++ spc () ++ prlist_with_sep pr_comma prc l) - let string_of_debug = function - | Off -> "" - | Debug -> "debug " - | Info -> "info_" - let pr_then () = str ";" let ltop = (5,E) @@ -752,7 +696,6 @@ module Make type 'a printer = { pr_tactic : tolerability -> 'tacexpr -> std_ppcmds; pr_constr : 'trm -> std_ppcmds; - pr_uconstr : 'utrm -> std_ppcmds; pr_lconstr : 'trm -> std_ppcmds; pr_dconstr : 'dtrm -> std_ppcmds; pr_pattern : 'pat -> std_ppcmds; @@ -761,13 +704,12 @@ module Make pr_reference : 'ref -> std_ppcmds; pr_name : 'nam -> std_ppcmds; pr_generic : 'lev generic_argument -> std_ppcmds; - pr_extend : int -> ml_tactic_entry -> 'lev generic_argument list -> std_ppcmds; - pr_alias : int -> KerName.t -> 'lev generic_argument list -> std_ppcmds; + pr_extend : int -> ml_tactic_entry -> 'a gen_tactic_arg list -> std_ppcmds; + pr_alias : int -> KerName.t -> 'a gen_tactic_arg list -> std_ppcmds; } constraint 'a = < term :'trm; - utrm :'utrm; dterm :'dtrm; pattern :'pat; constant :'cst; @@ -781,7 +723,6 @@ module Make (* some shortcuts *) let _pr_bindings = pr_bindings pr.pr_constr pr.pr_lconstr in - let pr_ex_bindings = pr_bindings_gen true pr.pr_constr pr.pr_lconstr in let pr_with_bindings = pr_with_bindings pr.pr_constr pr.pr_lconstr in let pr_with_bindings_arg_full = pr_with_bindings_arg in let pr_with_bindings_arg = pr_with_bindings_arg pr.pr_constr pr.pr_lconstr in @@ -849,9 +790,6 @@ module Make let rec pr_atom0 a = tag_atom a (match a with | TacIntroPattern [] -> primitive "intros" | TacIntroMove (None,MoveLast) -> primitive "intro" - | TacTrivial (d,[],Some []) -> str (string_of_debug d) ++ primitive "trivial" - | TacAuto (d,None,[],Some []) -> str (string_of_debug d) ++ primitive "auto" - | TacClear (true,[]) -> primitive "clear" | t -> str "(" ++ pr_atom1 t ++ str ")" ) @@ -886,13 +824,10 @@ module Make ++ pr_opt pr_eliminator cbo) | TacCase (ev,cb) -> hov 1 (primitive (with_evars ev "case") ++ spc () ++ pr_with_bindings_arg cb) - | TacFix (ido,n) -> hov 1 (primitive "fix" ++ pr_opt pr_id ido ++ pr_intarg n) | TacMutualFix (id,n,l) -> hov 1 ( primitive "fix" ++ spc () ++ pr_id id ++ pr_intarg n ++ spc() ++ keyword "with" ++ spc () ++ prlist_with_sep spc pr_fix_tac l) - | TacCofix ido -> - hov 1 (primitive "cofix" ++ pr_opt pr_id ido) | TacMutualCofix (id,l) -> hov 1 ( primitive "cofix" ++ spc () ++ pr_id id ++ spc() @@ -916,11 +851,6 @@ module Make pr_with_occurrences pr.pr_constr cl ++ pr_as_name na) l ) - | TacGeneralizeDep c -> - hov 1 ( - primitive "generalize" ++ spc () ++ str "dependent" - ++ pr_constrarg c - ) | TacLetTac (na,c,cl,true,_) when Locusops.is_nowhere cl -> hov 1 (primitive "pose" ++ pr_pose pr.pr_constr pr.pr_lconstr na c) | TacLetTac (na,c,cl,b,e) -> @@ -959,43 +889,7 @@ module Make ++ pr_arg pr_quantified_hypothesis h2 ) - (* Automation tactics *) - | TacTrivial (_,[],Some []) as x -> - pr_atom0 x - | TacTrivial (d,lems,db) -> - hov 0 ( - str (string_of_debug d) ++ primitive "trivial" - ++ pr_auto_using pr.pr_constr lems ++ pr_hintbases db - ) - | TacAuto (_,None,[],Some []) as x -> - pr_atom0 x - | TacAuto (d,n,lems,db) -> - hov 0 ( - str (string_of_debug d) ++ primitive "auto" - ++ pr_opt (pr_or_var int) n - ++ pr_auto_using pr.pr_constr lems ++ pr_hintbases db - ) - (* Context management *) - | TacClear (true,[]) as t -> - pr_atom0 t - | TacClear (keep,l) -> - hov 1 ( - primitive "clear" ++ spc () - ++ (if keep then str "- " else mt ()) - ++ prlist_with_sep spc pr.pr_name l - ) - | TacClearBody l -> - hov 1 ( - primitive "clearbody" ++ spc () - ++ prlist_with_sep spc pr.pr_name l - ) - | TacMove (id1,id2) -> - hov 1 ( - primitive "move" - ++ brk (1,1) ++ pr.pr_name id1 - ++ Miscprint.pr_move_location pr.pr_name id2 - ) | TacRename l -> hov 1 ( primitive "rename" ++ brk (1,1) @@ -1006,13 +900,6 @@ module Make l ) - (* Constructors *) - | TacSplit (ev,l) -> - hov 1 ( - primitive (with_evars ev "exists") - ++ prlist_with_sep (fun () -> str",") pr_ex_bindings l - ) - (* Conversion *) | TacReduce (r,h) -> hov 1 ( @@ -1032,10 +919,6 @@ module Make ) ++ pr.pr_dconstr c ++ pr_clauses (Some true) pr.pr_name h ) - (* Equivalence relations *) - | TacSymmetry cls -> - primitive "symmetry" ++ pr_clauses (Some true) pr.pr_name cls - (* Equality and inversion *) | TacRewrite (ev,l,cl,by) -> hov 1 ( @@ -1257,26 +1140,17 @@ module Make | TacML (loc,s,l) -> pr_with_comments loc (pr.pr_extend 1 s l), lcall | TacAlias (loc,kn,l) -> - pr_with_comments loc (pr.pr_alias (level_of inherited) kn (List.map snd l)), latom + pr_with_comments loc (pr.pr_alias (level_of inherited) kn l), latom ) in if prec_less prec inherited then strm else str"(" ++ strm ++ str")" and pr_tacarg = function - | TacDynamic (loc,t) -> - pr_with_comments loc - (str "<" ++ keyword "dynamic" ++ str " [" ++ str (Dyn.tag t) ++ str "]>") - | MetaIdArg (loc,true,s) -> - pr_with_comments loc (str "$" ++ str s) - | MetaIdArg (loc,false,s) -> - pr_with_comments loc (keyword "constr:" ++ str " $" ++ str s) | Reference r -> pr.pr_reference r | ConstrMayEval c -> pr_may_eval pr.pr_constr pr.pr_lconstr pr.pr_constant pr.pr_pattern c - | UConstr c -> - keyword "uconstr:" ++ pr.pr_uconstr c | TacFreshId l -> keyword "fresh" ++ pr_fresh_ids l | TacPretype c -> @@ -1304,7 +1178,6 @@ module Make let pr = { pr_tactic = pr_raw_tactic_level; pr_constr = pr_constr_expr; - pr_uconstr = pr_constr_expr; pr_dconstr = pr_constr_expr; pr_lconstr = pr_lconstr_expr; pr_pattern = pr_constr_pattern_expr; @@ -1313,7 +1186,7 @@ module Make pr_reference = pr_reference; pr_name = pr_lident; pr_generic = Genprint.generic_raw_print; - pr_extend = pr_raw_extend pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr; + pr_extend = pr_raw_extend_rec pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr; pr_alias = pr_raw_alias pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr; } in make_pr_tac @@ -1327,7 +1200,7 @@ module Make let pr_pat_and_constr_expr pr ((c,_),_) = pr c - let rec pr_glob_tactic_level env n t = + let pr_glob_tactic_level env n t = let glob_printers = (strip_prod_binders_glob_constr) in @@ -1335,7 +1208,6 @@ module Make let pr = { pr_tactic = prtac; pr_constr = pr_and_constr_expr (pr_glob_constr_env env); - pr_uconstr = pr_and_constr_expr (pr_glob_constr_env env); pr_dconstr = pr_and_constr_expr (pr_glob_constr_env env); pr_lconstr = pr_and_constr_expr (pr_lglob_constr_env env); pr_pattern = pr_pat_and_constr_expr (pr_glob_constr_env env); @@ -1344,7 +1216,7 @@ module Make pr_reference = pr_ltac_or_var (pr_located pr_ltac_constant); pr_name = pr_lident; pr_generic = Genprint.generic_glb_print; - pr_extend = pr_glob_extend + pr_extend = pr_glob_extend_rec (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) prtac (pr_pat_and_constr_expr (pr_glob_constr_env env)); pr_alias = pr_glob_alias @@ -1377,7 +1249,6 @@ module Make let pr = { pr_tactic = pr_glob_tactic_level env; pr_constr = pr_constr_env env Evd.empty; - pr_uconstr = pr_closed_glob_env env Evd.empty; pr_dconstr = pr_and_constr_expr (pr_glob_constr_env env); pr_lconstr = pr_lconstr_env env Evd.empty; pr_pattern = pr_constr_pattern_env env Evd.empty; @@ -1386,12 +1257,12 @@ module Make pr_reference = pr_located pr_ltac_constant; pr_name = pr_id; pr_generic = Genprint.generic_top_print; - pr_extend = pr_extend + pr_extend = pr_extend_rec (pr_constr_env env Evd.empty) (pr_lconstr_env env Evd.empty) - (pr_glob_tactic_level env) pr_constr_pattern; + pr_value pr_constr_pattern; pr_alias = pr_alias (pr_constr_env env Evd.empty) (pr_lconstr_env env Evd.empty) - (pr_glob_tactic_level env) pr_constr_pattern; + pr_value pr_constr_pattern; } in make_pr_tac @@ -1401,6 +1272,39 @@ module Make in prtac n t + let pr_raw_generic env = pr_raw_generic_rec + pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr pr_reference + + let pr_glb_generic env = pr_glb_generic_rec + (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) + (pr_glob_tactic_level env) (pr_pat_and_constr_expr (pr_glob_constr_env env)) + + let pr_top_generic env = pr_top_generic_rec + (pr_constr_env env Evd.empty) (pr_lconstr_env env Evd.empty) + pr_value pr_constr_pattern + + let pr_raw_extend env = pr_raw_extend_rec + pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr + + let pr_glob_extend env = pr_glob_extend_rec + (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) + (pr_glob_tactic_level env) (pr_pat_and_constr_expr (pr_glob_constr_env env)) + + let check_val_type t arg = + let AnyArg t = t in +(* let t = Genarg.val_tag (Obj.magic t) in *) +(* let Val.Dyn (t', _) = arg in *) +(* match Genarg.Val.eq t t' with *) +(* | None -> false *) +(* | Some _ -> true *) + true (** FIXME *) + + let pr_alias pr lev key args = + pr_alias_gen check_val_type pr lev key args + + let pr_extend pr lev ml args = + pr_extend_gen check_val_type pr lev ml args + let pr_tactic env = pr_tactic_level env ltop end @@ -1444,8 +1348,14 @@ let () = let pr_bool b = if b then str "true" else str "false" in let pr_unit _ = str "()" in let pr_string s = str "\"" ++ str s ++ str "\"" in + Genprint.register_print0 Constrarg.wit_int_or_var + (pr_or_var int) (pr_or_var int) int; Genprint.register_print0 Constrarg.wit_ref pr_reference (pr_or_var (pr_located pr_global)) pr_global; + Genprint.register_print0 Constrarg.wit_ident + pr_id pr_id pr_id; + Genprint.register_print0 Constrarg.wit_var + (pr_located pr_id) (pr_located pr_id) pr_id; Genprint.register_print0 Constrarg.wit_intro_pattern (Miscprint.pr_intro_pattern pr_constr_expr) @@ -1460,11 +1370,41 @@ let () = Genprint.register_print0 Constrarg.wit_sort pr_glob_sort pr_glob_sort (pr_sort Evd.empty); Genprint.register_print0 + Constrarg.wit_constr + Ppconstr.pr_constr_expr + (fun (c, _) -> Printer.pr_glob_constr c) + Printer.pr_constr + ; + Genprint.register_print0 Constrarg.wit_uconstr Ppconstr.pr_constr_expr (fun (c,_) -> Printer.pr_glob_constr c) Printer.pr_closed_glob ; + Genprint.register_print0 + Constrarg.wit_open_constr + Ppconstr.pr_constr_expr + (fun (c, _) -> Printer.pr_glob_constr c) + Printer.pr_constr + ; + Genprint.register_print0 Constrarg.wit_red_expr + (pr_red_expr (pr_constr_expr, pr_lconstr_expr, pr_or_by_notation pr_reference, pr_constr_pattern_expr)) + (pr_red_expr (pr_and_constr_expr pr_glob_constr, pr_lglob_constr, pr_or_var (pr_and_short_name pr_evaluable_reference), pr_pat_and_constr_expr pr_glob_constr)) + (pr_red_expr (pr_constr, pr_lconstr, pr_evaluable_reference, pr_constr_pattern)); + Genprint.register_print0 Constrarg.wit_quant_hyp pr_quantified_hypothesis pr_quantified_hypothesis pr_quantified_hypothesis; + Genprint.register_print0 Constrarg.wit_bindings + (pr_bindings_no_with pr_constr_expr pr_lconstr_expr) + (pr_bindings_no_with (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr)) + (fun it -> pr_bindings_no_with pr_constr pr_lconstr (fst (run_delayed it))); + Genprint.register_print0 Constrarg.wit_constr_may_eval + (pr_may_eval pr_constr_expr pr_lconstr_expr (pr_or_by_notation pr_reference) pr_constr_pattern_expr) + (pr_may_eval (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr) + (pr_or_var (pr_and_short_name pr_evaluable_reference)) (pr_pat_and_constr_expr pr_glob_constr)) + pr_constr; + Genprint.register_print0 Constrarg.wit_constr_with_bindings + (pr_with_bindings pr_constr_expr pr_lconstr_expr) + (pr_with_bindings (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr)) + (fun it -> pr_with_bindings pr_constr pr_lconstr (fst (run_delayed it))); Genprint.register_print0 Stdarg.wit_int int int int; Genprint.register_print0 Stdarg.wit_bool pr_bool pr_bool pr_bool; Genprint.register_print0 Stdarg.wit_unit pr_unit pr_unit pr_unit; @@ -1475,16 +1415,10 @@ let () = let printer _ _ prtac = prtac (0, E) in declare_extra_genarg_pprule wit_tactic printer printer printer -let _ = Hook.set Tactic_debug.tactic_printer - (fun x -> pr_glob_tactic (Global.env()) x) - -let _ = Hook.set Tactic_debug.match_pattern_printer - (fun env sigma hyp -> pr_match_pattern (pr_constr_pattern_env env sigma) hyp) - -let _ = Hook.set Tactic_debug.match_rule_printer - (fun rl -> - pr_match_rule false (pr_glob_tactic (Global.env())) - (fun (_,p) -> pr_constr_pattern p) rl) +let () = + let pr_unit _ _ _ () = str "()" in + let printer _ _ prtac = prtac (0, E) in + declare_extra_genarg_pprule wit_ltac printer printer pr_unit module Richpp = struct diff --git a/printing/pptactic.mli b/printing/pptactic.mli index 30b9483db..31a5a5d4a 100644 --- a/printing/pptactic.mli +++ b/printing/pptactic.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -32,7 +32,7 @@ type 'a glob_extra_genarg_printer = type 'a extra_genarg_printer = (Term.constr -> std_ppcmds) -> (Term.constr -> std_ppcmds) -> - (tolerability -> glob_tactic_expr -> std_ppcmds) -> + (tolerability -> Val.t -> std_ppcmds) -> 'a -> std_ppcmds val declare_extra_genarg_pprule : @@ -41,11 +41,11 @@ val declare_extra_genarg_pprule : 'b glob_extra_genarg_printer -> 'c extra_genarg_printer -> unit -type grammar_terminals = string option list +type grammar_terminals = Tacexpr.raw_tactic_expr Egramml.grammar_prod_item list type pp_tactic = { - pptac_args : argument_type list; - pptac_prods : int * grammar_terminals; + pptac_level : int; + pptac_prods : grammar_terminals; } val declare_ml_tactic_pprule : ml_tactic_name -> pp_tactic array -> unit diff --git a/printing/pptacticsig.mli b/printing/pptacticsig.mli index 1631bda37..b98b6c67e 100644 --- a/printing/pptacticsig.mli +++ b/printing/pptacticsig.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,11 +8,9 @@ open Pp open Genarg -open Constrexpr open Tacexpr open Ppextend open Environ -open Pattern open Misctypes module type Pp = sig @@ -32,46 +30,24 @@ module type Pp = sig val pr_clauses : bool option -> ('a -> Pp.std_ppcmds) -> 'a Locus.clause_expr -> Pp.std_ppcmds - val pr_raw_generic : - (constr_expr -> std_ppcmds) -> - (constr_expr -> std_ppcmds) -> - (tolerability -> raw_tactic_expr -> std_ppcmds) -> - (constr_expr -> std_ppcmds) -> - (Libnames.reference -> std_ppcmds) -> rlevel generic_argument -> - std_ppcmds - - val pr_glb_generic : - (glob_constr_and_expr -> Pp.std_ppcmds) -> - (glob_constr_and_expr -> Pp.std_ppcmds) -> - (tolerability -> glob_tactic_expr -> std_ppcmds) -> - (glob_constr_pattern_and_expr -> std_ppcmds) -> - glevel generic_argument -> std_ppcmds - - val pr_top_generic : - (Term.constr -> std_ppcmds) -> - (Term.constr -> std_ppcmds) -> - (tolerability -> glob_tactic_expr -> std_ppcmds) -> - (Pattern.constr_pattern -> std_ppcmds) -> - tlevel generic_argument -> - std_ppcmds - - val pr_raw_extend: - (constr_expr -> std_ppcmds) -> (constr_expr -> std_ppcmds) -> - (tolerability -> raw_tactic_expr -> std_ppcmds) -> - (constr_expr -> std_ppcmds) -> int -> - ml_tactic_entry -> raw_generic_argument list -> std_ppcmds - - val pr_glob_extend: - (glob_constr_and_expr -> std_ppcmds) -> (glob_constr_and_expr -> std_ppcmds) -> - (tolerability -> glob_tactic_expr -> std_ppcmds) -> - (glob_constr_pattern_and_expr -> std_ppcmds) -> int -> - ml_tactic_entry -> glob_generic_argument list -> std_ppcmds + + val pr_raw_generic : env -> rlevel generic_argument -> std_ppcmds + + val pr_glb_generic : env -> glevel generic_argument -> std_ppcmds + + val pr_top_generic : env -> tlevel generic_argument -> std_ppcmds + + val pr_raw_extend: env -> int -> + ml_tactic_entry -> raw_tactic_arg list -> std_ppcmds + + val pr_glob_extend: env -> int -> + ml_tactic_entry -> glob_tactic_arg list -> std_ppcmds val pr_extend : - (Term.constr -> std_ppcmds) -> (Term.constr -> std_ppcmds) -> - (tolerability -> glob_tactic_expr -> std_ppcmds) -> - (constr_pattern -> std_ppcmds) -> int -> - ml_tactic_entry -> typed_generic_argument list -> std_ppcmds + (Val.t -> std_ppcmds) -> int -> ml_tactic_entry -> Val.t list -> std_ppcmds + + val pr_alias : (Val.t -> std_ppcmds) -> + int -> Names.KerName.t -> Val.t list -> std_ppcmds val pr_ltac_constant : Nametab.ltac_constant -> std_ppcmds @@ -91,4 +67,9 @@ module type Pp = sig ('constr -> std_ppcmds) -> ('constr -> std_ppcmds) -> 'constr bindings -> std_ppcmds + val pr_match_pattern : ('a -> std_ppcmds) -> 'a match_pattern -> std_ppcmds + + val pr_match_rule : bool -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) -> + ('b, 'a) match_rule -> std_ppcmds + end diff --git a/printing/pputils.ml b/printing/pputils.ml index ee1a39efd..906b463a8 100644 --- a/printing/pputils.ml +++ b/printing/pputils.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/printing/pputils.mli b/printing/pputils.mli index 728774832..a0f2c7728 100644 --- a/printing/pputils.mli +++ b/printing/pputils.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index 00c276bdb..c1f5e122b 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -79,13 +79,7 @@ module Make | VernacEndSubproof -> str"" | _ -> str"." - let pr_gen t = - pr_raw_generic - pr_constr_expr - pr_lconstr_expr - pr_raw_tactic_level - pr_constr_expr - pr_reference t + let pr_gen t = pr_raw_generic (Global.env ()) t let sep = fun _ -> spc() let sep_v2 = fun _ -> str"," ++ spc() @@ -111,10 +105,9 @@ module Make else id let pr_production_item = function - | TacNonTerm (loc,nt,Some (p,sep)) -> + | TacNonTerm (loc, nt, (p, sep)) -> let pp_sep = if not (String.is_empty sep) then str "," ++ quote (str sep) else mt () in str nt ++ str"(" ++ pr_id (strip_meta p) ++ pp_sep ++ str")" - | TacNonTerm (loc,nt,None) -> str nt | TacTerm s -> qs s let pr_comment pr_c = function @@ -385,17 +378,6 @@ module Make | l -> spc() ++ hov 1 (str"(" ++ prlist_with_sep sep_v2 pr_syntax_modifier l ++ str")") - let print_level n = - if not (Int.equal n 0) then - spc () ++ tag_keyword (str "(at level " ++ int n ++ str ")") - else - mt () - - let pr_grammar_tactic_rule n (_,pil,t) = - hov 2 (keyword "Tactic Notation" ++ print_level n ++ spc() ++ - hov 0 (prlist_with_sep sep pr_production_item pil ++ - spc() ++ str":=" ++ spc() ++ pr_raw_tactic t)) - let pr_univs pl = match pl with | None -> mt () @@ -473,8 +455,6 @@ module Make keyword "Print TypeClasses" | PrintInstances qid -> keyword "Print Instances" ++ spc () ++ pr_smart_global qid - | PrintLtac qid -> - keyword "Print Ltac" ++ spc() ++ pr_ltac_ref qid | PrintCoercions -> keyword "Print Coercions" | PrintCoercionPaths (s,t) -> @@ -493,8 +473,6 @@ module Make keyword "Print Hint *" | PrintHintDbName s -> keyword "Print HintDb" ++ spc () ++ str s - | PrintRewriteHintDbName s -> - keyword "Print Rewrite HintDb" ++ spc() ++ str s | PrintUniverses (b, fopt) -> let cmd = if b then "Print Sorted Universes" @@ -594,7 +572,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 @@ -640,10 +619,10 @@ module Make else spc() ++ qs s ) - | VernacTime v -> - return (keyword "Time" ++ spc() ++ pr_vernac_list v) - | VernacRedirect (s, v) -> - return (keyword "Redirect" ++ spc() ++ qs s ++ spc() ++ pr_vernac_list v) + | VernacTime (_,v) -> + return (keyword "Time" ++ spc() ++ pr_vernac v) + | VernacRedirect (s, (_,v)) -> + return (keyword "Redirect" ++ spc() ++ qs s ++ spc() ++ pr_vernac v) | VernacTimeout(n,v) -> return (keyword "Timeout " ++ int n ++ spc() ++ pr_vernac v) | VernacFail v -> @@ -652,8 +631,6 @@ module Make return (keyword "No-parsing-rule for VernacError") (* Syntax *) - | VernacTacticNotation (n,r,e) -> - return (pr_grammar_tactic_rule n ("",r,e)) | VernacOpenCloseScope (_,(opening,sc)) -> return ( keyword (if opening then "Open " else "Close ") ++ @@ -924,8 +901,9 @@ module Make hov 1 ( (if abst then keyword "Declare" ++ spc () else mt ()) ++ keyword "Instance" ++ - (match snd instid with Name id -> spc () ++ pr_lident (fst instid, id) ++ spc () | - Anonymous -> mt ()) ++ + (match instid with + | (loc, Name id), l -> spc () ++ pr_plident ((loc, id),l) ++ spc () + | (_, Anonymous), _ -> mt ()) ++ pr_and_type_binders_arg sup ++ str":" ++ spc () ++ pr_constr cl ++ pr_priority pri ++ @@ -986,24 +964,6 @@ module Make prlist_with_sep (fun () -> str " <+ ") pr_m mexprs) ) (* Solving *) - | VernacSolve (i,info,tac,deftac) -> - let pr_goal_selector = function - | SelectNth i -> int i ++ str":" - | SelectId id -> pr_id id ++ str":" - | SelectAll -> str"all" ++ str":" - | SelectAllParallel -> str"par" - in - let pr_info = - match info with - | None -> mt () - | Some i -> str"Info"++spc()++int i++spc() - in - return ( - (if i = Proof_global.get_default_goal_selector () then mt() else pr_goal_selector i) ++ - pr_info ++ - pr_raw_tactic tac - ++ (if deftac then str ".." else mt ()) - ) | VernacSolveExistential (i,c) -> return (keyword "Existential" ++ spc () ++ int i ++ pr_lconstrarg c) @@ -1035,24 +995,6 @@ module Make return (keyword "Cd" ++ pr_opt qs s) (* Commands *) - | VernacDeclareTacticDefinition (rc,l) -> - let pr_tac_body (id, redef, body) = - let idl, body = - match body with - | Tacexpr.TacFun (idl,b) -> idl,b - | _ -> [], body in - pr_ltac_ref id ++ - prlist (function None -> str " _" - | Some id -> spc () ++ pr_id id) idl - ++ (if redef then str" ::=" else str" :=") ++ brk(1,1) ++ - pr_raw_tactic body - in - return ( - hov 1 - (keyword "Ltac" ++ spc () ++ - prlist_with_sep (fun () -> - fnl() ++ keyword "with" ++ spc ()) pr_tac_body l) - ) | VernacCreateHintDb (dbname,b) -> return ( hov 1 (keyword "Create HintDb" ++ spc () ++ @@ -1229,8 +1171,6 @@ module Make (keyword "Comments" ++ spc() ++ prlist_with_sep sep (pr_comment pr_constr) l) ) - | VernacNop -> - mt() (* Toplevel control *) | VernacToplevelControl exn -> @@ -1267,11 +1207,6 @@ module Make | VernacEndSubproof -> return (str "}") - and pr_vernac_list l = - hov 2 (str"[" ++ spc() ++ - prlist (fun v -> pr_located pr_vernac v ++ sep_end (snd v) ++ fnl()) l - ++ spc() ++ str"]") - and pr_extend s cl = let pr_arg a = try pr_gen a diff --git a/printing/ppvernac.mli b/printing/ppvernac.mli index f38848cdc..d3d4a5ceb 100644 --- a/printing/ppvernac.mli +++ b/printing/ppvernac.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/printing/ppvernacsig.mli b/printing/ppvernacsig.mli index cfcd49744..5d1c89332 100644 --- a/printing/ppvernacsig.mli +++ b/printing/ppvernacsig.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/printing/prettyp.ml b/printing/prettyp.ml index b8c5fd4cf..9745a7925 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -35,7 +35,7 @@ type object_pr = { print_syntactic_def : kernel_name -> std_ppcmds; print_module : bool -> Names.module_path -> std_ppcmds; print_modtype : module_path -> std_ppcmds; - print_named_decl : Id.t * constr option * types -> std_ppcmds; + print_named_decl : Context.Named.Declaration.t -> std_ppcmds; print_library_entry : bool -> (object_name * Lib.node) -> std_ppcmds option; print_context : bool -> int option -> Lib.library_segment -> std_ppcmds; print_typed_value_in_env : Environ.env -> Evd.evar_map -> Term.constr * Term.types -> Pp.std_ppcmds; @@ -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 *) @@ -125,7 +132,8 @@ let print_renames_list prefix l = let need_expansion impl ref = let typ = Global.type_of_global_unsafe ref in let ctx = prod_assum typ in - let nprods = List.length (List.filter (fun (_,b,_) -> Option.is_empty b) ctx) in + let open Context.Rel.Declaration in + let nprods = List.count is_local_assum ctx in not (List.is_empty impl) && List.length impl >= nprods && let _,lastimpl = List.chop nprods impl in List.exists is_status_implicit lastimpl @@ -161,8 +169,10 @@ type opacity = | FullyOpaque | TransparentMaybeOpacified of Conv_oracle.level -let opacity env = function - | VarRef v when not (Option.is_empty (pi2 (Environ.lookup_named v env))) -> +let opacity env = + let open Context.Named.Declaration in + function + | VarRef v when is_local_def (Environ.lookup_named v env) -> Some(TransparentMaybeOpacified (Conv_oracle.get_strategy (Environ.oracle env) (VarKey v))) | ConstRef cst -> @@ -208,8 +218,8 @@ let print_polymorphism ref = let print_primitive_record recflag mipv = function | Some (Some (_, ps,_)) -> let eta = match recflag with - | Decl_kinds.CoFinite -> mt () - | Decl_kinds.Finite | Decl_kinds.BiFinite -> str " and has eta conversion" + | Decl_kinds.CoFinite | Decl_kinds.Finite -> mt () + | Decl_kinds.BiFinite -> str " and has eta conversion" in [pr_id mipv.(0).mind_typename ++ str" is primitive" ++ eta ++ str"."] | _ -> [] @@ -433,11 +443,13 @@ let print_named_def name body typ = let print_named_assum name typ = str "*** [" ++ str name ++ str " : " ++ pr_ltype typ ++ str "]" -let gallina_print_named_decl (id,c,typ) = - let s = Id.to_string id in - match c with - | Some body -> print_named_def s body typ - | None -> print_named_assum s typ +let gallina_print_named_decl = + let open Context.Named.Declaration in + function + | LocalAssum (id, typ) -> + print_named_assum (Id.to_string id) typ + | LocalDef (id, body, typ) -> + print_named_def (Id.to_string id) body typ let assumptions_for_print lna = List.fold_right (fun na env -> add_name na env) lna empty_names_context @@ -463,16 +475,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 @@ -481,17 +498,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 ++ @@ -703,8 +726,8 @@ let print_any_name = function try (* Var locale de but, pas var de section... donc pas d'implicits *) let dir,str = repr_qualid qid in if not (DirPath.is_empty dir) then raise Not_found; - let (_,c,typ) = Global.lookup_named str in - (print_named_decl (str,c,typ)) + let open Context.Named.Declaration in + str |> Global.lookup_named |> set_id str |> print_named_decl with Not_found -> errorlabstrm "print_name" (pr_qualid qid ++ spc () ++ str "not a defined object.") @@ -732,8 +755,8 @@ let print_opaque_name qid = let ty = Universes.unsafe_type_of_global gr in print_typed_value (mkConstruct cstr, ty) | VarRef id -> - let (_,c,ty) = lookup_named id env in - print_named_decl (id,c,ty) + let open Context.Named.Declaration in + lookup_named id env |> set_id id |> print_named_decl let print_about_any loc k = match k with diff --git a/printing/prettyp.mli b/printing/prettyp.mli index 6216d4d53..0eab15579 100644 --- a/printing/prettyp.mli +++ b/printing/prettyp.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -66,7 +66,7 @@ type object_pr = { print_syntactic_def : kernel_name -> std_ppcmds; print_module : bool -> Names.module_path -> std_ppcmds; print_modtype : module_path -> std_ppcmds; - print_named_decl : Id.t * constr option * types -> std_ppcmds; + print_named_decl : Context.Named.Declaration.t -> std_ppcmds; print_library_entry : bool -> (object_name * Lib.node) -> std_ppcmds option; print_context : bool -> int option -> Lib.library_segment -> std_ppcmds; print_typed_value_in_env : Environ.env -> Evd.evar_map -> Term.constr * Term.types -> Pp.std_ppcmds; diff --git a/printing/printer.ml b/printing/printer.ml index 12782a428..22bc122bd 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -30,7 +30,8 @@ let delayed_emacs_cmd s = 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) (**********************************************************************) (** Terms *) @@ -50,7 +51,7 @@ let pr_lconstr_core goal_concl_style env sigma t = let pr_lconstr_env env = pr_lconstr_core false env let pr_constr_env env = pr_constr_core false env -let _ = Hook.set Proofview.Refine.pr_constr pr_constr_env +let _ = Hook.set Refine.pr_constr pr_constr_env let pr_lconstr_goal_style_env env = pr_lconstr_core true env let pr_constr_goal_style_env env = pr_constr_core true env @@ -208,10 +209,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() @@ -262,16 +263,19 @@ let pr_var_decl_skel pr_id env sigma (id,c,typ) = let ptyp = (str" : " ++ pt) in (pr_id id ++ hov 0 (pbody ++ ptyp)) -let pr_var_decl env sigma (id,c,typ) = - pr_var_decl_skel pr_id env sigma (id,c,typ) +let pr_var_decl env sigma d = + pr_var_decl_skel pr_id env sigma (Context.Named.Declaration.to_tuple d) let pr_var_list_decl env sigma (l,c,typ) = hov 0 (pr_var_decl_skel (fun ids -> prlist_with_sep pr_comma pr_id ids) env sigma (l,c,typ)) -let pr_rel_decl env sigma (na,c,typ) = - let pbody = match c with - | None -> mt () - | Some c -> +let pr_rel_decl env sigma decl = + let open Context.Rel.Declaration in + let na = get_name decl in + let typ = get_type decl in + let pbody = match decl with + | LocalAssum _ -> mt () + | LocalDef (_,c,_) -> (* Force evaluation *) let pb = pr_lconstr_env env sigma c in let pb = if isCast c then surround pb else pb in @@ -293,7 +297,7 @@ let pr_named_context_of env sigma = hv 0 (prlist_with_sep (fun _ -> ws 2) (fun x -> x) psl) let pr_named_context env sigma ne_context = - hv 0 (Context.fold_named_context + hv 0 (Context.Named.fold_outside (fun d pps -> pps ++ ws 2 ++ pr_var_decl env sigma d) ne_context ~init:(mt ())) @@ -306,7 +310,7 @@ let pr_rel_context_of env sigma = (* Prints an env (variables and de Bruijn). Separator: newline *) let pr_context_unlimited env sigma = let sign_env = - Context.fold_named_list_context + Context.NamedList.fold (fun d pps -> let pidt = pr_var_list_decl env sigma d in (pps ++ fnl () ++ pidt)) @@ -333,7 +337,7 @@ let pr_context_limit n env sigma = else let k = lgsign-n in let _,sign_env = - Context.fold_named_list_context + Context.NamedList.fold (fun d (i,pps) -> if i < k then (i+1, (pps ++str ".")) @@ -400,7 +404,7 @@ let display_name = false (* display a goal name *) let pr_goal_name sigma g = - if display_name then str " " ++ Pp.surround (pr_id (Evd.evar_ident g sigma)) + if display_name then str " " ++ Pp.surround (pr_existential_key sigma g) else mt () (* display the conclusion of a goal *) @@ -420,7 +424,8 @@ let pr_evgl_sign sigma evi = | None -> [], [] | Some f -> List.filter2 (fun b c -> not b) f (evar_context evi) in - let ids = List.rev_map pi1 l in + let open Context.Named.Declaration in + let ids = List.rev_map get_id l in let warn = if List.is_empty ids then mt () else (str "(" ++ prlist_with_sep pr_comma pr_id ids ++ str " cannot be used)") @@ -455,14 +460,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 @@ -636,8 +644,8 @@ let pr_open_subgoals ?(proof=Proof_global.give_me_the_proof ()) () = | _ , _, _ -> let end_cmd = 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) ++ + (let s = Proof_global.Bullet.suggest p in + if Pp.is_empty s then s else fnl () ++ s) ++ fnl () in pr_subgoals ~pr_first:false (Some end_cmd) bsigma seeds shelf [] bgoals @@ -652,9 +660,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 " ++ str id ++ str " is:" ++ cut () + v 0 (str "goal / evar " ++ str uid ++ str " is:" ++ cut () ++ pr_goal gs) in try @@ -715,7 +731,7 @@ let prterm = pr_lconstr type context_object = | Variable of Id.t (* A section variable or a Let definition *) - | Axiom of constant * (Label.t * Context.rel_context * types) list + | Axiom of constant * (Label.t * Context.Rel.t * types) list | Opaque of constant (* An opaque constant. *) | Transparent of constant @@ -765,7 +781,7 @@ let pr_assumptionset env s = let (v, a, o, tr) = accu in match t with | Variable id -> - let var = str (Id.to_string id) ++ str " : " ++ pr_ltype typ in + let var = pr_id id ++ str " : " ++ pr_ltype typ in (var :: v, a, o, tr) | Axiom (kn,[]) -> let ax = safe_pr_constant env kn ++ safe_pr_ltype typ in @@ -774,7 +790,7 @@ let pr_assumptionset env s = 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 " used in " ++ pr_label lbl ++ str " to prove:" ++ safe_pr_ltype_relctx (ctx,ty)) l in (v, ax :: a, o, tr) @@ -824,3 +840,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 5f56adbe6..70993bb72 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -10,7 +10,6 @@ open Pp open Names open Globnames open Term -open Context open Environ open Pattern open Evd @@ -84,7 +83,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 *) @@ -108,13 +108,13 @@ val pr_pconstructor : env -> pconstructor -> std_ppcmds val pr_context_unlimited : env -> evar_map -> std_ppcmds val pr_ne_context_of : std_ppcmds -> env -> evar_map -> std_ppcmds -val pr_var_decl : env -> evar_map -> named_declaration -> std_ppcmds -val pr_var_list_decl : env -> evar_map -> named_list_declaration -> std_ppcmds -val pr_rel_decl : env -> evar_map -> rel_declaration -> std_ppcmds +val pr_var_decl : env -> evar_map -> Context.Named.Declaration.t -> std_ppcmds +val pr_var_list_decl : env -> evar_map -> Context.NamedList.Declaration.t -> std_ppcmds +val pr_rel_decl : env -> evar_map -> Context.Rel.Declaration.t -> std_ppcmds -val pr_named_context : env -> evar_map -> named_context -> std_ppcmds +val pr_named_context : env -> evar_map -> Context.Named.t -> std_ppcmds val pr_named_context_of : env -> evar_map -> std_ppcmds -val pr_rel_context : env -> evar_map -> rel_context -> std_ppcmds +val pr_rel_context : env -> evar_map -> Context.Rel.t -> std_ppcmds val pr_rel_context_of : env -> evar_map -> std_ppcmds val pr_context_of : env -> evar_map -> std_ppcmds @@ -164,7 +164,7 @@ val prterm : constr -> std_ppcmds (** = pr_lconstr *) 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 + | Axiom of constant * (Label.t * Context.Rel.t * types) list | Opaque of constant (** An opaque constant. *) | Transparent of constant (** A transparent constant *) @@ -175,7 +175,8 @@ module ContextObjectMap : CMap.ExtS val pr_assumptionset : 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/printmod.ml b/printing/printmod.ml index 53d0508c7..9354cd28d 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -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,21 +83,26 @@ 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 let mip = mib.mind_packets.(i) in let params = Inductive.inductive_paramdecls (mib,u) in - let args = extended_rel_list 0 params in + let args = Context.Rel.to_extended_list 0 params in let arity = hnf_prod_applist env (build_ind_type env ((mib,mip),u)) args in 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 = @@ -136,12 +143,14 @@ let print_record env mind mib = in let mip = mib.mind_packets.(0) in let params = Inductive.inductive_paramdecls (mib,u) in - let args = extended_rel_list 0 params in + let args = Context.Rel.to_extended_list 0 params in let arity = hnf_prod_applist env (build_ind_type env ((mib,mip),u)) args in let cstrtypes = Inductive.type_of_constructors ((mind,0),u) (mib,mip) in 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 @@ -254,7 +263,7 @@ let nametab_register_modparam mbid mtb = List.iter (nametab_register_body mp dir) struc let print_body is_impl env mp (l,body) = - let name = str (Label.to_string l) in + let name = pr_label l in hov 2 (match body with | SFBmodule _ -> keyword "Module" ++ spc () ++ name | SFBmodtype _ -> keyword "Module Type" ++ spc () ++ name @@ -263,6 +272,7 @@ let print_body is_impl env mp (l,body) = 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 () @@ -271,17 +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 *) + 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 + Printer.pr_lconstr_env env sigma (Vars.subst_instance_constr u (Mod_subst.force_constr l))) | _ -> mt ()) ++ str "." ++ - Printer.pr_universe_ctx (Univ.instantiate_univ_context cb.const_universes)) + Printer.pr_universe_ctx sigma (Univ.instantiate_univ_context cb.const_universes)) | SFBmind mib -> try let env = Option.get env in diff --git a/printing/printmod.mli b/printing/printmod.mli index bea475345..7f7d34392 100644 --- a/printing/printmod.mli +++ b/printing/printmod.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/printing/printmodsig.mli b/printing/printmodsig.mli index 5d0d4ab0b..f71fffdce 100644 --- a/printing/printmodsig.mli +++ b/printing/printmodsig.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/printing/richprinter.mli b/printing/richprinter.mli index 41c313514..261d22c4c 100644 --- a/printing/richprinter.mli +++ b/printing/richprinter.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/proofs/clenv.ml b/proofs/clenv.ml index ae790d9b8..1ef0b087b 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -345,15 +345,6 @@ let clenv_pose_metas_as_evars clenv dep_mvs = (******************************************************************) -let connect_clenv gls clenv = - let evd = evars_reset_evd ~with_conv_pbs:true gls.sigma clenv.evd in - { clenv with - evd = evd ; - env = Goal.V82.env evd (sig_it gls) } - -(* let connect_clenv_key = Profile.declare_profile "connect_clenv";; *) -(* let connect_clenv = Profile.profile2 connect_clenv_key connect_clenv *) - (* [clenv_fchain mv clenv clenv'] * * Resolves the value of "mv" (which must be undefined) in clenv to be @@ -382,12 +373,12 @@ let fchain_flags () = { (default_unify_flags ()) with allow_K_in_toplevel_higher_order_unification = true } -let clenv_fchain ?(flags=fchain_flags ()) mv clenv nextclenv = +let clenv_fchain ?with_univs ?(flags=fchain_flags ()) mv clenv nextclenv = (* Add the metavars of [nextclenv] to [clenv], with their name-environment *) let clenv' = { templval = clenv.templval; templtyp = clenv.templtyp; - evd = meta_merge nextclenv.evd clenv.evd; + evd = meta_merge ?with_univs nextclenv.evd clenv.evd; env = nextclenv.env } in (* unify the type of the template of [nextclenv] with the type of [mv] *) let clenv'' = diff --git a/proofs/clenv.mli b/proofs/clenv.mli index eb1081706..59b166ea0 100644 --- a/proofs/clenv.mli +++ b/proofs/clenv.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -49,9 +49,8 @@ val refresh_undefined_univs : clausenv -> clausenv * Univ.universe_level_subst (** {6 linking of clenvs } *) -val connect_clenv : Goal.goal sigma -> clausenv -> clausenv val clenv_fchain : - ?flags:unify_flags -> metavariable -> clausenv -> clausenv -> clausenv + ?with_univs:bool -> ?flags:unify_flags -> metavariable -> clausenv -> clausenv -> clausenv (** {6 Unification with clenvs } *) diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml index 894b290f1..08e6c91de 100644 --- a/proofs/clenvtac.ml +++ b/proofs/clenvtac.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/proofs/clenvtac.mli b/proofs/clenvtac.mli index ea2043613..00e74a247 100644 --- a/proofs/clenvtac.mli +++ b/proofs/clenvtac.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/proofs/evar_refiner.ml b/proofs/evar_refiner.ml index 9b358210a..3192a6a29 100644 --- a/proofs/evar_refiner.ml +++ b/proofs/evar_refiner.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -59,14 +59,3 @@ let w_refine (evk,evi) (ltac_var,rawc) sigma = str (string_of_existential evk)) in define_and_solve_constraints evk typed_c env (evars_reset_evd sigma' sigma) - -(* vernac command Existential *) - -(* Main component of vernac command Existential *) -let instantiate_pf_com evk com sigma = - let evi = Evd.find sigma evk in - let env = Evd.evar_filtered_env evi in - let rawc = Constrintern.intern_constr env com in - let ltac_vars = Pretyping.empty_lvar in - let sigma' = w_refine (evk, evi) (ltac_vars, rawc) sigma in - sigma' diff --git a/proofs/evar_refiner.mli b/proofs/evar_refiner.mli index 673dad55d..e3778e94c 100644 --- a/proofs/evar_refiner.mli +++ b/proofs/evar_refiner.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -13,8 +13,3 @@ open Pretyping val w_refine : evar * evar_info -> glob_constr_ltac_closure -> evar_map -> evar_map - -val instantiate_pf_com : - Evd.evar -> Constrexpr.constr_expr -> Evd.evar_map -> Evd.evar_map - -(** the instantiate tactic was moved to [tactics/evar_tactics.ml] *) diff --git a/proofs/goal.ml b/proofs/goal.ml index 107ce7f8e..111a947a9 100644 --- a/proofs/goal.ml +++ b/proofs/goal.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -9,6 +9,8 @@ open Util open Pp open Term +open Sigma.Notations +open Context.Named.Declaration (* This module implements the abstract interface to goals *) (* A general invariant of the module, is that a goal whose associated @@ -70,10 +72,12 @@ module V82 = struct Evd.evar_extra = extra } in let evi = Typeclasses.mark_unresolvable evi in - let (evars, evk) = Evarutil.new_pure_evar_full evars evi in + let evars = Sigma.Unsafe.of_evar_map evars in + let Sigma (evk, evars, _) = Evarutil.new_pure_evar_full evars evi in + let evars = Sigma.to_evar_map evars in let evars = Evd.restore_future_goals evars prev_future_goals prev_principal_goal in let ctxt = Environ.named_context_of_val hyps in - let inst = Array.map_of_list (fun (id, _, _) -> mkVar id) ctxt in + let inst = Array.map_of_list (mkVar % get_id) ctxt in let ev = Term.mkEvar (evk,inst) in (evk, ev, evars) @@ -89,7 +93,10 @@ module V82 = struct (* Instantiates a goal with an open term, using name of goal for evk' *) let partial_solution_to sigma evk evk' c = let id = Evd.evar_ident evk sigma in - Evd.rename evk' id (partial_solution sigma evk c) + let sigma = partial_solution sigma evk c in + match id with + | None -> sigma + | Some id -> Evd.rename evk' id sigma (* Parts of the progress tactical *) let same_goal evars1 gl1 evars2 gl2 = @@ -123,8 +130,10 @@ module V82 = struct let new_evi = { evi with Evd.evar_hyps = new_hyps; Evd.evar_filter = new_filter } in let new_evi = Typeclasses.mark_unresolvable new_evi in - let (new_sigma, evk) = Evarutil.new_pure_evar_full Evd.empty new_evi in - { Evd.it = evk ; sigma = new_sigma; } + let sigma = Sigma.Unsafe.of_evar_map Evd.empty in + let Sigma (evk, sigma, _) = Evarutil.new_pure_evar_full sigma new_evi in + let sigma = Sigma.to_evar_map sigma in + { Evd.it = evk ; sigma = sigma; } (* Used by the compatibility layer and typeclasses *) let nf_evar sigma gl = @@ -139,7 +148,7 @@ module V82 = struct let env = env sigma gl in let genv = Global.env () in let is_proof_var decl = - try ignore (Environ.lookup_named (Util.pi1 decl) genv); false + try ignore (Environ.lookup_named (get_id decl) genv); false with Not_found -> true in Environ.fold_named_context_reverse (fun t decl -> if is_proof_var decl then diff --git a/proofs/goal.mli b/proofs/goal.mli index a00a95a2f..8a3d6e815 100644 --- a/proofs/goal.mli +++ b/proofs/goal.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -67,7 +67,7 @@ module V82 : sig val same_goal : Evd.evar_map -> goal -> Evd.evar_map -> goal -> bool (* Used for congruence closure *) - val new_goal_with : Evd.evar_map -> goal -> Context.named_context -> goal Evd.sigma + val new_goal_with : Evd.evar_map -> goal -> Context.Named.t -> goal Evd.sigma (* Used by the compatibility layer and typeclasses *) val nf_evar : Evd.evar_map -> goal -> goal * Evd.evar_map diff --git a/proofs/logic.ml b/proofs/logic.ml index 7d101b4c7..09f308abe 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -22,6 +22,7 @@ open Proof_type open Type_errors open Retyping open Misctypes +open Context.Named.Declaration type refiner_error = @@ -160,7 +161,8 @@ let reorder_context env sign ord = | _ -> (match ctxt_head with | [] -> error_no_such_hypothesis (List.hd ord) - | (x,_,_ as d) :: ctxt -> + | d :: ctxt -> + let x = get_id d in if Id.Set.mem x expected then step ord (Id.Set.remove x expected) ctxt (push_item x d moved_hyps) ctxt_tail @@ -175,7 +177,8 @@ let reorder_val_context env sign ord = -let check_decl_position env sign (x,_,_ as d) = +let check_decl_position env sign d = + let x = get_id d in 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 @@ -200,16 +203,17 @@ let move_location_eq m1 m2 = match m1, m2 with let rec get_hyp_after h = function | [] -> error_no_such_hypothesis h - | (hyp,_,_) :: right -> - if Id.equal hyp h then - match right with (id,_,_)::_ -> MoveBefore id | [] -> MoveFirst + | d :: right -> + if Id.equal (get_id d) h then + match right with d' ::_ -> MoveBefore (get_id d') | [] -> MoveFirst else get_hyp_after h right let split_sign hfrom hto l = let rec splitrec left toleft = function | [] -> error_no_such_hypothesis hfrom - | (hyp,c,typ) as d :: right -> + | d :: right -> + let hyp,_,typ = to_tuple d in if Id.equal hyp hfrom then (left,right,d, toleft || move_location_eq hto MoveLast) else @@ -227,27 +231,28 @@ let hyp_of_move_location = function | MoveBefore id -> id | _ -> assert false -let move_hyp toleft (left,(idfrom,_,_ as declfrom),right) hto = +let move_hyp toleft (left,declfrom,right) hto = let env = Global.env() in - let test_dep (hyp,c,typ as d) (hyp2,c,typ2 as d2) = + let test_dep d d2 = if toleft - then occur_var_in_decl env hyp2 d - else occur_var_in_decl env hyp d2 + then occur_var_in_decl env (get_id d2) d + else occur_var_in_decl env (get_id d) d2 in let rec moverec first middle = function | [] -> if match hto with MoveFirst | MoveLast -> false | _ -> true then error_no_such_hypothesis (hyp_of_move_location hto); List.rev first @ List.rev middle - | (hyp,_,_) :: _ as right when move_location_eq hto (MoveBefore hyp) -> + | d :: _ as right when move_location_eq hto (MoveBefore (get_id d)) -> List.rev first @ List.rev middle @ right - | (hyp,_,_) as d :: right -> + | d :: right -> + let hyp = get_id d in let (first',middle') = if List.exists (test_dep d) middle then if not (move_location_eq hto (MoveAfter hyp)) then (first, d::middle) else - errorlabstrm "move_hyp" (str "Cannot move " ++ pr_id idfrom ++ + errorlabstrm "move_hyp" (str "Cannot move " ++ pr_id (get_id declfrom) ++ Miscprint.pr_move_location pr_id hto ++ str (if toleft then ": it occurs in " else ": it depends on ") ++ pr_id hyp ++ str ".") @@ -356,9 +361,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 @@ -481,12 +488,14 @@ and mk_casegoals sigma goal goalacc p c = (acc'',lbrty,conclty,sigma,p',c') -let convert_hyp check sign sigma (id,b,bt as d) = +let convert_hyp check sign sigma d = + let id,b,bt = to_tuple d in let env = Global.env() in let reorder = ref [] in let sign' = apply_to_hyp sign id - (fun _ (_,c,ct) _ -> + (fun _ d' _ -> + let _,c,ct = to_tuple d' in let env = Global.env_of_context sign in if check && not (is_conv env sigma bt ct) then errorlabstrm "Logic.convert_hyp" @@ -520,17 +529,17 @@ let prim_refiner r sigma goal = if replace then let nexthyp = get_hyp_after id (named_context_of_val sign) in let sign,t,cl,sigma = clear_hyps2 env sigma (Id.Set.singleton id) sign t cl in - move_hyp false ([],(id,None,t),named_context_of_val sign) + move_hyp false ([], LocalAssum (id,t),named_context_of_val sign) nexthyp, t,cl,sigma else (if !check && mem_named_context id (named_context_of_val sign) then 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 + push_named_context_val (LocalAssum (id,t)) sign,t,cl,sigma) in let (sg2,ev2,sigma) = Goal.V82.mk_goal sigma sign cl (Goal.V82.extra sigma goal) in - let oterm = Term.mkApp (mkNamedLambda id t ev2 , [| ev1 |]) in + let oterm = Term.mkNamedLetIn id ev1 t ev2 in let sigma = Goal.V82.partial_solution_to sigma goal sg2 oterm in if b then ([sg1;sg2],sigma) else ([sg2;sg1],sigma) @@ -544,7 +553,8 @@ let prim_refiner r sigma goal = with Not_found -> error "Cannot do a fixpoint on a non inductive type." else - check_ind (push_rel (na,None,c1) env) (k-1) b + let open Context.Rel.Declaration in + check_ind (push_rel (LocalAssum (na,c1)) env) (k-1) b | _ -> error "Not enough products." in let ((sp,_),u) = check_ind env n cl in @@ -558,7 +568,7 @@ let prim_refiner r sigma goal = if !check && mem_named_context f (named_context_of_val sign) then 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 + mk_sign (push_named_context_val (LocalAssum (f,ar)) sign) oth | [] -> Evd.Monad.List.map (fun (_,_,c) sigma -> let gl,ev,sig' = @@ -582,7 +592,8 @@ let prim_refiner r sigma goal = let rec check_is_coind env cl = let b = whd_betadeltaiota env sigma cl in match kind_of_term b with - | Prod (na,c1,b) -> check_is_coind (push_rel (na,None,c1) env) b + | Prod (na,c1,b) -> let open Context.Rel.Declaration in + check_is_coind (push_rel (LocalAssum (na,c1)) env) b | _ -> try let _ = find_coinductive env sigma b in () @@ -599,7 +610,7 @@ let prim_refiner r sigma goal = error "Name already used in the environment.") with | Not_found -> - mk_sign (push_named_context_val (f,None,ar) sign) oth) + mk_sign (push_named_context_val (LocalAssum (f,ar)) sign) oth) | [] -> Evd.Monad.List.map (fun (_,c) sigma -> let gl,ev,sigma = diff --git a/proofs/logic.mli b/proofs/logic.mli index d034b73c5..9aa4ac207 100644 --- a/proofs/logic.mli +++ b/proofs/logic.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -53,4 +53,4 @@ exception RefinerError of refiner_error val catchable_exception : exn -> bool val convert_hyp : bool -> Environ.named_context_val -> evar_map -> - Context.named_declaration -> Environ.named_context_val + Context.Named.Declaration.t -> Environ.named_context_val diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 2ab3dc67a..5367a907e 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -20,14 +20,15 @@ let get_current_proof_name = Proof_global.get_current_proof_name let get_all_proof_names = Proof_global.get_all_proof_names type lemma_possible_guards = Proof_global.lemma_possible_guards +type universe_binders = Proof_global.universe_binders let delete_proof = Proof_global.discard let delete_current_proof = Proof_global.discard_current let delete_all_proofs = Proof_global.discard_all -let start_proof (id : Id.t) str sigma hyps c ?init_tac terminator = +let start_proof (id : Id.t) ?pl str sigma hyps c ?init_tac terminator = let goals = [ (Global.env_of_context hyps , c) ] in - Proof_global.start_proof sigma id str goals terminator; + Proof_global.start_proof sigma id ?pl str goals terminator; let env = Global.env () in ignore (Proof_global.with_current_proof (fun _ p -> match init_tac with @@ -54,6 +55,9 @@ let set_used_variables l = let get_used_variables () = Proof_global.get_used_variables () +let get_universe_binders () = + Proof_global.get_universe_binders () + exception NoSuchGoal let _ = Errors.register_handler begin function | NoSuchGoal -> Errors.error "No such goal." @@ -81,7 +85,8 @@ let get_current_goal_context () = with NoSuchGoal -> (* spiwack: returning empty evar_map, since if there is no goal, under focus, there is no accessible evar either *) - (Evd.empty, Global.env ()) + let env = Global.env () in + (Evd.from_env env, env) let current_proof_statement () = match Proof_global.V82.get_current_initial_conclusions () with @@ -101,8 +106,6 @@ let solve ?with_end_tac gi info_lvl tac pr = | Vernacexpr.SelectNth i -> Proofview.tclFOCUS i i tac | Vernacexpr.SelectId id -> Proofview.tclFOCUSID id tac | Vernacexpr.SelectAll -> tac - | Vernacexpr.SelectAllParallel -> - Errors.anomaly(str"SelectAllParallel not handled by Stm") in let (p,(status,info)) = Proof.run_tactic (Global.env ()) tac pr in let () = @@ -140,7 +143,7 @@ let build_constant_by_tactic id ctx sign ?(goal_kind = Global, false, Proof Theo let status = by tac in let _,(const,univs,_) = cook_proof () in delete_current_proof (); - const, status, univs + const, status, fst univs with reraise -> let reraise = Errors.push reraise in delete_current_proof (); @@ -151,10 +154,14 @@ let build_by_tactic ?(side_eff=true) env ctx ?(poly=false) typ tac = 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 = if side_eff then Term_typing.handle_entry_side_effects env ce else { ce with const_entry_body = Future.chain ~pure:true ce.const_entry_body (fun (pt, _) -> pt, Declareops.no_seff) } 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 let univs' = Evd.merge_context_set Evd.univ_rigid (Evd.from_ctx univs) ctx in - assert(Declareops.side_effects_is_empty se); + assert(Safe_typing.empty_private_constants = se); cb, status, Evd.evar_universe_context univs' let refine_by_tactic env sigma ty tac = @@ -189,7 +196,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 (**********************************************************************) @@ -207,7 +214,7 @@ let solve_by_implicit_tactic env sigma evk = match (!implicit_tactic, snd (evar_source evk sigma)) with | Some tac, (Evar_kinds.ImplicitArg _ | Evar_kinds.QuestionMark _) when - Context.named_context_equal (Environ.named_context_of_val evi.evar_hyps) + Context.Named.equal (Environ.named_context_of_val evi.evar_hyps) (Environ.named_context env) -> let tac = Proofview.tclTHEN tac (Proofview.tclEXTEND [] (Proofview.tclZERO (Errors.UserError ("",Pp.str"Proof is not complete."))) []) in (try diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index b1fba132d..cd8992015 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -55,8 +55,10 @@ val delete_all_proofs : unit -> unit type lemma_possible_guards = Proof_global.lemma_possible_guards +type universe_binders = Id.t Loc.located list + val start_proof : - Id.t -> goal_kind -> Evd.evar_map -> named_context_val -> constr -> + Id.t -> ?pl:universe_binders -> goal_kind -> Evd.evar_map -> named_context_val -> constr -> ?init_tac:unit Proofview.tactic -> Proof_global.proof_terminator -> unit @@ -69,11 +71,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. @@ -121,6 +123,9 @@ 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 Universe binders } *) +val get_universe_binders : unit -> universe_binders option + (** {6 ... } *) (** [solve (SelectNth n) tac] applies tactic [tac] to the [n]th subgoal of the current focused proof or raises a [UserError] if no @@ -152,7 +157,7 @@ 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 : ?side_eff:bool -> env -> Evd.evar_universe_context -> ?poly:polymorphic -> types -> unit Proofview.tactic -> diff --git a/proofs/proof.ml b/proofs/proof.ml index c7aa5bad9..86af420dc 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -334,22 +334,24 @@ let compact p = (*** Tactics ***) let run_tactic env tac pr = + let open Proofview.Notations in let sp = pr.proofview in - let (_,tacticced_proofview,(status,to_shelve,give_up),info_trace) = - Proofview.apply env tac sp + let undef sigma l = List.filter (fun g -> Evd.is_undefined sigma g) l in + let tac = + tac >>= fun () -> + Proofview.tclEVARMAP >>= fun sigma -> + (* Already solved goals are not to be counted as shelved. Nor are + they to be marked as unresolvable. *) + let retrieved = undef sigma (List.rev (Evd.future_goals sigma)) in + let sigma = List.fold_left Proofview.Unsafe.mark_as_goal sigma retrieved in + Proofview.Unsafe.tclEVARS sigma >>= fun () -> + Proofview.tclUNIT retrieved in - let sigma = Proofview.return tacticced_proofview in - (* Already solved goals are not to be counted as shelved. Nor are - they to be marked as unresolvable. *) - let undef l = List.filter (fun g -> Evd.is_undefined sigma g) l in - let retrieved = undef (List.rev (Evd.future_goals sigma)) in - let shelf = (undef pr.shelf)@retrieved@(undef to_shelve) in - let proofview = - List.fold_left - Proofview.Unsafe.mark_as_goal - tacticced_proofview - retrieved + let (retrieved,proofview,(status,to_shelve,give_up),info_trace) = + Proofview.apply env tac sp in + let sigma = Proofview.return proofview in + let shelf = (undef sigma pr.shelf)@retrieved@(undef sigma to_shelve) in let given_up = pr.given_up@give_up in let proofview = Proofview.Unsafe.reset_future_goals proofview in { pr with proofview ; shelf ; given_up },(status,info_trace) @@ -387,9 +389,27 @@ module V82 = struct { p with proofview = Proofview.V82.grab p.proofview } + (* Main component of vernac command Existential *) let instantiate_evar n com pr = - let sp = pr.proofview in - let proofview = Proofview.V82.instantiate_evar n com sp in + let tac = + Proofview.tclBIND Proofview.tclEVARMAP begin fun sigma -> + let (evk, evi) = + let evl = Evarutil.non_instantiated sigma in + let evl = Evar.Map.bindings evl in + if (n <= 0) then + Errors.error "incorrect existential variable index" + else if CList.length evl < n then + Errors.error "not so many uninstantiated existential variables" + else + CList.nth evl (n-1) + in + let env = Evd.evar_filtered_env evi in + let rawc = Constrintern.intern_constr env com in + let ltac_vars = Pretyping.empty_lvar in + let sigma = Evar_refiner.w_refine (evk, evi) (ltac_vars, rawc) sigma in + Proofview.Unsafe.tclEVARS sigma + end in + let ((), proofview, _, _) = Proofview.apply (Global.env ()) tac pr.proofview in let shelf = List.filter begin fun g -> Evd.is_undefined (Proofview.return proofview) g diff --git a/proofs/proof.mli b/proofs/proof.mli index a0ed0654d..5053fc7fb 100644 --- a/proofs/proof.mli +++ b/proofs/proof.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 4af18ab2d..647dbe111 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -36,7 +36,7 @@ let find_proof_mode n = Errors.error (Format.sprintf "No proof mode named \"%s\"." n) let register_proof_mode ({name = n} as m) = - Hashtbl.add proof_modes n (Ephemeron.create m) + Hashtbl.add proof_modes n (CEphemeron.create m) (* initial mode: standard mode *) let standard = { name = "No" ; set = (fun ()->()) ; reset = (fun () -> ()) } @@ -52,7 +52,7 @@ let _ = optname = "default proof mode" ; optkey = ["Default";"Proof";"Mode"] ; optread = begin fun () -> - (Ephemeron.default !default_proof_mode standard).name + (CEphemeron.default !default_proof_mode standard).name end; optwrite = begin fun n -> default_proof_mode := find_proof_mode n @@ -63,14 +63,14 @@ let _ = (* Extra info on proofs. *) type lemma_possible_guards = int list list -type proof_universes = Evd.evar_universe_context +type proof_universes = Evd.evar_universe_context * Universes.universe_binders option +type universe_binders = Id.t Loc.located list 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 = @@ -83,12 +83,13 @@ type closed_proof = proof_object * proof_terminator type pstate = { pid : Id.t; - terminator : proof_terminator Ephemeron.key; + terminator : proof_terminator CEphemeron.key; endline_tactic : Tacexpr.raw_tactic_expr option; section_vars : Context.section_context option; proof : Proof.proof; strength : Decl_kinds.goal_kind; - mode : proof_mode Ephemeron.key; + mode : proof_mode CEphemeron.key; + universe_binders: universe_binders option; } let make_terminator f = f @@ -105,11 +106,11 @@ let current_proof_mode = ref !default_proof_mode let update_proof_mode () = match !pstates with | { mode = m } :: _ -> - Ephemeron.iter_opt !current_proof_mode (fun x -> x.reset ()); + CEphemeron.iter_opt !current_proof_mode (fun x -> x.reset ()); current_proof_mode := m; - Ephemeron.iter_opt !current_proof_mode (fun x -> x.set ()) + CEphemeron.iter_opt !current_proof_mode (fun x -> x.set ()) | _ -> - Ephemeron.iter_opt !current_proof_mode (fun x -> x.reset ()); + CEphemeron.iter_opt !current_proof_mode (fun x -> x.reset ()); current_proof_mode := find_proof_mode "No" (* combinators for the current_proof lists *) @@ -217,9 +218,9 @@ let set_proof_mode mn = set_proof_mode (find_proof_mode mn) (get_current_proof_name ()) let activate_proof_mode mode = - Ephemeron.iter_opt (find_proof_mode mode) (fun x -> x.set ()) + CEphemeron.iter_opt (find_proof_mode mode) (fun x -> x.set ()) let disactivate_proof_mode mode = - Ephemeron.iter_opt (find_proof_mode mode) (fun x -> x.reset ()) + CEphemeron.iter_opt (find_proof_mode mode) (fun x -> x.reset ()) (** [start_proof sigma id str goals terminator] starts a proof of name [id] with goals [goals] (a list of pairs of environment and @@ -229,31 +230,34 @@ let disactivate_proof_mode mode = end of the proof to close the proof. The proof is started in the evar map [sigma] (which can typically contain universe constraints). *) -let start_proof sigma id str goals terminator = +let start_proof sigma id ?pl str goals terminator = let initial_state = { pid = id; - terminator = Ephemeron.create terminator; + terminator = CEphemeron.create terminator; proof = Proof.start sigma goals; endline_tactic = None; section_vars = None; strength = str; - mode = find_proof_mode "No" } in + mode = find_proof_mode "No"; + universe_binders = pl } in push initial_state pstates -let start_dependent_proof id str goals terminator = +let start_dependent_proof id ?pl str goals terminator = let initial_state = { pid = id; - terminator = Ephemeron.create terminator; + terminator = CEphemeron.create terminator; proof = Proof.dependent_start goals; endline_tactic = None; section_vars = None; strength = str; - mode = find_proof_mode "No" } in + mode = find_proof_mode "No"; + universe_binders = pl } in push initial_state pstates let get_used_variables () = (cur_pstate ()).section_vars +let get_universe_binders () = (cur_pstate ()).universe_binders -let proof_using_auto_clear = ref true +let proof_using_auto_clear = ref false let _ = Goptions.declare_bool_option { Goptions.optsync = true; Goptions.optdepr = false; @@ -263,18 +267,19 @@ let _ = Goptions.declare_bool_option Goptions.optwrite = (fun b -> proof_using_auto_clear := b) } let set_used_variables l = + let open Context.Named.Declaration in 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 + List.fold_right Id.Set.add (List.map get_id 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,_) -> + | LocalAssum (x,_) -> if Id.Set.mem x all_safe then orig else (ctx, all_safe, (Loc.ghost,x)::to_clear) - | (x,Some bo, ty) as decl -> + | LocalDef (x,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 @@ -304,7 +309,8 @@ let constrain_variables init uctx = Univ.ContextSet.add_constraints cstrs (UState.context_set uctx) let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl = - let { pid; section_vars; strength; proof; terminator } = cur_pstate () in + let { pid; section_vars; strength; proof; terminator; universe_binders } = + 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 @@ -323,19 +329,21 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl = let open Universes in let body = c in let typ = - if not (keep_body_ucst_separate || not (Declareops.side_effects_is_empty eff)) then + 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 - if keep_body_ucst_separate || not (Declareops.side_effects_is_empty eff) then + 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 = constrain_variables 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 used_univs = Univ.LSet.union used_univs_body used_univs_typ in + let ctx_body = restrict_universe_context ctx used_univs in (initunivs, typ), ((body, ctx_body), eff) else let initunivs = Univ.UContext.empty in @@ -369,11 +377,16 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl = const_entry_opaque = true; const_entry_universes = univs; const_entry_polymorphic = poly}) - fpl initial_goals in - { id = pid; entries = entries; persistence = strength; universes = universes }, - fun pr_ending -> Ephemeron.get terminator pr_ending + fpl initial_goals in + let binders = + Option.map (fun names -> fst (Evd.universe_context ~names (Evd.from_ctx universes))) + universe_binders + in + { id = pid; entries = entries; persistence = strength; + universes = (universes, binders) }, + fun pr_ending -> CEphemeron.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 @@ -419,11 +432,11 @@ let close_proof ~keep_body_ucst_separate fix_exn = (** Gets the current terminator without checking that the proof has been completed. Useful for the likes of [Admitted]. *) -let get_terminator () = Ephemeron.get ( cur_pstate() ).terminator +let get_terminator () = CEphemeron.get ( cur_pstate() ).terminator let set_terminator hook = match !pstates with | [] -> raise NoCurrentProof - | p :: ps -> pstates := { p with terminator = Ephemeron.create hook } :: ps + | p :: ps -> pstates := { p with terminator = CEphemeron.create hook } :: ps @@ -454,7 +467,7 @@ module Bullet = struct type behavior = { name : string; put : Proof.proof -> t -> Proof.proof; - suggest: Proof.proof -> string option + suggest: Proof.proof -> std_ppcmds } let behaviors = Hashtbl.create 4 @@ -464,7 +477,7 @@ module Bullet = struct let none = { name = "None"; put = (fun x _ -> x); - suggest = (fun _ -> None) + suggest = (fun _ -> mt ()) } let _ = register_behavior none @@ -480,26 +493,20 @@ module Bullet = struct (* give a message only if more informative than the standard coq message *) let suggest_on_solved_goal sugg = match sugg with - | NeedClosingBrace -> Some "Try unfocusing with \"}\"." - | NoBulletInUse -> None - | ProofFinished -> None - | Suggest b -> Some ("Focus next goal with bullet " - ^ Pp.string_of_ppcmds (Pp.(pr_bullet b)) - ^".") - | Unfinished b -> Some ("The current bullet " - ^ Pp.string_of_ppcmds (Pp.(pr_bullet b)) - ^ " is unfinished.") + | NeedClosingBrace -> str"Try unfocusing with \"}\"." + | NoBulletInUse -> mt () + | ProofFinished -> mt () + | Suggest b -> str"Focus next goal with bullet " ++ pr_bullet b ++ str"." + | Unfinished b -> str"The current bullet " ++ pr_bullet b ++ str" is unfinished." (* give always a message. *) let suggest_on_error sugg = match sugg with - | NeedClosingBrace -> "Try unfocusing with \"}\"." + | NeedClosingBrace -> str"Try unfocusing with \"}\"." | NoBulletInUse -> assert false (* This should never raise an error. *) - | ProofFinished -> "No more subgoals." - | Suggest b -> ("Bullet " ^ Pp.string_of_ppcmds (Pp.(pr_bullet b)) - ^ " is mandatory here.") - | Unfinished b -> ("Current bullet " ^ Pp.string_of_ppcmds (Pp.(pr_bullet b)) - ^ " is not finished.") + | ProofFinished -> str"No more subgoals." + | Suggest b -> str"Bullet " ++ pr_bullet b ++ str" is mandatory here." + | Unfinished b -> str"Current bullet " ++ pr_bullet b ++ str" is not finished." exception FailedBullet of t * suggestion @@ -507,8 +514,8 @@ module Bullet = struct Errors.register_handler (function | FailedBullet (b,sugg) -> - let prefix = "Wrong bullet " ^ Pp.string_of_ppcmds (Pp.(pr_bullet b)) ^ " : " in - Errors.errorlabstrm "Focus" (str prefix ++ str (suggest_on_error sugg)) + let prefix = str"Wrong bullet " ++ pr_bullet b ++ str" : " in + Errors.errorlabstrm "Focus" (prefix ++ suggest_on_error sugg) | _ -> raise Errors.Unhandled) @@ -619,7 +626,10 @@ module Bullet = struct (!current_behavior).name end; optwrite = begin fun n -> - current_behavior := Hashtbl.find behaviors n + current_behavior := + try Hashtbl.find behaviors n + with Not_found -> + Errors.error ("Unknown bullet behavior: \"" ^ n ^ "\".") end } @@ -654,7 +664,6 @@ let print_goal_selector = function | Vernacexpr.SelectAll -> "all" | Vernacexpr.SelectNth i -> string_of_int i | Vernacexpr.SelectId id -> Id.to_string id - | Vernacexpr.SelectAllParallel -> "par" let parse_goal_selector = function | "all" -> Vernacexpr.SelectAll @@ -702,3 +711,9 @@ 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 929bb86e8..ebe7f6d6f 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -55,18 +55,18 @@ val compact_the_proof : unit -> unit (i.e. an proof ending command) and registers the appropriate values. *) type lemma_possible_guards = int list list -type proof_universes = Evd.evar_universe_context +type proof_universes = Evd.evar_universe_context * Universes.universe_binders option +type universe_binders = Names.Id.t Loc.located list 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; *) - (** guards : lemma_possible_guards; *) } type proof_ending = - | Admitted of Names.Id.t * Decl_kinds.goal_kind * Entries.parameter_entry * proof_universes + | 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 @@ -83,14 +83,20 @@ val apply_terminator : proof_terminator -> proof_ending -> unit closing commands and the xml plugin); [terminator] is used at the end of the proof to close the proof. *) val start_proof : - Evd.evar_map -> Names.Id.t -> Decl_kinds.goal_kind -> (Environ.env * Term.types) list -> + Evd.evar_map -> Names.Id.t -> ?pl:universe_binders -> + Decl_kinds.goal_kind -> (Environ.env * Term.types) list -> proof_terminator -> unit (** Like [start_proof] except that there may be dependencies between initial goals. *) val start_dependent_proof : - Names.Id.t -> Decl_kinds.goal_kind -> Proofview.telescope -> - proof_terminator -> unit + Names.Id.t -> ?pl:universe_binders -> 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 *) @@ -100,7 +106,7 @@ val close_proof : keep_body_ucst_separate:bool -> Future.fix_exn -> closed_proof * 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. *) @@ -138,6 +144,8 @@ 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 +val get_universe_binders : unit -> universe_binders option + (**********************************************************) (* *) (* Proof modes *) @@ -164,7 +172,7 @@ module Bullet : sig type behavior = { name : string; put : Proof.proof -> t -> Proof.proof; - suggest: Proof.proof -> string option + suggest: Proof.proof -> Pp.std_ppcmds } (** A registered behavior can then be accessed in Coq @@ -181,7 +189,7 @@ module Bullet : sig (** Handles focusing/defocusing with bullets: *) val put : Proof.proof -> t -> Proof.proof - val suggest : Proof.proof -> string option + val suggest : Proof.proof -> Pp.std_ppcmds end diff --git a/proofs/proof_type.ml b/proofs/proof_type.ml deleted file mode 100644 index 47b2b255e..000000000 --- a/proofs/proof_type.ml +++ /dev/null @@ -1,52 +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 *) -(************************************************************************) - -(*i*) -open Evd -open Names -open Term -open Tacexpr -open Glob_term -open Nametab -open Misctypes -(*i*) - -(* This module defines the structure of proof tree and the tactic type. So, it - is used by Proof_tree and Refiner *) - -(** Types of goals, tactics, rules ... *) - -type goal = Goal.goal - -type tactic = goal sigma -> goal list sigma - -type prim_rule = - | Cut of bool * bool * Id.t * types - | FixRule of Id.t * int * (Id.t * int * constr) list * int - | Cofix of Id.t * (Id.t * constr) list * int - | Refine of constr - | Thin of Id.t list - | Move of Id.t * Id.t move_location - -(** Nowadays, the only rules we'll consider are the primitive rules *) - -type rule = prim_rule - -(** Ltac traces *) - -type ltac_call_kind = - | LtacMLCall of glob_tactic_expr - | LtacNotationCall of KerName.t - | LtacNameCall of ltac_constant - | LtacAtomCall of glob_atomic_tactic_expr - | LtacVarCall of Id.t * glob_tactic_expr - | LtacConstrInterp of glob_constr * Pretyping.ltac_var_map - -type ltac_trace = (Loc.t * ltac_call_kind) list - -let (ltac_trace_info : ltac_trace Exninfo.t) = Exninfo.make () diff --git a/proofs/proof_type.mli b/proofs/proof_type.mli index f5e2bad2a..b4c9dae2a 100644 --- a/proofs/proof_type.mli +++ b/proofs/proof_type.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -57,19 +57,3 @@ type rule = prim_rule type goal = Goal.goal type tactic = goal sigma -> goal list sigma - -(** Ltac traces *) - -(** TODO: Move those definitions somewhere sensible *) - -type ltac_call_kind = - | LtacMLCall of glob_tactic_expr - | LtacNotationCall of KerName.t - | LtacNameCall of ltac_constant - | LtacAtomCall of glob_atomic_tactic_expr - | LtacVarCall of Id.t * glob_tactic_expr - | LtacConstrInterp of glob_constr * Pretyping.ltac_var_map - -type ltac_trace = (Loc.t * ltac_call_kind) list - -val ltac_trace_info : ltac_trace Exninfo.t diff --git a/proofs/proof_using.ml b/proofs/proof_using.ml index 7eed1cb31..681a7fa1a 100644 --- a/proofs/proof_using.ml +++ b/proofs/proof_using.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -10,6 +10,7 @@ open Names open Environ open Util open Vernacexpr +open Context.Named.Declaration let to_string e = let rec aux = function @@ -33,7 +34,8 @@ let in_nameset = let rec close_fwd e s = let s' = - List.fold_left (fun s (id,b,ty) -> + List.fold_left (fun s decl -> + let (id,b,ty) = Context.Named.Declaration.to_tuple decl in 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 @@ -61,13 +63,13 @@ and set_of_id env ty id = Id.Set.union (global_vars_set env ty) acc) Id.Set.empty ty else if Id.to_string id = "All" then - List.fold_right Id.Set.add (List.map pi1 (named_context env)) Id.Set.empty + List.fold_right Id.Set.add (List.map get_id (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 + List.fold_right Id.Set.add (List.map get_id (named_context env)) Id.Set.empty let process_expr env e ty = let ty_expr = SsSingl(Loc.ghost, Id.of_string "Type") in diff --git a/proofs/proof_using.mli b/proofs/proof_using.mli index dcf8a0fcd..1bf38b690 100644 --- a/proofs/proof_using.mli +++ b/proofs/proof_using.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/proofs/proofs.mllib b/proofs/proofs.mllib index 1bd701cb9..9130a186b 100644 --- a/proofs/proofs.mllib +++ b/proofs/proofs.mllib @@ -2,16 +2,14 @@ Miscprint Goal Evar_refiner Proof_using -Proof_type Proof_errors Logic -Proofview +Refine Proof Proof_global Redexpr Refiner Tacmach Pfedit -Tactic_debug Clenv Clenvtac diff --git a/proofs/redexpr.ml b/proofs/redexpr.ml index be92f2b04..2d886b8e1 100644 --- a/proofs/redexpr.ml +++ b/proofs/redexpr.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -158,8 +158,6 @@ let make_flag env f = f.rConst red in red -let is_reference = function PRef _ | PVar _ -> true | _ -> false - (* table of custom reductino fonctions, not synchronized, filled via ML calls to [declare_reduction] *) let reduction_tab = ref String.Map.empty @@ -196,7 +194,7 @@ let out_arg = function let out_with_occurrences (occs,c) = (Locusops.occurrences_map (List.map out_arg) occs, c) -let e_red f env evm c = evm, f env evm c +let e_red f = { e_redfun = fun env evm c -> Sigma.here (f env (Sigma.to_evar_map evm) c) evm } let head_style = false (* Turn to true to have a semantics where simpl only reduce at the head when an evaluable reference is given, e.g. diff --git a/proofs/redexpr.mli b/proofs/redexpr.mli index b32cedf8e..b91911087 100644 --- a/proofs/redexpr.mli +++ b/proofs/redexpr.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/proofs/refine.ml b/proofs/refine.ml new file mode 100644 index 000000000..db0b26f7e --- /dev/null +++ b/proofs/refine.ml @@ -0,0 +1,122 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Pp +open Util +open Proofview_monad +open Sigma.Notations +open Proofview.Notations +open Context.Named.Declaration + +let extract_prefix env info = + let ctx1 = List.rev (Environ.named_context env) in + let ctx2 = List.rev (Evd.evar_context info) in + let rec share l1 l2 accu = match l1, l2 with + | d1 :: l1, d2 :: l2 -> + if d1 == d2 then share l1 l2 (d1 :: accu) + else (accu, d2 :: l2) + | _ -> (accu, l2) + in + share ctx1 ctx2 [] + +let typecheck_evar ev env sigma = + let info = Evd.find sigma ev in + (** Typecheck the hypotheses. *) + let type_hyp (sigma, env) decl = + let t = get_type decl in + let evdref = ref sigma in + let _ = Typing.e_sort_of env evdref t in + let () = match decl with + | LocalAssum _ -> () + | LocalDef (_,body,_) -> Typing.e_check env evdref body t + in + (!evdref, Environ.push_named decl env) + in + let (common, changed) = extract_prefix env info in + let env = Environ.reset_with_named_context (Environ.val_of_named_context common) env in + let (sigma, env) = List.fold_left type_hyp (sigma, env) changed in + (** Typecheck the conclusion *) + let evdref = ref sigma in + let _ = Typing.e_sort_of env evdref (Evd.evar_concl info) in + !evdref + +let typecheck_proof c concl env sigma = + let evdref = ref sigma in + let () = Typing.e_check env evdref c concl in + !evdref + +let (pr_constrv,pr_constr) = + Hook.make ~default:(fun _env _sigma _c -> Pp.str"<constr>") () + +let refine ?(unsafe = true) f = Proofview.Goal.enter { enter = begin fun gl -> + let gl = Proofview.Goal.assume gl in + let sigma = Proofview.Goal.sigma gl in + let sigma = Sigma.to_evar_map sigma in + let env = Proofview.Goal.env gl in + let concl = Proofview.Goal.concl gl in + (** Save the [future_goals] state to restore them after the + refinement. *) + let prev_future_goals = Evd.future_goals sigma in + let prev_principal_goal = Evd.principal_future_goal sigma in + (** Create the refinement term *) + let (c, sigma) = Sigma.run (Evd.reset_future_goals sigma) f in + let evs = Evd.future_goals sigma in + let evkmain = Evd.principal_future_goal sigma in + (** Check that the introduced evars are well-typed *) + let fold accu ev = typecheck_evar ev env accu in + let sigma = if unsafe then sigma else CList.fold_left fold sigma evs in + (** Check that the refined term is typesafe *) + let sigma = if unsafe then sigma else typecheck_proof c concl env sigma in + (** Check that the goal itself does not appear in the refined term *) + let self = Proofview.Goal.goal gl in + let _ = + if not (Evarutil.occur_evar_upto sigma self c) then () + else Pretype_errors.error_occur_check env sigma self c + in + (** Proceed to the refinement *) + let sigma = match evkmain with + | None -> Evd.define self c sigma + | Some evk -> + let id = Evd.evar_ident self sigma in + let sigma = Evd.define self c sigma in + match id with + | None -> sigma + | Some id -> Evd.rename evk id sigma + in + (** Restore the [future goals] state. *) + let sigma = Evd.restore_future_goals sigma prev_future_goals prev_principal_goal in + (** Select the goals *) + let comb = CList.map_filter (Proofview.Unsafe.advance sigma) (CList.rev evs) in + let sigma = CList.fold_left Proofview.Unsafe.mark_as_goal sigma comb in + let trace () = Pp.(hov 2 (str"refine"++spc()++ Hook.get pr_constrv env sigma c)) in + Proofview.Trace.name_tactic trace (Proofview.tclUNIT ()) >>= fun () -> + Proofview.Unsafe.tclEVARS sigma >>= fun () -> + Proofview.Unsafe.tclSETGOALS comb +end } + +(** Useful definitions *) + +let with_type env evd c t = + let my_type = Retyping.get_type_of env evd c in + let j = Environ.make_judge c my_type in + let (evd,j') = + Coercion.inh_conv_coerce_to true (Loc.ghost) env evd j t + in + evd , j'.Environ.uj_val + +let refine_casted ?unsafe f = Proofview.Goal.enter { enter = begin fun gl -> + let gl = Proofview.Goal.assume gl in + let concl = Proofview.Goal.concl gl in + let env = Proofview.Goal.env gl in + let f = { run = fun h -> + let Sigma (c, h, p) = f.run h in + let sigma, c = with_type env (Sigma.to_evar_map h) c concl in + Sigma (c, Sigma.Unsafe.of_evar_map sigma, p) + } in + refine ?unsafe f +end } diff --git a/proofs/refine.mli b/proofs/refine.mli new file mode 100644 index 000000000..17c7e28ca --- /dev/null +++ b/proofs/refine.mli @@ -0,0 +1,37 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Proofview + +(** {6 The refine tactic} *) + +(** Printer used to print the constr which refine refines. *) +val pr_constr : + (Environ.env -> Evd.evar_map -> Term.constr -> Pp.std_ppcmds) Hook.t + +(** {7 Refinement primitives} *) + +val refine : ?unsafe:bool -> Constr.t Sigma.run -> unit tactic +(** In [refine ?unsafe t], [t] is a term with holes under some + [evar_map] context. The term [t] is used as a partial solution + for the current goal (refine is a goal-dependent tactic), the + new holes created by [t] become the new subgoals. Exceptions + raised during the interpretation of [t] are caught and result in + tactic failures. If [unsafe] is [false] (default is [true]) [t] is + type-checked beforehand. *) + +(** {7 Helper functions} *) + +val with_type : Environ.env -> Evd.evar_map -> + Term.constr -> Term.types -> Evd.evar_map * Term.constr +(** [with_type env sigma c t] ensures that [c] is of type [t] + inserting a coercion if needed. *) + +val refine_casted : ?unsafe:bool -> Constr.t Sigma.run -> unit tactic +(** Like {!refine} except the refined term is coerced to the conclusion of the + current goal. *) diff --git a/proofs/refiner.ml b/proofs/refiner.ml index ba62b2cb2..186525e15 100644 --- a/proofs/refiner.ml +++ b/proofs/refiner.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -13,7 +13,7 @@ open Evd open Environ open Proof_type open Logic - +open Context.Named.Declaration let sig_it x = x.it let project x = x.sigma @@ -197,12 +197,12 @@ let tclNOTSAMEGOAL (tac : tactic) goal = 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 + let oldhyps:Context.Named.t = pf_hyps goal in let rslt:Proof_type.goal list Evd.sigma = tac goal in let { it = gls; sigma = sigma; } = rslt in - let hyps:Context.named_context list = + let hyps:Context.Named.t 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 cmp d1 d2 = Names.Id.equal (get_id d1) (get_id d2) in let newhyps = List.map (fun hypl -> List.subtract cmp hypl oldhyps) @@ -215,7 +215,7 @@ let tclSHOWHYPS (tac : tactic) (goal: Goal.goal Evd.sigma) List.fold_left (fun acc lh -> acc ^ (if !frst then (frst:=false;"") else " | ") ^ (List.fold_left - (fun acc (nm,_,_) -> (Names.Id.to_string nm) ^ " " ^ acc) + (fun acc d -> (Names.Id.to_string (get_id d)) ^ " " ^ acc) "" lh)) "" newhyps in pp (str (emacs_str "<infoH>") diff --git a/proofs/refiner.mli b/proofs/refiner.mli index a81555ff5..dd9153a02 100644 --- a/proofs/refiner.mli +++ b/proofs/refiner.mli @@ -1,12 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Context open Evd open Proof_type @@ -16,7 +15,7 @@ val sig_it : 'a sigma -> 'a val project : 'a sigma -> evar_map val pf_env : goal sigma -> Environ.env -val pf_hyps : goal sigma -> named_context +val pf_hyps : goal sigma -> Context.Named.t val unpackage : 'a sigma -> evar_map ref * 'a val repackage : evar_map ref -> 'a -> 'a sigma diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index 57c60cbee..33cef7486 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -18,6 +18,8 @@ open Tacred open Proof_type open Logic open Refiner +open Sigma.Notations +open Context.Named.Declaration let re_sig it gc = { it = it; sigma = gc; } @@ -40,21 +42,22 @@ let pf_hyps = Refiner.pf_hyps let pf_concl gls = Goal.V82.concl (project gls) (sig_it gls) let pf_hyps_types gls = let sign = Environ.named_context (pf_env gls) in - List.map (fun (id,_,x) -> (id, x)) sign + List.map (function LocalAssum (id,x) + | LocalDef (id,_,x) -> id, x) + sign -let pf_nth_hyp_id gls n = let (id,c,t) = List.nth (pf_hyps gls) (n-1) in id +let pf_nth_hyp_id gls n = List.nth (pf_hyps gls) (n-1) |> get_id let pf_last_hyp gl = List.hd (pf_hyps gl) let pf_get_hyp gls id = try - Context.lookup_named id (pf_hyps gls) + Context.Named.lookup id (pf_hyps gls) with Not_found -> raise (RefinerError (NoSuchHyp id)) let pf_get_hyp_typ gls id = - let (_,_,ty)= (pf_get_hyp gls id) in - ty + pf_get_hyp gls id |> get_type let pf_ids_of_hyps gls = ids_of_named_context (pf_hyps gls) @@ -70,7 +73,10 @@ let pf_get_new_ids ids gls = let pf_global gls id = Constrintern.construct_reference (pf_hyps gls) id let pf_reduction_of_red_expr gls re c = - (fst (reduction_of_red_expr (pf_env gls) re)) (pf_env gls) (project gls) c + let (redfun, _) = reduction_of_red_expr (pf_env gls) re in + let sigma = Sigma.Unsafe.of_evar_map (project gls) in + let Sigma (c, sigma, _) = redfun.e_redfun (pf_env gls) sigma c in + (Sigma.to_evar_map sigma, c) let pf_apply f gls = f (pf_env gls) (project gls) let pf_eapply f gls x = @@ -95,7 +101,7 @@ let pf_const_value = pf_reduce (fun env _ -> constant_value_in env) let pf_reduce_to_quantified_ind = pf_reduce reduce_to_quantified_ind let pf_reduce_to_atomic_ind = pf_reduce reduce_to_atomic_ind -let pf_hnf_type_of gls = compose (pf_whd_betadeltaiota gls) (pf_get_type_of gls) +let pf_hnf_type_of gls = pf_whd_betadeltaiota gls % pf_get_type_of gls let pf_is_matching = pf_apply Constr_matching.is_matching_conv let pf_matches = pf_apply Constr_matching.matches_conv @@ -198,19 +204,20 @@ module New = struct let pf_get_hyp id gl = let hyps = Proofview.Goal.hyps gl in let sign = - try Context.lookup_named id hyps + try Context.Named.lookup id hyps with Not_found -> raise (RefinerError (NoSuchHyp id)) in sign let pf_get_hyp_typ id gl = - let (_,_,ty) = pf_get_hyp id gl in - ty + pf_get_hyp id gl |> get_type let pf_hyps_types gl = let env = Proofview.Goal.env gl in let sign = Environ.named_context env in - List.map (fun (id,_,x) -> (id, x)) sign + List.map (function LocalAssum (id,x) + | LocalDef (id,_,x) -> id, x) + sign let pf_last_hyp gl = let hyps = Proofview.Goal.hyps gl in diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index c45fd250c..f786b5f21 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,7 +8,6 @@ open Names open Term -open Context open Environ open Evd open Proof_type @@ -34,18 +33,18 @@ val apply_sig_tac : val pf_concl : goal sigma -> types val pf_env : goal sigma -> env -val pf_hyps : goal sigma -> named_context +val pf_hyps : goal sigma -> Context.Named.t (*i val pf_untyped_hyps : goal sigma -> (Id.t * constr) list i*) val pf_hyps_types : goal sigma -> (Id.t * types) list val pf_nth_hyp_id : goal sigma -> int -> Id.t -val pf_last_hyp : goal sigma -> named_declaration +val pf_last_hyp : goal sigma -> Context.Named.Declaration.t val pf_ids_of_hyps : goal sigma -> Id.t list val pf_global : goal sigma -> Id.t -> constr 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 +val pf_get_hyp : goal sigma -> Id.t -> Context.Named.Declaration.t val pf_get_hyp_typ : goal sigma -> Id.t -> types val pf_get_new_id : Id.t -> goal sigma -> Id.t @@ -123,9 +122,9 @@ module New : sig val pf_ids_of_hyps : ('a, 'r) Proofview.Goal.t -> identifier list val pf_hyps_types : ('a, 'r) Proofview.Goal.t -> (identifier * types) list - val pf_get_hyp : identifier -> ([ `NF ], 'r) Proofview.Goal.t -> named_declaration + val pf_get_hyp : identifier -> ([ `NF ], 'r) Proofview.Goal.t -> Context.Named.Declaration.t val pf_get_hyp_typ : identifier -> ([ `NF ], 'r) Proofview.Goal.t -> types - val pf_last_hyp : ([ `NF ], 'r) Proofview.Goal.t -> named_declaration + val pf_last_hyp : ([ `NF ], 'r) Proofview.Goal.t -> Context.Named.Declaration.t val pf_nf_concl : ([ `LZ ], 'r) Proofview.Goal.t -> types val pf_reduce_to_quantified_ind : ('a, 'r) Proofview.Goal.t -> types -> pinductive * types diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index e525031e6..c7faef333 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -60,9 +60,7 @@ module Make(T : Task) = struct type more_data = | MoreDataUnivLevel of Univ.universe_level list - - let request_expiry_of_task (t, c) = T.request_of_task t, c - + let slave_respond (Request r) = let res = T.perform r in Response res @@ -125,8 +123,9 @@ module Make(T : Task) = struct "-async-proofs-worker-priority"; Flags.string_of_priority !Flags.async_proofs_worker_priority] | ("-ideslave"|"-emacs"|"-emacs-U"|"-batch")::tl -> set_slave_opt tl - | ("-async-proofs" |"-toploop" |"-vi2vo" |"-compile" - |"-load-vernac-source" |"-compile-verbose" + | ("-async-proofs" |"-toploop" |"-vi2vo" + |"-load-vernac-source" |"-l" |"-load-vernac-source-verbose" |"-lv" + |"-compile" |"-compile-verbose" |"-async-proofs-worker-priority" |"-worker-id") :: _ :: tl -> set_slave_opt tl | x::tl -> x :: set_slave_opt tl in @@ -183,6 +182,13 @@ module Make(T : Task) = struct let () = Unix.sleep 1 in kill_if () in + let kill_if () = + try kill_if () + with Sys.Break -> + let () = stop_waiting := true in + let () = TQueue.broadcast queue in + Worker.kill proc + in let _ = Thread.create kill_if () in try while true do @@ -313,7 +319,7 @@ module Make(T : Task) = struct let response = slave_respond request in report_status "Idle"; marshal_response (Option.get !slave_oc) response; - Ephemeron.clear () + CEphemeron.clear () with | MarshalError s -> pr_err ("Fatal marshal error: " ^ s); flush_all (); exit 2 diff --git a/stm/asyncTaskQueue.mli b/stm/asyncTaskQueue.mli index a3fe4b8c0..f140f8ed5 100644 --- a/stm/asyncTaskQueue.mli +++ b/stm/asyncTaskQueue.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/stm/coqworkmgrApi.ml b/stm/coqworkmgrApi.ml index c34d447e6..20d5152aa 100644 --- a/stm/coqworkmgrApi.ml +++ b/stm/coqworkmgrApi.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/stm/coqworkmgrApi.mli b/stm/coqworkmgrApi.mli index 42dd39b92..548958140 100644 --- a/stm/coqworkmgrApi.mli +++ b/stm/coqworkmgrApi.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/stm/dag.ml b/stm/dag.ml index d0515d3ff..0c7f9f34b 100644 --- a/stm/dag.ml +++ b/stm/dag.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/stm/dag.mli b/stm/dag.mli index 14ccdc9f1..6b4442df0 100644 --- a/stm/dag.mli +++ b/stm/dag.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/stm/lemmas.ml b/stm/lemmas.ml index 5f034e361..80b3fef19 100644 --- a/stm/lemmas.ml +++ b/stm/lemmas.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -31,6 +31,7 @@ open Reductionops open Constrexpr open Constrintern open Impargs +open Context.Rel.Declaration type 'a declaration_hook = Decl_kinds.locality -> Globnames.global_reference -> 'a let mk_hook hook = hook @@ -44,7 +45,8 @@ let call_hook fix_exn hook l c = let retrieve_first_recthm = function | VarRef id -> - (pi2 (Global.lookup_named id),variable_opacity id) + let open Context.Named.Declaration in + (get_value (Global.lookup_named id),variable_opacity id) | ConstRef cst -> let cb = Global.lookup_constant cst in (Global.body_of_constant_body cb, is_opaque cb) @@ -70,11 +72,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 @@ -106,11 +109,12 @@ let find_mutually_recursive_statements thms = (fun env c -> fst (whd_betadeltaiota_stack env Evd.empty c)) (Global.env()) hyps in let ind_hyps = - List.flatten (List.map_i (fun i (_,b,t) -> + List.flatten (List.map_i (fun i decl -> + let t = get_type decl in match kind_of_term t with | Ind ((kn,_ as ind),u) when let mind = Global.lookup_mind kn in - mind.mind_finite <> Decl_kinds.CoFinite && Option.is_empty b -> + mind.mind_finite <> Decl_kinds.CoFinite && is_local_assum decl -> [ind,x,i] | _ -> []) 0 (List.rev whnf_hyp_hds)) in @@ -185,7 +189,7 @@ let look_for_possibly_mutual_statements = function (* Saving a goal *) -let save ?export_seff id const cstrs do_guard (locality,poly,kind) hook = +let save ?export_seff id const cstrs pl do_guard (locality,poly,kind) hook = let fix_exn = Future.fix_exn_of const.Entries.const_entry_body in try let const = adjust_guardness_conditions const do_guard in @@ -204,6 +208,7 @@ let save ?export_seff id const cstrs do_guard (locality,poly,kind) hook = declare_constant ?export_seff id ~local (DefinitionEntry const, k) in (locality, ConstRef kn) in definition_message id; + Option.iter (Universes.register_universe_binders r) pl; call_hook (fun exn -> exn) hook l r with e when Errors.noncritical e -> let e = Errors.push e in @@ -218,11 +223,11 @@ let compute_proof_name locality = function locality == Global && Nametab.exists_cci (Lib.make_path_except_section id) then user_err_loc (loc,"",pr_id id ++ str " already exists."); - id + id, pl | None -> - next_global_ident_away default_thm_id (Pfedit.get_all_proof_names ()) + next_global_ident_away default_thm_id (Pfedit.get_all_proof_names ()), None -let save_remaining_recthms (locality,p,kind) norm ctx body opaq i (id,(t_i,(_,imps))) = +let save_remaining_recthms (locality,p,kind) norm ctx body opaq i ((id,pl),(t_i,(_,imps))) = let t_i = norm t_i in match body with | None -> @@ -275,28 +280,28 @@ let save_hook = ref ignore let set_save_hook f = save_hook := f let save_named ?export_seff proof = - let id,const,cstrs,do_guard,persistence,hook = proof in - save ?export_seff id const cstrs do_guard persistence hook + let id,const,(cstrs,pl),do_guard,persistence,hook = proof in + save ?export_seff id const cstrs pl do_guard persistence hook let check_anonymity id save_ident = if not (String.equal (atompart_of_id id) (Id.to_string (default_thm_id))) then error "This command can only be used for unnamed theorem." - let save_anonymous ?export_seff proof save_ident = - let id,const,cstrs,do_guard,persistence,hook = proof in + let id,const,(cstrs,pl),do_guard,persistence,hook = proof in check_anonymity id save_ident; - save ?export_seff save_ident const cstrs do_guard persistence hook + save ?export_seff save_ident const cstrs pl do_guard persistence hook let save_anonymous_with_strength ?export_seff proof kind save_ident = - let id,const,cstrs,do_guard,_,hook = proof in + let id,const,(cstrs,pl),do_guard,_,hook = proof in check_anonymity id save_ident; (* we consider that non opaque behaves as local for discharge *) - save ?export_seff save_ident const cstrs do_guard (Global, const.const_entry_polymorphic, Proof kind) hook + save ?export_seff save_ident const cstrs pl do_guard + (Global, const.const_entry_polymorphic, Proof kind) hook (* Admitted *) -let admit (id,k,e) hook () = +let admit (id,k,e) pl hook () = let kn = declare_constant id (ParameterEntry e, IsAssumption Conjectural) in let () = match k with | Global, _, _ -> () @@ -305,6 +310,7 @@ let admit (id,k,e) hook () = str "declared as an axiom.") in let () = assumption_message id in + Option.iter (Universes.register_universe_binders (ConstRef kn)) pl; call_hook (fun exn -> exn) hook Global (ConstRef kn) (* Starting a goal *) @@ -314,11 +320,10 @@ let set_start_hook = (:=) start_hook let get_proof proof do_guard hook opacity = - let (id,(const,cstrs,persistence)) = + let (id,(const,univs,persistence)) = Pfedit.cook_this_proof proof in - (** FIXME *) - id,{const with const_entry_opaque = opacity},cstrs,do_guard,persistence,hook + id,{const with const_entry_opaque = opacity},univs,do_guard,persistence,hook let check_exist = List.iter (fun (loc,id) -> @@ -329,16 +334,16 @@ let check_exist = let universe_proof_terminator compute_guard hook = let open Proof_global in make_terminator begin function - | Admitted (id,k,pe,ctx) -> - admit (id,k,pe) (hook (Some ctx)) (); + | Admitted (id,k,pe,(ctx,pl)) -> + admit (id,k,pe) pl (hook (Some ctx)) (); 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 (Some proof.Proof_global.universes)) is_opaque in + let proof = get_proof proof compute_guard + (hook (Some (fst proof.Proof_global.universes))) is_opaque in begin match idopt with | None -> save_named ~export_seff proof | Some ((_,id),None) -> save_anonymous ~export_seff proof id @@ -351,7 +356,7 @@ let universe_proof_terminator compute_guard hook = let standard_proof_terminator compute_guard hook = universe_proof_terminator compute_guard (fun _ -> hook) -let start_proof id kind sigma ?terminator ?sign c ?init_tac ?(compute_guard=[]) hook = +let start_proof id ?pl kind sigma ?terminator ?sign c ?init_tac ?(compute_guard=[]) hook = let terminator = match terminator with | None -> standard_proof_terminator compute_guard hook | Some terminator -> terminator compute_guard hook @@ -362,9 +367,9 @@ let start_proof id kind sigma ?terminator ?sign c ?init_tac ?(compute_guard=[]) | None -> initialize_named_context_for_proof () in !start_hook c; - Pfedit.start_proof id kind sigma sign c ?init_tac terminator + Pfedit.start_proof id ?pl kind sigma sign c ?init_tac terminator -let start_proof_univs id kind sigma ?terminator ?sign c ?init_tac ?(compute_guard=[]) hook = +let start_proof_univs id ?pl kind sigma ?terminator ?sign c ?init_tac ?(compute_guard=[]) hook = let terminator = match terminator with | None -> universe_proof_terminator compute_guard hook | Some terminator -> terminator compute_guard hook @@ -375,11 +380,11 @@ let start_proof_univs id kind sigma ?terminator ?sign c ?init_tac ?(compute_guar | None -> initialize_named_context_for_proof () in !start_hook c; - Pfedit.start_proof id kind sigma sign c ?init_tac terminator + Pfedit.start_proof id ?pl kind sigma sign c ?init_tac terminator let rec_tac_initializer finite guard thms snl = if finite then - match List.map (fun (id,(t,_)) -> (id,t)) thms with + match List.map (fun ((id,_),(t,_)) -> (id,t)) thms with | (id,_)::l -> Tactics.mutual_cofix id l 0 | _ -> assert false else @@ -387,7 +392,7 @@ let rec_tac_initializer finite guard thms snl = let nl = match snl with | None -> List.map succ (List.map List.last guard) | Some nl -> nl - in match List.map2 (fun (id,(t,_)) n -> (id,n,t)) thms nl with + in match List.map2 (fun ((id,_),(t,_)) n -> (id,n,t)) thms nl with | (id,n,_)::l -> Tactics.mutual_fix id n l 0 | _ -> assert false @@ -416,7 +421,7 @@ let start_proof_with_initialization kind ctx recguard thms snl hook = (if Flags.is_auto_intros () then Some (intro_tac (List.hd thms)) else None), [] in match thms with | [] -> anomaly (Pp.str "No proof to start") - | (id,(t,(_,imps)))::other_thms -> + | ((id,pl),(t,(_,imps)))::other_thms -> let hook ctx strength ref = let ctx = match ctx with | None -> Evd.empty_evar_universe_context @@ -435,7 +440,7 @@ let start_proof_with_initialization kind ctx recguard thms snl hook = List.iter (fun (strength,ref,imps) -> maybe_declare_manual_implicits false ref imps; call_hook (fun exn -> exn) hook strength ref) thms_data in - start_proof_univs id kind ctx t ?init_tac (fun ctx -> mk_hook (hook ctx)) ~compute_guard:guard + start_proof_univs id ?pl kind ctx t ?init_tac (fun ctx -> mk_hook (hook ctx)) ~compute_guard:guard let start_proof_com kind thms hook = let env0 = Global.env () in @@ -448,7 +453,7 @@ let start_proof_com kind thms hook = let impls, ((env, ctx), imps) = interp_context_evars env0 evdref bl in let t', imps' = interp_type_evars_impls ~impls env evdref t in evdref := solve_remaining_evars all_and_fail_flags env !evdref (Evd.empty,!evdref); - let ids = List.map pi1 ctx in + let ids = List.map get_name ctx in (compute_proof_name (pi1 kind) sopt, (nf_evar !evdref (it_mkProd_or_LetIn t' ctx), (ids, imps @ lift_implicits (List.length ids) imps'), @@ -479,14 +484,13 @@ let save_proof ?proof = function if const_entry_type = None then error "Admitted requires an explicit statement"; let typ = Option.get const_entry_type in - let ctx = Evd.evar_context_universe_context universes in + let ctx = Evd.evar_context_universe_context (fst universes) in Admitted(id, k, (const_entry_secctx, pi2 k, (typ, ctx), None), universes) | None -> let id, k, typ = Pfedit.current_proof_statement () in (* This will warn if the proof is complete *) 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 @@ -496,7 +500,10 @@ 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),universes) + let names = Pfedit.get_universe_binders () in + let binders, ctx = Evd.universe_context ?names (Evd.from_ctx universes) in + Admitted(id,k,(sec_vars, pi2 k, (typ, ctx), None), + (universes, Some binders)) in Proof_global.apply_terminator (Proof_global.get_terminator ()) pe | Vernacexpr.Proved (is_opaque,idopt) -> @@ -515,5 +522,11 @@ let save_proof ?proof = function let get_current_context () = try Pfedit.get_current_goal_context () with e when Logic.catchable_exception e -> - let env = Global.env () in - (Evd.from_env env, env) + try (* No more focused goals ? *) + let p = Pfedit.get_pftreestate () in + let evd = Proof.in_proof p (fun x -> x) in + (evd, Global.env ()) + with Proof_global.NoCurrentProof -> + let env = Global.env () in + (Evd.from_env env, env) + diff --git a/stm/lemmas.mli b/stm/lemmas.mli index dca6afe19..9120787d1 100644 --- a/stm/lemmas.mli +++ b/stm/lemmas.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -9,12 +9,9 @@ open Names open Term open Decl_kinds -open Constrexpr -open Vernacexpr open Pfedit type 'a declaration_hook - val mk_hook : (Decl_kinds.locality -> Globnames.global_reference -> 'a) -> 'a declaration_hook @@ -24,29 +21,31 @@ val call_hook : (** A hook start_proof calls on the type of the definition being started *) val set_start_hook : (types -> unit) -> unit -val start_proof : Id.t -> goal_kind -> Evd.evar_map -> +val start_proof : Id.t -> ?pl:universe_binders -> goal_kind -> Evd.evar_map -> ?terminator:(lemma_possible_guards -> unit declaration_hook -> Proof_global.proof_terminator) -> ?sign:Environ.named_context_val -> types -> ?init_tac:unit Proofview.tactic -> ?compute_guard:lemma_possible_guards -> unit declaration_hook -> unit -val start_proof_univs : Id.t -> goal_kind -> Evd.evar_map -> - ?terminator:(lemma_possible_guards -> (Proof_global.proof_universes option -> unit declaration_hook) -> Proof_global.proof_terminator) -> +val start_proof_univs : Id.t -> ?pl:universe_binders -> goal_kind -> Evd.evar_map -> + ?terminator:(lemma_possible_guards -> (Evd.evar_universe_context option -> unit declaration_hook) -> Proof_global.proof_terminator) -> ?sign:Environ.named_context_val -> types -> ?init_tac:unit Proofview.tactic -> ?compute_guard:lemma_possible_guards -> - (Proof_global.proof_universes option -> unit declaration_hook) -> unit + (Evd.evar_universe_context option -> unit declaration_hook) -> unit val start_proof_com : goal_kind -> Vernacexpr.proof_expr list -> unit declaration_hook -> unit val start_proof_with_initialization : - goal_kind -> Evd.evar_map -> (bool * lemma_possible_guards * unit Proofview.tactic list option) option -> - (Id.t * (types * (Name.t list * Impargs.manual_explicitation list))) list + goal_kind -> Evd.evar_map -> + (bool * lemma_possible_guards * unit Proofview.tactic list option) option -> + ((Id.t * universe_binders option) * + (types * (Name.t list * Impargs.manual_explicitation list))) list -> int list option -> unit declaration_hook -> unit val universe_proof_terminator : Proof_global.lemma_possible_guards -> - (Proof_global.proof_universes option -> unit declaration_hook) -> + (Evd.evar_universe_context option -> unit declaration_hook) -> Proof_global.proof_terminator val standard_proof_terminator : diff --git a/stm/proofworkertop.ml b/stm/proofworkertop.ml index 0e40c345c..23538a467 100644 --- a/stm/proofworkertop.ml +++ b/stm/proofworkertop.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/stm/queryworkertop.ml b/stm/queryworkertop.ml index c8e6432bb..fff6d5543 100644 --- a/stm/queryworkertop.ml +++ b/stm/queryworkertop.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/stm/spawned.ml b/stm/spawned.ml index 66fe07dbc..c6df87267 100644 --- a/stm/spawned.ml +++ b/stm/spawned.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/stm/spawned.mli b/stm/spawned.mli index d0183e081..acad49f37 100644 --- a/stm/spawned.mli +++ b/stm/spawned.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/stm/stm.ml b/stm/stm.ml index 7dc0ff84a..92032e9bc 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -53,6 +53,9 @@ let execution_error, execution_error_hook = Hook.make let unreachable_state, unreachable_state_hook = Hook.make ~default:(fun _ _ -> ()) () +let tactic_being_run, tactic_being_run_hook = Hook.make + ~default:(fun _ -> ()) () + include Hook (* enables: Hooks.(call foo args) *) @@ -80,13 +83,25 @@ let async_proofs_workers_extra_env = ref [||] type ast = { verbose : bool; loc : Loc.t; mutable expr : vernac_expr } let pr_ast { expr } = pr_vernac expr +(* Commands piercing opaque *) +let may_pierce_opaque = function + | { expr = VernacPrint (PrintName _) } -> true + | { expr = VernacExtend (("Extraction",_), _) } -> true + | { expr = VernacExtend (("SeparateExtraction",_), _) } -> true + | { expr = VernacExtend (("ExtractionLibrary",_), _) } -> true + | { expr = VernacExtend (("RecursiveExtractionLibrary",_), _) } -> true + | { expr = VernacExtend (("ExtractionConstant",_), _) } -> true + | { expr = VernacExtend (("ExtractionInlinedConstant",_), _) } -> true + | { expr = VernacExtend (("ExtractionInductive",_), _) } -> true + | _ -> false + (* Wrapper for Vernacentries.interp to set the feedback id *) let vernac_interp ?proof id ?route { verbose; loc; expr } = let rec internal_command = function | VernacResetName _ | VernacResetInitial | VernacBack _ | VernacBackTo _ | VernacRestart | VernacUndo _ | VernacUndoTo _ | VernacBacktrack _ | VernacAbortAll | VernacAbort _ -> true - | VernacTime el | VernacRedirect (_,el) -> List.for_all (fun (_,e) -> internal_command e) el + | VernacTime (_,e) | VernacRedirect (_,(_,e)) -> internal_command e | _ -> false in if internal_command expr then begin prerr_endline ("ignoring " ^ string_of_ppcmds(pr_vernac expr)) @@ -123,6 +138,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 @@ -135,9 +154,10 @@ type branch_type = 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 ] } + cqueue : [ `MainQueue | `TacQueue of cancel_switch | `QueryQueue of cancel_switch | `SkipQueue ] } type fork_t = ast * Vcs_.Branch.t * Vernacexpr.opacity_guarantee * Id.t list type qed_t = { qast : ast; @@ -505,7 +525,10 @@ end = struct (* {{{ *) let rec fill id = if (get_info id).state = None then fill (Vcs_aux.visit v id).next else copy_info_w_state v id in - fill stop + let v = fill stop in + (* We put in the new dag the first state (since Qed shall run on it, + * see check_task_aux) *) + copy_info_w_state v start let nodes_in_slice ~start ~stop = List.rev (List.map fst (nodes_in_slice ~start ~stop)) @@ -591,6 +614,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 @@ -614,6 +638,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 = @@ -624,10 +649,9 @@ end = struct (* {{{ *) States.unfreeze system; Proof_global.unfreeze proof (* hack to make futures functional *) - let in_t, out_t = Dyn.create "state4future" let () = Future.set_freeze - (fun () -> in_t (freeze_global_state `No, !cur_id)) - (fun t -> let s,i = out_t t in unfreeze_global_state s; cur_id := i) + (fun () -> Obj.magic (freeze_global_state `No, !cur_id)) + (fun t -> let s,i = Obj.magic t in unfreeze_global_state s; cur_id := i) type frozen_state = state type proof_part = @@ -721,7 +745,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); @@ -730,7 +757,7 @@ 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 @@ -1113,9 +1140,10 @@ end = struct (* {{{ *) let perform_states query = if query = [] then [] else - let is_tac = function - | VernacSolve _ | VernacFocus _ | VernacUnfocus | VernacBullet _ -> true - | _ -> false in + let is_tac e = match classify_vernac e with + | VtProofStep _, _ -> true + | _ -> false + in let initial = let rec aux id = try match VCS.visit id with { next } -> aux next @@ -1386,7 +1414,7 @@ and TacTask : sig t_state : Stateid.t; t_state_fb : Stateid.t; t_assign : output Future.assignement -> unit; - t_ast : ast; + t_ast : int * ast; t_goal : Goal.goal; t_kill : unit -> unit; t_name : string } @@ -1403,7 +1431,7 @@ end = struct (* {{{ *) t_state : Stateid.t; t_state_fb : Stateid.t; t_assign : output Future.assignement -> unit; - t_ast : ast; + t_ast : int * ast; t_goal : Goal.goal; t_kill : unit -> unit; t_name : string } @@ -1412,7 +1440,7 @@ end = struct (* {{{ *) r_state : Stateid.t; r_state_fb : Stateid.t; r_document : VCS.vcs option; - r_ast : ast; + r_ast : int * ast; r_goal : Goal.goal; r_name : string } @@ -1456,12 +1484,27 @@ end = struct (* {{{ *) | Some { t_kill } -> t_kill () | _ -> () + let command_focus = Proof.new_focus_kind () + let focus_cond = Proof.no_cond command_focus + let perform { r_state = id; r_state_fb; r_document = vcs; r_ast; r_goal } = Option.iter VCS.restore vcs; try Reach.known_state ~cache:`No id; let t, uc = Future.purify (fun () -> - vernac_interp r_state_fb r_ast; + let _,_,_,_,sigma0 = Proof.proof (Proof_global.give_me_the_proof ()) in + let g = Evd.find sigma0 r_goal in + if not ( + Evarutil.is_ground_term sigma0 Evd.(evar_concl g) && + List.for_all (Context.Named.Declaration.for_all (Evarutil.is_ground_term sigma0)) + Evd.(evar_context g)) + then + Errors.errorlabstrm "Stm" (strbrk("the par: goal selector supports ground "^ + "goals only")) + else begin + let (i, ast) = r_ast in + Proof_global.simple_with_current_proof (fun _ p -> Proof.focus focus_cond () i p); + vernac_interp r_state_fb ast; let _,_,_,_,sigma = Proof.proof (Proof_global.give_me_the_proof ()) in match Evd.(evar_body (find sigma r_goal)) with | Evd.Evar_empty -> Errors.errorlabstrm "Stm" (str "no progress") @@ -1469,9 +1512,10 @@ end = struct (* {{{ *) let t = Evarutil.nf_evar sigma t in if Evarutil.is_ground_term sigma t then t, Evd.evar_universe_context sigma - else Errors.errorlabstrm "Stm" (str"The solution is not ground")) - () in - RespBuiltSubProof (t,uc) + else Errors.errorlabstrm "Stm" (str"The solution is not ground") + end) () + in + RespBuiltSubProof (t,uc) with e when Errors.noncritical e -> RespError (Errors.print e) let name_of_task { t_name } = t_name @@ -1489,12 +1533,11 @@ end = struct (* {{{ *) module TaskQueue = AsyncTaskQueue.MakeQueue(TacTask) let vernac_interp cancel nworkers safe_id id { verbose; loc; expr = e } = - let e, etac, time, fail = + let e, time, fail = let rec find time fail = function - | VernacSolve(_,_,re,b) -> re, b, time, fail - | VernacTime [_,e] | VernacRedirect (_,[_,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 + | _ -> e, time, fail in find false false e in Hooks.call Hooks.with_fail fail (fun () -> (if time then System.with_time false else (fun x -> x)) (fun () -> ignore(TaskQueue.with_n_workers nworkers (fun queue -> @@ -1506,8 +1549,7 @@ end = struct (* {{{ *) Future.create_delegate ~name:(Printf.sprintf "subgoal %d" i) (State.exn_on id ~valid:safe_id) in - let t_ast = - { verbose;loc;expr = VernacSolve(SelectNth i,None,e,etac) } in + let t_ast = (i, { verbose; loc; expr = e }) in let t_name = Goal.uid g in TaskQueue.enqueue_task queue ({ t_state = safe_id; t_state_fb = id; @@ -1607,7 +1649,7 @@ end = struct (* {{{ *) let vernac_interp switch prev id q = assert(TaskQueue.n_workers (Option.get !queue) > 0); TaskQueue.enqueue_task (Option.get !queue) - QueryTask.({ QueryTask.t_where = prev; t_for = id; t_what = q }, switch) + QueryTask.({ t_where = prev; t_for = id; t_what = q }, switch) let init () = queue := Some (TaskQueue.create (if !Flags.async_proofs_full then 1 else 0)) @@ -1636,7 +1678,7 @@ let delegate name = let time = get_hint_bp_time name in time >= 1.0 || !Flags.compilation_mode = Flags.BuildVio || !Flags.async_proofs_full - + let collect_proof keep cur hd brkind id = prerr_endline ("Collecting proof ending at "^Stateid.to_string id); let no_name = "" in @@ -1658,16 +1700,20 @@ let collect_proof keep cur hd brkind id = let has_proof_no_using = function | Some (_, { expr = VernacProof(_,None) }) -> true | _ -> false in - let may_pierce_opaque = function - | { expr = VernacPrint (PrintName _) } -> true - | _ -> false in + let too_complex_to_delegate = function + | { expr = (VernacDeclareModule _ + | VernacDefineModule _ + | VernacDeclareModuleType _ + | VernacInclude _) } -> true + | { expr = (VernacRequire _ | VernacImport _) } -> true + | ast -> may_pierce_opaque ast in let parent = function Some (p, _) -> p | None -> assert false in let is_empty = function `Async(_,_,[],_,_) | `MaybeASync(_,_,[],_,_) -> true | _ -> false in let rec collect last accn id = let view = VCS.visit id in match view.step with | (`Sideff (`Ast(x,_)) | `Cmd { cast = x }) - when may_pierce_opaque x -> `Sync(no_name,None,`Print) + when too_complex_to_delegate x -> `Sync(no_name,None,`Print) | `Cmd { cast = x } -> collect (Some (id,x)) (id::accn) view.next | `Sideff (`Ast(x,_)) -> collect (Some (id,x)) (id::accn) view.next (* An Alias could jump everywhere... we hope we can ignore it*) @@ -1753,8 +1799,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; @@ -1774,19 +1821,26 @@ let known_state ?(redefine_qed=false) ~cache id = | `Alias (id,_) -> (fun () -> reach view.next; reach id ), cache, true + | `Cmd { cast = x; cqueue = `SkipQueue } -> (fun () -> + reach view.next), cache, true | `Cmd { cast = x; cqueue = `TacQueue cancel } -> (fun () -> reach ~cache:`Shallow view.next; + Hooks.(call tactic_being_run true); Partac.vernac_interp - cancel !Flags.async_proofs_n_tacworkers view.next id x + cancel !Flags.async_proofs_n_tacworkers view.next id x; + Hooks.(call tactic_being_run false) ), cache, true | `Cmd { cast = x; cqueue = `QueryQueue cancel } when Flags.async_proofs_is_master () -> (fun () -> reach view.next; Query.vernac_interp cancel view.next id x ), cache, false - | `Cmd { cast = x } -> (fun () -> - reach view.next; vernac_interp id x - ), cache, true + | `Cmd { cast = x; ceff = eff; ctac } -> (fun () -> + reach view.next; + if ctac then Hooks.(call tactic_being_run true); + vernac_interp id x; + if ctac then Hooks.(call tactic_being_run false); + 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 () @@ -1885,7 +1939,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; @@ -2134,8 +2188,12 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) = let id = VCS.new_node ~id:newtip () in let queue = if !Flags.async_proofs_full then `QueryQueue (ref false) + else if Flags.(!compilation_mode = BuildVio) && + VCS.((get_branch head).kind = `Master) && + may_pierce_opaque x + then `SkipQueue 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") @@ -2158,7 +2216,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) = anomaly(str"VtProofMode must be executed VtNow") | VtProofMode mode, VtNow -> let id = VCS.new_node ~id:newtip () in - VCS.commit id (Cmd {ctac=false;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 } -> () @@ -2176,7 +2234,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 @@ -2192,7 +2250,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 @@ -2212,11 +2270,16 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) = Proof_global.there_are_pending_proofs () then begin let bname = VCS.mk_branch_name x in - VCS.commit id (Fork (x,bname,Doesn'tGuaranteeOpacity,[])); + let opacity_of_produced_term = + match x.expr with + | VernacInstance (false, _,_ , None, _) -> GuaranteesOpacity + | _ -> Doesn'tGuaranteeOpacity in + VCS.commit id (Fork (x,bname,opacity_of_produced_term,[])); 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 @@ -2305,6 +2368,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 @@ -2315,7 +2389,9 @@ 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 - | { step = (`Fork _ | `Sideff _ | `Qed _) } -> tip + | { 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 old_branch = let master_id, cancel_switch, keep = @@ -2365,7 +2441,7 @@ let edit_at id = | _, Some _, None -> assert false | 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 + 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) -> @@ -2551,5 +2627,6 @@ 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 +let tactic_being_run_hook = Hooks.tactic_being_run_hook (* vim:set foldmethod=marker: *) diff --git a/stm/stm.mli b/stm/stm.mli index 18ed6fc2e..4279921b3 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -9,6 +9,7 @@ open Vernacexpr open Names open Feedback +open Loc (** state-transaction-machine interface *) @@ -19,7 +20,7 @@ open Feedback The sentence [s] is parsed in the state [ontop]. If [newtip] is provided, then the returned state id is guaranteed to be [newtip] *) -val add : ontop:Stateid.t -> ?newtip:Stateid.t -> ?check:(located_vernac_expr -> unit) -> +val add : ontop:Stateid.t -> ?newtip:Stateid.t -> ?check:(vernac_expr located -> unit) -> bool -> edit_id -> string -> Stateid.t * [ `NewTip | `Unfocus of Stateid.t ] @@ -107,6 +108,9 @@ val execution_error_hook : (Stateid.t -> Loc.t -> Pp.std_ppcmds -> 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 +(* called with true before and with false after a tactic explicitly + * in the document is run *) +val tactic_being_run_hook : (bool -> unit) Hook.t (* Messages from the workers to the master *) val forward_feedback_hook : (Feedback.feedback -> unit) Hook.t @@ -123,7 +127,7 @@ val state_of_id : Stateid.t -> [ `Valid of state option | `Expired ] (* Adds a new line to the document. It replaces the core of Vernac.interp. [finish] is called as the last bit of this function is the system is running interactively (-emacs or coqtop). *) -val interp : bool -> located_vernac_expr -> unit +val interp : bool -> vernac_expr located -> unit (* Queries for backward compatibility *) val current_proof_depth : unit -> int @@ -136,3 +140,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 2dad962be..ee121c46a 100644 --- a/stm/tQueue.ml +++ b/stm/tQueue.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/stm/tQueue.mli b/stm/tQueue.mli index 1df52d252..27eca12af 100644 --- a/stm/tQueue.mli +++ b/stm/tQueue.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/stm/tacworkertop.ml b/stm/tacworkertop.ml index c1a37fed9..d5333d107 100644 --- a/stm/tacworkertop.ml +++ b/stm/tacworkertop.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/stm/texmacspp.ml b/stm/texmacspp.ml index b91208041..2d2ea1f8b 100644 --- a/stm/texmacspp.ml +++ b/stm/texmacspp.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -20,9 +20,6 @@ let unlock loc = let start, stop = Loc.unloc loc in (string_of_int start, string_of_int stop) -let xmlNoop = (* almost noop *) - PCData "" - let xmlWithLoc loc ename attr xml = let start, stop = unlock loc in Element(ename, [ "begin", start; "end", stop ] @ attr, xml) @@ -307,7 +304,13 @@ and pp_cases_pattern_expr cpe = xmlApply loc (xmlOperator "alias" ~attr:["name", string_of_id id] loc :: [pp_cases_pattern_expr cpe]) - | CPatCstr (loc, ref, cpel1, cpel2) -> + | CPatCstr (loc, ref, None, cpel2) -> + xmlApply loc + (xmlOperator "reference" + ~attr:["name", Libnames.string_of_reference ref] loc :: + [Element ("impargs", [], []); + Element ("args", [], (List.map pp_cases_pattern_expr cpel2))]) + | CPatCstr (loc, ref, Some cpel1, cpel2) -> xmlApply loc (xmlOperator "reference" ~attr:["name", Libnames.string_of_reference ref] loc :: @@ -347,7 +350,7 @@ and pp_cases_pattern_expr cpe = xmlApply loc (xmlOperator "delimiter" ~attr:["name", delim] loc :: [pp_cases_pattern_expr cpe]) -and pp_case_expr (e, (name, pat)) = +and pp_case_expr (e, name, pat) = match name, pat with | None, None -> xmlScrutinee [pp_expr e] | Some (loc, name), None -> @@ -460,7 +463,7 @@ and pp_expr ?(attr=[]) e = (return @ [Element ("scrutinees", [], List.map pp_case_expr cel)] @ [pp_branch_expr_list bel])) - | CRecord (_, _, _) -> assert false + | CRecord (_, _) -> assert false | CLetIn (loc, (varloc, var), value, body) -> xmlApply loc (xmlOperator "let" loc :: @@ -487,12 +490,12 @@ let rec tmpp v loc = (* Control *) | VernacLoad (verbose,f) -> xmlWithLoc loc "load" ["verbose",string_of_bool verbose;"file",f] [] - | VernacTime l -> + | VernacTime (loc,e) -> xmlApply loc (Element("time",[],[]) :: - List.map (fun(loc,e) ->tmpp e loc) l) - | VernacRedirect (s, l) -> + [tmpp e loc]) + | VernacRedirect (s, (loc,e)) -> xmlApply loc (Element("redirect",["path", s],[]) :: - List.map (fun(loc,e) ->tmpp e loc) l) + [tmpp e loc]) | VernacTimeout (s,e) -> xmlApply loc (Element("timeout",["val",string_of_int s],[]) :: [tmpp e loc]) @@ -500,9 +503,6 @@ let rec tmpp v loc = | VernacError _ -> xmlWithLoc loc "error" [] [] (* Syntax *) - | VernacTacticNotation _ as x -> - xmlLtac loc [PCData (Pp.string_of_ppcmds (Ppvernac.pr_vernac x))] - | VernacSyntaxExtension (_, ((_, name), sml)) -> let attrs = List.flatten (List.map attribute_of_syntax_modifier sml) in xmlReservedNotation attrs name loc @@ -668,7 +668,7 @@ let rec tmpp v loc = (* Solving *) - | (VernacSolve _ | VernacSolveExistential _) as x -> + | (VernacSolveExistential _) as x -> xmlLtac loc [PCData (Pp.string_of_ppcmds (Ppvernac.pr_vernac x))] (* Auxiliary file and library management *) @@ -694,7 +694,6 @@ let rec tmpp v loc = | VernacBackTo _ -> PCData "VernacBackTo" (* Commands *) - | VernacDeclareTacticDefinition _ as x -> xmlTODO loc x | VernacCreateHintDb _ as x -> xmlTODO loc x | VernacRemoveHints _ as x -> xmlTODO loc x | VernacHints _ as x -> xmlTODO loc x @@ -724,7 +723,6 @@ let rec tmpp v loc = | VernacRegister _ as x -> xmlTODO loc x | VernacComments (cl) -> xmlComment loc (List.flatten (List.map pp_comment cl)) - | VernacNop as x -> xmlTODO loc x (* Stm backdoor *) | VernacStm _ as x -> xmlTODO loc x diff --git a/stm/texmacspp.mli b/stm/texmacspp.mli index 58dec8fdc..858847fb6 100644 --- a/stm/texmacspp.mli +++ b/stm/texmacspp.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/stm/vcs.ml b/stm/vcs.ml index dfcbc19ae..38c029901 100644 --- a/stm/vcs.ml +++ b/stm/vcs.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/stm/vcs.mli b/stm/vcs.mli index fb79d02cb..8f22fee84 100644 --- a/stm/vcs.mli +++ b/stm/vcs.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index a898c687b..ecaf0fb7c 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -60,7 +60,7 @@ let undo_classifier = ref (fun _ -> assert false) let set_undo_classifier f = undo_classifier := f let rec classify_vernac e = - let rec static_classifier e = match e with + let static_classifier e = match e with (* PG compatibility *) | VernacUnsetOption (["Silent"]|["Undo"]|["Printing";"Depth"]) | VernacSetOption ((["Silent"]|["Undo"]|["Printing";"Depth"]),_) @@ -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 | VernacRedirect (_, e) -> classify_vernac_list e + | VernacTime (_,e) | VernacRedirect (_, (_,e)) -> classify_vernac e | VernacFail e -> (* Fail Qed or Fail Lemma must not join/fork the DAG *) (match classify_vernac e with | ( VtQuery _ | VtProofStep _ | VtSideff _ @@ -102,12 +102,10 @@ let rec classify_vernac e = | VernacCheckMayEval _ -> VtQuery (true,(Stateid.dummy,Feedback.default_route)), VtLater (* ProofStep *) - | VernacSolve (SelectAllParallel,_,_,_) -> VtProofStep true, VtLater | VernacProof _ | VernacBullet _ | VernacFocus _ | VernacUnfocus | VernacSubproof _ | VernacEndSubproof - | VernacSolve _ | VernacCheckGuard | VernacUnfocused | VernacSolveExistential _ -> VtProofStep false, VtLater @@ -175,11 +173,6 @@ let rec classify_vernac e = | VernacRegister _ | 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 *) @@ -195,7 +188,6 @@ let rec classify_vernac e = | VernacInfix _ | VernacNotation _ | VernacNotationAddFormat _ | VernacSyntaxExtension _ | VernacSyntacticDefinition _ - | VernacTacticNotation _ | VernacRequire _ | VernacImport _ | VernacInclude _ | VernacDeclareMLModule _ | VernacContext _ (* TASSI: unsure *) @@ -208,7 +200,6 @@ let rec classify_vernac e = | VernacResetName _ | VernacResetInitial | VernacBacktrack _ | VernacBackTo _ | VernacRestart -> !undo_classifier e (* What are these? *) - | VernacNop | VernacToplevelControl _ | VernacRestoreState _ | VernacWriteState _ -> VtUnknown, VtNow @@ -217,13 +208,6 @@ let rec classify_vernac e = | VernacExtend (s,l) -> try List.assoc s !classifiers l () with Not_found -> anomaly(str"No classifier for"++spc()++str (fst s)) - and classify_vernac_list = function - (* spiwack: It would be better to define a monoid on classifiers. - So that the classifier of the list would be the composition of - the classifier of the individual commands. Currently: special - case for singleton lists.*) - | [_,c] -> static_classifier c - | l -> VtUnknown,VtNow in let res = static_classifier e in if Flags.is_universe_polymorphism () then diff --git a/stm/vernac_classifier.mli b/stm/vernac_classifier.mli index 0680fe842..45ca5cf6b 100644 --- a/stm/vernac_classifier.mli +++ b/stm/vernac_classifier.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/stm/vio_checking.ml b/stm/vio_checking.ml index 06bf955c8..d4dcf72c1 100644 --- a/stm/vio_checking.ml +++ b/stm/vio_checking.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -43,7 +43,7 @@ let schedule_vio_checking j fs = let rec filter_argv b = function | [] -> [] | "-schedule-vio-checking" :: rest -> filter_argv true rest - | s :: rest when s.[0] = '-' && b -> filter_argv false (s :: rest) + | s :: rest when String.length s > 0 && s.[0] = '-' && b -> filter_argv false (s :: rest) | _ :: rest when b -> filter_argv b rest | s :: rest -> s :: filter_argv b rest in let pack = function diff --git a/stm/vio_checking.mli b/stm/vio_checking.mli index e2da50269..c0b6d9e6f 100644 --- a/stm/vio_checking.mli +++ b/stm/vio_checking.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/stm/workerPool.ml b/stm/workerPool.ml index db3bb5ad4..b94fae547 100644 --- a/stm/workerPool.ml +++ b/stm/workerPool.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/stm/workerPool.mli b/stm/workerPool.mli index f46303b54..75c325360 100644 --- a/stm/workerPool.mli +++ b/stm/workerPool.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/tactics/auto.ml b/tactics/auto.ml index 4a520612f..fc6ff03b4 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -67,9 +67,6 @@ let auto_unif_flags_of st1 st2 useeager = let auto_unif_flags = auto_unif_flags_of full_transparent_state empty_transparent_state false -let auto_flags_of_state st = - auto_unif_flags_of full_transparent_state st false - (* Try unification with the precompiled clause, then use registered Apply *) let connect_hint_clenv poly (c, _, ctx) clenv gl = @@ -85,11 +82,14 @@ let connect_hint_clenv poly (c, _, ctx) clenv gl = 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 + (** Only metas are mentioning the old universes. *) + let clenv = { + templval = Evd.map_fl map clenv.templval; + templtyp = Evd.map_fl map clenv.templtyp; + evd = Evd.map_metas map evd; + env = Proofview.Goal.env gl; + } in + 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 @@ -119,7 +119,8 @@ let exact poly (c,clenv) = let ctx = Evd.evar_universe_context clenv.evd in ctx, c in - Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in let sigma = Sigma.to_evar_map sigma in let sigma = Evd.merge_universe_context sigma ctx in Sigma.Unsafe.of_pair (exact_check c', sigma) @@ -139,8 +140,6 @@ si après Intros la conclusion matche le pattern. (* conclPattern doit échouer avec error car il est rattraper par tclFIRST *) -let (forward_interp_tactic, extern_interp) = Hook.make () - let conclPattern concl pat tac = let constr_bindings env sigma = match pat with @@ -155,7 +154,13 @@ let conclPattern concl pat tac = let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in constr_bindings env sigma >>= fun constr_bindings -> - Hook.get forward_interp_tactic constr_bindings tac + let open Genarg in + let open Geninterp in + let inj c = Val.Dyn (val_tag (topwit Constrarg.wit_constr), c) in + let fold id c accu = Id.Map.add id (inj c) accu in + let lfun = Id.Map.fold fold constr_bindings Id.Map.empty in + let ist = { lfun; extra = TacStore.empty } in + Ftactic.run (Geninterp.generic_interp ist tac) (fun _ -> Proofview.tclUNIT ()) end } (***********************************************************) @@ -295,9 +300,6 @@ let tclTRY_dbg d tac = (* Papageno : cette fonction a été pas mal simplifiée depuis que la base de Hint impérative a été remplacée par plusieurs bases fonctionnelles *) -let auto_unif_flags = - auto_unif_flags_of full_transparent_state empty_transparent_state false - let flags_of_state st = auto_unif_flags_of st st false @@ -326,7 +328,7 @@ let rec trivial_fail_db dbg mod_delta db_list local_db = let env = Proofview.Goal.env gl in let nf c = Evarutil.nf_evar sigma c in let decl = Tacmach.New.pf_last_hyp (Proofview.Goal.assume gl) in - let hyp = Context.map_named_declaration nf decl in + let hyp = Context.Named.Declaration.map_constr nf decl in let hintl = make_resolve_hyp env sigma hyp in trivial_fail_db dbg mod_delta db_list (Hint_db.add_list env sigma hintl local_db) @@ -392,7 +394,7 @@ and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly})) | Unfold_nth c -> Proofview.V82.tactic (fun gl -> if exists_evaluable_reference (pf_env gl) c then - tclPROGRESS (reduce (Unfold [AllOccurrences,c]) Locusops.onConcl) gl + tclPROGRESS (Proofview.V82.of_tactic (reduce (Unfold [AllOccurrences,c]) Locusops.onConcl)) gl else tclFAIL 0 (str"Unbound reference") gl) | Extern tacast -> conclPattern concl p tacast diff --git a/tactics/auto.mli b/tactics/auto.mli index 215544a59..8c4f35904 100644 --- a/tactics/auto.mli +++ b/tactics/auto.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -10,13 +10,9 @@ open Names open Term open Clenv open Pattern -open Evd open Decl_kinds open Hints -val extern_interp : - (patvar_map -> Tacexpr.glob_tactic_expr -> unit Proofview.tactic) Hook.t - (** Auto and related automation tactics *) val priority : ('a * full_hint) list -> ('a * full_hint) list @@ -29,8 +25,6 @@ val connect_hint_clenv : polymorphic -> raw_hint -> clausenv -> ([ `NF ], 'r) Proofview.Goal.t -> clausenv * constr (** Try unification with the precompiled clause, then use registered Apply *) -val unify_resolve_nodelta : polymorphic -> (raw_hint * clausenv) -> unit Proofview.tactic - val unify_resolve : polymorphic -> Unification.unify_flags -> (raw_hint * clausenv) -> unit Proofview.tactic (** [ConclPattern concl pat tacast]: @@ -38,7 +32,7 @@ val unify_resolve : polymorphic -> Unification.unify_flags -> (raw_hint * clause [Pattern.somatches], then replace [?1] [?2] metavars in tacast by the right values to build a tactic *) -val conclPattern : constr -> constr_pattern option -> Tacexpr.glob_tactic_expr -> unit Proofview.tactic +val conclPattern : constr -> constr_pattern option -> Genarg.glob_generic_argument -> unit Proofview.tactic (** The Auto tactic *) @@ -46,24 +40,24 @@ val conclPattern : constr -> constr_pattern option -> Tacexpr.glob_tactic_expr - "nocore" amongst the databases. *) val auto : ?debug:Tacexpr.debug -> - int -> open_constr list -> hint_db_name list -> unit Proofview.tactic + int -> Tacexpr.delayed_open_constr list -> hint_db_name list -> unit Proofview.tactic (** Auto with more delta. *) val new_auto : ?debug:Tacexpr.debug -> - int -> open_constr list -> hint_db_name list -> unit Proofview.tactic + int -> Tacexpr.delayed_open_constr list -> hint_db_name list -> unit Proofview.tactic (** auto with default search depth and with the hint database "core" *) val default_auto : unit Proofview.tactic (** auto with all hint databases except the "v62" compatibility database *) val full_auto : ?debug:Tacexpr.debug -> - int -> open_constr list -> unit Proofview.tactic + int -> Tacexpr.delayed_open_constr list -> unit Proofview.tactic (** auto with all hint databases except the "v62" compatibility database and doing delta *) val new_full_auto : ?debug:Tacexpr.debug -> - int -> open_constr list -> unit Proofview.tactic + int -> Tacexpr.delayed_open_constr list -> unit Proofview.tactic (** auto with default search depth and with all hint databases except the "v62" compatibility database *) @@ -71,19 +65,19 @@ val default_full_auto : unit Proofview.tactic (** The generic form of auto (second arg [None] means all bases) *) val gen_auto : ?debug:Tacexpr.debug -> - int option -> open_constr list -> hint_db_name list option -> unit Proofview.tactic + int option -> Tacexpr.delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic (** The hidden version of auto *) val h_auto : ?debug:Tacexpr.debug -> - int option -> open_constr list -> hint_db_name list option -> unit Proofview.tactic + int option -> Tacexpr.delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic (** Trivial *) val trivial : ?debug:Tacexpr.debug -> - open_constr list -> hint_db_name list -> unit Proofview.tactic + Tacexpr.delayed_open_constr list -> hint_db_name list -> unit Proofview.tactic val gen_trivial : ?debug:Tacexpr.debug -> - open_constr list -> hint_db_name list option -> unit Proofview.tactic + Tacexpr.delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic val full_trivial : ?debug:Tacexpr.debug -> - open_constr list -> unit Proofview.tactic + Tacexpr.delayed_open_constr list -> unit Proofview.tactic val h_trivial : ?debug:Tacexpr.debug -> - open_constr list -> hint_db_name list option -> unit Proofview.tactic + Tacexpr.delayed_open_constr list -> hint_db_name list option -> unit Proofview.tactic diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index 43a8d7f06..4816f8a45 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -27,13 +27,13 @@ type rew_rule = { rew_lemma: constr; rew_pat: constr; rew_ctx: Univ.universe_context_set; rew_l2r: bool; - rew_tac: glob_tactic_expr option } + rew_tac: Genarg.glob_generic_argument option } let subst_hint subst hint = let cst' = subst_mps subst hint.rew_lemma in let typ' = subst_mps subst hint.rew_type in let pat' = subst_mps subst hint.rew_pat in - let t' = Option.smartmap (Tacsubst.subst_tactic subst) hint.rew_tac in + let t' = Option.smartmap (Genintern.generic_substitute subst) hint.rew_tac in if hint.rew_lemma == cst' && hint.rew_type == typ' && hint.rew_tac == t' then hint else { hint with rew_lemma = cst'; rew_type = typ'; @@ -85,16 +85,17 @@ let print_rewrite_hintdb bas = str (if h.rew_l2r then "rewrite -> " else "rewrite <- ") ++ Printer.pr_lconstr h.rew_lemma ++ str " of type " ++ Printer.pr_lconstr h.rew_type ++ Option.cata (fun tac -> str " then use tactic " ++ - Pptactic.pr_glob_tactic (Global.env()) tac) (mt ()) h.rew_tac) + Pptactic.pr_glb_generic (Global.env()) tac) (mt ()) h.rew_tac) (find_rewrites bas)) -type raw_rew_rule = Loc.t * constr Univ.in_universe_context_set * bool * raw_tactic_expr option +type raw_rew_rule = Loc.t * constr Univ.in_universe_context_set * bool * Genarg.raw_generic_argument option (* Applies all the rules of one base *) let one_base general_rewrite_maybe_in tac_main bas = let lrul = find_rewrites bas in let try_rewrite dir ctx c tc = - Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in let subst, ctx' = Universes.fresh_universe_context_set_instance ctx in let c' = Vars.subst_univs_level_constr subst c in let sigma = Sigma.to_evar_map sigma in @@ -103,7 +104,12 @@ let one_base general_rewrite_maybe_in tac_main bas = Sigma.Unsafe.of_pair (tac, sigma) end } in let lrul = List.map (fun h -> - let tac = match h.rew_tac with None -> Proofview.tclUNIT () | Some t -> Tacinterp.eval_tactic t in + let tac = match h.rew_tac with + | None -> Proofview.tclUNIT () + | Some tac -> + let ist = { Geninterp.lfun = Id.Map.empty; extra = Geninterp.TacStore.empty } in + Ftactic.run (Geninterp.generic_interp ist tac) (fun _ -> Proofview.tclUNIT ()) + in (h.rew_ctx,h.rew_lemma,h.rew_l2r,tac)) lrul in Tacticals.New.tclREPEAT_MAIN (Proofview.tclPROGRESS (List.fold_left (fun tac (ctx,csr,dir,tc) -> Tacticals.New.tclTHEN tac @@ -132,7 +138,7 @@ let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas = fun dir cstr tac gl -> let last_hyp_id = match Tacmach.pf_hyps gl with - (last_hyp_id,_,_)::_ -> last_hyp_id + d :: _ -> Context.Named.Declaration.get_id d | _ -> (* even the hypothesis id is missing *) raise (Logic.RefinerError (Logic.NoSuchHyp !id)) in @@ -141,7 +147,8 @@ let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas = match gls with g::_ -> (match Environ.named_context_of_val (Goal.V82.hyps gl'.Evd.sigma g) with - (lastid,_,_)::_ -> + d ::_ -> + let lastid = Context.Named.Declaration.get_id d in if not (Id.equal last_hyp_id lastid) then begin let gl'' = @@ -196,7 +203,8 @@ let gen_auto_multi_rewrite conds tac_main lbas cl = try_do_hyps (fun id -> id) ids end }) -let auto_multi_rewrite ?(conds=Naive) = gen_auto_multi_rewrite conds (Proofview.tclUNIT()) +let auto_multi_rewrite ?(conds=Naive) lems cl = + Proofview.V82.wrap_exceptions (fun () -> gen_auto_multi_rewrite conds (Proofview.tclUNIT()) lems cl) let auto_multi_rewrite_with ?(conds=Naive) tac_main lbas cl = let onconcl = match cl.Locus.concl_occs with NoOccurrences -> false | _ -> true in @@ -205,7 +213,7 @@ let auto_multi_rewrite_with ?(conds=Naive) tac_main lbas cl = (* autorewrite with .... in clause using tac n'est sur que si clause represente soit le but soit UNE hypothese *) - gen_auto_multi_rewrite conds tac_main lbas cl + Proofview.V82.wrap_exceptions (fun () -> gen_auto_multi_rewrite conds tac_main lbas cl) | _ -> Tacticals.New.tclZEROMSG (strbrk "autorewrite .. in .. using can only be used either with a unique hypothesis or on the conclusion.") @@ -297,6 +305,8 @@ let add_rew_rules base lrul = let counter = ref 0 in let env = Global.env () in let sigma = Evd.from_env env in + let ist = { Genintern.ltacvars = Id.Set.empty; genv = Global.env () } in + let intern tac = snd (Genintern.generic_intern ist tac) in let lrul = List.fold_left (fun dn (loc,(c,ctx),b,t) -> @@ -305,7 +315,7 @@ let add_rew_rules base lrul = 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; - rew_tac = Option.map Tacintern.glob_tactic t} + rew_tac = Option.map intern t} in incr counter; HintDN.add pat (!counter, rul) dn) HintDN.empty lrul in Lib.add_anonymous_leaf (inHintRewrite (base,lrul)) diff --git a/tactics/autorewrite.mli b/tactics/autorewrite.mli index 9905b5202..ac613b57c 100644 --- a/tactics/autorewrite.mli +++ b/tactics/autorewrite.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -11,7 +11,7 @@ open Tacexpr open Equality (** Rewriting rules before tactic interpretation *) -type raw_rew_rule = Loc.t * Term.constr Univ.in_universe_context_set * bool * Tacexpr.raw_tactic_expr option +type raw_rew_rule = Loc.t * constr Univ.in_universe_context_set * bool * Genarg.raw_generic_argument option (** To add rewriting rules to a base *) val add_rew_rules : string -> raw_rew_rule list -> unit @@ -29,7 +29,7 @@ type rew_rule = { rew_lemma: constr; rew_pat: constr; rew_ctx: Univ.universe_context_set; rew_l2r: bool; - rew_tac: glob_tactic_expr option } + rew_tac: Genarg.glob_generic_argument option } val find_rewrites : string -> rew_rule list diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml index b87d65753..491bc8b4a 100644 --- a/tactics/btermdn.ml +++ b/tactics/btermdn.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/tactics/btermdn.mli b/tactics/btermdn.mli index f29d18615..8ca5549b8 100644 --- a/tactics/btermdn.mli +++ b/tactics/btermdn.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 8ee3ec928..485559898 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -158,9 +158,9 @@ let e_give_exact flags poly (c,clenv) gl = let c, gl = if poly then let clenv', subst = Clenv.refresh_undefined_univs clenv in - let clenv' = connect_clenv gl clenv' in + let evd = evars_reset_evd ~with_conv_pbs:true gl.sigma clenv'.evd in let c = Vars.subst_univs_level_constr subst c in - c, {gl with sigma = clenv'.evd} + c, {gl with sigma = evd} else c, gl in let t1 = pf_unsafe_type_of gl c in @@ -245,7 +245,7 @@ and e_my_find_search db_list local_db hdc complete sigma concl = 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])) + | Unfold_nth c -> Proofview.V82.tactic (tclWEAK_PROGRESS (Proofview.V82.of_tactic (unfold_in_concl [AllOccurrences,c]))) | Extern tacast -> conclPattern concl p tacast in let tac = Proofview.V82.of_tactic (run_hint t tac) in @@ -302,8 +302,10 @@ type ('a,'b) optionk2 = | Nonek2 of failure | Somek2 of 'a * 'b * ('a,'b) optionk2 fk -let make_resolve_hyp env sigma st flags only_classes pri (id, _, cty) = - let cty = Evarutil.nf_evar sigma cty in +let make_resolve_hyp env sigma st flags only_classes pri decl = + let open Context.Named.Declaration in + let id = get_id decl in + let cty = Evarutil.nf_evar sigma (get_type decl) in let rec iscl env ty = let ctx, ar = decompose_prod_assum ty in match kind_of_term (fst (decompose_app ar)) with @@ -345,9 +347,10 @@ let make_hints g st only_classes sign = List.fold_left (fun (paths, hints) hyp -> let consider = - try let (_, b, t) = Global.lookup_named (pi1 hyp) in + let open Context.Named.Declaration in + try let t = Global.lookup_named (get_id hyp) |> get_type in (* Section variable, reindex only if the type changed *) - not (Term.eq_constr t (pi3 hyp)) + not (Term.eq_constr t (get_type hyp)) with Not_found -> true in if consider then @@ -569,14 +572,6 @@ let rec fix_limit limit (t : 'a tac) : 'a tac = if Int.equal limit 0 then fail_tac ReachedLimit else then_tac t { skft = fun sk fk -> (fix_limit (pred limit) t).skft sk fk } -let fix_iterative' t = - let rec aux depth = - { skft = fun sk fk gls -> - (fix_limit depth t).skft sk - (function NotApplicable as e -> fk e - | ReachedLimit -> (aux (succ depth)).skft sk fk gls) gls } - in aux 1 - let fix_iterative t = let rec aux depth = or_else_tac (fix_limit depth t) diff --git a/tactics/class_tactics.mli b/tactics/class_tactics.mli index c6207ed63..f1bcfa7dd 100644 --- a/tactics/class_tactics.mli +++ b/tactics/class_tactics.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index 0cc74ff44..ab6fb37fd 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -15,6 +15,7 @@ open Reductionops open Misctypes open Sigma.Notations open Proofview.Notations +open Context.Named.Declaration (* Absurd *) @@ -24,7 +25,8 @@ let mk_absurd_proof t = mkLambda (Names.Name id,t,mkApp (mkRel 2,[|mkRel 1|]))) let absurd c = - Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let sigma = Sigma.to_evar_map sigma in let j = Retyping.get_judgment_of env sigma c in @@ -46,7 +48,7 @@ let absurd c = absurd c let filter_hyp f tac = let rec seek = function | [] -> Proofview.tclZERO Not_found - | (id,_,t)::rest when f t -> tac id + | d::rest when f (get_type d) -> tac (get_id d) | _::rest -> seek rest in Proofview.Goal.enter { enter = begin fun gl -> let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in @@ -59,8 +61,9 @@ let contradiction_context = let env = Proofview.Goal.env gl in let rec seek_neg l = match l with | [] -> Tacticals.New.tclZEROMSG (Pp.str"No such contradiction") - | (id,_,typ)::rest -> - let typ = nf_evar sigma typ in + | d :: rest -> + let id = get_id d in + let typ = nf_evar sigma (get_type d) in let typ = whd_betadeltaiota env sigma typ in if is_empty_type typ then simplest_elim (mkVar id) diff --git a/tactics/contradiction.mli b/tactics/contradiction.mli index 25d07e259..b876aee90 100644 --- a/tactics/contradiction.mli +++ b/tactics/contradiction.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/tactics/dnet.ml b/tactics/dnet.ml index 93334db73..c501e3062 100644 --- a/tactics/dnet.ml +++ b/tactics/dnet.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/tactics/dnet.mli b/tactics/dnet.mli index 52853d702..9f29c60b6 100644 --- a/tactics/dnet.mli +++ b/tactics/dnet.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml index dbdfb3e92..9cfb805d4 100644 --- a/tactics/eauto.ml4 +++ b/tactics/eauto.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4deps: "grammar/grammar.cma" i*) - open Pp open Errors open Util @@ -30,8 +28,6 @@ open Locusops open Hints open Proofview.Notations -DECLARE PLUGIN "eauto" - let eauto_unif_flags = auto_flags_of_state full_transparent_state let e_give_exact ?(flags=eauto_unif_flags) c = @@ -50,20 +46,22 @@ let e_assumption = Tacticals.New.tclFIRST (List.map assumption (Tacmach.New.pf_ids_of_hyps gl)) end } -TACTIC EXTEND eassumption -| [ "eassumption" ] -> [ e_assumption ] -END - -TACTIC EXTEND eexact -| [ "eexact" constr(c) ] -> [ e_give_exact c ] -END - let registered_e_assumption = Proofview.Goal.enter { enter = begin fun gl -> Tacticals.New.tclFIRST (List.map (fun id -> e_give_exact (mkVar id)) (Tacmach.New.pf_ids_of_hyps gl)) end } +let eval_uconstrs ist cs = + let flags = { + Pretyping.use_typeclasses = false; + use_unif_heuristics = true; + use_hook = Some Pfedit.solve_by_implicit_tactic; + fail_evar = false; + expand_evars = true + } in + List.map (fun c -> Pretyping.type_uconstr ~flags ist c) cs + (************************************************************************) (* PROLOG tactic *) (************************************************************************) @@ -102,20 +100,18 @@ let out_term = function | IsConstr (c, _) -> c | 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 (false,true)) gl x)) l in - let n = - match n with - | ArgArg n -> n - | _ -> error "Prolog called with a non closed argument." +let prolog_tac l n = + Proofview.V82.tactic begin fun gl -> + let map c = + let (c, sigma) = Tactics.run_delayed (pf_env gl) (project gl) c in + let c = pf_apply (prepare_hint false (false,true)) gl (sigma, c) in + out_term c in + let l = List.map map l in try (prolog l n gl) with UserError ("Refiner.tclFIRST",_) -> errorlabstrm "Prolog.prolog" (str "Prolog failed.") - -TACTIC EXTEND prolog -| [ "prolog" "[" open_constr_list(l) "]" int_or_var(n) ] -> [ Proofview.V82.tactic (prolog_tac l n) ] -END + end open Auto open Unification @@ -175,6 +171,10 @@ and e_my_find_search db_list local_db hdc concl = in let tac_of_hint = fun (st, {pri = b; pat = p; code = t; poly = poly}) -> + let b = match Hints.repr_hint t with + | Unfold_nth _ -> 1 + | _ -> b + in (b, let tac = function | Res_pf (term,cl) -> unify_resolve poly st (term,cl) @@ -183,7 +183,7 @@ and e_my_find_search db_list local_db hdc concl = | Res_pf_THEN_trivial_fail (term,cl) -> Tacticals.New.tclTHEN (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) + | Unfold_nth c -> reduce (Unfold [AllOccurrences,c]) onConcl | Extern tacast -> conclPattern concl p tacast in let tac = run_hint t tac in @@ -214,7 +214,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 : Tacexpr.delayed_open_constr list; } and prev_search_state = (* for info eauto *) @@ -253,8 +254,8 @@ module SearchProblem = struct let d = s'.depth - s.depth in let d' = Int.compare s.priority s'.priority in let nbgoals s = List.length (sig_it s.tacres) in - if not (Int.equal d' 0) then d' - else if not (Int.equal d 0) then d + if not (Int.equal d 0) then d + else if not (Int.equal d' 0) then d' else Int.compare (nbgoals s) (nbgoals s') let branching s = @@ -273,7 +274,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 [Tactics.intro, (-1), lazy (str "intro")] in @@ -287,7 +288,8 @@ module SearchProblem = struct 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 = @@ -299,7 +301,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 @@ -307,12 +310,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) @@ -377,7 +381,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; @@ -385,6 +389,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 = @@ -398,7 +403,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 -> @@ -422,83 +427,16 @@ let full_eauto ?(debug=Off) n lems gl = tclTRY (e_search_auto debug n lems db_list) gl let gen_eauto ?(debug=Off) np lems = function - | None -> full_eauto ~debug np lems - | Some l -> eauto ~debug np lems l + | None -> Proofview.V82.tactic (full_eauto ~debug np lems) + | Some l -> Proofview.V82.tactic (eauto ~debug np lems l) let make_depth = function | None -> !default_search_depth - | Some (ArgArg d) -> d - | _ -> error "eauto called with a non closed argument." + | Some d -> d let make_dimension n = function | None -> (true,make_depth n) - | Some (ArgArg d) -> (false,d) - | _ -> error "eauto called with a non closed argument." - -open Genarg - -(* Hint bases *) - -let pr_hintbases _prc _prlc _prt = Pptactic.pr_hintbases - -ARGUMENT EXTEND hintbases - TYPED AS preident_list_opt - PRINTED BY pr_hintbases -| [ "with" "*" ] -> [ None ] -| [ "with" ne_preident_list(l) ] -> [ Some l ] -| [ ] -> [ Some [] ] -END - -let pr_constr_coma_sequence prc _ _ = - prlist_with_sep pr_comma (fun (_,c) -> prc c) - -ARGUMENT EXTEND constr_coma_sequence - TYPED AS open_constr_list - PRINTED BY pr_constr_coma_sequence -| [ open_constr(c) "," constr_coma_sequence(l) ] -> [ c::l ] -| [ open_constr(c) ] -> [ [c] ] -END - -let pr_auto_using prc _prlc _prt = Pptactic.pr_auto_using (fun (_,c) -> prc c) - -ARGUMENT EXTEND auto_using - TYPED AS open_constr_list - PRINTED BY pr_auto_using -| [ "using" constr_coma_sequence(l) ] -> [ l ] -| [ ] -> [ [] ] -END - -TACTIC EXTEND eauto -| [ "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) - hintbases(db) ] -> - [ Proofview.V82.tactic (gen_eauto (make_dimension n p) lems db) ] -END - -TACTIC EXTEND new_eauto -| [ "new" "auto" int_or_var_opt(n) auto_using(lems) - hintbases(db) ] -> - [ match db with - | None -> new_full_auto (make_depth n) lems - | Some l -> new_auto (make_depth n) lems l ] -END - -TACTIC EXTEND debug_eauto -| [ "debug" "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) - hintbases(db) ] -> - [ Proofview.V82.tactic (gen_eauto ~debug:Debug (make_dimension n p) lems db) ] -END - -TACTIC EXTEND info_eauto -| [ "info_eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) - hintbases(db) ] -> - [ Proofview.V82.tactic (gen_eauto ~debug:Info (make_dimension n p) lems db) ] -END - -TACTIC EXTEND dfs_eauto -| [ "dfs" "eauto" int_or_var_opt(p) auto_using(lems) - hintbases(db) ] -> - [ Proofview.V82.tactic (gen_eauto (true, make_depth p) lems db) ] -END + | Some d -> (false,d) let cons a l = a :: l @@ -512,27 +450,26 @@ let autounfolds db occs cls gl = let ids = Idset.filter (fun id -> List.mem id hyps) ids in Cset.fold (fun cst -> cons (AllOccurrences, EvalConstRef cst)) csts (Id.Set.fold (fun id -> cons (AllOccurrences, EvalVarRef id)) ids [])) db) - in unfold_option unfolds cls gl + in Proofview.V82.of_tactic (unfold_option unfolds cls) gl -let autounfold db cls gl = +let autounfold db cls = + Proofview.V82.tactic begin fun gl -> let cls = concrete_clause_of (fun () -> pf_ids_of_hyps gl) cls in let tac = autounfolds db in tclMAP (function | OnHyp (id,occs,where) -> tac occs (Some (id,where)) | OnConcl occs -> tac occs None) cls gl + end -let autounfold_tac db cls gl = +let autounfold_tac db cls = + Proofview.tclUNIT () >>= fun () -> let dbs = match db with | None -> String.Set.elements (current_db_names ()) | Some [] -> ["core"] | Some l -> l in - autounfold dbs cls gl - -TACTIC EXTEND autounfold -| [ "autounfold" hintbases(db) clause(cl) ] -> [ Proofview.V82.tactic (autounfold_tac db cl) ] -END + autounfold dbs cls let unfold_head env (ids, csts) c = let rec aux c = @@ -587,103 +524,3 @@ let autounfold_one db cl = | None -> convert_concl_no_check c' DEFAULTcast else Tacticals.New.tclFAIL 0 (str "Nothing to unfold") end } - -(* Cset.fold (fun cst -> cons (all_occurrences, EvalConstRef cst)) csts *) -(* (Id.Set.fold (fun id -> cons (all_occurrences, EvalVarRef id)) ids [])) db) *) -(* in unfold_option unfolds cl *) - -(* let db = try searchtable_map dbname *) -(* with Not_found -> errorlabstrm "autounfold" (str "Unknown database " ++ str dbname) *) -(* in *) -(* let (ids, csts) = Hint_db.unfolds db in *) -(* Cset.fold (fun cst -> tclORELSE (unfold_option [(occ, EvalVarRef id)] cst)) csts *) -(* (Id.Set.fold (fun id -> tclORELSE (unfold_option [(occ, EvalVarRef id)] cl) ids acc))) *) -(* (tclFAIL 0 (mt())) db *) - -TACTIC EXTEND autounfold_one -| [ "autounfold_one" hintbases(db) "in" hyp(id) ] -> - [ autounfold_one (match db with None -> ["core"] | Some x -> "core"::x) (Some (id, InHyp)) ] -| [ "autounfold_one" hintbases(db) ] -> - [ autounfold_one (match db with None -> ["core"] | Some x -> "core"::x) None ] - END - -TACTIC EXTEND autounfoldify -| [ "autounfoldify" constr(x) ] -> [ - Proofview.V82.tactic ( - let db = match kind_of_term x with - | Const (c,_) -> Label.to_string (con_label c) - | _ -> assert false - in autounfold ["core";db] onConcl - )] -END - -TACTIC EXTEND unify -| ["unify" constr(x) constr(y) ] -> [ unify x y ] -| ["unify" constr(x) constr(y) "with" preident(base) ] -> [ - let table = try Some (searchtable_map base) with Not_found -> None in - match table with - | None -> - let msg = str "Hint table " ++ str base ++ str " not found" in - Tacticals.New.tclZEROMSG msg - | Some t -> - let state = Hint_db.transparent_state t in - unify ~state x y - ] -END - - -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 - -ARGUMENT EXTEND hints_path_atom - TYPED AS hints_path_atom - PRINTED BY pr_hints_path_atom -| [ global_list(g) ] -> [ PathHints (List.map Nametab.global g) ] -| [ "*" ] -> [ 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 - -ARGUMENT EXTEND hints_path - TYPED AS hints_path - PRINTED BY pr_hints_path -| [ "(" hints_path(p) ")" ] -> [ p ] -| [ "!" hints_path(p) ] -> [ PathStar p ] -| [ "emp" ] -> [ PathEmpty ] -| [ "eps" ] -> [ PathEpsilon ] -| [ hints_path_atom(a) ] -> [ PathAtom a ] -| [ hints_path(p) "|" hints_path(q) ] -> [ PathOr (p, q) ] -| [ hints_path(p) ";" hints_path(q) ] -> [ PathSeq (p, q) ] -END - -let pr_hintbases _prc _prlc _prt = Pptactic.pr_hintbases - -ARGUMENT EXTEND opthints - TYPED AS preident_list_opt - PRINTED BY pr_hintbases -| [ ":" ne_preident_list(l) ] -> [ Some l ] -| [ ] -> [ None ] -END - -VERNAC COMMAND EXTEND HintCut CLASSIFIED AS SIDEFF -| [ "Hint" "Cut" "[" hints_path(p) "]" opthints(dbnames) ] -> [ - let entry = HintsCutEntry p in - Hints.add_hints (Locality.make_section_locality (Locality.LocalityFixme.consume ())) - (match dbnames with None -> ["core"] | Some l -> l) entry ] -END diff --git a/tactics/eauto.mli b/tactics/eauto.mli index b55c70fa1..8812093d5 100644 --- a/tactics/eauto.mli +++ b/tactics/eauto.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,31 +8,26 @@ open Term open Proof_type -open Evd open Hints -val hintbases : hint_db_name list option Pcoq.Gram.entry - -val wit_hintbases : hint_db_name list option Genarg.uniform_genarg_type - -val wit_auto_using : - (Tacexpr.open_constr_expr list, - Tacexpr.open_glob_constr list, Evd.open_constr list) - Genarg.genarg_type - - val e_assumption : unit Proofview.tactic val registered_e_assumption : unit Proofview.tactic val e_give_exact : ?flags:Unification.unify_flags -> constr -> unit Proofview.tactic -val gen_eauto : ?debug:Tacexpr.debug -> bool * int -> open_constr list -> - hint_db_name list option -> tactic +val prolog_tac : Tacexpr.delayed_open_constr list -> int -> unit Proofview.tactic + +val gen_eauto : ?debug:Tacexpr.debug -> bool * int -> Tacexpr.delayed_open_constr list -> + hint_db_name list option -> unit Proofview.tactic val eauto_with_bases : ?debug:Tacexpr.debug -> bool * int -> - open_constr list -> hint_db list -> Proof_type.tactic + Tacexpr.delayed_open_constr list -> hint_db list -> Proof_type.tactic + +val autounfold : hint_db_name list -> Locus.clause -> unit Proofview.tactic +val autounfold_tac : hint_db_name list option -> Locus.clause -> unit Proofview.tactic +val autounfold_one : hint_db_name list -> Locus.hyp_location option -> unit Proofview.tactic -val autounfold : hint_db_name list -> Locus.clause -> tactic +val make_dimension : int option -> int option -> bool * int diff --git a/tactics/elim.ml b/tactics/elim.ml index d3aa16092..d441074f6 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -16,29 +16,21 @@ open Tacmach.New open Tacticals.New open Tactics open Proofview.Notations +open Context.Named.Declaration +(* Supposed to be called without as clause *) let introElimAssumsThen tac ba = - let nassums = - List.fold_left - (fun acc b -> if b then acc+2 else acc+1) - 0 ba.Tacticals.branchsign - in - let introElimAssums = tclDO nassums intro in + assert (ba.Tacticals.branchnames == []); + let introElimAssums = tclDO ba.Tacticals.nassums intro in (tclTHEN introElimAssums (elim_on_ba tac ba)) +(* Supposed to be called with a non-recursive scheme *) let introCaseAssumsThen tac ba = - let case_thin_sign = - List.flatten - (List.map (function b -> if b then [false;true] else [false]) - ba.Tacticals.branchsign) - in - let n1 = List.length case_thin_sign in + let n1 = List.length ba.Tacticals.branchsign in let n2 = List.length ba.Tacticals.branchnames in let (l1,l2),l3 = if n1 < n2 then List.chop n1 ba.Tacticals.branchnames, [] - else - (ba.Tacticals.branchnames, []), - if n1 > n2 then snd (List.chop n2 case_thin_sign) else [] in + else (ba.Tacticals.branchnames, []), List.make (n1-n2) false in let introCaseAssums = tclTHEN (intro_patterns l1) (intros_clearing l3) in (tclTHEN introCaseAssums (case_on_ba (tac l2) ba)) @@ -146,7 +138,8 @@ let induction_trailer abs_i abs_j bargs = in let (hyps,_) = List.fold_left - (fun (bring_ids,leave_ids) (cid,_,_ as d) -> + (fun (bring_ids,leave_ids) d -> + let cid = get_id d in if not (List.mem cid leave_ids) then (d::bring_ids,leave_ids) else (bring_ids,cid::leave_ids)) @@ -154,15 +147,14 @@ let induction_trailer abs_i abs_j bargs = in let ids = List.rev (ids_of_named_context hyps) in (tclTHENLIST - [bring_hyps hyps; tclTRY (Proofview.V82.tactic (clear ids)); - simple_elimination (mkVar id)]) + [revert ids; simple_elimination (mkVar id)]) end } )) let double_ind h1 h2 = Proofview.Goal.nf_enter { enter = begin fun gl -> - let abs_i = of_old (depth_of_quantified_hypothesis true h1) gl in - let abs_j = of_old (depth_of_quantified_hypothesis true h2) gl in + let abs_i = depth_of_quantified_hypothesis true h1 gl in + let abs_j = depth_of_quantified_hypothesis true h2 gl in let abs = if abs_i < abs_j then Proofview.tclUNIT (abs_i,abs_j) else if abs_i > abs_j then Proofview.tclUNIT (abs_j,abs_i) else diff --git a/tactics/elim.mli b/tactics/elim.mli index 8e98646e7..a94f642a0 100644 --- a/tactics/elim.mli +++ b/tactics/elim.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/tactics/elimschemes.ml b/tactics/elimschemes.ml index e6a8cbe3a..de2818902 100644 --- a/tactics/elimschemes.ml +++ b/tactics/elimschemes.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -18,6 +18,7 @@ open Indrec open Declarations open Typeops open Ind_tables +open Sigma.Notations (* Induction/recursion schemes *) @@ -52,7 +53,7 @@ let optimize_non_type_induction_scheme kind dep sort _ ind = 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_ctx ectx) (ind,u) dep sort in - (c, Evd.evar_universe_context sigma), Declareops.no_seff + (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 @@ -68,15 +69,15 @@ let build_induction_scheme_in_type dep sort ind = 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" @@ -102,31 +103,31 @@ let rec_dep_scheme_kind_from_type = let build_case_analysis_scheme_in_type dep sort ind = let env = Global.env () in - let sigma = Evd.from_env env in - let sigma, indu = Evd.fresh_inductive_instance env sigma ind in - let sigma, c = build_case_analysis_scheme env sigma indu dep sort in - c, Evd.evar_universe_context sigma + let sigma = Sigma.Unsafe.of_evar_map (Evd.from_env env) in + let Sigma (indu, sigma, _) = Sigma.fresh_inductive_instance env sigma ind in + let Sigma (c, sigma, _) = build_case_analysis_scheme env sigma indu dep sort in + c, Evd.evar_universe_context (Sigma.to_evar_map sigma) 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/elimschemes.mli b/tactics/elimschemes.mli index 0b843b8f1..c36797059 100644 --- a/tactics/elimschemes.mli +++ b/tactics/elimschemes.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml index 74e5e036a..011296a8d 100644 --- a/tactics/eqdecide.ml +++ b/tactics/eqdecide.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -12,8 +12,6 @@ (* by Eduardo Gimenez *) (************************************************************************) -(*i camlp4deps: "grammar/grammar.cma" i*) - open Errors open Util open Names @@ -24,7 +22,9 @@ open Tactics open Tacticals.New open Auto open Constr_matching +open Misctypes open Hipattern +open Pretyping open Tacmach.New open Coqlib open Proofview.Notations @@ -74,10 +74,15 @@ let mkBranches c1 c2 = clear_last; intros] +let discrHyp id = + let c = { delayed = fun env sigma -> Sigma.here (Term.mkVar id, NoBindings) sigma } in + let tac c = Equality.discr_tac false (Some (None, Tacexpr.ElimOnConstr c)) in + Tacticals.New.tclDELAYEDWITHHOLES false c tac + let solveNoteqBranch side = tclTHEN (choose_noteq side) (tclTHEN introf - (onLastHypId (fun id -> Extratactics.discrHyp id))) + (onLastHypId (fun id -> discrHyp id))) (* Constructs the type {c1=c2}+{~c1=c2} *) @@ -117,16 +122,21 @@ let rec rewrite_and_clear hyps = match hyps with let eqCase tac = tclTHEN intro (onLastHypId tac) +let injHyp id = + let c = { delayed = fun env sigma -> Sigma.here (Term.mkVar id, NoBindings) sigma } in + let tac c = Equality.injClause None false (Some (None, Tacexpr.ElimOnConstr c)) in + Tacticals.New.tclDELAYEDWITHHOLES false c tac + 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 (red_in_concl) (tclTHEN (intro_using absurd) (tclTHEN (Simple.apply (mkVar diseq)) - (tclTHEN (Extratactics.injHyp absurd) + (tclTHEN (injHyp absurd) (full_trivial [])))))))) open Proofview.Notations diff --git a/tactics/eqdecide.mli b/tactics/eqdecide.mli index 864160f62..cb48a5bcc 100644 --- a/tactics/eqdecide.mli +++ b/tactics/eqdecide.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index f7d3ad5d0..a03489c80 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -49,7 +49,6 @@ open Util open Names open Term open Vars -open Context open Declarations open Environ open Inductive @@ -58,6 +57,8 @@ open Namegen open Inductiveops open Ind_tables open Indrec +open Sigma.Notations +open Context.Rel.Declaration let hid = Id.of_string "H" let xid = Id.of_string "X" @@ -70,8 +71,8 @@ let build_dependent_inductive ind (mib,mip) = let realargs,_ = List.chop mip.mind_nrealdecls mip.mind_arity_ctxt in applist (mkIndU ind, - extended_rel_list mip.mind_nrealdecls mib.mind_params_ctxt - @ extended_rel_list 0 realargs) + Context.Rel.to_extended_list mip.mind_nrealdecls mib.mind_params_ctxt + @ Context.Rel.to_extended_list 0 realargs) let my_it_mkLambda_or_LetIn s c = it_mkLambda_or_LetIn c s let my_it_mkProd_or_LetIn s c = it_mkProd_or_LetIn c s @@ -104,11 +105,11 @@ let get_sym_eq_data env (ind,u) = error "Not an inductive type with a single constructor."; let arityctxt = Vars.subst_instance_context u mip.mind_arity_ctxt in let realsign,_ = List.chop mip.mind_nrealdecls arityctxt in - if List.exists (fun (_,b,_) -> not (Option.is_empty b)) realsign then + if List.exists is_local_def realsign then error "Inductive equalities with local definitions in arity not supported."; let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in let _,constrargs = decompose_app ccl in - if not (Int.equal (rel_context_length constrsign) (rel_context_length mib.mind_params_ctxt)) then + if not (Int.equal (Context.Rel.length constrsign) (Context.Rel.length mib.mind_params_ctxt)) then error "Constructor must have no arguments"; (* This can be relaxed... *) let params,constrargs = List.chop mib.mind_nparams constrargs in if mip.mind_nrealargs > mib.mind_nparams then @@ -139,11 +140,11 @@ let get_non_sym_eq_data env (ind,u) = error "Not an inductive type with a single constructor."; let arityctxt = Vars.subst_instance_context u mip.mind_arity_ctxt in let realsign,_ = List.chop mip.mind_nrealdecls arityctxt in - if List.exists (fun (_,b,_) -> not (Option.is_empty b)) realsign then + if List.exists is_local_def realsign then error "Inductive equalities with local definitions in arity not supported"; let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in let _,constrargs = decompose_app ccl in - if not (Int.equal (rel_context_length constrsign) (rel_context_length mib.mind_params_ctxt)) then + if not (Int.equal (Context.Rel.length constrsign) (Context.Rel.length mib.mind_params_ctxt)) then error "Constructor must have no arguments"; let _,constrargs = List.chop mib.mind_nparams constrargs in let constrargs = List.map (Vars.subst_instance_constr u) constrargs in @@ -169,20 +170,20 @@ let build_sym_scheme env ind = let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 = get_sym_eq_data env indu in let cstr n = - mkApp (mkConstructUi(indu,1),extended_rel_vect n mib.mind_params_ctxt) in + mkApp (mkConstructUi(indu,1),Context.Rel.to_extended_vect n mib.mind_params_ctxt) in let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in let applied_ind = build_dependent_inductive indu specif in let realsign_ind = - name_context env ((Name varH,None,applied_ind)::realsign) in + name_context env ((LocalAssum (Name varH,applied_ind))::realsign) in let ci = make_case_info (Global.env()) ind RegularStyle in let c = - (my_it_mkLambda_or_LetIn mib.mind_params_ctxt + (my_it_mkLambda_or_LetIn paramsctxt (my_it_mkLambda_or_LetIn_name realsign_ind (mkCase (ci, my_it_mkLambda_or_LetIn_name (lift_rel_context (nrealargs+1) realsign_ind) (mkApp (mkIndU indu,Array.concat - [extended_rel_vect (3*nrealargs+2) paramsctxt1; + [Context.Rel.to_extended_vect (3*nrealargs+2) paramsctxt1; rel_vect 1 nrealargs; rel_vect (2*nrealargs+2) nrealargs])), mkRel 1 (* varH *), @@ -193,7 +194,7 @@ let sym_scheme_kind = declare_individual_scheme_object "_sym_internal" (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 *) @@ -223,16 +224,16 @@ let build_sym_involutive_scheme env ind = get_sym_eq_data env indu in let eq,eqrefl,ctx = get_coq_eq ctx in let sym, ctx, eff = const_of_scheme sym_scheme_kind env ind ctx in - let cstr n = mkApp (mkConstructUi (indu,1),extended_rel_vect n paramsctxt) in + let cstr n = mkApp (mkConstructUi (indu,1),Context.Rel.to_extended_vect n paramsctxt) in let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in let applied_ind = build_dependent_inductive indu specif in let applied_ind_C = mkApp (mkIndU indu, Array.append - (extended_rel_vect (nrealargs+1) mib.mind_params_ctxt) + (Context.Rel.to_extended_vect (nrealargs+1) mib.mind_params_ctxt) (rel_vect (nrealargs+1) nrealargs)) in let realsign_ind = - name_context env ((Name varH,None,applied_ind)::realsign) in + name_context env ((LocalAssum (Name varH,applied_ind))::realsign) in let ci = make_case_info (Global.env()) ind RegularStyle in let c = (my_it_mkLambda_or_LetIn paramsctxt @@ -243,15 +244,15 @@ let build_sym_involutive_scheme env ind = (mkApp (eq,[| mkApp (mkIndU indu, Array.concat - [extended_rel_vect (3*nrealargs+2) paramsctxt1; + [Context.Rel.to_extended_vect (3*nrealargs+2) paramsctxt1; rel_vect (2*nrealargs+2) nrealargs; rel_vect 1 nrealargs]); mkApp (sym,Array.concat - [extended_rel_vect (3*nrealargs+2) paramsctxt1; + [Context.Rel.to_extended_vect (3*nrealargs+2) paramsctxt1; rel_vect 1 nrealargs; rel_vect (2*nrealargs+2) nrealargs; [|mkApp (sym,Array.concat - [extended_rel_vect (3*nrealargs+2) paramsctxt1; + [Context.Rel.to_extended_vect (3*nrealargs+2) paramsctxt1; rel_vect (2*nrealargs+2) nrealargs; rel_vect 1 nrealargs; [|mkRel 1|]])|]]); @@ -334,7 +335,7 @@ let build_l2r_rew_scheme dep env ind kind = let eq,eqrefl,ctx = get_coq_eq ctx in let cstr n p = mkApp (mkConstructUi(indu,1), - Array.concat [extended_rel_vect n paramsctxt1; + Array.concat [Context.Rel.to_extended_vect n paramsctxt1; rel_vect p nrealargs]) in let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in let varHC = fresh env (Id.of_string "HC") in @@ -342,26 +343,26 @@ let build_l2r_rew_scheme dep env ind kind = let applied_ind = build_dependent_inductive indu specif in let applied_ind_P = mkApp (mkIndU indu, Array.concat - [extended_rel_vect (3*nrealargs) paramsctxt1; + [Context.Rel.to_extended_vect (3*nrealargs) paramsctxt1; rel_vect 0 nrealargs; rel_vect nrealargs nrealargs]) in let applied_ind_G = mkApp (mkIndU indu, Array.concat - [extended_rel_vect (3*nrealargs+3) paramsctxt1; + [Context.Rel.to_extended_vect (3*nrealargs+3) paramsctxt1; rel_vect (nrealargs+3) nrealargs; rel_vect 0 nrealargs]) in let realsign_P = lift_rel_context nrealargs realsign in let realsign_ind_P = - name_context env ((Name varH,None,applied_ind_P)::realsign_P) in + name_context env ((LocalAssum (Name varH,applied_ind_P))::realsign_P) in let realsign_ind_G = - name_context env ((Name varH,None,applied_ind_G):: + name_context env ((LocalAssum (Name varH,applied_ind_G)):: lift_rel_context (nrealargs+3) realsign) in let applied_sym_C n = mkApp(sym, - Array.append (extended_rel_vect n mip.mind_arity_ctxt) [|mkVar varH|]) in + Array.append (Context.Rel.to_extended_vect n mip.mind_arity_ctxt) [|mkVar varH|]) in let applied_sym_G = mkApp(sym, - Array.concat [extended_rel_vect (nrealargs*3+4) paramsctxt1; + Array.concat [Context.Rel.to_extended_vect (nrealargs*3+4) paramsctxt1; rel_vect (nrealargs+4) nrealargs; rel_vect 1 nrealargs; [|mkRel 1|]]) in @@ -371,7 +372,7 @@ let build_l2r_rew_scheme dep env ind kind = let ci = make_case_info (Global.env()) ind RegularStyle in let cieq = make_case_info (Global.env()) (fst (destInd eq)) RegularStyle in let applied_PC = - mkApp (mkVar varP,Array.append (extended_rel_vect 1 realsign) + mkApp (mkVar varP,Array.append (Context.Rel.to_extended_vect 1 realsign) (if dep then [|cstr (2*nrealargs+1) 1|] else [||])) in let applied_PG = mkApp (mkVar varP,Array.append (rel_vect 1 nrealargs) @@ -381,11 +382,11 @@ let build_l2r_rew_scheme dep env ind kind = (if dep then [|mkRel 2|] else [||])) in let applied_sym_sym = mkApp (sym,Array.concat - [extended_rel_vect (2*nrealargs+4) paramsctxt1; + [Context.Rel.to_extended_vect (2*nrealargs+4) paramsctxt1; rel_vect 4 nrealargs; rel_vect (nrealargs+4) nrealargs; [|mkApp (sym,Array.concat - [extended_rel_vect (2*nrealargs+4) paramsctxt1; + [Context.Rel.to_extended_vect (2*nrealargs+4) paramsctxt1; rel_vect (nrealargs+4) nrealargs; rel_vect 4 nrealargs; [|mkRel 2|]])|]]) in @@ -395,7 +396,7 @@ let build_l2r_rew_scheme dep env ind kind = applied_sym_C 3, [|mkVar varHC|]) in let c = - (my_it_mkLambda_or_LetIn mib.mind_params_ctxt + (my_it_mkLambda_or_LetIn paramsctxt (my_it_mkLambda_or_LetIn_name realsign (mkNamedLambda varP (my_it_mkProd_or_LetIn (if dep then realsign_ind_P else realsign_P) s) @@ -408,11 +409,12 @@ let build_l2r_rew_scheme dep env ind kind = mkApp (eq,[|lift 4 applied_ind;applied_sym_sym;mkRel 1|]), applied_PR)), mkApp (sym_involutive, - Array.append (extended_rel_vect 3 mip.mind_arity_ctxt) [|mkVar varH|]), + Array.append (Context.Rel.to_extended_vect 3 mip.mind_arity_ctxt) [|mkVar varH|]), [|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 *) @@ -446,7 +448,7 @@ let build_l2r_forward_rew_scheme dep env ind kind = get_sym_eq_data env indu in let cstr n p = mkApp (mkConstructUi(indu,1), - Array.concat [extended_rel_vect n paramsctxt1; + Array.concat [Context.Rel.to_extended_vect n paramsctxt1; rel_vect p nrealargs]) in let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in let varHC = fresh env (Id.of_string "HC") in @@ -454,19 +456,19 @@ let build_l2r_forward_rew_scheme dep env ind kind = let applied_ind = build_dependent_inductive indu specif in let applied_ind_P = mkApp (mkIndU indu, Array.concat - [extended_rel_vect (4*nrealargs+2) paramsctxt1; + [Context.Rel.to_extended_vect (4*nrealargs+2) paramsctxt1; rel_vect 0 nrealargs; rel_vect (nrealargs+1) nrealargs]) in let applied_ind_P' = mkApp (mkIndU indu, Array.concat - [extended_rel_vect (3*nrealargs+1) paramsctxt1; + [Context.Rel.to_extended_vect (3*nrealargs+1) paramsctxt1; rel_vect 0 nrealargs; rel_vect (2*nrealargs+1) nrealargs]) in let realsign_P n = lift_rel_context (nrealargs*n+n) realsign in let realsign_ind = - name_context env ((Name varH,None,applied_ind)::realsign) in + name_context env ((LocalAssum (Name varH,applied_ind))::realsign) in let realsign_ind_P n aP = - name_context env ((Name varH,None,aP)::realsign_P n) in + name_context env ((LocalAssum (Name varH,aP))::realsign_P n) in let s, ctx' = Universes.fresh_sort_in_family (Global.env ()) kind in let ctx = Univ.ContextSet.union ctx ctx' in let s = mkSort s in @@ -484,7 +486,7 @@ let build_l2r_forward_rew_scheme dep env ind kind = mkApp (mkVar varP,Array.append (rel_vect 3 nrealargs) (if dep then [|cstr (3*nrealargs+4) 3|] else [||])) in let c = - (my_it_mkLambda_or_LetIn mib.mind_params_ctxt + (my_it_mkLambda_or_LetIn paramsctxt (my_it_mkLambda_or_LetIn_name realsign (mkNamedLambda varH applied_ind (mkCase (ci, @@ -537,14 +539,14 @@ let build_r2l_forward_rew_scheme dep env ind kind = let ((mib,mip as specif),constrargs,realsign,paramsctxt,nrealargs) = get_non_sym_eq_data env indu in let cstr n = - mkApp (mkConstructUi(indu,1),extended_rel_vect n mib.mind_params_ctxt) in + mkApp (mkConstructUi(indu,1),Context.Rel.to_extended_vect n mib.mind_params_ctxt) in let constrargs_cstr = constrargs@[cstr 0] in let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in let varHC = fresh env (Id.of_string "HC") in let varP = fresh env (Id.of_string "P") in let applied_ind = build_dependent_inductive indu specif in let realsign_ind = - name_context env ((Name varH,None,applied_ind)::realsign) in + name_context env ((LocalAssum (Name varH,applied_ind))::realsign) in let s, ctx' = Universes.fresh_sort_in_family (Global.env ()) kind in let ctx = Univ.ContextSet.union ctx ctx' in let s = mkSort s in @@ -553,8 +555,8 @@ let build_r2l_forward_rew_scheme dep env ind kind = applist (mkVar varP,if dep then constrargs_cstr else constrargs) in let applied_PG = mkApp (mkVar varP, - if dep then extended_rel_vect 0 realsign_ind - else extended_rel_vect 1 realsign) in + if dep then Context.Rel.to_extended_vect 0 realsign_ind + else Context.Rel.to_extended_vect 1 realsign) in let c = (my_it_mkLambda_or_LetIn paramsctxt (my_it_mkLambda_or_LetIn_name realsign_ind @@ -598,12 +600,12 @@ let fix_r2l_forward_rew_scheme (c, ctx') = | hp :: p :: ind :: indargs -> let c' = my_it_mkLambda_or_LetIn indargs - (mkLambda_or_LetIn (map_rel_declaration (liftn (-1) 1) p) - (mkLambda_or_LetIn (map_rel_declaration (liftn (-1) 2) hp) - (mkLambda_or_LetIn (map_rel_declaration (lift 2) ind) + (mkLambda_or_LetIn (map_constr (liftn (-1) 1) p) + (mkLambda_or_LetIn (map_constr (liftn (-1) 2) hp) + (mkLambda_or_LetIn (map_constr (lift 2) ind) (Reductionops.whd_beta Evd.empty (applist (c, - extended_rel_list 3 indargs @ [mkRel 1;mkRel 3;mkRel 2])))))) + Context.Rel.to_extended_list 3 indargs @ [mkRel 1;mkRel 3;mkRel 2])))))) in c', ctx' | _ -> anomaly (Pp.str "Ill-formed non-dependent left-to-right rewriting scheme") @@ -629,9 +631,10 @@ let fix_r2l_forward_rew_scheme (c, ctx') = (**********************************************************************) let build_r2l_rew_scheme dep env ind k = - let sigma, indu = Evd.fresh_inductive_instance env (Evd.from_env env) ind in - let sigma', c = build_case_analysis_scheme env sigma indu dep k in - c, Evd.evar_universe_context sigma' + let sigma = Sigma.Unsafe.of_evar_map (Evd.from_env env) in + let Sigma (indu, sigma, _) = Sigma.fresh_inductive_instance env sigma ind in + let Sigma (c, sigma, _) = build_case_analysis_scheme env sigma indu dep k in + c, Evd.evar_universe_context (Sigma.to_evar_map sigma) let build_l2r_rew_scheme = build_l2r_rew_scheme let build_l2r_forward_rew_scheme = build_l2r_forward_rew_scheme @@ -660,7 +663,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 +673,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 +683,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 *) @@ -694,7 +697,7 @@ 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) + (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 +707,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 *) @@ -735,13 +738,13 @@ let build_congr env (eq,refl,ctx) ind = let arityctxt = Vars.subst_instance_context u mip.mind_arity_ctxt in let paramsctxt = Vars.subst_instance_context u mib.mind_params_ctxt in let realsign,_ = List.chop mip.mind_nrealdecls arityctxt in - if List.exists (fun (_,b,_) -> not (Option.is_empty b)) realsign then + if List.exists is_local_def realsign then error "Inductive equalities with local definitions in arity not supported."; let env_with_arity = push_rel_context arityctxt env in - let (_,_,ty) = lookup_rel (mip.mind_nrealargs - i + 1) env_with_arity in + let ty = get_type (lookup_rel (mip.mind_nrealargs - i + 1) env_with_arity) in let constrsign,ccl = decompose_prod_assum mip.mind_nf_lc.(0) in let _,constrargs = decompose_app ccl in - if Int.equal (rel_context_length constrsign) (rel_context_length mib.mind_params_ctxt) then + if Int.equal (Context.Rel.length constrsign) (Context.Rel.length mib.mind_params_ctxt) then error "Constructor must have no arguments"; let b = List.nth constrargs (i + mib.mind_nparams - 1) in let varB = fresh env (Id.of_string "B") in @@ -757,8 +760,8 @@ let build_congr env (eq,refl,ctx) ind = (mkNamedLambda varH (applist (mkIndU indu, - extended_rel_list (mip.mind_nrealargs+2) paramsctxt @ - extended_rel_list 0 realsign)) + Context.Rel.to_extended_list (mip.mind_nrealargs+2) paramsctxt @ + Context.Rel.to_extended_list 0 realsign)) (mkCase (ci, my_it_mkLambda_or_LetIn_name (lift_rel_context (mip.mind_nrealargs+3) realsign) @@ -766,9 +769,9 @@ let build_congr env (eq,refl,ctx) ind = (Anonymous, applist (mkIndU indu, - extended_rel_list (2*mip.mind_nrealdecls+3) + Context.Rel.to_extended_list (2*mip.mind_nrealdecls+3) paramsctxt - @ extended_rel_list 0 realsign), + @ Context.Rel.to_extended_list 0 realsign), mkApp (eq, [|mkVar varB; mkApp (mkVar varf, [|lift (2*mip.mind_nrealdecls+4) b|]); @@ -781,5 +784,6 @@ let build_congr env (eq,refl,ctx) ind = let congr_scheme_kind = declare_individual_scheme_object "_congr" (fun _ ind -> - (* May fail if equality is not defined *) - build_congr (Global.env()) (get_coq_eq Univ.ContextSet.empty) ind, Declareops.no_seff) + (* May fail if equality is not defined *) + 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 6bb84808a..aa8a6d4bd 100644 --- a/tactics/eqschemes.mli +++ b/tactics/eqschemes.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -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 85bc50216..bc03baf26 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -43,6 +43,7 @@ open Misctypes open Sigma.Notations open Proofview.Notations open Unification +open Context.Named.Declaration (* Options *) @@ -206,9 +207,47 @@ let rewrite_conv_closed_unif_flags = { resolve_evars = false } +let rewrite_keyed_core_unif_flags = { + modulo_conv_on_closed_terms = Some full_transparent_state; + (* We have this flag for historical reasons, it has e.g. the consequence *) + (* to rewrite "?x+2" in "y+(1+1)=0" or to rewrite "?x+?x" in "2+(1+1)=0" *) + + use_metas_eagerly_in_conv_on_closed_terms = true; + use_evars_eagerly_in_conv_on_closed_terms = false; + (* Combined with modulo_conv_on_closed_terms, this flag allows since 8.2 *) + (* to rewrite e.g. "?x+(2+?x)" in "1+(1+2)=0" *) + + modulo_delta = full_transparent_state; + modulo_delta_types = full_transparent_state; + check_applied_meta_types = true; + use_pattern_unification = true; + (* To rewrite "?n x y" in "y+x=0" when ?n is *) + (* a preexisting evar of the goal*) + + use_meta_bound_pattern_unification = true; + + frozen_evars = Evar.Set.empty; + (* This is set dynamically *) + + restrict_conv_on_strict_subterms = false; + modulo_betaiota = true; + + modulo_eta = true; +} + +let rewrite_keyed_unif_flags = { + core_unify_flags = rewrite_keyed_core_unif_flags; + merge_unify_flags = rewrite_keyed_core_unif_flags; + subterm_unify_flags = rewrite_keyed_core_unif_flags; + allow_K_in_toplevel_higher_order_unification = false; + resolve_evars = false +} + let rewrite_elim with_evars frzevars cls c e = Proofview.Goal.enter { enter = begin fun gl -> - let flags = make_flags frzevars (Tacmach.New.project gl) rewrite_conv_closed_unif_flags c in + let flags = if Unification.is_keyed_unification () + then rewrite_keyed_unif_flags else rewrite_conv_closed_unif_flags in + let flags = make_flags frzevars (Tacmach.New.project gl) flags c in general_elim_clause with_evars flags cls c e end } @@ -317,8 +356,8 @@ let find_elim hdcncl lft2rgt dep cls ot gl = Logic.eq or Jmeq just before *) assert false in - let sigma, elim = Evd.fresh_global (Global.env ()) (Tacmach.New.project gl) (ConstRef c) in - sigma, elim, Declareops.no_seff + let Sigma (elim, sigma, p) = Sigma.fresh_global (Global.env ()) (Proofview.Goal.sigma gl) (ConstRef c) in + Sigma ((elim, Safe_typing.empty_private_constants), sigma, p) else let scheme_name = match dep, lft2rgt, inccl with (* Non dependent case *) @@ -336,10 +375,10 @@ 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 ()) (Tacmach.New.project gl) (ConstRef c) + let Sigma (elim, sigma, p) = + Sigma.fresh_global (Global.env ()) (Proofview.Goal.sigma gl) (ConstRef c) in - sigma, elim, eff + Sigma ((elim, eff), sigma, p) | _ -> assert false let type_of_clause cls gl = match cls with @@ -347,19 +386,19 @@ let type_of_clause cls gl = match cls with | Some id -> pf_get_hyp_typ id gl let leibniz_rewrite_ebindings_clause cls lft2rgt tac c t l with_evars frzevars dep_proof_ok hdcncl = - Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let isatomic = isProd (whd_zeta hdcncl) in let dep_fun = if isatomic then dependent else dependent_no_evar in let type_of_cls = type_of_clause cls gl in let dep = dep_proof_ok && dep_fun c type_of_cls in - let (sigma,elim,effs) = find_elim hdcncl lft2rgt dep cls (Some t) gl in + let Sigma ((elim, effs), sigma, p) = find_elim hdcncl lft2rgt dep cls (Some t) gl in let tac = Proofview.tclEFFECTS effs <*> general_elim_clause with_evars frzevars tac cls c t l (match lft2rgt with None -> false | Some b -> b) {elimindex = None; elimbody = (elim,NoBindings); elimrename = None} in - Sigma.Unsafe.of_pair (tac, sigma) + Sigma (tac, sigma, p) end } let adjust_rewriting_direction args lft2rgt = @@ -822,13 +861,13 @@ let descend_then env sigma head dirn = *) -(* [construct_discriminator env dirn headval] - constructs a case-split on [headval], with the [dirn]-th branch - giving [True], and all the rest giving False. *) +(* [construct_discriminator env sigma dirn c ind special default]] + constructs a case-split on [c] of type [ind], with the [dirn]-th + branch giving [special], and all the rest giving [default]. *) -let construct_discriminator env sigma dirn c sort = +let build_selector env sigma dirn c ind special default = let IndType(indf,_) = - try find_rectype env sigma (get_type_of env sigma c) + try find_rectype env sigma ind with Not_found -> (* one can find Rel(k) in case of dependent constructors like T := c : (A:Set)A->T and a discrimination @@ -840,25 +879,29 @@ let construct_discriminator env sigma dirn c sort = dependent types.") in let (indp,_) = dest_ind_family indf in let ind, _ = check_privacy env indp in + let typ = Retyping.get_type_of env sigma default in let (mib,mip) = lookup_mind_specif env ind in - let (true_0,false_0,sort_0) = build_coq_True(),build_coq_False(),Prop Null in let deparsign = make_arity_signature env true indf in - let p = it_mkLambda_or_LetIn (mkSort sort_0) deparsign in + let p = it_mkLambda_or_LetIn typ deparsign in let cstrs = get_constructors env indf in let build_branch i = - let endpt = if Int.equal i dirn then true_0 else false_0 in + let endpt = if Int.equal i dirn then special else default in it_mkLambda_or_LetIn endpt cstrs.(i-1).cs_args in let brl = List.map build_branch(List.interval 1 (Array.length mip.mind_consnames)) in let ci = make_case_info env ind RegularStyle in mkCase (ci, p, c, Array.of_list brl) -let rec build_discriminator env sigma dirn c sort = function - | [] -> construct_discriminator env sigma dirn c sort +let rec build_discriminator env sigma dirn c = function + | [] -> + let ind = get_type_of env sigma c in + let true_0,false_0 = + build_coq_True(),build_coq_False() in + build_selector env sigma dirn c ind true_0 false_0 | ((sp,cnum),argnum)::l -> let (cnum_nlams,cnum_env,kont) = descend_then env sigma c cnum in let newc = mkRel(cnum_nlams-argnum) in - let subval = build_discriminator cnum_env sigma dirn newc sort l in + let subval = build_discriminator cnum_env sigma dirn newc l in kont subval (build_coq_False (),mkSort (Prop Null)) (* Note: discrimination could be more clever: if some elimination is @@ -918,13 +961,13 @@ let apply_on_clause (f,t) clause = (match kind_of_term (last_arg f_clause.templval.Evd.rebus) with | Meta mv -> mv | _ -> errorlabstrm "" (str "Ill-formed clause applicator.")) in - clenv_fchain argmv f_clause clause + clenv_fchain ~with_univs:false argmv f_clause clause -let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn sort = +let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn = let e = next_ident_away eq_baseid (ids_of_context env) in - let e_env = push_named (e,None,t) env in + let e_env = push_named (Context.Named.Declaration.LocalAssum (e,t)) env in let discriminator = - build_discriminator e_env sigma dirn (mkVar e) sort cpath in + build_discriminator e_env sigma dirn (mkVar e) cpath in let sigma,(pf, absurd_term), eff = discrimination_pf env sigma e (t,t1,t2) discriminator lbeq in let pf_ty = mkArrow eqn absurd_term in @@ -939,13 +982,11 @@ let discrEq (lbeq,_,(t,t1,t2) as u) eq_clause = let sigma = eq_clause.evd in Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let concl = Proofview.Goal.concl gl in match find_positions env sigma t1 t2 with | Inr _ -> 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 + discr_positions env sigma u eq_clause cpath dirn end } let onEquality with_evars tac (c,lbindc) = @@ -1026,7 +1067,7 @@ 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 = type_of ~refresh:true env sigma (mkRel lind) in - let (na,_,_) = lookup_rel lind env in + let na = Context.Rel.Declaration.get_name (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 (* Now [lind] is [mkRel 1] and we abstract on (na:a) *) @@ -1297,7 +1338,7 @@ let simplify_args env sigma t = let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac = let e = next_ident_away eq_baseid (ids_of_context env) in - let e_env = push_named (e, None,t) env in + let e_env = push_named (LocalAssum (e,t)) env in let evdref = ref sigma in let filter (cpath, t1', t2') = try @@ -1319,13 +1360,13 @@ let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac = tclZEROMSG (str "Failed to decompose the equality.") else Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) - (Proofview.tclBIND - (Proofview.Monad.List.map + (Tacticals.New.tclTHENFIRST + (Proofview.tclIGNORE (Proofview.Monad.List.map (fun (pf,ty) -> tclTHENS (cut ty) [inject_if_homogenous_dependent_pair ty; Proofview.V82.tactic (refine pf)]) - (if l2r then List.rev injectors else injectors)) - (fun _ -> tac (List.length injectors))) + (if l2r then List.rev injectors else injectors))) + (tac (List.length injectors))) let injEqThen tac l2r (eq,_,(t,t1,t2) as u) eq_clause = let sigma = eq_clause.evd in @@ -1356,7 +1397,7 @@ let postInjEqTac clear_flag ipats c n = then intro_patterns_bound_to n MoveLast ipats else intro_patterns_to MoveLast ipats in tclTHEN clear_tac intro_tac - | None -> tclIDTAC + | None -> apply_clear_request clear_flag false c let injEq clear_flag ipats = let l2r = @@ -1375,12 +1416,11 @@ let injHyp clear_flag id = injClause None false (Some (clear_flag,ElimOnIdent (L let decompEqThen ntac (lbeq,_,(t,t1,t2) as u) clause = Proofview.Goal.nf_enter { enter = begin fun gl -> - let sort = pf_apply get_type_of gl (Proofview.Goal.concl gl) in let sigma = clause.evd in let env = Proofview.Goal.env gl in match find_positions env sigma t1 t2 with | Inl (cpath, (_,dirn), _) -> - discr_positions env sigma u clause cpath dirn sort + discr_positions env sigma u clause cpath dirn | Inr [] -> (* Change: do not fail, simplify clear this trivial hyp *) ntac (clenv_value clause) 0 | Inr posns -> @@ -1451,6 +1491,7 @@ let decomp_tuple_term env c t = in decomprec (mkRel 1) c t let subst_tuple_term env sigma dep_pair1 dep_pair2 b = + let sigma = Sigma.to_evar_map sigma in let typ = get_type_of env sigma dep_pair1 in (* We find all possible decompositions *) let decomps1 = decomp_tuple_term env dep_pair1 typ in @@ -1475,7 +1516,7 @@ let subst_tuple_term env sigma dep_pair1 dep_pair2 b = (* Retype to get universes right *) 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 + Sigma.Unsafe.of_pair ((body, expected_goal), sigma) (* Like "replace" but decompose dependent equalities *) (* i.e. if equality is "exists t v = exists u w", and goal is "phi(t,u)", *) @@ -1483,11 +1524,13 @@ let subst_tuple_term env sigma dep_pair1 dep_pair2 b = (* on for further iterated sigma-tuples *) let cutSubstInConcl l2r eqn = - Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in let (lbeq,u,(t,e1,e2)) = find_eq_data_decompose gl eqn in let typ = pf_concl gl in let (e1,e2) = if l2r then (e1,e2) else (e2,e1) in - let sigma,typ,expected = pf_apply subst_tuple_term gl e1 e2 typ in + let Sigma ((typ, expected), sigma, p) = subst_tuple_term env sigma e1 e2 typ in let tac = tclTHENFIRST (tclTHENLIST [ @@ -1496,22 +1539,26 @@ let cutSubstInConcl l2r eqn = ]) (change_concl expected) (* Put in normalized form *) in - Sigma.Unsafe.of_pair (tac, sigma) + Sigma (tac, sigma, p) end } let cutSubstInHyp l2r eqn id = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in let (lbeq,u,(t,e1,e2)) = find_eq_data_decompose gl eqn in let typ = pf_get_hyp_typ id gl in let (e1,e2) = if l2r then (e1,e2) else (e2,e1) in - let sigma,typ,expected = pf_apply subst_tuple_term gl e1 e2 typ in - tclTHENFIRST + let Sigma ((typ, expected), sigma, p) = subst_tuple_term env sigma e1 e2 typ in + let tac = + tclTHENFIRST (tclTHENLIST [ - (Proofview.Unsafe.tclEVARS sigma); (change_in_hyp None (make_change_arg typ) (id,InHypTypeOnly)); (replace_core (onHyp id) l2r eqn) ]) (change_in_hyp None (make_change_arg expected) (id,InHypTypeOnly)) + in + Sigma (tac, sigma, p) end } let try_rewrite tac = @@ -1563,26 +1610,6 @@ user = raise user error specific to rewrite (**********************************************************************) (* Substitutions tactics (JCF) *) -let unfold_body x = - Proofview.Goal.enter { enter = begin fun gl -> - (** We normalize the given hypothesis immediately. *) - let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in - let (_, xval, _) = Context.lookup_named x hyps in - let xval = match xval with - | None -> errorlabstrm "unfold_body" - (pr_id x ++ str" is not a defined hypothesis.") - | Some xval -> pf_nf_evar gl xval - in - afterHyp x begin fun aft -> - let hl = List.fold_right (fun (y,yval,_) cl -> (y,InHyp) :: cl) aft [] in - let xvar = mkVar x in - let rfun _ _ c = replace_term xvar xval c in - let reducth h = Proofview.V82.tactic (fun gl -> reduct_in_hyp rfun h gl) in - let reductc = Proofview.V82.tactic (fun gl -> reduct_in_concl (rfun, DEFAULTcast) gl) in - tclTHENLIST [tclMAP reducth hl; reductc] - end - end } - let restrict_to_eq_and_identity eq = (* compatibility *) if not (is_global glob_eq eq) && not (is_global glob_identity eq) @@ -1591,9 +1618,10 @@ 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 occurring in [t] *) -let is_eq_x gl x (id,_,c) = +let is_eq_x gl x d = + let id = get_id d in try - let c = pf_nf_evar gl c in + let c = pf_nf_evar gl (get_type d) in let (_,lhs,rhs) = pi3 (find_eq_data_decompose gl c) in if (Term.eq_constr x lhs) && not (occur_term x rhs) then raise (FoundHyp (id,rhs,true)); if (Term.eq_constr x rhs) && not (occur_term x lhs) then raise (FoundHyp (id,lhs,false)) @@ -1610,11 +1638,12 @@ let subst_one dep_proof_ok x (hyp,rhs,dir) = 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) -> + List.rev (snd (List.fold_right (fun dcl (deps,allhyps) -> + let id = get_id dcl in if not (Id.equal id hyp) && List.exists (fun y -> occur_var_in_decl env y dcl) deps then - ((if b = None then deps else id::deps), id::allhyps) + ((if is_local_assum dcl then deps else id::deps), id::allhyps) else (deps,allhyps)) hyps @@ -1638,7 +1667,7 @@ let subst_one dep_proof_ok x (hyp,rhs,dir) = let subst_one_var dep_proof_ok x = Proofview.Goal.enter { enter = begin fun gl -> let gl = Proofview.Goal.assume gl in - let (_,xval,_) = pf_get_hyp x gl in + let xval = pf_get_hyp x gl |> get_value in (* If x has a body, simply replace x with body and clear x *) if not (Option.is_empty xval) then tclTHEN (unfold_body x) (clear [x]) else (* x is a variable: *) @@ -1649,7 +1678,7 @@ let subst_one_var dep_proof_ok x = (** [is_eq_x] ensures nf_evar on its side *) let hyps = Proofview.Goal.hyps gl in let test hyp _ = is_eq_x gl varx hyp in - Context.fold_named_context test ~init:() hyps; + Context.Named.fold_outside test ~init:() hyps; errorlabstrm "Subst" (str "Cannot find any non-recursive equality over " ++ pr_id x ++ str".") @@ -1697,14 +1726,14 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = let gl = Proofview.Goal.assume gl in let env = Proofview.Goal.env gl in let find_eq_data_decompose = find_eq_data_decompose gl in - let test (hyp,_,c) = + let test decl = try - let lbeq,u,(_,x,y) = find_eq_data_decompose c in + let lbeq,u,(_,x,y) = find_eq_data_decompose (get_type decl) in let eq = Universes.constr_of_global_univ (lbeq.eq,u) in if flags.only_leibniz then restrict_to_eq_and_identity eq; match kind_of_term x, kind_of_term y with | Var z, _ | _, Var z when not (is_evaluable env (EvalVarRef z)) -> - Some hyp + Some (get_id decl) | _ -> None with Constr_matching.PatternMatchingFailure -> None @@ -1718,7 +1747,7 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = Proofview.Goal.enter { 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 c = pf_get_hyp hyp gl |> get_type in let _,_,(_,x,y) = find_eq_data_decompose c in (* J.F.: added to prevent failure on goal containing x=x as an hyp *) if Term.eq_constr x y then Proofview.tclUNIT () else @@ -1786,10 +1815,11 @@ let cond_eq_term c t gl = let rewrite_assumption_cond cond_eq_term cl = let rec arec hyps gl = match hyps with | [] -> error "No such assumption." - | (id,_,t) ::rest -> + | hyp ::rest -> + let id = get_id hyp in begin try - let dir = cond_eq_term t gl in + let dir = cond_eq_term (get_type hyp) gl in general_rewrite_clause dir false (mkVar id,NoBindings) cl with | Failure _ | UserError _ -> arec rest gl end diff --git a/tactics/equality.mli b/tactics/equality.mli index 840ede7d9..458d8f372 100644 --- a/tactics/equality.mli +++ b/tactics/equality.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -117,3 +117,8 @@ val subst_all : ?flags:subst_tactic_flags -> unit -> unit Proofview.tactic val replace_term : bool option -> constr -> clause -> unit Proofview.tactic val set_eq_dec_scheme_kind : mutual scheme_kind -> unit + +(* [build_selector env sigma i c t u v] matches on [c] of + type [t] and returns [u] in branch [i] and [v] on other branches *) +val build_selector : env -> evar_map -> int -> constr -> types -> + constr -> constr -> constr diff --git a/tactics/ftactic.ml b/tactics/ftactic.ml index fea0432ae..588709873 100644 --- a/tactics/ftactic.ml +++ b/tactics/ftactic.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -16,7 +16,7 @@ type 'a focus = (** Type of tactics potentially goal-dependent. If it contains a [Depends], then the length of the inner list is guaranteed to be the number of - currently focussed goals. Otherwise it means the tactic does not depends + currently focussed goals. Otherwise it means the tactic does not depend on the current set of focussed goals. *) type 'a t = 'a focus Proofview.tactic @@ -37,16 +37,32 @@ let bind (type a) (type b) (m : a t) (f : a -> b t) : b t = m >>= function Proofview.tclDISPATCHL (List.map f l) >>= fun l -> Proofview.tclUNIT (Depends (List.concat l)) +let goals = Proofview.Goal.goals >>= fun l -> Proofview.tclUNIT (Depends l) +let set_sigma r = + let Sigma.Sigma (ans, sigma, _) = r in + Proofview.Unsafe.tclEVARS (Sigma.to_evar_map sigma) >>= fun () -> ans + let nf_enter f = - bind (Proofview.Goal.goals >>= fun l -> Proofview.tclUNIT (Depends l)) + bind goals + (fun gl -> + gl >>= fun gl -> + Proofview.Goal.normalize gl >>= fun nfgl -> + Proofview.V82.wrap_exceptions (fun () -> f.enter nfgl)) + +let nf_s_enter f = + bind goals (fun gl -> gl >>= fun gl -> Proofview.Goal.normalize gl >>= fun nfgl -> - Proofview.V82.wrap_exceptions (fun () -> f nfgl)) + Proofview.V82.wrap_exceptions (fun () -> set_sigma (f.s_enter nfgl))) let enter f = - bind (Proofview.Goal.goals >>= fun l -> Proofview.tclUNIT (Depends l)) - (fun gl -> gl >>= fun gl -> Proofview.V82.wrap_exceptions (fun () -> f gl)) + bind goals + (fun gl -> gl >>= fun gl -> Proofview.V82.wrap_exceptions (fun () -> f.enter gl)) + +let s_enter f = + bind goals + (fun gl -> gl >>= fun gl -> Proofview.V82.wrap_exceptions (fun () -> set_sigma (f.s_enter gl))) let with_env t = t >>= function @@ -83,4 +99,8 @@ end module Ftac = Monad.Make(Self) module List = Ftac.List -let debug_prompt = Tactic_debug.debug_prompt +module Notations = +struct + let (>>=) = bind + let (<*>) = fun m n -> bind m (fun () -> n) +end diff --git a/tactics/ftactic.mli b/tactics/ftactic.mli index 449649922..19041f169 100644 --- a/tactics/ftactic.mli +++ b/tactics/ftactic.mli @@ -1,11 +1,13 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Proofview.Notations + (** Potentially focussing tactics *) type +'a focus @@ -37,14 +39,19 @@ val run : 'a t -> ('a -> unit Proofview.tactic) -> unit Proofview.tactic (** {5 Focussing} *) -val nf_enter : (([ `NF ], 'r) Proofview.Goal.t -> 'a t) -> 'a t +val nf_enter : ([ `NF ], 'a t) enter -> 'a t (** Enter a goal. The resulting tactic is focussed. *) -(** FIXME: Should be polymorphic over the stage. *) -val enter : (([ `LZ ], 'r) Proofview.Goal.t -> 'a t) -> 'a t +val enter : ([ `LZ ], 'a t) enter -> 'a t (** Enter a goal, without evar normalization. The resulting tactic is focussed. *) -(** FIXME: Should be polymorphic over the stage. *) + +val s_enter : ([ `LZ ], 'a t) s_enter -> 'a t +(** Enter a goal and put back an evarmap. The resulting tactic is focussed. *) + +val nf_s_enter : ([ `NF ], 'a t) s_enter -> 'a t +(** Enter a goal, without evar normalization and put back an evarmap. The + resulting tactic is focussed. *) val with_env : 'a t -> (Environ.env*'a) t (** [with_env t] returns, in addition to the return type of [t], an @@ -63,7 +70,10 @@ val (<*>) : unit t -> 'a t -> 'a t module List : Monad.ListS with type 'a t := 'a t -(** {5 Debug} *) +(** {5 Notations} *) -val debug_prompt : - int -> Tacexpr.glob_tactic_expr -> (Tactic_debug.debug_info -> 'a t) -> 'a t +module Notations : +sig + val (>>=) : 'a t -> ('a -> 'b t) -> 'b t + val (<*>) : unit t -> 'a t -> 'a t +end diff --git a/tactics/geninterp.ml b/tactics/geninterp.ml index d44c4ac3a..008075800 100644 --- a/tactics/geninterp.ml +++ b/tactics/geninterp.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -12,11 +12,10 @@ open Genarg module TacStore = Store.Make(struct end) type interp_sign = { - lfun : tlevel generic_argument Id.Map.t; + lfun : Val.t Id.Map.t; extra : TacStore.t } -type ('glb, 'top) interp_fun = interp_sign -> - Goal.goal Evd.sigma -> 'glb -> Evd.evar_map * 'top +type ('glb, 'top) interp_fun = interp_sign -> 'glb -> 'top Ftactic.t module InterpObj = struct @@ -30,9 +29,7 @@ module Interp = Register(InterpObj) let interp = Interp.obj let register_interp0 = Interp.register0 -let generic_interp ist gl v = - let unpacker wit v = - let (sigma, ans) = interp wit ist gl (glb v) in - (sigma, in_gen (topwit wit) ans) - in - unpack { unpacker; } v +let generic_interp ist (GenArg (Glbwit wit, v)) = + let open Ftactic.Notations in + interp wit ist v >>= fun ans -> + Ftactic.return (Val.Dyn (val_tag (topwit wit), ans)) diff --git a/tactics/geninterp.mli b/tactics/geninterp.mli index 3c653697d..0992db7a2 100644 --- a/tactics/geninterp.mli +++ b/tactics/geninterp.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -14,15 +14,14 @@ open Genarg module TacStore : Store.S type interp_sign = { - lfun : tlevel generic_argument Id.Map.t; + lfun : Val.t Id.Map.t; extra : TacStore.t } -type ('glb, 'top) interp_fun = interp_sign -> - Goal.goal Evd.sigma -> 'glb -> Evd.evar_map * 'top +type ('glb, 'top) interp_fun = interp_sign -> 'glb -> 'top Ftactic.t val interp : ('raw, 'glb, 'top) genarg_type -> ('glb, 'top) interp_fun -val generic_interp : (glob_generic_argument, typed_generic_argument) interp_fun +val generic_interp : (glob_generic_argument, Val.t) interp_fun val register_interp0 : ('raw, 'glb, 'top) genarg_type -> ('glb, 'top) interp_fun -> unit diff --git a/tactics/hightactics.mllib b/tactics/hightactics.mllib deleted file mode 100644 index ff2e1ff6a..000000000 --- a/tactics/hightactics.mllib +++ /dev/null @@ -1,11 +0,0 @@ -Extraargs -Coretactics -Extratactics -Eauto -Class_tactics -G_class -Rewrite -G_rewrite -Tauto -Eqdecide -G_eqdecide diff --git a/tactics/hints.ml b/tactics/hints.ml index 4ba9adafe..b2104ba43 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -33,6 +33,8 @@ open Pfedit open Tacred open Printer open Vernacexpr +open Sigma.Notations +open Context.Named.Declaration (****************************************) (* General functions *) @@ -74,7 +76,7 @@ type 'a hint_ast = | Give_exact of 'a | Res_pf_THEN_trivial_fail of 'a (* Hint Immediate *) | Unfold_nth of evaluable_global_reference (* Hint Unfold *) - | Extern of glob_tactic_expr (* Hint Extern *) + | Extern of Genarg.glob_generic_argument (* Hint Extern *) type hints_path_atom = | PathHints of global_reference list @@ -153,27 +155,6 @@ let fresh_key = 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 -| PathAny, PathAny -> true -| (PathHints _ | PathAny), _ -> false - -let eq_auto_tactic t1 t2 = match t1, t2 with -| Res_pf (c1, _), Res_pf (c2, _) -> Constr.equal c1 c2 -| ERes_pf (c1, _), ERes_pf (c2, _) -> Constr.equal c1 c2 -| Give_exact (c1, _), Give_exact (c2, _) -> Constr.equal c1 c2 -| Res_pf_THEN_trivial_fail (c1, _), Res_pf_THEN_trivial_fail (c2, _) -> Constr.equal c1 c2 -| Unfold_nth gr1, Unfold_nth gr2 -> eq_egr gr1 gr2 -| Extern tac1, Extern tac2 -> tac1 == tac2 (** May cause redundancy in addkv *) -| (Res_pf _ | ERes_pf _ | Give_exact _ | Res_pf_THEN_trivial_fail _ - | Unfold_nth _ | Extern _), _ -> false - -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 && - eq_auto_tactic t1.code t2.code - let pri_order_int (id1, {pri=pri1}) (id2, {pri=pri2}) = let d = pri1 - pri2 in if Int.equal d 0 then id2 - id1 @@ -382,15 +363,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 @@ -673,7 +658,7 @@ let make_exact_entry env sigma pri poly ?(name=PathAny) (c, cty, ctx) = match kind_of_term cty with | Prod _ -> failwith "make_exact_entry" | _ -> - let pat = pi3 (Patternops.pattern_of_constr env sigma cty) in + let pat = Patternops.pattern_of_constr env sigma cty in let hd = try head_pattern_bound pat with BoundPattern -> failwith "make_exact_entry" @@ -692,7 +677,7 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri poly ?(name=PathAny) (c, let sigma' = Evd.merge_context_set univ_flexible sigma ctx in let ce = mk_clenv_from_env env sigma' None (c,cty) in let c' = clenv_type (* ~reduce:false *) ce in - let pat = pi3 (Patternops.pattern_of_constr env ce.evd c') in + let pat = Patternops.pattern_of_constr env ce.evd c' in let hd = try head_pattern_bound pat with BoundPattern -> failwith "make_apply_entry" in @@ -743,11 +728,12 @@ let make_resolves env sigma flags pri poly ?name cr = ents (* used to add an hypothesis to the local hint database *) -let make_resolve_hyp env sigma (hname,_,htyp) = +let make_resolve_hyp env sigma decl = + let hname = get_id decl in try [make_apply_entry env sigma (true, true, false) None false ~name:(PathHints [VarRef hname]) - (mkVar hname, htyp, Univ.ContextSet.empty)] + (mkVar hname, get_type decl, Univ.ContextSet.empty)] with | Failure _ -> [] | e when Logic.catchable_exception e -> anomaly (Pp.str "make_resolve_hyp") @@ -763,6 +749,7 @@ let make_unfold eref = code = with_uid (Unfold_nth eref) }) let make_extern pri pat tacast = + let tacast = Genarg.in_gen (Genarg.glbwit Constrarg.wit_ltac) tacast in let hdconstr = Option.map try_head_pattern pat in (hdconstr, { pri = pri; @@ -790,7 +777,7 @@ let make_trivial env sigma poly ?(name=PathAny) r = 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))); + pat = Some (Patternops.pattern_of_constr env ce.evd (clenv_type ce)); name = name; code= with_uid (Res_pf_THEN_trivial_fail(c,t,ctx)) }) @@ -914,7 +901,7 @@ let subst_autohint (subst, obj) = let ref' = subst_evaluable_reference subst ref in if ref==ref' then data.code.obj else Unfold_nth ref' | Extern tac -> - let tac' = Tacsubst.subst_tactic subst tac in + let tac' = Genintern.generic_substitute subst tac in if tac==tac' then data.code.obj else Extern tac' in let name' = subst_path_atom subst data.name in @@ -1077,7 +1064,7 @@ let prepare_hint check (poly,local) env init (sigma,c) = (* Not clever enough to construct dependency graph of evars *) error "Not clever enough to deal with evars dependent in other evars."; raise (Found (c,t)) - | _ -> iter_constr find_next_evar c in + | _ -> Constr.iter find_next_evar c in let rec iter c = try find_next_evar c; c with Found (evar,t) -> @@ -1086,7 +1073,7 @@ let prepare_hint check (poly,local) env init (sigma,c) = subst := (evar,mkVar id)::!subst; mkNamedLambda id t (iter (replace_term evar (mkVar id) c)) in let c' = iter c in - if check then Evarutil.check_evars (Global.env()) Evd.empty sigma c'; + if check then Pretyping.check_evars (Global.env()) Evd.empty sigma c'; let diff = Univ.ContextSet.diff (Evd.universe_context_set sigma) (Evd.universe_context_set init) in if poly then IsConstr (c', diff) else if local then IsConstr (c', diff) @@ -1180,6 +1167,12 @@ let add_hint_lemmas env sigma eapply lems hint_db = Hint_db.add_list env sigma hintlist' hint_db let make_local_hint_db env sigma ts eapply lems = + let map c = + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma (c, sigma, _) = c.delayed env sigma in + (Sigma.to_evar_map sigma, c) + in + let lems = List.map map lems in let sign = Environ.named_context env in let ts = match ts with | None -> Hint_db.transparent_state (searchtable_map "core") @@ -1227,7 +1220,7 @@ let pr_hint h = match h.obj with env with e when Errors.noncritical e -> Global.env () in - (str "(*external*) " ++ Pptactic.pr_glob_tactic env tac) + (str "(*external*) " ++ Pptactic.pr_glb_generic env tac) let pr_id_hint (id, v) = (pr_hint v.code ++ str"(level " ++ int v.pri ++ str", id " ++ int id ++ str ")" ++ spc ()) diff --git a/tactics/hints.mli b/tactics/hints.mli index af4d3d1f6..df9d79212 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -10,7 +10,6 @@ open Pp open Util open Names open Term -open Context open Environ open Globnames open Decl_kinds @@ -34,7 +33,7 @@ type 'a hint_ast = | Give_exact of 'a | Res_pf_THEN_trivial_fail of 'a (* Hint Immediate *) | Unfold_nth of evaluable_global_reference (* Hint Unfold *) - | Extern of Tacexpr.glob_tactic_expr (* Hint Extern *) + | Extern of Genarg.glob_generic_argument (* Hint Extern *) type hint type raw_hint = constr * types * Univ.universe_context_set @@ -70,6 +69,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 : @@ -191,7 +191,7 @@ val make_resolves : If the hyp cannot be used as a Hint, the empty list is returned. *) val make_resolve_hyp : - env -> evar_map -> named_declaration -> hint_entry list + env -> evar_map -> Context.Named.Declaration.t -> hint_entry list (** [make_extern pri pattern tactic_expr] *) @@ -213,7 +213,7 @@ val extern_intern_tac : Useful to take the current goal hypotheses as hints; Boolean tells if lemmas with evars are allowed *) -val make_local_hint_db : env -> evar_map -> ?ts:transparent_state -> bool -> open_constr list -> hint_db +val make_local_hint_db : env -> evar_map -> ?ts:transparent_state -> bool -> Tacexpr.delayed_open_constr list -> hint_db val make_db_list : hint_db_name list -> hint_db list diff --git a/tactics/hipattern.ml4 b/tactics/hipattern.ml4 index 95f3af57e..bcec90f80 100644 --- a/tactics/hipattern.ml4 +++ b/tactics/hipattern.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -19,6 +19,7 @@ open Constr_matching open Coqlib open Declarations open Tacmach.New +open Context.Rel.Declaration (* I implemented the following functions which test whether a term t is an inductive but non-recursive type, a general conjuction, a @@ -101,13 +102,16 @@ let match_with_one_constructor style onlybinary allow_rec t = (decompose_prod_n_assum mib.mind_nparams mip.mind_nf_lc.(0)))) in if List.for_all - (fun (_,b,c) -> Option.is_empty b && isRel c && Int.equal (destRel c) mib.mind_nparams) ctx + (fun decl -> let c = get_type decl in + is_local_assum decl && + isRel c && + Int.equal (destRel c) mib.mind_nparams) ctx then Some (hdapp,args) else None else let ctyp = prod_applist mip.mind_nf_lc.(0) args in - let cargs = List.map pi3 ((prod_assum ctyp)) in + let cargs = List.map get_type (prod_assum ctyp) in if not (is_lax_conjunction style) || has_nodep_prod ctyp then (* Record or non strict conjunction *) Some (hdapp,List.rev cargs) @@ -152,7 +156,7 @@ let is_tuple t = let test_strict_disjunction n lc = Array.for_all_i (fun i c -> match (prod_assum (snd (decompose_prod_n_assum n c))) with - | [_,None,c] -> isRel c && Int.equal (destRel c) (n - i) + | [LocalAssum (_,c)] -> isRel c && Int.equal (destRel c) (n - i) | _ -> false) 0 lc let match_with_disjunction ?(strict=false) ?(onlybinary=false) t = diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli index 281e6b9bb..7cc41f1b9 100644 --- a/tactics/hipattern.mli +++ b/tactics/hipattern.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/tactics/inv.ml b/tactics/inv.ml index a9fa52e92..89c6beb32 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -13,7 +13,6 @@ open Names open Nameops open Term open Vars -open Context open Termops open Namegen open Environ @@ -29,6 +28,7 @@ open Misctypes open Tacexpr open Sigma.Notations open Proofview.Notations +open Context.Named.Declaration let clear hyps = Proofview.V82.tactic (clear hyps) @@ -97,7 +97,7 @@ let make_inv_predicate env evd indf realargs id status concl = (* We lift to make room for the equations *) (hyps,lift nrealargs bodypred) in - let nhyps = rel_context_length hyps in + let nhyps = Context.Rel.length hyps in let env' = push_rel_context hyps env in (* Now the arity is pushed, and we need to construct the pairs * ai,mkRel(n-i+1) *) @@ -182,9 +182,9 @@ let make_inv_predicate env evd indf realargs id status concl = let dependent_hyps env id idlist gl = let rec dep_rec =function | [] -> [] - | (id1,_,_)::l -> + | d::l -> (* Update the type of id1: it may have been subject to rewriting *) - let d = pf_get_hyp id1 gl in + let d = pf_get_hyp (get_id d) gl in if occur_var_in_decl env id d then d :: dep_rec l else dep_rec l @@ -193,8 +193,8 @@ let dependent_hyps env id idlist gl = let split_dep_and_nodep hyps gl = List.fold_right - (fun (id,_,_ as d) (l1,l2) -> - if var_occurs_in_pf gl id then (d::l1,l2) else (l1,d::l2)) + (fun d (l1,l2) -> + if var_occurs_in_pf gl (get_id d) then (d::l1,l2) else (l1,d::l2)) hyps ([],[]) (* Computation of dids is late; must have been done in rewrite_equations*) @@ -297,17 +297,17 @@ let get_names (allow_conj,issimple) (loc, pat as x) = match pat with error "Discarding pattern not allowed for inversion equations." | IntroAction (IntroRewrite _) -> error "Rewriting pattern not allowed for inversion equations." - | IntroAction (IntroOrAndPattern [[]]) when allow_conj -> (None, []) - | IntroAction (IntroOrAndPattern [(_,IntroNaming (IntroIdentifier id)) :: _ as l]) + | IntroAction (IntroOrAndPattern (IntroAndPattern [])) when allow_conj -> (None, []) + | IntroAction (IntroOrAndPattern (IntroAndPattern ((_,IntroNaming (IntroIdentifier id)) :: _ as l) | IntroOrPattern [(_,IntroNaming (IntroIdentifier id)) :: _ as l ])) when allow_conj -> (Some id,l) - | IntroAction (IntroOrAndPattern [_]) -> + | IntroAction (IntroOrAndPattern (IntroAndPattern _)) -> if issimple then error"Conjunctive patterns not allowed for simple inversion equations." else error"Nested conjunctive patterns not allowed for inversion equations." | IntroAction (IntroInjection l) -> error "Injection patterns not allowed for inversion equations." - | IntroAction (IntroOrAndPattern l) -> + | IntroAction (IntroOrAndPattern (IntroOrPattern _)) -> error "Disjunctive patterns not allowed for inversion equations." | IntroAction (IntroApplyOn (c,pat)) -> error "Apply patterns not allowed for inversion equations." @@ -385,7 +385,7 @@ let rewrite_equations as_mode othin neqns names ba = Proofview.Goal.nf_enter { enter = begin fun gl -> let (depids,nodepids) = split_dep_and_nodep ba.Tacticals.assums gl in let first_eq = ref MoveLast in - let avoid = if as_mode then List.map pi1 nodepids else [] in + let avoid = if as_mode then List.map get_id nodepids else [] in match othin with | Some thin -> tclTHENLIST @@ -400,11 +400,11 @@ let rewrite_equations as_mode othin neqns names ba = (onLastHypId (fun id -> tclTRY (projectAndApply as_mode thin avoid id first_eq names depids))))) names; - tclMAP (fun (id,_,_) -> tclIDTAC >>= fun () -> (* delay for [first_eq]. *) - let idopt = if as_mode then Some id else None in + tclMAP (fun d -> tclIDTAC >>= fun () -> (* delay for [first_eq]. *) + let idopt = if as_mode then Some (get_id d) else None in intro_move idopt (if thin then MoveLast else !first_eq)) nodepids; - (tclMAP (fun (id,_,_) -> tclTRY (clear [id])) depids)] + (tclMAP (fun d -> tclTRY (clear [get_id d])) depids)] | None -> (* simple inversion *) if as_mode then @@ -432,7 +432,8 @@ let rewrite_equations_tac as_mode othin id neqns names ba = tac let raw_inversion inv_kind id status names = - Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in let sigma = Sigma.to_evar_map sigma in let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl gl in @@ -458,7 +459,7 @@ let raw_inversion inv_kind id status names = in let refined id = let prf = mkApp (mkVar id, args) in - Proofview.Refine.refine { run = fun h -> Sigma (prf, h, Sigma.refl) } + Refine.refine { run = fun h -> Sigma (prf, h, Sigma.refl) } in let neqns = List.length realargs in let as_mode = names != None in diff --git a/tactics/inv.mli b/tactics/inv.mli index 412f30c20..af1cb996a 100644 --- a/tactics/inv.mli +++ b/tactics/inv.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/tactics/leminv.ml b/tactics/leminv.ml index 04a78dc57..70782ec64 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -14,7 +14,6 @@ open Term open Vars open Termops open Namegen -open Context open Evd open Printer open Reductionops @@ -28,6 +27,7 @@ open Tacticals.New open Tactics open Decl_kinds open Proofview.Notations +open Context.Named.Declaration let no_inductive_inconstr env sigma constr = (str "Cannot recognize an inductive predicate in " ++ @@ -118,11 +118,11 @@ let rec add_prods_sign env sigma t = | Prod (na,c1,b) -> let id = id_of_name_using_hdchar env t na in let b'= subst1 (mkVar id) b in - add_prods_sign (push_named (id,None,c1) env) sigma b' + add_prods_sign (push_named (LocalAssum (id,c1)) env) sigma b' | LetIn (na,c1,t1,b) -> let id = id_of_name_using_hdchar env t na in let b'= subst1 (mkVar id) b in - add_prods_sign (push_named (id,Some c1,t1) env) sigma b' + add_prods_sign (push_named (LocalDef (id,c1,t1)) env) sigma b' | _ -> (env,t) (* [dep_option] indicates whether the inversion lemma is dependent or not. @@ -155,9 +155,10 @@ let compute_first_inversion_scheme env sigma ind sort dep_option = let ivars = global_vars env i in let revargs,ownsign = fold_named_context - (fun env (id,_,_ as d) (revargs,hyps) -> + (fun env d (revargs,hyps) -> + let id = get_id d in if Id.List.mem id ivars then - ((mkVar id)::revargs,add_named_decl d hyps) + ((mkVar id)::revargs, Context.Named.add d hyps) else (revargs,hyps)) env ~init:([],[]) @@ -167,7 +168,7 @@ let compute_first_inversion_scheme env sigma ind sort dep_option = (pty,goal) in let npty = nf_betadeltaiota env sigma pty in - let extenv = push_named (p,None,npty) env in + let extenv = push_named (LocalAssum (p,npty)) env in extenv, goal (* [inversion_scheme sign I] @@ -204,10 +205,10 @@ let inversion_scheme env sigma t sort dep_option inv_op = let global_named_context = Global.named_context () in let ownSign = ref begin fold_named_context - (fun env (id,_,_ as d) sign -> - if mem_named_context id global_named_context then sign - else add_named_decl d sign) - invEnv ~init:empty_named_context + (fun env d sign -> + if mem_named_context (get_id d) global_named_context then sign + else Context.Named.add d sign) + invEnv ~init:Context.Named.empty end in let avoid = ref [] in let { sigma=sigma } = Proof.V82.subgoals pf in @@ -218,9 +219,9 @@ let inversion_scheme env sigma t sort dep_option inv_op = let h = next_ident_away (Id.of_string "H") !avoid in let ty,inst = Evarutil.generalize_evar_over_rels sigma (e,args) in avoid := h::!avoid; - ownSign := add_named_decl (h,None,ty) !ownSign; + ownSign := Context.Named.add (LocalAssum (h,ty)) !ownSign; applist (mkVar h, inst) - | _ -> map_constr fill_holes c + | _ -> Constr.map fill_holes c in let c = fill_holes pfterm in (* warning: side-effect on ownSign *) @@ -230,7 +231,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/leminv.mli b/tactics/leminv.mli index 2f80d26fc..c6ed9606f 100644 --- a/tactics/leminv.mli +++ b/tactics/leminv.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/tactics/taccoerce.ml b/tactics/taccoerce.ml index ab71f5f2e..358f6d646 100644 --- a/tactics/taccoerce.ml +++ b/tactics/taccoerce.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -18,21 +18,33 @@ open Constrarg exception CannotCoerceTo of string let (wit_constr_context : (Empty.t, Empty.t, constr) Genarg.genarg_type) = - Genarg.create_arg None "constr_context" + Genarg.create_arg "constr_context" (* includes idents known to be bound and references *) let (wit_constr_under_binders : (Empty.t, Empty.t, constr_under_binders) Genarg.genarg_type) = - Genarg.create_arg None "constr_under_binders" + Genarg.create_arg "constr_under_binders" + +let has_type : type a. Val.t -> a typed_abstract_argument_type -> bool = fun v wit -> + let Val.Dyn (t, _) = v in + match Val.eq t (val_tag wit) with + | None -> false + | Some Refl -> true + +let prj : type a. a Val.tag -> Val.t -> a option = fun t v -> + let Val.Dyn (t', x) = v in + match Val.eq t t' with + | None -> None + | Some Refl -> Some x + +let in_gen wit v = Val.Dyn (val_tag wit, v) +let out_gen wit v = match prj (val_tag wit) v with None -> assert false | Some x -> x module Value = struct -type t = tlevel generic_argument +type t = Val.t -let rec normalize v = - if has_type v (topwit wit_genarg) then - normalize (out_gen (topwit wit_genarg) v) - else v +let normalize v = v let of_constr c = in_gen (topwit wit_constr) c @@ -64,9 +76,21 @@ let to_int v = let to_list v = let v = normalize v in - let list_unpacker wit l = List.map (fun v -> in_gen (topwit wit) v) (top l) in - try Some (list_unpack { list_unpacker } v) - with Failure _ -> None + let Val.Dyn (tag, v) = v in + match tag with + | Val.List t -> Some (List.map (fun x -> Val.Dyn (t, x)) v) + | _ -> None + +let of_list t v = Val.Dyn (Val.List t, v) + +let to_option v = + let v = normalize v in + let Val.Dyn (tag, v) = v in + match tag with + | Val.Opt t -> Some (Option.map (fun x -> Val.Dyn (t, x)) v) + | _ -> None + +let of_option t v = Val.Dyn (Val.Opt t, v) end diff --git a/tactics/taccoerce.mli b/tactics/taccoerce.mli index 85bad364d..87137fd2e 100644 --- a/tactics/taccoerce.mli +++ b/tactics/taccoerce.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -29,8 +29,7 @@ exception CannotCoerceTo of string module Value : sig - type t = tlevel generic_argument - (** Tactics manipulate [tlevel generic_argument]. *) + type t = Val.t val normalize : t -> t (** Eliminated the leading dynamic type casts. *) @@ -42,6 +41,9 @@ sig val of_int : int -> t val to_int : t -> int option val to_list : t -> t list option + val of_list : 'a Val.tag -> 'a list -> t + val to_option : t -> t option option + val of_option : 'a Val.tag -> 'a option -> t end (** {5 Coercion functions} *) @@ -55,9 +57,6 @@ val coerce_to_intro_pattern : Environ.env -> Value.t -> Tacexpr.delayed_open_con val coerce_to_intro_pattern_naming : Environ.env -> Value.t -> intro_pattern_naming_expr -val coerce_to_intro_pattern_naming : - Environ.env -> Value.t -> intro_pattern_naming_expr - val coerce_to_hint_base : Value.t -> string val coerce_to_int : Value.t -> int diff --git a/tactics/tactic_matching.ml b/tactics/tactic_matching.ml index 4e3624fb7..2144b75e7 100644 --- a/tactics/tactic_matching.ml +++ b/tactics/tactic_matching.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -11,6 +11,7 @@ open Names open Tacexpr +open Context.Named.Declaration (** [t] is the type of matching successes. It ultimately contains a {!Tacexpr.glob_tactic_expr} representing the left-hand side of the @@ -278,9 +279,10 @@ module PatternMatching (E:StaticEnvironment) = struct [hyps]. Tries the hypotheses in order. For each success returns the name of the matched hypothesis. *) let hyp_match_type hypname pat hyps = - pick hyps >>= fun (id,b,hyp) -> - let refresh = not (Option.is_empty b) in - pattern_match_term refresh pat hyp () <*> + pick hyps >>= fun decl -> + let id = get_id decl in + let refresh = is_local_def decl in + pattern_match_term refresh pat (get_type decl) () <*> put_terms (id_map_try_add_name hypname (Term.mkVar id) empty_term_subst) <*> return id @@ -290,12 +292,12 @@ module PatternMatching (E:StaticEnvironment) = struct success returns the name of the matched hypothesis. *) let hyp_match_body_and_type hypname bodypat typepat hyps = pick hyps >>= function - | (id,Some body,hyp) -> + | LocalDef (id,body,hyp) -> pattern_match_term false bodypat body () <*> pattern_match_term true typepat hyp () <*> put_terms (id_map_try_add_name hypname (Term.mkVar id) empty_term_subst) <*> return id - | (id,None,hyp) -> fail + | LocalAssum (id,hyp) -> fail (** [hyp_match pat hyps] dispatches to {!hyp_match_type} or {!hyp_match_body_and_type} depending on whether @@ -317,7 +319,7 @@ module PatternMatching (E:StaticEnvironment) = struct (* spiwack: alternatively it is possible to return the list with the matched hypothesis removed directly in [hyp_match]. *) - let select_matched_hyp (id,_,_) = Id.equal id matched_hyp in + let select_matched_hyp decl = Id.equal (get_id decl) matched_hyp in let hyps = CList.remove_first select_matched_hyp hyps in hyp_pattern_list_match pats hyps lhs | [] -> return lhs diff --git a/tactics/tactic_matching.mli b/tactics/tactic_matching.mli index d8e6dd0ae..090207bcc 100644 --- a/tactics/tactic_matching.mli +++ b/tactics/tactic_matching.mli @@ -43,7 +43,7 @@ val match_term : val match_goal: Environ.env -> Evd.evar_map -> - Context.named_context -> + Context.Named.t -> Term.constr -> (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 bdbc0aa21..7f904a561 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -12,10 +12,11 @@ open Util open Names open Term open Termops -open Context open Declarations open Tacmach open Clenv +open Sigma.Notations +open Context.Named.Declaration (************************************************************************) (* Tacticals re-exported from the Refiner module *) @@ -69,7 +70,7 @@ let nthDecl m gl = try List.nth (pf_hyps gl) (m-1) with Failure _ -> error "No such assumption." -let nthHypId m gl = pi1 (nthDecl m gl) +let nthHypId m gl = nthDecl m gl |> get_id let nthHyp m gl = mkVar (nthHypId m gl) let lastDecl gl = nthDecl 1 gl @@ -80,7 +81,7 @@ let nLastDecls n gl = try List.firstn n (pf_hyps gl) with Failure _ -> error "Not enough hypotheses in the goal." -let nLastHypsId n gl = List.map pi1 (nLastDecls n gl) +let nLastHypsId n gl = List.map get_id (nLastDecls n gl) let nLastHyps n gl = List.map mkVar (nLastHypsId n gl) let onNthDecl m tac gl = tac (nthDecl m gl) gl @@ -98,7 +99,7 @@ let onNLastHypsId n tac = onHyps (nLastHypsId n) tac let onNLastHyps n tac = onHyps (nLastHyps n) tac let afterHyp id gl = - fst (List.split_when (fun (hyp,_,_) -> Id.equal hyp id) (pf_hyps gl)) + fst (List.split_when (Id.equal id % get_id) (pf_hyps gl)) (***************************************) (* Clause Tacticals *) @@ -147,14 +148,16 @@ type branch_args = { largs : constr list; (* its arguments *) branchnum : int; (* the branch number *) pred : constr; (* the predicate we used *) - nassums : int; (* the number of assumptions to be introduced *) + nassums : int; (* number of assumptions/letin to be introduced *) branchsign : bool list; (* the signature of the branch. - true=recursive argument, false=constant *) + true=assumption, false=let-in *) branchnames : Tacexpr.intro_patterns} type branch_assumptions = { - ba : branch_args; (* the branch args *) - assums : named_context} (* the list of assumptions introduced *) + ba : branch_args; (* the branch args *) + assums : Context.Named.t} (* the list of assumptions introduced *) + +open Misctypes let fix_empty_or_and_pattern nv l = (* 1- The syntax does not distinguish between "[ ]" for one clause with no @@ -162,36 +165,78 @@ let fix_empty_or_and_pattern nv l = (* 2- More generally, we admit "[ ]" for any disjunctive pattern of arbitrary length *) match l with - | [[]] -> List.make nv [] + | IntroOrPattern [[]] -> IntroOrPattern (List.make nv []) | _ -> l -let check_or_and_pattern_size loc names n = - if not (Int.equal (List.length names) n) then - if Int.equal n 1 then - user_err_loc (loc,"",str "Expects a conjunctive pattern.") - else - user_err_loc (loc,"",str "Expects a disjunctive pattern with " ++ int n - ++ str " branches.") - -let compute_induction_names n = function +let check_or_and_pattern_size check_and loc names branchsigns = + let n = Array.length branchsigns in + let msg p1 p2 = strbrk "a conjunctive pattern made of " ++ int p1 ++ (if p1 == p2 then mt () else str " or " ++ int p2) ++ str " patterns" in + let err1 p1 p2 = + user_err_loc (loc,"",str "Expects " ++ msg p1 p2 ++ str ".") in + let errn n = + user_err_loc (loc,"",str "Expects a disjunctive pattern with " ++ int n + ++ str " branches.") in + let err1' p1 p2 = + user_err_loc (loc,"",strbrk "Expects a disjunctive pattern with 1 branch or " ++ msg p1 p2 ++ str ".") in + let errforthcoming loc = + user_err_loc (loc,"",strbrk "Unexpected non atomic pattern.") in + match names with + | IntroAndPattern l -> + if not (Int.equal n 1) then errn n; + let l' = List.filter (function _,IntroForthcoming _ -> true | _,IntroNaming _ | _,IntroAction _ -> false) l in + if l' != [] then errforthcoming (fst (List.hd l')); + if check_and then + let p1 = List.count (fun x -> x) branchsigns.(0) in + let p2 = List.length branchsigns.(0) in + let p = List.length l in + if not (Int.equal p p1 || Int.equal p p2) then err1 p1 p2; + if Int.equal p p1 then + IntroAndPattern + (List.extend branchsigns.(0) (Loc.ghost,IntroNaming IntroAnonymous) l) + else + names + else + names + | IntroOrPattern ll -> + if not (Int.equal n (List.length ll)) then + if Int.equal n 1 then + let p1 = List.count (fun x -> x) branchsigns.(0) in + let p2 = List.length branchsigns.(0) in + err1' p1 p2 else errn n; + names + +let get_and_check_or_and_pattern_gen check_and loc names branchsigns = + let names = check_or_and_pattern_size check_and loc names branchsigns in + match names with + | IntroAndPattern l -> [|l|] + | IntroOrPattern l -> Array.of_list l + +let get_and_check_or_and_pattern = get_and_check_or_and_pattern_gen true + +let compute_induction_names_gen check_and branchletsigns = function | None -> - Array.make n [] + Array.make (Array.length branchletsigns) [] | Some (loc,names) -> - let names = fix_empty_or_and_pattern n names in - check_or_and_pattern_size loc names n; - Array.of_list names + let names = fix_empty_or_and_pattern (Array.length branchletsigns) names in + get_and_check_or_and_pattern_gen check_and loc names branchletsigns -let compute_construtor_signatures isrec ((_,k as ity),u) = +let compute_induction_names = compute_induction_names_gen true + +(* Compute the let-in signature of case analysis or standard induction scheme *) +let compute_constructor_signatures isrec ((_,k as ity),u) = let rec analrec c recargs = match kind_of_term c, recargs with | Prod (_,_,c), recarg::rest -> - let b = match Declareops.dest_recarg recarg with - | Norec | Imbr _ -> false - | Mrec (_,j) -> isrec && Int.equal j k - in b :: (analrec c rest) - | LetIn (_,_,_,c), rest -> false :: (analrec c rest) + let rest = analrec c rest in + begin match Declareops.dest_recarg recarg with + | Norec | Imbr _ -> true :: rest + | Mrec (_,j) -> + if isrec && Int.equal j k then true :: true :: rest + else true :: rest + end + | LetIn (_,_,_,c), rest -> false :: analrec c rest | _, [] -> [] - | _ -> anomaly (Pp.str "compute_construtor_signatures") + | _ -> anomaly (Pp.str "compute_constructor_signatures") in let (mib,mip) = Global.lookup_inductive ity in let n = mib.mind_nparams in @@ -225,60 +270,28 @@ let gl_make_elim ind gl = pf_apply Evd.fresh_global gl gr let gl_make_case_dep ind gl = - pf_apply Indrec.build_case_analysis_scheme gl ind true + let sigma = Sigma.Unsafe.of_evar_map (Tacmach.project gl) in + let Sigma (r, sigma, _) = Indrec.build_case_analysis_scheme (pf_env gl) sigma ind true (elimination_sort_of_goal gl) + in + (Sigma.to_evar_map sigma, r) let gl_make_case_nodep ind gl = - pf_apply Indrec.build_case_analysis_scheme gl ind false + let sigma = Sigma.Unsafe.of_evar_map (Tacmach.project gl) in + let Sigma (r, sigma, _) = Indrec.build_case_analysis_scheme (pf_env gl) sigma ind false (elimination_sort_of_goal gl) + in + (Sigma.to_evar_map sigma, r) let make_elim_branch_assumptions ba gl = - let rec makerec (assums,cargs,constargs,recargs,indargs) lb lc = - match lb,lc with - | ([], _) -> - { ba = ba; - assums = assums} - | ((true::tl), ((idrec,_,_ as recarg)::(idind,_,_ as indarg)::idtl)) -> - makerec (recarg::indarg::assums, - idrec::cargs, - idrec::recargs, - constargs, - idind::indargs) tl idtl - | ((false::tl), ((id,_,_ as constarg)::idtl)) -> - makerec (constarg::assums, - id::cargs, - id::constargs, - recargs, - indargs) tl idtl - | (_, _) -> anomaly (Pp.str "make_elim_branch_assumptions") - in - makerec ([],[],[],[],[]) ba.branchsign - (try List.firstn ba.nassums (pf_hyps gl) - with Failure _ -> anomaly (Pp.str "make_elim_branch_assumptions")) + let assums = + try List.rev (List.firstn ba.nassums (pf_hyps gl)) + with Failure _ -> anomaly (Pp.str "make_elim_branch_assumptions") in + { ba = ba; assums = assums } let elim_on_ba tac ba gl = tac (make_elim_branch_assumptions ba gl) gl -let make_case_branch_assumptions ba gl = - let rec makerec (assums,cargs,constargs,recargs) p_0 p_1 = - match p_0,p_1 with - | ([], _) -> - { ba = ba; - assums = assums} - | ((true::tl), ((idrec,_,_ as recarg)::idtl)) -> - makerec (recarg::assums, - idrec::cargs, - idrec::recargs, - constargs) tl idtl - | ((false::tl), ((id,_,_ as constarg)::idtl)) -> - makerec (constarg::assums, - id::cargs, - recargs, - id::constargs) tl idtl - | (_, _) -> anomaly (Pp.str "make_case_branch_assumptions") - in - makerec ([],[],[],[]) ba.branchsign - (try List.firstn ba.nassums (pf_hyps gl) - with Failure _ -> anomaly (Pp.str "make_case_branch_assumptions")) +let make_case_branch_assumptions = make_elim_branch_assumptions let case_on_ba tac ba gl = tac (make_case_branch_assumptions ba gl) gl @@ -508,6 +521,14 @@ module New = struct in Proofview.Unsafe.tclEVARS sigma <*> tac >>= check_evars_if + let tclDELAYEDWITHHOLES check x tac = + Proofview.Goal.nf_enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let Sigma (x, sigma, _) = x.Tacexpr.delayed env sigma in + tclWITHHOLES check (tac x) (Sigma.to_evar_map sigma) + end } + let tclTIMEOUT n t = Proofview.tclOR (Proofview.tclTIMEOUT n t) @@ -532,8 +553,7 @@ module New = struct let nthHypId m gl = (** We only use [id] *) let gl = Proofview.Goal.assume gl in - let (id,_,_) = nthDecl m gl in - id + nthDecl m gl |> get_id let nthHyp m gl = mkVar (nthHypId m gl) @@ -565,7 +585,7 @@ module New = struct let afterHyp id tac = Proofview.Goal.nf_enter { enter = begin fun gl -> let hyps = Proofview.Goal.hyps gl in - let rem, _ = List.split_when (fun (hyp,_,_) -> Id.equal hyp id) hyps in + let rem, _ = List.split_when (Id.equal id % get_id) hyps in tac rem end } @@ -619,9 +639,9 @@ module New = struct 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 - let brnames = compute_induction_names (Array.length branchsigns) allnames in + let elimclause' = clenv_fchain ~with_univs:false indmv elimclause indclause in + let branchsigns = compute_constructor_signatures isrec ind in + let brnames = compute_induction_names_gen false branchsigns allnames in let flags = Unification.elim_flags () in let elimclause' = match predicate with @@ -633,10 +653,7 @@ module New = struct let (hd,largs) = decompose_app clenv'.templtyp.Evd.rebus in let ba = { branchsign = branchsigns.(i); branchnames = brnames.(i); - nassums = - List.fold_left - (fun acc b -> if b then acc+2 else acc+1) - 0 branchsigns.(i); + nassums = List.length branchsigns.(i); branchnum = i+1; ity = ind; largs = List.map (clenv_nf_meta clenv') largs; diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index 80e01a8d0..0f926468b 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -9,7 +9,6 @@ open Pp open Names open Term -open Context open Tacmach open Proof_type open Tacexpr @@ -60,29 +59,29 @@ val tclIFTHENTRYELSEMUST : tactic -> tactic -> tactic val onNthHypId : int -> (Id.t -> tactic) -> tactic val onNthHyp : int -> (constr -> tactic) -> tactic -val onNthDecl : int -> (named_declaration -> tactic) -> tactic +val onNthDecl : int -> (Context.Named.Declaration.t -> tactic) -> tactic val onLastHypId : (Id.t -> tactic) -> tactic val onLastHyp : (constr -> tactic) -> tactic -val onLastDecl : (named_declaration -> tactic) -> tactic +val onLastDecl : (Context.Named.Declaration.t -> tactic) -> tactic val onNLastHypsId : int -> (Id.t list -> tactic) -> tactic val onNLastHyps : int -> (constr list -> tactic) -> tactic -val onNLastDecls : int -> (named_context -> tactic) -> tactic +val onNLastDecls : int -> (Context.Named.t -> tactic) -> tactic val lastHypId : goal sigma -> Id.t val lastHyp : goal sigma -> constr -val lastDecl : goal sigma -> named_declaration +val lastDecl : goal sigma -> Context.Named.Declaration.t val nLastHypsId : int -> goal sigma -> Id.t list val nLastHyps : int -> goal sigma -> constr list -val nLastDecls : int -> goal sigma -> named_context +val nLastDecls : int -> goal sigma -> Context.Named.t -val afterHyp : Id.t -> goal sigma -> named_context +val afterHyp : Id.t -> goal sigma -> Context.Named.t val ifOnHyp : (Id.t * types -> bool) -> (Id.t -> tactic) -> (Id.t -> tactic) -> Id.t -> tactic -val onHyps : (goal sigma -> named_context) -> - (named_context -> tactic) -> tactic +val onHyps : (goal sigma -> Context.Named.t) -> + (Context.Named.t -> tactic) -> tactic (** {6 Tacticals applying to goal components } *) @@ -99,32 +98,36 @@ val onClauseLR : (Id.t option -> tactic) -> clause -> tactic (** {6 Elimination tacticals. } *) type branch_args = { - ity : pinductive; (** the type we were eliminating on *) + ity : pinductive; (** the type we were eliminating on *) largs : constr list; (** its arguments *) branchnum : int; (** the branch number *) pred : constr; (** the predicate we used *) - nassums : int; (** the number of assumptions to be introduced *) + nassums : int; (** number of assumptions/letin to be introduced *) branchsign : bool list; (** the signature of the branch. - true=recursive argument, false=constant *) + true=assumption, false=let-in *) branchnames : intro_patterns} type branch_assumptions = { - ba : branch_args; (** the branch args *) - assums : named_context} (** the list of assumptions introduced *) + ba : branch_args; (** the branch args *) + assums : Context.Named.t} (** the list of assumptions introduced *) -(** [check_disjunctive_pattern_size loc pats n] returns an appropriate - error message if |pats| <> n *) -val check_or_and_pattern_size : - Loc.t -> delayed_open_constr or_and_intro_pattern_expr -> int -> unit +(** [get_and_check_or_and_pattern loc pats branchsign] returns an appropriate + error message if |pats| <> |branchsign|; extends them if no pattern is given + for let-ins in the case of a conjunctive pattern *) +val get_and_check_or_and_pattern : + Loc.t -> delayed_open_constr or_and_intro_pattern_expr -> + bool list array -> intro_patterns array (** Tolerate "[]" to mean a disjunctive pattern of any length *) val fix_empty_or_and_pattern : int -> delayed_open_constr or_and_intro_pattern_expr -> delayed_open_constr or_and_intro_pattern_expr +val compute_constructor_signatures : rec_flag -> pinductive -> bool list array + (** Useful for [as intro_pattern] modifier *) val compute_induction_names : - int -> or_and_intro_pattern option -> intro_patterns array + bool list array -> or_and_intro_pattern option -> intro_patterns array val elimination_sort_of_goal : goal sigma -> sorts_family val elimination_sort_of_hyp : Id.t -> goal sigma -> sorts_family @@ -144,7 +147,7 @@ val case_on_ba : (branch_assumptions -> tactic) -> branch_args -> tactic semantics as the similarly named tacticals in [Proofview]. The tactical of [Proofview] are used in the definition of the tacticals of [Tacticals.New], but they are more atomic. In - particular [Tacticals.New.tclORELSE] sees like of progress as a + particular [Tacticals.New.tclORELSE] sees lack of progress as a failure, whereas [Proofview.tclORELSE] doesn't. Additionally every tactic which can catch failure ([tclOR], [tclORELSE], [tclTRY], [tclREPEAt], etc…) are run into each goal independently (failures @@ -219,11 +222,12 @@ module New : sig val tclSOLVE : unit tactic list -> unit tactic val tclPROGRESS : unit tactic -> unit tactic val tclWITHHOLES : bool -> 'a tactic -> Evd.evar_map -> 'a tactic + val tclDELAYEDWITHHOLES : bool -> 'a delayed_open -> ('a -> unit tactic) -> unit tactic val tclTIMEOUT : int -> unit tactic -> unit tactic val tclTIME : string option -> 'a tactic -> 'a tactic - val nLastDecls : ([ `NF ], 'r) Proofview.Goal.t -> int -> named_context + val nLastDecls : ([ `NF ], 'r) Proofview.Goal.t -> int -> Context.Named.t val ifOnHyp : (identifier * types -> bool) -> (identifier -> unit Proofview.tactic) -> (identifier -> unit Proofview.tactic) -> @@ -232,11 +236,11 @@ module New : sig val onNthHypId : int -> (identifier -> unit tactic) -> unit tactic val onLastHypId : (identifier -> unit tactic) -> unit tactic val onLastHyp : (constr -> unit tactic) -> unit tactic - val onLastDecl : (named_declaration -> unit tactic) -> unit tactic + val onLastDecl : (Context.Named.Declaration.t -> unit tactic) -> unit tactic - val onHyps : ([ `NF ], named_context) Proofview.Goal.enter -> - (named_context -> unit tactic) -> unit tactic - val afterHyp : Id.t -> (named_context -> unit tactic) -> unit tactic + val onHyps : ([ `NF ], Context.Named.t) Proofview.Goal.enter -> + (Context.Named.t -> unit tactic) -> unit tactic + val afterHyp : Id.t -> (Context.Named.t -> unit tactic) -> unit tactic val tryAllHyps : (identifier -> unit tactic) -> unit tactic val tryAllHypsAndConcl : (identifier option -> unit tactic) -> unit tactic diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 94e334914..7ae178af5 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -13,7 +13,6 @@ open Names open Nameops open Term open Vars -open Context open Termops open Find_subterm open Namegen @@ -45,15 +44,6 @@ open Misctypes open Proofview.Notations open Sigma.Notations -let nb_prod x = - let rec count n c = - match kind_of_term c with - Prod(_,_,t) -> count (n+1) t - | LetIn(_,a,_,t) -> count n (subst1 a t) - | Cast(c,_,_) -> count n c - | _ -> n - in count 0 x - let inj_with_occurrences e = (AllOccurrences,e) let dloc = Loc.ghost @@ -146,7 +136,7 @@ let _ = Kept as false for compatibility. *) -let bracketing_last_or_and_intro_pattern = ref false +let bracketing_last_or_and_intro_pattern = ref true let use_bracketing_last_or_and_intro_pattern () = !bracketing_last_or_and_intro_pattern @@ -171,19 +161,20 @@ let _ = (** This tactic creates a partial proof realizing the introduction rule, but does not check anything. *) -let unsafe_intro env store (id, c, t) b = - Proofview.Refine.refine ~unsafe:true { run = begin fun sigma -> - let sigma = Sigma.to_evar_map sigma in +let unsafe_intro env store decl b = + let open Context.Named.Declaration in + Refine.refine ~unsafe:true { run = begin fun sigma -> let ctx = named_context_val env in - let nctx = push_named_context_val (id, c, t) ctx in - let inst = List.map (fun (id, _, _) -> mkVar id) (named_context env) in + let nctx = push_named_context_val decl ctx in + let inst = List.map (mkVar % get_id) (named_context env) in let ninst = mkRel 1 :: inst in - let nb = subst1 (mkVar id) b in - let sigma, ev = new_evar_instance nctx sigma nb ~store ninst in - Sigma.Unsafe.of_pair (mkNamedLambda_or_LetIn (id, c, t) ev, sigma) + let nb = subst1 (mkVar (get_id decl)) b in + let Sigma (ev, sigma, p) = new_evar_instance nctx sigma nb ~principal:true ~store ninst in + Sigma (mkNamedLambda_or_LetIn decl ev, sigma, p) end } let introduction ?(check=true) id = + let open Context.Named.Declaration in Proofview.Goal.enter { enter = begin fun gl -> let gl = Proofview.Goal.assume gl in let concl = Proofview.Goal.concl gl in @@ -196,8 +187,8 @@ let introduction ?(check=true) id = (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 - | LetIn (_, c, t, b) -> unsafe_intro env store (id, Some c, t) b + | Prod (_, t, b) -> unsafe_intro env store (LocalAssum (id, t)) b + | LetIn (_, c, t, b) -> unsafe_intro env store (LocalDef (id, c, t)) b | _ -> raise (RefinerError IntroNeedsProduct) end } @@ -208,7 +199,7 @@ let convert_concl ?(check=true) ty k = let env = Proofview.Goal.env gl in let store = Proofview.Goal.extra gl in let conclty = Proofview.Goal.raw_concl gl in - Proofview.Refine.refine ~unsafe:true { run = begin fun sigma -> + Refine.refine ~unsafe:true { run = begin fun sigma -> let Sigma ((), sigma, p) = if check then begin let sigma = Sigma.to_evar_map sigma in @@ -231,7 +222,7 @@ let convert_hyp ?(check=true) d = let store = Proofview.Goal.extra gl in let sign = convert_hyp check (named_context_val env) sigma d in let env = reset_with_named_context sign env in - Proofview.Refine.refine ~unsafe:true { run = begin fun sigma -> + Refine.refine ~unsafe:true { run = begin fun sigma -> Evarutil.new_evar env sigma ~principal:true ~store ty end } end } @@ -242,8 +233,9 @@ let convert_hyp_no_check = convert_hyp ~check:false let convert_gen pb x y = Proofview.Goal.enter { 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") @@ -295,7 +287,8 @@ let apply_clear_request clear_flag dft c = error "keep/clear modifiers apply only to hypothesis names." in let clear = match clear_flag with | None -> dft && isVar c - | Some clear -> check_isvar c; clear in + | Some true -> check_isvar c; true + | Some false -> false in if clear then Proofview.V82.tactic (thin [destVar c]) else Tacticals.New.tclIDTAC @@ -304,6 +297,7 @@ let move_hyp id dest gl = Tacmach.move_hyp id dest gl (* Renaming hypotheses *) let rename_hyp repl = + let open Context.Named.Declaration in let fold accu (src, dst) = match accu with | None -> None | Some (srcs, dsts) -> @@ -325,7 +319,7 @@ let rename_hyp repl = let concl = Proofview.Goal.concl gl in let store = Proofview.Goal.extra gl in (** Check that we do not mess variables *) - let fold accu (id, _, _) = Id.Set.add id accu in + let fold accu decl = Id.Set.add (get_id decl) accu in let vars = List.fold_left fold Id.Set.empty hyps in let () = if not (Id.Set.subset src vars) then @@ -343,18 +337,16 @@ let rename_hyp repl = let make_subst (src, dst) = (src, mkVar dst) in let subst = List.map make_subst repl in let subst c = Vars.replace_vars subst c in - let map (id, body, t) = - let id = try List.assoc_f Id.equal id repl with Not_found -> id in - (id, Option.map subst body, subst t) + let map decl = + decl |> map_id (fun id -> try List.assoc_f Id.equal id repl with Not_found -> id) + |> map_constr subst in let nhyps = List.map map hyps in let nconcl = subst concl in let nctx = Environ.val_of_named_context nhyps in - let instance = List.map (fun (id, _, _) -> mkVar id) hyps in - Proofview.Refine.refine ~unsafe:true { run = begin fun sigma -> - let sigma = Sigma.to_evar_map sigma in - let (sigma, c) = Evarutil.new_evar_instance nctx sigma nconcl ~store instance in - Sigma.Unsafe.of_pair (c, sigma) + let instance = List.map (mkVar % get_id) hyps in + Refine.refine ~unsafe:true { run = begin fun sigma -> + Evarutil.new_evar_instance nctx sigma nconcl ~store instance end } end } @@ -378,11 +370,13 @@ let id_of_name_with_default id = function let default_id_of_sort s = if Sorts.is_small s then default_small_ident else default_type_ident -let default_id env sigma = function - | (name,None,t) -> +let default_id env sigma decl = + let open Context.Rel.Declaration in + match decl with + | LocalAssum (name,t) -> let dft = default_id_of_sort (Retyping.get_sort_of env sigma t) in id_of_name_with_default dft name - | (name,Some b,_) -> id_of_name_using_hdchar env b name + | LocalDef (name,b,_) -> id_of_name_using_hdchar env b name (* Non primitive introduction tactics are treated by intro_then_gen There is possibly renaming, with possibly names to avoid and @@ -417,8 +411,9 @@ let find_name mayrepl decl naming gl = match naming with (**************************************************************) let assert_before_then_gen b naming t tac = + let open Context.Rel.Declaration in Proofview.Goal.enter { enter = begin fun gl -> - let id = find_name b (Anonymous,None,t) naming gl in + let id = find_name b (LocalAssum (Anonymous,t)) naming gl in Tacticals.New.tclTHENLAST (Proofview.V82.tactic (fun gl -> @@ -435,8 +430,9 @@ let assert_before na = assert_before_gen false (naming_of_name na) let assert_before_replacing id = assert_before_gen true (NamingMustBe (dloc,id)) let assert_after_then_gen b naming t tac = + let open Context.Rel.Declaration in Proofview.Goal.enter { enter = begin fun gl -> - let id = find_name b (Anonymous,None,t) naming gl in + let id = find_name b (LocalAssum (Anonymous,t)) naming gl in Tacticals.New.tclTHENFIRST (Proofview.V82.tactic (fun gl -> @@ -480,17 +476,18 @@ let cofix ido gl = match ido with type tactic_reduction = env -> evar_map -> constr -> constr -let pf_reduce_decl redfun where (id,c,ty) gl = - let redfun' = Tacmach.pf_reduce redfun gl in - match c with - | None -> +let pf_reduce_decl redfun where decl gl = + let open Context.Named.Declaration in + let redfun' = Tacmach.New.pf_apply redfun gl in + match decl with + | LocalAssum (id,ty) -> if where == InHypValueOnly then errorlabstrm "" (pr_id id ++ str " has no value."); - (id,None,redfun' ty) - | Some b -> + LocalAssum (id,redfun' ty) + | LocalDef (id,b,ty) -> let b' = if where != InHypTypeOnly then redfun' b else b in let ty' = if where != InHypValueOnly then redfun' ty else ty in - (id,Some b',ty') + LocalDef (id,b',ty') (* Possibly equip a reduction with the occurrences mentioned in an occurrence clause *) @@ -560,12 +557,15 @@ let bind_red_expr_occurrences occs nbcl redexp = reduction function either to the conclusion or to a certain hypothesis *) -let reduct_in_concl (redfun,sty) gl = - Proofview.V82.of_tactic (convert_concl_no_check (Tacmach.pf_reduce redfun gl (Tacmach.pf_concl gl)) sty) gl +let reduct_in_concl (redfun,sty) = + Proofview.Goal.nf_enter { enter = begin fun gl -> + convert_concl_no_check (Tacmach.New.pf_apply redfun gl (Tacmach.New.pf_concl gl)) sty + end } -let reduct_in_hyp ?(check=false) redfun (id,where) gl = - Proofview.V82.of_tactic (convert_hyp ~check - (pf_reduce_decl redfun where (Tacmach.pf_get_hyp gl id) gl)) gl +let reduct_in_hyp ?(check=false) redfun (id,where) = + Proofview.Goal.nf_enter { enter = begin fun gl -> + convert_hyp ~check (pf_reduce_decl redfun where (Tacmach.New.pf_get_hyp id gl) gl) + end } let revert_cast (redfun,kind as r) = if kind == DEFAULTcast then (redfun,REVERTcast) else r @@ -576,31 +576,33 @@ let reduct_option ?(check=false) redfun = function (** Tactic reduction modulo evars (for universes essentially) *) -let pf_e_reduce_decl redfun where (id,c,ty) gl = - let sigma = project gl in - let redfun = redfun (pf_env gl) in - match c with - | None -> +let pf_e_reduce_decl redfun where decl gl = + let open Context.Named.Declaration in + let sigma = Proofview.Goal.sigma gl in + let redfun sigma c = redfun.e_redfun (Tacmach.New.pf_env gl) sigma c in + match decl with + | LocalAssum (id,ty) -> if where == InHypValueOnly then errorlabstrm "" (pr_id id ++ str " has no value."); - let sigma, ty' = redfun sigma ty in - sigma, (id,None,ty') - | Some b -> - let sigma, b' = if where != InHypTypeOnly then redfun sigma b else sigma, b in - let sigma, ty' = if where != InHypValueOnly then redfun sigma ty else sigma, ty in - sigma, (id,Some b',ty') - -let e_reduct_in_concl (redfun,sty) gl = - Proofview.V82.of_tactic - (let sigma, c' = (Tacmach.pf_apply redfun gl (Tacmach.pf_concl gl)) in - Proofview.Unsafe.tclEVARS sigma <*> - convert_concl_no_check c' sty) gl - -let e_reduct_in_hyp ?(check=false) redfun (id,where) gl = - Proofview.V82.of_tactic - (let sigma, decl' = pf_e_reduce_decl redfun where (Tacmach.pf_get_hyp gl id) gl in - Proofview.Unsafe.tclEVARS sigma <*> - convert_hyp ~check decl') gl + let Sigma (ty', sigma, p) = redfun sigma ty in + Sigma (LocalAssum (id, ty'), sigma, p) + | LocalDef (id,b,ty) -> + let Sigma (b', sigma, p) = if where != InHypTypeOnly then redfun sigma b else Sigma.here b sigma in + let Sigma (ty', sigma, q) = if where != InHypValueOnly then redfun sigma ty else Sigma.here ty sigma in + Sigma (LocalDef (id, b', ty'), sigma, p +> q) + +let e_reduct_in_concl (redfun, sty) = + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let Sigma (c', sigma, p) = redfun.e_redfun (Tacmach.New.pf_env gl) sigma (Tacmach.New.pf_concl gl) in + Sigma (convert_concl_no_check c' sty, sigma, p) + end } + +let e_reduct_in_hyp ?(check=false) redfun (id, where) = + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let Sigma (decl', sigma, p) = pf_e_reduce_decl redfun where (Tacmach.New.pf_get_hyp id gl) gl in + Sigma (convert_hyp ~check decl', sigma, p) + end } let e_reduct_option ?(check=false) redfun = function | Some id -> e_reduct_in_hyp ~check (fst redfun) id @@ -610,84 +612,91 @@ let e_reduct_option ?(check=false) redfun = function from conversions. *) let e_change_in_concl (redfun,sty) = - Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> - let sigma = Sigma.to_evar_map sigma in - let (sigma, c) = redfun (Proofview.Goal.env gl) sigma (Proofview.Goal.raw_concl gl) in - Sigma.Unsafe.of_pair (convert_concl_no_check c sty, sigma) + Proofview.Goal.s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let Sigma (c, sigma, p) = redfun.e_redfun (Proofview.Goal.env gl) sigma (Proofview.Goal.raw_concl gl) in + Sigma (convert_concl_no_check c sty, sigma, p) end } -let e_pf_change_decl (redfun : bool -> e_reduction_function) where (id,c,ty) env sigma = - match c with - | None -> +let e_pf_change_decl (redfun : bool -> e_reduction_function) where decl env sigma = + let open Context.Named.Declaration in + match decl with + | LocalAssum (id,ty) -> if where == InHypValueOnly then errorlabstrm "" (pr_id id ++ str " has no value."); - let sigma',ty' = redfun false env sigma ty in - sigma', (id,None,ty') - | Some b -> - let sigma',b' = - if where != InHypTypeOnly then redfun true env sigma b else sigma, b + let Sigma (ty', sigma, p) = (redfun false).e_redfun env sigma ty in + Sigma (LocalAssum (id, ty'), sigma, p) + | LocalDef (id,b,ty) -> + let Sigma (b', sigma, p) = + if where != InHypTypeOnly then (redfun true).e_redfun env sigma b else Sigma.here b sigma in - let sigma',ty' = - if where != InHypValueOnly then redfun false env sigma' ty else sigma', ty + let Sigma (ty', sigma, q) = + if where != InHypValueOnly then (redfun false).e_redfun env sigma ty else Sigma.here ty sigma in - sigma', (id,Some b',ty') + Sigma (LocalDef (id,b',ty'), sigma, p +> q) let e_change_in_hyp redfun (id,where) = - Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> - let sigma = Sigma.to_evar_map sigma in + Proofview.Goal.s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in let hyp = Tacmach.New.pf_get_hyp id (Proofview.Goal.assume gl) in - let sigma, c = e_pf_change_decl redfun where hyp (Proofview.Goal.env gl) sigma in - Sigma.Unsafe.of_pair (convert_hyp c, sigma) + let Sigma (c, sigma, p) = e_pf_change_decl redfun where hyp (Proofview.Goal.env gl) sigma in + Sigma (convert_hyp c, sigma, p) end } -type change_arg = Pattern.patvar_map -> evar_map -> evar_map * constr +type change_arg = Pattern.patvar_map -> constr Sigma.run -let make_change_arg c = - fun pats sigma -> (sigma, replace_vars (Id.Map.bindings pats) c) +let make_change_arg c pats = + { run = fun sigma -> Sigma.here (replace_vars (Id.Map.bindings pats) c) sigma } let check_types env sigma mayneedglobalcheck deep newc origc = let t1 = Retyping.get_type_of env sigma newc in if deep then begin let t2 = Retyping.get_type_of env sigma origc in - let sigma, t2 = Evarsolve.refresh_universes ~onlyalg:true (Some false) env sigma t2 in - if not (snd (infer_conv ~pb:Reduction.CUMUL env sigma t1 t2)) then + let sigma, t2 = Evarsolve.refresh_universes + ~onlyalg:true (Some false) env sigma t2 in + let sigma, b = infer_conv ~pb:Reduction.CUMUL env sigma t1 t2 in + if not b then if isSort (whd_betadeltaiota env sigma t1) && isSort (whd_betadeltaiota env sigma t2) - then - mayneedglobalcheck := true + then (mayneedglobalcheck := true; sigma) else errorlabstrm "convert-check-hyp" (str "Types are incompatible.") + else sigma end else if not (isSort (whd_betadeltaiota env sigma t1)) then errorlabstrm "convert-check-hyp" (str "Not a type.") + else sigma (* Now we introduce different instances of the previous tacticals *) -let change_and_check cv_pb mayneedglobalcheck deep t env sigma c = - let sigma, t' = t sigma in - check_types env sigma mayneedglobalcheck deep t' c; +let change_and_check cv_pb mayneedglobalcheck deep t = { e_redfun = begin fun env sigma c -> + let Sigma (t', sigma, p) = t.run sigma in + let sigma = Sigma.to_evar_map sigma in + let sigma = check_types env sigma mayneedglobalcheck deep t' c in let sigma, b = infer_conv ~pb:cv_pb env sigma t' c in if not b then errorlabstrm "convert-check-hyp" (str "Not convertible."); - sigma, t' + Sigma.Unsafe.of_pair (t', sigma) +end } (* Use cumulativity only if changing the conclusion not a subterm *) -let change_on_subterm cv_pb deep t where env sigma c = +let change_on_subterm cv_pb deep t where = { e_redfun = begin fun env sigma c -> let mayneedglobalcheck = ref false in - let sigma,c = match where with - | None -> change_and_check cv_pb mayneedglobalcheck deep (t Id.Map.empty) env sigma c + let Sigma (c, sigma, p) = match where with + | None -> (change_and_check cv_pb mayneedglobalcheck deep (t Id.Map.empty)).e_redfun env sigma c | Some occl -> - e_contextually false occl + (e_contextually false occl (fun subst -> - change_and_check Reduction.CONV mayneedglobalcheck true (t subst)) + change_and_check Reduction.CONV mayneedglobalcheck true (t subst))).e_redfun env sigma c in if !mayneedglobalcheck then begin - try ignore (Typing.unsafe_type_of env sigma c) + try ignore (Typing.unsafe_type_of env (Sigma.to_evar_map sigma) c) with e when catchable_exception e -> error "Replacement would lead to an ill-typed term." end; - sigma,c + Sigma (c, sigma, p) +end } let change_in_concl occl t = e_change_in_concl ((change_on_subterm Reduction.CUMUL false t occl),DEFAULTcast) @@ -740,14 +749,16 @@ let reduction_clause redexp cl = | OnConcl occs -> (None, bind_red_expr_occurrences occs nbcl redexp)) cl -let reduce redexp cl goal = - let cl = concrete_clause_of (fun () -> Tacmach.pf_ids_of_hyps goal) cl in +let reduce redexp cl = + Proofview.Goal.enter { enter = begin fun gl -> + let cl = concrete_clause_of (fun () -> Tacmach.New.pf_ids_of_hyps gl) 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) -> + let tac = Tacticals.New.tclMAP (fun (where,redexp) -> e_reduct_option ~check - (Redexpr.reduction_of_red_expr (Tacmach.pf_env goal) redexp) where) redexps in - if check then with_check tac goal else tac goal + (Redexpr.reduction_of_red_expr (Tacmach.New.pf_env gl) redexp) where) redexps in + if check then Proofview.V82.tactic (fun gl -> with_check (Proofview.V82.of_tactic tac) gl) else tac (** FIXME *) + end } (* Unfolding occurrences of a constant *) @@ -768,10 +779,9 @@ let unfold_constr = function let find_intro_names ctxt gl = let _, res = List.fold_right (fun decl acc -> - let wantedname,x,typdecl = decl in let env,idl = acc in let name = fresh_id idl (default_id env gl.sigma decl) gl in - let newenv = push_rel (wantedname,x,typdecl) env in + let newenv = push_rel decl env in (newenv,(name::idl))) ctxt (pf_env gl , []) in List.rev res @@ -783,15 +793,16 @@ let build_intro_tac id dest tac = match dest with Proofview.V82.tactic (move_hyp id dest); tac id] let rec intro_then_gen name_flag move_flag force_flag dep_flag tac = + let open Context.Rel.Declaration in Proofview.Goal.enter { enter = begin fun gl -> let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in let concl = nf_evar (Tacmach.New.project gl) concl in match kind_of_term concl with | Prod (name,t,u) when not dep_flag || (dependent (mkRel 1) u) -> - let name = find_name false (name,None,t) name_flag gl in + let name = find_name false (LocalAssum (name,t)) name_flag gl in build_intro_tac name move_flag tac | LetIn (name,b,t,u) when not dep_flag || (dependent (mkRel 1) u) -> - let name = find_name false (name,Some b,t) name_flag gl in + let name = find_name false (LocalDef (name,b,t)) name_flag gl in build_intro_tac name move_flag tac | _ -> begin if not force_flag then Proofview.tclZERO (RefinerError IntroNeedsProduct) @@ -802,7 +813,7 @@ let rec intro_then_gen name_flag move_flag force_flag dep_flag tac = else Proofview.tclUNIT () end <*> Proofview.tclORELSE - (Tacticals.New.tclTHEN (Proofview.V82.tactic hnf_in_concl) + (Tacticals.New.tclTHEN hnf_in_concl (intro_then_gen name_flag move_flag false dep_flag tac)) begin function (e, info) -> match e with | RefinerError IntroNeedsProduct -> @@ -854,21 +865,24 @@ let intro_forthcoming_then_gen name_flag move_flag dep_flag n bound tac = aux n [] let get_next_hyp_position id gl = + let open Context.Named.Declaration in let rec aux = function | [] -> raise (RefinerError (NoSuchHyp id)) - | (hyp,_,_) :: right -> - if Id.equal hyp id then - match right with (id,_,_)::_ -> MoveBefore id | [] -> MoveLast + | decl :: right -> + if Id.equal (get_id decl) id then + match right with decl::_ -> MoveBefore (get_id decl) | [] -> MoveLast else aux right in aux (Proofview.Goal.hyps (Proofview.Goal.assume gl)) let get_previous_hyp_position id gl = + let open Context.Named.Declaration in let rec aux dest = function | [] -> raise (RefinerError (NoSuchHyp id)) - | (hyp,_,_) :: right -> - if Id.equal hyp id then dest else aux (MoveAfter hyp) right + | decl :: right -> + let hyp = get_id decl in + if Id.equal hyp id then dest else aux (MoveAfter hyp) right in aux MoveLast (Proofview.Goal.hyps (Proofview.Goal.assume gl)) @@ -914,25 +928,25 @@ let intros_replacing ids = (* User-level introduction tactics *) -let pf_lookup_hypothesis_as_renamed env ccl = function +let lookup_hypothesis_as_renamed env ccl = function | AnonHyp n -> Detyping.lookup_index_as_renamed env ccl n | NamedHyp id -> Detyping.lookup_name_as_displayed env ccl id -let pf_lookup_hypothesis_as_renamed_gen red h gl = - let env = pf_env gl in +let lookup_hypothesis_as_renamed_gen red h gl = + let env = Proofview.Goal.env gl in let rec aux ccl = - match pf_lookup_hypothesis_as_renamed env ccl h with + match lookup_hypothesis_as_renamed env ccl h with | None when red -> - aux - (snd ((fst (Redexpr.reduction_of_red_expr env (Red true))) - env (project gl) ccl)) + let (redfun, _) = Redexpr.reduction_of_red_expr env (Red true) in + let Sigma (c, _, _) = redfun.e_redfun env (Proofview.Goal.sigma gl) ccl in + aux c | x -> x in - try aux (Tacmach.pf_concl gl) + try aux (Proofview.Goal.concl gl) with Redelimination -> None -let is_quantified_hypothesis id g = - match pf_lookup_hypothesis_as_renamed_gen false (NamedHyp id) g with +let is_quantified_hypothesis id gl = + match lookup_hypothesis_as_renamed_gen false (NamedHyp id) gl with | Some _ -> true | None -> false @@ -944,7 +958,7 @@ let msg_quantified_hypothesis = function str " non dependent hypothesis" let depth_of_quantified_hypothesis red h gl = - match pf_lookup_hypothesis_as_renamed_gen red h gl with + match lookup_hypothesis_as_renamed_gen red h gl with | Some depth -> depth | None -> errorlabstrm "lookup_quantified_hypothesis" @@ -955,7 +969,7 @@ let depth_of_quantified_hypothesis red h gl = let intros_until_gen red h = Proofview.Goal.nf_enter { enter = begin fun gl -> - let n = Tacmach.New.of_old (depth_of_quantified_hypothesis red h) gl in + let n = depth_of_quantified_hypothesis red h gl in Tacticals.New.tclDO n (if red then introf else intro) end } @@ -1035,6 +1049,8 @@ let map_induction_arg f = function (* tactic "cut" (actually modus ponens) *) (****************************************) +let normalize_cut = false + let cut c = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in @@ -1053,12 +1069,12 @@ let cut c = if is_sort then let id = next_name_away_with_default "H" Anonymous (Tacmach.New.pf_ids_of_hyps gl) in (** Backward compat: normalize [c]. *) - let c = local_strong whd_betaiota sigma c in - Proofview.Refine.refine ~unsafe:true { run = begin fun h -> + let c = if normalize_cut then local_strong whd_betaiota sigma c else c in + Refine.refine ~unsafe:true { run = begin fun h -> let Sigma (f, h, p) = Evarutil.new_evar ~principal:true env h (mkArrow c (Vars.lift 1 concl)) in let Sigma (x, h, q) = Evarutil.new_evar env h c in - let f = mkLambda (Name id, c, mkApp (Vars.lift 1 f, [|mkRel 1|])) in - Sigma (mkApp (f, [|x|]), h, p +> q) + let f = mkLetIn (Name id, x, c, mkApp (Vars.lift 1 f, [|mkRel 1|])) in + Sigma (f, h, p +> q) end } else Tacticals.New.tclZEROMSG (str "Not a proposition or a type.") @@ -1145,6 +1161,7 @@ let index_of_ind_arg t = in aux None 0 t let enforce_prop_bound_names rename tac = + let open Context.Rel.Declaration in match rename with | Some (isrec,nn) when Namegen.use_h_based_elimination_names () -> (* Rename dependent arguments in Prop with name "H" *) @@ -1164,11 +1181,11 @@ let enforce_prop_bound_names rename tac = Name (add_suffix Namegen.default_prop_ident s) else na in - mkProd (na,t,aux (push_rel (na,None,t) env) sigma (i-1) t') + mkProd (na,t,aux (push_rel (LocalAssum (na,t)) env) sigma (i-1) t') | Prod (Anonymous,t,t') -> - mkProd (Anonymous,t,aux (push_rel (Anonymous,None,t) env) sigma (i-1) t') + mkProd (Anonymous,t,aux (push_rel (LocalAssum (Anonymous,t)) env) sigma (i-1) t') | LetIn (na,c,t,t') -> - mkLetIn (na,c,t,aux (push_rel (na,Some c,t) env) sigma (i-1) t') + mkLetIn (na,c,t,aux (push_rel (LocalDef (na,c,t)) env) sigma (i-1) t') | _ -> print_int i; Pp.msg (print_constr t); assert false in let rename_branch i = Proofview.Goal.nf_enter { enter = begin fun gl -> @@ -1247,14 +1264,14 @@ let general_elim with_evars clear_flag (c, lbindc) elim = (* Case analysis tactics *) let general_case_analysis_in_context with_evars clear_flag (c,lbindc) = - Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in - let sigma = Sigma.to_evar_map sigma in let concl = Proofview.Goal.concl gl in - let t = Retyping.get_type_of env sigma c in - let (mind,_) = reduce_to_quantified_ind env sigma t in + let t = Retyping.get_type_of env (Sigma.to_evar_map sigma) c in + let (mind,_) = reduce_to_quantified_ind env (Sigma.to_evar_map sigma) t in let sort = Tacticals.New.elimination_sort_of_goal gl in - let sigma, elim = + let Sigma (elim, sigma, p) = if occur_term c concl then build_case_analysis_scheme env sigma mind true sort else @@ -1264,7 +1281,7 @@ let general_case_analysis_in_context with_evars clear_flag (c,lbindc) = {elimindex = None; elimbody = (elim,NoBindings); elimrename = Some (false, constructors_nrealdecls (fst mind))}) in - Sigma.Unsafe.of_pair (tac, sigma) + Sigma (tac, sigma, p) end } let general_case_analysis with_evars clear_flag (c,lbindc as cx) = @@ -1298,7 +1315,7 @@ let find_eliminator c gl = let default_elim with_evars clear_flag (c,_ as cx) = Proofview.tclORELSE - (Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> + (Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma, elim = find_eliminator c gl in let tac = (general_elim with_evars clear_flag cx elim) @@ -1342,7 +1359,9 @@ let simplest_elim c = default_elim false None (c,NoBindings) *) let clenv_fchain_in id ?(flags=elim_flags ()) mv elimclause hypclause = - try clenv_fchain ~flags mv elimclause hypclause + (** The evarmap of elimclause is assumed to be an extension of hypclause, so + we do not need to merge the universes coming from hypclause. *) + try clenv_fchain ~with_univs:false ~flags mv elimclause hypclause with PretypeError (env,evd,NoOccurrenceFound (op,_)) -> (* Set the hypothesis name in the message *) raise (PretypeError (env,evd,NoOccurrenceFound (op,Some id))) @@ -1388,11 +1407,13 @@ type conjunction_status = | NotADefinedRecordUseScheme of constr let make_projection env sigma params cstr sign elim i n c u = + let open Context.Rel.Declaration in let elim = match elim with | NotADefinedRecordUseScheme elim -> (* bugs: goes from right to left when i increases! *) - let (na,b,t) = List.nth cstr.cs_args i in - let b = match b with None -> mkRel (i+1) | Some b -> b in + let decl = List.nth cstr.cs_args i in + let t = get_type decl in + let b = match decl with LocalAssum _ -> mkRel (i+1) | LocalDef (_,b,_) -> b in let branch = it_mkLambda_or_LetIn b cstr.cs_args in if (* excludes dependent projection types *) @@ -1404,7 +1425,7 @@ let make_projection env sigma params cstr sign elim i n c u = then let t = lift (i+1-n) t in let abselim = beta_applist (elim,params@[t;branch]) in - let c = beta_applist (abselim, [mkApp (c, extended_rel_vect 0 sign)]) in + let c = beta_applist (abselim, [mkApp (c, Context.Rel.to_extended_vect 0 sign)]) in Some (it_mkLambda_or_LetIn c sign, it_mkProd_or_LetIn t sign) else None @@ -1412,7 +1433,7 @@ let make_projection env sigma params cstr sign elim i n c u = (* goes from left to right when i increases! *) match List.nth l i with | Some proj -> - let args = extended_rel_vect 0 sign in + let args = Context.Rel.to_extended_vect 0 sign in let proj = if Environ.is_projection proj env then mkProj (Projection.make proj false, mkApp (c, args)) @@ -1444,8 +1465,9 @@ let descend_in_conjunctions avoid tac (err, info) c = let elim = try DefinedRecord (Recordops.lookup_projections ind) with Not_found -> - let elim = build_case_analysis_scheme env sigma (ind,u) false sort in - NotADefinedRecordUseScheme (snd elim) in + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma (elim, _, _) = build_case_analysis_scheme env sigma (ind,u) false sort in + NotADefinedRecordUseScheme elim in Tacticals.New.tclFIRST (List.init n (fun i -> Proofview.Goal.enter { enter = begin fun gl -> @@ -1469,7 +1491,8 @@ let descend_in_conjunctions avoid tac (err, info) c = (****************************************************) let solve_remaining_apply_goals = - Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in if !apply_solve_class_goals then try let env = Proofview.Goal.env gl in @@ -1502,7 +1525,7 @@ let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind)) (* The actual type of the theorem. It will be matched against the goal. If this fails, then the head constant will be unfolded step by step. *) - let concl_nprod = nb_prod concl in + let concl_nprod = nb_prod_modulo_zeta concl in let rec try_main_apply with_destruct c = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in @@ -1511,7 +1534,7 @@ let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind)) let thm_ty0 = nf_betaiota sigma (Retyping.get_type_of env sigma c) in let try_apply thm_ty nprod = try - let n = nb_prod thm_ty - nprod in + let n = nb_prod_modulo_zeta thm_ty - nprod in if n<0 then error "Applied theorem has not enough premisses."; let clause = make_clenv_binding_apply env sigma (Some n) (c,thm_ty) lbind in Clenvtac.res_pf clause ~with_evars ~flags @@ -1627,7 +1650,7 @@ let progress_with_clause flags innerclause clause = let ordered_metas = List.rev (clenv_independent clause) in if List.is_empty ordered_metas then error "Statement without assumptions."; let f mv = - try Some (find_matching_clause (clenv_fchain mv ~flags clause) innerclause) + try Some (find_matching_clause (clenv_fchain ~with_univs:false mv ~flags clause) innerclause) with Failure _ -> None in try List.find_map f ordered_metas @@ -1646,6 +1669,7 @@ let apply_in_once_main flags innerclause env sigma (d,lbind) = let apply_in_once sidecond_first with_delta with_destruct with_evars naming id (clear_flag,(loc,(d,lbind))) tac = + let open Context.Rel.Declaration in Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in @@ -1653,7 +1677,7 @@ let apply_in_once sidecond_first with_delta with_destruct with_evars naming if with_delta then default_unify_flags () else default_no_delta_unify_flags () in let t' = Tacmach.New.pf_get_hyp_typ id gl in let innerclause = mk_clenv_from_env env sigma (Some 0) (mkVar id,t') in - let targetid = find_name true (Anonymous,None,t') naming gl in + let targetid = find_name true (LocalAssum (Anonymous,t')) naming gl in let rec aux idstoclear with_destruct c = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in @@ -1712,7 +1736,7 @@ let cut_and_apply c = | Prod (_,c1,c2) when not (dependent (mkRel 1) c2) -> let concl = Proofview.Goal.concl gl in let env = Tacmach.New.pf_env gl in - Proofview.Refine.refine { run = begin fun sigma -> + Refine.refine { run = begin fun sigma -> let typ = mkProd (Anonymous, c2, concl) in let Sigma (f, sigma, p) = Evarutil.new_evar env sigma typ in let Sigma (x, sigma, q) = Evarutil.new_evar env sigma c1 in @@ -1733,10 +1757,11 @@ let cut_and_apply c = (* let refine_no_check = Profile.profile2 refine_no_checkkey refine_no_check *) let new_exact_no_check c = - Proofview.Refine.refine ~unsafe:true { run = fun h -> Sigma.here c h } + Refine.refine ~unsafe:true { run = fun h -> Sigma.here c h } let exact_check c = - Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in (** We do not need to normalize the goal because we just check convertibility *) let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in let env = Proofview.Goal.env gl in @@ -1754,19 +1779,25 @@ let vm_cast_no_check c gl = let concl = Tacmach.pf_concl gl in Tacmach.refine_no_check (Term.mkCast(c,Term.VMcast,concl)) gl +let native_cast_no_check c gl = + let concl = Tacmach.pf_concl gl in + Tacmach.refine_no_check (Term.mkCast(c,Term.NATIVEcast,concl)) gl + let exact_proof c gl = let c,ctx = Constrintern.interp_casted_constr (Tacmach.pf_env gl) (Tacmach.project gl) c (Tacmach.pf_concl gl) in tclTHEN (tclEVARUNIVCONTEXT ctx) (Tacmach.refine_no_check c) gl let assumption = + let open Context.Named.Declaration in let rec arec gl only_eq = function | [] -> if only_eq then let hyps = Proofview.Goal.hyps gl in arec gl false hyps else Tacticals.New.tclZEROMSG (str "No such assumption.") - | (id, c, t)::rest -> + | decl::rest -> + let t = get_type decl in let concl = Proofview.Goal.concl gl in let sigma = Tacmach.New.project gl in let (sigma, is_same_type) = @@ -1777,7 +1808,7 @@ let assumption = in if is_same_type then (Proofview.Unsafe.tclEVARS sigma) <*> - Proofview.Refine.refine ~unsafe:true { run = fun h -> Sigma.here (mkVar id) h } + Refine.refine ~unsafe:true { run = fun h -> Sigma.here (mkVar (get_id decl)) h } else arec gl only_eq rest in let assumption_tac = { enter = begin fun gl -> @@ -1807,45 +1838,48 @@ let check_is_type env ty msg = Proofview.tclEVARMAP >>= fun sigma -> let evdref = ref sigma in try - let _ = Typing.sort_of env evdref ty in + let _ = Typing.e_sort_of env evdref ty in Proofview.Unsafe.tclEVARS !evdref with e when Errors.noncritical e -> msg e -let check_decl env (_, c, ty) msg = +let check_decl env decl msg = + let open Context.Named.Declaration in + let ty = get_type decl in Proofview.tclEVARMAP >>= fun sigma -> let evdref = ref sigma in try - let _ = Typing.sort_of env evdref ty in - let _ = match c with - | None -> () - | Some c -> Typing.check env evdref c ty + let _ = Typing.e_sort_of env evdref ty in + let _ = match decl with + | LocalAssum _ -> () + | LocalDef (_,c,_) -> Typing.e_check env evdref c ty in Proofview.Unsafe.tclEVARS !evdref with e when Errors.noncritical e -> msg e let clear_body ids = + let open Context.Named.Declaration in Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in let ctx = named_context env in - let map (id, body, t as decl) = match body with - | None -> + let map = function + | LocalAssum (id,t) as decl -> let () = if List.mem_f Id.equal id ids then errorlabstrm "" (str "Hypothesis " ++ pr_id id ++ str " is not a local definition") in decl - | Some _ -> - if List.mem_f Id.equal id ids then (id, None, t) else decl + | LocalDef (id,_,t) as decl -> + if List.mem_f Id.equal id ids then LocalAssum (id, t) else decl in let ctx = List.map map ctx in let base_env = reset_context env in let env = push_named_context ctx base_env in let check_hyps = - let check env (id, _, _ as decl) = + let check env decl = let msg _ = Tacticals.New.tclZEROMSG - (str "Hypothesis " ++ pr_id id ++ on_the_bodies ids) + (str "Hypothesis " ++ pr_id (get_id decl) ++ on_the_bodies ids) in check_decl env decl msg <*> Proofview.tclUNIT (push_named decl env) in @@ -1859,8 +1893,8 @@ let clear_body ids = check_is_type env concl msg in check_hyps <*> check_concl <*> - Proofview.Refine.refine ~unsafe:true { run = begin fun sigma -> - Evarutil.new_evar env sigma concl + Refine.refine ~unsafe:true { run = begin fun sigma -> + Evarutil.new_evar env sigma ~principal:true concl end } end } @@ -1884,49 +1918,16 @@ let rec intros_clearing = function Tacticals.New.tclTHENLIST [ intro; Tacticals.New.onLastHypId (fun id -> Proofview.V82.tactic (clear [id])); intros_clearing tl] -(* Modifying/Adding an hypothesis *) - -let specialize (c,lbind) g = - let tac, term = - if lbind == NoBindings then - let evd = Typeclasses.resolve_typeclasses (pf_env g) (project g) in - tclEVARS evd, nf_evar evd c - else - let clause = Tacmach.pf_apply make_clenv_binding g (c,Tacmach.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 - let rec chk = function - | [] -> [] - | t::l -> if occur_meta t then [] else t :: chk l - in - let tstack = chk tstack in - let term = applist(thd,List.map (nf_evar clause.evd) tstack) in - if occur_meta term then - errorlabstrm "" (str "Cannot infer an instance for " ++ - pr_name (meta_name clause.evd (List.hd (collect_metas term))) ++ - str "."); - tclEVARS clause.evd, term - in - match kind_of_term (fst(decompose_app (snd(decompose_lam_assum c)))) with - | Var id when Id.List.mem id (Tacmach.pf_ids_of_hyps g) -> - tclTHEN tac - (tclTHENFIRST - (fun g -> Proofview.V82.of_tactic (assert_before_replacing id (Tacmach.pf_unsafe_type_of g term)) g) - (exact_no_check term)) g - | _ -> tclTHEN tac - (tclTHENLAST - (fun g -> Proofview.V82.of_tactic (cut (Tacmach.pf_unsafe_type_of g term)) g) - (exact_no_check term)) g - (* Keeping only a few hypotheses *) let keep hyps = + let open Context.Named.Declaration in Proofview.Goal.nf_enter { enter = begin fun gl -> Proofview.tclENV >>= fun env -> let ccl = Proofview.Goal.concl gl in let cl,_ = - fold_named_context_reverse (fun (clear,keep) (hyp,_,_ as decl) -> + fold_named_context_reverse (fun (clear,keep) decl -> + let hyp = get_id decl in if Id.List.mem hyp hyps || List.exists (occur_var_in_decl env hyp) keep || occur_var env hyp ccl @@ -1937,6 +1938,53 @@ let keep hyps = Proofview.V82.tactic (fun gl -> thin cl gl) end } +(*********************************) +(* Basic generalization tactics *) +(*********************************) + +(* Given a type [T] convertible to [forall x1..xn:A1..An(x1..xn-1), G(x1..xn)] + and [a1..an:A1..An(a1..an-1)] such that the goal is [G(a1..an)], + this generalizes [hyps |- goal] into [hyps |- T] *) + +let apply_type newcl args = + Proofview.Goal.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let store = Proofview.Goal.extra gl in + Refine.refine { run = begin fun sigma -> + let newcl = nf_betaiota (Sigma.to_evar_map sigma) newcl (* As in former Logic.refine *) in + let Sigma (ev, sigma, p) = + Evarutil.new_evar env sigma ~principal:true ~store newcl in + Sigma (applist (ev, args), sigma, p) + end } + end } + +(* Given a context [hyps] with domain [x1..xn], possibly with let-ins, + and well-typed in the current goal, [bring_hyps hyps] generalizes + [ctxt |- G(x1..xn] into [ctxt |- forall hyps, G(x1..xn)] *) + +let bring_hyps hyps = + if List.is_empty hyps then Tacticals.New.tclIDTAC + else + Proofview.Goal.enter { 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 (Context.Named.to_instance hyps) in + Refine.refine { run = begin fun sigma -> + let Sigma (ev, sigma, p) = + Evarutil.new_evar env sigma ~principal:true ~store newcl in + Sigma (mkApp (ev, args), sigma, p) + end } + end } + +let revert hyps = + Proofview.Goal.enter { enter = begin fun gl -> + let gl = Proofview.Goal.assume gl in + let ctx = List.map (fun id -> Tacmach.New.pf_get_hyp id gl) hyps in + (bring_hyps ctx) <*> (Proofview.V82.tactic (clear hyps)) + end } + (************************) (* Introduction tactics *) (************************) @@ -1952,7 +2000,8 @@ let check_number_of_constructors expctdnumopt i nconstr = if i > nconstr then error "Not enough constructors." let constructor_tac with_evars expctdnumopt i lbind = - Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in let cl = Tacmach.New.pf_nf_concl gl in let reduce_to_quantified_ind = Tacmach.New.pf_apply Tacred.reduce_to_quantified_ind gl @@ -2069,47 +2118,59 @@ let intro_or_and_pattern loc bracketed ll thin tac id = Proofview.Goal.enter { enter = begin fun gl -> let c = mkVar id 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 - check_or_and_pattern_size loc ll (Array.length nv); + let (ind,t) = Tacmach.New.pf_reduce_to_quantified_ind gl t in + let branchsigns = compute_constructor_signatures false ind in + let nv_with_let = Array.map List.length branchsigns in + let ll = fix_empty_or_and_pattern (Array.length branchsigns) ll in + let ll = get_and_check_or_and_pattern loc ll branchsigns in Tacticals.New.tclTHENLASTn (Tacticals.New.tclTHEN (simplest_case c) (Proofview.V82.tactic (clear [id]))) (Array.map2 (fun n l -> tac thin (Some (bracketed,n)) l) - nv (Array.of_list ll)) + nv_with_let ll) end } -let rewrite_hyp assert_style l2r id = +let rewrite_hyp_then assert_style thin l2r id tac = let rew_on l2r = Hook.get forward_general_rewrite_clause l2r false (mkVar id,NoBindings) in let subst_on l2r x rhs = Hook.get forward_subst_one true x (id,rhs,l2r) in - let clear_var_and_eq c = tclTHEN (clear [id]) (clear [destVar c]) in + let clear_var_and_eq id' = clear [id';id] in + let early_clear id' thin = + List.filter (fun (_,id) -> not (Id.equal id id')) thin in Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env 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 + let eqtac, thin = match match_with_equality_type t with | Some (hdcncl,[_;lhs;rhs]) -> if l2r && isVar lhs && not (occur_var env (destVar lhs) rhs) then - subst_on l2r (destVar lhs) rhs + let id' = destVar lhs in + subst_on l2r id' rhs, early_clear id' thin else if not l2r && isVar rhs && not (occur_var env (destVar rhs) lhs) then - subst_on l2r (destVar rhs) lhs + let id' = destVar rhs in + subst_on l2r id' lhs, early_clear id' thin else - Tacticals.New.tclTHEN (rew_on l2r onConcl) (Proofview.V82.tactic (clear [id])) + Tacticals.New.tclTHEN (rew_on l2r onConcl) (Proofview.V82.tactic (clear [id])), + thin | Some (hdcncl,[c]) -> let l2r = not l2r in (* equality of the form eq_true *) if isVar c then + let id' = destVar c in Tacticals.New.tclTHEN (rew_on l2r allHypsAndConcl) - (Proofview.V82.tactic (clear_var_and_eq c)) + (Proofview.V82.tactic (clear_var_and_eq id')), + early_clear id' thin else - Tacticals.New.tclTHEN (rew_on l2r onConcl) (Proofview.V82.tactic (clear [id])) + Tacticals.New.tclTHEN (rew_on l2r onConcl) (Proofview.V82.tactic (clear [id])), + thin | _ -> - Tacticals.New.tclTHEN (rew_on l2r onConcl) (Proofview.V82.tactic (clear [id])) + Tacticals.New.tclTHEN (rew_on l2r onConcl) (Proofview.V82.tactic (clear [id])), + thin in + (* Skip the side conditions of the rewriting step *) + Tacticals.New.tclTHENFIRST eqtac (tac thin) end } -let rec prepare_naming loc = function +let prepare_naming loc = function | IntroIdentifier id -> NamingMustBe (loc,id) | IntroAnonymous -> NamingAvoid [] | IntroFresh id -> NamingBasedOn (id,[]) @@ -2117,7 +2178,8 @@ let rec prepare_naming loc = function let rec explicit_intro_names = function | (_, IntroForthcoming _) :: l -> explicit_intro_names l | (_, IntroNaming (IntroIdentifier id)) :: l -> id :: explicit_intro_names l -| (_, IntroAction (IntroOrAndPattern ll)) :: l' -> +| (_, IntroAction (IntroOrAndPattern l)) :: l' -> + let ll = match l with IntroAndPattern l -> [l] | IntroOrPattern ll -> ll in List.flatten (List.map (fun l -> explicit_intro_names (l@l')) ll) | (_, IntroAction (IntroInjection l)) :: l' -> explicit_intro_names (l@l') @@ -2231,10 +2293,7 @@ and intro_pattern_action loc b style pat thin destopt tac id = match pat with | IntroInjection l' -> intro_decomp_eq loc l' thin tac id | IntroRewrite l2r -> - Tacticals.New.tclTHENLAST - (* Skip the side conditions of the rewriting step *) - (rewrite_hyp style l2r id) - (tac thin None []) + rewrite_hyp_then style thin l2r id (fun thin -> tac thin None []) | IntroApplyOn (f,(loc,pat)) -> let naming,tac_ipat = prepare_intros_loc loc (IntroIdentifier id) destopt pat in @@ -2243,19 +2302,12 @@ and intro_pattern_action loc b style pat thin destopt tac id = match pat with Proofview.tclUNIT () (* apply_in_once do a replacement *) else Proofview.V82.tactic (clear [id]) in - Proofview.Goal.enter { enter = begin fun gl -> - let sigma = Tacmach.New.project gl in - let env = Proofview.Goal.env gl in - let (c, sigma) = run_delayed env sigma f in - Tacticals.New.tclWITHHOLES false - (Tacticals.New.tclTHENFIRST - (* Skip the side conditions of the apply *) - (apply_in_once false true true true naming id - (None,(sigma,(c,NoBindings))) - (fun id -> Tacticals.New.tclTHEN doclear (tac_ipat id))) - (tac thin None [])) - sigma - end } + let f = { delayed = fun env sigma -> + let Sigma (c, sigma, p) = f.delayed env sigma in + Sigma ((c, NoBindings), sigma, p) + } in + apply_in_delayed_once false true true true naming id (None,(loc,f)) + (fun id -> Tacticals.New.tclTHENLIST [doclear; tac_ipat id; tac thin None []]) and prepare_intros_loc loc dft destopt = function | IntroNaming ipat -> @@ -2314,7 +2366,7 @@ let assert_as first hd ipat t = (* apply in as *) let general_apply_in sidecond_first with_delta with_destruct with_evars - with_clear id lemmas ipat = + id lemmas ipat = let tac (naming,lemma) tac id = apply_in_delayed_once sidecond_first with_delta with_destruct with_evars naming id lemma tac in @@ -2339,12 +2391,12 @@ let general_apply_in sidecond_first with_delta with_destruct with_evars Tacticals.New.tclTHENFIRST (tclMAPFIRST tac lemmas_target) (ipat_tac id) *) -let apply_in simple with_evars clear_flag id lemmas ipat = +let apply_in simple with_evars id lemmas ipat = let lemmas = List.map (fun (k,(loc,l)) -> k, (loc, { delayed = fun _ sigma -> Sigma.here l sigma })) lemmas in - general_apply_in false simple simple with_evars clear_flag id lemmas ipat + general_apply_in false simple simple with_evars id lemmas ipat -let apply_delayed_in simple with_evars clear_flag id lemmas ipat = - general_apply_in false simple simple with_evars clear_flag id lemmas ipat +let apply_delayed_in simple with_evars id lemmas ipat = + general_apply_in false simple simple with_evars id lemmas ipat (*****************************) (* Tactics abstracting terms *) @@ -2371,10 +2423,17 @@ let decode_hyp = function *) let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = - Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in - let t = match ty with Some t -> t | _ -> typ_of env sigma c in - let Sigma ((newcl, eq_tac), sigma, p) = match with_eq with + let Sigma (t, sigma, p) = match ty with + | Some t -> Sigma.here t sigma + | None -> + let t = typ_of env sigma c in + let sigma, c = Evarsolve.refresh_universes ~onlyalg:true (Some false) env (Sigma.to_evar_map sigma) t in + Sigma.Unsafe.of_pair (c, sigma) + in + let Sigma ((newcl, eq_tac), sigma, q) = match with_eq with | Some (lr,(loc,ido)) -> let heq = match ido with | IntroAnonymous -> new_fresh_id [id] (add_prefix "Heq" id) gl @@ -2405,24 +2464,28 @@ let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = Tacticals.New.tclMAP convert_hyp_no_check depdecls; eq_tac ] in - Sigma (tac, sigma, p) + Sigma (tac, sigma, p +> q) end } let insert_before decls lasthyp env = + let open Context.Named.Declaration in match lasthyp with | None -> push_named_context decls env | Some id -> Environ.fold_named_context - (fun _ (id',_,_ as d) env -> - let env = if Id.equal id id' then push_named_context decls env else env in + (fun _ d env -> + let env = if Id.equal id (get_id d) then push_named_context decls env else env in push_named d env) ~init:(reset_context env) env (* unsafe *) let mkletin_goal env sigma store with_eq dep (id,lastlhyp,ccl,c) ty = - let body = if dep then Some c else None in + let open Context.Named.Declaration in let t = match ty with Some t -> t | _ -> typ_of env sigma c in + let decl = if dep then LocalDef (id,c,t) + else LocalAssum (id,t) + in match with_eq with | Some (lr,(loc,ido)) -> let heq = match ido with @@ -2438,16 +2501,17 @@ let mkletin_goal env sigma store with_eq dep (id,lastlhyp,ccl,c) ty = let Sigma (refl, sigma, q) = Sigma.fresh_global env sigma eqdata.refl in let eq = applist (eq,args) in let refl = applist (refl, [t;mkVar id]) in - let newenv = insert_before [heq,None,eq;id,body,t] lastlhyp env in + let newenv = insert_before [LocalAssum (heq,eq); decl] lastlhyp env in let Sigma (x, sigma, r) = new_evar newenv sigma ~principal:true ~store ccl in Sigma (mkNamedLetIn id c t (mkNamedLetIn heq refl eq x), sigma, p +> q +> r) | None -> - let newenv = insert_before [id,body,t] lastlhyp env in + let newenv = insert_before [decl] lastlhyp env in let Sigma (x, sigma, p) = new_evar newenv sigma ~principal:true ~store ccl in Sigma (mkNamedLetIn id c t x, sigma, p) let letin_tac with_eq id c ty occs = - Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let ccl = Proofview.Goal.concl gl in let abs = AbstractExact (id,c,ty,occs,true) in @@ -2458,7 +2522,8 @@ let letin_tac with_eq id c ty occs = end } let letin_pat_tac with_eq id c occs = - Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let ccl = Proofview.Goal.concl gl in let check t = true in @@ -2498,38 +2563,6 @@ let enough_by na t tac = forward false (Some tac) (ipat_of_name na) t (* Generalization tactics *) (***************************) -(* Given a type [T] convertible to [forall x1..xn:A1..An(x1..xn-1), G(x1..xn)] - and [a1..an:A1..An(a1..an-1)] such that the goal is [G(a1..an)], - this generalizes [hyps |- goal] into [hyps |- T] *) - -let apply_type hdcty argl gl = - refine (applist (mkCast (Evarutil.mk_new_meta(),DEFAULTcast, hdcty),argl)) gl - -(* Given a context [hyps] with domain [x1..xn], possibly with let-ins, - and well-typed in the current goal, [bring_hyps hyps] generalizes - [ctxt |- G(x1..xn] into [ctxt |- forall hyps, G(x1..xn)] *) - -let bring_hyps hyps = - if List.is_empty hyps then Tacticals.New.tclIDTAC - else - Proofview.Goal.enter { enter = begin fun gl -> - let env = Proofview.Goal.env 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 { run = begin fun sigma -> - let Sigma (ev, sigma, p) = Evarutil.new_evar env sigma newcl in - Sigma (mkApp (ev, args), sigma, p) - end } - end } - -let revert hyps = - Proofview.Goal.enter { enter = begin fun gl -> - let gl = Proofview.Goal.assume gl in - let ctx = List.map (fun id -> Tacmach.New.pf_get_hyp id gl) hyps in - (bring_hyps ctx) <*> (Proofview.V82.tactic (clear hyps)) - end } - (* Compute a name for a generalization *) let generalized_name c t ids cl = function @@ -2553,32 +2586,39 @@ let generalized_name c t ids cl = function [forall x, x1:A1(x1), .., xi:Ai(x). T(x)] with all [c] abtracted in [Ai] but only those at [occs] in [T] *) -let generalize_goal_gen env ids i ((occs,c,b),na) t (cl,evd) = +let generalize_goal_gen env sigma ids i ((occs,c,b),na) t cl = + let open Context.Rel.Declaration in let decls,cl = decompose_prod_n_assum i cl in let dummy_prod = it_mkProd_or_LetIn mkProp decls in let newdecls,_ = decompose_prod_n_assum i (subst_term_gen eq_constr_nounivs c dummy_prod) in - let cl',evd' = subst_closed_term_occ env evd (AtOccs occs) c (it_mkProd_or_LetIn cl newdecls) in + let cl',sigma' = subst_closed_term_occ env sigma (AtOccs occs) c (it_mkProd_or_LetIn cl newdecls) in let na = generalized_name c t ids cl' na in - mkProd_or_LetIn (na,b,t) cl', evd' + let decl = match b with + | None -> LocalAssum (na,t) + | Some b -> LocalDef (na,b,t) + in + mkProd_or_LetIn decl cl', sigma' -let generalize_goal gl i ((occs,c,b),na as o) cl = - let t = Tacmach.pf_unsafe_type_of gl c in +let generalize_goal gl i ((occs,c,b),na as o) (cl,sigma) = let env = Tacmach.pf_env gl in - generalize_goal_gen env (Tacmach.pf_ids_of_hyps gl) i o t cl + let ids = Tacmach.pf_ids_of_hyps gl in + let sigma, t = Typing.type_of env sigma c in + generalize_goal_gen env sigma ids i o t cl let generalize_dep ?(with_let=false) c gl = + let open Context.Named.Declaration in let env = pf_env gl in let sign = pf_hyps gl in let init_ids = ids_of_named_context (Global.named_context()) in - let seek d toquant = - if List.exists (fun (id,_,_) -> occur_var_in_decl env id d) toquant + let seek (d:Context.Named.Declaration.t) (toquant:Context.Named.t) = + if List.exists (fun d' -> occur_var_in_decl env (get_id d') d) toquant || dependent_in_decl c d then d::toquant else toquant in - let to_quantify = Context.fold_named_context seek sign ~init:[] in + let to_quantify = Context.Named.fold_outside seek sign ~init:[] in let to_quantify_rev = List.rev to_quantify in - let qhyps = List.map (fun (id,_,_) -> id) to_quantify_rev in + let qhyps = List.map get_id to_quantify_rev in let tothin = List.filter (fun id -> not (Id.List.mem id init_ids)) qhyps in let tothin' = match kind_of_term c with @@ -2590,16 +2630,16 @@ let generalize_dep ?(with_let=false) c gl = let body = if with_let then match kind_of_term c with - | Var id -> pi2 (Tacmach.pf_get_hyp gl id) + | Var id -> Tacmach.pf_get_hyp gl id |> get_value | _ -> None else None in let cl'',evd = generalize_goal gl 0 ((AllOccurrences,c,body),Anonymous) (cl',project gl) in - let args = instance_from_named_context to_quantify_rev in + let args = Context.Named.to_instance to_quantify_rev in tclTHENLIST [tclEVARS evd; - apply_type cl'' (if Option.is_empty body then c::args else args); + Proofview.V82.of_tactic (apply_type cl'' (if Option.is_empty body then c::args else args)); thin (List.rev tothin')] gl @@ -2609,28 +2649,30 @@ let generalize_gen_let lconstr gl = List.fold_right_i (generalize_goal gl) 0 lconstr (Tacmach.pf_concl gl,Tacmach.project gl) in - tclTHEN (tclEVARS evd) + Proofview.V82.of_tactic (Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS evd) (apply_type newcl (List.map_filter (fun ((_,c,b),_) -> - if Option.is_empty b then Some c else None) lconstr)) gl + if Option.is_empty b then Some c else None) lconstr))) gl let new_generalize_gen_let lconstr = - Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in let gl = Proofview.Goal.assume gl in let concl = Proofview.Goal.concl gl in let sigma = Sigma.to_evar_map sigma in let env = Proofview.Goal.env gl in let ids = Tacmach.New.pf_ids_of_hyps gl in - let (newcl, sigma), args = + let newcl, sigma, args = List.fold_right_i - (fun i ((_,c,b),_ as o) (cl, args) -> - let t = Tacmach.New.pf_unsafe_type_of gl c in + (fun i ((_,c,b),_ as o) (cl, sigma, args) -> + let sigma, t = Typing.type_of env sigma 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), []) + let cl, sigma = generalize_goal_gen env sigma ids i o t cl in + (cl, sigma, args)) + 0 lconstr (concl, sigma, []) in let tac = - Proofview.Refine.refine { run = begin fun sigma -> - let Sigma (ev, sigma, p) = Evarutil.new_evar env sigma newcl in + Refine.refine { run = begin fun sigma -> + let Sigma (ev, sigma, p) = Evarutil.new_evar env sigma ~principal:true newcl in Sigma ((applist (ev, args)), sigma, p) end } in @@ -2638,7 +2680,8 @@ let new_generalize_gen_let lconstr = end } let generalize_gen lconstr = - generalize_gen_let (List.map (fun ((occs,c),na) -> + generalize_gen_let (List.map (fun (occs_c,na) -> + let (occs,c) = Redexpr.out_with_occurrences occs_c in (occs,c,None),na) lconstr) let new_generalize_gen lconstr = @@ -2663,29 +2706,77 @@ let quantify lconstr = tclIDTAC *) +(* Modifying/Adding an hypothesis *) + +let specialize (c,lbind) = + Proofview.Goal.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + let sigma, term = + if lbind == NoBindings then + let sigma = Typeclasses.resolve_typeclasses env sigma in + sigma, nf_evar sigma c + else + let clause = make_clenv_binding env sigma (c,Retyping.get_type_of env sigma 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 + let rec chk = function + | [] -> [] + | t::l -> if occur_meta t then [] else t :: chk l + in + let tstack = chk tstack in + let term = applist(thd,List.map (nf_evar clause.evd) tstack) in + if occur_meta term then + errorlabstrm "" (str "Cannot infer an instance for " ++ + pr_name (meta_name clause.evd (List.hd (collect_metas term))) ++ + str "."); + clause.evd, term in + let typ = Retyping.get_type_of env sigma term in + match kind_of_term (fst(decompose_app (snd(decompose_lam_assum c)))) with + | Var id when Id.List.mem id (Tacmach.New.pf_ids_of_hyps gl) -> + Tacticals.New.tclTHEN + (Proofview.Unsafe.tclEVARS sigma) + (Tacticals.New.tclTHENFIRST + (assert_before_replacing id typ) + (new_exact_no_check term)) + | _ -> + (* To deprecate in favor of generalize? *) + Tacticals.New.tclTHEN + (Proofview.Unsafe.tclEVARS sigma) + (Tacticals.New.tclTHENLAST + (cut typ) + (new_exact_no_check term)) + end } + (*****************************) (* Ad hoc unfold *) (*****************************) (* The two following functions should already exist, but found nowhere *) (* Unfolds x by its definition everywhere *) -let unfold_body x gl = - let hyps = pf_hyps gl in - let xval = - match Context.lookup_named x hyps with - (_,Some xval,_) -> xval - | _ -> errorlabstrm "unfold_body" - (pr_id x ++ str" is not a defined hypothesis.") in - let aft = afterHyp x gl in - let hl = List.fold_right (fun (y,yval,_) cl -> (y,InHyp) :: cl) aft [] in +let unfold_body x = + let open Context.Named.Declaration in + Proofview.Goal.enter { enter = begin fun gl -> + (** We normalize the given hypothesis immediately. *) + let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in + let xval = match Context.Named.lookup x hyps with + | LocalAssum _ -> errorlabstrm "unfold_body" + (pr_id x ++ str" is not a defined hypothesis.") + | LocalDef (_,xval,_) -> pf_nf_evar gl xval + in + Tacticals.New.afterHyp x begin fun aft -> + let hl = List.fold_right (fun decl cl -> (get_id decl, InHyp) :: cl) aft [] in let xvar = mkVar x in let rfun _ _ c = replace_term xvar xval c in - tclTHENLIST - [tclMAP (fun h -> reduct_in_hyp rfun h) hl; - reduct_in_concl (rfun,DEFAULTcast)] gl + let reducth h = reduct_in_hyp rfun h in + let reductc = reduct_in_concl (rfun, DEFAULTcast) in + Tacticals.New.tclTHENLIST [Tacticals.New.tclMAP reducth hl; reductc] + end + end } (* Either unfold and clear if defined or simply clear if not a definition *) -let expand_hyp id = tclTHEN (tclTRY (unfold_body id)) (clear [id]) +let expand_hyp id = Tacticals.New.tclTHEN (Tacticals.New.tclTRY (unfold_body id)) (Proofview.V82.tactic (clear [id])) (*****************************) (* High-level induction *) @@ -2698,8 +2789,6 @@ let expand_hyp id = tclTHEN (tclTRY (unfold_body id)) (clear [id]) - [hyp0] is the induction hypothesis - we extract from [args] the variables which are not rigid parameters of the inductive type, this is [indvars] (other terms are forgotten); - [indhyps] are the ones which actually are declared in context - (done in [find_atomic_param_of_ind]) - we look for all hyps depending of [hyp0] or one of [indvars]: this is [dephyps] of types [deptyps] respectively - [statuslist] tells for each hyps in [dephyps] after which other hyp @@ -2711,7 +2800,7 @@ let expand_hyp id = tclTHEN (tclTRY (unfold_body id)) (clear [id]) Strategy: (cf in [induction_with_atomization_of_ind_arg]) - requantify and clear all [dephyps] - apply induction on [hyp0] - - clear [indhyps] and [hyp0] + - clear those of [indvars] that are variables and [hyp0] - in the i-th subgoal, intro the arguments of the i-th constructor of the inductive type after [hyp0succ] (done in [induct_discharge]) let the induction hypotheses on top of the @@ -2807,8 +2896,8 @@ let induct_discharge dests avoid' tac (avoid,ra) names = let avoid = avoid @ avoid' in let rec peel_tac ra dests names thin = match ra with - | (RecArg,deprec,recvarname) :: - (IndArg,depind,hyprecname) :: ra' -> + | (RecArg,_,deprec,recvarname) :: + (IndArg,_,depind,hyprecname) :: ra' -> Proofview.Goal.enter { enter = begin fun gl -> let (recpat,names) = match names with | [loc,IntroNaming (IntroIdentifier id) as pat] -> @@ -2825,7 +2914,7 @@ let induct_discharge dests avoid' tac (avoid,ra) names = peel_tac ra' (update_dest dests ids') names thin) end }) end } - | (IndArg,dep,hyprecname) :: ra' -> + | (IndArg,_,dep,hyprecname) :: ra' -> Proofview.Goal.enter { enter = begin fun gl -> (* Rem: does not happen in Coq schemes, only in user-defined schemes *) let pat,names = @@ -2833,7 +2922,7 @@ let induct_discharge dests avoid' tac (avoid,ra) names = dest_intro_patterns avoid thin MoveLast [pat] (fun ids thin -> peel_tac ra' (update_dest dests ids) names thin) end } - | (RecArg,dep,recvarname) :: ra' -> + | (RecArg,_,dep,recvarname) :: ra' -> Proofview.Goal.enter { enter = begin fun gl -> let (pat,names) = consume_pattern avoid (Name recvarname) dep gl names in @@ -2841,7 +2930,7 @@ let induct_discharge dests avoid' tac (avoid,ra) names = dest_intro_patterns avoid thin dest [pat] (fun ids thin -> peel_tac ra' dests names thin) end } - | (OtherArg,dep,_) :: ra' -> + | (OtherArg,_,dep,_) :: ra' -> Proofview.Goal.enter { enter = begin fun gl -> let (pat,names) = consume_pattern avoid Anonymous dep gl names in let dest = get_recarg_dest dests in @@ -2858,6 +2947,15 @@ let induct_discharge dests avoid' tac (avoid,ra) names = s'embêter à regarder si un letin_tac ne fait pas des substitutions aussi sur l'argument voisin *) +let expand_projections env sigma c = + let sigma = Sigma.to_evar_map sigma in + let rec aux env c = + match kind_of_term c with + | Proj (p, c) -> Retyping.expand_projection env sigma p (aux env c) [] + | _ -> map_constr_with_full_binders push_rel aux env c + in aux env c + + (* Marche pas... faut prendre en compte l'occurrence précise... *) let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = @@ -2866,11 +2964,14 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = let tmptyp0 = Tacmach.New.pf_get_hyp_typ hyp0 (Proofview.Goal.assume gl) in let reduce_to_quantified_ref = Tacmach.New.pf_apply reduce_to_quantified_ref gl in let typ0 = reduce_to_quantified_ref indref tmptyp0 in - let prods, indtyp = decompose_prod typ0 in + let prods, indtyp = decompose_prod_assum typ0 in let hd,argl = decompose_app indtyp in + let env' = push_rel_context prods env in + let sigma = Proofview.Goal.sigma gl in let params = List.firstn nparams argl in + let params' = List.map (expand_projections env' sigma) params in (* le gl est important pour ne pas préévaluer *) - let rec atomize_one i args avoid = + let rec atomize_one i args args' avoid = if Int.equal i nparams then let t = applist (hd, params@args) in Tacticals.New.tclTHEN @@ -2879,22 +2980,23 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = else let c = List.nth argl (i-1) in match kind_of_term c with - | Var id when not (List.exists (occur_var env id) args) && - not (List.exists (occur_var env id) params) -> + | Var id when not (List.exists (occur_var env id) args') && + not (List.exists (occur_var env id) params') -> (* Based on the knowledge given by the user, all constraints on the variable are generalizable in the current environment so that it is clearable after destruction *) - atomize_one (i-1) (c::args) (id::avoid) + atomize_one (i-1) (c::args) (c::args') (id::avoid) | _ -> - if List.exists (dependent c) params || - List.exists (dependent c) args + let c' = expand_projections env' sigma c in + if List.exists (dependent c) params' || + List.exists (dependent c) args' then (* This is a case where the argument is constrained in a way which would require some kind of inversion; we follow the (old) discipline of not generalizing over this term, since we don't try to invert the constraint anyway. *) - atomize_one (i-1) (c::args) avoid + atomize_one (i-1) (c::args) (c'::args') avoid else (* We reason blindly on the term and do as if it were generalizable, ignoring the constraints coming from @@ -2907,9 +3009,9 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = let x = fresh_id_in_env avoid id env in Tacticals.New.tclTHEN (letin_tac None (Name x) c None allHypsAndConcl) - (atomize_one (i-1) (mkVar x::args) (x::avoid)) + (atomize_one (i-1) (mkVar x::args) (mkVar x::args') (x::avoid)) in - atomize_one (List.length argl) [] [] + atomize_one (List.length argl) [] [] [] end } (* [cook_sign] builds the lists [beforetoclear] (preceding the @@ -2934,7 +3036,6 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = Induction hypothesis is H4 ([hyp0]) Variable parameters of (le O n) is the singleton list with "n" ([indvars]) - Part of [indvars] really in context is the same ([indhyps]) The dependent hyps are H3 and H6 ([dephyps]) For H3 the memorized places are H5 ([lhyp]) and H2 ([rhyp]) because these names are among the hyp which are fixed through the induction @@ -2979,8 +3080,9 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = exception Shunt of Id.t move_location let cook_sign hyp0_opt inhyps indvars env = - (* First phase from L to R: get [indhyps], [decldep] and [statuslist] + (* First phase from L to R: get [toclear], [decldep] and [statuslist] for the hypotheses before (= more ancient than) hyp0 (see above) *) + let open Context.Named.Declaration in let toclear = ref [] in let avoid = ref [] in let decldeps = ref [] in @@ -2989,7 +3091,8 @@ let cook_sign hyp0_opt inhyps indvars env = let lstatus = ref [] in let before = ref true in let maindep = ref false in - let seek_deps env (hyp,_,_ as decl) rhyp = + let seek_deps env decl rhyp = + let hyp = get_id decl in if (match hyp0_opt with Some hyp0 -> Id.equal hyp hyp0 | _ -> false) then begin before:=false; @@ -3008,7 +3111,7 @@ let cook_sign hyp0_opt inhyps indvars env = in let depother = List.is_empty inhyps && (List.exists (fun id -> occur_var_in_decl env id decl) indvars || - List.exists (fun (id,_,_) -> occur_var_in_decl env id decl) !decldeps) + List.exists (fun decl' -> occur_var_in_decl env (get_id decl') decl) !decldeps) in if not (List.is_empty inhyps) && Id.List.mem hyp inhyps || dephyp0 || depother @@ -3030,7 +3133,8 @@ let cook_sign hyp0_opt inhyps indvars env = in let _ = fold_named_context seek_deps env ~init:MoveFirst in (* 2nd phase from R to L: get left hyp of [hyp0] and [lhyps] *) - let compute_lstatus lhyp (hyp,_,_) = + let compute_lstatus lhyp decl = + let hyp = get_id decl in if (match hyp0_opt with Some hyp0 -> Id.equal hyp hyp0 | _ -> false) then raise (Shunt lhyp); if Id.List.mem hyp !ldeps then begin @@ -3080,20 +3184,20 @@ type elim_scheme = { elimc: constr with_bindings option; elimt: types; indref: global_reference option; - params: rel_context; (* (prm1,tprm1);(prm2,tprm2)...(prmp,tprmp) *) - nparams: int; (* number of parameters *) - predicates: rel_context; (* (Qq, (Tq_1 -> Tq_2 ->...-> Tq_nq)), (Q1,...) *) - npredicates: int; (* Number of predicates *) - branches: rel_context; (* branchr,...,branch1 *) - nbranches: int; (* Number of branches *) - args: rel_context; (* (xni, Ti_ni) ... (x1, Ti_1) *) - nargs: int; (* number of arguments *) - indarg: rel_declaration option; (* Some (H,I prm1..prmp x1...xni) - if HI is in premisses, None otherwise *) - concl: types; (* Qi x1...xni HI (f...), HI and (f...) - are optional and mutually exclusive *) - indarg_in_concl: bool; (* true if HI appears at the end of conclusion *) - farg_in_concl: bool; (* true if (f...) appears at the end of conclusion *) + params: Context.Rel.t; (* (prm1,tprm1);(prm2,tprm2)...(prmp,tprmp) *) + nparams: int; (* number of parameters *) + predicates: Context.Rel.t; (* (Qq, (Tq_1 -> Tq_2 ->...-> Tq_nq)), (Q1,...) *) + npredicates: int; (* Number of predicates *) + branches: Context.Rel.t; (* branchr,...,branch1 *) + nbranches: int; (* Number of branches *) + args: Context.Rel.t; (* (xni, Ti_ni) ... (x1, Ti_1) *) + nargs: int; (* number of arguments *) + indarg: Context.Rel.Declaration.t option; (* Some (H,I prm1..prmp x1...xni) + if HI is in premisses, None otherwise *) + concl: types; (* Qi x1...xni HI (f...), HI and (f...) + are optional and mutually exclusive *) + indarg_in_concl: bool; (* true if HI appears at the end of conclusion *) + farg_in_concl: bool; (* true if (f...) appears at the end of conclusion *) } let empty_scheme = @@ -3213,46 +3317,54 @@ let decompose_indapp f args = | _ -> f, args let mk_term_eq env sigma ty t ty' t' = + let sigma = Sigma.to_evar_map sigma in if Reductionops.is_conv env sigma ty ty' then mkEq ty t t', mkRefl ty' t' else mkHEq ty t ty' t', mkHRefl ty' t' -let make_abstract_generalize gl id concl dep ctx body c eqs args refls = - let meta = Evarutil.new_meta() in +let make_abstract_generalize env id typ concl dep ctx body c eqs args refls = + let open Context.Rel.Declaration in + Refine.refine { run = begin fun sigma -> let eqslen = List.length eqs in - let term, typ = mkVar id, Tacmach.pf_get_hyp_typ gl id in (* Abstract by the "generalized" hypothesis equality proof if necessary. *) let abshypeq, abshypt = if dep then - let eq, refl = mk_term_eq (push_rel_context ctx (Tacmach.pf_env gl)) (Tacmach.project gl) (lift 1 c) (mkRel 1) typ term in + let eq, refl = mk_term_eq (push_rel_context ctx env) sigma (lift 1 c) (mkRel 1) typ (mkVar id) in mkProd (Anonymous, eq, lift 1 concl), [| refl |] else concl, [||] in - (* Abstract by equalitites *) + (* Abstract by equalities *) let eqs = lift_togethern 1 eqs in (* lift together and past genarg *) - let abseqs = it_mkProd_or_LetIn (lift eqslen abshypeq) (List.map (fun x -> (Anonymous, None, x)) eqs) in + let abseqs = it_mkProd_or_LetIn (lift eqslen abshypeq) (List.map (fun x -> LocalAssum (Anonymous, x)) eqs) in + let decl = match body with + | None -> LocalAssum (Name id, c) + | Some body -> LocalDef (Name id, body, c) + in (* Abstract by the "generalized" hypothesis. *) - let genarg = mkProd_or_LetIn (Name id, body, c) abseqs in + let genarg = mkProd_or_LetIn decl abseqs in (* Abstract by the extension of the context *) let genctyp = it_mkProd_or_LetIn genarg ctx in (* The goal will become this product. *) - let genc = mkCast (mkMeta meta, DEFAULTcast, genctyp) in + let Sigma (genc, sigma, p) = Evarutil.new_evar env sigma ~principal:true genctyp in (* Apply the old arguments giving the proper instantiation of the hyp *) let instc = mkApp (genc, Array.of_list args) in - (* Then apply to the original instanciated hyp. *) + (* Then apply to the original instantiated hyp. *) let instc = Option.cata (fun _ -> instc) (mkApp (instc, [| mkVar id |])) body in (* Apply the reflexivity proofs on the indices. *) let appeqs = mkApp (instc, Array.of_list refls) in - (* Finaly, apply the reflexivity proof for the original hyp, to get a term of type gl again. *) - mkApp (appeqs, abshypt) + (* Finally, apply the reflexivity proof for the original hyp, to get a term of type gl again. *) + Sigma (mkApp (appeqs, abshypt), sigma, p) + end } let hyps_of_vars env sign nogen hyps = + let open Context.Named.Declaration in if Id.Set.is_empty hyps then [] else let (_,lh) = - Context.fold_named_context_reverse - (fun (hs,hl) (x,_,_ as d) -> + Context.Named.fold_inside + (fun (hs,hl) d -> + let x = get_id d in if Id.Set.mem x nogen then (hs,hl) else if Id.Set.mem x hs then (hs,x::hl) else @@ -3281,12 +3393,13 @@ let linear vars args = true with Seen -> false -let is_defined_variable env id = match lookup_named id env with -| (_, None, _) -> false -| (_, Some _, _) -> true +let is_defined_variable env id = + let open Context.Named.Declaration in + lookup_named id env |> is_local_def let abstract_args gl generalize_vars dep id defined f args = - let sigma = Tacmach.project gl in + let open Context.Rel.Declaration in + let sigma = ref (Tacmach.project gl) in let env = Tacmach.pf_env gl in let concl = Tacmach.pf_concl gl in let dep = dep || dependent (mkVar id) concl in @@ -3302,12 +3415,14 @@ let abstract_args gl generalize_vars dep id defined f args = eqs are not lifted w.r.t. each other yet. (* will be needed when going to dependent indexes *) *) 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 - List.hd rel, c + let name, ty, arity = + let rel, c = Reductionops.splay_prod_n env !sigma 1 prod in + let decl = List.hd rel in + get_name decl, get_type decl, c in let argty = Tacmach.pf_unsafe_type_of gl arg in - let ty = (* refresh_universes_strict *) ty 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 @@ -3317,7 +3432,7 @@ let abstract_args gl generalize_vars dep id defined f args = Id.Set.add id nongenvars, Id.Set.remove id vars, env) | _ -> let name = get_id name in - let decl = (Name name, None, ty) in + let decl = LocalAssum (Name name, ty) in let ctx = decl :: ctx in let c' = mkApp (lift 1 c, [|mkRel 1|]) in let args = arg :: args in @@ -3346,8 +3461,9 @@ let abstract_args gl generalize_vars dep id defined f args = true, mkApp (f', before), after in if dogen then + let tyf' = Tacmach.pf_unsafe_type_of gl f' in let arity, ctx, ctxenv, c', args, eqs, refls, nogen, vars, env = - Array.fold_left aux (Tacmach.pf_unsafe_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 = @@ -3356,21 +3472,26 @@ 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', Retyping.get_type_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', Retyping.get_type_of ctxenv !sigma c' + else None, c' + in + let typ = Tacmach.pf_get_hyp_typ gl id in + let tac = make_abstract_generalize (pf_env gl) id typ concl dep ctx body c' eqs args refls in + let tac = Proofview.Unsafe.tclEVARS !sigma <*> tac in + Some (tac, dep, succ (List.length ctx), vars) else None let abstract_generalize ?(generalize_vars=true) ?(force_dep=false) id = + let open Context.Named.Declaration in Proofview.Goal.nf_enter { enter = begin fun gl -> Coqlib.check_required_library Coqlib.jmeq_module_name; let (f, args, def, id, oldid) = let oldid = Tacmach.New.pf_get_new_id id gl in - let (_, b, t) = Tacmach.New.pf_get_hyp id gl in - match b with - | None -> let f, args = decompose_app t in + match Tacmach.New.pf_get_hyp id gl with + | LocalAssum (_,t) -> let f, args = decompose_app t in (f, args, false, id, oldid) - | Some t -> + | LocalDef (_,t,_) -> let f, args = decompose_app t in (f, args, true, id, oldid) in @@ -3380,20 +3501,24 @@ 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 (tac, 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 [ + tac; + rename_hyp [(id, oldid)]; Tacticals.New.tclDO n intro; + Proofview.V82.tactic (generalize_dep ~with_let:true (mkVar oldid))] + else Tacticals.New.tclTHENLIST [ + tac; + 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 = @@ -3401,6 +3526,7 @@ let rec compare_upto_variables x y = else compare_constr compare_upto_variables x y let specialize_eqs id gl = + let open Context.Rel.Declaration in let env = Tacmach.pf_env gl in let ty = Tacmach.pf_get_hyp_typ gl id in let evars = ref (project gl) in @@ -3429,15 +3555,14 @@ let specialize_eqs id gl = if in_eqs then acc, in_eqs, ctx, ty else let e = e_new_evar (push_rel_context ctx env) evars t in - aux false ((na, Some e, t) :: ctx) (mkApp (lift 1 acc, [| mkRel 1 |])) b) + aux false (LocalDef (na,e,t) :: ctx) (mkApp (lift 1 acc, [| mkRel 1 |])) b) | t -> acc, in_eqs, ctx, ty in let acc, worked, ctx, ty = aux false [] (mkVar id) ty in let ctx' = nf_rel_context_evar !evars ctx in - let ctx'' = List.map (fun (n,b,t as decl) -> - match b with - | Some k when isEvar k -> (n,None,t) - | b -> decl) ctx' + let ctx'' = List.map (function + | LocalDef (n,k,t) when isEvar k -> LocalAssum (n,t) + | decl -> decl) ctx' in let ty' = it_mkProd_or_LetIn ty ctx'' in let acc' = it_mkLambda_or_LetIn acc ctx'' in @@ -3471,18 +3596,19 @@ let occur_rel n c = We also return the conclusion. *) let decompose_paramspred_branch_args elimt = - let rec cut_noccur elimt acc2 : rel_context * rel_context * types = + let open Context.Rel.Declaration in + let rec cut_noccur elimt acc2 = match kind_of_term elimt with | Prod(nme,tpe,elimt') -> let hd_tpe,_ = decompose_app ((strip_prod_assum tpe)) in if not (occur_rel 1 elimt') && isRel hd_tpe - then cut_noccur elimt' ((nme,None,tpe)::acc2) + then cut_noccur elimt' (LocalAssum (nme,tpe)::acc2) else let acc3,ccl = decompose_prod_assum elimt in acc2 , acc3 , ccl | App(_, _) | Rel _ -> acc2 , [] , elimt | _ -> error_ind_scheme "" in - let rec cut_occur elimt acc1 : rel_context * rel_context * rel_context * types = + let rec cut_occur elimt acc1 = match kind_of_term elimt with - | Prod(nme,tpe,c) when occur_rel 1 c -> cut_occur c ((nme,None,tpe)::acc1) + | Prod(nme,tpe,c) when occur_rel 1 c -> cut_occur c (LocalAssum (nme,tpe)::acc1) | Prod(nme,tpe,c) -> let acc2,acc3,ccl = cut_noccur elimt [] in acc1,acc2,acc3,ccl | App(_, _) | Rel _ -> acc1,[],[],elimt | _ -> error_ind_scheme "" in @@ -3524,6 +3650,7 @@ let exchange_hd_app subst_hd t = - finish to fill in the elim_scheme: indarg/farg/args and finally indref. *) let compute_elim_sig ?elimc elimt = + let open Context.Rel.Declaration in let params_preds,branches,args_indargs,conclusion = decompose_paramspred_branch_args elimt in @@ -3557,8 +3684,8 @@ let compute_elim_sig ?elimc elimt = (* 3- Look at last arg: is it the indarg? *) ignore ( match List.hd args_indargs with - | hiname,Some _,hi -> error_ind_scheme "" - | hiname,None,hi -> + | LocalDef (hiname,_,hi) -> error_ind_scheme "" + | LocalAssum (hiname,hi) -> let hi_ind, hi_args = decompose_app hi in let hi_is_ind = (* hi est d'un type globalisable *) match kind_of_term hi_ind with @@ -3582,24 +3709,25 @@ let compute_elim_sig ?elimc elimt = with Exit -> (* Ending by computing indref: *) match !res.indarg with | None -> !res (* No indref *) - | Some ( _,Some _,_) -> error_ind_scheme "" - | Some ( _,None,ind) -> + | Some (LocalDef _) -> error_ind_scheme "" + | Some (LocalAssum (_,ind)) -> let indhd,indargs = decompose_app ind in try {!res with indref = Some (global_of_constr indhd) } with e when Errors.noncritical e -> error "Cannot find the inductive type of the inductive scheme." let compute_scheme_signature scheme names_info ind_type_guess = + let open Context.Rel.Declaration in let f,l = decompose_app scheme.concl in (* Vérifier que les arguments de Qi sont bien les xi. *) let cond, check_concl = match scheme.indarg with - | Some (_,Some _,_) -> + | Some (LocalDef _) -> error "Strange letin, cannot recognize an induction scheme." | None -> (* Non standard scheme *) let cond hd = Term.eq_constr hd ind_type_guess && not scheme.farg_in_concl in (cond, fun _ _ -> ()) - | Some ( _,None,ind) -> (* Standard scheme from an inductive type *) + | Some (LocalAssum (_,ind)) -> (* Standard scheme from an inductive type *) let indhd,indargs = decompose_app ind in let cond hd = Term.eq_constr hd indhd in let check_concl is_pred p = @@ -3608,7 +3736,7 @@ let compute_scheme_signature scheme names_info ind_type_guess = let ind_is_ok = List.equal Term.eq_constr (List.lastn scheme.nargs indargs) - (extended_rel_list 0 scheme.args) in + (Context.Rel.to_extended_list 0 scheme.args) in if not (ccl_arg_ok && ind_is_ok) then error_ind_scheme "the conclusion of" in (cond, check_concl) @@ -3623,28 +3751,28 @@ let compute_scheme_signature scheme names_info ind_type_guess = let rec check_branch p c = match kind_of_term c with | Prod (_,t,c) -> - (is_pred p t, dependent (mkRel 1) c) :: check_branch (p+1) c + (is_pred p t, true, dependent (mkRel 1) c) :: check_branch (p+1) c | LetIn (_,_,_,c) -> - (OtherArg, dependent (mkRel 1) c) :: check_branch (p+1) c + (OtherArg, false, dependent (mkRel 1) c) :: check_branch (p+1) c | _ when is_pred p c == IndArg -> [] | _ -> raise Exit in let rec find_branches p lbrch = match lbrch with - | (_,None,t)::brs -> + | LocalAssum (_,t) :: brs -> (try let lchck_brch = check_branch p t in let n = List.fold_left - (fun n (b,_) -> if b == RecArg then n+1 else n) 0 lchck_brch in + (fun n (b,_,_) -> if b == RecArg then n+1 else n) 0 lchck_brch in let recvarname, hyprecname, avoid = make_up_names n scheme.indref names_info in let namesign = - List.map (fun (b,dep) -> - (b, dep, if b == IndArg then hyprecname else recvarname)) + List.map (fun (b,is_assum,dep) -> + (b,is_assum,dep,if b == IndArg then hyprecname else recvarname)) lchck_brch in (avoid,namesign) :: find_branches (p+1) brs with Exit-> error_ind_scheme "the branches of") - | (_,Some _,_)::_ -> error_ind_scheme "the branches of" + | LocalDef _ :: _ -> error_ind_scheme "the branches of" | [] -> check_concl is_pred p; [] in Array.of_list (find_branches 0 (List.rev scheme.branches)) @@ -3666,11 +3794,16 @@ let guess_elim isrec dep s hyp0 gl = let evd, elimc = if isrec && not (is_nonrec (fst mind)) then find_ind_eliminator (fst mind) s gl else + let env = Tacmach.New.pf_env gl in + let sigma = Sigma.Unsafe.of_evar_map (Tacmach.New.project gl) in if use_dependent_propositions_elimination () && dep then - Tacmach.New.pf_apply build_case_analysis_scheme gl mind true s + let Sigma (ind, sigma, _) = build_case_analysis_scheme env sigma mind true s in + (Sigma.to_evar_map sigma, ind) else - Tacmach.New.pf_apply build_case_analysis_scheme_default gl mind s in + let Sigma (ind, sigma, _) = build_case_analysis_scheme_default env sigma mind s in + (Sigma.to_evar_map sigma, ind) + in let elimt = Tacmach.New.pf_unsafe_type_of gl elimc in evd, ((elimc, NoBindings), elimt), mkIndU mind @@ -3680,7 +3813,7 @@ let given_elim hyp0 (elimc,lbind as e) gl = Tacmach.New.project 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 + (Id.t list * (elim_arg_kind * bool * bool * Id.t) list) array type eliminator_source = | ElimUsing of (eliminator * types) * scheme_signature @@ -3720,13 +3853,15 @@ let is_functional_induction elimc gl = (* Wait the last moment to guess the eliminator so as to know if we need a dependent one or not *) -let get_eliminator elim dep s gl = match elim with +let get_eliminator elim dep s gl = + let open Context.Rel.Declaration in + match elim with | ElimUsing (elim,indsign) -> Tacmach.New.project gl, (* bugged, should be computed *) true, elim, indsign | ElimOver (isrec,id) -> let evd, (elimc,elimt),_ as elims = guess_elim isrec dep s id gl in let _, (l, s) = compute_elim_signature elims id in - let branchlengthes = List.map (fun (_,b,c) -> assert (b=None); pi1 (decompose_prod_letin c)) (List.rev s.branches) in + let branchlengthes = List.map (fun d -> assert (is_local_assum d); pi1 (decompose_prod_letin (get_type d))) (List.rev s.branches) in evd, isrec, ({elimindex = None; elimbody = elimc; elimrename = Some (isrec,Array.of_list branchlengthes)}, elimt), l (* Instantiate all meta variables of elimclause using lid, some elts @@ -3759,7 +3894,7 @@ let recolle_clenv i params args elimclause gl = trying to unify (which would lead to trying to apply it to evars if y is a product). *) let indclause = mk_clenv_from_n gl (Some 0) (x,y) in - let elimclause' = clenv_fchain i acc indclause in + let elimclause' = clenv_fchain ~with_univs:false i acc indclause in elimclause') (List.rev clauses) elimclause @@ -3787,27 +3922,33 @@ let induction_tac with_evars params indvars elim gl = induction applies with the induction hypotheses *) let apply_induction_in_context hyp0 inhyps elim indvars names induct_tac = - Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> + let open Context.Named.Declaration in + Proofview.Goal.s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let sigma = Sigma.to_evar_map sigma in let concl = Tacmach.New.pf_nf_concl gl in - let statuslists,lhyp0,toclear,deps,avoid,dep = cook_sign hyp0 inhyps indvars env in - let dep = dep || Option.cata (fun id -> occur_var env id concl) false hyp0 in + let statuslists,lhyp0,toclear,deps,avoid,dep_in_hyps = cook_sign hyp0 inhyps indvars env in + let dep_in_concl = Option.cata (fun id -> occur_var env id concl) false hyp0 in + let dep = dep_in_hyps || dep_in_concl in let tmpcl = it_mkNamedProd_or_LetIn concl deps in let s = Retyping.get_sort_family_of env sigma tmpcl in let deps_cstr = List.fold_left - (fun a (id,b,_) -> if Option.is_empty b then (mkVar id)::a else a) [] deps in + (fun a decl -> if is_local_assum decl then (mkVar (get_id decl))::a else a) [] deps in let (sigma, isrec, elim, indsign) = get_eliminator elim dep s (Proofview.Goal.assume gl) in - let names = compute_induction_names (Array.length indsign) names in + let branchletsigns = + let f (_,is_not_let,_,_) = is_not_let in + Array.map (fun (_,l) -> List.map f l) indsign in + let names = compute_induction_names branchletsigns names in let tac = (if isrec then Tacticals.New.tclTHENFIRSTn else Tacticals.New.tclTHENLASTn) (Tacticals.New.tclTHENLIST [ (* Generalize dependent hyps (but not args) *) - if deps = [] then Proofview.tclUNIT () else Proofview.V82.tactic (apply_type tmpcl deps_cstr); + if deps = [] then Proofview.tclUNIT () else apply_type tmpcl deps_cstr; (* side-conditions in elim (resp case) schemes come last (resp first) *) induct_tac elim; - Proofview.V82.tactic (tclMAP expand_hyp toclear) + Tacticals.New.tclMAP expand_hyp toclear; ]) (Array.map2 (induct_discharge lhyp0 avoid (re_intro_dependent_hypotheses statuslists)) @@ -3861,7 +4002,7 @@ let induction_without_atomization isrec with_evars elim names lid = if indvars = [] then [List.hd lid_params] else indvars in let induct_tac elim = Proofview.V82.tactic (tclTHENLIST [ (* pattern to make the predicate appear. *) - reduce (Pattern (List.map inj_with_occurrences lidcstr)) onConcl; + Proofview.V82.of_tactic (reduce (Pattern (List.map inj_with_occurrences lidcstr)) onConcl); (* Induction by "refine (indscheme ?i ?j ?k...)" + resolution of all possible holes using arguments given by the user (but the functional one). *) @@ -3874,6 +4015,7 @@ let induction_without_atomization isrec with_evars elim names lid = (* assume that no occurrences are selected *) let clear_unselected_context id inhyps cls gl = + let open Context.Named.Declaration in if occur_var (Tacmach.pf_env gl) id (Tacmach.pf_concl gl) && cls.concl_occs == NoOccurrences then errorlabstrm "" @@ -3881,7 +4023,8 @@ let clear_unselected_context id inhyps cls gl = ++ str "."); match cls.onhyps with | Some hyps -> - let to_erase (id',_,_ as d) = + let to_erase d = + let id' = get_id d in if Id.List.mem id' inhyps then (* if selected, do not erase *) None else (* erase if not selected and dependent on id or selected hyps *) @@ -3952,9 +4095,14 @@ let check_enough_applied env sigma elim = (* Last argument is supposed to be the induction argument *) check_expected_type env sigma elimc elimt +let guard_no_unifiable = Proofview.guard_no_unifiable >>= function +| None -> Proofview.tclUNIT () +| Some l -> Proofview.tclZERO (RefinerError (UnresolvedBindings l)) + let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim id ((pending,(c0,lbind)),(eqname,names)) t0 inhyps cls tac = - Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let ccl = Proofview.Goal.raw_concl gl in let store = Proofview.Goal.extra gl in @@ -3978,14 +4126,14 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim (* and destruct has side conditions first *) Tacticals.New.tclTHENLAST) (Tacticals.New.tclTHENLIST [ - Proofview.Refine.refine ~unsafe:true { run = begin fun sigma -> + Refine.refine ~unsafe:true { run = begin fun sigma -> let b = not with_evars && with_eq != None in let Sigma (c, sigma, p) = use_bindings env sigma elim b (c0,lbind) t0 in let t = Retyping.get_type_of env (Sigma.to_evar_map sigma) c in let Sigma (ans, sigma, q) = mkletin_goal env sigma store with_eq false (id,lastlhyp,ccl,c) (Some t) in Sigma (ans, sigma, p +> q) end }; - Proofview.(if with_evars then shelve_unifiable else guard_no_unifiable); + if with_evars then Proofview.shelve_unifiable else guard_no_unifiable; if is_arg_pure_hyp then Tacticals.New.tclTRY (Proofview.V82.tactic (thin [destVar c0])) else Proofview.tclUNIT (); @@ -4002,7 +4150,7 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim let env = reset_with_named_context sign env in let tac = Tacticals.New.tclTHENLIST [ - Proofview.Refine.refine ~unsafe:true { run = begin fun sigma -> + Refine.refine ~unsafe:true { run = begin fun sigma -> mkletin_goal env sigma store with_eq true (id,lastlhyp,ccl,c) None end }; tac @@ -4023,10 +4171,9 @@ let induction_gen clear_flag isrec with_evars elim | _ -> [] in Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in + let sigma = Proofview.Goal.sigma gl in let ccl = Proofview.Goal.raw_concl gl in let cls = Option.default allHypsAndConcl cls in - let sigma = Sigma.Unsafe.of_evar_map sigma in let t = typ_of env sigma c in let is_arg_pure_hyp = isVar c && not (mem_named_context (destVar c) (Global.named_context())) @@ -4241,19 +4388,20 @@ let elim_scheme_type elim t = end } let elim_type t = - Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> let (ind,t) = Tacmach.New.pf_apply reduce_to_atomic_ind gl t in let evd, elimc = find_ind_eliminator (fst ind) (Tacticals.New.elimination_sort_of_goal gl) gl in Sigma.Unsafe.of_pair (elim_scheme_type elimc t, evd) end } let case_type t = - Proofview.Goal.s_enter { s_enter = begin fun gl sigma -> - let (ind,t) = Tacmach.New.pf_apply reduce_to_atomic_ind gl t in - let evd, elimc = - Tacmach.New.pf_apply build_case_analysis_scheme_default gl ind (Tacticals.New.elimination_sort_of_goal gl) - in - Sigma.Unsafe.of_pair (elim_scheme_type elimc t, evd) + Proofview.Goal.s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let env = Tacmach.New.pf_env gl in + let (ind,t) = reduce_to_atomic_ind env (Sigma.to_evar_map sigma) t in + let s = Tacticals.New.elimination_sort_of_goal gl in + let Sigma (elimc, evd, p) = build_case_analysis_scheme_default env sigma ind s in + Sigma (elim_scheme_type elimc t, evd, p) end } @@ -4453,39 +4601,45 @@ let intros_transitivity n = Tacticals.New.tclTHEN intros (transitivity_gen n) is solved by tac *) (** d1 is the section variable in the global context, d2 in the goal context *) -let interpretable_as_section_decl evd d1 d2 = match d2,d1 with - | (_,Some _,_), (_,None,_) -> false - | (_,Some b1,t1), (_,Some b2,t2) -> +let interpretable_as_section_decl evd d1 d2 = + let open Context.Named.Declaration in + match d2, d1 with + | LocalDef _, LocalAssum _ -> false + | LocalDef (_,b1,t1), LocalDef (_,b2,t2) -> e_eq_constr_univs evd b1 b2 && e_eq_constr_univs evd t1 t2 - | (_,None,t1), (_,_,t2) -> e_eq_constr_univs evd t1 t2 + | LocalAssum (_,t1), d2 -> e_eq_constr_univs evd t1 (get_type d2) let rec decompose len c t accu = + let open Context.Rel.Declaration in if len = 0 then (c, t, accu) else match kind_of_term c, kind_of_term t with | Lambda (na, u, c), Prod (_, _, t) -> - decompose (pred len) c t ((na, None, u) :: accu) + decompose (pred len) c t (LocalAssum (na, u) :: accu) | LetIn (na, b, u, c), LetIn (_, _, _, t) -> - decompose (pred len) c t ((na, Some b, u) :: accu) + decompose (pred len) c t (LocalDef (na, b, u) :: accu) | _ -> assert false -let rec shrink ctx sign c t accu = match ctx, sign with -| [], [] -> (c, t, accu) -| p :: ctx, (id, _, _) :: sign -> - if noccurn 1 c then - let c = subst1 mkProp c in - let t = subst1 mkProp t in - shrink ctx sign c t accu - else - let c = mkLambda_or_LetIn p c in - let t = mkProd_or_LetIn p t in - let accu = match p with - | (_, None, _) -> mkVar id :: accu - | (_, Some _, _) -> accu +let rec shrink ctx sign c t accu = + let open Context.Rel.Declaration in + match ctx, sign with + | [], [] -> (c, t, accu) + | p :: ctx, decl :: sign -> + if noccurn 1 c then + let c = subst1 mkProp c in + let t = subst1 mkProp t in + shrink ctx sign c t accu + else + let c = mkLambda_or_LetIn p c in + let t = mkProd_or_LetIn p t in + let accu = if is_local_assum p then let open Context.Named.Declaration in + mkVar (get_id decl) :: accu + else accu in shrink ctx sign c t accu | _ -> assert false let shrink_entry sign const = + let open Context.Named.Declaration in let open Entries in let typ = match const.const_entry_type with | None -> assert false @@ -4506,19 +4660,22 @@ let abstract_subproof id gk tac = let open Tacticals.New in let open Tacmach.New in let open Proofview.Notations in - Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma -> + let open Context.Named.Declaration in + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in let current_sign = Global.named_context() and global_sign = Proofview.Goal.hyps gl in let sigma = Sigma.to_evar_map sigma in let evdref = ref sigma in let sign,secsign = List.fold_right - (fun (id,_,_ as d) (s1,s2) -> + (fun d (s1,s2) -> + let id = get_id d in if mem_named_context id current_sign && - interpretable_as_section_decl evdref (Context.lookup_named id current_sign) d + interpretable_as_section_decl evdref (Context.Named.lookup id current_sign) d then (s1,push_named_context_val d s2) - else (add_named_decl d s1,s2)) - global_sign (empty_named_context,empty_named_context_val) in + else (Context.Named.add d s1,s2)) + global_sign (Context.Named.empty, empty_named_context_val) in let id = next_global_ident_away id (pf_ids_of_hyps gl) in let concl = it_mkNamedProd_or_LetIn (Proofview.Goal.concl gl) sign in let concl = @@ -4546,7 +4703,7 @@ let abstract_subproof id gk tac = in let const, args = if !shrink_abstract then shrink_entry sign const - else (const, List.rev (instance_from_named_context sign)) + else (const, List.rev (Context.Named.to_instance sign)) in let cd = Entries.DefinitionEntry const in let decl = (cd, IsProof Lemma) in @@ -4555,9 +4712,9 @@ let abstract_subproof id gk tac = (* 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 solve = Proofview.tclEFFECTS effs <*> @@ -4585,7 +4742,8 @@ let tclABSTRACT name_op tac = abstract_subproof s gk tac let unify ?(state=full_transparent_state) x y = - Proofview.Goal.nf_s_enter { s_enter = begin fun gl sigma -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in try let core_flags = { (default_unify_flags ()).core_unify_flags with @@ -4609,12 +4767,6 @@ module Simple = struct let intro x = intro_move (Some x) MoveLast - let generalize_gen cl = - generalize_gen (List.map (on_fst Redexpr.out_with_occurrences) cl) - let generalize cl = - generalize_gen (List.map (fun c -> ((AllOccurrences,c),Names.Anonymous)) - cl) - let apply c = apply_with_bindings_gen false false [None,(Loc.ghost,(c,NoBindings))] let eapply c = @@ -4623,7 +4775,7 @@ module Simple = struct let case c = general_case_analysis false None (c,NoBindings) let apply_in id c = - apply_in false false None id [None,(Loc.ghost, (c, NoBindings))] None + apply_in false false id [None,(Loc.ghost, (c, NoBindings))] None end @@ -4638,11 +4790,11 @@ module New = struct open Locus let reduce_after_refine = - Proofview.V82.tactic (reduce + reduce (Lazy {rBeta=true;rIota=true;rZeta=false;rDelta=false;rConst=[]}) - {onhyps=None; concl_occs=AllOccurrences }) + {onhyps=None; concl_occs=AllOccurrences } let refine ?unsafe c = - Proofview.Refine.refine ?unsafe c <*> + Refine.refine ?unsafe c <*> reduce_after_refine end diff --git a/tactics/tactics.mli b/tactics/tactics.mli index d62d27ca3..4c4a96ec0 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -9,7 +9,6 @@ open Loc open Names open Term -open Context open Environ open Proof_type open Evd @@ -26,16 +25,16 @@ open Locus (** {6 General functions. } *) -val is_quantified_hypothesis : Id.t -> goal sigma -> bool +val is_quantified_hypothesis : Id.t -> ([`NF],'b) Proofview.Goal.t -> bool (** {6 Primitive tactics. } *) val introduction : ?check:bool -> Id.t -> unit Proofview.tactic val refine : constr -> tactic val convert_concl : ?check:bool -> types -> cast_kind -> unit Proofview.tactic -val convert_hyp : ?check:bool -> named_declaration -> unit Proofview.tactic +val convert_hyp : ?check:bool -> Context.Named.Declaration.t -> unit Proofview.tactic val convert_concl_no_check : types -> cast_kind -> unit Proofview.tactic -val convert_hyp_no_check : named_declaration -> unit Proofview.tactic +val convert_hyp_no_check : Context.Named.Declaration.t -> unit Proofview.tactic val thin : Id.t list -> tactic val mutual_fix : Id.t -> int -> (Id.t * int * constr) list -> int -> tactic @@ -50,7 +49,7 @@ val convert_leq : constr -> constr -> unit Proofview.tactic val fresh_id_in_env : Id.t list -> Id.t -> env -> Id.t val fresh_id : Id.t list -> Id.t -> goal sigma -> Id.t -val find_intro_names : rel_context -> goal sigma -> Id.t list +val find_intro_names : Context.Rel.t -> goal sigma -> Id.t list val intro : unit Proofview.tactic val introf : unit Proofview.tactic @@ -74,7 +73,7 @@ val intros : unit Proofview.tactic (** [depth_of_quantified_hypothesis b h g] returns the index of [h] in the conclusion of goal [g], up to head-reduction if [b] is [true] *) val depth_of_quantified_hypothesis : - bool -> quantified_hypothesis -> goal sigma -> int + bool -> quantified_hypothesis -> ([`NF],'b) Proofview.Goal.t -> int val intros_until : quantified_hypothesis -> unit Proofview.tactic @@ -118,6 +117,7 @@ val intros_patterns : intro_patterns -> unit Proofview.tactic val assumption : unit Proofview.tactic val exact_no_check : constr -> tactic val vm_cast_no_check : constr -> tactic +val native_cast_no_check : constr -> tactic val exact_check : constr -> unit Proofview.tactic val exact_proof : Constrexpr.constr_expr -> tactic @@ -125,51 +125,51 @@ val exact_proof : Constrexpr.constr_expr -> tactic type tactic_reduction = env -> evar_map -> constr -> constr -type change_arg = patvar_map -> evar_map -> evar_map * constr +type change_arg = patvar_map -> constr Sigma.run val make_change_arg : constr -> change_arg -val reduct_in_hyp : ?check:bool -> tactic_reduction -> hyp_location -> tactic -val reduct_option : ?check:bool -> tactic_reduction * cast_kind -> goal_location -> tactic -val reduct_in_concl : tactic_reduction * cast_kind -> tactic +val reduct_in_hyp : ?check:bool -> tactic_reduction -> hyp_location -> unit Proofview.tactic +val reduct_option : ?check:bool -> tactic_reduction * cast_kind -> goal_location -> unit Proofview.tactic +val reduct_in_concl : tactic_reduction * cast_kind -> unit Proofview.tactic val change_in_concl : (occurrences * constr_pattern) option -> change_arg -> unit Proofview.tactic val change_concl : constr -> unit Proofview.tactic val change_in_hyp : (occurrences * constr_pattern) option -> change_arg -> hyp_location -> unit Proofview.tactic -val red_in_concl : tactic -val red_in_hyp : hyp_location -> tactic -val red_option : goal_location -> tactic -val hnf_in_concl : tactic -val hnf_in_hyp : hyp_location -> tactic -val hnf_option : goal_location -> tactic -val simpl_in_concl : tactic -val simpl_in_hyp : hyp_location -> tactic -val simpl_option : goal_location -> tactic -val normalise_in_concl : tactic -val normalise_in_hyp : hyp_location -> tactic -val normalise_option : goal_location -> tactic -val normalise_vm_in_concl : tactic +val red_in_concl : unit Proofview.tactic +val red_in_hyp : hyp_location -> unit Proofview.tactic +val red_option : goal_location -> unit Proofview.tactic +val hnf_in_concl : unit Proofview.tactic +val hnf_in_hyp : hyp_location -> unit Proofview.tactic +val hnf_option : goal_location -> unit Proofview.tactic +val simpl_in_concl : unit Proofview.tactic +val simpl_in_hyp : hyp_location -> unit Proofview.tactic +val simpl_option : goal_location -> unit Proofview.tactic +val normalise_in_concl : unit Proofview.tactic +val normalise_in_hyp : hyp_location -> unit Proofview.tactic +val normalise_option : goal_location -> unit Proofview.tactic +val normalise_vm_in_concl : unit Proofview.tactic val unfold_in_concl : - (occurrences * evaluable_global_reference) list -> tactic + (occurrences * evaluable_global_reference) list -> unit Proofview.tactic val unfold_in_hyp : - (occurrences * evaluable_global_reference) list -> hyp_location -> tactic + (occurrences * evaluable_global_reference) list -> hyp_location -> unit Proofview.tactic val unfold_option : - (occurrences * evaluable_global_reference) list -> goal_location -> tactic + (occurrences * evaluable_global_reference) list -> goal_location -> unit Proofview.tactic val change : constr_pattern option -> change_arg -> clause -> tactic val pattern_option : - (occurrences * constr) list -> goal_location -> tactic -val reduce : red_expr -> clause -> tactic -val unfold_constr : global_reference -> tactic + (occurrences * constr) list -> goal_location -> unit Proofview.tactic +val reduce : red_expr -> clause -> unit Proofview.tactic +val unfold_constr : global_reference -> unit Proofview.tactic (** {6 Modification of the local context. } *) val clear : Id.t list -> tactic val clear_body : Id.t list -> unit Proofview.tactic -val unfold_body : Id.t -> tactic +val unfold_body : Id.t -> unit Proofview.tactic val keep : Id.t list -> unit Proofview.tactic val apply_clear_request : clear_flag -> bool -> constr -> unit Proofview.tactic -val specialize : constr with_bindings -> tactic +val specialize : constr with_bindings -> unit Proofview.tactic val move_hyp : Id.t -> Id.t move_location -> tactic val rename_hyp : (Id.t * Id.t) list -> unit Proofview.tactic @@ -178,8 +178,8 @@ val revert : Id.t list -> unit Proofview.tactic (** {6 Resolution tactics. } *) -val apply_type : constr -> constr list -> tactic -val bring_hyps : named_context -> unit Proofview.tactic +val apply_type : constr -> constr list -> unit Proofview.tactic +val bring_hyps : Context.Named.t -> unit Proofview.tactic val apply : constr -> unit Proofview.tactic val eapply : constr -> unit Proofview.tactic @@ -196,12 +196,12 @@ val eapply_with_bindings : constr with_bindings -> unit Proofview.tactic val cut_and_apply : constr -> unit Proofview.tactic val apply_in : - advanced_flag -> evars_flag -> clear_flag -> Id.t -> + advanced_flag -> evars_flag -> Id.t -> (clear_flag * constr with_bindings located) list -> intro_pattern option -> unit Proofview.tactic val apply_delayed_in : - advanced_flag -> evars_flag -> clear_flag -> Id.t -> + advanced_flag -> evars_flag -> Id.t -> (clear_flag * delayed_open_constr_with_bindings located) list -> intro_pattern option -> unit Proofview.tactic @@ -238,20 +238,20 @@ type elim_scheme = { elimc: constr with_bindings option; elimt: types; indref: global_reference option; - params: rel_context; (** (prm1,tprm1);(prm2,tprm2)...(prmp,tprmp) *) - nparams: int; (** number of parameters *) - predicates: rel_context; (** (Qq, (Tq_1 -> Tq_2 ->...-> Tq_nq)), (Q1,...) *) - npredicates: int; (** Number of predicates *) - branches: rel_context; (** branchr,...,branch1 *) - nbranches: int; (** Number of branches *) - args: rel_context; (** (xni, Ti_ni) ... (x1, Ti_1) *) - nargs: int; (** number of arguments *) - indarg: rel_declaration option; (** Some (H,I prm1..prmp x1...xni) - if HI is in premisses, None otherwise *) - concl: types; (** Qi x1...xni HI (f...), HI and (f...) - are optional and mutually exclusive *) - indarg_in_concl: bool; (** true if HI appears at the end of conclusion *) - farg_in_concl: bool; (** true if (f...) appears at the end of conclusion *) + params: Context.Rel.t; (** (prm1,tprm1);(prm2,tprm2)...(prmp,tprmp) *) + nparams: int; (** number of parameters *) + predicates: Context.Rel.t; (** (Qq, (Tq_1 -> Tq_2 ->...-> Tq_nq)), (Q1,...) *) + npredicates: int; (** Number of predicates *) + branches: Context.Rel.t; (** branchr,...,branch1 *) + nbranches: int; (** Number of branches *) + args: Context.Rel.t; (** (xni, Ti_ni) ... (x1, Ti_1) *) + nargs: int; (** number of arguments *) + indarg: Context.Rel.Declaration.t option; (** Some (H,I prm1..prmp x1...xni) + if HI is in premisses, None otherwise *) + concl: types; (** Qi x1...xni HI (f...), HI and (f...) + are optional and mutually exclusive *) + indarg_in_concl: bool; (** true if HI appears at the end of conclusion *) + farg_in_concl: bool; (** true if (f...) appears at the end of conclusion *) } val compute_elim_sig : ?elimc: constr with_bindings -> types -> elim_scheme @@ -385,7 +385,8 @@ val letin_pat_tac : (bool * intro_pattern_naming) option -> (** {6 Generalize tactics. } *) val generalize : constr list -> tactic -val generalize_gen : ((occurrences * constr) * Name.t) list -> tactic +val generalize_gen : (constr Locus.with_occurrences * Name.t) list -> tactic + val new_generalize : constr list -> unit Proofview.tactic val new_generalize_gen : ((occurrences * constr) * Name.t) list -> unit Proofview.tactic @@ -417,9 +418,6 @@ module Simple : sig (** Simplified version of some of the above tactics *) val intro : Id.t -> unit Proofview.tactic - val generalize : constr list -> tactic - val generalize_gen : (constr Locus.with_occurrences * Name.t) list -> tactic - val apply : constr -> unit Proofview.tactic val eapply : constr -> unit Proofview.tactic val elim : constr -> unit Proofview.tactic @@ -433,7 +431,7 @@ end module New : sig val refine : ?unsafe:bool -> constr Sigma.run -> unit Proofview.tactic - (** [refine ?unsafe c] is [Proofview.Refine.refine ?unsafe c] + (** [refine ?unsafe c] is [Refine.refine ?unsafe c] followed by beta-iota-reduction of the conclusion. *) val reduce_after_refine : unit Proofview.tactic diff --git a/tactics/tactics.mllib b/tactics/tactics.mllib index 2c5edc20e..ab8069225 100644 --- a/tactics/tactics.mllib +++ b/tactics/tactics.mllib @@ -14,15 +14,12 @@ Equality Contradiction Inv Leminv -Tacsubst Taccoerce -Tacenv Hints Auto -Tacintern +Eauto +Class_tactics Tactic_matching -Tacinterp -Evar_tactics Term_dnet +Eqdecide Autorewrite -Tactic_option diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4 deleted file mode 100644 index 9bee7ab3e..000000000 --- a/tactics/tauto.ml4 +++ /dev/null @@ -1,401 +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 *) -(************************************************************************) - -(*i camlp4deps: "grammar/grammar.cma" i*) - -open Term -open Hipattern -open Names -open Pp -open Genarg -open Stdarg -open Tacinterp -open Tactics -open Errors -open Util -open Proofview.Notations - -DECLARE PLUGIN "tauto" - -let assoc_var s ist = - let v = Id.Map.find (Names.Id.of_string s) ist.lfun in - match Value.to_constr v with - | Some c -> c - | None -> failwith "tauto: anomaly" - -(** Parametrization of tauto *) - -type tauto_flags = { - -(* Whether conjunction and disjunction are restricted to binary connectives *) - binary_mode : bool; - -(* Whether compatibility for buggy detection of binary connective is on *) - binary_mode_bugged_detection : bool; - -(* Whether conjunction and disjunction are restricted to the connectives *) -(* having the structure of "and" and "or" (up to the choice of sorts) in *) -(* contravariant position in an hypothesis *) - strict_in_contravariant_hyp : bool; - -(* Whether conjunction and disjunction are restricted to the connectives *) -(* having the structure of "and" and "or" (up to the choice of sorts) in *) -(* an hypothesis and in the conclusion *) - strict_in_hyp_and_ccl : bool; - -(* Whether unit type includes equality types *) - strict_unit : bool; -} - -(* Whether inner not are unfolded *) -let negation_unfolding = ref true - -(* Whether inner iff are unfolded *) -let iff_unfolding = ref false - -let unfold_iff () = !iff_unfolding || Flags.version_less_or_equal Flags.V8_2 - -open Goptions -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "unfolding of not in intuition"; - optkey = ["Intuition";"Negation";"Unfolding"]; - optread = (fun () -> !negation_unfolding); - optwrite = (:=) negation_unfolding } - -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "unfolding of iff in intuition"; - optkey = ["Intuition";"Iff";"Unfolding"]; - optread = (fun () -> !iff_unfolding); - optwrite = (:=) iff_unfolding } - -(** Test *) - -let make_lfun l = - let fold accu (id, v) = Id.Map.add (Id.of_string id) v accu in - List.fold_left fold Id.Map.empty l - -let is_empty ist = - if is_empty_type (assoc_var "X1" ist) then - <:tactic<idtac>> - else - <:tactic<fail>> - -(* Strictly speaking, this exceeds the propositional fragment as it - matches also equality types (and solves them if a reflexivity) *) -let is_unit_or_eq flags ist = - let test = if flags.strict_unit then is_unit_type else is_unit_or_eq_type in - if test (assoc_var "X1" ist) then - <:tactic<idtac>> - else - <:tactic<fail>> - -let is_record t = - let (hdapp,args) = decompose_app t in - match (kind_of_term hdapp) with - | Ind (ind,u) -> - let (mib,mip) = Global.lookup_inductive ind in - mib.Declarations.mind_record <> None - | _ -> false - -let bugged_is_binary t = - isApp t && - let (hdapp,args) = decompose_app t in - match (kind_of_term hdapp) with - | Ind (ind,u) -> - let (mib,mip) = Global.lookup_inductive ind in - Int.equal mib.Declarations.mind_nparams 2 - | _ -> false - -let iter_tac tacl = - List.fold_right (fun tac tacs -> <:tactic< $tac; $tacs >>) tacl - -(** Dealing with conjunction *) - -let is_conj flags ist = - let ind = assoc_var "X1" ist in - if (not flags.binary_mode_bugged_detection || bugged_is_binary ind) && - is_conjunction - ~strict:flags.strict_in_hyp_and_ccl - ~onlybinary:flags.binary_mode ind - then - <:tactic<idtac>> - else - <:tactic<fail>> - -let flatten_contravariant_conj flags ist = - let typ = assoc_var "X1" ist in - let c = assoc_var "X2" ist in - let hyp = assoc_var "id" ist in - match match_with_conjunction - ~strict:flags.strict_in_contravariant_hyp - ~onlybinary:flags.binary_mode typ - with - | Some (_,args) -> - let newtyp = valueIn (Value.of_constr (List.fold_right mkArrow args c)) in - let hyp = valueIn (Value.of_constr hyp) in - let intros = - iter_tac (List.map (fun _ -> <:tactic< intro >>) args) - <:tactic< idtac >> in - <:tactic< - let newtyp := $newtyp in - let hyp := $hyp in - assert newtyp by ($intros; apply hyp; split; assumption); - clear hyp - >> - | _ -> - <:tactic<fail>> - -(** Dealing with disjunction *) - -let constructor i = - let name = { Tacexpr.mltac_plugin = "coretactics"; mltac_tactic = "constructor" } in - (** Take care of the index: this is the second entry in constructor. *) - let name = { Tacexpr.mltac_name = name; mltac_index = 1 } in - let i = in_gen (rawwit Constrarg.wit_int_or_var) (Misctypes.ArgArg i) in - Tacexpr.TacML (Loc.ghost, name, [i]) - -let is_disj flags ist = - let t = assoc_var "X1" ist in - if (not flags.binary_mode_bugged_detection || bugged_is_binary t) && - is_disjunction - ~strict:flags.strict_in_hyp_and_ccl - ~onlybinary:flags.binary_mode t - then - <:tactic<idtac>> - else - <:tactic<fail>> - -let flatten_contravariant_disj flags ist = - let typ = assoc_var "X1" ist in - let c = assoc_var "X2" ist in - let hyp = assoc_var "id" ist in - match match_with_disjunction - ~strict:flags.strict_in_contravariant_hyp - ~onlybinary:flags.binary_mode - typ with - | Some (_,args) -> - let hyp = valueIn (Value.of_constr hyp) in - iter_tac (List.map_i (fun i arg -> - let typ = valueIn (Value.of_constr (mkArrow arg c)) in - let ci = constructor i in - <:tactic< - let typ := $typ in - let hyp := $hyp in - assert typ by (intro; apply hyp; $ci; assumption) - >>) 1 args) <:tactic< let hyp := $hyp in clear hyp >> - | _ -> - <:tactic<fail>> - - -(** Main tactic *) - -let not_dep_intros ist = - <:tactic< - repeat match goal with - | |- (forall (_: ?X1), ?X2) => intro - | |- (Coq.Init.Logic.not _) => unfold Coq.Init.Logic.not at 1; intro - end >> - -let axioms flags ist = - let t_is_unit_or_eq = tacticIn (is_unit_or_eq flags) - and t_is_empty = tacticIn is_empty in - let c1 = constructor 1 in - <:tactic< - match reverse goal with - | |- ?X1 => $t_is_unit_or_eq; $c1 - | _:?X1 |- _ => $t_is_empty; elimtype X1; assumption - | _:?X1 |- ?X1 => assumption - end >> - - -let simplif flags ist = - let t_is_unit_or_eq = tacticIn (is_unit_or_eq flags) - and t_is_conj = tacticIn (is_conj flags) - and t_flatten_contravariant_conj = tacticIn (flatten_contravariant_conj flags) - and t_flatten_contravariant_disj = tacticIn (flatten_contravariant_disj flags) - and t_is_disj = tacticIn (is_disj flags) - and t_not_dep_intros = tacticIn not_dep_intros in - let c1 = constructor 1 in - <:tactic< - $t_not_dep_intros; - repeat - (match reverse goal with - | id: ?X1 |- _ => $t_is_conj; elim id; do 2 intro; clear id - | id: (Coq.Init.Logic.iff _ _) |- _ => elim id; do 2 intro; clear id - | id: (Coq.Init.Logic.not _) |- _ => red in id - | id: ?X1 |- _ => $t_is_disj; elim id; intro; clear id - | id0: (forall (_: ?X1), ?X2), id1: ?X1|- _ => - (* generalize (id0 id1); intro; clear id0 does not work - (see Marco Maggiesi's bug PR#301) - so we instead use Assert and exact. *) - assert X2; [exact (id0 id1) | clear id0] - | id: forall (_ : ?X1), ?X2|- _ => - $t_is_unit_or_eq; cut X2; - [ intro; clear id - | (* id : forall (_: ?X1), ?X2 |- ?X2 *) - cut X1; [exact id| $c1; fail] - ] - | id: forall (_ : ?X1), ?X2|- _ => - $t_flatten_contravariant_conj - (* moved from "id:(?A/\?B)->?X2|-" to "?A->?B->?X2|-" *) - | id: forall (_: Coq.Init.Logic.iff ?X1 ?X2), ?X3|- _ => - assert (forall (_: forall _:X1, X2), forall (_: forall _: X2, X1), X3) - by (do 2 intro; apply id; split; assumption); - clear id - | id: forall (_:?X1), ?X2|- _ => - $t_flatten_contravariant_disj - (* moved from "id:(?A\/?B)->?X2|-" to "?A->?X2,?B->?X2|-" *) - | |- ?X1 => $t_is_conj; split - | |- (Coq.Init.Logic.iff _ _) => split - | |- (Coq.Init.Logic.not _) => red - end; - $t_not_dep_intros) >> - -let rec tauto_intuit flags t_reduce solver = - let t_axioms = tacticIn (axioms flags) - and t_simplif = tacticIn (simplif flags) - and t_is_disj = tacticIn (is_disj flags) in - let lfun = make_lfun [("t_solver", solver)] in - let ist = { default_ist () with lfun = lfun; } in - let vars = [Id.of_string "t_solver"] in - (vars, ist, <:tactic< - let rec t_tauto_intuit := - ($t_simplif;$t_axioms - || match reverse goal with - | id:forall(_: forall (_: ?X1), ?X2), ?X3|- _ => - cut X3; - [ intro; clear id; t_tauto_intuit - | cut (forall (_: X1), X2); - [ exact id - | generalize (fun y:X2 => id (fun x:X1 => y)); intro; clear id; - solve [ t_tauto_intuit ]]] - | id:forall (_:not ?X1), ?X3|- _ => - cut X3; - [ intro; clear id; t_tauto_intuit - | cut (not X1); [ exact id | clear id; intro; solve [t_tauto_intuit ]]] - | |- ?X1 => - $t_is_disj; solve [left;t_tauto_intuit | right;t_tauto_intuit] - end - || - (* NB: [|- _ -> _] matches any product *) - match goal with | |- forall (_ : _), _ => intro; t_tauto_intuit - | |- _ => $t_reduce;t_solver - end - || - t_solver - ) in t_tauto_intuit >>) - -let reduction_not_iff _ist = - match !negation_unfolding, unfold_iff () with - | true, true -> <:tactic< unfold Coq.Init.Logic.not, Coq.Init.Logic.iff in * >> - | true, false -> <:tactic< unfold Coq.Init.Logic.not in * >> - | false, true -> <:tactic< unfold Coq.Init.Logic.iff in * >> - | false, false -> <:tactic< idtac >> - -let t_reduction_not_iff = tacticIn reduction_not_iff - -let intuition_gen ist flags tac = - Proofview.Goal.enter { enter = begin fun gl -> - let tac = Value.of_closure ist tac in - let env = Proofview.Goal.env gl in - let vars, ist, intuition = tauto_intuit flags t_reduction_not_iff tac in - let glb_intuition = Tacintern.glob_tactic_env vars env intuition in - eval_tactic_ist ist glb_intuition - end } - -let tauto_intuitionistic flags = - Proofview.tclORELSE - (intuition_gen (default_ist ()) flags <:tactic<fail>>) - begin function (e, info) -> match e with - | Refiner.FailError _ | UserError _ -> - Tacticals.New.tclZEROMSG (str "tauto failed.") - | e -> Proofview.tclZERO ~info e - end - -let coq_nnpp_path = - let dir = List.map Id.of_string ["Classical_Prop";"Logic";"Coq"] in - Libnames.make_path (DirPath.make dir) (Id.of_string "NNPP") - -let tauto_classical flags nnpp = - Proofview.tclORELSE - (Tacticals.New.tclTHEN (apply nnpp) (tauto_intuitionistic flags)) - begin function (e, info) -> match e with - | UserError _ -> Tacticals.New.tclZEROMSG (str "Classical tauto failed.") - | e -> Proofview.tclZERO ~info e - end - -let tauto_gen flags = - (* spiwack: I use [tclBIND (tclUNIT ())] as a way to delay the effect - (in [constr_of_global]) to the application of the tactic. *) - Proofview.tclBIND - (Proofview.tclUNIT ()) - begin fun () -> try - let nnpp = Universes.constr_of_global (Nametab.global_of_path coq_nnpp_path) in - (* try intuitionistic version first to avoid an axiom if possible *) - Tacticals.New.tclORELSE (tauto_intuitionistic flags) (tauto_classical flags nnpp) - with Not_found -> - tauto_intuitionistic flags - end - -let default_intuition_tac = <:tactic< auto with * >> - -(* This is the uniform mode dealing with ->, not, iff and types isomorphic to - /\ and *, \/ and +, False and Empty_set, True and unit, _and_ eq-like types. - For the moment not and iff are still always unfolded. *) -let tauto_uniform_unit_flags = { - binary_mode = true; - binary_mode_bugged_detection = false; - strict_in_contravariant_hyp = true; - strict_in_hyp_and_ccl = true; - strict_unit = false -} - -(* This is the compatibility mode (not used) *) -let tauto_legacy_flags = { - binary_mode = true; - binary_mode_bugged_detection = true; - strict_in_contravariant_hyp = true; - strict_in_hyp_and_ccl = false; - strict_unit = false -} - -(* This is the improved mode *) -let tauto_power_flags = { - binary_mode = false; (* support n-ary connectives *) - binary_mode_bugged_detection = false; - strict_in_contravariant_hyp = false; (* supports non-regular connectives *) - strict_in_hyp_and_ccl = false; - strict_unit = false -} - -let tauto = tauto_gen tauto_uniform_unit_flags -let dtauto = tauto_gen tauto_power_flags - -TACTIC EXTEND tauto -| [ "tauto" ] -> [ tauto ] -END - -TACTIC EXTEND dtauto -| [ "dtauto" ] -> [ dtauto ] -END - -TACTIC EXTEND intuition -| [ "intuition" ] -> [ intuition_gen ist tauto_uniform_unit_flags default_intuition_tac ] -| [ "intuition" tactic(t) ] -> [ intuition_gen ist tauto_uniform_unit_flags t ] -END - -TACTIC EXTEND dintuition -| [ "dintuition" ] -> [ intuition_gen ist tauto_power_flags default_intuition_tac ] -| [ "dintuition" tactic(t) ] -> [ intuition_gen ist tauto_power_flags t ] -END diff --git a/tactics/term_dnet.ml b/tactics/term_dnet.ml index 65239a5f7..e4b45489d 100644 --- a/tactics/term_dnet.ml +++ b/tactics/term_dnet.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/tactics/term_dnet.mli b/tactics/term_dnet.mli index 58f95ac6c..fcc03befe 100644 --- a/tactics/term_dnet.mli +++ b/tactics/term_dnet.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/test-suite/Makefile b/test-suite/Makefile index 31b212900..f333ae63e 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -154,6 +154,9 @@ summary.log: $(SHOW) SUMMARY $(HIDE)$(MAKE) --quiet summary > "$@" +report: summary.log + $(HIDE)if grep -F 'Error!' summary.log ; then false; fi + ####################################################################### # Regression (and progression) tests ####################################################################### @@ -349,7 +352,7 @@ $(addsuffix .log,$(wildcard ideal-features/*.v)): %.v.log: %.v fi; \ } > "$@" -# Additionnal dependencies for module tests +# Additional 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 $< @@ -388,7 +391,7 @@ misc/deps-order.log: } > "$@" # Sort universes for the whole standard library -EXPECTED_UNIVERSES := 5 +EXPECTED_UNIVERSES := 4 # Prop is not counted universes: misc/universes.log misc/universes.log: misc/universes/all_stdlib.v @echo "TEST misc/universes" diff --git a/test-suite/bench/lists-100.v b/test-suite/bench/lists-100.v index 352c7cea7..5c64716c7 100644 --- a/test-suite/bench/lists-100.v +++ b/test-suite/bench/lists-100.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/test-suite/bench/lists_100.v b/test-suite/bench/lists_100.v index 352c7cea7..5c64716c7 100644 --- a/test-suite/bench/lists_100.v +++ b/test-suite/bench/lists_100.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/test-suite/bugs/4623.v b/test-suite/bugs/4623.v new file mode 100644 index 000000000..405d09809 --- /dev/null +++ b/test-suite/bugs/4623.v @@ -0,0 +1,5 @@ +Goal Type -> Type. +set (T := Type). +clearbody T. +refine (@id _). +Qed.
\ No newline at end of file diff --git a/test-suite/bugs/4624.v b/test-suite/bugs/4624.v new file mode 100644 index 000000000..a737afcda --- /dev/null +++ b/test-suite/bugs/4624.v @@ -0,0 +1,7 @@ +Record foo := mkfoo { type : Type }. + +Canonical Structure fooA (T : Type) := mkfoo (T -> T). + +Definition id (t : foo) (x : type t) := x. + +Definition bar := id _ ((fun x : nat => x) : _).
\ No newline at end of file diff --git a/test-suite/bugs/closed/1850.v b/test-suite/bugs/closed/1850.v new file mode 100644 index 000000000..26b48093b --- /dev/null +++ b/test-suite/bugs/closed/1850.v @@ -0,0 +1,4 @@ +Parameter P : Type -> Type -> Type. +Notation "e |= t --> v" := (P e t v) (at level 100, t at level 54). +Fail Check (nat |= nat --> nat). + diff --git a/test-suite/bugs/opened/2800.v b/test-suite/bugs/closed/2800.v index c559ab0c1..2ee438934 100644 --- a/test-suite/bugs/opened/2800.v +++ b/test-suite/bugs/closed/2800.v @@ -1,6 +1,6 @@ Goal False. -Fail intuition +intuition match goal with | |- _ => idtac " foo" end. diff --git a/test-suite/bugs/closed/3068.v b/test-suite/bugs/closed/3068.v index ced6d9594..79671ce93 100644 --- a/test-suite/bugs/closed/3068.v +++ b/test-suite/bugs/closed/3068.v @@ -56,7 +56,7 @@ Section Finite_nat_set. subst fs1. apply iff_refl. intros H. - eapply counted_list_equal_nth_char. + eapply (counted_list_equal_nth_char _ _ _ _ ?[def]). intros i. destruct (counted_def_nth fs1 i _ ) eqn:H0. (* This was not part of the initial bug report; this is to check that diff --git a/test-suite/bugs/closed/3249.v b/test-suite/bugs/closed/3249.v index d41d23173..71d457b00 100644 --- a/test-suite/bugs/closed/3249.v +++ b/test-suite/bugs/closed/3249.v @@ -5,7 +5,7 @@ Ltac ret_and_left T := lazymatch eval hnf in t with | ?a /\ ?b => constr:(proj1 T) | forall x : ?T', @?f x => - constr:(fun x : T' => $(let fx := constr:(T x) in + constr:(fun x : T' => ltac:(let fx := constr:(T x) in let t := ret_and_left fx in - exact t)$) + exact t)) end. diff --git a/test-suite/bugs/closed/3257.v b/test-suite/bugs/closed/3257.v new file mode 100644 index 000000000..d8aa6a047 --- /dev/null +++ b/test-suite/bugs/closed/3257.v @@ -0,0 +1,5 @@ +Require Import Setoid Morphisms Basics. +Lemma foo A B (P : B -> Prop) : + pointwise_relation _ impl (fun z => A -> P z) P. +Proof. + Fail reflexivity. diff --git a/test-suite/bugs/closed/3267.v b/test-suite/bugs/closed/3267.v index 5ce1ddf0c..8175d66ac 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/3285.v b/test-suite/bugs/closed/3285.v index 25162329e..68e6b7386 100644 --- a/test-suite/bugs/closed/3285.v +++ b/test-suite/bugs/closed/3285.v @@ -1,7 +1,7 @@ Goal True. Proof. match goal with - | _ => let x := constr:($(fail)$) in idtac + | _ => let x := constr:(ltac:(fail)) in idtac | _ => idtac end. Abort. diff --git a/test-suite/bugs/closed/3286.v b/test-suite/bugs/closed/3286.v index b08b7ab3c..701480fc8 100644 --- a/test-suite/bugs/closed/3286.v +++ b/test-suite/bugs/closed/3286.v @@ -6,20 +6,20 @@ Ltac make_apply_under_binders_in lem H := | forall x : ?T, @?P x => let ret := constr:(fun x' : T => let Hx := H x' in - $(let ret' := tac lem Hx in - exact ret')$) in + ltac:(let ret' := tac lem Hx in + exact ret')) in match eval cbv zeta in ret with | fun x => Some (@?P x) => let P' := (eval cbv zeta in P) in constr:(Some P') end - | _ => let ret := constr:($(match goal with + | _ => let ret := constr:(ltac:(match goal with | _ => (let H' := fresh in pose H as H'; apply lem in H'; exact (Some H')) | _ => exact (@None nat) end - )$) in + )) in let ret' := (eval cbv beta zeta in ret) in constr:(ret') | _ => constr:(@None nat) diff --git a/test-suite/bugs/closed/3314.v b/test-suite/bugs/closed/3314.v index fb3791af5..a5782298c 100644 --- a/test-suite/bugs/closed/3314.v +++ b/test-suite/bugs/closed/3314.v @@ -1,9 +1,9 @@ Require Import TestSuite.admit. Set Universe Polymorphism. Definition Lift -: $(let U1 := constr:(Type) in +: ltac:(let U1 := constr:(Type) in let U0 := constr:(Type : U1) in - exact (U0 -> U1))$ + exact (U0 -> U1)) := fun T => T. Fail Check nat:Prop. (* The command has indeed failed with message: diff --git a/test-suite/bugs/closed/3330.v b/test-suite/bugs/closed/3330.v index e6a50449d..e3b5e9435 100644 --- a/test-suite/bugs/closed/3330.v +++ b/test-suite/bugs/closed/3330.v @@ -8,7 +8,7 @@ Inductive foo : Type@{l} := bar : foo . Section MakeEq. Variables (a : foo@{i}) (b : foo@{j}). - Let t := $(let ty := type of b in exact ty)$. + Let t := ltac:(let ty := type of b in exact ty). Definition make_eq (x:=b) := a : t. End MakeEq. diff --git a/test-suite/bugs/closed/3347.v b/test-suite/bugs/closed/3347.v index 63d5c7a57..dcf5394ea 100644 --- a/test-suite/bugs/closed/3347.v +++ b/test-suite/bugs/closed/3347.v @@ -1,7 +1,7 @@ Require Import TestSuite.admit. (* File reduced by coq-bug-finder from original input, then from 12653 lines to 12453 lines, then from 11673 lines to 681 lines, then from 693 lines to 469 lines, then from 375 lines to 56 lines *) Set Universe Polymorphism. -Notation Type1 := $(let U := constr:(Type) in let gt := constr:(Set : U) in exact U)$ (only parsing). +Notation Type1 := ltac:(let U := constr:(Type) in let gt := constr:(Set : U) in exact U) (only parsing). Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. Inductive Unit : Type1 := tt : Unit. Fail Check Unit : Set. (* [Check Unit : Set] should fail if [Type1] is defined correctly *) diff --git a/test-suite/bugs/closed/3354.v b/test-suite/bugs/closed/3354.v index 14b66db36..a635285f2 100644 --- a/test-suite/bugs/closed/3354.v +++ b/test-suite/bugs/closed/3354.v @@ -1,5 +1,5 @@ Set Universe Polymorphism. -Notation Type1 := $(let U := constr:(Type) in let gt := constr:(Set : U) in exact U)$ (only parsing). +Notation Type1 := ltac:(let U := constr:(Type) in let gt := constr:(Set : U) in exact U) (only parsing). Inductive Empty : Type1 := . Fail Check Empty : Set. (* Toplevel input, characters 15-116: diff --git a/test-suite/bugs/closed/3467.v b/test-suite/bugs/closed/3467.v index 7e3711624..88ae03057 100644 --- a/test-suite/bugs/closed/3467.v +++ b/test-suite/bugs/closed/3467.v @@ -1,5 +1,5 @@ Module foo. - Notation x := $(exact I)$. + Notation x := ltac:(exact I). End foo. Module bar. Include foo. diff --git a/test-suite/bugs/closed/3487.v b/test-suite/bugs/closed/3487.v index 03c60a8ba..1321a8598 100644 --- a/test-suite/bugs/closed/3487.v +++ b/test-suite/bugs/closed/3487.v @@ -1,4 +1,4 @@ -Notation bar := $(exact I)$. +Notation bar := ltac:(exact I). Notation foo := bar (only parsing). Class baz := { x : False }. Instance: baz. diff --git a/test-suite/bugs/closed/3554.v b/test-suite/bugs/closed/3554.v new file mode 100644 index 000000000..13a79cc84 --- /dev/null +++ b/test-suite/bugs/closed/3554.v @@ -0,0 +1 @@ +Example foo (f : forall {_ : Type}, Type) : Type. diff --git a/test-suite/bugs/closed/3612.v b/test-suite/bugs/closed/3612.v index 9125ab16d..25060debe 100644 --- a/test-suite/bugs/closed/3612.v +++ b/test-suite/bugs/closed/3612.v @@ -35,6 +35,9 @@ Axiom path_path_sigma : forall {A : Type} (P : A -> Type) (u v : sigT P) (r : p..1 = q..1) (s : transport (fun x => transport P x u.2 = v.2) r p..2 = q..2), p = q. + +Declare ML Module "coretactics". + Goal forall (A : Type) (B : forall _ : A, Type) (x : @sigT A (fun x : A => B x)) (xx : @paths (@sigT A (fun x0 : A => B x0)) x x), @paths (@paths (@sigT A (fun x0 : A => B x0)) x x) xx diff --git a/test-suite/bugs/closed/3682.v b/test-suite/bugs/closed/3682.v index 2a282d221..9d37d1a2d 100644 --- a/test-suite/bugs/closed/3682.v +++ b/test-suite/bugs/closed/3682.v @@ -3,4 +3,4 @@ Class Foo. Definition bar `{Foo} (x : Set) := Set. Instance: Foo. Definition bar1 := bar nat. -Definition bar2 := bar $(admit)$. +Definition bar2 := bar ltac:(admit). diff --git a/test-suite/bugs/closed/3684.v b/test-suite/bugs/closed/3684.v index f7b137386..130d57779 100644 --- a/test-suite/bugs/closed/3684.v +++ b/test-suite/bugs/closed/3684.v @@ -1,5 +1,5 @@ Require Import TestSuite.admit. Definition foo : Set. Proof. - refine ($(abstract admit)$). + refine (ltac:(abstract admit)). Qed. diff --git a/test-suite/bugs/closed/3685.v b/test-suite/bugs/closed/3685.v index a5bea34a9..7a0c3e6f1 100644 --- a/test-suite/bugs/closed/3685.v +++ b/test-suite/bugs/closed/3685.v @@ -39,11 +39,11 @@ Module Export PointwiseCore. (G : Functor D D') : Functor (C -> D) (C' -> D'). Proof. - refine (Build_Functor + unshelve (refine (Build_Functor (C -> D) (C' -> D') _ _ - _); + _)); abstract admit. Defined. End PointwiseCore. diff --git a/test-suite/bugs/closed/3686.v b/test-suite/bugs/closed/3686.v index b650920b2..df5f66748 100644 --- a/test-suite/bugs/closed/3686.v +++ b/test-suite/bugs/closed/3686.v @@ -33,11 +33,11 @@ Module Export PointwiseCore. (G : Functor D D') : Functor (C -> D) (C' -> D'). Proof. - refine (Build_Functor + unshelve (refine (Build_Functor (C -> D) (C' -> D') _ _ - _); + _)); abstract admit. Defined. End PointwiseCore. diff --git a/test-suite/bugs/closed/3690.v b/test-suite/bugs/closed/3690.v index df9f5f476..c24173abf 100644 --- a/test-suite/bugs/closed/3690.v +++ b/test-suite/bugs/closed/3690.v @@ -18,7 +18,7 @@ Top.8} Top.6 Top.7 Top.8 |= *) *) -Definition bar := $(let t := eval compute in foo in exact t)$. +Definition bar := ltac:(let t := eval compute in foo in exact t). Check @bar. (* bar@{Top.13 Top.14 Top.15 Top.16} : Type@{Top.16+1} diff --git a/test-suite/bugs/closed/3699.v b/test-suite/bugs/closed/3699.v index 62137f0c0..8dadc2419 100644 --- a/test-suite/bugs/closed/3699.v +++ b/test-suite/bugs/closed/3699.v @@ -34,8 +34,8 @@ Module NonPrim. : forall b:B, P b. Proof. intros b. - refine (pr1 (isconnected_elim _ _)). - 2:exact b. + unshelve (refine (pr1 (isconnected_elim _ _))). + exact b. intro x. exact (transport P x.2 (d x.1)). Defined. @@ -47,8 +47,8 @@ Module NonPrim. : forall b:B, P b. Proof. intros b. - refine (pr1 (isconnected_elim _ _)). - 2:exact b. + unshelve (refine (pr1 (isconnected_elim _ _))). + exact b. intros [a p]. exact (transport P p (d a)). Defined. @@ -65,7 +65,7 @@ Module NonPrim. set (fibermap := fun a0p : hfiber f (f a) => let (a0, p) := a0p in transport P p (d a0)). Set Printing Implicit. - let G := match goal with |- ?G => constr:G end in + let G := match goal with |- ?G => constr:(G) end in first [ match goal with | [ |- (@isconnected_elim n (@hfiber A B f (f a)) (@isconnected_hfiber_conn_map n A B f H (f a)) @@ -111,8 +111,8 @@ Module Prim. : forall b:B, P b. Proof. intros b. - refine (pr1 (isconnected_elim _ _)). - 2:exact b. + unshelve (refine (pr1 (isconnected_elim _ _))). + exact b. intro x. exact (transport P x.2 (d x.1)). Defined. @@ -124,8 +124,8 @@ Module Prim. : forall b:B, P b. Proof. intros b. - refine (pr1 (isconnected_elim _ _)). - 2:exact b. + unshelve (refine (pr1 (isconnected_elim _ _))). + exact b. intros [a p]. exact (transport P p (d a)). Defined. @@ -142,7 +142,7 @@ Module Prim. set (fibermap := fun a0p : hfiber f (f a) => let (a0, p) := a0p in transport P p (d a0)). Set Printing Implicit. - let G := match goal with |- ?G => constr:G end in + let G := match goal with |- ?G => constr:(G) end in first [ match goal with | [ |- (@isconnected_elim n (@hfiber A B f (f a)) (@isconnected_hfiber_conn_map n A B f H (f a)) diff --git a/test-suite/bugs/closed/3735.v b/test-suite/bugs/closed/3735.v new file mode 100644 index 000000000..a50572ace --- /dev/null +++ b/test-suite/bugs/closed/3735.v @@ -0,0 +1,4 @@ +Require Import Coq.Program.Tactics. +Class Foo := { bar : Type }. +Fail Lemma foo : Foo -> bar. (* 'Command has indeed failed.' in both 8.4 and trunk *) +Fail Program Lemma foo : Foo -> bar.
\ No newline at end of file diff --git a/test-suite/bugs/closed/3743.v b/test-suite/bugs/closed/3743.v index 4dfb3380a..c799d4393 100644 --- a/test-suite/bugs/closed/3743.v +++ b/test-suite/bugs/closed/3743.v @@ -3,7 +3,7 @@ coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (d65496f09c4b68fa318783e53f9cd6d5c18e1eb7) *) Require Export Coq.Setoids.Setoid. -Fail Add Parametric Relation A +Add Parametric Relation A : A (@eq A) transitivity proved by transitivity as refine_rel. diff --git a/test-suite/bugs/closed/3746.v b/test-suite/bugs/closed/3746.v new file mode 100644 index 000000000..a9463f94b --- /dev/null +++ b/test-suite/bugs/closed/3746.v @@ -0,0 +1,92 @@ + +(* Bug report #3746 : Include and restricted signature *) + +Module Type MT. Parameter p : nat. End MT. +Module Type EMPTY. End EMPTY. +Module Empty. End Empty. + +(* Include of an applied functor with restricted sig : + Used to create axioms (bug report #3746), now forbidden. *) + +Module F (X:EMPTY) : MT. + Definition p := 0. +End F. + +Module InclFunctRestr. + Fail Include F(Empty). +End InclFunctRestr. + +(* A few variants (indirect restricted signature), also forbidden. *) + +Module F1 := F. +Module F2 (X:EMPTY) := F X. + +Module F3a (X:EMPTY). Definition p := 0. End F3a. +Module F3 (X:EMPTY) : MT := F3a X. + +Module InclFunctRestrBis. + Fail Include F1(Empty). + Fail Include F2(Empty). + Fail Include F3(Empty). +End InclFunctRestrBis. + +(* Recommended workaround: manual instance before the include. *) + +Module InclWorkaround. + Module Temp := F(Empty). + Include Temp. +End InclWorkaround. + +Compute InclWorkaround.p. +Print InclWorkaround.p. +Print Assumptions InclWorkaround.p. (* Closed under the global context *) + + + +(* Related situations which are ok, just to check *) + +(* A) Include of non-functor with restricted signature : + creates a proxy to initial stuff *) + +Module M : MT. + Definition p := 0. +End M. + +Module InclNonFunct. + Include M. +End InclNonFunct. + +Definition check : InclNonFunct.p = M.p := eq_refl. +Print Assumptions InclNonFunct.p. (* Closed *) + + +(* B) Include of a module type with opaque content: + The opaque content is "copy-pasted". *) + +Module Type SigOpaque. + Definition p : nat. Proof. exact 0. Qed. +End SigOpaque. + +Module InclSigOpaque. + Include SigOpaque. +End InclSigOpaque. + +Compute InclSigOpaque.p. +Print InclSigOpaque.p. +Print Assumptions InclSigOpaque.p. (* Closed *) + + +(* C) Include of an applied functor with opaque proofs : + opaque proof "copy-pasted" (and substituted). *) + +Module F' (X:EMPTY). + Definition p : nat. Proof. exact 0. Qed. +End F'. + +Module InclFunctOpa. + Include F'(Empty). +End InclFunctOpa. + +Compute InclFunctOpa.p. +Print InclFunctOpa.p. +Print Assumptions InclFunctOpa.p. (* Closed *) diff --git a/test-suite/bugs/closed/3807.v b/test-suite/bugs/closed/3807.v new file mode 100644 index 000000000..108ebf592 --- /dev/null +++ b/test-suite/bugs/closed/3807.v @@ -0,0 +1,33 @@ +Set Universe Polymorphism. +Set Printing Universes. +Unset Universe Minimization ToSet. + + +Definition foo : Type := nat. +About foo. +(* foo@{Top.1} : Type@{Top.1}*) +(* Top.1 |= *) + +Definition bar : foo -> nat. +Admitted. +About bar. +(* bar@{Top.2} : foo@{Top.2} -> nat *) +(* Top.2 |= *) + +Lemma baz@{i} : foo@{i} -> nat. +Proof. + exact bar. +Defined. + +Definition bar'@{i} : foo@{i} -> nat. + intros f. exact 0. +Admitted. +About bar'. +(* bar'@{i} : foo@{i} -> nat *) +(* i |= *) + +Axiom f@{i} : Type@{i}. +(* +*** [ f@{i} : Type@{i} ] +(* i |= *) +*)
\ No newline at end of file diff --git a/test-suite/bugs/opened/3848.v b/test-suite/bugs/closed/3848.v index a03e8ffda..c0ef02f1e 100644 --- a/test-suite/bugs/opened/3848.v +++ b/test-suite/bugs/closed/3848.v @@ -19,4 +19,4 @@ Proof. refine (functor_forall (f^-1) (fun (x:A) (y:Q (f^-1 x)) => eisretr f x # (g (f^-1 x))^-1 y)). -Fail Defined. (* Error: Attempt to save an incomplete proof *) +Defined. (* was: Error: Attempt to save an incomplete proof *) diff --git a/test-suite/bugs/opened/3849.v b/test-suite/bugs/closed/3849.v index 5290054a0..a8dc3af9c 100644 --- a/test-suite/bugs/opened/3849.v +++ b/test-suite/bugs/closed/3849.v @@ -5,4 +5,4 @@ Tactic Notation "bar" hyp_list(hs) := foo hs. Goal True. do 5 pose proof 0 as ?n0. foo n1 n2. -Fail bar n3 n4. +bar n3 n4. diff --git a/test-suite/bugs/closed/3881.v b/test-suite/bugs/closed/3881.v index 4408ab885..a327bbf2a 100644 --- a/test-suite/bugs/closed/3881.v +++ b/test-suite/bugs/closed/3881.v @@ -8,7 +8,7 @@ Reserved Notation "x -> y" (at level 99, right associativity, y at level 200). Notation "A -> B" := (forall (_ : A), B) : type_scope. Axiom admit : forall {T}, T. Notation "g 'o' f" := (fun x => g (f x)) (at level 40, left associativity). -Notation "g 'o' f" := $(let g' := g in let f' := f in exact (fun x => g' (f' x)))$ (at level 40, left associativity). (* Ensure that x is not captured in [g] or [f] in case they contain holes *) +Notation "g 'o' f" := ltac:(let g' := g in let f' := f in exact (fun x => g' (f' x))) (at level 40, left associativity). (* Ensure that x is not captured in [g] or [f] in case they contain holes *) Inductive eq {A} (x:A) : A -> Prop := eq_refl : x = x where "x = y" := (@eq _ x y) : type_scope. Arguments eq_refl {_ _}. Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y := match p with eq_refl => eq_refl end. @@ -23,7 +23,7 @@ Proof. pose (fun H => @isequiv_homotopic _ _ ((g o f) o f^-1) _ H (fun b => ap g (eisretr f b))) as k. revert k. - let x := match goal with |- let k := ?x in _ => constr:x end in + let x := match goal with |- let k := ?x in _ => constr:(x) end in intro k; clear k; pose (x _). pose (@isequiv_homotopic _ _ ((g o f) o f^-1) g _ diff --git a/test-suite/bugs/opened/3923.v b/test-suite/bugs/closed/3923.v index 6aa6b4932..0aa029e73 100644 --- a/test-suite/bugs/opened/3923.v +++ b/test-suite/bugs/closed/3923.v @@ -30,4 +30,4 @@ Axiom empty_fieldstore : cert_fieldstore. End MkCertRuntimeTypes. -Fail Extraction MkCertRuntimeTypes. +Extraction MkCertRuntimeTypes. (* Was leading to an uncaught Not_found *) diff --git a/test-suite/bugs/closed/3974.v b/test-suite/bugs/closed/3974.v new file mode 100644 index 000000000..b6be15959 --- /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 000000000..95851c813 --- /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/3998.v b/test-suite/bugs/closed/3998.v new file mode 100644 index 000000000..ced13839d --- /dev/null +++ b/test-suite/bugs/closed/3998.v @@ -0,0 +1,24 @@ +Class FieldType (F : Set) := mkFieldType { fldTy: F -> Set }. +Hint Mode FieldType + : typeclass_instances. (* The F parameter is an input *) + +Inductive I1 := C. +Inductive I2 := . + +Instance I1FieldType : FieldType I1 := { fldTy := I1_rect _ bool }. +Instance I2FieldType : FieldType I2 := { fldTy := I2_rect _ }. + +Definition RecordOf F (FT: FieldType F) := forall f:F, fldTy f. + +Class MapOps (M K : Set) := { + tgtTy: K -> Set; + update: M -> forall k:K, tgtTy k -> M +}. + +Instance RecordMapOps F (FT: FieldType F) : MapOps (RecordOf F FT) F := +{ tgtTy := fldTy; update := fun r (f: F) (x: fldTy f) z => r z }. + +Axiom ex : RecordOf _ I1FieldType. + +Definition works := (fun ex' => update ex' C true) (update ex C false). +Set Typeclasses Debug. +Definition doesnt := update (update ex C false) C true.
\ No newline at end of file diff --git a/test-suite/bugs/closed/4116.v b/test-suite/bugs/closed/4116.v index f808cb45e..5932c9c56 100644 --- a/test-suite/bugs/closed/4116.v +++ b/test-suite/bugs/closed/4116.v @@ -110,7 +110,7 @@ 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 _); + unshelve refine (let __transparent_assert_hypothesis := (_ : type) in _); [ | ( let H := match goal with H := _ |- _ => constr:(H) end in @@ -321,7 +321,7 @@ Section Grothendieck. Definition Gcategory : PreCategory. Proof. - refine (@Build_PreCategory + unshelve refine (@Build_PreCategory Pair (fun s d => Gmorphism s d) Gidentity @@ -346,7 +346,7 @@ Section Grothendieck2. Instance iscategory_grothendieck_toset : IsCategory (Gcategory F). Proof. intros s d. - refine (isequiv_adjointify _ _ _ _). + unshelve refine (isequiv_adjointify _ _ _ _). { intro m. transparent assert (H' : (s.(c) = d.(c))). diff --git a/test-suite/bugs/closed/4149.v b/test-suite/bugs/closed/4149.v new file mode 100644 index 000000000..b81c680cd --- /dev/null +++ b/test-suite/bugs/closed/4149.v @@ -0,0 +1,4 @@ +Goal forall A, A -> Type. +Proof. + intros; eauto. +Qed. diff --git a/test-suite/bugs/closed/4151.v b/test-suite/bugs/closed/4151.v new file mode 100644 index 000000000..fec64555f --- /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/4256.v b/test-suite/bugs/closed/4256.v new file mode 100644 index 000000000..3cdc4ada0 --- /dev/null +++ b/test-suite/bugs/closed/4256.v @@ -0,0 +1,43 @@ +(* Testing 8.5 regression with type classes not solving evars + redefined while trying to solve them with the type class mechanism *) + +Global Set Universe Polymorphism. +Monomorphic Universe i. +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. + +Inductive trunc_index : Type := +| minus_two : trunc_index +| trunc_S : trunc_index -> trunc_index. +Notation "-1" := (trunc_S minus_two) (at level 0). + +Class IsPointed (A : Type) := point : A. +Arguments point A {_}. + +Record pType := + { pointed_type : Type ; + ispointed_type : IsPointed pointed_type }. +Coercion pointed_type : pType >-> Sortclass. +Existing Instance ispointed_type. + +Private Inductive Trunc (n : trunc_index) (A :Type) : Type := + tr : A -> Trunc n A. +Arguments tr {n A} a. + + + +Record ooGroup := + { classifying_space : pType@{i} }. + +Definition group_loops (X : pType) +: ooGroup. +Proof. + (** This works: *) + pose (x0 := point X). + pose (H := existT (fun x:X => Trunc -1 (x = point X)) x0 (tr idpath)). + clear H x0. + (** But this doesn't: *) + pose (existT (fun x:X => Trunc -1 (x = point X)) (point X) (tr idpath)). diff --git a/test-suite/bugs/closed/4273.v b/test-suite/bugs/closed/4273.v new file mode 100644 index 000000000..591ea4b5b --- /dev/null +++ b/test-suite/bugs/closed/4273.v @@ -0,0 +1,9 @@ + + +Set Primitive Projections. +Record total2 (P : nat -> Prop) := tpair { pr1 : nat; pr2 : P pr1 }. +Theorem onefiber' (q : total2 (fun y => y = 0)) : True. +Proof. assert (foo:=pr2 _ q). simpl in foo. + destruct foo. (* Error: q is used in conclusion. *) exact I. Qed. + +Print onefiber'.
\ No newline at end of file diff --git a/test-suite/bugs/closed/4284.v b/test-suite/bugs/closed/4284.v new file mode 100644 index 000000000..0fff3026f --- /dev/null +++ b/test-suite/bugs/closed/4284.v @@ -0,0 +1,6 @@ +Set Primitive Projections. +Record total2 { T: Type } ( P: T -> Type ) := tpair { pr1 : T; pr2 : P pr1 }. +Theorem onefiber' {X : Type} (P : X -> Type) (x : X) : True. +Proof. +set (Q1 := total2 (fun f => pr1 P f = x)). +set (f1:=fun q1 : Q1 => pr2 _ (pr1 _ q1)). diff --git a/test-suite/bugs/closed/4287.v b/test-suite/bugs/closed/4287.v index 0623cf5b8..43c9b5129 100644 --- a/test-suite/bugs/closed/4287.v +++ b/test-suite/bugs/closed/4287.v @@ -118,8 +118,6 @@ 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}. +Check setlt@{Set i}. +Check setlt@{Set j}.
\ No newline at end of file diff --git a/test-suite/bugs/closed/4293.v b/test-suite/bugs/closed/4293.v new file mode 100644 index 000000000..3671c931b --- /dev/null +++ b/test-suite/bugs/closed/4293.v @@ -0,0 +1,7 @@ +Module Type Foo. +Definition T := let X := Type in Type. +End Foo. + +Module M : Foo. +Definition T := let X := Type in Type. +End M.
\ No newline at end of file diff --git a/test-suite/bugs/closed/4363.v b/test-suite/bugs/closed/4363.v new file mode 100644 index 000000000..9895548c1 --- /dev/null +++ b/test-suite/bugs/closed/4363.v @@ -0,0 +1,9 @@ +Set Printing Universes. +Definition foo : Type. +Proof. + assert (H : Set) by abstract (assert Type by abstract exact Type using bar; exact nat). + exact bar. +Defined. (* Toplevel input, characters 0-8: +Error: +The term "(fun _ : Set => bar) foo_subproof" has type +"Type@{Top.2}" while it is expected to have type "Type@{Top.1}". *) diff --git a/test-suite/bugs/closed/4375.v b/test-suite/bugs/closed/4375.v new file mode 100644 index 000000000..03af16535 --- /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/4378.v b/test-suite/bugs/closed/4378.v new file mode 100644 index 000000000..9d5916556 --- /dev/null +++ b/test-suite/bugs/closed/4378.v @@ -0,0 +1,9 @@ +Tactic Notation "epose" open_constr(a) := + let a' := fresh in + pose a as a'. +Tactic Notation "epose2" open_constr(a) tactic3(tac) := + let a' := fresh in + pose a as a'. +Goal True. + epose _. Undo. + epose2 _ idtac. diff --git a/test-suite/bugs/closed/4390.v b/test-suite/bugs/closed/4390.v new file mode 100644 index 000000000..a96a13700 --- /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 000000000..60c935459 --- /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 000000000..3566353d8 --- /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/4400.v b/test-suite/bugs/closed/4400.v new file mode 100644 index 000000000..5c23f8404 --- /dev/null +++ b/test-suite/bugs/closed/4400.v @@ -0,0 +1,19 @@ +(* -*- coq-prog-args: ("-emacs" "-require" "Coq.Compat.Coq84" "-compat" "8.4") -*- *) +Require Import Coq.Lists.List Coq.Logic.JMeq Program.Equality. +Set Printing Universes. +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/4404.v b/test-suite/bugs/closed/4404.v new file mode 100644 index 000000000..27b43a61d --- /dev/null +++ b/test-suite/bugs/closed/4404.v @@ -0,0 +1,4 @@ +Inductive Foo : Type -> Type := foo A : Foo A. +Goal True. + remember Foo. + diff --git a/test-suite/bugs/closed/4412.v b/test-suite/bugs/closed/4412.v new file mode 100644 index 000000000..4b2aae0c7 --- /dev/null +++ b/test-suite/bugs/closed/4412.v @@ -0,0 +1,4 @@ +Require Import Coq.Bool.Bool Coq.Setoids.Setoid. +Goal forall (P : forall b : bool, b = true -> Type) (x y : bool) (H : andb x y = true) (H' : P _ H), True. + intros. + Fail rewrite Bool.andb_true_iff in H. diff --git a/test-suite/bugs/closed/4420.v b/test-suite/bugs/closed/4420.v new file mode 100644 index 000000000..0e16cb239 --- /dev/null +++ b/test-suite/bugs/closed/4420.v @@ -0,0 +1,19 @@ +Module foo. + Context (Char : Type). + Axiom foo : Type -> Type. + Goal foo Char = foo Char. + change foo with (fun x => foo x). + cbv beta. + reflexivity. + Defined. +End foo. + +Inductive foo (A : Type) : Prop := I. (*Top.1*) +Lemma bar : foo Type. (*Top.3*) +Proof. + Set Printing Universes. +change foo with (fun x : Type => foo x). (*Top.4*) +cbv beta. +apply I. (* I Type@{Top.3} : (fun x : Type@{Top.4} => foo x) Type@{Top.3} *) +Defined. + diff --git a/test-suite/bugs/closed/4429.v b/test-suite/bugs/closed/4429.v new file mode 100644 index 000000000..bf0e570ab --- /dev/null +++ b/test-suite/bugs/closed/4429.v @@ -0,0 +1,31 @@ +Require Import Arith.Compare_dec. +Require Import Unicode.Utf8. + +Fixpoint my_nat_iter (n : nat) {A} (f : A → A) (x : A) : A := + match n with + | O => x + | S n' => f (my_nat_iter n' f x) + end. + +Definition gcd_IT_F (f : nat * nat → nat) (mn : nat * nat) : nat := + match mn with + | (0, 0) => 0 + | (0, S n') => S n' + | (S m', 0) => S m' + | (S m', S n') => + match le_gt_dec (S m') (S n') with + | left _ => f (S m', S n' - S m') + | right _ => f (S m' - S n', S n') + end + end. + +Axiom max_correct_l : ∀ m n : nat, m <= max m n. +Axiom max_correct_r : ∀ m n : nat, n <= max m n. + +Hint Resolve max_correct_l max_correct_r : arith. + +Theorem foo : ∀ p p' p'' : nat, p'' < S (max p (max p' p'')). +Proof. + intros. + Timeout 3 eauto with arith. +Qed. diff --git a/test-suite/bugs/closed/4433.v b/test-suite/bugs/closed/4433.v new file mode 100644 index 000000000..9eeb86468 --- /dev/null +++ b/test-suite/bugs/closed/4433.v @@ -0,0 +1,29 @@ +Require Import Coq.Arith.Arith Coq.Init.Wf. +Axiom proof_admitted : False. +Goal exists x y z : nat, Fix + Wf_nat.lt_wf + (fun _ => nat -> nat) + (fun x' f => match x' as x'0 + return match x'0 with + | 0 => True + | S x'' => x'' < x' + end + -> nat -> nat + with + | 0 => fun _ _ => 0 + | S x'' => f x'' + end + (match x' with + | 0 => I + | S x'' => (Nat.lt_succ_diag_r _) + end)) + z + y + = 0. +Proof. + do 3 (eexists; [ shelve.. | ]). + match goal with |- ?G => let G' := (eval lazy in G) in change G with G' end. + case proof_admitted. + Unshelve. + all:constructor. +Defined.
\ No newline at end of file diff --git a/test-suite/bugs/closed/4443.v b/test-suite/bugs/closed/4443.v new file mode 100644 index 000000000..66dfa0e68 --- /dev/null +++ b/test-suite/bugs/closed/4443.v @@ -0,0 +1,31 @@ +Set Universe Polymorphism. + +Record TYPE@{i} := cType { + type : Type@{i}; +}. + +Definition PROD@{i j k} + (A : Type@{i}) + (B : A -> Type@{j}) + : TYPE@{k}. +Proof. + refine (cType@{i} _). ++ refine (forall x : A, B x). +Defined. + +Local Unset Strict Universe Declaration. +Definition PRODinj + (A : Type@{i}) + (B : A -> Type) + : TYPE. +Proof. + refine (cType@{i} _). ++ refine (forall x : A, B x). +Defined. + + Monomorphic Universe i j. + Monomorphic Constraint j < i. +Set Printing Universes. +Check PROD@{i i i}. +Check PRODinj@{i j}. +Fail Check PRODinj@{j i}.
\ No newline at end of file diff --git a/test-suite/bugs/closed/4453.v b/test-suite/bugs/closed/4453.v new file mode 100644 index 000000000..009dd5e3c --- /dev/null +++ b/test-suite/bugs/closed/4453.v @@ -0,0 +1,8 @@ + +Section Foo. +Variable A : Type. +Lemma foo : A -> True. now intros _. Qed. +Goal Type -> True. +rename A into B. +intros A. +Fail apply foo. diff --git a/test-suite/bugs/closed/4456.v b/test-suite/bugs/closed/4456.v new file mode 100644 index 000000000..a32acf789 --- /dev/null +++ b/test-suite/bugs/closed/4456.v @@ -0,0 +1,647 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-R" "." "Fiat" "-top" "BooleanRecognizerMin" "-R" "." "Top") -*- *) +(* File reduced by coq-bug-finder from original input, then from 2475 lines to 729 lines, then from 746 lines to 658 lines, then from 675 lines to 658 lines *) +(* coqc version 8.5beta3 (November 2015) compiled on Nov 11 2015 18:23:0 with OCaml 4.01.0 + coqtop version 8.5beta3 (November 2015) *) +(* Variable P : forall n m : nat, n = m -> Prop. *) +(* Axiom Prefl : forall n : nat, P n n eq_refl. *) +Axiom proof_admitted : False. + +Tactic Notation "admit" := case proof_admitted. + +Require Coq.Program.Program. +Require Coq.Strings.String. +Require Coq.omega.Omega. +Module Export Fiat_DOT_Common. +Module Export Fiat. +Module Common. +Import Coq.Lists.List. +Export Coq.Program.Program. + +Global Set Implicit Arguments. + +Global Coercion is_true : bool >-> Sortclass. +Coercion bool_of_sum {A B} (b : sum A B) : bool := if b then true else false. + +Fixpoint ForallT {T} (P : T -> Type) (ls : list T) : Type + := match ls return Type with + | nil => True + | x::xs => (P x * ForallT P xs)%type + end. +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. + +End Common. + +End Fiat. + +End Fiat_DOT_Common. +Module Export Fiat_DOT_Parsers_DOT_StringLike_DOT_Core. +Module Export Fiat. +Module Export Parsers. +Module Export StringLike. +Module Export Core. +Import Coq.Relations.Relation_Definitions. +Import Coq.Classes.Morphisms. + +Local Coercion is_true : bool >-> Sortclass. + +Module Export StringLike. + Class StringLike {Char : Type} := + { + String :> Type; + is_char : String -> Char -> bool; + length : String -> nat; + take : nat -> String -> String; + drop : nat -> String -> String; + get : nat -> String -> option Char; + unsafe_get : nat -> String -> Char; + bool_eq : String -> String -> bool; + beq : relation String := fun x y => bool_eq x y + }. + + Arguments StringLike : clear implicits. + Infix "=s" := (@beq _ _) (at level 70, no associativity) : type_scope. + Notation "s ~= [ ch ]" := (is_char s ch) (at level 70, no associativity) : string_like_scope. + Local Open Scope string_like_scope. + + Class StringLikeProperties (Char : Type) `{StringLike Char} := + { + singleton_unique : forall s ch ch', s ~= [ ch ] -> s ~= [ ch' ] -> ch = ch'; + singleton_exists : forall s, length s = 1 -> exists ch, s ~= [ ch ]; + get_0 : forall s ch, take 1 s ~= [ ch ] <-> get 0 s = Some ch; + get_S : forall n s, get (S n) s = get n (drop 1 s); + unsafe_get_correct : forall n s ch, get n s = Some ch -> unsafe_get n s = ch; + length_singleton : forall s ch, s ~= [ ch ] -> length s = 1; + bool_eq_char : forall s s' ch, s ~= [ ch ] -> s' ~= [ ch ] -> s =s s'; + is_char_Proper :> Proper (beq ==> eq ==> eq) is_char; + length_Proper :> Proper (beq ==> eq) length; + take_Proper :> Proper (eq ==> beq ==> beq) take; + drop_Proper :> Proper (eq ==> beq ==> beq) drop; + bool_eq_Equivalence :> Equivalence beq; + bool_eq_empty : forall str str', length str = 0 -> length str' = 0 -> str =s str'; + take_short_length : forall str n, n <= length str -> length (take n str) = n; + take_long : forall str n, length str <= n -> take n str =s str; + take_take : forall str n m, take n (take m str) =s take (min n m) str; + drop_length : forall str n, length (drop n str) = length str - n; + drop_0 : forall str, drop 0 str =s str; + drop_drop : forall str n m, drop n (drop m str) =s drop (n + m) str; + drop_take : forall str n m, drop n (take m str) =s take (m - n) (drop n str); + take_drop : forall str n m, take n (drop m str) =s drop m (take (n + m) str); + bool_eq_from_get : forall str str', (forall n, get n str = get n str') -> str =s str' + }. +Global Arguments StringLikeProperties _ {_}. +End StringLike. + +End Core. + +End StringLike. + +End Parsers. + +End Fiat. + +End Fiat_DOT_Parsers_DOT_StringLike_DOT_Core. + +Module Export Fiat_DOT_Parsers_DOT_ContextFreeGrammar_DOT_Core. +Module Export Fiat. +Module Export Parsers. +Module Export ContextFreeGrammar. +Module Export Core. +Import Coq.Strings.String. +Import Coq.Lists.List. +Export Fiat.Parsers.StringLike.Core. + +Section cfg. + Context {Char : Type}. + + Section definitions. + + Inductive item := + | Terminal (_ : Char) + | 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. + +Arguments item _ : clear implicits. +Arguments production _ : clear implicits. +Arguments productions _ : clear implicits. +Arguments grammar _ : clear implicits. + +End Core. + +End ContextFreeGrammar. + +End Parsers. + +End Fiat. + +End Fiat_DOT_Parsers_DOT_ContextFreeGrammar_DOT_Core. + +Module Export Fiat_DOT_Parsers_DOT_BaseTypes. +Module Export Fiat. +Module Export Parsers. +Module Export BaseTypes. +Import Coq.Arith.Wf_nat. + +Local Coercion is_true : bool >-> Sortclass. + +Section recursive_descent_parser. + Context {Char} {HSL : StringLike Char} {G : grammar Char}. + + Class parser_computational_predataT := + { nonterminals_listT : Type; + nonterminal_carrierT : Type; + of_nonterminal : String.string -> nonterminal_carrierT; + to_nonterminal : nonterminal_carrierT -> String.string; + initial_nonterminals_data : nonterminals_listT; + nonterminals_length : nonterminals_listT -> nat; + is_valid_nonterminal : nonterminals_listT -> nonterminal_carrierT -> bool; + remove_nonterminal : nonterminals_listT -> nonterminal_carrierT -> nonterminals_listT }. + + Class parser_removal_dataT' `{predata : parser_computational_predataT} := + { nonterminals_listT_R : nonterminals_listT -> nonterminals_listT -> Prop + := ltof _ nonterminals_length; + nonterminals_length_zero : forall ls, + nonterminals_length ls = 0 + -> forall nt, is_valid_nonterminal ls nt = false; + remove_nonterminal_dec : forall ls nonterminal, + is_valid_nonterminal ls nonterminal + -> nonterminals_listT_R (remove_nonterminal ls nonterminal) ls; + remove_nonterminal_noninc : forall ls nonterminal, + ~nonterminals_listT_R ls (remove_nonterminal ls nonterminal); + initial_nonterminals_correct : forall nonterminal, + is_valid_nonterminal initial_nonterminals_data (of_nonterminal nonterminal) <-> List.In nonterminal (Valid_nonterminals G); + initial_nonterminals_correct' : forall nonterminal, + is_valid_nonterminal initial_nonterminals_data nonterminal <-> List.In (to_nonterminal nonterminal) (Valid_nonterminals G); + to_of_nonterminal : forall nonterminal, + List.In nonterminal (Valid_nonterminals G) + -> to_nonterminal (of_nonterminal nonterminal) = nonterminal; + of_to_nonterminal : forall nonterminal, + is_valid_nonterminal initial_nonterminals_data nonterminal + -> of_nonterminal (to_nonterminal nonterminal) = nonterminal; + ntl_wf : well_founded nonterminals_listT_R + := well_founded_ltof _ _; + remove_nonterminal_1 + : forall ls ps ps', + is_valid_nonterminal (remove_nonterminal ls ps) ps' + -> is_valid_nonterminal ls ps'; + remove_nonterminal_2 + : forall ls ps ps', + is_valid_nonterminal (remove_nonterminal ls ps) ps' = false + <-> is_valid_nonterminal ls ps' = false \/ ps = ps' }. + + Class split_dataT := + { split_string_for_production + : item Char -> production Char -> String -> list nat }. + + Class boolean_parser_dataT := + { predata :> parser_computational_predataT; + split_data :> split_dataT }. +End recursive_descent_parser. + +End BaseTypes. + +End Parsers. + +End Fiat. + +End Fiat_DOT_Parsers_DOT_BaseTypes. + +Module Export Fiat_DOT_Common_DOT_List_DOT_Operations. +Module Export Fiat. +Module Export Common. +Module Export List. +Module Export Operations. + +Import Coq.Lists.List. + +Module Export List. + Section InT. + Context {A : Type} (a : A). + + Fixpoint InT (ls : list A) : Set + := match ls return Set with + | nil => False + | b :: m => (b = a) + InT m + end%type. + End InT. + + End List. + +End Operations. + +End List. + +End Common. + +End Fiat. + +End Fiat_DOT_Common_DOT_List_DOT_Operations. + +Module Export Fiat_DOT_Parsers_DOT_StringLike_DOT_Properties. +Module Export Fiat. +Module Export Parsers. +Module Export StringLike. +Module Export Properties. + +Section String. + Context {Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char}. + + Lemma take_length {str n} + : length (take n str) = min n (length str). +admit. +Defined. + + End String. + +End Properties. + +End StringLike. + +End Parsers. + +End Fiat. + +End Fiat_DOT_Parsers_DOT_StringLike_DOT_Properties. + +Module Export Fiat_DOT_Parsers_DOT_ContextFreeGrammar_DOT_Properties. +Module Export Fiat. +Module Export Parsers. +Module Export ContextFreeGrammar. +Module Export Properties. + +Local Open Scope list_scope. +Definition production_is_reachableT {Char} (G : grammar Char) (p : production Char) + := { nt : _ + & { prefix : _ + & List.In nt (Valid_nonterminals G) + * List.InT + (prefix ++ p) + (Lookup G nt) } }%type. + +End Properties. + +End ContextFreeGrammar. + +End Parsers. + +End Fiat. + +End Fiat_DOT_Parsers_DOT_ContextFreeGrammar_DOT_Properties. + +Module Export Fiat_DOT_Parsers_DOT_MinimalParse. +Module Export Fiat. +Module Export Parsers. +Module Export MinimalParse. +Import Coq.Lists.List. +Import Fiat.Parsers.ContextFreeGrammar.Core. + +Local Coercion is_true : bool >-> Sortclass. +Local Open Scope string_like_scope. + +Section cfg. + Context {Char} {HSL : StringLike Char} {G : grammar Char}. + Context {predata : @parser_computational_predataT} + {rdata' : @parser_removal_dataT' _ G predata}. + + Inductive minimal_parse_of + : forall (len0 : nat) (valid : nonterminals_listT) + (str : String), + productions Char -> Type := + | MinParseHead : forall len0 valid str pat pats, + @minimal_parse_of_production len0 valid str pat + -> @minimal_parse_of len0 valid str (pat::pats) + | MinParseTail : forall len0 valid str pat pats, + @minimal_parse_of len0 valid str pats + -> @minimal_parse_of len0 valid str (pat::pats) + with minimal_parse_of_production + : forall (len0 : nat) (valid : nonterminals_listT) + (str : String), + production Char -> Type := + | MinParseProductionNil : forall len0 valid str, + length str = 0 + -> @minimal_parse_of_production len0 valid str nil + | MinParseProductionCons : forall len0 valid str n pat pats, + length str <= len0 + -> @minimal_parse_of_item len0 valid (take n str) pat + -> @minimal_parse_of_production len0 valid (drop n str) pats + -> @minimal_parse_of_production len0 valid str (pat::pats) + with minimal_parse_of_item + : forall (len0 : nat) (valid : nonterminals_listT) + (str : String), + item Char -> Type := + | MinParseTerminal : forall len0 valid str ch, + str ~= [ ch ] + -> @minimal_parse_of_item len0 valid str (Terminal ch) + | MinParseNonTerminal + : forall len0 valid str (nt : String.string), + @minimal_parse_of_nonterminal len0 valid str nt + -> @minimal_parse_of_item len0 valid str (NonTerminal nt) + with minimal_parse_of_nonterminal + : forall (len0 : nat) (valid : nonterminals_listT) + (str : String), + String.string -> Type := + | MinParseNonTerminalStrLt + : forall len0 valid (nt : String.string) str, + length str < len0 + -> is_valid_nonterminal initial_nonterminals_data (of_nonterminal nt) + -> @minimal_parse_of (length str) initial_nonterminals_data str (Lookup G nt) + -> @minimal_parse_of_nonterminal len0 valid str nt + | MinParseNonTerminalStrEq + : forall len0 str valid nonterminal, + length str = len0 + -> is_valid_nonterminal initial_nonterminals_data (of_nonterminal nonterminal) + -> is_valid_nonterminal valid (of_nonterminal nonterminal) + -> @minimal_parse_of len0 (remove_nonterminal valid (of_nonterminal nonterminal)) str (Lookup G nonterminal) + -> @minimal_parse_of_nonterminal len0 valid str nonterminal. + +End cfg. + +End MinimalParse. + +End Parsers. + +End Fiat. + +End Fiat_DOT_Parsers_DOT_MinimalParse. + +Module Export Fiat_DOT_Parsers_DOT_CorrectnessBaseTypes. +Module Export Fiat. +Module Export Parsers. +Module Export CorrectnessBaseTypes. +Import Coq.Lists.List. +Import Fiat.Parsers.ContextFreeGrammar.Core. +Import Fiat_DOT_Common.Fiat.Common. +Section general. + Context {Char} {HSL : StringLike Char} {G : grammar Char}. + + Definition split_list_completeT_for {data : @parser_computational_predataT} + {len0 valid} + (it : item Char) (its : production Char) + (str : String) + (pf : length str <= len0) + (split_list : list nat) + + := ({ n : nat + & (minimal_parse_of_item (G := G) (predata := data) len0 valid (take n str) it) + * (minimal_parse_of_production (G := G) len0 valid (drop n str) its) }%type) + -> ({ n : nat + & (In (min (length str) n) (map (min (length str)) split_list)) + * (minimal_parse_of_item (G := G) len0 valid (take n str) it) + * (minimal_parse_of_production (G := G) len0 valid (drop n str) its) }%type). + + Definition split_list_completeT {data : @parser_computational_predataT} + (splits : item Char -> production Char -> String -> list nat) + := forall len0 valid str (pf : length str <= len0) nt, + is_valid_nonterminal initial_nonterminals_data (of_nonterminal nt) + -> ForallT + (Forall_tails + (fun prod + => match prod return Type with + | nil => True + | it::its + => @split_list_completeT_for data len0 valid it its str pf (splits it its str) + end)) + (Lookup G nt). + + Class boolean_parser_completeness_dataT' {data : boolean_parser_dataT} := + { split_string_for_production_complete + : split_list_completeT split_string_for_production }. +End general. + +End CorrectnessBaseTypes. + +End Parsers. + +End Fiat. + +End Fiat_DOT_Parsers_DOT_CorrectnessBaseTypes. + +Module Export Fiat. +Module Export Parsers. +Module Export ContextFreeGrammar. +Module Export Valid. +Export Fiat.Parsers.StringLike.Core. + +Section cfg. + Context {Char : Type} {HSL : StringLike Char} (G : grammar Char) + {predata : parser_computational_predataT}. + + Definition item_valid (it : item Char) + := match it with + | Terminal _ => True + | NonTerminal nt' => is_true (is_valid_nonterminal initial_nonterminals_data (of_nonterminal nt')) + end. + + Definition production_valid pat + := List.Forall item_valid pat. + + Definition productions_valid pats + := List.Forall production_valid pats. + + Definition grammar_valid + := forall nt, + List.In nt (Valid_nonterminals G) + -> productions_valid (Lookup G nt). +End cfg. + +End Valid. + +Section app. + Context {Char : Type} {HSL : StringLike Char} (G : grammar Char) + {predata : parser_computational_predataT}. + + Lemma hd_production_valid + (it : item Char) + (its : production Char) + (H : production_valid (it :: its)) + : item_valid it. +admit. +Defined. + + Lemma production_valid_cons + (it : item Char) + (its : production Char) + (H : production_valid (it :: its)) + : production_valid its. +admit. +Defined. + + End app. + +Import Coq.Lists.List. +Import Coq.omega.Omega. +Import Fiat_DOT_Common.Fiat.Common. +Import Fiat.Parsers.ContextFreeGrammar.Valid. +Local Open Scope string_like_scope. + +Section recursive_descent_parser. + Context {Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char} (G : grammar Char). + Context {data : @boolean_parser_dataT Char _} + {cdata : @boolean_parser_completeness_dataT' Char _ G data} + {rdata : @parser_removal_dataT' _ G _} + {gvalid : grammar_valid G}. + + Local Notation dec T := (T + (T -> False))%type (only parsing). + + Local Notation iffT x y := ((x -> y) * (y -> x))%type (only parsing). + + Lemma dec_prod {A B} (HA : dec A) (HB : dec B) : dec (A * B). +admit. +Defined. + + Lemma dec_In {A} {P : A -> Type} (HA : forall a, dec (P a)) ls + : dec { a : _ & (In a ls * P a) }. +admit. +Defined. + + Section item. + Context {len0 valid} + (str : String) + (str_matches_nonterminal' + : nonterminal_carrierT -> bool) + (str_matches_nonterminal + : forall nt : nonterminal_carrierT, + dec (minimal_parse_of_nonterminal (G := G) len0 valid str (to_nonterminal nt))). + + Section valid. + Context (Hmatches + : forall nt, + is_valid_nonterminal initial_nonterminals_data nt + -> str_matches_nonterminal nt = str_matches_nonterminal' nt :> bool) + (it : item Char) + (Hvalid : item_valid it). + + Definition parse_item' + : dec (minimal_parse_of_item (G := G) len0 valid str it). + Proof. + clear Hvalid. + refine (match it return dec (minimal_parse_of_item len0 valid str it) with + | Terminal ch => if Sumbool.sumbool_of_bool (str ~= [ ch ]) + then inl (MinParseTerminal _ _ _ _ _) + else inr (fun _ => !) + | NonTerminal nt => if str_matches_nonterminal (of_nonterminal nt) + then inl (MinParseNonTerminal _) + else inr (fun _ => !) + end); + clear str_matches_nonterminal Hmatches; + admit. + Defined. + End valid. + + End item. + Context {len0 valid} + (parse_nonterminal + : forall (str : String) (len : nat) (Hlen : length str = len) (pf : len <= len0) (nt : nonterminal_carrierT), + dec (minimal_parse_of_nonterminal (G := G) len0 valid str (to_nonterminal nt))). + + Lemma dec_in_helper {ls it its str} + : iffT {n0 : nat & + (In (min (length str) n0) (map (min (length str)) ls) * + minimal_parse_of_item (G := G) len0 valid (take n0 str) it * + minimal_parse_of_production (G := G) len0 valid (drop n0 str) its)%type} + {n0 : nat & + (In n0 ls * + (minimal_parse_of_item (G := G) len0 valid (take n0 str) it * + minimal_parse_of_production (G := G) len0 valid (drop n0 str) its))%type}. +admit. +Defined. + + Lemma parse_production'_helper {str it its} (pf : length str <= len0) + : dec {n0 : nat & + (minimal_parse_of_item (G := G) len0 valid (take n0 str) it * + minimal_parse_of_production (G := G) len0 valid (drop n0 str) its)%type} + -> dec (minimal_parse_of_production (G := G) len0 valid str (it :: its)). +admit. +Defined. + Local Ltac t_parse_production_for := repeat + match goal with + | [ H : (beq_nat _ _) = true |- _ ] => apply EqNat.beq_nat_true in H + | _ => progress subst + | _ => solve [ constructor; assumption ] + | [ H : minimal_parse_of_production _ _ _ nil |- _ ] => (inversion H; clear H) + | [ H : minimal_parse_of_production _ _ _ (_::_) |- _ ] => (inversion H; clear H) + | [ H : ?x = 0, H' : context[?x] |- _ ] => rewrite H in H' + | _ => progress simpl in * + | _ => discriminate + | [ H : forall x, (_ * _)%type -> _ |- _ ] => specialize (fun x y z => H x (y, z)) + | _ => solve [ eauto with nocore ] + | _ => solve [ apply Min.min_case_strong; omega ] + | _ => omega + | [ H : production_valid (_::_) |- _ ] + => let H' := fresh in + pose proof H as H'; + apply production_valid_cons in H; + apply hd_production_valid in H' + end. + + Definition parse_production'_for + (splits : item Char -> production Char -> String -> list nat) + (Hsplits : forall str it its (Hreachable : production_is_reachableT G (it::its)) pf', split_list_completeT_for (len0 := len0) (G := G) (valid := valid) it its str pf' (splits it its str)) + (str : String) + (len : nat) + (Hlen : length str = len) + (pf : len <= len0) + (prod : production Char) + (Hreachable : production_is_reachableT G prod) + : dec (minimal_parse_of_production (G := G) len0 valid str prod). + Proof. + revert prod Hreachable str len Hlen pf. + refine + ((fun pf_helper => + list_rect + (fun prod => + forall (Hreachable : production_is_reachableT G prod) + (str : String) + (len : nat) + (Hlen : length str = len) + (pf : len <= len0), + dec (minimal_parse_of_production (G := G) len0 valid str prod)) + ( + fun Hreachable str len Hlen pf + => match Utils.dec (beq_nat len 0) with + | left H => inl _ + | right H => inr (fun p => _) + end) + (fun it its parse_production' Hreachable str len Hlen pf + => parse_production'_helper + _ + (let parse_item := (fun n pf => parse_item' (parse_nonterminal (take n str) (len := min n len) (eq_trans take_length (f_equal (min _) Hlen)) pf) it) in + let parse_item := (fun n => parse_item n (Min.min_case_strong n len (fun k => k <= len0) (fun Hlen => (Nat.le_trans _ _ _ Hlen pf)) (fun Hlen => pf))) in + let parse_production := (fun n => parse_production' (pf_helper it its Hreachable) (drop n str) (len - n) (eq_trans (drop_length _ _) (f_equal (fun x => x - _) Hlen)) (Nat.le_trans _ _ _ (Nat.le_sub_l _ _) pf)) in + match dec_In + (fun n => dec_prod (parse_item n) (parse_production n)) + (splits it its str) + with + | inl p => inl (existT _ (projT1 p) (snd (projT2 p))) + | inr p + => let pf' := (Nat.le_trans _ _ _ (Nat.eq_le_incl _ _ Hlen) pf) in + let H := (_ : split_list_completeT_for (G := G) (len0 := len0) (valid := valid) it its str pf' (splits it its str)) in + inr (fun p' => p (fst dec_in_helper (H p'))) + end) + )) _); + [ clear parse_nonterminal Hsplits splits rdata cdata + | clear parse_nonterminal Hsplits splits rdata cdata + | .. + | admit ]. + abstract t_parse_production_for. + abstract t_parse_production_for. + abstract t_parse_production_for. + abstract t_parse_production_for. + Defined. diff --git a/test-suite/bugs/closed/4462.v b/test-suite/bugs/closed/4462.v new file mode 100644 index 000000000..c680518c6 --- /dev/null +++ b/test-suite/bugs/closed/4462.v @@ -0,0 +1,7 @@ +Variables P Q : Prop. +Axiom pqrw : P <-> Q. + +Require Setoid. + +Goal P -> Q. +unshelve (rewrite pqrw). diff --git a/test-suite/bugs/closed/4467.v b/test-suite/bugs/closed/4467.v new file mode 100644 index 000000000..6f8631d45 --- /dev/null +++ b/test-suite/bugs/closed/4467.v @@ -0,0 +1,15 @@ +(* Fixing missing test for variable shadowing *) + +Definition test (x y:bool*bool) := + match x with + | (e as e1, (true) as e2) + | ((true) as e1, e as e2) => + let '(e, b) := y in + e + | _ => true + end. + +Goal test (true,false) (true,true) = true. +(* used to evaluate to "false = true" in 8.4 *) +reflexivity. +Qed. diff --git a/test-suite/bugs/closed/4479.v b/test-suite/bugs/closed/4479.v new file mode 100644 index 000000000..921579d1e --- /dev/null +++ b/test-suite/bugs/closed/4479.v @@ -0,0 +1,3 @@ +Goal True. +Fail autorewrite with foo. +try autorewrite with foo. diff --git a/test-suite/bugs/closed/4480.v b/test-suite/bugs/closed/4480.v new file mode 100644 index 000000000..08a86330f --- /dev/null +++ b/test-suite/bugs/closed/4480.v @@ -0,0 +1,12 @@ +Require Import Setoid. + +Definition proj (P Q : Prop) := P. + +Lemma foo (P : Prop) : proj P P = P. +Admitted. +Lemma trueI : True <-> True. +Admitted. +Goal True. + Fail setoid_rewrite foo. + Fail setoid_rewrite trueI. +
\ No newline at end of file diff --git a/test-suite/bugs/closed/4484.v b/test-suite/bugs/closed/4484.v new file mode 100644 index 000000000..f988539d6 --- /dev/null +++ b/test-suite/bugs/closed/4484.v @@ -0,0 +1,10 @@ +(* Testing 8.5 regression with type classes not solving evars + redefined while trying to solve them with the type class mechanism *) + +Class A := {}. +Axiom foo : forall {ac : A}, bool. +Lemma bar (ac : A) : True. +Check (match foo as k return foo = k -> True with + | true => _ + | false => _ + end eq_refl). diff --git a/test-suite/bugs/closed/4495.v b/test-suite/bugs/closed/4495.v new file mode 100644 index 000000000..8b032db5f --- /dev/null +++ b/test-suite/bugs/closed/4495.v @@ -0,0 +1 @@ +Fail Notation "'forall' x .. y ',' P " := (forall x, .. (forall y, P) ..) (at level 200, x binder, y binder). diff --git a/test-suite/bugs/closed/4503.v b/test-suite/bugs/closed/4503.v new file mode 100644 index 000000000..f54d6433d --- /dev/null +++ b/test-suite/bugs/closed/4503.v @@ -0,0 +1,37 @@ +Require Coq.Classes.RelationClasses. + +Class PreOrder (A : Type) (r : A -> A -> Type) : Type := +{ refl : forall x, r x x }. + +(* FAILURE 1 *) + +Section foo. + Polymorphic Universes A. + Polymorphic Context {A : Type@{A}} {rA : A -> A -> Prop} {PO : PreOrder A rA}. + + Fail Definition foo := PO. +End foo. + + +Module ILogic. + +Set Universe Polymorphism. + +(* Logical connectives *) +Class ILogic@{L} (A : Type@{L}) : Type := mkILogic +{ + lentails: A -> A -> Prop; + lentailsPre:> RelationClasses.PreOrder lentails +}. + + +End ILogic. + +Set Printing Universes. + +(* There is stil a problem if the class is universe polymorphic *) +Section Embed_ILogic_Pre. + Polymorphic Universes A T. + Fail Context {A : Type@{A}} {ILA: ILogic.ILogic@{A} A}. + +End Embed_ILogic_Pre.
\ No newline at end of file diff --git a/test-suite/bugs/closed/4511.v b/test-suite/bugs/closed/4511.v new file mode 100644 index 000000000..0cdb3aee4 --- /dev/null +++ b/test-suite/bugs/closed/4511.v @@ -0,0 +1,3 @@ +Goal True. +Fail evar I. + diff --git a/test-suite/bugs/closed/4519.v b/test-suite/bugs/closed/4519.v new file mode 100644 index 000000000..ccbc47d20 --- /dev/null +++ b/test-suite/bugs/closed/4519.v @@ -0,0 +1,21 @@ +Set Universe Polymorphism. +Section foo. + Universe i. + Context (foo : Type@{i}) (bar : Type@{i}). + Definition qux@{i} (baz : Type@{i}) := foo -> bar. +End foo. +Set Printing Universes. +Print qux. (* qux@{Top.42 Top.43} = +fun foo bar _ : Type@{Top.42} => foo -> bar + : Type@{Top.42} -> Type@{Top.42} -> Type@{Top.42} -> Type@{Top.42} +(* Top.42 Top.43 |= *) +(* This is wrong; the first two types are equal, but the last one is not *) + +qux is universe polymorphic +Argument scopes are [type_scope type_scope type_scope] + *) +Check qux nat nat nat : Set. +Check qux nat nat Set : Set. (* Error: +The term "qux@{Top.50 Top.51} ?T ?T0 Set" has type "Type@{Top.50}" while it is +expected to have type "Set" +(universe inconsistency: Cannot enforce Top.50 = Set because Set < Top.50). *)
\ No newline at end of file diff --git a/test-suite/bugs/closed/4533.v b/test-suite/bugs/closed/4533.v new file mode 100644 index 000000000..ae17fb145 --- /dev/null +++ b/test-suite/bugs/closed/4533.v @@ -0,0 +1,226 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-nois" "-indices-matter" "-R" "." "Top" "-top" "bug_lex_wrong_rewrite_02") -*- *) +(* File reduced by coq-bug-finder from original input, then from 1125 lines to +346 lines, then from 360 lines to 346 lines, then from 822 lines to 271 lines, +then from 285 lines to 271 lines *) +(* coqc version 8.5 (January 2016) compiled on Jan 23 2016 16:15:22 with OCaml +4.01.0 + coqtop version 8.5 (January 2016) *) +Inductive False := . +Axiom proof_admitted : False. +Tactic Notation "admit" := case proof_admitted. +Require Coq.Init.Datatypes. +Import Coq.Init.Notations. +Global Set Universe Polymorphism. +Global Set Primitive Projections. +Notation "A -> B" := (forall (_ : A), B) : type_scope. +Module Export Datatypes. + Set Implicit Arguments. + Notation nat := Coq.Init.Datatypes.nat. + Notation S := Coq.Init.Datatypes.S. + Record prod (A B : Type) := pair { fst : A ; snd : B }. + Notation "x * y" := (prod x y) : type_scope. + Delimit Scope nat_scope with nat. + Open Scope nat_scope. +End Datatypes. +Module Export Specif. + Set Implicit Arguments. + Record sig {A} (P : A -> Type) := exist { proj1_sig : A ; proj2_sig : P +proj1_sig }. + Notation sigT := sig (only parsing). + Notation "{ x : A & P }" := (sigT (fun x:A => P)) : type_scope. + Notation projT1 := proj1_sig (only parsing). + Notation projT2 := proj2_sig (only parsing). +End Specif. +Global Set Keyed Unification. +Global Unset Strict Universe Declaration. +Definition Type1@{i} := Eval hnf in let gt := (Set : Type@{i}) in Type@{i}. +Definition Type2@{i j} := Eval hnf in let gt := (Type1@{j} : Type@{i}) in +Type@{i}. +Definition Type2le@{i j} := Eval hnf in let gt := (Set : Type@{i}) in + let ge := ((fun x => x) : Type1@{j} -> +Type@{i}) in Type@{i}. +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 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. +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 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 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) + }. +Arguments eissect {A B}%type_scope f%function_scope {_} _. +Inductive Unit : Type1 := tt : Unit. +Local Open Scope path_scope. +Definition concat_p_pp {A : Type} {x y z t : A} (p : x = y) (q : y = z) (r : z += t) : + p @ (q @ r) = (p @ q) @ r := + match r with idpath => + match q with idpath => + match p with idpath => 1 + end end 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. +Definition ExtensionAlong {A B : Type} (f : A -> B) + (P : B -> Type) (d : forall x:A, P (f x)) + := { s : forall y:B, P y & forall x:A, s (f x) = d x }. +Fixpoint ExtendableAlong@{i j k l} + (n : nat) {A : Type@{i}} {B : Type@{j}} + (f : A -> B) (C : B -> Type@{k}) : Type@{l} + := match n with + | 0 => Unit@{l} + | S n => (forall (g : forall a, C (f a)), + ExtensionAlong@{i j k l l} f C g) * + forall (h k : forall b, C b), + ExtendableAlong n f (fun b => h b = k b) + end. + +Definition ooExtendableAlong@{i j k l} + {A : Type@{i}} {B : Type@{j}} + (f : A -> B) (C : B -> Type@{k}) : Type@{l} + := forall n, ExtendableAlong@{i j k l} n f C. + +Module Type ReflectiveSubuniverses. + + Parameter ReflectiveSubuniverse@{u a} : Type2@{u a}. + + Parameter O_reflector@{u a i} : forall (O : ReflectiveSubuniverse@{u a}), + Type2le@{i a} -> Type2le@{i a}. + + Parameter In@{u a i} : forall (O : ReflectiveSubuniverse@{u a}), + Type2le@{i a} -> Type2le@{i a}. + + Parameter O_inO@{u a i} : forall (O : ReflectiveSubuniverse@{u a}) (T : +Type@{i}), + In@{u a i} O (O_reflector@{u a i} O T). + + Parameter to@{u a i} : forall (O : ReflectiveSubuniverse@{u a}) (T : +Type@{i}), + T -> O_reflector@{u a i} O T. + + Parameter extendable_to_O@{u a i j k} + : forall (O : ReflectiveSubuniverse@{u a}) {P : Type2le@{i a}} {Q : +Type2le@{j a}} {Q_inO : In@{u a j} O Q}, + ooExtendableAlong@{i i j k} (to O P) (fun _ => Q). + +End ReflectiveSubuniverses. + +Module ReflectiveSubuniverses_Theory (Os : ReflectiveSubuniverses). + Export Os. + Existing Class In. + Module Export Coercions. + Coercion O_reflector : ReflectiveSubuniverse >-> Funclass. + End Coercions. + Global Existing Instance O_inO. + + Section ORecursion. + Context {O : ReflectiveSubuniverse}. + + Definition O_rec {P Q : Type} {Q_inO : In O Q} + (f : P -> Q) + : O P -> Q + := (fst (extendable_to_O O 1%nat) f).1. + + Definition O_rec_beta {P Q : Type} {Q_inO : In O Q} + (f : P -> Q) (x : P) + : O_rec f (to O P x) = f x + := (fst (extendable_to_O O 1%nat) f).2 x. + + Definition O_indpaths {P Q : Type} {Q_inO : In O Q} + (g h : O P -> Q) (p : g o to O P == h o to O P) + : g == h + := (fst (snd (extendable_to_O O 2) g h) p).1. + + End ORecursion. + + + Section Reflective_Subuniverse. + Context (O : ReflectiveSubuniverse@{Ou Oa}). + + Definition isequiv_to_O_inO@{u a i} (T : Type@{i}) `{In@{u a i} O T} : +IsEquiv@{i i} (to O T). + Proof. + + pose (g := O_rec@{u a i i i i i} idmap). + refine (isequiv_adjointify (to O T) g _ _). + - + refine (O_indpaths@{u a i i i i i} (to O T o g) idmap _). + intros x. + apply ap. + apply O_rec_beta. + - + intros x. + apply O_rec_beta. + Defined. + Global Existing Instance isequiv_to_O_inO. + + End Reflective_Subuniverse. + +End ReflectiveSubuniverses_Theory. + +Module Type Preserves_Fibers (Os : ReflectiveSubuniverses). + Module Export Os_Theory := ReflectiveSubuniverses_Theory Os. +End Preserves_Fibers. + +Opaque eissect. +Module Lex_Reflective_Subuniverses + (Os : ReflectiveSubuniverses) (Opf : Preserves_Fibers Os). + Import Opf. + Goal forall (O : ReflectiveSubuniverse) (A : Type) (B : A -> Type) (A_inO : +In O A), + + forall g, + forall (x : O {x : A & B x}) v v' v'' (p2 : v'' = v') (p0 : v' = v) (p1 : +v = _) r, + (p2 + @ (p0 + @ p1)) + @ eissect (to O A) (g x) = r. + intros. + cbv zeta. + rewrite concat_p_pp. + match goal with + | [ |- p2 @ p0 @ p1 @ eissect (to O A) (g x) = r ] => idtac "good" + | [ |- ?G ] => fail 1 "bad" G + end. + Fail rewrite concat_p_pp.
\ No newline at end of file diff --git a/test-suite/bugs/closed/4544.v b/test-suite/bugs/closed/4544.v new file mode 100644 index 000000000..d14cc86fc --- /dev/null +++ b/test-suite/bugs/closed/4544.v @@ -0,0 +1,1007 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-nois" "-indices-matter" "-R" "." "Top" "-top" "bug_oog_looping_rewrite_01") -*- *) +(* File reduced by coq-bug-finder from original input, then from 2553 lines to 1932 lines, then from 1946 lines to 1932 lines, then from 2467 lines to 1002 lines, then from 1016 lines to 1002 lines *) +(* coqc version 8.5 (January 2016) compiled on Jan 23 2016 16:15:22 with OCaml 4.01.0 + coqtop version 8.5 (January 2016) *) +Inductive False := . +Axiom proof_admitted : False. +Tactic Notation "admit" := case proof_admitted. +Require Coq.Init.Datatypes. + +Import Coq.Init.Notations. + +Global Set Universe Polymorphism. + +Notation "A -> B" := (forall (_ : A), B) : type_scope. +Global Set Primitive Projections. + +Inductive sum (A B : Type) : Type := + | inl : A -> sum A B + | inr : B -> sum A B. +Notation nat := Coq.Init.Datatypes.nat. +Notation S := Coq.Init.Datatypes.S. +Notation "x + y" := (sum x y) : type_scope. + +Record prod (A B : Type) := pair { fst : A ; snd : B }. + +Notation "x * y" := (prod x y) : type_scope. +Module Export Specif. + +Set Implicit Arguments. + +Record sig {A} (P : A -> Type) := exist { proj1_sig : A ; proj2_sig : P proj1_sig }. +Arguments proj1_sig {A P} _ / . + +Notation sigT := sig (only parsing). +Notation existT := exist (only parsing). + +Notation "{ x : A & P }" := (sigT (fun x:A => P)) : type_scope. + +Notation projT1 := proj1_sig (only parsing). +Notation projT2 := proj2_sig (only parsing). + +End Specif. +Module Export HoTT_DOT_Basics_DOT_Overture. +Module Export HoTT. +Module Export Basics. +Module Export Overture. + +Global Set Keyed Unification. + +Global Unset Strict Universe Declaration. + +Notation Type0 := Set. + +Definition Type1@{i} := Eval hnf in let gt := (Set : Type@{i}) in Type@{i}. + +Definition Type2@{i j} := Eval hnf in let gt := (Type1@{j} : Type@{i}) in Type@{i}. + +Definition Type2le@{i j} := Eval hnf in let gt := (Set : Type@{i}) in + let ge := ((fun x => x) : Type1@{j} -> Type@{i}) in Type@{i}. + +Notation idmap := (fun x => x). +Delimit Scope function_scope with function. +Delimit Scope path_scope with path. +Delimit Scope fibration_scope with fibration. +Delimit Scope trunc_scope with trunc. + +Open Scope trunc_scope. +Open Scope path_scope. +Open Scope fibration_scope. +Open Scope nat_scope. +Open Scope function_scope. + +Notation "( x ; y )" := (existT _ x y) : fibration_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. + +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. + +Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing) : path_scope. + +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 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) +}. + +Arguments eisretr {A B}%type_scope f%function_scope {_} _. + +Record Equiv A B := BuildEquiv { + equiv_fun : A -> B ; + equiv_isequiv : IsEquiv equiv_fun +}. + +Coercion equiv_fun : Equiv >-> Funclass. + +Global Existing Instance equiv_isequiv. + +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. + +Class Contr_internal (A : Type) := BuildContr { + center : A ; + contr : (forall y : A, center = y) +}. + +Arguments center A {_}. + +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. +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. + +Global Instance istrunc_paths (A : Type) n `{H : IsTrunc n.+1 A} (x y : A) +: IsTrunc n (x = y) + := H x y. + +Notation Contr := (IsTrunc -2). +Notation IsHProp := (IsTrunc -1). + +Hint Extern 0 => progress change Contr_internal with Contr in * : typeclass_instances. + +Monomorphic Axiom dummy_funext_type : Type0. +Monomorphic Class Funext := { dummy_funext_value : dummy_funext_type }. + +Inductive Unit : Type1 := + tt : Unit. + +Class IsPointed (A : Type) := point : A. + +Arguments point A {_}. + +Record pType := + { pointed_type : Type ; + ispointed_type : IsPointed pointed_type }. + +Coercion pointed_type : pType >-> Sortclass. + +Global Existing Instance ispointed_type. + +Definition hfiber {A B : Type} (f : A -> B) (y : B) := { x : A & f x = y }. + +Ltac revert_opaque x := + revert x; + match goal with + | [ |- forall _, _ ] => idtac + | _ => fail 1 "Reverted constant is not an opaque variable" + end. + +End Overture. + +End Basics. + +End HoTT. + +End HoTT_DOT_Basics_DOT_Overture. +Module Export HoTT_DOT_Basics_DOT_PathGroupoids. +Module Export HoTT. +Module Export Basics. +Module Export PathGroupoids. + +Local Open Scope path_scope. + +Definition concat_p1 {A : Type} {x y : A} (p : x = y) : + p @ 1 = p + := + match p with idpath => 1 end. + +Definition concat_1p {A : Type} {x y : A} (p : x = y) : + 1 @ p = p + := + match p with idpath => 1 end. + +Definition concat_p_pp {A : Type} {x y z t : A} (p : x = y) (q : y = z) (r : z = t) : + p @ (q @ r) = (p @ q) @ r := + match r with idpath => + match q with idpath => + match p with idpath => 1 + end end end. + +Definition concat_pp_p {A : Type} {x y z t : A} (p : x = y) (q : y = z) (r : z = t) : + (p @ q) @ r = p @ (q @ r) := + match r with idpath => + match q with idpath => + match p with idpath => 1 + end end end. + +Definition concat_pV {A : Type} {x y : A} (p : x = y) : + p @ p^ = 1 + := + match p with idpath => 1 end. + +Definition moveR_Vp {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : x = y) : + p = r @ q -> r^ @ p = q. +admit. +Defined. + +Definition moveL_Vp {A : Type} {x y z : A} (p : x = z) (q : y = z) (r : x = y) : + r @ q = p -> q = r^ @ p. +admit. +Defined. + +Definition moveR_M1 {A : Type} {x y : A} (p q : x = y) : + 1 = p^ @ q -> p = q. +admit. +Defined. + +Definition ap_pp {A B : Type} (f : A -> B) {x y z : A} (p : x = y) (q : y = z) : + ap f (p @ q) = (ap f p) @ (ap f q) + := + match q with + idpath => + match p with idpath => 1 end + end. + +Definition ap_V {A B : Type} (f : A -> B) {x y : A} (p : x = y) : + ap f (p^) = (ap f p)^ + := + match p with idpath => 1 end. + +Definition ap_compose {A B C : Type} (f : A -> B) (g : B -> C) {x y : A} (p : x = y) : + ap (g o f) p = ap g (ap f p) + := + match p with idpath => 1 end. + +Definition concat_pA1 {A : Type} {f : A -> A} (p : forall x, x = f x) {x y : A} (q : x = y) : + (p x) @ (ap f q) = q @ (p y) + := + match q as i in (_ = y) return (p x @ ap f i = i @ p y) with + | idpath => concat_p1 _ @ (concat_1p _)^ + end. + +End PathGroupoids. + +End Basics. + +End HoTT. + +End HoTT_DOT_Basics_DOT_PathGroupoids. +Module Export HoTT_DOT_Basics_DOT_Equivalences. +Module Export HoTT. +Module Export Basics. +Module Export Equivalences. + +Definition isequiv_commsq {A B C D} + (f : A -> B) (g : C -> D) (h : A -> C) (k : B -> D) + (p : k o f == g o h) + `{IsEquiv _ _ f} `{IsEquiv _ _ h} `{IsEquiv _ _ k} +: IsEquiv g. +admit. +Defined. + +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). + Proof. + unfold issect'. + apply moveR_M1. + repeat rewrite ap_pp, concat_p_pp; rewrite <- ap_compose. + rewrite (concat_pA1 (fun b => (isretr b)^) (ap f (issect a)^)). + repeat rewrite concat_pp_p; rewrite ap_V; apply moveL_Vp; rewrite concat_p1. + rewrite concat_p_pp, <- ap_compose. + rewrite (concat_pA1 (fun b => (isretr b)^) (isretr (f a))). + rewrite concat_pV, concat_1p; reflexivity. + Qed. + + Definition isequiv_adjointify : IsEquiv f + := BuildIsEquiv A B f g isretr issect' is_adjoint'. + +End Adjointify. + +End Equivalences. + +End Basics. + +End HoTT. + +End HoTT_DOT_Basics_DOT_Equivalences. +Module Export HoTT_DOT_Basics_DOT_Trunc. +Module Export HoTT. +Module Export Basics. +Module Export Trunc. +Generalizable Variables A B m n f. + +Definition trunc_equiv A {B} (f : A -> B) + `{IsTrunc n A} `{IsEquiv A B f} + : IsTrunc n B. +admit. +Defined. + +Record TruncType (n : trunc_index) := BuildTruncType { + trunctype_type : Type ; + istrunc_trunctype_type : IsTrunc n trunctype_type +}. + +Arguments BuildTruncType _ _ {_}. + +Coercion trunctype_type : TruncType >-> Sortclass. + +Notation "n -Type" := (TruncType n) (at level 1) : type_scope. +Notation hProp := (-1)-Type. + +Notation BuildhProp := (BuildTruncType -1). + +End Trunc. + +End Basics. + +End HoTT. + +End HoTT_DOT_Basics_DOT_Trunc. +Module Export HoTT_DOT_Types_DOT_Unit. +Module Export HoTT. +Module Export Types. +Module Export Unit. + +Notation unit_name x := (fun (_ : Unit) => x). + +End Unit. + +End Types. + +End HoTT. + +End HoTT_DOT_Types_DOT_Unit. +Module Export HoTT_DOT_Types_DOT_Sigma. +Module Export HoTT. +Module Export Types. +Module Export Sigma. +Local Open Scope path_scope. + +Definition path_sigma_uncurried {A : Type} (P : A -> Type) (u v : sigT P) + (pq : {p : u.1 = v.1 & p # u.2 = v.2}) +: u = v + := match pq.2 in (_ = v2) return u = (v.1; v2) with + | 1 => match pq.1 as p in (_ = v1) return u = (v1; p # u.2) with + | 1 => 1 + end + end. + +Definition path_sigma {A : Type} (P : A -> Type) (u v : sigT P) + (p : u.1 = v.1) (q : p # u.2 = v.2) +: u = v + := path_sigma_uncurried P u v (p;q). + +Definition path_sigma' {A : Type} (P : A -> Type) {x x' : A} {y : P x} {y' : P x'} + (p : x = x') (q : p # y = y') +: (x;y) = (x';y') + := path_sigma P (x;y) (x';y') p q. + +Global Instance isequiv_pr1_contr {A} {P : A -> Type} + `{forall a, Contr (P a)} +: IsEquiv (@pr1 A P) | 100. +Proof. + refine (isequiv_adjointify (@pr1 A P) + (fun a => (a ; center (P a))) _ _). + - + intros a; reflexivity. + - + intros [a p]. + refine (path_sigma' P 1 (contr _)). +Defined. + +Definition path_sigma_hprop {A : Type} {P : A -> Type} + `{forall x, IsHProp (P x)} + (u v : sigT P) +: u.1 = v.1 -> u = v + := path_sigma_uncurried P u v o pr1^-1. + +End Sigma. + +End Types. + +End HoTT. + +End HoTT_DOT_Types_DOT_Sigma. +Module Export HoTT_DOT_Extensions. +Module Export HoTT. +Module Export Extensions. + +Section Extensions. + + Definition ExtensionAlong {A B : Type} (f : A -> B) + (P : B -> Type) (d : forall x:A, P (f x)) + := { s : forall y:B, P y & forall x:A, s (f x) = d x }. + + Fixpoint ExtendableAlong@{i j k l} + (n : nat) {A : Type@{i}} {B : Type@{j}} + (f : A -> B) (C : B -> Type@{k}) : Type@{l} + := match n with + | 0 => Unit@{l} + | S n => (forall (g : forall a, C (f a)), + ExtensionAlong@{i j k l l} f C g) * + forall (h k : forall b, C b), + ExtendableAlong n f (fun b => h b = k b) + end. + + Definition ooExtendableAlong@{i j k l} + {A : Type@{i}} {B : Type@{j}} + (f : A -> B) (C : B -> Type@{k}) : Type@{l} + := forall n, ExtendableAlong@{i j k l} n f C. + +End Extensions. + +End Extensions. + +End HoTT. + +End HoTT_DOT_Extensions. +Module Export HoTT. +Module Export Modalities. +Module Export ReflectiveSubuniverse. + +Module Type ReflectiveSubuniverses. + + Parameter ReflectiveSubuniverse@{u a} : Type2@{u a}. + + Parameter O_reflector@{u a i} : forall (O : ReflectiveSubuniverse@{u a}), + Type2le@{i a} -> Type2le@{i a}. + + Parameter In@{u a i} : forall (O : ReflectiveSubuniverse@{u a}), + Type2le@{i a} -> Type2le@{i a}. + + Parameter O_inO@{u a i} : forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}), + In@{u a i} O (O_reflector@{u a i} O T). + + Parameter to@{u a i} : forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}), + T -> O_reflector@{u a i} O T. + + Parameter inO_equiv_inO@{u a i j k} : + forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}) (U : Type@{j}) + (T_inO : In@{u a i} O T) (f : T -> U) (feq : IsEquiv f), + + let gei := ((fun x => x) : Type@{i} -> Type@{k}) in + let gej := ((fun x => x) : Type@{j} -> Type@{k}) in + In@{u a j} O U. + + Parameter hprop_inO@{u a i} + : Funext -> forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}), + IsHProp (In@{u a i} O T). + + Parameter extendable_to_O@{u a i j k} + : forall (O : ReflectiveSubuniverse@{u a}) {P : Type2le@{i a}} {Q : Type2le@{j a}} {Q_inO : In@{u a j} O Q}, + ooExtendableAlong@{i i j k} (to O P) (fun _ => Q). + +End ReflectiveSubuniverses. + +Module ReflectiveSubuniverses_Theory (Os : ReflectiveSubuniverses). +Export Os. + +Module Export Coercions. + + Coercion O_reflector : ReflectiveSubuniverse >-> Funclass. + +End Coercions. + +End ReflectiveSubuniverses_Theory. + +Module Type ReflectiveSubuniverses_Restriction_Data (Os : ReflectiveSubuniverses). + + Parameter New_ReflectiveSubuniverse@{u a} : Type2@{u a}. + + Parameter ReflectiveSubuniverses_restriction@{u a} + : New_ReflectiveSubuniverse@{u a} -> Os.ReflectiveSubuniverse@{u a}. + +End ReflectiveSubuniverses_Restriction_Data. + +Module ReflectiveSubuniverses_Restriction + (Os : ReflectiveSubuniverses) + (Res : ReflectiveSubuniverses_Restriction_Data Os) +<: ReflectiveSubuniverses. + + Definition ReflectiveSubuniverse := Res.New_ReflectiveSubuniverse. + + Definition O_reflector@{u a i} (O : ReflectiveSubuniverse@{u a}) + := Os.O_reflector@{u a i} (Res.ReflectiveSubuniverses_restriction O). + Definition In@{u a i} (O : ReflectiveSubuniverse@{u a}) + := Os.In@{u a i} (Res.ReflectiveSubuniverses_restriction O). + Definition O_inO@{u a i} (O : ReflectiveSubuniverse@{u a}) + := Os.O_inO@{u a i} (Res.ReflectiveSubuniverses_restriction O). + Definition to@{u a i} (O : ReflectiveSubuniverse@{u a}) + := Os.to@{u a i} (Res.ReflectiveSubuniverses_restriction O). + Definition inO_equiv_inO@{u a i j k} (O : ReflectiveSubuniverse@{u a}) + := Os.inO_equiv_inO@{u a i j k} (Res.ReflectiveSubuniverses_restriction O). + Definition hprop_inO@{u a i} (H : Funext) (O : ReflectiveSubuniverse@{u a}) + := Os.hprop_inO@{u a i} H (Res.ReflectiveSubuniverses_restriction O). + Definition extendable_to_O@{u a i j k} (O : ReflectiveSubuniverse@{u a}) + := @Os.extendable_to_O@{u a i j k} (Res.ReflectiveSubuniverses_restriction@{u a} O). + +End ReflectiveSubuniverses_Restriction. + +Module ReflectiveSubuniverses_FamUnion + (Os1 Os2 : ReflectiveSubuniverses) +<: ReflectiveSubuniverses. + + Definition ReflectiveSubuniverse@{u a} : Type2@{u a} + := Os1.ReflectiveSubuniverse@{u a} + Os2.ReflectiveSubuniverse@{u a}. + + Definition O_reflector@{u a i} : forall (O : ReflectiveSubuniverse@{u a}), + Type2le@{i a} -> Type2le@{i a}. +admit. +Defined. + + Definition In@{u a i} : forall (O : ReflectiveSubuniverse@{u a}), + Type2le@{i a} -> Type2le@{i a}. + Proof. + intros [O|O]; [ exact (Os1.In@{u a i} O) + | exact (Os2.In@{u a i} O) ]. + Defined. + + Definition O_inO@{u a i} + : forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}), + In@{u a i} O (O_reflector@{u a i} O T). +admit. +Defined. + + Definition to@{u a i} : forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}), + T -> O_reflector@{u a i} O T. +admit. +Defined. + + Definition inO_equiv_inO@{u a i j k} : + forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}) (U : Type@{j}) + (T_inO : In@{u a i} O T) (f : T -> U) (feq : IsEquiv f), + In@{u a j} O U. + Proof. + intros [O|O]; [ exact (Os1.inO_equiv_inO@{u a i j k} O) + | exact (Os2.inO_equiv_inO@{u a i j k} O) ]. + Defined. + + Definition hprop_inO@{u a i} + : Funext -> forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}), + IsHProp (In@{u a i} O T). +admit. +Defined. + + Definition extendable_to_O@{u a i j k} + : forall (O : ReflectiveSubuniverse@{u a}) {P : Type2le@{i a}} {Q : Type2le@{j a}} {Q_inO : In@{u a j} O Q}, + ooExtendableAlong@{i i j k} (to O P) (fun _ => Q). +admit. +Defined. + +End ReflectiveSubuniverses_FamUnion. + +End ReflectiveSubuniverse. + +End Modalities. + +End HoTT. + +Module Type Modalities. + + Parameter Modality@{u a} : Type2@{u a}. + + Parameter O_reflector@{u a i} : forall (O : Modality@{u a}), + Type2le@{i a} -> Type2le@{i a}. + + Parameter In@{u a i} : forall (O : Modality@{u a}), + Type2le@{i a} -> Type2le@{i a}. + + Parameter O_inO@{u a i} : forall (O : Modality@{u a}) (T : Type@{i}), + In@{u a i} O (O_reflector@{u a i} O T). + + Parameter to@{u a i} : forall (O : Modality@{u a}) (T : Type@{i}), + T -> O_reflector@{u a i} O T. + + Parameter inO_equiv_inO@{u a i j k} : + forall (O : Modality@{u a}) (T : Type@{i}) (U : Type@{j}) + (T_inO : In@{u a i} O T) (f : T -> U) (feq : IsEquiv f), + + let gei := ((fun x => x) : Type@{i} -> Type@{k}) in + let gej := ((fun x => x) : Type@{j} -> Type@{k}) in + In@{u a j} O U. + + Parameter hprop_inO@{u a i} + : Funext -> forall (O : Modality@{u a}) (T : Type@{i}), + IsHProp (In@{u a i} O T). + +End Modalities. + +Module Modalities_to_ReflectiveSubuniverses + (Os : Modalities) <: ReflectiveSubuniverses. + + Import Os. + + Fixpoint O_extendable@{u a i j k} (O : Modality@{u a}) + (A : Type@{i}) (B : O_reflector O A -> Type@{j}) + (B_inO : forall a, In@{u a j} O (B a)) (n : nat) + : ExtendableAlong@{i i j k} n (to O A) B. +admit. +Defined. + + Definition ReflectiveSubuniverse := Modality. + + Definition O_reflector := O_reflector. + + Definition In@{u a i} : forall (O : ReflectiveSubuniverse@{u a}), + Type2le@{i a} -> Type2le@{i a} + := In@{u a i}. + Definition O_inO@{u a i} : forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}), + In@{u a i} O (O_reflector@{u a i} O T) + := O_inO@{u a i}. + Definition to := to. + Definition inO_equiv_inO@{u a i j k} : + forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}) (U : Type@{j}) + (T_inO : In@{u a i} O T) (f : T -> U) (feq : IsEquiv f), + In@{u a j} O U + := inO_equiv_inO@{u a i j k}. + Definition hprop_inO@{u a i} + : Funext -> forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}), + IsHProp (In@{u a i} O T) + := hprop_inO@{u a i}. + + Definition extendable_to_O@{u a i j k} (O : ReflectiveSubuniverse@{u a}) + {P : Type2le@{i a}} {Q : Type2le@{j a}} {Q_inO : In@{u a j} O Q} + : ooExtendableAlong@{i i j k} (to O P) (fun _ => Q) + := fun n => O_extendable O P (fun _ => Q) (fun _ => Q_inO) n. + +End Modalities_to_ReflectiveSubuniverses. + +Module Type EasyModalities. + + Parameter Modality@{u a} : Type2@{u a}. + + Parameter O_reflector@{u a i} : forall (O : Modality@{u a}), + Type2le@{i a} -> Type2le@{i a}. + + Parameter to@{u a i} : forall (O : Modality@{u a}) (T : Type@{i}), + T -> O_reflector@{u a i} O T. + + Parameter minO_pathsO@{u a i} + : forall (O : Modality@{u a}) (A : Type@{i}) + (z z' : O_reflector@{u a i} O A), + IsEquiv (to@{u a i} O (z = z')). + +End EasyModalities. + +Module EasyModalities_to_Modalities (Os : EasyModalities) +<: Modalities. + + Import Os. + + Definition Modality := Modality. + + Definition O_reflector@{u a i} := O_reflector@{u a i}. + Definition to@{u a i} := to@{u a i}. + + Definition In@{u a i} + : forall (O : Modality@{u a}), Type@{i} -> Type@{i} + := fun O A => IsEquiv@{i i} (to O A). + + Definition hprop_inO@{u a i} `{Funext} (O : Modality@{u a}) + (T : Type@{i}) + : IsHProp (In@{u a i} O T). +admit. +Defined. + + Definition O_ind_internal@{u a i j k} (O : Modality@{u a}) + (A : Type@{i}) (B : O_reflector@{u a i} O A -> Type@{j}) + (B_inO : forall oa, In@{u a j} O (B oa)) + : let gei := ((fun x => x) : Type@{i} -> Type@{k}) in + let gej := ((fun x => x) : Type@{j} -> Type@{k}) in + (forall a, B (to O A a)) -> forall oa, B oa. +admit. +Defined. + + Definition O_ind_beta_internal@{u a i j k} (O : Modality@{u a}) + (A : Type@{i}) (B : O_reflector@{u a i} O A -> Type@{j}) + (B_inO : forall oa, In@{u a j} O (B oa)) + (f : forall a : A, B (to O A a)) (a:A) + : O_ind_internal@{u a i j k} O A B B_inO f (to O A a) = f a. +admit. +Defined. + + Definition O_inO@{u a i} (O : Modality@{u a}) (A : Type@{i}) + : In@{u a i} O (O_reflector@{u a i} O A). +admit. +Defined. + + Definition inO_equiv_inO@{u a i j k} (O : Modality@{u a}) (A : Type@{i}) (B : Type@{j}) + (A_inO : In@{u a i} O A) (f : A -> B) (feq : IsEquiv f) + : In@{u a j} O B. + Proof. + simple refine (isequiv_commsq (to O A) (to O B) f + (O_ind_internal O A (fun _ => O_reflector O B) _ (fun a => to O B (f a))) _). + - + intros; apply O_inO. + - + intros a; refine (O_ind_beta_internal@{u a i j k} O A (fun _ => O_reflector O B) _ _ a). + - + apply A_inO. + - + simple refine (isequiv_adjointify _ + (O_ind_internal O B (fun _ => O_reflector O A) _ (fun b => to O A (f^-1 b))) _ _); + intros x. + + + apply O_inO. + + + pattern x; refine (O_ind_internal O B _ _ _ x); intros. + * + apply minO_pathsO. + * + simpl; admit. + + + pattern x; refine (O_ind_internal O A _ _ _ x); intros. + * + apply minO_pathsO. + * + simpl; admit. + Defined. + +End EasyModalities_to_Modalities. + +Module Modalities_Theory (Os : Modalities). + +Export Os. +Module Export Os_ReflectiveSubuniverses + := Modalities_to_ReflectiveSubuniverses Os. +Module Export RSU + := ReflectiveSubuniverses_Theory Os_ReflectiveSubuniverses. + +Module Export Coercions. + Coercion modality_to_reflective_subuniverse + := idmap : Modality -> ReflectiveSubuniverse. +End Coercions. + +Class IsConnected (O : Modality@{u a}) (A : Type@{i}) + + := isconnected_contr_O : IsTrunc@{i} -2 (O A). + +Class IsConnMap (O : Modality@{u a}) + {A : Type@{i}} {B : Type@{j}} (f : A -> B) + := isconnected_hfiber_conn_map + + : forall b:B, IsConnected@{u a k} O (hfiber@{i j} f b). + +End Modalities_Theory. + +Private Inductive Trunc (n : trunc_index) (A :Type) : Type := + tr : A -> Trunc n A. +Arguments tr {n A} a. + +Global Instance istrunc_truncation (n : trunc_index) (A : Type@{i}) +: IsTrunc@{j} n (Trunc@{i} n A). +Admitted. + +Definition Trunc_ind {n A} + (P : Trunc n A -> Type) {Pt : forall aa, IsTrunc n (P aa)} + : (forall a, P (tr a)) -> (forall aa, P aa) +:= (fun f aa => match aa with tr a => fun _ => f a end Pt). + +Definition Truncation_Modality := trunc_index. + +Module Truncation_Modalities <: Modalities. + + Definition Modality : Type2@{u a} := Truncation_Modality. + + Definition O_reflector (n : Modality@{u u'}) A := Trunc n A. + + Definition In (n : Modality@{u u'}) A := IsTrunc n A. + + Definition O_inO (n : Modality@{u u'}) A : In n (O_reflector n A). +admit. +Defined. + + Definition to (n : Modality@{u u'}) A := @tr n A. + + Definition inO_equiv_inO (n : Modality@{u u'}) + (A : Type@{i}) (B : Type@{j}) Atr f feq + : let gei := ((fun x => x) : Type@{i} -> Type@{k}) in + let gej := ((fun x => x) : Type@{j} -> Type@{k}) in + In n B + := @trunc_equiv A B f n Atr feq. + + Definition hprop_inO `{Funext} (n : Modality@{u u'}) A + : IsHProp (In n A). +admit. +Defined. + +End Truncation_Modalities. + +Module Import TrM := Modalities_Theory Truncation_Modalities. + +Definition merely (A : Type@{i}) : hProp@{i} := BuildhProp (Trunc -1 A). + +Notation IsSurjection := (IsConnMap -1). + +Definition BuildIsSurjection {A B} (f : A -> B) : + (forall b, merely (hfiber f b)) -> IsSurjection f. +admit. +Defined. + +Ltac strip_truncations := + + progress repeat match goal with + | [ T : _ |- _ ] + => revert_opaque T; + refine (@Trunc_ind _ _ _ _ _); + + []; + intro T + end. +Local Open Scope trunc_scope. + +Global Instance conn_pointed_type {n : trunc_index} {A : Type} (a0:A) + `{IsConnMap n _ _ (unit_name a0)} : IsConnected n.+1 A | 1000. +admit. +Defined. + +Definition loops (A : pType) : pType := + Build_pType (point A = point A) idpath. + +Record pMap (A B : pType) := + { pointed_fun : A -> B ; + point_eq : pointed_fun (point A) = point B }. + +Arguments point_eq {A B} f : rename. +Coercion pointed_fun : pMap >-> Funclass. + +Infix "->*" := pMap (at level 99) : pointed_scope. +Local Open Scope pointed_scope. + +Definition pmap_compose {A B C : pType} + (g : B ->* C) (f : A ->* B) +: A ->* C + := Build_pMap A C (g o f) + (ap g (point_eq f) @ point_eq g). + +Record pHomotopy {A B : pType} (f g : pMap A B) := + { pointed_htpy : f == g ; + point_htpy : pointed_htpy (point A) @ point_eq g = point_eq f }. +Arguments pointed_htpy {A B f g} p x. + +Infix "==*" := pHomotopy (at level 70, no associativity) : pointed_scope. + +Definition loops_functor {A B : pType} (f : A ->* B) +: (loops A) ->* (loops B). +Proof. + refine (Build_pMap (loops A) (loops B) + (fun p => (point_eq f)^ @ (ap f p @ point_eq f)) _). + apply moveR_Vp; simpl. + refine (concat_1p _ @ (concat_p1 _)^). +Defined. + +Definition loops_functor_compose {A B C : pType} + (g : B ->* C) (f : A ->* B) +: (loops_functor (pmap_compose g f)) + ==* (pmap_compose (loops_functor g) (loops_functor f)). +admit. +Defined. + +Local Open Scope path_scope. + +Record ooGroup := + { classifying_space : pType@{i} ; + isconn_classifying_space : IsConnected@{u a i} 0 classifying_space + }. + +Local Notation B := classifying_space. + +Definition group_type (G : ooGroup) : Type + := point (B G) = point (B G). + +Coercion group_type : ooGroup >-> Sortclass. + +Definition group_loops (X : pType) +: ooGroup. +Proof. + + pose (x0 := point X); + pose (BG := (Build_pType + { x:X & merely (x = point X) } + (existT (fun x:X => merely (x = point X)) x0 (tr 1)))). + + cut (IsConnected 0 BG). + { + exact (Build_ooGroup BG). +} + cut (IsSurjection (unit_name (point BG))). + { + intros; refine (conn_pointed_type (point _)). +} + apply BuildIsSurjection; simpl; intros [x p]. + strip_truncations; apply tr; exists tt. + apply path_sigma_hprop; simpl. + exact (p^). +Defined. + +Definition loops_group (X : pType) +: loops X <~> group_loops X. +admit. +Defined. + +Definition ooGroupHom (G H : ooGroup) + := pMap (B G) (B H). + +Definition grouphom_fun {G H} (phi : ooGroupHom G H) : G -> H + := loops_functor phi. + +Coercion grouphom_fun : ooGroupHom >-> Funclass. + +Definition group_loops_functor + {X Y : pType} (f : pMap X Y) +: ooGroupHom (group_loops X) (group_loops Y). +Proof. + simple refine (Build_pMap _ _ _ _); simpl. + - + intros [x p]. + exists (f x). + strip_truncations; apply tr. + exact (ap f p @ point_eq f). + - + apply path_sigma_hprop; simpl. + apply point_eq. +Defined. + +Definition loops_functor_group + {X Y : pType} (f : pMap X Y) +: loops_functor (group_loops_functor f) o loops_group X + == loops_group Y o loops_functor f. +admit. +Defined. + +Definition grouphom_compose {G H K : ooGroup} + (psi : ooGroupHom H K) (phi : ooGroupHom G H) +: ooGroupHom G K + := pmap_compose psi phi. + +Definition group_loops_functor_compose + {X Y Z : pType} + (psi : pMap Y Z) (phi : pMap X Y) +: grouphom_compose (group_loops_functor psi) (group_loops_functor phi) + == group_loops_functor (pmap_compose psi phi). +Proof. + intros g. + unfold grouphom_fun, grouphom_compose. + refine (pointed_htpy (loops_functor_compose _ _) g @ _). + pose (p := eisretr (loops_group X) g). + change (loops_functor (group_loops_functor psi) + (loops_functor (group_loops_functor phi) g) + = loops_functor (group_loops_functor + (pmap_compose psi phi)) g). + rewrite <- p. + Fail Timeout 1 Time rewrite !loops_functor_group. + (* 0.004 s in 8.5rc1, 8.677 s in 8.5 *) + Timeout 1 do 3 rewrite loops_functor_group. +Abort.
\ No newline at end of file diff --git a/test-suite/bugs/closed/4574.v b/test-suite/bugs/closed/4574.v new file mode 100644 index 000000000..39ba19036 --- /dev/null +++ b/test-suite/bugs/closed/4574.v @@ -0,0 +1,8 @@ +Require Import Setoid. + +Definition block A (a : A) := a. + +Goal forall A (a : A), block Type nat. +Proof. +Fail reflexivity. + diff --git a/test-suite/bugs/closed/4580.v b/test-suite/bugs/closed/4580.v new file mode 100644 index 000000000..4ffd5f0f4 --- /dev/null +++ b/test-suite/bugs/closed/4580.v @@ -0,0 +1,6 @@ +Require Import Program. + +Class Foo (A : Type) := foo : A. + +Unset Refine Instance Mode. +Program Instance f1 : Foo nat := S _. diff --git a/test-suite/bugs/closed/4582.v b/test-suite/bugs/closed/4582.v new file mode 100644 index 000000000..0842fb8fa --- /dev/null +++ b/test-suite/bugs/closed/4582.v @@ -0,0 +1,10 @@ +Require List. +Import List.ListNotations. + +Variable Foo : nat -> nat. + +Delimit Scope Foo_scope with F. + +Notation " [ x ] " := (Foo x) : Foo_scope. + +Check ([1] : nat)%F. diff --git a/test-suite/bugs/closed/4588.v b/test-suite/bugs/closed/4588.v new file mode 100644 index 000000000..ff66277e0 --- /dev/null +++ b/test-suite/bugs/closed/4588.v @@ -0,0 +1,10 @@ +Set Primitive Projections. + +(* This proof was accepted in Coq 8.5 because the subterm specs were not +projected correctly *) +Inductive foo : Prop := mkfoo { proj1 : False -> foo; proj2 : (forall P : Prop, P -> P) }. + +Fail Fixpoint loop (x : foo) : False := + loop (proj2 x _ x). + +Fail Definition bad : False := loop (mkfoo (fun x => match x with end) (fun _ x => x)). diff --git a/test-suite/bugs/closed/4596.v b/test-suite/bugs/closed/4596.v new file mode 100644 index 000000000..592fdb658 --- /dev/null +++ b/test-suite/bugs/closed/4596.v @@ -0,0 +1,14 @@ +Require Import Coq.Setoids.Setoid Coq.Classes.Morphisms. + +Definition T (x : bool) := x = true. + +Goal forall (S : Type) (b b0 : S -> nat -> bool) (str : S) (p : nat) + (s : forall n : nat, bool) + (s0 s1 : nat -> S -> S), + (forall (str0 : S) (n m : nat), + (if s m then T (b0 (s1 n str0) 0) else T (b (s1 n str0) 0)) -> T (b (s0 n str0) m) -> + T (b str0 m)) -> + T (b str p). +Proof. +intros ???????? H0. +rewrite H0. diff --git a/test-suite/bugs/closed/4627.v b/test-suite/bugs/closed/4627.v new file mode 100644 index 000000000..e1206bb37 --- /dev/null +++ b/test-suite/bugs/closed/4627.v @@ -0,0 +1,49 @@ +Class sa (A:Type) := { }. + +Record predicate A (sa:sa A) := + { pred_fun: A->Prop }. +Record ABC : Type := + { abc: Type }. +Record T := + { T_abc: ABC }. + + +(* +sa: forall _ : Type@{Top.179}, Prop +predicate: forall (A : Type@{Top.205}) (_ : sa A), Type@{max(Set+1, Top.205)} +T: Type@{Top.208+1} +ABC: Type@{Top.208+1} +abc: forall _ : ABC, Type@{Top.208} + +Top.205 <= Top.179 predicate <= sa.A +Set < Top.208 Set < abc +Set < Top.205 Set < predicate +*) + +Definition foo : predicate T (Build_sa T) := + {| pred_fun:= fun w => True |}. +(* *) +(* Top.208 < Top.205 <--- added by foo *) +(* *) + +Check predicate nat (Build_sa nat). +(* + +The issue is that the template polymorphic universe of [predicate], Top.205, does not get replaced with the universe of [nat] in the above line. + -Jason Gross + +8.5 -- predicate nat (Build_sa nat): Type@{max(Set+1, Top.205)} +8.5 EXPECTED -- predicate nat (Build_sa nat): Type@{Set+1} +8.4pl4 -- predicate nat {| |}: Type (* max(Set, (Set)+1) *) +*) + +(* This works in 8.4pl4 and SHOULD work in 8.5 *) +Definition bar : ABC := + {| abc:= predicate nat (Build_sa nat) |}. +(* +The term "predicate nat (Build_sa nat)" has type + "Type@{max(Set+1, Top.205)}" +while it is expected to have type "Type@{Top.208}" +(universe inconsistency: Cannot enforce Top.205 <= +Top.208 because Top.208 < Top.205). +*)
\ No newline at end of file diff --git a/test-suite/bugs/closed/931.v b/test-suite/bugs/closed/931.v index e86b3be64..ea3347a85 100644 --- a/test-suite/bugs/closed/931.v +++ b/test-suite/bugs/closed/931.v @@ -2,6 +2,6 @@ Parameter P : forall n : nat, n=n -> Prop. Goal Prop. refine (P _ _). - 2:instantiate (1:=0). + instantiate (1:=0). trivial. Qed. diff --git a/test-suite/bugs/closed/HoTT_coq_002.v b/test-suite/bugs/closed/HoTT_coq_002.v index ba69f6b15..dba4d5998 100644 --- a/test-suite/bugs/closed/HoTT_coq_002.v +++ b/test-suite/bugs/closed/HoTT_coq_002.v @@ -9,7 +9,7 @@ Section SpecializedFunctor. (* Variable objC : Type. *) Context `(C : SpecializedCategory objC). - Polymorphic Record SpecializedFunctor := { + Record SpecializedFunctor := { ObjectOf' : objC -> Type; ObjectC : Object C }. diff --git a/test-suite/bugs/closed/HoTT_coq_014.v b/test-suite/bugs/closed/HoTT_coq_014.v index ae3e50d7e..223a98de1 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_020.v b/test-suite/bugs/closed/HoTT_coq_020.v index 4938b80f9..008fb72c4 100644 --- a/test-suite/bugs/closed/HoTT_coq_020.v +++ b/test-suite/bugs/closed/HoTT_coq_020.v @@ -59,8 +59,8 @@ Polymorphic Definition FunctorFrom0 objC (C : Category objC) : Functor Cat0 C := Build_Functor Cat0 C (fun x => match x with end). Section Law0. - Variable objC : Type. - Variable C : Category objC. + Polymorphic Variable objC : Type. + Polymorphic Variable C : Category objC. Set Printing All. Set Printing Universes. diff --git a/test-suite/bugs/closed/HoTT_coq_077.v b/test-suite/bugs/closed/HoTT_coq_077.v index db3b60eda..017780c1f 100644 --- a/test-suite/bugs/closed/HoTT_coq_077.v +++ b/test-suite/bugs/closed/HoTT_coq_077.v @@ -30,7 +30,7 @@ Definition prod_rect' A B (P : prod A B -> Type) (u : forall (fst : A) (snd : B) (p : prod A B) : P p := u (fst p) (snd p). -Notation typeof x := ($(let T := type of x in exact T)$) (only parsing). +Notation typeof x := (ltac:(let T := type of x in exact T)) (only parsing). (* Check for eta *) Check eq_refl : typeof (@prod_rect) = typeof (@prod_rect'). diff --git a/test-suite/bugs/closed/HoTT_coq_090.v b/test-suite/bugs/closed/HoTT_coq_090.v index 5fa167038..d77b9b63a 100644 --- a/test-suite/bugs/closed/HoTT_coq_090.v +++ b/test-suite/bugs/closed/HoTT_coq_090.v @@ -84,7 +84,7 @@ Arguments transport {A} P {x y} p%path_scope u : simpl nomatch. Instance isequiv_path {A B : Type} (p : A = B) : IsEquiv (transport (fun X:Type => X) p) | 0. Proof. - refine (@BuildIsEquiv _ _ _ (transport (fun X:Type => X) p^) _ _ _); + unshelve refine (@BuildIsEquiv _ _ _ (transport (fun X:Type => X) p^) _ _ _); admit. Defined. diff --git a/test-suite/bugs/closed/HoTT_coq_114.v b/test-suite/bugs/closed/HoTT_coq_114.v index 341128338..3535e6c41 100644 --- a/test-suite/bugs/closed/HoTT_coq_114.v +++ b/test-suite/bugs/closed/HoTT_coq_114.v @@ -1 +1 @@ -Inductive test : $(let U := type of Type in exact U)$ := t. +Inductive test : ltac:(let U := type of Type in exact U) := t. diff --git a/test-suite/bugs/opened/3248.v b/test-suite/bugs/opened/3248.v index 9e7d1eb5d..33c408a28 100644 --- a/test-suite/bugs/opened/3248.v +++ b/test-suite/bugs/opened/3248.v @@ -3,7 +3,7 @@ Ltac ret_and_left f := let T := type of f in lazymatch eval hnf in T with | ?T' -> _ => - let ret := constr:(fun x' : T' => $(tac (f x'))$) in + let ret := constr:(fun x' : T' => ltac:(tac (f x'))) in exact ret | ?T' => exact f end. @@ -12,6 +12,6 @@ Goal forall A B : Prop, forall x y : A, True. Proof. intros A B x y. pose (f := fun (x y : A) => conj x y). - pose (a := $(ret_and_left f)$). + pose (a := ltac:(ret_and_left f)). Fail unify (a x y) (conj x y). Abort. diff --git a/test-suite/bugs/opened/3277.v b/test-suite/bugs/opened/3277.v index 19ed787d1..5f4231363 100644 --- a/test-suite/bugs/opened/3277.v +++ b/test-suite/bugs/opened/3277.v @@ -4,4 +4,4 @@ Goal True. evarr _. Admitted. Goal True. - Fail exact $(evarr _)$. (* Error: Cannot infer this placeholder. *) + Fail exact ltac:(evarr _). (* Error: Cannot infer this placeholder. *) diff --git a/test-suite/bugs/opened/3278.v b/test-suite/bugs/opened/3278.v index ced535afd..1c6deae94 100644 --- a/test-suite/bugs/opened/3278.v +++ b/test-suite/bugs/opened/3278.v @@ -1,8 +1,8 @@ Module a. Check let x' := _ in - $(exact x')$. + ltac:(exact x'). - Notation foo x := (let x' := x in $(exact x')$). + Notation foo x := (let x' := x in ltac:(exact x')). Fail Check foo _. (* Error: Cannot infer an internal placeholder of type "Type" in environment: @@ -12,10 +12,10 @@ x' := ?42 : ?41 End a. Module b. - Notation foo x := (let x' := x in let y := ($(exact I)$ : True) in I). + Notation foo x := (let x' := x in let y := (ltac:(exact I) : True) in I). Notation bar x := (let x' := x in let y := (I : True) in I). - Check let x' := _ in $(exact I)$. (* let x' := ?5 in I *) + Check let x' := _ in ltac:(exact I). (* let x' := ?5 in I *) Check bar _. (* let x' := ?9 in let y := I in I *) Fail Check foo _. (* Error: Cannot infer an internal placeholder of type "Type" in environment: diff --git a/test-suite/bugs/opened/3304.v b/test-suite/bugs/opened/3304.v index 529cc737d..66668930c 100644 --- a/test-suite/bugs/opened/3304.v +++ b/test-suite/bugs/opened/3304.v @@ -1,3 +1,3 @@ -Fail Notation "( x , y , .. , z )" := $(let r := constr:(prod .. (prod x y) .. z) in r)$. +Fail Notation "( x , y , .. , z )" := ltac:(let r := constr:(prod .. (prod x y) .. z) in r). (* The command has indeed failed with message: => Error: Special token .. is for use in the Notation command. *) diff --git a/test-suite/bugs/opened/3410.v b/test-suite/bugs/opened/3410.v deleted file mode 100644 index 0d259181a..000000000 --- a/test-suite/bugs/opened/3410.v +++ /dev/null @@ -1 +0,0 @@ -Fail repeat match goal with H:_ |- _ => setoid_rewrite X in H end. diff --git a/test-suite/bugs/opened/3459.v b/test-suite/bugs/opened/3459.v index 9e6107b30..762611f75 100644 --- a/test-suite/bugs/opened/3459.v +++ b/test-suite/bugs/opened/3459.v @@ -7,9 +7,9 @@ Proof. (* This line used to fail with a Not_found up to some point, and then to produce an ill-typed term *) match goal with - | [ |- context G[2] ] => let y := constr:(fun x => $(let r := constr:(@eq Set x x) in + | [ |- context G[2] ] => let y := constr:(fun x => ltac:(let r := constr:(@eq Set x x) in clear x; - exact r)$) in + exact r)) in pose y end. (* Add extra test for typability (should not fail when bug closed) *) diff --git a/test-suite/bugs/opened/3554.v b/test-suite/bugs/opened/3554.v deleted file mode 100644 index 422c5770e..000000000 --- a/test-suite/bugs/opened/3554.v +++ /dev/null @@ -1 +0,0 @@ -Fail Example foo (f : forall {_ : Type}, Type) : Type. diff --git a/test-suite/complexity/f_equal.v b/test-suite/complexity/f_equal.v new file mode 100644 index 000000000..86698fa87 --- /dev/null +++ b/test-suite/complexity/f_equal.v @@ -0,0 +1,14 @@ +(* Checks that f_equal does not reduce the term uselessly *) +(* Expected time < 1.00s *) + +Fixpoint stupid (n : nat) : unit := +match n with +| 0 => tt +| S n => + let () := stupid n in + let () := stupid n in + tt +end. + +Goal stupid 23 = stupid 23. +Timeout 5 Time f_equal. diff --git a/test-suite/complexity/ring2.v b/test-suite/complexity/ring2.v index 52dae265b..04fa59075 100644 --- a/test-suite/complexity/ring2.v +++ b/test-suite/complexity/ring2.v @@ -39,7 +39,7 @@ Admitted. Ltac Zcst t := match isZcst t with true => t - | _ => constr:NotConstant + | _ => constr:(NotConstant) end. Add Ring Zr : Zth diff --git a/test-suite/failure/Tauto.v b/test-suite/failure/Tauto.v index 749db0002..d91d159d9 100644 --- a/test-suite/failure/Tauto.v +++ b/test-suite/failure/Tauto.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/test-suite/failure/clash_cons.v b/test-suite/failure/clash_cons.v index 8e34ffbda..b3fbff680 100644 --- a/test-suite/failure/clash_cons.v +++ b/test-suite/failure/clash_cons.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/test-suite/failure/fixpoint1.v b/test-suite/failure/fixpoint1.v index 7b52316ed..c2b521c21 100644 --- a/test-suite/failure/fixpoint1.v +++ b/test-suite/failure/fixpoint1.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/test-suite/failure/guard.v b/test-suite/failure/guard.v index b3a0a3356..8db278583 100644 --- a/test-suite/failure/guard.v +++ b/test-suite/failure/guard.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/test-suite/failure/illtype1.v b/test-suite/failure/illtype1.v index 7e4c5ac57..8ed3af1ce 100644 --- a/test-suite/failure/illtype1.v +++ b/test-suite/failure/illtype1.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/test-suite/failure/int31.v b/test-suite/failure/int31.v new file mode 100644 index 000000000..b1d112247 --- /dev/null +++ b/test-suite/failure/int31.v @@ -0,0 +1,17 @@ +Require Import Int31 BigN. + +Open Scope int31_scope. + +(* This used to go through because of an unbalanced stack bug in the bytecode +interpreter *) + +Lemma bad : False. +assert (1 = 2). +change 1 with (add31 (addmuldiv31 65 (add31 1 1) 2) 1). +Fail vm_compute; reflexivity. +(* +discriminate. +Qed. +*) +Abort. + diff --git a/test-suite/failure/positivity.v b/test-suite/failure/positivity.v index 30762a77f..8089de2bf 100644 --- a/test-suite/failure/positivity.v +++ b/test-suite/failure/positivity.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/test-suite/failure/redef.v b/test-suite/failure/redef.v index e5db81768..c8dc6303f 100644 --- a/test-suite/failure/redef.v +++ b/test-suite/failure/redef.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/test-suite/failure/search.v b/test-suite/failure/search.v index a6e6bc489..648ab0820 100644 --- a/test-suite/failure/search.v +++ b/test-suite/failure/search.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/test-suite/ide/undo013.fake b/test-suite/ide/undo013.fake index f44156aa3..921a9d0f0 100644 --- a/test-suite/ide/undo013.fake +++ b/test-suite/ide/undo013.fake @@ -23,5 +23,5 @@ ADD { Qed. } ADD { apply H. } # </replay> ADD { Qed. } -QUERY { Fail idtac. } +QUERY { Fail Show. } QUERY { Check (aa,bb,cc). } diff --git a/test-suite/ide/undo014.fake b/test-suite/ide/undo014.fake index 6d58b061e..f5fe77470 100644 --- a/test-suite/ide/undo014.fake +++ b/test-suite/ide/undo014.fake @@ -22,5 +22,5 @@ ADD { destruct H. } ADD { Qed. } ADD { apply H. } ADD { Qed. } -QUERY { Fail idtac. } +QUERY { Fail Show. } QUERY { Check (aa,bb,cc). } diff --git a/test-suite/ide/undo015.fake b/test-suite/ide/undo015.fake index ac17985aa..a1e5c947b 100644 --- a/test-suite/ide/undo015.fake +++ b/test-suite/ide/undo015.fake @@ -25,5 +25,5 @@ ADD { destruct H. } ADD { Qed. } ADD { apply H. } ADD { Qed. } -QUERY { Fail idtac. } +QUERY { Fail Show. } QUERY { Check (aa,bb,cc). } diff --git a/test-suite/ide/undo016.fake b/test-suite/ide/undo016.fake index bdb81ecd9..f9414c1ea 100644 --- a/test-suite/ide/undo016.fake +++ b/test-suite/ide/undo016.fake @@ -27,5 +27,5 @@ ADD { destruct H. } ADD { Qed. } ADD { apply H. } ADD { Qed. } -QUERY { Fail idtac. } +QUERY { Fail Show. } QUERY { Check (aa,bb,cc). } diff --git a/test-suite/ideal-features/Apply.v b/test-suite/ideal-features/Apply.v index ed46eb229..c8e9af216 100644 --- a/test-suite/ideal-features/Apply.v +++ b/test-suite/ideal-features/Apply.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/test-suite/micromega/square.v b/test-suite/micromega/square.v index 8767f6874..abf8be72e 100644 --- a/test-suite/micromega/square.v +++ b/test-suite/micromega/square.v @@ -53,8 +53,7 @@ Qed. Theorem sqrt2_not_rational : ~exists x:Q, x^2==2#1. Proof. - unfold Qeq; intros [x]; simpl (Qden (2#1)); rewrite Z.mul_1_r. - intros HQeq. + unfold Qeq; intros (x,HQeq); simpl (Qden (2#1)) in HQeq; rewrite Z.mul_1_r in HQeq. assert (Heq : (Qnum x ^ 2 = 2 * ' Qden x ^ 2%Q)%Z) by (rewrite QnumZpower in HQeq ; rewrite QdenZpower in HQeq ; auto). assert (Hnx : (Qnum x <> 0)%Z) diff --git a/test-suite/misc/berardi_test.v b/test-suite/misc/berardi_test.v index 219686b95..a64db4dab 100644 --- a/test-suite/misc/berardi_test.v +++ b/test-suite/misc/berardi_test.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/test-suite/output/Cases.out b/test-suite/output/Cases.out index 09f032d47..f44465456 100644 --- a/test-suite/output/Cases.out +++ b/test-suite/output/Cases.out @@ -48,8 +48,8 @@ f = fun H : B => match H with | AC x => - (let b0 := b in - if b0 as b return (P b -> True) + let b0 := b in + (if b0 as b return (P b -> True) then fun _ : P true => Logic.I else fun _ : P false => Logic.I) x end diff --git a/test-suite/output/Cases.v b/test-suite/output/Cases.v index 4116a5ebc..a4d19d693 100644 --- a/test-suite/output/Cases.v +++ b/test-suite/output/Cases.v @@ -72,8 +72,8 @@ Inductive B : Prop := AC : P b -> B. Definition f : B -> True. Proof. -intros []. -destruct b as [|] ; intros _ ; exact Logic.I. +intros [x]. +destruct b as [|] ; exact Logic.I. Defined. Print f. diff --git a/test-suite/output/Existentials.out b/test-suite/output/Existentials.out index 483a9ea79..9680d2bbf 100644 --- a/test-suite/output/Existentials.out +++ b/test-suite/output/Existentials.out @@ -1,5 +1,4 @@ -Existential 1 = -?Goal0 : [p : nat q := S p : nat n : nat m : nat |- ?y = m] +Existential 1 = ?Goal : [p : nat q := S p : nat n : nat m : nat |- ?y = m] Existential 2 = ?y : [p : nat q := S p : nat n : nat m : nat |- nat] (p, q cannot be used) -Existential 3 = ?e : [q : nat n : nat m : nat |- n = ?y] +Existential 3 = ?Goal0 : [q : nat n : nat m : nat |- n = ?y] diff --git a/test-suite/output/Extraction_matchs_2413.out b/test-suite/output/Extraction_matchs_2413.out index 848abd009..f738b0d09 100644 --- a/test-suite/output/Extraction_matchs_2413.out +++ b/test-suite/output/Extraction_matchs_2413.out @@ -4,7 +4,7 @@ let test1 b = b (** val test2 : bool -> bool **) -let test2 b = +let test2 _ = False (** val wrong_id : 'a1 hole -> 'a2 hole **) diff --git a/test-suite/output/Notations.out b/test-suite/output/Notations.out index b1558dab1..26eaca827 100644 --- a/test-suite/output/Notations.out +++ b/test-suite/output/Notations.out @@ -111,14 +111,14 @@ fun x : option Z => match x with | NONE2 => 0 end : option Z -> Z -fun x : list ?T1 => match x with - | NIL => NONE2 - | (_ :') t => SOME2 t - end - : list ?T1 -> option (list ?T1) +fun x : list ?T => match x with + | NIL => NONE2 + | (_ :') t => SOME2 t + end + : list ?T -> option (list ?T) where -?T1 : [x : list ?T1 x1 : list ?T1 x0 := x1 : list ?T1 |- Type] (x, x1, - x0 cannot be used) +?T : [x : list ?T x1 : list ?T x0 := x1 : list ?T |- Type] (x, x1, + x0 cannot be used) s : s 10 diff --git a/test-suite/output/inference.out b/test-suite/output/inference.out index f2d144778..576fbd7c0 100644 --- a/test-suite/output/inference.out +++ b/test-suite/output/inference.out @@ -6,13 +6,13 @@ 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 : T 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] +?y : [n : nat x := A n : T n |- ?T -> T n] +?y0 : [n : nat x := A n : T n |- ?T] fun n : nat => ?y ?y0 : T n : forall n : nat, T n where -?y : [n : nat |- ?T0 -> T n] -?y0 : [n : nat |- ?T0] +?y : [n : nat |- ?T -> T n] +?y0 : [n : nat |- ?T] diff --git a/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v b/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v index 0d75d52a3..06357cfc2 100644 --- a/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v +++ b/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v @@ -1902,14 +1902,14 @@ Qed. Lemma Zsgn_15 : forall x y : Z, Zsgn (x * y) = (Zsgn x * Zsgn y)%Z. Proof. - intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; constructor. + intros [|p1|p1]; [intros y|intros [|p2|p2] ..]; simpl in |- *; constructor. Qed. Lemma Zsgn_16 : forall x y : Z, Zsgn (x * y) = 1%Z -> {(0 < x)%Z /\ (0 < y)%Z} + {(x < 0)%Z /\ (y < 0)%Z}. Proof. - intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H; + intros [|p1|p1]; [intros y|intros [|p2|p2] ..]; simpl in |- *; intro H; try discriminate H; [ left | right ]; repeat split. Qed. @@ -1917,13 +1917,13 @@ Lemma Zsgn_17 : forall x y : Z, Zsgn (x * y) = (-1)%Z -> {(0 < x)%Z /\ (y < 0)%Z} + {(x < 0)%Z /\ (0 < y)%Z}. Proof. - intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H; + intros [|p1|p1]; [intros y|intros [|p2|p2] ..]; simpl in |- *; intro H; try discriminate H; [ left | right ]; repeat split. Qed. Lemma Zsgn_18 : forall x y : Z, Zsgn (x * y) = 0%Z -> {x = 0%Z} + {y = 0%Z}. Proof. - intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H; + intros [|p1|p1]; [intros y|intros [|p2|p2] ..]; simpl in |- *; intro H; try discriminate H; [ left | right | right ]; constructor. Qed. @@ -1932,40 +1932,40 @@ Qed. Lemma Zsgn_19 : forall x y : Z, (0 < Zsgn x + Zsgn y)%Z -> (0 < x + y)%Z. Proof. Proof. - intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H; + intros [|p1|p1]; [intros y|intros [|p2|p2] ..]; simpl in |- *; intro H; discriminate H || (constructor || apply Zsgn_12; assumption). Qed. Lemma Zsgn_20 : forall x y : Z, (Zsgn x + Zsgn y < 0)%Z -> (x + y < 0)%Z. Proof. Proof. - intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intro H; + intros [|p1|p1]; [intros y|intros [|p2|p2] ..]; simpl in |- *; intro H; discriminate H || (constructor || apply Zsgn_11; assumption). Qed. Lemma Zsgn_21 : forall x y : Z, (0 < Zsgn x + Zsgn y)%Z -> (0 <= x)%Z. Proof. - intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intros H H0; + intros [|p1|p1]; [intros y|intros [|p2|p2] ..]; simpl in |- *; intros H H0; discriminate H || discriminate H0. Qed. Lemma Zsgn_22 : forall x y : Z, (Zsgn x + Zsgn y < 0)%Z -> (x <= 0)%Z. Proof. Proof. - intros [y| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; intros H H0; + intros [|p1|p1]; [intros y|intros [|p2|p2] ..]; simpl in |- *; intros H H0; discriminate H || discriminate H0. Qed. Lemma Zsgn_23 : forall x y : Z, (0 < Zsgn x + Zsgn y)%Z -> (0 <= y)%Z. Proof. - intros [[| p2| p2]| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; + intros [|p1|p1] [|p2|p2]; simpl in |- *; intros H H0; discriminate H || discriminate H0. Qed. Lemma Zsgn_24 : forall x y : Z, (Zsgn x + Zsgn y < 0)%Z -> (y <= 0)%Z. Proof. - intros [[| p2| p2]| p1 [| p2| p2]| p1 [| p2| p2]]; simpl in |- *; + intros [|p1|p1] [|p2|p2]; simpl in |- *; intros H H0; discriminate H || discriminate H0. Qed. diff --git a/test-suite/success/Case22.v b/test-suite/success/Case22.v index ce9050d42..3c696502c 100644 --- a/test-suite/success/Case22.v +++ b/test-suite/success/Case22.v @@ -17,3 +17,47 @@ Definition foo (x : I') : bool := match x with C' => true end. + +(* Bug found in november 2015: was wrongly failing in 8.5beta2 and 8.5beta3 *) + +Inductive I2 (A:Type) : let B:=A in forall C, let D:=(C*B)%type in Type := + E2 : I2 A nat. + +Check fun x:I2 nat nat => match x in I2 _ X Y Z return X*Y*Z with + E2 _ => (0,0,(0,0)) + end. + +(* This used to succeed in 8.3, 8.4 and 8.5beta1 *) + +Inductive IND : forall X:Type, let Y:=X in Type := + CONSTR : IND True. + +Definition F (x:IND True) (A:Type) := + (* This failed in 8.5beta2 though it should have been accepted *) + match x in IND X Y return Y with + CONSTR => Logic.I + end. + +Theorem paradox : False. + (* This succeeded in 8.3, 8.4 and 8.5beta1 because F had wrong type *) +Fail Proof (F C False). + +(* Another bug found in November 2015 (a substitution was wrongly + reversed at pretyping level) *) + +Inductive Ind (A:Type) : + let X:=A in forall Y:Type, let Z:=(X*Y)%type in Type := + Constr : Ind A nat. + +Check fun x:Ind bool nat => + match x in Ind _ X Y Z return Z with + | Constr _ => (true,0) + end. + +(* A vm_compute bug (the type of constructors was not supposed to + contain local definitions before proper parameters) *) + +Inductive Ind2 (b:=1) (c:nat) : Type := + Constr2 : Ind2 c. + +Eval vm_compute in Constr2 2. diff --git a/test-suite/success/Cases.v b/test-suite/success/Cases.v index e42663505..49c465b6c 100644 --- a/test-suite/success/Cases.v +++ b/test-suite/success/Cases.v @@ -1861,3 +1861,10 @@ Type (fun n => match n with Definition transport {A} (P : A->Type) {x y : A} (p : x=y) (u : P x) : P y := match p with eq_refl => u end. + +(* Check in-pattern clauses with constant constructors, which were + previously interpreted as variables (before 8.5) *) + +Check match eq_refl 0 in _=O return O=O with eq_refl => eq_refl end. + +Check match niln in listn O return O=O with niln => eq_refl end. diff --git a/test-suite/success/Check.v b/test-suite/success/Check.v index 87c38cfa0..e4ee351c3 100644 --- a/test-suite/success/Check.v +++ b/test-suite/success/Check.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/test-suite/success/Field.v b/test-suite/success/Field.v index 8db08b6d7..438e46135 100644 --- a/test-suite/success/Field.v +++ b/test-suite/success/Field.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/test-suite/success/Hints.v b/test-suite/success/Hints.v index cc8cec470..f934a5c74 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/Injection.v b/test-suite/success/Injection.v index 25e464d67..56ed89ed8 100644 --- a/test-suite/success/Injection.v +++ b/test-suite/success/Injection.v @@ -68,6 +68,12 @@ einjection (H O). instantiate (1:=O). Abort. +Goal (forall x y : nat, x = y -> S x = S y) -> True. +intros. +einjection (H O ?[y]) as H0. +instantiate (y:=O). +Abort. + (* Test the injection intropattern *) Goal forall (a b:nat) l l', cons a l = cons b l' -> a=b. diff --git a/test-suite/success/MatchFail.v b/test-suite/success/MatchFail.v index 7069bba43..8462d3627 100644 --- a/test-suite/success/MatchFail.v +++ b/test-suite/success/MatchFail.v @@ -9,14 +9,14 @@ Require Export ZArithRing. Ltac compute_POS := match goal with | |- context [(Zpos (xI ?X1))] => - let v := constr:X1 in - match constr:v with + let v := constr:(X1) in + match constr:(v) with | 1%positive => fail 1 | _ => rewrite (BinInt.Pos2Z.inj_xI v) end | |- context [(Zpos (xO ?X1))] => - let v := constr:X1 in - match constr:v with + let v := constr:(X1) in + match constr:(v) with | 1%positive => fail 1 | _ => rewrite (BinInt.Pos2Z.inj_xO v) end diff --git a/test-suite/success/Notations.v b/test-suite/success/Notations.v index 2371d32cd..b72a06740 100644 --- a/test-suite/success/Notations.v +++ b/test-suite/success/Notations.v @@ -101,3 +101,9 @@ Fail Check fun x => match x with S (FORALL x, _) => 0 end. Parameter traverse : (nat -> unit) -> (nat -> unit). Notation traverse_var f l := (traverse (fun l => f l) l). + +(* Check that when an ident become a keyword, it does not break + previous rules relying on the string to be classified as an ident *) + +Notation "'intros' x" := (S x) (at level 0). +Goal True -> True. intros H. exact H. Qed. diff --git a/test-suite/success/Notations2.v b/test-suite/success/Notations2.v new file mode 100644 index 000000000..9505a56e3 --- /dev/null +++ b/test-suite/success/Notations2.v @@ -0,0 +1,92 @@ +(* This file is giving some examples about how implicit arguments and + scopes are treated when using abbreviations or notations, in terms + or patterns, or when using @ and parentheses in terms and patterns. + +The convention is: + +Constant foo with implicit arguments and scopes used in a term or a pattern: + + foo do not deactivate further arguments and scopes + @foo deactivates further arguments and scopes + (foo x) deactivates further arguments and scopes + (@foo x) deactivates further arguments and scopes + +Notations binding to foo: + +# := foo do not deactivate further arguments and scopes +# := @foo deactivates further arguments and scopes +# x := foo x deactivates further arguments and scopes +# x := @foo x deactivates further arguments and scopes + +Abbreviations binding to foo: + +f := foo do not deactivate further arguments and scopes +f := @foo deactivates further arguments and scopes +f x := foo x do not deactivate further arguments and scopes +f x := @foo x do not deactivate further arguments and scopes +*) + +(* One checks that abbreviations and notations in patterns now behave like in terms *) + +Inductive prod' A : Type -> Type := +| pair' (a:A) B (b:B) (c:bool) : prod' A B. +Arguments pair' [A] a%bool_scope [B] b%bool_scope c%bool_scope. +Notation "0" := true : bool_scope. + +(* 1. Abbreviations do not stop implicit arguments to be inserted and scopes to be used *) +Notation c1 x := (pair' x). +Check pair' 0 0 0 : prod' bool bool. +Check (pair' 0) _ 0%bool 0%bool : prod' bool bool. (* parentheses are blocking implicit and scopes *) +Check c1 0 0 0 : prod' bool bool. +Check fun x : prod' bool bool => match x with c1 0 y 0 => 2 | _ => 1 end. + +(* 2. Abbreviations do not stop implicit arguments to be inserted and scopes to be used *) +Notation c2 x := (@pair' _ x). +Check (@pair' _ 0) _ 0%bool 0%bool : prod' bool bool. (* parentheses are blocking implicit and scopes *) +Check c2 0 0 0 : prod' bool bool. +Check fun A (x : prod' bool A) => match x with c2 0 y 0 => 2 | _ => 1 end. +Check fun A (x : prod' bool A) => match x with (@pair' _ 0) _ y 0%bool => 2 | _ => 1 end. + +(* 3. Abbreviations do not stop implicit arguments to be inserted and scopes to be used *) +Notation c3 x := ((@pair') _ x). +Check (@pair') _ 0%bool _ 0%bool 0%bool : prod' bool bool. (* @ is blocking implicit and scopes *) +Check ((@pair') _ 0%bool) _ 0%bool 0%bool : prod' bool bool. (* parentheses and @ are blocking implicit and scopes *) +Check c3 0 0 0 : prod' nat bool. (* First scope is blocked but not the last two scopes *) +Check fun A (x :prod' nat A) => match x with c3 0 y 0 => 2 | _ => 1 end. + +(* 4. Abbreviations do not stop implicit arguments to be inserted and scopes to be used *) +(* unless an atomic @ is given *) +Notation c4 := (@pair'). +Check (@pair') _ 0%bool _ 0%bool 0%bool : prod' bool bool. +Check c4 _ 0%bool _ 0%bool 0%bool : prod' bool bool. +Check fun A (x :prod' bool A) => match x with c4 _ 0%bool _ y 0%bool => 2 | _ => 1 end. +Check fun A (x :prod' bool A) => match x with (@pair') _ 0%bool _ y 0%bool => 2 | _ => 1 end. + +(* 5. Notations stop further implicit arguments to be inserted and scopes to be used *) +Notation "# x" := (pair' x) (at level 0, x at level 1). +Check pair' 0 0 0 : prod' bool bool. +Check # 0 _ 0%bool 0%bool : prod' bool bool. +Check fun A (x :prod' bool A) => match x with # 0 _ y 0%bool => 2 | _ => 1 end. + +(* 6. Notations stop further implicit arguments to be inserted and scopes to be used *) +Notation "## x" := ((@pair') _ x) (at level 0, x at level 1). +Check (@pair') _ 0%bool _ 0%bool 0%bool : prod' bool bool. +Check ((@pair') _ 0%bool) _ 0%bool 0%bool : prod' bool bool. +Check ## 0%bool _ 0%bool 0%bool : prod' bool bool. +Check fun A (x :prod' bool A) => match x with ## 0%bool _ y 0%bool => 2 | _ => 1 end. + +(* 7. Notations stop further implicit arguments to be inserted and scopes to be used *) +Notation "###" := (@pair') (at level 0). +Check (@pair') _ 0%bool _ 0%bool 0%bool : prod' bool bool. +Check ### _ 0%bool _ 0%bool 0%bool : prod' bool bool. +Check fun A (x :prod' bool A) => match x with ### _ 0%bool _ y 0%bool => 2 | _ => 1 end. + +(* 8. Notations w/o @ preserves implicit arguments and scopes *) +Notation "####" := pair' (at level 0). +Check #### 0 0 0 : prod' bool bool. +Check fun A (x :prod' bool A) => match x with #### 0 y 0 => 2 | _ => 1 end. + +(* 9. Notations w/o @ but arguments do not preserve further implicit arguments and scopes *) +Notation "##### x" := (pair' x) (at level 0, x at level 1). +Check ##### 0 _ 0%bool 0%bool : prod' bool bool. +Check fun A (x :prod' bool A) => match x with ##### 0 _ y 0%bool => 2 | _ => 1 end. diff --git a/test-suite/success/Tauto.v b/test-suite/success/Tauto.v index 01d9afb42..767f15be7 100644 --- a/test-suite/success/Tauto.v +++ b/test-suite/success/Tauto.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/test-suite/success/TestRefine.v b/test-suite/success/TestRefine.v index 3090f40cd..c8a8b862f 100644 --- a/test-suite/success/TestRefine.v +++ b/test-suite/success/TestRefine.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/test-suite/success/apply.v b/test-suite/success/apply.v index 55b666b72..02e043bc3 100644 --- a/test-suite/success/apply.v +++ b/test-suite/success/apply.v @@ -543,7 +543,7 @@ Qed. Lemma bar (X: nat -> nat -> Prop) (foo:forall x, X x x) (a: unit) (H: tt = a): exists x, exists y, X x y. Proof. -intros; eexists; eexists; case H. +intros; eexists; eexists ?[y]; case H. apply (foo ?y). Grab Existential Variables. exact 0. diff --git a/test-suite/success/auto.v b/test-suite/success/auto.v index aaa7b3a51..5477c8331 100644 --- a/test-suite/success/auto.v +++ b/test-suite/success/auto.v @@ -45,3 +45,92 @@ Proof. eexists. Fail progress debug eauto with test2. progress eauto with test. Qed. + +(** Patterns of Extern have a "matching" semantics. + It is not so for apply/exact hints *) + +Class B (A : Type). +Class I. +Instance i : I. + +Definition flip {A B C : Type} (f : A -> B -> C) := fun y x => f x y. +Class D (f : nat -> nat -> nat). +Definition ftest (x y : nat) := x + y. +Definition flipD (f : nat -> nat -> nat) : D f -> D (flip f). + Admitted. +Module Instnopat. + Local Instance: B nat. + (* pattern_of_constr -> B nat *) + (* exact hint *) + Check (_ : B nat). + (* map_eauto -> B_instance0 *) + (* NO Constr_matching.matches !!! *) + Check (_ : B _). + + Goal exists T, B T. + eexists. + eauto with typeclass_instances. + Qed. + + Local Instance: D ftest. + Local Hint Resolve flipD | 0 : typeclass_instances. + (* pattern: D (flip _) *) + Fail Timeout 1 Check (_ : D _). (* loops applying flipD *) + +End Instnopat. + +Module InstnopatApply. + Local Instance: I -> B nat. + (* pattern_of_constr -> B nat *) + (* apply hint *) + Check (_ : B nat). + (* map_eauto -> B_instance0 *) + (* NO Constr_matching.matches !!! *) + Check (_ : B _). + + Goal exists T, B T. + eexists. + eauto with typeclass_instances. + Qed. +End InstnopatApply. + +Module InstPat. + Hint Extern 3 (B nat) => split : typeclass_instances. + (* map_eauto -> Extern hint *) + (* Constr_matching.matches -> true *) + Check (_ : B nat). + (* map_eauto -> Extern hint *) + (* Constr_matching.matches -> false: + Because an inductive in the pattern does not match an evar in the goal *) + Check (_ : B _). + + Goal exists T, B T. + eexists. + (* map_existential -> Extern hint *) + (* Constr_matching.matches -> false *) + Fail progress eauto with typeclass_instances. + (* map_eauto -> Extern hint *) + (* Constr_matching.matches -> false *) + Fail typeclasses eauto. + Abort. + + Hint Extern 0 (D (flip _)) => apply flipD : typeclass_instances. + Module withftest. + Local Instance: D ftest. + + Check (_ : D _). + (* D_instance_0 : D ftest *) + Check (_ : D (flip _)). + (* ... : D (flip ftest) *) + End withftest. + Module withoutftest. + Hint Extern 0 (D ftest) => split : typeclass_instances. + Check (_ : D _). + (* ? : D ?, _not_ looping *) + Check (_ : D (flip _)). + (* ? : D (flip ?), _not_ looping *) + + Check (_ : D (flip ftest)). + (* flipD ftest {| |} : D (flip ftest) *) + End withoutftest. +End InstPat. diff --git a/test-suite/success/bigQ.v b/test-suite/success/bigQ.v new file mode 100644 index 000000000..7fd0cf669 --- /dev/null +++ b/test-suite/success/bigQ.v @@ -0,0 +1,66 @@ +Require Import BigQ. +Import List. + +Definition pi_4_approx_low' := +(5066193963420194617885108698600649932059391557720145469382602092416947640628637390992675949693715109726079394291478795603894419483819297806310615866892414925850691415582239745615128821983865262221858109336884967754871321668348027076234335167119885298878199925731495390387858629042311908406056230882123787019283378509712244687397013657159455607193734144010901984756727174636853404278421831024545476850410085042498464474261035780891759930905778986584183710930670670301831474144997069400304290351567959717683444430666444319233768399342338059169002790777424962570605618705584660815518973602995097110557181643034682308210782171804373210646804613922337450953858508244032293753591878060539465788294318856859293281629951093130167801471787011911886414492513677892193100809508943832528344473873460853362957387889412799458784754514139679847887887544849825173792522272708046699681079289358082661375778523609867456540595586031625044964543428047238934233579184772793670436643502740076366994465457847106782560289782615794595755672643440040123002018908935362541166831619056664637901929131328502017686713274283777724453661234225382109584471950444925886358166551424008707439387934109226545596919797083495958300914344992836193126080289565652575543234385558967555959267746932292860747199382633363026440008828134867747920263181610216905129926037611247017868033961426567047355301676870662406173724238530061264149506666345040372864118731705584795947926329181826992456072045382170981478151356381437136818835196834068650217794381425547036331194595892801393225038235274901050364737353586927051766717037643833477566087835266968086513005761986678747515870298138062157791066648217784877968385924845017637219384732843791052551854695220023477365706464590594542001161575677402761543188277502092362285265847964496740584911576627239093631932307473445797386335961743298553548881544486940399236133577915988716682746485564575640818803540680574730591500432326858763829791848612343662539095316357052823005419355719381626599487868023399182174939253393897549026675976384326749445831606130546375395770778462506203752920470130305293966478109733954117063941901686840180727195741528561335809865193566993349413786715403053579411364371500063193205131503024022217701373077790337150298315820556080596579100618643147698304927957576213733526923182742441048553793831725592624850721293495085399785588171300815789795594858916409701139277050529011775828846362873246196866089783324522718656445008090114701320562608474099248873638488023114015981013142490827777895317580810590743940417298263300561876701828404744082864248409230009391001735746615476377303707782123483770118391136826609366946585715225248587168403619476143657107412319421501162805102723455593551478028055839072686207007765300258935153546418515706362733656094770289090398825190320430416955807878686642673124733998295439657633866090085982598765253268688814792672416195730086607425842181518560588819896560847103627615434844684536463752986969865794019299978956052589825441828842338163389851892617560591840546654410705167593310272272965900821031821380595084783691324416454359888103920904935692840264474003367023256964191100139001239923263691779167792867186165635514824889759796850863175082506408142175595463676408992027105356481220754473245821534527625758942093801142305560662681150069082553674495761075895588095760081401141419460482860852822686860785424514171214889677926763812031823537071721974799922995763666175738785000806081164280471363125324839717808977470218218571800106898347366938927189989988149888641129263448064762730769285877330997355234347773807099829665997515649429224335217107760728789764718885665291038706425454675746218345291274054088843647602239258308472486102933167465443294268551209015027897159307743987020521392788721231001835675584104894174434637260464035122611721657641428625505184886116917149318963070896162119215386541876236027342810162765609201440423207771441367926085768438143507025739041041240810056881304230519058117534418374553879198061289605354335880794397478047346975609179199801003098836622253165101961484972165230151495472006888128587168049198312469715081555662345452800468933420359802645393289853553618279788400476187713990872203669487294118461245455333004125835663010526985716431187034663870796866708678078952110615910196519835267441831874676895301527286826106517027821074816850326548617513767142627360001181210946100011774672126943957522004190414960909074050454565964857276407084991922274068961845339154089866785707764290964299529444616711194034827611771558783466230353209661849406004241580029437779784290315347968833708422223285859451369907260780956405036020581705441364379616715041818815829810906212826084485200785283123265202151252852134381195424724503189247411069117189489985791487434549080447866370484866697404176437230771558469231403088139693477706784802801265075586678597768511791952562627345622499328 + # 100788726492580594349650258277496659410917619472657560321971265983799894639441017438166498752997098978003489632843381325240982516059309714013145358125224597827602157516585886911710102182473475545864474089191789296685473601331678556438310133356793199956062857423397512495293688453655805536015029176541424005214818033707522950635262669828538132795615008381824067071229426026518897202246241637377064076189277685257166926338187911595052586669184297526234794666364657344206795357967279911782849686515024121916258300642000317525374433525235296287037535618423661645124459323811792936193272341688261801253469089129439519903538495370298752436267926761998785090092411372633429302950606054074205533246665546979112178855223925266166034953000200646676762301817000435641690517142795144469005596172113586738287118865058604922865654348297975054956781513943444060257230946224520058527667925776273088622386666860662470481606622952298649177217986593047495967209669116410592230626047083795555559776477430548946990993890380787911273437967786556742804566652408275798339221179283430482118140020742719695900657696142739101628984271513292954605191778803974738871043737934546460016184719168074062912083778327025499841998124431899131874519812228674255796948879306477894924710085384116453080236862135706628989104070747737689294987000148388110561753028594988959655591699155508380909698460304884908709246116411180876105681720036833487450945730831039969246996849503525429840196651386469599438064049723005123629385485140945945416764414133189625489032807860400751723995946290581976152580477047961138617997133510128194027510895265424780627975864980749945631413855375897945293107842908479797077570371447220506451229526132919408351287454305932886749170523056147842439813407002950370505941417426433452282518739345666494683448699945734453214481915512562995906034771246088038719298959180199052759295868161570318718927430655393250250811804905393113074074574608255523847592006804881016594060188745212933427473833239777228852952217878690668413947367586040297784502192683200664398064682201012931468052982448022330449955215606614483165425935154496289535573901139223034819824408001205784146243892228030383941863746839845526558421740316887532141893650230936137269356278754487130882868595412163277284772124736531380334814212708066069618080153747333573454834500999083737284449542481264971030785043701582134343596645346132964567391370300568578875509971483039720438955919863275044932311289587494336123538202079503922025306586828117649623642521324286648529829664567232756108169459356549144779085080036654897525078792273443307070502103724611233768453196294899770515940520895908289018412144327894912660060761908970811602375085884115384049610753387776858733798341463052471017393165656926510611173543365663267563198760597092606598728110197523695339144204179424646442294307593146446562536865057987897899655645968129515654148044008249646703504419478535298270862753806142083172190778193001810574370442181909146645889199829207284871551220439225371051511970054965951914399901815408791418836185742573331879114400013259342896515702942707292473805188905427717363630137869116872433627556880809120353079342030725196065815470427569172350436988386579444534375353968759750750178342190349607711313840613843718547859929387259163285524671855725511880656411741012446023392964655239624520090988149679656514996202498334816938716757663800773997302639681907686195671083505910700098597156238624351157219093280177066146218516478636356056420098245995113668018177690728654922707281126889313941750547830163078886329630807850633273613622550216189245162735650139455042125252043274668279981753287687674520319519360593091620297805736177366738063651905396783336064579717230286821545930579779462534206093794040878198825916141099864730374109311705285661056855668930671948265232862757146615431791375559792290479316263924560826544387396762768331402198937951439504767950821089741987629257538953417586416459087855138539304027013800937360598578194413362672871055543854633921502486683911956250444582746421552178164852341035733290405311280719066037175324627429434912416361334254696649419037348733709488576582107382055914938194078813926926742828297826939120316120573453588052056773875836843924877773978390546387248009519202370375478981843515393806263037580338009594022254079586380520797699651840576286033587273591899639699077044271208886940540056794360292760863657703246410020854088849880453524038877935317875884698324859548991680533307680053872403383516589028793015681082435908524045497475001609824047204954932626536311826911363867426654549346914317405110707189532251727848751560224936842128628673253616256326013555922159336370177663785738170802777550686079119049748734352584409583136667752555307842739679930698964098088960000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000)%bigQ +. + +Definition pi_4_approx_high' := +(5066193963420194617885108698600649932059391557720145469382602092416947640628637390992675949693715109726079394291478795603894419483819297806310615866892414925850691415582239745615128821983865262221858109336884967754871321668348027076234335167119885298878199925731495390387858629042311908406056230882123787019283378509712244687397013657159455607193734144010901984756727174636853404278421831024545476850410085042498464474261035780891759930905778986584183710930670670301831474144997069400304290351567959717683444430666444319233768399342338059169002790777424962570605618705584660815518973602995097110557181643034682308210788409308322071457087096445676662503017187903223859814905546579050729173916234740628466315449085686468204847296426235788544874405450791749423436215032927889914519102361378633666267941326393265376660400091389373564825046526561381561278586121772300141564909333667988204680492088607706214346458601842899721615765319505314310192693665547163360402786722105590252780194994950097926184146718893770363322073641336811404180286358079915338791029818581497746089864894356686643882883410392601500048021013346713450539807687779704798018559373507951388092945938366448668853081682176581336156031434604604833692503597621519809826880683536141897075567053733515342478008373282599947520770191238802249392773327261328133194484586433840861730959791563023761306622956165536481335792721379318928171897265310054788931201902441066997927781894934061720760080768154565282051604447333036111267534150649674590201404453202347064545359869105856798745664471694795576801148562495225166002814304124970965817043547048503388910163287916513427409193998045119986267987892522931703487420953769290650229176116308194977201080691718825944370436642709192983358059711255925052564016519597530235976618244111239816418652282585432539731271068892992142956810775762851238126881225206289553948196520384709574383566733478326330112084307565420647201107231840508040019131253750047046446929758911912155202166566751947087545292626353331520202690130850009389387290465497377022080531269511355734944672010542204118978272180881335465227900174033380001851066811103401787656367819132934758616060307366679580043123632565656840669377840733018248707250548277181001911990237151790533341326223932843775840498222236867608395855700891719880219904948672458645420169533565809609056209006342663841718949396996175294237942265325043426430990062217643279654512512640557763489491751115437780462208361129433667449740743123546232162409802316714286708788831227582498585478334315076725145986771341647015244092760289407649044493584479944044779273447198382196766547779885914425854375158084417582279211000449529495605127376707776277159376010648950025135061284601443461110447113346277147728593420397807946636800365109579479211273476195727270004743568492888900356505584731622538401071221591141889158461271000051210318027818802379539544396973228585821742794928813630781709195703717312953337431290682263448669168179857644544116657440168099166467471736180072984407514757289757495435699300593165669101965987430482600019222913485092771346963058673132443387835726110205958057187517487684058179749952286341120230051432903482992282688283815697442898155194928723360957436110770317998431272108100149791425689283090777721270428030993332057319821685391144252815655146410678839177846108260765981523812232294638190350688210999605869296307711846463311346627138400477211801219366400312514793356564308532012682051019030257269068628100171220662165246389309014292764479226570049772046255291379151017129899157296574099437276707879597755725339406865738613810979022640265737120949077721294633786520294559343155148383011293584240192753971366644780434237846862975993387453786681995831719537733846579480995517357440575781962659282856696638992709756358478461648462532279323701121386551383509193782388241965285971965887701816406255233933761008649762854363984142178331798953040874526844255758512982810004271235810681505829473926495256537353108899526434200682024946218302499640511518360332022463196599199779172637638655415918976955930735312156870786600023896830267884391447789311101069654521354446521135407720085038662159974712373018912537116964809382149581004863115431780452188813210275393919111435118030412595133958954313836191108258769640843644195537185904547405641078708492098917460393911427237155683288565433183738513871595286090814836422982384810033331519971102974091067660369548406192526284519976668985518575216481570167748402860759832933071281814538397923687510782620605409323050353840034866296214149657376249634795555007199540807313397329050410326609108411299737760271566308288500400587417017113933243099961248847368789383209110747378488312550109911605079801570534271874115018095746872468910162721975463388518648962869080447866370484866697404176437230771558469231403088139693477706784802801265075586678597768511791952562627345622499328 + # 100788726492580594349650258277496659410917619472657560321971265983799894639441017438166498752997098978003489632843381325240982516059309714013145358125224597827602157516585886911710102182473475545864474089191789296685473601331678556438310133356793199956062857423397512495293688453655805536015029176541424005214818033707522950635262669828538132795615008381824067071229426026518897202246241637377064076189277685257166926338187911595052586669184297526234794666364657344206795357967279911782849686515024121916258300642000317525374433525235296287037535618423661645124459323811792936193272341688261801253469089129439519903538495370298752436267926761998785090092411372633429302950606054074205533246665546979112178855223925266166034953000200646676762301817000435641690517142795144469005596172113586738287118865058604922865654348297975054956781513943444060257230946224520058527667925776273088622386666860662470481606622952298649177217986593047495967209669116410592230626047083795555559776477430548946990993890380787911273437967786556742804566652408275798339221179283430482118140020742719695900657696142739101628984271513292954605191778803974738871043737934546460016184719168074062912083778327025499841998124431899131874519812228674255796948879306477894924710085384116453080236862135706628989104070747737689294987000148388110561753028594988959655591699155508380909698460304884908709246116411180876105681720036833487450945730831039969246996849503525429840196651386469599438064049723005123629385485140945945416764414133189625489032807860400751723995946290581976152580477047961138617997133510128194027510895265424780627975864980749945631413855375897945293107842908479797077570371447220506451229526132919408351287454305932886749170523056147842439813407002950370505941417426433452282518739345666494683448699945734453214481915512562995906034771246088038719298959180199052759295868161570318718927430655393250250811804905393113074074574608255523847592006804881016594060188745212933427473833239777228852952217878690668413947367586040297784502192683200664398064682201012931468052982448022330449955215606614483165425935154496289535573901139223034819824408001205784146243892228030383941863746839845526558421740316887532141893650230936137269356278754487130882868595412163277284772124736531380334814212708066069618080153747333573454834500999083737284449542481264971030785043701582134343596645346132964567391370300568578875509971483039720438955919863275044932311289587494336123538202079503922025306586828117649623642521324286648529829664567232756108169459356549144779085080036654897525078792273443307070502103724611233768453196294899770515940520895908289018412144327894912660060761908970811602375085884115384049610753387776858733798341463052471017393165656926510611173543365663267563198760597092606598728110197523695339144204179424646442294307593146446562536865057987897899655645968129515654148044008249646703504419478535298270862753806142083172190778193001810574370442181909146645889199829207284871551220439225371051511970054965951914399901815408791418836185742573331879114400013259342896515702942707292473805188905427717363630137869116872433627556880809120353079342030725196065815470427569172350436988386579444534375353968759750750178342190349607711313840613843718547859929387259163285524671855725511880656411741012446023392964655239624520090988149679656514996202498334816938716757663800773997302639681907686195671083505910700098597156238624351157219093280177066146218516478636356056420098245995113668018177690728654922707281126889313941750547830163078886329630807850633273613622550216189245162735650139455042125252043274668279981753287687674520319519360593091620297805736177366738063651905396783336064579717230286821545930579779462534206093794040878198825916141099864730374109311705285661056855668930671948265232862757146615431791375559792290479316263924560826544387396762768331402198937951439504767950821089741987629257538953417586416459087855138539304027013800937360598578194413362672871055543854633921502486683911956250444582746421552178164852341035733290405311280719066037175324627429434912416361334254696649419037348733709488576582107382055914938194078813926926742828297826939120316120573453588052056773875836843924877773978390546387248009519202370375478981843515393806263037580338009594022254079586380520797699651840576286033587273591899639699077044271208886940540056794360292760863657703246410020854088849880453524038877935317875884698324859548991680533307680053872403383516589028793015681082435908524045497475001609824047204954932626536311826911363867426654549346914317405110707189532251727848751560224936842128628673253616256326013555922159336370177663785738170802777550686079119049748734352584409583136667752555307842739679930698964098088960000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000)%bigQ +. + +Fixpoint numden_Rcontfrac_tailrecB (accu: list bigZ) (n1 d1: bigZ) (n2 d2: bigZ) (fuel: nat) {struct fuel}: + (list bigZ * bigQ * bigQ) := + let default := (rev_append accu nil, BigQ.div (BigQ.Qz n1) (BigQ.Qz d1), BigQ.div (BigQ.Qz n2) (BigQ.Qz d2)) in + match fuel with + | O => default + | S fuel' => + let '(q1, r1) := BigZ.div_eucl n1 d1 in + let '(q2, r2) := BigZ.div_eucl n2 d2 in + match BigZ.eqb q1 q2 with + | false => default + | true => + let r1_is_zero := BigZ.eqb r1 0 in + let r2_is_zero := BigZ.eqb r2 0 in + match Bool.eqb r1_is_zero r2_is_zero with + | false => default + | true => + match r1_is_zero with + | true => + match BigZ.eqb q1 1 with + | true => (rev_append accu nil, 1%bigQ, 1%bigQ) + | false => (rev_append ((q1 - 1)%bigZ :: accu) nil, 1%bigQ, 1%bigQ) + end + | false => numden_Rcontfrac_tailrecB (q1 :: accu) d1 r1 d2 r2 fuel' + end + end + end + end. + +Definition Bnum b := + match b with + | BigQ.Qz t => t + | BigQ.Qq n d => + if (d =? BigN.zero)%bigN then 0%bigZ else n + end. + +Definition Bden b := + match b with + | BigQ.Qz _ => 1%bigN + | BigQ.Qq _ d => if (d =? BigN.zero)%bigN then 1%bigN else d + end. + +Definition rat_Rcontfrac_tailrecB q1 q2 := + numden_Rcontfrac_tailrecB nil (Bnum q1) (BigZ.Pos (Bden q1)) (Bnum q2) (BigZ.Pos (Bden q2)). + +Definition pi_4_contfrac := + rat_Rcontfrac_tailrecB pi_4_approx_low' pi_4_approx_high' 3000. + +(* The following used to fail because of a non canonical representation of 0 in +the bytecode interpreter. Bug reported privately by Tahina Ramananandro. *) +Goal pi_4_contfrac = pi_4_contfrac. +vm_compute. +reflexivity. +Qed. diff --git a/test-suite/success/cc.v b/test-suite/success/cc.v index a70d91963..dc0527d82 100644 --- a/test-suite/success/cc.v +++ b/test-suite/success/cc.v @@ -129,5 +129,10 @@ Qed. End bug_2447. +(* congruence was supposed to do discriminate but it was bugged for + types with indices *) - +Inductive I : nat -> Type := C : I 0 | D : I 0. +Goal ~C=D. +congruence. +Qed. diff --git a/test-suite/success/destruct.v b/test-suite/success/destruct.v index 83a33f75d..90a60daa6 100644 --- a/test-suite/success/destruct.v +++ b/test-suite/success/destruct.v @@ -96,19 +96,21 @@ Abort. (* Check that subterm selection does not solve existing evars *) Goal exists x, S x = S 0. -eexists. +eexists ?[x]. +Show x. (* Incidentally test Show on a named goal *) destruct (S _). (* Incompatible occurrences but takes the first one since Oct 2014 *) change (0 = S 0). Abort. Goal exists x, S 0 = S x. -eexists. +eexists ?[x]. destruct (S _). (* Incompatible occurrences but takes the first one since Oct 2014 *) change (0 = S ?x). +[x]: exact 0. (* Incidentally test applying a tactic to a goal on the shelve *) Abort. Goal exists n p:nat, (S n,S n) = (S p,S p) /\ p = n. -do 2 eexists. +eexists ?[n]; eexists ?[p]. destruct (_, S _). (* Was unifying at some time in trunk, now takes the first occurrence *) change ((n, n0) = (S ?p, S ?p) /\ ?p = ?n). Abort. @@ -387,7 +389,7 @@ Abort. Goal forall b:bool, True. intro b. -destruct !b. +destruct (b). clear b. (* b has to be here *) Abort. @@ -424,7 +426,7 @@ destruct b eqn:H. (* Check natural instantiation behavior when the goal has already an evar *) Goal exists x, S x = x. -eexists. +eexists ?[x]. destruct (S _). change (0 = ?x). Abort. diff --git a/test-suite/success/eauto.v b/test-suite/success/eauto.v index 9e57801e0..773dd321e 100644 --- a/test-suite/success/eauto.v +++ b/test-suite/success/eauto.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/test-suite/success/eqdecide.v b/test-suite/success/eqdecide.v index 1b5c7f183..1f6af0dc4 100644 --- a/test-suite/success/eqdecide.v +++ b/test-suite/success/eqdecide.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/test-suite/success/extraction.v b/test-suite/success/extraction.v index 57f3775d7..0086e090b 100644 --- a/test-suite/success/extraction.v +++ b/test-suite/success/extraction.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/test-suite/success/extraction_impl.v b/test-suite/success/extraction_impl.v new file mode 100644 index 000000000..dfdeff82f --- /dev/null +++ b/test-suite/success/extraction_impl.v @@ -0,0 +1,82 @@ + +(** Examples of extraction with manually-declared implicit arguments *) + +(** NB: we should someday check the produced code instead of + simply running the commands. *) + +(** Bug #4243, part 1 *) + +Inductive dnat : nat -> Type := +| d0 : dnat 0 +| ds : forall n m, n = m -> dnat n -> dnat (S n). + +Extraction Implicit ds [m]. + +Lemma dnat_nat: forall n, dnat n -> nat. +Proof. + intros n d. + induction d as [| n m Heq d IHn]. + exact 0. exact (S IHn). +Defined. + +Recursive Extraction dnat_nat. + +Extraction Implicit dnat_nat [n]. +Recursive Extraction dnat_nat. + +(** Same, with a Fixpoint *) + +Fixpoint dnat_nat' n (d:dnat n) := + match d with + | d0 => 0 + | ds n m _ d => S (dnat_nat' n d) + end. + +Recursive Extraction dnat_nat'. + +Extraction Implicit dnat_nat' [n]. +Recursive Extraction dnat_nat'. + +(** Bug #4243, part 2 *) + +Inductive enat: nat -> Type := + e0: enat 0 +| es: forall n, enat n -> enat (S n). + +Lemma enat_nat: forall n, enat n -> nat. +Proof. + intros n e. + induction e as [| n e IHe]. + exact (O). + exact (S IHe). +Defined. + +Extraction Implicit es [n]. +Extraction Implicit enat_nat [n]. +Recursive Extraction enat_nat. + +(** Same, with a Fixpoint *) + +Fixpoint enat_nat' n (e:enat n) : nat := + match e with + | e0 => 0 + | es n e => S (enat_nat' n e) + end. + +Extraction Implicit enat_nat' [n]. +Recursive Extraction enat_nat'. + +(** Bug #4228 *) + +Module Food. +Inductive Course := +| main: nat -> Course +| dessert: nat -> Course. + +Inductive Meal : Course -> Type := +| one_course : forall n:nat, Meal (main n) +| two_course : forall n m, Meal (main n) -> Meal (dessert m). +Extraction Implicit two_course [n]. +End Food. + +Recursive Extraction Food.Meal. diff --git a/test-suite/success/inds_type_sec.v b/test-suite/success/inds_type_sec.v index b733aef6d..c729b23ce 100644 --- a/test-suite/success/inds_type_sec.v +++ b/test-suite/success/inds_type_sec.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/test-suite/success/induct.v b/test-suite/success/induct.v index 7ae60d989..1ed731f50 100644 --- a/test-suite/success/induct.v +++ b/test-suite/success/induct.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -151,3 +151,46 @@ intros x H1 H. induction H. change (0 = z -> True) in IHrepr''. Abort. + +(* Test double induction *) + +(* This was failing in 8.5 and before because of a bug in the order of + hypotheses *) + +Inductive I2 : Type := + C2 : forall x:nat, x=x -> I2. +Goal forall a b:I2, a = b. +double induction a b. +Abort. + +(* This was leaving useless hypotheses in 8.5 and before because of + the same bug. This is a change of compatibility. *) + +Inductive I3 : Prop := + C3 : forall x:nat, x=x -> I3. +Goal forall a b:I3, a = b. +double induction a b. +Fail clear H. (* H should have been erased *) +Abort. + +(* This one had quantification in reverse order in 8.5 and before *) +(* This is a change of compatibility. *) + +Goal forall m n, le m n -> le n m -> n=m. +intros m n. double induction 1 2. +3:destruct 1. (* Should be "S m0 <= m0" *) +Abort. + +(* Idem *) + +Goal forall m n p q, le m n -> le p q -> n+p=m+q. +intros *. double induction 1 2. +3:clear H2. (* H2 should have been erased *) +Abort. + +(* This is unchanged *) + +Goal forall m n:nat, n=m. +double induction m n. +Abort. + diff --git a/test-suite/success/intros.v b/test-suite/success/intros.v index 35ba94fb6..ee69df977 100644 --- a/test-suite/success/intros.v +++ b/test-suite/success/intros.v @@ -34,38 +34,97 @@ intros _ ?. exact H. Qed. -(* A short test about introduction pattern pat/c *) +(* A short test about introduction pattern pat%c *) Goal (True -> 0=0) -> True /\ False -> 0=0. -intros H (H1/H,_). +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,_). +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 +(* 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. +intros H H1%H. exact H1. Qed. Goal forall n, n = S n -> 0=0. -intros n H/n_Sn. +intros n H%n_Sn. destruct H. Qed. (* Another check about generated names and cleared hypotheses with - pat/c patterns *) + pat%c patterns *) Goal (True -> 0=0 /\ 1=1) -> True -> 0=0. -intros H (H1,?)/H. +intros H (H1,?)%H. change (1=1) in H0. exact H1. Qed. + +(* Checking iterated pat%c1...%cn introduction patterns and side conditions *) + +Goal forall A B C D:Prop, (A -> B -> C) -> (C -> D) -> B -> A -> D. +intros * H H0 H1. +intros H2%H%H0. +- exact H2. +- exact H1. +Qed. + +(* Bug found by Enrico *) + +Goal forall x : nat, True. +intros y%(fun x => x). +Abort. + +(* Fixing a bug in the order of side conditions of a "->" step *) + +Goal (True -> 1=0) -> 1=1. +intros ->. +- reflexivity. +- exact I. +Qed. + +Goal forall x, (True -> x=0) -> 0=x. +intros x ->. +- reflexivity. +- exact I. +Qed. + +(* Fixing a bug when destructing a type with let-ins in the constructor *) + +Inductive I := C : let x:=1 in x=1 -> I. +Goal I -> True. +intros [x H]. (* Was failing in 8.5 *) +Abort. + +(* Ensuring that the (pat1,...,patn) intropatterns has the expected size, up + to skipping let-ins *) + +Goal I -> 1=1. +intros (H). (* This skips x *) +exact H. +Qed. + +Goal I -> 1=1. +Fail intros (x,H,H'). +Fail intros [|]. +intros (x,H). +exact H. +Qed. + +Goal Acc le 0 -> True. +Fail induction 1 as (n,H). (* Induction hypothesis is missing *) +induction 1 as (n,H,IH). +exact Logic.I. +Qed. + + diff --git a/test-suite/success/keyedrewrite.v b/test-suite/success/keyedrewrite.v index bbe9d4bff..b88c142be 100644 --- a/test-suite/success/keyedrewrite.v +++ b/test-suite/success/keyedrewrite.v @@ -22,3 +22,41 @@ Qed. Print Equivalent Keys. End foo. + +Require Import Arith List Omega. + +Definition G {A} (f : A -> A -> A) (x : A) := f x x. + +Lemma list_foo A (l : list A) : G (@app A) (l ++ nil) = G (@app A) l. +Proof. unfold G; rewrite app_nil_r; reflexivity. Qed. + +(* Bundled version of a magma *) +Structure magma := Magma { b_car :> Type; op : b_car -> b_car -> b_car }. +Arguments op {_} _ _. + +(* Instance for lists *) +Canonical Structure list_magma A := Magma (list A) (@app A). + +(* Basically like list_foo, but now uses the op projection instead of app for +the argument of G *) +Lemma test1 A (l : list A) : G op (l ++ nil) = G op l. + +(* Ensure that conversion of terms with evars is allowed once a keyed candidate unifier is found *) +rewrite -> list_foo. +reflexivity. +Qed. + +(* Basically like list_foo, but now uses the op projection for everything *) +Lemma test2 A (l : list A) : G op (op l nil) = G op l. +Proof. +rewrite ->list_foo. +reflexivity. +Qed. + + Require Import Bool. + Set Keyed Unification. + + Lemma test b : b && true = b. + Fail rewrite andb_true_l. + Admitted. +
\ No newline at end of file diff --git a/test-suite/success/ltac.v b/test-suite/success/ltac.v index 5bef2e512..ce9099059 100644 --- a/test-suite/success/ltac.v +++ b/test-suite/success/ltac.v @@ -15,7 +15,7 @@ Ltac F x := idtac; G x with G y := idtac; F y. (* Check that Match Context keeps a closure *) -Ltac U := let a := constr:I in +Ltac U := let a := constr:(I) in match goal with | |- _ => apply a end. @@ -75,7 +75,7 @@ Qed. (* Check context binding *) Ltac sym t := - match constr:t with + match constr:(t) with | context C[(?X1 = ?X2)] => context C [X1 = X2] end. @@ -143,7 +143,7 @@ Qed. Ltac check_binding y := cut ((fun y => y) = S). Goal True. -check_binding ipattern:H. +check_binding ipattern:(H). Abort. (* Check that variables explicitly parsed as ltac variables are not @@ -151,7 +151,7 @@ Abort. Ltac afi tac := intros; tac. Goal 1 = 2. -afi ltac:auto. +afi ltac:(auto). Abort. (* Tactic Notation avec listes *) @@ -174,7 +174,7 @@ Abort. empty args *) Goal True. -match constr:@None with @None => exact I end. +match constr:(@None) with @None => exact I end. Abort. (* Check second-order pattern unification *) @@ -218,7 +218,7 @@ Ltac Z1 t := set (x:=t). Ltac Z2 t := t. Goal True -> True. Z1 O. -Z2 ltac:O. +Z2 ltac:(O). exact I. Qed. @@ -302,7 +302,7 @@ Abort. (* Check instantiation of binders using ltac names *) Goal True. -let x := ipattern:y in assert (forall x y, x = y + 0). +let x := ipattern:(y) in assert (forall x y, x = y + 0). intro. destruct y. (* Check that the name is y here *) Abort. @@ -317,29 +317,3 @@ let T := constr:(fun a b : nat => a) in end. exact (eq_refl n). Qed. - -(* Check that matching "match" does not look into the invisible - canonically generated binders of the return clause and of the branches *) - -Goal forall n, match n with 0 => true | S _ => false end = true. -intros. unfold nat_rect. -Fail match goal with |- context [nat] => idtac end. -Abort. - -(* Check that branches of automatically generated elimination - principle are correctly eta-expanded and hence matchable as seen - from the user point of view *) - -Goal forall a f n, nat_rect (fun _ => nat) a f n = 0. -intros. unfold nat_rect. -match goal with |- context [f _] => idtac end. -Abort. - -(* Check that branches of automatically generated elimination - principle are in correct form also in the presence of let-ins *) - -Inductive a (b:=0) : let b':=1 in Type := c : let d:=0 in a. -Goal forall x, match x with c => 0 end = 1. -intros. -match goal with |- context [0] => idtac end. -Abort. diff --git a/test-suite/success/mutual_ind.v b/test-suite/success/mutual_ind.v index 54cfa658c..45c1a5e58 100644 --- a/test-suite/success/mutual_ind.v +++ b/test-suite/success/mutual_ind.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/test-suite/success/polymorphism.v b/test-suite/success/polymorphism.v index d6bbfe29a..878875bd9 100644 --- a/test-suite/success/polymorphism.v +++ b/test-suite/success/polymorphism.v @@ -242,7 +242,7 @@ Fail Check (Prop : Set). Fail Check (Set : Set). Check (Set : Type). Check (Prop : Type). -Definition setType := $(let t := type of Set in exact t)$. +Definition setType := ltac:(let t := type of Set in exact t). Definition foo (A : Prop) := A. @@ -303,7 +303,7 @@ 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 RL (x : R@{i}) : ltac:(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. diff --git a/test-suite/success/primitiveproj.v b/test-suite/success/primitiveproj.v index 125615c53..b5e6ccd61 100644 --- a/test-suite/success/primitiveproj.v +++ b/test-suite/success/primitiveproj.v @@ -35,10 +35,6 @@ Set Implicit Arguments. Check nat. -(* Inductive X (U:Type) := Foo (k : nat) (x : X U). *) -(* Parameter x : X nat. *) -(* Check x.(k). *) - Inductive X (U:Type) := { k : nat; a: k = k -> X U; b : let x := a eq_refl in X U }. Parameter x:X nat. @@ -49,18 +45,8 @@ Inductive Y := { next : option Y }. Check _.(next) : option Y. Lemma eta_ind (y : Y) : y = Build_Y y.(next). -Proof. reflexivity. Defined. - -Variable t : Y. +Proof. Fail reflexivity. Abort. -Fixpoint yn (n : nat) (y : Y) : Y := - match n with - | 0 => t - | S n => {| next := Some (yn n y) |} - end. - -Lemma eta_ind' (y: Y) : Some (yn 100 y) = Some {| next := (yn 100 y).(next) |}. -Proof. reflexivity. Defined. (* @@ -194,4 +180,17 @@ 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 +(*Unset Printing Primitive Projection Parameters.*) + +(* Primitive projections in the presence of let-ins (was not failing in beta3)*) + +Set Primitive Projections. +Record s (x:nat) (y:=S x) := {c:=x; d:x=c}. +Lemma f : 0=1. +Proof. +Fail apply d. +(* +split. +reflexivity. +Qed. +*) diff --git a/test-suite/success/proof_using.v b/test-suite/success/proof_using.v index c83f45e2a..adaa05ad0 100644 --- a/test-suite/success/proof_using.v +++ b/test-suite/success/proof_using.v @@ -178,6 +178,7 @@ End Let. Check (test_let 3). +(* Disabled Section Clear. Variable a: nat. @@ -192,6 +193,6 @@ trivial. Qed. End Clear. - +*) diff --git a/test-suite/success/refine.v b/test-suite/success/refine.v index 1e667884b..352abb2af 100644 --- a/test-suite/success/refine.v +++ b/test-suite/success/refine.v @@ -62,7 +62,7 @@ Abort. Goal (forall n : nat, n = 0 -> Prop) -> Prop. intro P. refine (P _ _). -2:reflexivity. +reflexivity. Abort. (* Submitted by Jacek Chrzaszcz (bug #1102) *) diff --git a/test-suite/success/setoid_test.v b/test-suite/success/setoid_test.v index 0465c4b3f..4c173a3cd 100644 --- a/test-suite/success/setoid_test.v +++ b/test-suite/success/setoid_test.v @@ -166,3 +166,11 @@ Proof. intros. setoid_rewrite <- foo_prf. change (beq_nat x 0 = y). Abort. Goal forall (x : nat) (y : bool), beq_nat (foo_neg x) 0 = foo_neg y. Proof. intros. setoid_rewrite <- @foo_prf at 1. change (beq_nat x 0 = foo_neg y). Abort. +(* This should not raise an anomaly as it did for some time in early 2016 *) + +Definition t := nat -> bool. +Definition h (a b : t) := forall n, a n = b n. +Goal forall a b, h a b -> a 0 = true. +intros. +rewrite H. (* Fallback on ordinary rewrite without anomaly *) +Abort. diff --git a/test-suite/success/sideff.v b/test-suite/success/sideff.v new file mode 100644 index 000000000..3c0b81568 --- /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/unfold.v b/test-suite/success/unfold.v index 2954e2556..d595cbc2b 100644 --- a/test-suite/success/unfold.v +++ b/test-suite/success/unfold.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/test-suite/success/univers.v b/test-suite/success/univers.v index e00701fb6..269359ae6 100644 --- a/test-suite/success/univers.v +++ b/test-suite/success/univers.v @@ -60,3 +60,20 @@ Qed. (* Submitted by Danko Ilik (bug report #1507); related to LetIn *) Record U : Type := { A:=Type; a:A }. + +(** Check assignement of sorts to inductives and records. *) + +Variable sh : list nat. + +Definition is_box_in_shape (b :nat * nat) := True. +Definition myType := Type. + +Module Ind. +Inductive box_in : myType := + myBox (coord : nat * nat) (_ : is_box_in_shape coord) : box_in. +End Ind. + +Module Rec. +Record box_in : myType := + BoxIn { coord :> nat * nat; _ : is_box_in_shape coord }. +End Rec.
\ No newline at end of file diff --git a/test-suite/success/univnames.v b/test-suite/success/univnames.v index 31d264f64..048b53d26 100644 --- a/test-suite/success/univnames.v +++ b/test-suite/success/univnames.v @@ -21,6 +21,6 @@ Inductive bla@{l k} : Type@{k} := blaI : Type@{l} -> bla. Inductive blacopy@{k l} : Type@{k} := blacopyI : Type@{l} -> blacopy. -Universe g. +Monomorphic Universe g. Inductive blacopy'@{l} : Type@{g} := blacopy'I : Type@{l} -> blacopy'.
\ No newline at end of file diff --git a/test-suite/success/unshelve.v b/test-suite/success/unshelve.v new file mode 100644 index 000000000..672222bdd --- /dev/null +++ b/test-suite/success/unshelve.v @@ -0,0 +1,11 @@ +Axiom F : forall (b : bool), b = true -> + forall (i : unit), i = i -> True. + +Goal True. +Proof. +unshelve (refine (F _ _ _ _)). ++ exact true. ++ exact tt. ++ exact (@eq_refl bool true). ++ exact (@eq_refl unit tt). +Qed. diff --git a/test-suite/success/vm_univ_poly.v b/test-suite/success/vm_univ_poly.v new file mode 100644 index 000000000..58fa39743 --- /dev/null +++ b/test-suite/success/vm_univ_poly.v @@ -0,0 +1,141 @@ +(* 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@{i} (T : Type@{i}) : Type@{i} := +| PSome : T -> poption@{i} T +| PNone : poption@{i} T. + +Polymorphic Definition poption_default@{i} {T : Type@{i}} (p : poption@{i} T) (x : T) : T := + match p with + | @PSome _ y => y + | @PNone _ => x + end. + +Polymorphic Inductive plist@{i} (T : Type@{i}) : Type@{i} := +| pnil +| pcons : T -> plist@{i} T -> plist@{i} T. + +Arguments pnil {_}. +Arguments pcons {_} _ _. + +Polymorphic Definition pmap@{i j} + {T : Type@{i}} {U : Type@{j}} (f : T -> U) := + fix 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. + +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@{i} (T : Type@{i}) : Type@{i} := +| Empty +| Branch : plist@{i} (Tree@{i} T) -> Tree@{i} T. + +Polymorphic Definition pfold@{i u} + {T : Type@{i}} {U : Type@{u}} (f : T -> U -> U) := + fix pfold (acc : U) (ls : plist@{i} T) : U := + match ls with + | pnil => acc + | pcons a b => pfold (f a acc) b + end. + +Polymorphic Inductive nat@{i} : Type@{i} := +| O +| S : nat -> nat. + +Polymorphic Fixpoint nat_max@{i} (a b : nat@{i}) : nat@{i} := + match a , b with + | O , b => b + | a , O => a + | S a , S b => S (nat_max a b) + end. + +Polymorphic Fixpoint height@{i} {T : Type@{i}} (t : Tree@{i} T) : nat@{i} := + match t return nat@{i} with + | Empty _ => O + | Branch _ ls => S@{i} (pfold@{i i} nat_max O (pmap height ls)) + end. + +Polymorphic Fixpoint repeat@{i} {T : Type@{i}} (n : nat@{i}) (v : T) : plist@{i} T := + match n return plist@{i} T with + | O => pnil + | S n => pcons@{i} v (repeat n v) + end. + +Polymorphic Fixpoint big_tree@{i} (n : nat@{i}) : Tree@{i} nat@{i} := + match n with + | O => @Empty nat@{i} + | S n' => Branch@{i} nat@{i} (repeat@{i} n' (big_tree@{i} n')) + end. + +Eval compute in height (big_tree (S (S (S O)))). + +Let big := S (S (S (S (S O)))). +Polymorphic Definition really_big@{i} := (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}) <: @eq nat@{Set} (height@{Set} (@Branch@{Set} nat@{Set} (@pnil@{Set} (Tree@{Set} nat@{Set})))) (S@{Set} O@{Set}). + +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/success/vm_univ_poly_match.v b/test-suite/success/vm_univ_poly_match.v new file mode 100644 index 000000000..abe6d0fe0 --- /dev/null +++ b/test-suite/success/vm_univ_poly_match.v @@ -0,0 +1,28 @@ +Set Dump Bytecode. +Set Printing Universes. +Set Printing All. + +Polymorphic Class Applicative@{d c} (T : Type@{d} -> Type@{c}) := +{ pure : forall {A : Type@{d}}, A -> T A + ; ap : forall {A B : Type@{d}}, T (A -> B) -> T A -> T B +}. + +Universes Uo Ua. + +Eval compute in @pure@{Uo Ua}. + +Global Instance Applicative_option : Applicative@{Uo Ua} option := +{| pure := @Some + ; ap := fun _ _ f x => + match f , x with + | Some f , Some x => Some (f x) + | _ , _ => None + end +|}. + +Definition foo := ap (ap (pure plus) (pure 1)) (pure 1). + +Print foo. + + +Eval vm_compute in foo. diff --git a/test-suite/typeclasses/NewSetoid.v b/test-suite/typeclasses/NewSetoid.v index 6f37de658..49f20a23f 100644 --- a/test-suite/typeclasses/NewSetoid.v +++ b/test-suite/typeclasses/NewSetoid.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/test-suite/typeclasses/open_constr.v b/test-suite/typeclasses/open_constr.v new file mode 100644 index 000000000..5f1785c70 --- /dev/null +++ b/test-suite/typeclasses/open_constr.v @@ -0,0 +1,12 @@ +Tactic Notation "opose" open_constr(foo) := pose foo. +Class Foo := Build_Foo : Set. +Axiom f : forall `{Foo}, Set. +Set Printing Implicit. +Goal forall `{Foo}, True. +Proof. + intro H. + pose f. + opose f. + Fail let x := (eval hnf in P) in has_evar x. + let x := (eval hnf in P0) in has_evar x. + diff --git a/test-suite/vio/print.v b/test-suite/vio/print.v new file mode 100644 index 000000000..9c36a463c --- /dev/null +++ b/test-suite/vio/print.v @@ -0,0 +1,10 @@ +Lemma a : True. +Proof. +idtac. +exact I. +Qed. + +Print a. + +Lemma b : False. +Admitted. diff --git a/theories/Arith/Arith.v b/theories/Arith/Arith.v index 620a42014..953f7e4db 100644 --- a/theories/Arith/Arith.v +++ b/theories/Arith/Arith.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Arith/Arith_base.v b/theories/Arith/Arith_base.v index a99c4113d..b378828ef 100644 --- a/theories/Arith/Arith_base.v +++ b/theories/Arith/Arith_base.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Arith/Between.v b/theories/Arith/Between.v index 067235413..f998e8619 100644 --- a/theories/Arith/Between.v +++ b/theories/Arith/Between.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Arith/Bool_nat.v b/theories/Arith/Bool_nat.v index f91f3340a..602555b60 100644 --- a/theories/Arith/Bool_nat.v +++ b/theories/Arith/Bool_nat.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Arith/Compare.v b/theories/Arith/Compare.v index 400f2d81a..610e9a697 100644 --- a/theories/Arith/Compare.v +++ b/theories/Arith/Compare.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Arith/Compare_dec.v b/theories/Arith/Compare_dec.v index a97cf6dce..976507b56 100644 --- a/theories/Arith/Compare_dec.v +++ b/theories/Arith/Compare_dec.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Arith/Div2.v b/theories/Arith/Div2.v index 1c65a192a..016cb85e9 100644 --- a/theories/Arith/Div2.v +++ b/theories/Arith/Div2.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Arith/EqNat.v b/theories/Arith/EqNat.v index 2771670ef..206fc0ab5 100644 --- a/theories/Arith/EqNat.v +++ b/theories/Arith/EqNat.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Arith/Euclid.v b/theories/Arith/Euclid.v index eaacab02d..fbe98d172 100644 --- a/theories/Arith/Euclid.v +++ b/theories/Arith/Euclid.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Arith/Even.v b/theories/Arith/Even.v index 0f94a8ed6..3c8c250ab 100644 --- a/theories/Arith/Even.v +++ b/theories/Arith/Even.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Arith/Factorial.v b/theories/Arith/Factorial.v index 7d29f23c6..b119bb000 100644 --- a/theories/Arith/Factorial.v +++ b/theories/Arith/Factorial.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Arith/Gt.v b/theories/Arith/Gt.v index e406ff0dc..dfd576946 100644 --- a/theories/Arith/Gt.v +++ b/theories/Arith/Gt.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Arith/Le.v b/theories/Arith/Le.v index 875863e4a..ceb91187b 100644 --- a/theories/Arith/Le.v +++ b/theories/Arith/Le.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Arith/Lt.v b/theories/Arith/Lt.v index b783ca33c..f824ee6fb 100644 --- a/theories/Arith/Lt.v +++ b/theories/Arith/Lt.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Arith/Max.v b/theories/Arith/Max.v index 26875373b..65534b2e3 100644 --- a/theories/Arith/Max.v +++ b/theories/Arith/Max.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Arith/Min.v b/theories/Arith/Min.v index f2fa3aec6..38e59b7b8 100644 --- a/theories/Arith/Min.v +++ b/theories/Arith/Min.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Arith/Minus.v b/theories/Arith/Minus.v index 6e312e4fd..bc3a318cf 100644 --- a/theories/Arith/Minus.v +++ b/theories/Arith/Minus.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Arith/Mult.v b/theories/Arith/Mult.v index 2d82920b3..965812432 100644 --- a/theories/Arith/Mult.v +++ b/theories/Arith/Mult.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Arith/PeanoNat.v b/theories/Arith/PeanoNat.v index 799031a20..e3240bb78 100644 --- a/theories/Arith/PeanoNat.v +++ b/theories/Arith/PeanoNat.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Arith/Peano_dec.v b/theories/Arith/Peano_dec.v index a7ede3fc5..340a79689 100644 --- a/theories/Arith/Peano_dec.v +++ b/theories/Arith/Peano_dec.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Arith/Wf_nat.v b/theories/Arith/Wf_nat.v index 647648300..94bbd50a9 100644 --- a/theories/Arith/Wf_nat.v +++ b/theories/Arith/Wf_nat.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Bool/Bool.v b/theories/Bool/Bool.v index cc12cf47f..721ab6932 100644 --- a/theories/Bool/Bool.v +++ b/theories/Bool/Bool.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Bool/BoolEq.v b/theories/Bool/BoolEq.v index 11af2fd1b..aec4f0bbf 100644 --- a/theories/Bool/BoolEq.v +++ b/theories/Bool/BoolEq.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Bool/Bvector.v b/theories/Bool/Bvector.v index 7c63f0698..09f643c8e 100644 --- a/theories/Bool/Bvector.v +++ b/theories/Bool/Bvector.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Bool/DecBool.v b/theories/Bool/DecBool.v index e0b8ec9bf..501366ce2 100644 --- a/theories/Bool/DecBool.v +++ b/theories/Bool/DecBool.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Bool/IfProp.v b/theories/Bool/IfProp.v index a0acbe8c1..11f3d1d6f 100644 --- a/theories/Bool/IfProp.v +++ b/theories/Bool/IfProp.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Bool/Sumbool.v b/theories/Bool/Sumbool.v index c2e9183b6..fd7f42e2b 100644 --- a/theories/Bool/Sumbool.v +++ b/theories/Bool/Sumbool.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Bool/Zerob.v b/theories/Bool/Zerob.v index e146f25f0..16e47ac5a 100644 --- a/theories/Bool/Zerob.v +++ b/theories/Bool/Zerob.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Classes/CEquivalence.v b/theories/Classes/CEquivalence.v index 65353ed20..bd01de47e 100644 --- a/theories/Classes/CEquivalence.v +++ b/theories/Classes/CEquivalence.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Classes/CMorphisms.v b/theories/Classes/CMorphisms.v index fdedbf672..1cfca4169 100644 --- a/theories/Classes/CMorphisms.v +++ b/theories/Classes/CMorphisms.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -269,16 +269,6 @@ Section GenericInstances. Unset Strict Universe Declaration. (** 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@{i j Prop} R) := _. - - Next Obligation. - Proof. - unfold complement. - pose (mR x y X x0 y0 X0). - intuition. - Qed. (** The [flip] too, actually the [flip] instance is a bit more general. *) Program Definition flip_proper @@ -462,7 +452,7 @@ Ltac partial_application_tactic := let rec do_partial_apps H m cont := match m with | ?m' ?x => class_apply @Reflexive_partial_app_morphism ; - [(do_partial_apps H m' ltac:idtac)|clear H] + [(do_partial_apps H m' ltac:(idtac))|clear H] | _ => cont end in @@ -521,8 +511,8 @@ Ltac proper_reflexive := Hint Extern 1 (subrelation (flip _) _) => class_apply @flip1 : typeclass_instances. Hint Extern 1 (subrelation _ (flip _)) => class_apply @flip2 : typeclass_instances. -Hint Extern 1 (Proper _ (complement _)) => apply @complement_proper - : typeclass_instances. +(* Hint Extern 1 (Proper _ (complement _)) => apply @complement_proper *) +(* : typeclass_instances. *) Hint Extern 1 (Proper _ (flip _)) => apply @flip_proper : typeclass_instances. Hint Extern 2 (@Proper _ (flip _) _) => class_apply @proper_flip_proper @@ -537,7 +527,7 @@ Hint Extern 7 (@Proper _ _ _) => proper_reflexive Section Normalize. Context (A : Type). - Class Normalizes (m : crelation A) (m' : crelation A) : Prop := + Class Normalizes (m : crelation A) (m' : crelation A) := normalizes : relation_equivalence m m'. (** Current strategy: add [flip] everywhere and reduce using [subrelation] diff --git a/theories/Classes/CRelationClasses.v b/theories/Classes/CRelationClasses.v index 35b2b8a3d..3d7ef01fb 100644 --- a/theories/Classes/CRelationClasses.v +++ b/theories/Classes/CRelationClasses.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Classes/DecidableClass.v b/theories/Classes/DecidableClass.v index 9fe3d0fe8..a3b7e3115 100644 --- a/theories/Classes/DecidableClass.v +++ b/theories/Classes/DecidableClass.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Classes/EquivDec.v b/theories/Classes/EquivDec.v index 59e800c27..52313735e 100644 --- a/theories/Classes/EquivDec.v +++ b/theories/Classes/EquivDec.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Classes/Equivalence.v b/theories/Classes/Equivalence.v index c281af800..c45889479 100644 --- a/theories/Classes/Equivalence.v +++ b/theories/Classes/Equivalence.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Classes/Init.v b/theories/Classes/Init.v index 9574cf857..c13b36fd1 100644 --- a/theories/Classes/Init.v +++ b/theories/Classes/Init.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Classes/Morphisms.v b/theories/Classes/Morphisms.v index 1bdce6546..81b31d783 100644 --- a/theories/Classes/Morphisms.v +++ b/theories/Classes/Morphisms.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -465,7 +465,7 @@ Ltac partial_application_tactic := let rec do_partial_apps H m cont := match m with | ?m' ?x => class_apply @Reflexive_partial_app_morphism ; - [(do_partial_apps H m' ltac:idtac)|clear H] + [(do_partial_apps H m' ltac:(idtac))|clear H] | _ => cont end in diff --git a/theories/Classes/Morphisms_Prop.v b/theories/Classes/Morphisms_Prop.v index 096c96e5d..159001771 100644 --- a/theories/Classes/Morphisms_Prop.v +++ b/theories/Classes/Morphisms_Prop.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Classes/Morphisms_Relations.v b/theories/Classes/Morphisms_Relations.v index 68a8c06a3..6048fe067 100644 --- a/theories/Classes/Morphisms_Relations.v +++ b/theories/Classes/Morphisms_Relations.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Classes/RelationClasses.v b/theories/Classes/RelationClasses.v index 15cb02d37..11c204dae 100644 --- a/theories/Classes/RelationClasses.v +++ b/theories/Classes/RelationClasses.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -208,6 +208,10 @@ Hint Extern 4 (subrelation (flip _) _) => class_apply @subrelation_symmetric : typeclass_instances. Arguments irreflexivity {A R Irreflexive} [x] _. +Arguments symmetry {A} {R} {_} [x] [y] _. +Arguments asymmetry {A} {R} {_} [x] [y] _ _. +Arguments transitivity {A} {R} {_} [x] [y] [z] _ _. +Arguments Antisymmetric A eqA {_} _. Hint Resolve irreflexivity : ord. diff --git a/theories/Classes/SetoidClass.v b/theories/Classes/SetoidClass.v index f20100fe9..4b133a4d1 100644 --- a/theories/Classes/SetoidClass.v +++ b/theories/Classes/SetoidClass.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Classes/SetoidDec.v b/theories/Classes/SetoidDec.v index bf05934e9..7201c0b16 100644 --- a/theories/Classes/SetoidDec.v +++ b/theories/Classes/SetoidDec.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Classes/SetoidTactics.v b/theories/Classes/SetoidTactics.v index 8ca93341c..190397ae4 100644 --- a/theories/Classes/SetoidTactics.v +++ b/theories/Classes/SetoidTactics.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -77,23 +77,23 @@ Tactic Notation "setoid_replace" constr(x) "with" constr(y) Tactic Notation "setoid_replace" constr(x) "with" constr(y) "by" tactic3(t) := - setoidreplace (default_relation x y) ltac:t. + setoidreplace (default_relation x y) ltac:(t). Tactic Notation "setoid_replace" constr(x) "with" constr(y) "at" int_or_var_list(o) "by" tactic3(t) := - setoidreplaceat (default_relation x y) ltac:t o. + setoidreplaceat (default_relation x y) ltac:(t) o. Tactic Notation "setoid_replace" constr(x) "with" constr(y) "in" hyp(id) "by" tactic3(t) := - setoidreplacein (default_relation x y) id ltac:t. + setoidreplacein (default_relation x y) id ltac:(t). Tactic Notation "setoid_replace" constr(x) "with" constr(y) "in" hyp(id) "at" int_or_var_list(o) "by" tactic3(t) := - setoidreplaceinat (default_relation x y) id ltac:t o. + setoidreplaceinat (default_relation x y) id ltac:(t) o. Tactic Notation "setoid_replace" constr(x) "with" constr(y) "using" "relation" constr(rel) := @@ -107,13 +107,13 @@ Tactic Notation "setoid_replace" constr(x) "with" constr(y) Tactic Notation "setoid_replace" constr(x) "with" constr(y) "using" "relation" constr(rel) "by" tactic3(t) := - setoidreplace (rel x y) ltac:t. + setoidreplace (rel x y) ltac:(t). Tactic Notation "setoid_replace" constr(x) "with" constr(y) "using" "relation" constr(rel) "at" int_or_var_list(o) "by" tactic3(t) := - setoidreplaceat (rel x y) ltac:t o. + setoidreplaceat (rel x y) ltac:(t) o. Tactic Notation "setoid_replace" constr(x) "with" constr(y) "using" "relation" constr(rel) @@ -130,14 +130,14 @@ Tactic Notation "setoid_replace" constr(x) "with" constr(y) "using" "relation" constr(rel) "in" hyp(id) "by" tactic3(t) := - setoidreplacein (rel x y) id ltac:t. + setoidreplacein (rel x y) id ltac:(t). Tactic Notation "setoid_replace" constr(x) "with" constr(y) "using" "relation" constr(rel) "in" hyp(id) "at" int_or_var_list(o) "by" tactic3(t) := - setoidreplaceinat (rel x y) id ltac:t o. + setoidreplaceinat (rel x y) id ltac:(t) o. (** The [add_morphism_tactic] tactic is run at each [Add Morphism] command before giving the hand back to the user to discharge the diff --git a/theories/Compat/AdmitAxiom.v b/theories/Compat/AdmitAxiom.v new file mode 100644 index 000000000..4d9f55cfe --- /dev/null +++ b/theories/Compat/AdmitAxiom.v @@ -0,0 +1,15 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Compatibility file for making the admit tactic act similar to Coq v8.4. In +8.4, [admit] created a new axiom; in 8.5, it just shelves the goal. This +compatibility definition is not in the Coq84.v file to avoid loading an +inconsistent axiom implicitly. *) + +Axiom proof_admitted : False. +Ltac admit := clear; abstract case proof_admitted. diff --git a/theories/Compat/Coq84.v b/theories/Compat/Coq84.v index 83016976e..90083b00d 100644 --- a/theories/Compat/Coq84.v +++ b/theories/Compat/Coq84.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -18,10 +18,6 @@ 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. @@ -34,6 +30,27 @@ 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. *) diff --git a/theories/Compat/Coq85.v b/theories/Compat/Coq85.v index 1622f2aed..af2e04f88 100644 --- a/theories/Compat/Coq85.v +++ b/theories/Compat/Coq85.v @@ -1,9 +1,16 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) (** Compatibility file for making Coq act similar to Coq v8.5 *) + +(* In 8.5, "intros [|]", taken e.g. on a goal "A\/B->C", does not + behave as "intros [H|H]" but leave instead hypotheses quantified in + the goal, here producing subgoals A->C and B->C. *) + +Unset Bracketing Last Introduction Pattern. + diff --git a/theories/Compat/vo.itarget b/theories/Compat/vo.itarget index c0c40ab1c..43b197004 100644 --- a/theories/Compat/vo.itarget +++ b/theories/Compat/vo.itarget @@ -1,2 +1,3 @@ +AdmitAxiom.vo Coq84.vo Coq85.vo diff --git a/theories/FSets/FMapFacts.v b/theories/FSets/FMapFacts.v index 8c6f4b64a..eaeb2914b 100644 --- a/theories/FSets/FMapFacts.v +++ b/theories/FSets/FMapFacts.v @@ -2143,7 +2143,7 @@ Module OrdProperties (M:S). Section Fold_properties. (** The following lemma has already been proved on Weak Maps, - but with one additionnal hypothesis (some [transpose] fact). *) + but with one additional hypothesis (some [transpose] fact). *) Lemma fold_Equal : forall m1 m2 (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) (f:key->elt->A->A)(i:A), diff --git a/theories/FSets/FMapPositive.v b/theories/FSets/FMapPositive.v index 3eac15b03..9e59f0c50 100644 --- a/theories/FSets/FMapPositive.v +++ b/theories/FSets/FMapPositive.v @@ -1061,7 +1061,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. End PositiveMap. -(** Here come some additionnal facts about this implementation. +(** Here come some additional facts about this implementation. Most are facts that cannot be derivable from the general interface. *) diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v index aaffc0978..ddaf08bf7 100644 --- a/theories/Init/Datatypes.v +++ b/theories/Init/Datatypes.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v index 50f853f0e..85123cc44 100644 --- a/theories/Init/Logic.v +++ b/theories/Init/Logic.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Init/Logic_Type.v b/theories/Init/Logic_Type.v index 1e1264639..4a5f2ad69 100644 --- a/theories/Init/Logic_Type.v +++ b/theories/Init/Logic_Type.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Init/Nat.v b/theories/Init/Nat.v index afb46436c..b8920586f 100644 --- a/theories/Init/Nat.v +++ b/theories/Init/Nat.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Init/Notations.v b/theories/Init/Notations.v index a7bdba90a..65ea8028d 100644 --- a/theories/Init/Notations.v +++ b/theories/Init/Notations.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -85,8 +85,7 @@ Open Scope type_scope. Declare ML Module "coretactics". Declare ML Module "extratactics". -Declare ML Module "eauto". +Declare ML Module "g_auto". Declare ML Module "g_class". Declare ML Module "g_eqdecide". Declare ML Module "g_rewrite". -Declare ML Module "tauto". diff --git a/theories/Init/Peano.v b/theories/Init/Peano.v index 7a14ab39b..3749baf61 100644 --- a/theories/Init/Peano.v +++ b/theories/Init/Peano.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Init/Prelude.v b/theories/Init/Prelude.v index 0efb8744d..03f2328de 100644 --- a/theories/Init/Prelude.v +++ b/theories/Init/Prelude.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -15,6 +15,7 @@ Require Coq.Init.Nat. Require Export Peano. Require Export Coq.Init.Wf. Require Export Coq.Init.Tactics. +Require Export Coq.Init.Tauto. (* Initially available plugins (+ nat_syntax_plugin loaded in Datatypes) *) Declare ML Module "extraction_plugin". diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v index 1384901b7..6c0221856 100644 --- a/theories/Init/Specif.v +++ b/theories/Init/Specif.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Init/Tactics.v b/theories/Init/Tactics.v index a7d3f8062..59fdbb42f 100644 --- a/theories/Init/Tactics.v +++ b/theories/Init/Tactics.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Init/Tauto.v b/theories/Init/Tauto.v new file mode 100644 index 000000000..1e409607a --- /dev/null +++ b/theories/Init/Tauto.v @@ -0,0 +1,101 @@ +Require Import Notations. +Require Import Datatypes. +Require Import Logic. + +Local Declare ML Module "tauto". + +Local Ltac not_dep_intros := + repeat match goal with + | |- (forall (_: ?X1), ?X2) => intro + | |- (Coq.Init.Logic.not _) => unfold Coq.Init.Logic.not at 1; intro + end. + +Local Ltac axioms flags := + match reverse goal with + | |- ?X1 => is_unit_or_eq flags X1; constructor 1 + | _:?X1 |- _ => is_empty flags X1; elimtype X1; assumption + | _:?X1 |- ?X1 => assumption + end. + +Local Ltac simplif flags := + not_dep_intros; + repeat + (match reverse goal with + | id: ?X1 |- _ => is_conj flags X1; elim id; do 2 intro; clear id + | id: (Coq.Init.Logic.iff _ _) |- _ => elim id; do 2 intro; clear id + | id: (Coq.Init.Logic.not _) |- _ => red in id + | id: ?X1 |- _ => is_disj flags X1; elim id; intro; clear id + | id0: (forall (_: ?X1), ?X2), id1: ?X1|- _ => + (* generalize (id0 id1); intro; clear id0 does not work + (see Marco Maggiesi's bug PR#301) + so we instead use Assert and exact. *) + assert X2; [exact (id0 id1) | clear id0] + | id: forall (_ : ?X1), ?X2|- _ => + is_unit_or_eq flags X1; cut X2; + [ intro; clear id + | (* id : forall (_: ?X1), ?X2 |- ?X2 *) + cut X1; [exact id| constructor 1; fail] + ] + | id: forall (_ : ?X1), ?X2|- _ => + flatten_contravariant_conj flags X1 X2 id + (* moved from "id:(?A/\?B)->?X2|-" to "?A->?B->?X2|-" *) + | id: forall (_: Coq.Init.Logic.iff ?X1 ?X2), ?X3|- _ => + assert (forall (_: forall _:X1, X2), forall (_: forall _: X2, X1), X3) + by (do 2 intro; apply id; split; assumption); + clear id + | id: forall (_:?X1), ?X2|- _ => + flatten_contravariant_disj flags X1 X2 id + (* moved from "id:(?A\/?B)->?X2|-" to "?A->?X2,?B->?X2|-" *) + | |- ?X1 => is_conj flags X1; split + | |- (Coq.Init.Logic.iff _ _) => split + | |- (Coq.Init.Logic.not _) => red + end; + not_dep_intros). + +Local Ltac tauto_intuit flags t_reduce t_solver := + let rec t_tauto_intuit := + (simplif flags; axioms flags + || match reverse goal with + | id:forall(_: forall (_: ?X1), ?X2), ?X3|- _ => + cut X3; + [ intro; clear id; t_tauto_intuit + | cut (forall (_: X1), X2); + [ exact id + | generalize (fun y:X2 => id (fun x:X1 => y)); intro; clear id; + solve [ t_tauto_intuit ]]] + | id:forall (_:not ?X1), ?X3|- _ => + cut X3; + [ intro; clear id; t_tauto_intuit + | cut (not X1); [ exact id | clear id; intro; solve [t_tauto_intuit ]]] + | |- ?X1 => + is_disj flags X1; solve [left;t_tauto_intuit | right;t_tauto_intuit] + end + || + (* NB: [|- _ -> _] matches any product *) + match goal with | |- forall (_ : _), _ => intro; t_tauto_intuit + | |- _ => t_reduce;t_solver + end + || + t_solver + ) in t_tauto_intuit. + +Local Ltac intuition_gen flags solver := tauto_intuit flags reduction_not_iff solver. +Local Ltac tauto_intuitionistic flags := intuition_gen flags fail || fail "tauto failed". +Local Ltac tauto_classical flags := + (apply_nnpp || fail "tauto failed"); (tauto_intuitionistic flags || fail "Classical tauto failed"). +Local Ltac tauto_gen flags := tauto_intuitionistic flags || tauto_classical flags. + +Ltac tauto := with_uniform_flags ltac:(fun flags => tauto_gen flags). +Ltac dtauto := with_power_flags ltac:(fun flags => tauto_gen flags). + +Ltac intuition := with_uniform_flags ltac:(fun flags => intuition_gen flags ltac:(auto with *)). +Local Ltac intuition_then tac := with_uniform_flags ltac:(fun flags => intuition_gen flags tac). + +Ltac dintuition := with_power_flags ltac:(fun flags => intuition_gen flags ltac:(auto with *)). +Local Ltac dintuition_then tac := with_power_flags ltac:(fun flags => intuition_gen flags tac). + +Tactic Notation "intuition" := intuition. +Tactic Notation "intuition" tactic(t) := intuition_then t. + +Tactic Notation "dintuition" := dintuition. +Tactic Notation "dintuition" tactic(t) := dintuition_then t. diff --git a/theories/Init/Wf.v b/theories/Init/Wf.v index 6501b1e18..985ecaf27 100644 --- a/theories/Init/Wf.v +++ b/theories/Init/Wf.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Init/vo.itarget b/theories/Init/vo.itarget index cc62e66cc..99877065e 100644 --- a/theories/Init/vo.itarget +++ b/theories/Init/vo.itarget @@ -7,4 +7,5 @@ Prelude.vo Specif.vo Tactics.vo Wf.vo -Nat.vo
\ No newline at end of file +Nat.vo +Tauto.vo diff --git a/theories/Lists/List.v b/theories/Lists/List.v index 45306caf0..b66699220 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -26,7 +26,7 @@ In a special module to avoid conflicts. *) Module ListNotations. Notation " [ ] " := nil (format "[ ]") : list_scope. Notation " [ x ] " := (cons x nil) : list_scope. -Notation " [ x ; .. ; y ] " := (cons x .. (cons y nil) ..) : list_scope. +Notation " [ x ; y ; .. ; z ] " := (cons x (cons y .. (cons z nil) ..)) : list_scope. End ListNotations. Import ListNotations. @@ -970,6 +970,7 @@ Section Map. Lemma in_flat_map : forall (f:A->list B)(l:list A)(y:B), In y (flat_map f l) <-> exists x, In x l /\ In y (f x). Proof using A B. + clear Hfinjective. induction l; simpl; split; intros. contradiction. destruct H as (x,(H,_)); contradiction. diff --git a/theories/Lists/ListDec.v b/theories/Lists/ListDec.v index 8bd2daaff..3e2eeac04 100644 --- a/theories/Lists/ListDec.v +++ b/theories/Lists/ListDec.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Lists/ListSet.v b/theories/Lists/ListSet.v index c8ed95cd4..655d3940c 100644 --- a/theories/Lists/ListSet.v +++ b/theories/Lists/ListSet.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Lists/ListTactics.v b/theories/Lists/ListTactics.v index f19d95a9e..537d5f684 100644 --- a/theories/Lists/ListTactics.v +++ b/theories/Lists/ListTactics.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Lists/StreamMemo.v b/theories/Lists/StreamMemo.v index 74d464c5d..5a16cc439 100644 --- a/theories/Lists/StreamMemo.v +++ b/theories/Lists/StreamMemo.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Lists/Streams.v b/theories/Lists/Streams.v index cc4fb1793..7ec3d2503 100644 --- a/theories/Lists/Streams.v +++ b/theories/Lists/Streams.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Logic/Berardi.v b/theories/Logic/Berardi.v index d72f4072b..1e0bd0fed 100644 --- a/theories/Logic/Berardi.v +++ b/theories/Logic/Berardi.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Logic/ChoiceFacts.v b/theories/Logic/ChoiceFacts.v index d23274981..1420a000b 100644 --- a/theories/Logic/ChoiceFacts.v +++ b/theories/Logic/ChoiceFacts.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Logic/Classical.v b/theories/Logic/Classical.v index 600db472e..14d83501f 100644 --- a/theories/Logic/Classical.v +++ b/theories/Logic/Classical.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Logic/ClassicalChoice.v b/theories/Logic/ClassicalChoice.v index 07153b35f..7041ee40b 100644 --- a/theories/Logic/ClassicalChoice.v +++ b/theories/Logic/ClassicalChoice.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Logic/ClassicalDescription.v b/theories/Logic/ClassicalDescription.v index bdad50e27..9e6d07b2f 100644 --- a/theories/Logic/ClassicalDescription.v +++ b/theories/Logic/ClassicalDescription.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Logic/ClassicalEpsilon.v b/theories/Logic/ClassicalEpsilon.v index 2d9a1ffdf..0e91613d9 100644 --- a/theories/Logic/ClassicalEpsilon.v +++ b/theories/Logic/ClassicalEpsilon.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Logic/ClassicalFacts.v b/theories/Logic/ClassicalFacts.v index 6f736e45f..afd64efdf 100644 --- a/theories/Logic/ClassicalFacts.v +++ b/theories/Logic/ClassicalFacts.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -34,6 +34,8 @@ Table of contents: 3 3. Independence of general premises and drinker's paradox +4. Classical logic and principle of unrestricted minimization + *) (************************************************************************) @@ -442,10 +444,10 @@ Section Proof_irrelevance_WEM_CC. Theorem wproof_irrelevance_cc : ~~(b1 = b2). Proof. intros h. - refine (let NB := exist (fun P=>~~P -> P) B _ in _). + unshelve (refine (let NB := exist (fun P=>~~P -> P) B _ in _)). { exact (fun _ => b1). } pose proof (NoRetractToNegativeProp.paradox NB p2b b2p (wp2p2 h) wp2p1) as paradox. - refine (let F := exist (fun P=>~~P->P) False _ in _). + unshelve (refine (let F := exist (fun P=>~~P->P) False _ in _)). { auto. } exact (paradox F). Qed. @@ -659,3 +661,78 @@ Proof. exists x0; exact Hnot. Qed. +(** ** Principle of unrestricted minimization *) + +Require Import Coq.Arith.PeanoNat. + +Definition Minimal (P:nat -> Prop) (n:nat) : Prop := + P n /\ forall k, P k -> n<=k. + +Definition Minimization_Property (P : nat -> Prop) : Prop := + forall n, P n -> exists m, Minimal P m. + +Section Unrestricted_minimization_entails_excluded_middle. + + Hypothesis unrestricted_minimization: forall P, Minimization_Property P. + + Theorem unrestricted_minimization_entails_excluded_middle : forall A, A\/~A. + Proof. + intros A. + pose (P := fun n:nat => n=0/\A \/ n=1). + assert (P 1) as h. + { unfold P. intuition. } + assert (P 0 <-> A) as p₀. + { split. + + intros [[_ h₀]|[=]]. assumption. + + unfold P. tauto. } + apply unrestricted_minimization in h as ([|[|m]] & hm & hmm). + + intuition. + + right. + intros HA. apply p₀, hmm, PeanoNat.Nat.nle_succ_0 in HA. assumption. + + destruct hm as [([=],_) | [=] ]. + Qed. + +End Unrestricted_minimization_entails_excluded_middle. + +Require Import Wf_nat. + +Section Excluded_middle_entails_unrestricted_minimization. + + Hypothesis em : forall A, A\/~A. + + Theorem excluded_middle_entails_unrestricted_minimization : + forall P, Minimization_Property P. + Proof. + intros P n HPn. + assert (dec : forall n, P n \/ ~ P n) by auto using em. + assert (ex : exists n, P n) by (exists n; assumption). + destruct (dec_inh_nat_subset_has_unique_least_element P dec ex) as (n' & HPn' & _). + exists n'. assumption. + Qed. + +End Excluded_middle_entails_unrestricted_minimization. + +(** However, minimization for a given predicate does not necessarily imply + decidability of this predicate *) + +Section Example_of_undecidable_predicate_with_the_minimization_property. + + Variable s : nat -> bool. + + Let P n := exists k, n<=k /\ s k = true. + + Example undecidable_predicate_with_the_minimization_property : + Minimization_Property P. + Proof. + unfold Minimization_Property. + intros h hn. + exists 0. split. + + unfold P in *. destruct hn as (k&hk₁&hk₂). + exists k. split. + * rewrite <- hk₁. + apply PeanoNat.Nat.le_0_l. + * assumption. + + intros **. apply PeanoNat.Nat.le_0_l. + Qed. + +End Example_of_undecidable_predicate_with_the_minimization_property. diff --git a/theories/Logic/ClassicalUniqueChoice.v b/theories/Logic/ClassicalUniqueChoice.v index 4b0ec15eb..57f367e54 100644 --- a/theories/Logic/ClassicalUniqueChoice.v +++ b/theories/Logic/ClassicalUniqueChoice.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Logic/Classical_Pred_Type.v b/theories/Logic/Classical_Pred_Type.v index 8468ced35..6665798dd 100644 --- a/theories/Logic/Classical_Pred_Type.v +++ b/theories/Logic/Classical_Pred_Type.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Logic/Classical_Prop.v b/theories/Logic/Classical_Prop.v index be75c4e96..2c69d4f0e 100644 --- a/theories/Logic/Classical_Prop.v +++ b/theories/Logic/Classical_Prop.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Logic/ConstructiveEpsilon.v b/theories/Logic/ConstructiveEpsilon.v index 6f5bfae4d..a304dd24e 100644 --- a/theories/Logic/ConstructiveEpsilon.v +++ b/theories/Logic/ConstructiveEpsilon.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Logic/Decidable.v b/theories/Logic/Decidable.v index 545f92bd9..8b6054f9d 100644 --- a/theories/Logic/Decidable.v +++ b/theories/Logic/Decidable.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -50,7 +50,7 @@ Qed. Theorem dec_iff : forall A B:Prop, decidable A -> decidable B -> decidable (A<->B). Proof. -unfold decidable; tauto. +unfold decidable. tauto. Qed. Theorem not_not : forall P:Prop, decidable P -> ~ ~ P -> P. diff --git a/theories/Logic/Description.v b/theories/Logic/Description.v index 70cc0787c..0239222e3 100644 --- a/theories/Logic/Description.v +++ b/theories/Logic/Description.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Logic/Diaconescu.v b/theories/Logic/Diaconescu.v index 645173541..23af5afc6 100644 --- a/theories/Logic/Diaconescu.v +++ b/theories/Logic/Diaconescu.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Logic/Epsilon.v b/theories/Logic/Epsilon.v index fe17cde47..ffbb5758f 100644 --- a/theories/Logic/Epsilon.v +++ b/theories/Logic/Epsilon.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Logic/Eqdep.v b/theories/Logic/Eqdep.v index d9ffe68d8..f3a2783e1 100644 --- a/theories/Logic/Eqdep.v +++ b/theories/Logic/Eqdep.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Logic/EqdepFacts.v b/theories/Logic/EqdepFacts.v index 34aba4864..30e26c7c6 100644 --- a/theories/Logic/EqdepFacts.v +++ b/theories/Logic/EqdepFacts.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Logic/Eqdep_dec.v b/theories/Logic/Eqdep_dec.v index 65011e8e3..b7b4dec22 100644 --- a/theories/Logic/Eqdep_dec.v +++ b/theories/Logic/Eqdep_dec.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Logic/ExtensionalityFacts.v b/theories/Logic/ExtensionalityFacts.v index 61ee9eb9a..0e34e7e97 100644 --- a/theories/Logic/ExtensionalityFacts.v +++ b/theories/Logic/ExtensionalityFacts.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Logic/FinFun.v b/theories/Logic/FinFun.v index 670aa2199..064668015 100644 --- a/theories/Logic/FinFun.v +++ b/theories/Logic/FinFun.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Logic/FunctionalExtensionality.v b/theories/Logic/FunctionalExtensionality.v index eb50a3aae..04d9a6704 100644 --- a/theories/Logic/FunctionalExtensionality.v +++ b/theories/Logic/FunctionalExtensionality.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Logic/Hurkens.v b/theories/Logic/Hurkens.v index ede51f57f..841f843c0 100644 --- a/theories/Logic/Hurkens.v +++ b/theories/Logic/Hurkens.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -266,7 +266,7 @@ End Paradox. (** The [paradox] tactic can be called as a shortcut to use the paradox. *) Ltac paradox h := - refine ((fun h => _) (paradox _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ ));cycle 1. + unshelve (refine ((fun h => _) (paradox _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ ))). End Generic. @@ -319,77 +319,31 @@ Proof. + cbn. exact (fun u F => forall x:u, F x). + cbn. exact (fun _ _ x => x). + cbn. exact (fun _ _ x => x). - + cbn. easy. + + cbn. exact (fun F => u22u1 (forall x, F x)). + cbn. exact (fun _ x => u22u1_unit _ x). + cbn. exact (fun _ x => u22u1_counit _ x). - + cbn. intros **. now rewrite u22u1_coherent. (** Small universe *) + exact U0. (** The interpretation of the small universe is the image of [U0] in [U1]. *) + cbn. exact (fun X => u02u1 X). + cbn. exact (fun u F => u12u0 (forall x:(u02u1 u), u02u1 (F x))). - + cbn. intros * x. exact (u12u0_unit _ x). - + cbn. intros * x. exact (u12u0_counit _ x). + cbn. exact (fun u F => u12u0 (forall x:u, u02u1 (F x))). - + cbn. intros * x. exact (u12u0_unit _ x). - + cbn. intros * x. exact (u12u0_counit _ x). + cbn. exact (u12u0 F). + cbn in h. exact (u12u0_counit _ h). -Qed. - -End Paradox. - -End NoRetractToImpredicativeUniverse. - -(** * Prop is not a retract *) - -(** The existence in the pure Calculus of Constructions of a retract - from [Prop] into a small type of [Prop] is inconsistent. This is a - special case of the previous result. *) - -Module NoRetractFromSmallPropositionToProp. - -Section Paradox. - -(** ** Retract of [Prop] in a small type *) - -(** The retract is axiomatized using logical equivalence as the - equality on propositions. *) - -Variable bool : Prop. -Variable p2b : Prop -> bool. -Variable b2p : bool -> Prop. -Hypothesis p2p1 : forall A:Prop, b2p (p2b A) -> A. -Hypothesis p2p2 : forall A:Prop, A -> b2p (p2b A). - -(** ** Paradox *) - -Theorem paradox : forall B:Prop, B. -Proof. - intros B. - pose proof - (NoRetractToImpredicativeUniverse.paradox@{Type Prop}) as P. - refine (P _ _ _ _ _ _ _ _ _ _);clear P. - + exact bool. - + exact (fun x => forall P:Prop, (x->P)->P). - + cbn. exact (fun _ x P k => k x). - + cbn. intros F P x. - apply P. - intros f. - exact (f x). + cbn. easy. - + exact b2p. - + exact p2b. - + exact p2p2. - + exact p2p1. + + cbn. intros **. now rewrite u22u1_coherent. + + cbn. intros * x. exact (u12u0_unit _ x). + + cbn. intros * x. exact (u12u0_counit _ x). + + cbn. intros * x. exact (u12u0_unit _ x). + + cbn. intros * x. exact (u12u0_counit _ x). Qed. End Paradox. -End NoRetractFromSmallPropositionToProp. +End NoRetractToImpredicativeUniverse. (** * Modal fragments of [Prop] are not retracts *) @@ -428,7 +382,7 @@ Qed. Definition Forall {A:Type} (P:A->MProp) : MProp. Proof. - refine (exist _ _ _). + unshelve (refine (exist _ _ _)). + exact (forall x:A, El (P x)). + intros h x. eapply strength in h. @@ -458,27 +412,27 @@ Proof. + exact (fun _ => Forall). + cbn. exact (fun _ _ f => f). + cbn. exact (fun _ _ f => f). - + cbn. easy. + exact Forall. + cbn. exact (fun _ f => f). + cbn. exact (fun _ f => f). - + cbn. easy. (** Small universe *) + exact bool. + exact (fun b => El (b2p b)). + cbn. exact (fun _ F => p2b (Forall (fun x => b2p (F x)))). + + exact (fun _ F => p2b (Forall (fun x => b2p (F x)))). + + apply p2b. + exact B. + + cbn in h. auto. + + cbn. easy. + + cbn. easy. + cbn. auto. + cbn. intros * f. apply p2p1 in f. cbn in f. exact f. - + exact (fun _ F => p2b (Forall (fun x => b2p (F x)))). + cbn. auto. + cbn. intros * f. apply p2p1 in f. cbn in f. exact f. - + apply p2b. - exact B. - + cbn in h. auto. Qed. End Paradox. @@ -516,23 +470,97 @@ Hypothesis p2p2 : forall A:NProp, El A -> El (b2p (p2b A)). Theorem paradox : forall B:NProp, El B. Proof. intros B. - refine ((fun h => _) (NoRetractToModalProposition.paradox _ _ _ _ _ _ _ _ _ _));cycle 1. + unshelve (refine ((fun h => _) (NoRetractToModalProposition.paradox _ _ _ _ _ _ _ _ _ _))). + exact (fun P => ~~P). + + exact bool. + + exact p2b. + + exact b2p. + + exact B. + + exact h. + cbn. auto. + cbn. auto. + cbn. auto. + + auto. + + auto. +Qed. + +End Paradox. + +End NoRetractToNegativeProp. + +(** * Prop is not a retract *) + +(** The existence in the pure Calculus of Constructions of a retract + from [Prop] into a small type of [Prop] is inconsistent. This is a + special case of the previous result. *) + +Module NoRetractFromSmallPropositionToProp. + +(** ** The universe of propositions. *) + +Definition NProp := { P:Prop | P -> P}. +Definition El : NProp -> Prop := @proj1_sig _ _. + +Section MParadox. + +(** ** Retract of [Prop] in a small type, using the identity modality. *) + +Variable bool : NProp. +Variable p2b : NProp -> El bool. +Variable b2p : El bool -> NProp. +Hypothesis p2p1 : forall A:NProp, El (b2p (p2b A)) -> El A. +Hypothesis p2p2 : forall A:NProp, El A -> El (b2p (p2b A)). + +(** ** Paradox *) + +Theorem mparadox : forall B:NProp, El B. +Proof. + intros B. + unshelve (refine ((fun h => _) (NoRetractToModalProposition.paradox _ _ _ _ _ _ _ _ _ _))). + + exact (fun P => P). + exact bool. + exact p2b. + exact b2p. - + auto. - + auto. + exact B. + exact h. + + cbn. auto. + + cbn. auto. + + cbn. auto. + + auto. + + auto. +Qed. + +End MParadox. + +Section Paradox. + +(** ** Retract of [Prop] in a small type *) + +(** The retract is axiomatized using logical equivalence as the + equality on propositions. *) +Variable bool : Prop. +Variable p2b : Prop -> bool. +Variable b2p : bool -> Prop. +Hypothesis p2p1 : forall A:Prop, b2p (p2b A) -> A. +Hypothesis p2p2 : forall A:Prop, A -> b2p (p2b A). + +(** ** Paradox *) + +Theorem paradox : forall B:Prop, B. +Proof. + intros B. + unshelve (refine (mparadox (exist _ bool (fun x => x)) _ _ _ _ + (exist _ B (fun x => x)))). + + intros p. red. red. exact (p2b (El p)). + + cbn. intros b. red. exists (b2p b). exact (fun x => x). + + cbn. intros [A H]. cbn. apply p2p1. + + cbn. intros [A H]. cbn. apply p2p2. Qed. End Paradox. -End NoRetractToNegativeProp. +End NoRetractFromSmallPropositionToProp. + (** * Large universes are no retracts of [Prop]. *) @@ -569,7 +597,6 @@ Proof. + cbn. exact (fun u F => forall x, F x). + cbn. exact (fun _ _ x => x). + cbn. exact (fun _ _ x => x). - + cbn. easy. + exact (fun F => forall A:Prop, F(up A)). + cbn. exact (fun F f A => f (up A)). + cbn. @@ -577,20 +604,21 @@ Proof. specialize (f (down A)). rewrite up_down in f. exact f. + + exact Prop. + + cbn. exact (fun X => X). + + cbn. exact (fun A P => forall x:A, P x). + + cbn. exact (fun A P => forall x:A, P x). + + cbn. exact P. + + exact h. + + cbn. easy. + cbn. intros F f A. destruct (up_down A). cbn. reflexivity. - + exact Prop. - + cbn. exact (fun X => X). - + cbn. exact (fun A P => forall x:A, P x). + cbn. exact (fun _ _ x => x). + cbn. exact (fun _ _ x => x). - + cbn. exact (fun A P => forall x:A, P x). + cbn. exact (fun _ _ x => x). + cbn. exact (fun _ _ x => x). - + cbn. exact P. - + exact h. Qed. End Paradox. @@ -603,6 +631,8 @@ End NoRetractFromTypeToProp. Module TypeNeqSmallType. +Unset Universe Polymorphism. + Section Paradox. (** ** Universe [U] is equal to one of its elements. *) @@ -627,7 +657,6 @@ Proof. reflexivity. Qed. - Theorem paradox : False. Proof. Generic.paradox p. @@ -637,37 +666,37 @@ Proof. + cbn. exact (fun X F => forall x:X, F x). + cbn. exact (fun _ _ x => x). + cbn. exact (fun _ _ x => x). - + cbn. easy. + exact (fun F => forall x:A, F (up x)). + cbn. exact (fun _ f => fun x:A => f (up x)). + cbn. intros * f X. specialize (f (down X)). rewrite up_down in f. exact f. - + cbn. intros ? f X. - destruct (up_down X). cbn. - reflexivity. (** Small universe *) + exact A. (** The interpretation of [A] as a universe is [U]. *) + cbn. exact up. + cbn. exact (fun _ F => down (forall x, up (F x))). + + cbn. exact (fun _ F => down (forall x, up (F x))). + + cbn. exact (down False). + + rewrite up_down in p. + exact p. + + cbn. easy. + + cbn. intros ? f X. + destruct (up_down X). cbn. + reflexivity. + cbn. intros ? ? f. rewrite up_down. exact f. + cbn. intros ? ? f. rewrite up_down in f. exact f. - + cbn. exact (fun _ F => down (forall x, up (F x))). + cbn. intros ? ? f. rewrite up_down. exact f. + cbn. intros ? ? f. rewrite up_down in f. exact f. - + cbn. exact (down False). - + rewrite up_down in p. - exact p. Qed. End Paradox. @@ -683,7 +712,7 @@ Module PropNeqType. Theorem paradox : Prop <> Type. Proof. intros h. - refine (TypeNeqSmallType.paradox _ _). + unshelve (refine (TypeNeqSmallType.paradox _ _)). + exact Prop. + easy. Qed. diff --git a/theories/Logic/IndefiniteDescription.v b/theories/Logic/IndefiniteDescription.v index 9875710e6..21be50323 100644 --- a/theories/Logic/IndefiniteDescription.v +++ b/theories/Logic/IndefiniteDescription.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Logic/JMeq.v b/theories/Logic/JMeq.v index 98cddf0ad..2f95856b4 100644 --- a/theories/Logic/JMeq.v +++ b/theories/Logic/JMeq.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Logic/ProofIrrelevance.v b/theories/Logic/ProofIrrelevance.v index eb00dedd2..305839cd0 100644 --- a/theories/Logic/ProofIrrelevance.v +++ b/theories/Logic/ProofIrrelevance.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Logic/ProofIrrelevanceFacts.v b/theories/Logic/ProofIrrelevanceFacts.v index 6ab6abcf4..19b3e9e6f 100644 --- a/theories/Logic/ProofIrrelevanceFacts.v +++ b/theories/Logic/ProofIrrelevanceFacts.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Logic/PropFacts.v b/theories/Logic/PropFacts.v new file mode 100644 index 000000000..309539e5c --- /dev/null +++ b/theories/Logic/PropFacts.v @@ -0,0 +1,50 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) + +(** * Basic facts about Prop as a type *) + +(** An intuitionistic theorem from topos theory [[LambekScott]] + +References: + +[[LambekScott]] Jim Lambek, Phil J. Scott, Introduction to higher +order categorical logic, Cambridge Studies in Advanced Mathematics +(Book 7), 1988. + +*) + +Theorem injection_is_involution_in_Prop + (f : Prop -> Prop) + (inj : forall A B, (f A <-> f B) -> (A <-> B)) + (ext : forall A B, A <-> B -> f A <-> f B) + : forall A, f (f A) <-> A. +Proof. +intros. +enough (f (f (f A)) <-> f A) by (apply inj; assumption). +split; intro H. +- now_show (f A). + enough (f A <-> True) by firstorder. + enough (f (f A) <-> f True) by (apply inj; assumption). + split; intro H'. + + now_show (f True). + enough (f (f (f A)) <-> f True) by firstorder. + apply ext; firstorder. + + now_show (f (f A)). + enough (f (f A) <-> True) by firstorder. + apply inj; firstorder. +- now_show (f (f (f A))). + enough (f A <-> f (f (f A))) by firstorder. + apply ext. + split; intro H'. + + now_show (f (f A)). + enough (f A <-> f (f A)) by firstorder. + apply ext; firstorder. + + now_show A. + enough (f A <-> A) by firstorder. + apply inj; firstorder. +Defined. diff --git a/theories/Logic/RelationalChoice.v b/theories/Logic/RelationalChoice.v index 615981308..d16835f81 100644 --- a/theories/Logic/RelationalChoice.v +++ b/theories/Logic/RelationalChoice.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Logic/SetIsType.v b/theories/Logic/SetIsType.v index f110237e7..33fce6cc7 100644 --- a/theories/Logic/SetIsType.v +++ b/theories/Logic/SetIsType.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Logic/WKL.v b/theories/Logic/WKL.v index 408eca4a3..95f3e83f1 100644 --- a/theories/Logic/WKL.v +++ b/theories/Logic/WKL.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -40,7 +40,7 @@ Proposition is_path_from_characterization P n l : Proof. intros. split. - induction 1 as [|* HP _ (l'&Hl'&HPl')|* HP _ (l'&Hl'&HPl')]. - + exists []. split. reflexivity. intros n <-/le_n_0_eq. assumption. + + exists []. split. reflexivity. intros n <-%le_n_0_eq. assumption. + exists (true :: l'). split. apply eq_S, Hl'. intros [|] H. * assumption. * simpl. rewrite <- app_assoc. apply HPl', le_S_n, H. @@ -51,10 +51,10 @@ intros. split. + constructor. apply (HPl' 0). apply le_0_n. + eapply next_left. * apply (HPl' 0), le_0_n. - * fold (length l'). apply IHl'. intros n' H/le_n_S. apply HPl' in H. simpl in H. rewrite <- app_assoc in H. assumption. + * fold (length l'). apply IHl'. intros n' H%le_n_S. apply HPl' in H. simpl in H. rewrite <- app_assoc in H. assumption. + apply next_right. * apply (HPl' 0), le_0_n. - * fold (length l'). apply IHl'. intros n' H/le_n_S. apply HPl' in H. simpl in H. rewrite <- app_assoc in H. assumption. + * fold (length l'). apply IHl'. intros n' H%le_n_S. apply HPl' in H. simpl in H. rewrite <- app_assoc in H. assumption. Qed. (** [infinite_from P l] means that we can find arbitrary long paths diff --git a/theories/Logic/WeakFan.v b/theories/Logic/WeakFan.v index 2f84ebe5f..4416d38db 100644 --- a/theories/Logic/WeakFan.v +++ b/theories/Logic/WeakFan.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -89,7 +89,7 @@ Qed. Theorem WeakFanTheorem : forall P, barred P -> inductively_barred P []. Proof. intros P Hbar. -destruct Hbar with (X P) as (l,(Hd/Y_approx,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 as [|a l]. diff --git a/theories/MMaps/MMapAVL.v b/theories/MMaps/MMapAVL.v deleted file mode 100644 index d840f1f32..000000000 --- a/theories/MMaps/MMapAVL.v +++ /dev/null @@ -1,2158 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) -(* \VV/ *************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(***********************************************************************) - -(* Finite map library. *) - -(** * MMapAVL *) - -(** This module implements maps using AVL trees. - It follows the implementation from Ocaml's standard library. - - See the comments at the beginning of MSetAVL for more details. -*) - -Require Import Bool PeanoNat BinInt Int MMapInterface MMapList. -Require Import Orders OrdersFacts OrdersLists. - -Set Implicit Arguments. -Unset Strict Implicit. -(* For nicer extraction, we create inductive principles - only when needed *) -Local Unset Elimination Schemes. - -(** Notations and helper lemma about pairs *) - -Notation "s #1" := (fst s) (at level 9, format "s '#1'") : pair_scope. -Notation "s #2" := (snd s) (at level 9, format "s '#2'") : pair_scope. - -(** * The Raw functor - - Functor of pure functions + separate proofs of invariant - preservation *) - -Module Raw (Import I:Int)(X: OrderedType). -Local Open Scope pair_scope. -Local Open Scope lazy_bool_scope. -Local Open Scope Int_scope. -Local Notation int := I.t. - -Definition key := X.t. -Hint Transparent key. - -(** * Trees *) - -Section Elt. - -Variable elt : Type. - -(** * Trees - - The fifth field of [Node] is the height of the tree *) - -Inductive tree := - | Leaf : tree - | Node : tree -> key -> elt -> tree -> int -> tree. - -Notation t := tree. - -(** * Basic functions on trees: height and cardinal *) - -Definition height (m : t) : int := - match m with - | Leaf => 0 - | Node _ _ _ _ h => h - end. - -Fixpoint cardinal (m : t) : nat := - match m with - | Leaf => 0%nat - | Node l _ _ r _ => S (cardinal l + cardinal r) - end. - -(** * Empty Map *) - -Definition empty := Leaf. - -(** * Emptyness test *) - -Definition is_empty m := match m with Leaf => true | _ => false end. - -(** * Membership *) - -(** The [mem] function is deciding membership. It exploits the [Bst] property - to achieve logarithmic complexity. *) - -Fixpoint mem x m : bool := - match m with - | Leaf => false - | Node l y _ r _ => - match X.compare x y with - | Eq => true - | Lt => mem x l - | Gt => mem x r - end - end. - -Fixpoint find x m : option elt := - match m with - | Leaf => None - | Node l y d r _ => - match X.compare x y with - | Eq => Some d - | Lt => find x l - | Gt => find x r - end - end. - -(** * Helper functions *) - -(** [create l x r] creates a node, assuming [l] and [r] - to be balanced and [|height l - height r| <= 2]. *) - -Definition create l x e r := - Node l x e r (max (height l) (height r) + 1). - -(** [bal l x e r] acts as [create], but performs one step of - rebalancing if necessary, i.e. assumes [|height l - height r| <= 3]. *) - -Definition assert_false := create. - -Fixpoint bal l x d r := - let hl := height l in - let hr := height r in - if (hr+2) <? hl then - match l with - | Leaf => assert_false l x d r - | Node ll lx ld lr _ => - if (height lr) <=? (height ll) then - create ll lx ld (create lr x d r) - else - match lr with - | Leaf => assert_false l x d r - | Node lrl lrx lrd lrr _ => - create (create ll lx ld lrl) lrx lrd (create lrr x d r) - end - end - else - if (hl+2) <? hr then - match r with - | Leaf => assert_false l x d r - | Node rl rx rd rr _ => - if (height rl) <=? (height rr) then - create (create l x d rl) rx rd rr - else - match rl with - | Leaf => assert_false l x d r - | Node rll rlx rld rlr _ => - create (create l x d rll) rlx rld (create rlr rx rd rr) - end - end - else - create l x d r. - -(** * Insertion *) - -Fixpoint add x d m := - match m with - | Leaf => Node Leaf x d Leaf 1 - | Node l y d' r h => - match X.compare x y with - | Eq => Node l y d r h - | Lt => bal (add x d l) y d' r - | Gt => bal l y d' (add x d r) - end - end. - -(** * Extraction of minimum binding - - Morally, [remove_min] is to be applied to a non-empty tree - [t = Node l x e r h]. Since we can't deal here with [assert false] - for [t=Leaf], we pre-unpack [t] (and forget about [h]). -*) - -Fixpoint remove_min l x d r : t*(key*elt) := - match l with - | Leaf => (r,(x,d)) - | Node ll lx ld lr lh => - let (l',m) := remove_min ll lx ld lr in - (bal l' x d r, m) - end. - -(** * Merging two trees - - [merge0 t1 t2] builds the union of [t1] and [t2] assuming all elements - of [t1] to be smaller than all elements of [t2], and - [|height t1 - height t2| <= 2]. -*) - -Definition merge0 s1 s2 := - match s1,s2 with - | Leaf, _ => s2 - | _, Leaf => s1 - | _, Node l2 x2 d2 r2 h2 => - let '(s2',(x,d)) := remove_min l2 x2 d2 r2 in - bal s1 x d s2' - end. - -(** * Deletion *) - -Fixpoint remove x m := match m with - | Leaf => Leaf - | Node l y d r h => - match X.compare x y with - | Eq => merge0 l r - | Lt => bal (remove x l) y d r - | Gt => bal l y d (remove x r) - end - end. - -(** * join - - Same as [bal] but does not assume anything regarding heights of [l] - and [r]. -*) - -Fixpoint join l : key -> elt -> t -> t := - match l with - | Leaf => add - | Node ll lx ld lr lh => fun x d => - fix join_aux (r:t) : t := match r with - | Leaf => add x d l - | Node rl rx rd rr rh => - if rh+2 <? lh then bal ll lx ld (join lr x d r) - else if lh+2 <? rh then bal (join_aux rl) rx rd rr - else create l x d r - end - end. - -(** * Splitting - - [split x m] returns a triple [(l, o, r)] where - - [l] is the set of elements of [m] that are [< x] - - [r] is the set of elements of [m] that are [> x] - - [o] is the result of [find x m]. -*) - -Record triple := mktriple { t_left:t; t_opt:option elt; t_right:t }. -Notation "〚 l , b , r 〛" := (mktriple l b r) (at level 9). - -Fixpoint split x m : triple := match m with - | Leaf => 〚 Leaf, None, Leaf 〛 - | Node l y d r h => - match X.compare x y with - | Lt => let (ll,o,rl) := split x l in 〚 ll, o, join rl y d r 〛 - | Eq => 〚 l, Some d, r 〛 - | Gt => let (rl,o,rr) := split x r in 〚 join l y d rl, o, rr 〛 - end - end. - -(** * Concatenation - - Same as [merge] but does not assume anything about heights. -*) - -Definition concat m1 m2 := - match m1, m2 with - | Leaf, _ => m2 - | _ , Leaf => m1 - | _, Node l2 x2 d2 r2 _ => - let (m2',xd) := remove_min l2 x2 d2 r2 in - join m1 xd#1 xd#2 m2' - end. - -(** * Bindings *) - -(** [bindings_aux acc t] catenates the bindings of [t] in infix - order to the list [acc] *) - -Fixpoint bindings_aux (acc : list (key*elt)) m : list (key*elt) := - match m with - | Leaf => acc - | Node l x d r _ => bindings_aux ((x,d) :: bindings_aux acc r) l - end. - -(** then [bindings] is an instantiation with an empty [acc] *) - -Definition bindings := bindings_aux nil. - -(** * Fold *) - -Fixpoint fold {A} (f : key -> elt -> A -> A) (m : t) : A -> A := - fun a => match m with - | Leaf => a - | Node l x d r _ => fold f r (f x d (fold f l a)) - end. - -(** * Comparison *) - -Variable cmp : elt->elt->bool. - -(** ** Enumeration of the elements of a tree *) - -Inductive enumeration := - | End : enumeration - | More : key -> elt -> t -> enumeration -> enumeration. - -(** [cons m e] adds the elements of tree [m] on the head of - enumeration [e]. *) - -Fixpoint cons m e : enumeration := - match m with - | Leaf => e - | Node l x d r h => cons l (More x d r e) - end. - -(** One step of comparison of elements *) - -Definition equal_more x1 d1 (cont:enumeration->bool) e2 := - match e2 with - | End => false - | More x2 d2 r2 e2 => - match X.compare x1 x2 with - | Eq => cmp d1 d2 &&& cont (cons r2 e2) - | _ => false - end - end. - -(** Comparison of left tree, middle element, then right tree *) - -Fixpoint equal_cont m1 (cont:enumeration->bool) e2 := - match m1 with - | Leaf => cont e2 - | Node l1 x1 d1 r1 _ => - equal_cont l1 (equal_more x1 d1 (equal_cont r1 cont)) e2 - end. - -(** Initial continuation *) - -Definition equal_end e2 := match e2 with End => true | _ => false end. - -(** The complete comparison *) - -Definition equal m1 m2 := equal_cont m1 equal_end (cons m2 End). - -End Elt. -Notation t := tree. -Notation "〚 l , b , r 〛" := (mktriple l b r) (at level 9). -Notation "t #l" := (t_left t) (at level 9, format "t '#l'"). -Notation "t #o" := (t_opt t) (at level 9, format "t '#o'"). -Notation "t #r" := (t_right t) (at level 9, format "t '#r'"). - - -(** * Map *) - -Fixpoint map (elt elt' : Type)(f : elt -> elt')(m : t elt) : t elt' := - match m with - | Leaf _ => Leaf _ - | Node l x d r h => Node (map f l) x (f d) (map f r) h - end. - -(* * Mapi *) - -Fixpoint mapi (elt elt' : Type)(f : key -> elt -> elt')(m : t elt) : t elt' := - match m with - | Leaf _ => Leaf _ - | Node l x d r h => Node (mapi f l) x (f x d) (mapi f r) h - end. - -(** * Map with removal *) - -Fixpoint mapo (elt elt' : Type)(f : key -> elt -> option elt')(m : t elt) - : t elt' := - match m with - | Leaf _ => Leaf _ - | Node l x d r h => - match f x d with - | Some d' => join (mapo f l) x d' (mapo f r) - | None => concat (mapo f l) (mapo f r) - end - end. - -(** * Generalized merge - - Suggestion by B. Gregoire: a [merge] function with specialized - arguments that allows bypassing some tree traversal. Instead of one - [f0] of type [key -> option elt -> option elt' -> option elt''], - we ask here for: - - [f] which is a specialisation of [f0] when first option isn't [None] - - [mapl] treats a [tree elt] with [f0] when second option is [None] - - [mapr] treats a [tree elt'] with [f0] when first option is [None] - - The idea is that [mapl] and [mapr] can be instantaneous (e.g. - the identity or some constant function). -*) - -Section GMerge. -Variable elt elt' elt'' : Type. -Variable f : key -> elt -> option elt' -> option elt''. -Variable mapl : t elt -> t elt''. -Variable mapr : t elt' -> t elt''. - -Fixpoint gmerge m1 m2 := - match m1, m2 with - | Leaf _, _ => mapr m2 - | _, Leaf _ => mapl m1 - | Node l1 x1 d1 r1 h1, _ => - let (l2',o2,r2') := split x1 m2 in - match f x1 d1 o2 with - | Some e => join (gmerge l1 l2') x1 e (gmerge r1 r2') - | None => concat (gmerge l1 l2') (gmerge r1 r2') - end - end. - -End GMerge. - -(** * Merge - - The [merge] function of the Map interface can be implemented - via [gmerge] and [mapo]. -*) - -Section Merge. -Variable elt elt' elt'' : Type. -Variable f : key -> option elt -> option elt' -> option elt''. - -Definition merge : t elt -> t elt' -> t elt'' := - gmerge - (fun k d o => f k (Some d) o) - (mapo (fun k d => f k (Some d) None)) - (mapo (fun k d' => f k None (Some d'))). - -End Merge. - - - -(** * Invariants *) - -Section Invariants. -Variable elt : Type. - -(** ** Occurrence in a tree *) - -Inductive MapsTo (x : key)(e : elt) : t elt -> Prop := - | MapsRoot : forall l r h y, - X.eq x y -> MapsTo x e (Node l y e r h) - | MapsLeft : forall l r h y e', - MapsTo x e l -> MapsTo x e (Node l y e' r h) - | MapsRight : forall l r h y e', - MapsTo x e r -> MapsTo x e (Node l y e' r h). - -Inductive In (x : key) : t elt -> Prop := - | InRoot : forall l r h y e, - X.eq x y -> In x (Node l y e r h) - | InLeft : forall l r h y e', - In x l -> In x (Node l y e' r h) - | InRight : forall l r h y e', - In x r -> In x (Node l y e' r h). - -Definition In0 k m := exists e:elt, MapsTo k e m. - -(** ** Binary search trees *) - -(** [Above x m] : [x] is strictly greater than any key in [m]. - [Below x m] : [x] is strictly smaller than any key in [m]. *) - -Inductive Above (x:key) : t elt -> Prop := - | AbLeaf : Above x (Leaf _) - | AbNode l r h y e : Above x l -> X.lt y x -> Above x r -> - Above x (Node l y e r h). - -Inductive Below (x:key) : t elt -> Prop := - | BeLeaf : Below x (Leaf _) - | BeNode l r h y e : Below x l -> X.lt x y -> Below x r -> - Below x (Node l y e r h). - -Definition Apart (m1 m2 : t elt) : Prop := - forall x1 x2, In x1 m1 -> In x2 m2 -> X.lt x1 x2. - -(** Alternative statements, equivalent with [LtTree] and [GtTree] *) - -Definition lt_tree x m := forall y, In y m -> X.lt y x. -Definition gt_tree x m := forall y, In y m -> X.lt x y. - -(** [Bst t] : [t] is a binary search tree *) - -Inductive Bst : t elt -> Prop := - | BSLeaf : Bst (Leaf _) - | BSNode : forall x e l r h, Bst l -> Bst r -> - Above x l -> Below x r -> Bst (Node l x e r h). - -End Invariants. - - -(** * Correctness proofs, isolated in a sub-module *) - -Module Proofs. - Module MX := OrderedTypeFacts X. - Module PX := KeyOrderedType X. - Module L := MMapList.Raw X. - -Local Infix "∈" := In (at level 70). -Local Infix "==" := X.eq (at level 70). -Local Infix "<" := X.lt (at level 70). -Local Infix "<<" := Below (at level 70). -Local Infix ">>" := Above (at level 70). -Local Infix "<<<" := Apart (at level 70). - -Scheme tree_ind := Induction for tree Sort Prop. -Scheme Bst_ind := Induction for Bst Sort Prop. -Scheme MapsTo_ind := Induction for MapsTo Sort Prop. -Scheme In_ind := Induction for In Sort Prop. -Scheme Above_ind := Induction for Above Sort Prop. -Scheme Below_ind := Induction for Below Sort Prop. - -Functional Scheme mem_ind := Induction for mem Sort Prop. -Functional Scheme find_ind := Induction for find Sort Prop. -Functional Scheme bal_ind := Induction for bal Sort Prop. -Functional Scheme add_ind := Induction for add Sort Prop. -Functional Scheme remove_min_ind := Induction for remove_min Sort Prop. -Functional Scheme merge0_ind := Induction for merge0 Sort Prop. -Functional Scheme remove_ind := Induction for remove Sort Prop. -Functional Scheme concat_ind := Induction for concat Sort Prop. -Functional Scheme split_ind := Induction for split Sort Prop. -Functional Scheme mapo_ind := Induction for mapo Sort Prop. -Functional Scheme gmerge_ind := Induction for gmerge Sort Prop. - -(** * Automation and dedicated tactics. *) - -Local Hint Constructors tree MapsTo In Bst Above Below. -Local Hint Unfold lt_tree gt_tree Apart. -Local Hint Immediate MX.eq_sym. -Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans. - -Tactic Notation "factornode" ident(s) := - try clear s; - match goal with - | |- context [Node ?l ?x ?e ?r ?h] => - set (s:=Node l x e r h) in *; clearbody s; clear l x e r h - | _ : context [Node ?l ?x ?e ?r ?h] |- _ => - set (s:=Node l x e r h) in *; clearbody s; clear l x e r h - end. - -(** A tactic for cleaning hypothesis after use of functional induction. *) - -Ltac cleanf := - match goal with - | H : X.compare _ _ = Eq |- _ => - rewrite ?H; apply MX.compare_eq in H; cleanf - | H : X.compare _ _ = Lt |- _ => - rewrite ?H; apply MX.compare_lt_iff in H; cleanf - | H : X.compare _ _ = Gt |- _ => - rewrite ?H; apply MX.compare_gt_iff in H; cleanf - | _ => idtac - end. - - -(** A tactic to repeat [inversion_clear] on all hyps of the - form [(f (Node ...))] *) - -Ltac inv f := - match goal with - | H:f (Leaf _) |- _ => inversion_clear H; inv f - | H:f _ (Leaf _) |- _ => inversion_clear H; inv f - | H:f _ _ (Leaf _) |- _ => inversion_clear H; inv f - | H:f _ _ _ (Leaf _) |- _ => inversion_clear H; inv f - | H:f (Node _ _ _ _ _) |- _ => inversion_clear H; inv f - | H:f _ (Node _ _ _ _ _) |- _ => inversion_clear H; inv f - | H:f _ _ (Node _ _ _ _ _) |- _ => inversion_clear H; inv f - | H:f _ _ _ (Node _ _ _ _ _) |- _ => inversion_clear H; inv f - | _ => idtac - end. - -Ltac inv_all f := - match goal with - | H: f _ |- _ => inversion_clear H; inv f - | H: f _ _ |- _ => inversion_clear H; inv f - | H: f _ _ _ |- _ => inversion_clear H; inv f - | H: f _ _ _ _ |- _ => inversion_clear H; inv f - | _ => idtac - end. - -Ltac intuition_in := repeat (intuition; inv In; inv MapsTo). - -(* Function/Functional Scheme can't deal with internal fix. - Let's do its job by hand: *) - -Ltac join_tac l x d r := - revert x d r; - induction l as [| ll _ lx ld lr Hlr lh]; - [ | intros x d r; induction r as [| rl Hrl rx rd rr _ rh]; unfold join; - [ | destruct (rh+2 <? lh) eqn:LT; - [ match goal with |- context [ bal ?u ?v ?w ?z ] => - replace (bal u v w z) - with (bal ll lx ld (join lr x d (Node rl rx rd rr rh))); [ | auto] - end - | destruct (lh+2 <? rh) eqn:LT'; - [ match goal with |- context [ bal ?u ?v ?w ?z ] => - replace (bal u v w z) - with (bal (join (Node ll lx ld lr lh) x d rl) rx rd rr); [ | auto] - end - | ] ] ] ]; intros. - -Ltac cleansplit := - simpl; cleanf; inv Bst; - match goal with - | E:split _ _ = 〚 ?l, ?o, ?r 〛 |- _ => - change l with (〚l,o,r〛#l); rewrite <- ?E; - change o with (〚l,o,r〛#o); rewrite <- ?E; - change r with (〚l,o,r〛#r); rewrite <- ?E - | _ => idtac - end. - -(** * Basic results about [MapsTo], [In], [lt_tree], [gt_tree], [height] *) - -(** Facts about [MapsTo] and [In]. *) - -Lemma MapsTo_In {elt} k (e:elt) m : MapsTo k e m -> k ∈ m. -Proof. - induction 1; auto. -Qed. -Local Hint Resolve MapsTo_In. - -Lemma In_MapsTo {elt} k m : k ∈ m -> exists (e:elt), MapsTo k e m. -Proof. - induction 1; try destruct IHIn as (e,He); exists e; auto. -Qed. - -Lemma In_alt {elt} k (m:t elt) : In0 k m <-> k ∈ m. -Proof. - split. - intros (e,H); eauto. - unfold In0; apply In_MapsTo; auto. -Qed. - -Lemma MapsTo_1 {elt} m x y (e:elt) : - x == y -> MapsTo x e m -> MapsTo y e m. -Proof. - induction m; simpl; intuition_in; eauto. -Qed. -Hint Immediate MapsTo_1. - -Instance MapsTo_compat {elt} : - Proper (X.eq==>Logic.eq==>Logic.eq==>iff) (@MapsTo elt). -Proof. - intros x x' Hx e e' He m m' Hm. subst. - split; now apply MapsTo_1. -Qed. - -Instance In_compat {elt} : - Proper (X.eq==>Logic.eq==>iff) (@In elt). -Proof. - intros x x' H m m' <-. - induction m; simpl; intuition_in; eauto. -Qed. - -Lemma In_node_iff {elt} l x (e:elt) r h y : - y ∈ (Node l x e r h) <-> y ∈ l \/ y == x \/ y ∈ r. -Proof. - intuition_in. -Qed. - -(** Results about [Above] and [Below] *) - -Lemma above {elt} (m:t elt) x : - x >> m <-> forall y, y ∈ m -> y < x. -Proof. - split. - - induction 1; intuition_in; MX.order. - - induction m; constructor; auto. -Qed. - -Lemma below {elt} (m:t elt) x : - x << m <-> forall y, y ∈ m -> x < y. -Proof. - split. - - induction 1; intuition_in; MX.order. - - induction m; constructor; auto. -Qed. - -Lemma AboveLt {elt} (m:t elt) x y : x >> m -> y ∈ m -> y < x. -Proof. - rewrite above; intuition. -Qed. - -Lemma BelowGt {elt} (m:t elt) x y : x << m -> y ∈ m -> x < y. -Proof. - rewrite below; intuition. -Qed. - -Lemma Above_not_In {elt} (m:t elt) x : x >> m -> ~ x ∈ m. -Proof. - induction 1; intuition_in; MX.order. -Qed. - -Lemma Below_not_In {elt} (m:t elt) x : x << m -> ~ x ∈ m. -Proof. - induction 1; intuition_in; MX.order. -Qed. - -Lemma Above_trans {elt} (m:t elt) x y : x < y -> x >> m -> y >> m. -Proof. - induction 2; constructor; trivial; MX.order. -Qed. - -Lemma Below_trans {elt} (m:t elt) x y : y < x -> x << m -> y << m. -Proof. - induction 2; constructor; trivial; MX.order. -Qed. - -Local Hint Resolve - AboveLt Above_not_In Above_trans - BelowGt Below_not_In Below_trans. - -(** Helper tactic concerning order of elements. *) - -Ltac order := match goal with - | U: _ >> ?m, V: _ ∈ ?m |- _ => - generalize (AboveLt U V); clear U; order - | U: _ << ?m, V: _ ∈ ?m |- _ => - generalize (BelowGt U V); clear U; order - | U: _ >> ?m, V: MapsTo _ _ ?m |- _ => - generalize (AboveLt U (MapsTo_In V)); clear U; order - | U: _ << ?m, V: MapsTo _ _ ?m |- _ => - generalize (BelowGt U (MapsTo_In V)); clear U; order - | _ => MX.order -end. - -Lemma between {elt} (m m':t elt) x : - x >> m -> x << m' -> m <<< m'. -Proof. - intros H H' y y' Hy Hy'. order. -Qed. - -Section Elt. -Variable elt:Type. -Implicit Types m r : t elt. - -(** * Membership *) - -Lemma find_1 m x e : Bst m -> MapsTo x e m -> find x m = Some e. -Proof. - functional induction (find x m); cleanf; - intros; inv Bst; intuition_in; order. -Qed. - -Lemma find_2 m x e : find x m = Some e -> MapsTo x e m. -Proof. - functional induction (find x m); cleanf; subst; intros; auto. - - discriminate. - - injection H as ->. auto. -Qed. - -Lemma find_spec m x e : Bst m -> - (find x m = Some e <-> MapsTo x e m). -Proof. - split; auto using find_1, find_2. -Qed. - -Lemma find_in m x : find x m <> None -> x ∈ m. -Proof. - destruct (find x m) eqn:F; intros H. - - apply MapsTo_In with e. now apply find_2. - - now elim H. -Qed. - -Lemma in_find m x : Bst m -> x ∈ m -> find x m <> None. -Proof. - intros H H'. - destruct (In_MapsTo H') as (d,Hd). - now rewrite (find_1 H Hd). -Qed. - -Lemma find_in_iff m x : Bst m -> - (find x m <> None <-> x ∈ m). -Proof. - split; auto using find_in, in_find. -Qed. - -Lemma not_find_iff m x : Bst m -> - (find x m = None <-> ~ x ∈ m). -Proof. - intros H. rewrite <- find_in_iff; trivial. - destruct (find x m); split; try easy. now destruct 1. -Qed. - -Lemma eq_option_alt (o o':option elt) : - o=o' <-> (forall e, o=Some e <-> o'=Some e). -Proof. -split; intros. -- now subst. -- destruct o, o'; rewrite ?H; auto. symmetry; now apply H. -Qed. - -Lemma find_mapsto_equiv : forall m m' x, Bst m -> Bst m' -> - (find x m = find x m' <-> - (forall d, MapsTo x d m <-> MapsTo x d m')). -Proof. - intros m m' x Hm Hm'. rewrite eq_option_alt. - split; intros H d. now rewrite <- 2 find_spec. now rewrite 2 find_spec. -Qed. - -Lemma find_in_equiv : forall m m' x, Bst m -> Bst m' -> - find x m = find x m' -> - (x ∈ m <-> x ∈ m'). -Proof. - split; intros; apply find_in; [ rewrite <- H1 | rewrite H1 ]; - apply in_find; auto. -Qed. - -Lemma find_compat m x x' : Bst m -> X.eq x x' -> find x m = find x' m. -Proof. - intros B E. - destruct (find x' m) eqn:H. - - apply find_1; trivial. rewrite E. now apply find_2. - - rewrite not_find_iff in *; trivial. now rewrite E. -Qed. - -Lemma mem_spec m x : Bst m -> mem x m = true <-> x ∈ m. -Proof. - functional induction (mem x m); auto; intros; cleanf; - inv Bst; intuition_in; try discriminate; order. -Qed. - -(** * Empty map *) - -Lemma empty_bst : Bst (empty elt). -Proof. - constructor. -Qed. - -Lemma empty_spec x : find x (empty elt) = None. -Proof. - reflexivity. -Qed. - -(** * Emptyness test *) - -Lemma is_empty_spec m : is_empty m = true <-> forall x, find x m = None. -Proof. - destruct m as [|r x e l h]; simpl; split; try easy. - intros H. specialize (H x). now rewrite MX.compare_refl in H. -Qed. - -(** * Helper functions *) - -Lemma create_bst l x e r : - Bst l -> Bst r -> x >> l -> x << r -> Bst (create l x e r). -Proof. - unfold create; auto. -Qed. -Hint Resolve create_bst. - -Lemma create_in l x e r y : - y ∈ (create l x e r) <-> y == x \/ y ∈ l \/ y ∈ r. -Proof. - unfold create; split; [ inversion_clear 1 | ]; intuition. -Qed. - -Lemma bal_bst l x e r : Bst l -> Bst r -> - x >> l -> x << r -> Bst (bal l x e r). -Proof. - functional induction (bal l x e r); intros; cleanf; - inv Bst; inv Above; inv Below; - repeat apply create_bst; auto; unfold create; constructor; eauto. -Qed. -Hint Resolve bal_bst. - -Lemma bal_in l x e r y : - y ∈ (bal l x e r) <-> y == x \/ y ∈ l \/ y ∈ r. -Proof. - functional induction (bal l x e r); intros; cleanf; - rewrite !create_in; intuition_in. -Qed. - -Lemma bal_mapsto l x e r y e' : - MapsTo y e' (bal l x e r) <-> MapsTo y e' (create l x e r). -Proof. - functional induction (bal l x e r); intros; cleanf; - unfold assert_false, create; intuition_in. -Qed. - -Lemma bal_find l x e r y : - Bst l -> Bst r -> x >> l -> x << r -> - find y (bal l x e r) = find y (create l x e r). -Proof. - functional induction (bal l x e r); intros; cleanf; trivial; - inv Bst; inv Above; inv Below; - simpl; repeat case X.compare_spec; intuition; order. -Qed. - -(** * Insertion *) - -Lemma add_in m x y e : - y ∈ (add x e m) <-> y == x \/ y ∈ m. -Proof. - functional induction (add x e m); auto; intros; cleanf; - rewrite ?bal_in; intuition_in. setoid_replace y with x; auto. -Qed. - -Lemma add_lt m x e y : y >> m -> x < y -> y >> add x e m. -Proof. - intros. apply above. intros z. rewrite add_in. destruct 1; order. -Qed. - -Lemma add_gt m x e y : y << m -> y < x -> y << add x e m. -Proof. - intros. apply below. intros z. rewrite add_in. destruct 1; order. -Qed. - -Lemma add_bst m x e : Bst m -> Bst (add x e m). -Proof. - functional induction (add x e m); intros; cleanf; - inv Bst; try apply bal_bst; auto using add_lt, add_gt. -Qed. -Hint Resolve add_lt add_gt add_bst. - -Lemma add_spec1 m x e : Bst m -> find x (add x e m) = Some e. -Proof. - functional induction (add x e m); simpl; intros; cleanf; trivial. - - now rewrite MX.compare_refl. - - inv Bst. rewrite bal_find; auto. - simpl. case X.compare_spec; try order; auto. - - inv Bst. rewrite bal_find; auto. - simpl. case X.compare_spec; try order; auto. -Qed. - -Lemma add_spec2 m x y e : Bst m -> ~ x == y -> - find y (add x e m) = find y m. -Proof. - functional induction (add x e m); simpl; intros; cleanf; trivial. - - case X.compare_spec; trivial; order. - - case X.compare_spec; trivial; order. - - inv Bst. rewrite bal_find by auto. simpl. now rewrite IHt. - - inv Bst. rewrite bal_find by auto. simpl. now rewrite IHt. -Qed. - -Lemma add_find m x y e : Bst m -> - find y (add x e m) = - match X.compare y x with Eq => Some e | _ => find y m end. -Proof. - intros. - case X.compare_spec; intros. - - apply find_spec; auto. rewrite H0. apply find_spec; auto. - now apply add_spec1. - - apply add_spec2; trivial; order. - - apply add_spec2; trivial; order. -Qed. - -(** * Extraction of minimum binding *) - -Definition RemoveMin m res := - match m with - | Leaf _ => False - | Node l x e r h => remove_min l x e r = res - end. - -Lemma RemoveMin_step l x e r h m' p : - RemoveMin (Node l x e r h) (m',p) -> - (l = Leaf _ /\ m' = r /\ p = (x,e) \/ - exists m0, RemoveMin l (m0,p) /\ m' = bal m0 x e r). -Proof. - simpl. destruct l as [|ll lx le lr lh]; simpl. - - intros [= -> ->]. now left. - - destruct (remove_min ll lx le lr) as (l',p'). - intros [= <- <-]. right. now exists l'. -Qed. - -Lemma remove_min_mapsto m m' p : RemoveMin m (m',p) -> - forall y e, - MapsTo y e m <-> (y == p#1 /\ e = p#2) \/ MapsTo y e m'. -Proof. - revert m'. - induction m as [|l IH x d r _ h]; [destruct 1|]. - intros m' R. apply RemoveMin_step in R. - destruct R as [(->,(->,->))|[m0 (R,->)]]; intros y e; simpl. - - intuition_in. subst. now constructor. - - rewrite bal_mapsto. unfold create. specialize (IH _ R y e). - intuition_in. -Qed. - -Lemma remove_min_in m m' p : RemoveMin m (m',p) -> - forall y, y ∈ m <-> y == p#1 \/ y ∈ m'. -Proof. - revert m'. - induction m as [|l IH x e r _ h]; [destruct 1|]. - intros m' R y. apply RemoveMin_step in R. - destruct R as [(->,(->,->))|[m0 (R,->)]]. - + intuition_in. - + rewrite bal_in, In_node_iff, (IH _ R); intuition. -Qed. - -Lemma remove_min_lt m m' p : RemoveMin m (m',p) -> - forall y, y >> m -> y >> m'. -Proof. - intros R y L. apply above. intros z Hz. - apply (AboveLt L). - apply (remove_min_in R). now right. -Qed. - -Lemma remove_min_gt m m' p : RemoveMin m (m',p) -> - Bst m -> p#1 << m'. -Proof. - revert m'. - induction m as [|l IH x e r _ h]; [destruct 1|]. - intros m' R H. inv Bst. apply RemoveMin_step in R. - destruct R as [(_,(->,->))|[m0 (R,->)]]; auto. - assert (p#1 << m0) by now apply IH. - assert (In p#1 l) by (apply (remove_min_in R); now left). - apply below. intros z. rewrite bal_in. - intuition_in; order. -Qed. - -Lemma remove_min_bst m m' p : RemoveMin m (m',p) -> - Bst m -> Bst m'. -Proof. - revert m'. - induction m as [|l IH x e r _ h]; [destruct 1|]. - intros m' R H. inv Bst. apply RemoveMin_step in R. - destruct R as [(_,(->,->))|[m0 (R,->)]]; auto. - apply bal_bst; eauto using remove_min_lt. -Qed. - -Lemma remove_min_find m m' p : RemoveMin m (m',p) -> - Bst m -> - forall y, - find y m = - match X.compare y p#1 with - | Eq => Some p#2 - | Lt => None - | Gt => find y m' - end. -Proof. - revert m'. - induction m as [|l IH x e r _ h]; [destruct 1|]. - intros m' R B y. inv Bst. apply RemoveMin_step in R. - destruct R as [(->,(->,->))|[m0 (R,->)]]; auto. - assert (Bst m0) by now apply (remove_min_bst R). - assert (p#1 << m0) by now apply (remove_min_gt R). - assert (x >> m0) by now apply (remove_min_lt R). - assert (In p#1 l) by (apply (remove_min_in R); now left). - simpl in *. - rewrite (IH _ R), bal_find by trivial. clear IH. simpl. - do 2 case X.compare_spec; trivial; try order. -Qed. - -(** * Merging two trees *) - -Ltac factor_remove_min m R := match goal with - | h:int, H:remove_min ?l ?x ?e ?r = ?p |- _ => - assert (R:RemoveMin (Node l x e r h) p) by exact H; - set (m:=Node l x e r h) in *; clearbody m; clear H l x e r -end. - -Lemma merge0_in m1 m2 y : - y ∈ (merge0 m1 m2) <-> y ∈ m1 \/ y ∈ m2. -Proof. - functional induction (merge0 m1 m2); intros; try factornode m1. - - intuition_in. - - intuition_in. - - factor_remove_min l R. rewrite bal_in, (remove_min_in R). - simpl; intuition. -Qed. - -Lemma merge0_mapsto m1 m2 y e : - MapsTo y e (merge0 m1 m2) <-> MapsTo y e m1 \/ MapsTo y e m2. -Proof. - functional induction (merge0 m1 m2); intros; try factornode m1. - - intuition_in. - - intuition_in. - - factor_remove_min l R. rewrite bal_mapsto, (remove_min_mapsto R). - simpl. unfold create; intuition_in. subst. now constructor. -Qed. - -Lemma merge0_bst m1 m2 : Bst m1 -> Bst m2 -> m1 <<< m2 -> - Bst (merge0 m1 m2). -Proof. - functional induction (merge0 m1 m2); intros B1 B2 B12; trivial. - factornode m1. factor_remove_min l R. - apply bal_bst; auto. - - eapply remove_min_bst; eauto. - - apply above. intros z Hz. apply B12; trivial. - rewrite (remove_min_in R). now left. - - now apply (remove_min_gt R). -Qed. -Hint Resolve merge0_bst. - -(** * Deletion *) - -Lemma remove_in m x y : Bst m -> - (y ∈ remove x m <-> ~ y == x /\ y ∈ m). -Proof. - functional induction (remove x m); simpl; intros; cleanf; inv Bst; - rewrite ?merge0_in, ?bal_in, ?IHt; intuition_in; order. -Qed. - -Lemma remove_lt m x y : Bst m -> y >> m -> y >> remove x m. -Proof. - intros. apply above. intro. rewrite remove_in by trivial. - destruct 1; order. -Qed. - -Lemma remove_gt m x y : Bst m -> y << m -> y << remove x m. -Proof. - intros. apply below. intro. rewrite remove_in by trivial. - destruct 1; order. -Qed. - -Lemma remove_bst m x : Bst m -> Bst (remove x m). -Proof. - functional induction (remove x m); simpl; intros; cleanf; inv Bst. - - trivial. - - apply merge0_bst; eauto. - - apply bal_bst; auto using remove_lt. - - apply bal_bst; auto using remove_gt. -Qed. -Hint Resolve remove_bst remove_gt remove_lt. - -Lemma remove_spec1 m x : Bst m -> find x (remove x m) = None. -Proof. - intros. apply not_find_iff; auto. rewrite remove_in; intuition. -Qed. - -Lemma remove_spec2 m x y : Bst m -> ~ x == y -> - find y (remove x m) = find y m. -Proof. - functional induction (remove x m); simpl; intros; cleanf; inv Bst. - - trivial. - - case X.compare_spec; intros; try order; - rewrite find_mapsto_equiv; auto. - + intros. rewrite merge0_mapsto; intuition; order. - + apply merge0_bst; auto. red; intros; transitivity y0; order. - + intros. rewrite merge0_mapsto; intuition; order. - + apply merge0_bst; auto. now apply between with y0. - - rewrite bal_find by auto. simpl. case X.compare_spec; auto. - - rewrite bal_find by auto. simpl. case X.compare_spec; auto. -Qed. - -(** * join *) - -Lemma join_in l x d r y : - y ∈ (join l x d r) <-> y == x \/ y ∈ l \/ y ∈ r. -Proof. - join_tac l x d r. - - simpl join. rewrite add_in. intuition_in. - - rewrite add_in. intuition_in. - - rewrite bal_in, Hlr. clear Hlr Hrl. intuition_in. - - rewrite bal_in, Hrl; clear Hlr Hrl; intuition_in. - - apply create_in. -Qed. - -Lemma join_bst l x d r : - Bst (create l x d r) -> Bst (join l x d r). -Proof. - join_tac l x d r; unfold create in *; - inv Bst; inv Above; inv Below; auto. - - simpl. auto. - - apply bal_bst; auto. - apply below. intro. rewrite join_in. intuition_in; order. - - apply bal_bst; auto. - apply above. intro. rewrite join_in. intuition_in; order. -Qed. -Hint Resolve join_bst. - -Lemma join_find l x d r y : - Bst (create l x d r) -> - find y (join l x d r) = find y (create l x d r). -Proof. - unfold create at 1. - join_tac l x d r; trivial. - - simpl in *. inv Bst. - rewrite add_find; trivial. - case X.compare_spec; intros; trivial. - apply not_find_iff; auto. intro. order. - - clear Hlr. factornode l. simpl. inv Bst. - rewrite add_find by auto. - case X.compare_spec; intros; trivial. - apply not_find_iff; auto. intro. order. - - clear Hrl LT. factornode r. inv Bst; inv Above; inv Below. - rewrite bal_find; auto; simpl. - + rewrite Hlr; auto; simpl. - repeat (case X.compare_spec; trivial; try order). - + apply below. intro. rewrite join_in. intuition_in; order. - - clear Hlr LT LT'. factornode l. inv Bst; inv Above; inv Below. - rewrite bal_find; auto; simpl. - + rewrite Hrl; auto; simpl. - repeat (case X.compare_spec; trivial; try order). - + apply above. intro. rewrite join_in. intuition_in; order. -Qed. - -(** * split *) - -Lemma split_in_l0 m x y : y ∈ (split x m)#l -> y ∈ m. -Proof. - functional induction (split x m); cleansplit; - rewrite ?join_in; intuition. -Qed. - -Lemma split_in_r0 m x y : y ∈ (split x m)#r -> y ∈ m. -Proof. - functional induction (split x m); cleansplit; - rewrite ?join_in; intuition. -Qed. - -Lemma split_in_l m x y : Bst m -> - (y ∈ (split x m)#l <-> y ∈ m /\ y < x). -Proof. - functional induction (split x m); intros; cleansplit; - rewrite ?join_in, ?IHt; intuition_in; order. -Qed. - -Lemma split_in_r m x y : Bst m -> - (y ∈ (split x m)#r <-> y ∈ m /\ x < y). -Proof. - functional induction (split x m); intros; cleansplit; - rewrite ?join_in, ?IHt; intuition_in; order. -Qed. - -Lemma split_in_o m x : (split x m)#o = find x m. -Proof. - functional induction (split x m); intros; cleansplit; auto. -Qed. - -Lemma split_lt_l m x : Bst m -> x >> (split x m)#l. -Proof. - intro. apply above. intro. rewrite split_in_l; intuition; order. -Qed. - -Lemma split_lt_r m x y : y >> m -> y >> (split x m)#r. -Proof. - intro. apply above. intros z Hz. apply split_in_r0 in Hz. order. -Qed. - -Lemma split_gt_r m x : Bst m -> x << (split x m)#r. -Proof. - intro. apply below. intro. rewrite split_in_r; intuition; order. -Qed. - -Lemma split_gt_l m x y : y << m -> y << (split x m)#l. -Proof. - intro. apply below. intros z Hz. apply split_in_l0 in Hz. order. -Qed. -Hint Resolve split_lt_l split_lt_r split_gt_l split_gt_r. - -Lemma split_bst_l m x : Bst m -> Bst (split x m)#l. -Proof. - functional induction (split x m); intros; cleansplit; intuition; - auto using join_bst. -Qed. - -Lemma split_bst_r m x : Bst m -> Bst (split x m)#r. -Proof. - functional induction (split x m); intros; cleansplit; intuition; - auto using join_bst. -Qed. -Hint Resolve split_bst_l split_bst_r. - -Lemma split_find m x y : Bst m -> - find y m = match X.compare y x with - | Eq => (split x m)#o - | Lt => find y (split x m)#l - | Gt => find y (split x m)#r - end. -Proof. - functional induction (split x m); intros; cleansplit. - - now case X.compare. - - repeat case X.compare_spec; trivial; order. - - simpl in *. rewrite join_find, IHt; auto. - simpl. repeat case X.compare_spec; trivial; order. - - rewrite join_find, IHt; auto. - simpl; repeat case X.compare_spec; trivial; order. -Qed. - -(** * Concatenation *) - -Lemma concat_in m1 m2 y : - y ∈ (concat m1 m2) <-> y ∈ m1 \/ y ∈ m2. -Proof. - functional induction (concat m1 m2); intros; try factornode m1. - - intuition_in. - - intuition_in. - - factor_remove_min m2 R. - rewrite join_in, (remove_min_in R); simpl; intuition. -Qed. - -Lemma concat_bst m1 m2 : Bst m1 -> Bst m2 -> m1 <<< m2 -> - Bst (concat m1 m2). -Proof. - functional induction (concat m1 m2); intros B1 B2 LT; auto; - try factornode m1. - factor_remove_min m2 R. - apply join_bst, create_bst; auto. - - now apply (remove_min_bst R). - - apply above. intros y Hy. apply LT; trivial. - rewrite (remove_min_in R); now left. - - now apply (remove_min_gt R). -Qed. -Hint Resolve concat_bst. - -Definition oelse {A} (o1 o2:option A) := - match o1 with - | Some x => Some x - | None => o2 - end. - -Lemma concat_find m1 m2 y : Bst m1 -> Bst m2 -> m1 <<< m2 -> - find y (concat m1 m2) = oelse (find y m2) (find y m1). -Proof. - functional induction (concat m1 m2); intros B1 B2 B; auto; try factornode m1. - - destruct (find y m2); auto. - - factor_remove_min m2 R. - assert (xd#1 >> m1). - { apply above. intros z Hz. apply B; trivial. - rewrite (remove_min_in R). now left. } - rewrite join_find; simpl; auto. - + rewrite (remove_min_find R B2 y). - case X.compare_spec; intros; auto. - destruct (find y m2'); trivial. - simpl. symmetry. apply not_find_iff; eauto. - + apply create_bst; auto. - * now apply (remove_min_bst R). - * now apply (remove_min_gt R). -Qed. - - -(** * Elements *) - -Notation eqk := (PX.eqk (elt:= elt)). -Notation eqke := (PX.eqke (elt:= elt)). -Notation ltk := (PX.ltk (elt:= elt)). - -Lemma bindings_aux_mapsto : forall (s:t elt) acc x e, - InA eqke (x,e) (bindings_aux acc s) <-> MapsTo x e s \/ InA eqke (x,e) acc. -Proof. - induction s as [ | l Hl x e r Hr h ]; simpl; auto. - intuition. - inversion H0. - intros. - rewrite Hl. - destruct (Hr acc x0 e0); clear Hl Hr. - intuition; inversion_clear H3; intuition. - compute in H0. destruct H0; simpl in *; subst; intuition. -Qed. - -Lemma bindings_mapsto : forall (s:t elt) x e, - InA eqke (x,e) (bindings s) <-> MapsTo x e s. -Proof. - intros; generalize (bindings_aux_mapsto s nil x e); intuition. - inversion_clear H0. -Qed. - -Lemma bindings_in : forall (s:t elt) x, L.PX.In x (bindings s) <-> x ∈ s. -Proof. - intros. - unfold L.PX.In. - rewrite <- In_alt; unfold In0. - split; intros (y,H); exists y. - - now rewrite <- bindings_mapsto. - - unfold L.PX.MapsTo; now rewrite bindings_mapsto. -Qed. - -Lemma bindings_aux_sort : forall (s:t elt) acc, - Bst s -> sort ltk acc -> - (forall x e y, InA eqke (x,e) acc -> y ∈ s -> y < x) -> - sort ltk (bindings_aux acc s). -Proof. - induction s as [ | l Hl y e r Hr h]; simpl; intuition. - inv Bst. - apply Hl; auto. - - constructor. - + apply Hr; eauto. - + clear Hl Hr. - apply InA_InfA with (eqA:=eqke); auto with *. - intros (y',e') Hy'. - apply bindings_aux_mapsto in Hy'. compute. intuition; eauto. - - clear Hl Hr. intros x e' y' Hx Hy'. - inversion_clear Hx. - + compute in H. destruct H; simpl in *. order. - + apply bindings_aux_mapsto in H. intuition eauto. -Qed. - -Lemma bindings_sort : forall s : t elt, Bst s -> sort ltk (bindings s). -Proof. - intros; unfold bindings; apply bindings_aux_sort; auto. - intros; inversion H0. -Qed. -Hint Resolve bindings_sort. - -Lemma bindings_nodup : forall s : t elt, Bst s -> NoDupA eqk (bindings s). -Proof. - intros; apply PX.Sort_NoDupA; auto. -Qed. - -Lemma bindings_aux_cardinal m acc : - (length acc + cardinal m)%nat = length (bindings_aux acc m). -Proof. - revert acc. induction m; simpl; intuition. - rewrite <- IHm1; simpl. - rewrite <- IHm2. rewrite Nat.add_succ_r, <- Nat.add_assoc. - f_equal. f_equal. apply Nat.add_comm. -Qed. - -Lemma bindings_cardinal m : cardinal m = length (bindings m). -Proof. - exact (bindings_aux_cardinal m nil). -Qed. - -Lemma bindings_app : - forall (s:t elt) acc, bindings_aux acc s = bindings s ++ acc. -Proof. - induction s; simpl; intros; auto. - rewrite IHs1, IHs2. - unfold bindings; simpl. - rewrite 2 IHs1, IHs2, !app_nil_r, !app_ass; auto. -Qed. - -Lemma bindings_node : - forall (t1 t2:t elt) x e z l, - bindings t1 ++ (x,e) :: bindings t2 ++ l = - bindings (Node t1 x e t2 z) ++ l. -Proof. - unfold bindings; simpl; intros. - rewrite !bindings_app, !app_nil_r, !app_ass; auto. -Qed. - -(** * Fold *) - -Definition fold' {A} (f : key -> elt -> A -> A)(s : t elt) := - L.fold f (bindings s). - -Lemma fold_equiv_aux {A} (s : t elt) (f : key -> elt -> A -> A) (a : A) acc : - L.fold f (bindings_aux acc s) a = L.fold f acc (fold f s a). -Proof. - revert a acc. - induction s; simpl; trivial. - intros. rewrite IHs1. simpl. apply IHs2. -Qed. - -Lemma fold_equiv {A} (s : t elt) (f : key -> elt -> A -> A) (a : A) : - fold f s a = fold' f s a. -Proof. - unfold fold', bindings. now rewrite fold_equiv_aux. -Qed. - -Lemma fold_spec (s:t elt)(Hs:Bst s){A}(i:A)(f : key -> elt -> A -> A) : - fold f s i = fold_left (fun a p => f p#1 p#2 a) (bindings s) i. -Proof. - rewrite fold_equiv. unfold fold'. now rewrite L.fold_spec. -Qed. - -(** * Comparison *) - -(** [flatten_e e] returns the list of bindings of the enumeration [e] - i.e. the list of bindings actually compared *) - -Fixpoint flatten_e (e : enumeration elt) : list (key*elt) := match e with - | End _ => nil - | More x e t r => (x,e) :: bindings t ++ flatten_e r - end. - -Lemma flatten_e_bindings : - forall (l:t elt) r x d z e, - bindings l ++ flatten_e (More x d r e) = - bindings (Node l x d r z) ++ flatten_e e. -Proof. - intros; apply bindings_node. -Qed. - -Lemma cons_1 : forall (s:t elt) e, - flatten_e (cons s e) = bindings s ++ flatten_e e. -Proof. - induction s; auto; intros. - simpl flatten_e; rewrite IHs1; apply flatten_e_bindings; auto. -Qed. - -(** Proof of correction for the comparison *) - -Variable cmp : elt->elt->bool. - -Definition IfEq b l1 l2 := L.equal cmp l1 l2 = b. - -Lemma cons_IfEq : forall b x1 x2 d1 d2 l1 l2, - X.eq x1 x2 -> cmp d1 d2 = true -> - IfEq b l1 l2 -> - IfEq b ((x1,d1)::l1) ((x2,d2)::l2). -Proof. - unfold IfEq; destruct b; simpl; intros; case X.compare_spec; simpl; - try rewrite H0; auto; order. -Qed. - -Lemma equal_end_IfEq : forall e2, - IfEq (equal_end e2) nil (flatten_e e2). -Proof. - destruct e2; red; auto. -Qed. - -Lemma equal_more_IfEq : - forall x1 d1 (cont:enumeration elt -> bool) x2 d2 r2 e2 l, - IfEq (cont (cons r2 e2)) l (bindings r2 ++ flatten_e e2) -> - IfEq (equal_more cmp x1 d1 cont (More x2 d2 r2 e2)) ((x1,d1)::l) - (flatten_e (More x2 d2 r2 e2)). -Proof. - unfold IfEq; simpl; intros; destruct X.compare; simpl; auto. - rewrite <-andb_lazy_alt; f_equal; auto. -Qed. - -Lemma equal_cont_IfEq : forall m1 cont e2 l, - (forall e, IfEq (cont e) l (flatten_e e)) -> - IfEq (equal_cont cmp m1 cont e2) (bindings m1 ++ l) (flatten_e e2). -Proof. - induction m1 as [|l1 Hl1 x1 d1 r1 Hr1 h1]; intros; auto. - rewrite <- bindings_node; simpl. - apply Hl1; auto. - clear e2; intros [|x2 d2 r2 e2]. - simpl; red; auto. - apply equal_more_IfEq. - rewrite <- cons_1; auto. -Qed. - -Lemma equal_IfEq : forall (m1 m2:t elt), - IfEq (equal cmp m1 m2) (bindings m1) (bindings m2). -Proof. - intros; unfold equal. - rewrite <- (app_nil_r (bindings m1)). - replace (bindings m2) with (flatten_e (cons m2 (End _))) - by (rewrite cons_1; simpl; rewrite app_nil_r; auto). - apply equal_cont_IfEq. - intros. - apply equal_end_IfEq; auto. -Qed. - -Definition Equivb m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). - -Lemma Equivb_bindings : forall s s', - Equivb s s' <-> L.Equivb cmp (bindings s) (bindings s'). -Proof. -unfold Equivb, L.Equivb; split; split; intros. -do 2 rewrite bindings_in; firstorder. -destruct H. -apply (H2 k); rewrite <- bindings_mapsto; auto. -do 2 rewrite <- bindings_in; firstorder. -destruct H. -apply (H2 k); unfold L.PX.MapsTo; rewrite bindings_mapsto; auto. -Qed. - -Lemma equal_Equivb : forall (s s': t elt), Bst s -> Bst s' -> - (equal cmp s s' = true <-> Equivb s s'). -Proof. - intros s s' B B'. - rewrite Equivb_bindings, <- equal_IfEq. - split; [apply L.equal_2|apply L.equal_1]; auto. -Qed. - -End Elt. - -Section Map. -Variable elt elt' : Type. -Variable f : elt -> elt'. - -Lemma map_spec m x : - find x (map f m) = option_map f (find x m). -Proof. -induction m; simpl; trivial. case X.compare_spec; auto. -Qed. - -Lemma map_in m x : x ∈ (map f m) <-> x ∈ m. -Proof. -induction m; simpl; intuition_in. -Qed. - -Lemma map_bst m : Bst m -> Bst (map f m). -Proof. -induction m; simpl; auto. intros; inv Bst; constructor; auto. -- apply above. intro. rewrite map_in. intros. order. -- apply below. intro. rewrite map_in. intros. order. -Qed. - -End Map. -Section Mapi. -Variable elt elt' : Type. -Variable f : key -> elt -> elt'. - -Lemma mapi_spec m x : - exists y:key, - X.eq y x /\ find x (mapi f m) = option_map (f y) (find x m). -Proof. - induction m; simpl. - - now exists x. - - case X.compare_spec; simpl; auto. intros. now exists k. -Qed. - -Lemma mapi_in m x : x ∈ (mapi f m) <-> x ∈ m. -Proof. -induction m; simpl; intuition_in. -Qed. - -Lemma mapi_bst m : Bst m -> Bst (mapi f m). -Proof. -induction m; simpl; auto. intros; inv Bst; constructor; auto. -- apply above. intro. rewrite mapi_in. intros. order. -- apply below. intro. rewrite mapi_in. intros. order. -Qed. - -End Mapi. - -Section Mapo. -Variable elt elt' : Type. -Variable f : key -> elt -> option elt'. - -Lemma mapo_in m x : - x ∈ (mapo f m) -> - exists y d, X.eq y x /\ MapsTo x d m /\ f y d <> None. -Proof. -functional induction (mapo f m); simpl; auto; intro H. -- inv In. -- rewrite join_in in H; destruct H as [H|[H|H]]. - + exists x0, d. do 2 (split; auto). congruence. - + destruct (IHt H) as (y & e & ? & ? & ?). exists y, e. auto. - + destruct (IHt0 H) as (y & e & ? & ? & ?). exists y, e. auto. -- rewrite concat_in in H; destruct H as [H|H]. - + destruct (IHt H) as (y & e & ? & ? & ?). exists y, e. auto. - + destruct (IHt0 H) as (y & e & ? & ? & ?). exists y, e. auto. -Qed. - -Lemma mapo_lt m x : x >> m -> x >> mapo f m. -Proof. - intros H. apply above. intros y Hy. - destruct (mapo_in Hy) as (y' & e & ? & ? & ?). order. -Qed. - -Lemma mapo_gt m x : x << m -> x << mapo f m. -Proof. - intros H. apply below. intros y Hy. - destruct (mapo_in Hy) as (y' & e & ? & ? & ?). order. -Qed. -Hint Resolve mapo_lt mapo_gt. - -Lemma mapo_bst m : Bst m -> Bst (mapo f m). -Proof. -functional induction (mapo f m); simpl; auto; intro H; inv Bst. -- apply join_bst, create_bst; auto. -- apply concat_bst; auto. apply between with x; auto. -Qed. -Hint Resolve mapo_bst. - -Ltac nonify e := - replace e with (@None elt) by - (symmetry; rewrite not_find_iff; auto; intro; order). - -Definition obind {A B} (o:option A) (f:A->option B) := - match o with Some a => f a | None => None end. - -Lemma mapo_find m x : - Bst m -> - exists y, X.eq y x /\ - find x (mapo f m) = obind (find x m) (f y). -Proof. -functional induction (mapo f m); simpl; auto; intros B; - inv Bst. -- now exists x. -- rewrite join_find; auto. - + simpl. case X.compare_spec; simpl; intros. - * now exists x0. - * destruct IHt as (y' & ? & ?); auto. - exists y'; split; trivial. - * destruct IHt0 as (y' & ? & ?); auto. - exists y'; split; trivial. - + constructor; auto using mapo_lt, mapo_gt. -- rewrite concat_find; auto. - + destruct IHt0 as (y' & ? & ->); auto. - destruct IHt as (y'' & ? & ->); auto. - case X.compare_spec; simpl; intros. - * nonify (find x r). nonify (find x l). simpl. now exists x0. - * nonify (find x r). now exists y''. - * nonify (find x l). exists y'. split; trivial. - destruct (find x r); simpl; trivial. - now destruct (f y' e). - + apply between with x0; auto. -Qed. - -End Mapo. - -Section Gmerge. -Variable elt elt' elt'' : Type. -Variable f0 : key -> option elt -> option elt' -> option elt''. -Variable f : key -> elt -> option elt' -> option elt''. -Variable mapl : t elt -> t elt''. -Variable mapr : t elt' -> t elt''. -Hypothesis f0_f : forall x d o, f x d o = f0 x (Some d) o. -Hypothesis mapl_bst : forall m, Bst m -> Bst (mapl m). -Hypothesis mapr_bst : forall m', Bst m' -> Bst (mapr m'). -Hypothesis mapl_f0 : forall x m, Bst m -> - exists y, X.eq y x /\ - find x (mapl m) = obind (find x m) (fun d => f0 y (Some d) None). -Hypothesis mapr_f0 : forall x m, Bst m -> - exists y, X.eq y x /\ - find x (mapr m) = obind (find x m) (fun d => f0 y None (Some d)). - -Notation gmerge := (gmerge f mapl mapr). - -Lemma gmerge_in m m' y : Bst m -> Bst m' -> - y ∈ (gmerge m m') -> y ∈ m \/ y ∈ m'. -Proof. - functional induction (gmerge m m'); intros B1 B2 H; - try factornode m2; inv Bst. - - right. apply find_in. - generalize (in_find (mapr_bst B2) H). - destruct (@mapr_f0 y m2) as (y' & ? & ->); trivial. - intros A B. rewrite B in A. now elim A. - - left. apply find_in. - generalize (in_find (mapl_bst B1) H). - destruct (@mapl_f0 y m2) as (y' & ? & ->); trivial. - intros A B. rewrite B in A. now elim A. - - rewrite join_in in *. revert IHt1 IHt0 H. cleansplit. - generalize (split_bst_l x1 B2) (split_bst_r x1 B2). - rewrite split_in_r, split_in_l; intuition_in. - - rewrite concat_in in *. revert IHt1 IHt0 H; cleansplit. - generalize (split_bst_l x1 B2) (split_bst_r x1 B2). - rewrite split_in_r, split_in_l; intuition_in. -Qed. - -Lemma gmerge_lt m m' x : Bst m -> Bst m' -> - x >> m -> x >> m' -> x >> gmerge m m'. -Proof. - intros. apply above. intros y Hy. - apply gmerge_in in Hy; intuition_in; order. -Qed. - -Lemma gmerge_gt m m' x : Bst m -> Bst m' -> - x << m -> x << m' -> x << gmerge m m'. -Proof. - intros. apply below. intros y Hy. - apply gmerge_in in Hy; intuition_in; order. -Qed. -Hint Resolve gmerge_lt gmerge_gt. -Hint Resolve split_bst_l split_bst_r split_lt_l split_gt_r. - -Lemma gmerge_bst m m' : Bst m -> Bst m' -> Bst (gmerge m m'). -Proof. - functional induction (gmerge m m'); intros B1 B2; auto; - factornode m2; inv Bst; - (apply join_bst, create_bst || apply concat_bst); - revert IHt1 IHt0; cleansplit; intuition. - apply between with x1; auto. -Qed. -Hint Resolve gmerge_bst. - -Lemma oelse_none_r {A} (o:option A) : oelse o None = o. -Proof. now destruct o. Qed. - -Ltac nonify e := - let E := fresh "E" in - assert (E : e = None); - [ rewrite not_find_iff; auto; intro U; - try apply gmerge_in in U; intuition_in; order - | rewrite E; clear E ]. - -Lemma gmerge_find m m' x : Bst m -> Bst m' -> - In x m \/ In x m' -> - exists y, X.eq y x /\ - find x (gmerge m m') = f0 y (find x m) (find x m'). -Proof. - functional induction (gmerge m m'); intros B1 B2 H; - try factornode m2; inv Bst. - - destruct H; [ intuition_in | ]. - destruct (@mapr_f0 x m2) as (y,(Hy,E)); trivial. - exists y; split; trivial. - rewrite E. simpl. apply in_find in H; trivial. - destruct (find x m2); simpl; intuition. - - destruct H; [ | intuition_in ]. - destruct (@mapl_f0 x m2) as (y,(Hy,E)); trivial. - exists y; split; trivial. - rewrite E. simpl. apply in_find in H; trivial. - destruct (find x m2); simpl; intuition. - - generalize (split_bst_l x1 B2) (split_bst_r x1 B2). - rewrite (split_find x1 x B2). - rewrite e1 in *; simpl in *. intros. - rewrite join_find by (cleansplit; constructor; auto). - simpl. case X.compare_spec; intros. - + exists x1. split; auto. now rewrite <- e3, f0_f. - + apply IHt1; auto. clear IHt1 IHt0. - cleansplit; rewrite split_in_l; trivial. - intuition_in; order. - + apply IHt0; auto. clear IHt1 IHt0. - cleansplit; rewrite split_in_r; trivial. - intuition_in; order. - - generalize (split_bst_l x1 B2) (split_bst_r x1 B2). - rewrite (split_find x1 x B2). - pose proof (split_lt_l x1 B2). - pose proof (split_gt_r x1 B2). - rewrite e1 in *; simpl in *. intros. - rewrite concat_find by (try apply between with x1; auto). - case X.compare_spec; intros. - + clear IHt0 IHt1. - exists x1. split; auto. rewrite <- f0_f, e2. - nonify (find x (gmerge r1 r2')). - nonify (find x (gmerge l1 l2')). trivial. - + nonify (find x (gmerge r1 r2')). - simpl. apply IHt1; auto. clear IHt1 IHt0. - intuition_in; try order. - right. cleansplit. now apply split_in_l. - + nonify (find x (gmerge l1 l2')). simpl. - rewrite oelse_none_r. - apply IHt0; auto. clear IHt1 IHt0. - intuition_in; try order. - right. cleansplit. now apply split_in_r. -Qed. - -End Gmerge. - -Section Merge. -Variable elt elt' elt'' : Type. -Variable f : key -> option elt -> option elt' -> option elt''. - -Lemma merge_bst m m' : Bst m -> Bst m' -> Bst (merge f m m'). -Proof. -unfold merge; intros. -apply gmerge_bst with f; - auto using mapo_bst, mapo_find. -Qed. - -Lemma merge_spec1 m m' x : Bst m -> Bst m' -> - In x m \/ In x m' -> - exists y, X.eq y x /\ - find x (merge f m m') = f y (find x m) (find x m'). -Proof. - unfold merge; intros. - edestruct (gmerge_find (f0:=f)) as (y,(Hy,E)); - eauto using mapo_bst. - - reflexivity. - - intros. now apply mapo_find. - - intros. now apply mapo_find. -Qed. - -Lemma merge_spec2 m m' x : Bst m -> Bst m' -> - In x (merge f m m') -> In x m \/ In x m'. -Proof. -unfold merge; intros. -eapply gmerge_in with (f0:=f); try eassumption; - auto using mapo_bst, mapo_find. -Qed. - -End Merge. -End Proofs. -End Raw. - -(** * Encapsulation - - Now, in order to really provide a functor implementing [S], we - need to encapsulate everything into a type of balanced binary search trees. *) - -Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. - - Module E := X. - Module Raw := Raw I X. - Import Raw.Proofs. - - Record tree (elt:Type) := - Mk {this :> Raw.tree elt; is_bst : Raw.Bst this}. - - Definition t := tree. - Definition key := E.t. - - Section Elt. - Variable elt elt' elt'': Type. - - Implicit Types m : t elt. - Implicit Types x y : key. - Implicit Types e : elt. - - Definition empty : t elt := Mk (empty_bst elt). - Definition is_empty m : bool := Raw.is_empty m.(this). - Definition add x e m : t elt := Mk (add_bst x e m.(is_bst)). - Definition remove x m : t elt := Mk (remove_bst x m.(is_bst)). - Definition mem x m : bool := Raw.mem x m.(this). - Definition find x m : option elt := Raw.find x m.(this). - Definition map f m : t elt' := Mk (map_bst f m.(is_bst)). - Definition mapi (f:key->elt->elt') m : t elt' := - Mk (mapi_bst f m.(is_bst)). - Definition merge f m (m':t elt') : t elt'' := - Mk (merge_bst f m.(is_bst) m'.(is_bst)). - Definition bindings m : list (key*elt) := Raw.bindings m.(this). - Definition cardinal m := Raw.cardinal m.(this). - Definition fold {A} (f:key->elt->A->A) m i := Raw.fold (A:=A) f m.(this) i. - Definition equal cmp m m' : bool := Raw.equal cmp m.(this) m'.(this). - - Definition MapsTo x e m : Prop := Raw.MapsTo x e m.(this). - Definition In x m : Prop := Raw.In0 x m.(this). - - Definition eq_key : (key*elt) -> (key*elt) -> Prop := @PX.eqk elt. - Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop := @PX.eqke elt. - Definition lt_key : (key*elt) -> (key*elt) -> Prop := @PX.ltk elt. - - Instance MapsTo_compat : - Proper (E.eq==>Logic.eq==>Logic.eq==>iff) MapsTo. - Proof. - intros k k' Hk e e' He m m' Hm. unfold MapsTo; simpl. - now rewrite Hk, He, Hm. - Qed. - - Lemma find_spec m x e : find x m = Some e <-> MapsTo x e m. - Proof. apply find_spec. apply is_bst. Qed. - - Lemma mem_spec m x : mem x m = true <-> In x m. - Proof. - unfold In, mem; rewrite In_alt. apply mem_spec. apply is_bst. - Qed. - - Lemma empty_spec x : find x empty = None. - Proof. apply empty_spec. Qed. - - Lemma is_empty_spec m : is_empty m = true <-> forall x, find x m = None. - Proof. apply is_empty_spec. Qed. - - Lemma add_spec1 m x e : find x (add x e m) = Some e. - Proof. apply add_spec1. apply is_bst. Qed. - Lemma add_spec2 m x y e : ~ E.eq x y -> find y (add x e m) = find y m. - Proof. apply add_spec2. apply is_bst. Qed. - - Lemma remove_spec1 m x : find x (remove x m) = None. - Proof. apply remove_spec1. apply is_bst. Qed. - Lemma remove_spec2 m x y : ~E.eq x y -> find y (remove x m) = find y m. - Proof. apply remove_spec2. apply is_bst. Qed. - - Lemma bindings_spec1 m x e : - InA eq_key_elt (x,e) (bindings m) <-> MapsTo x e m. - Proof. apply bindings_mapsto. Qed. - - Lemma bindings_spec2 m : sort lt_key (bindings m). - Proof. apply bindings_sort. apply is_bst. Qed. - - Lemma bindings_spec2w m : NoDupA eq_key (bindings m). - Proof. apply bindings_nodup. apply is_bst. Qed. - - Lemma fold_spec m {A} (i : A) (f : key -> elt -> A -> A) : - fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i. - Proof. apply fold_spec. apply is_bst. Qed. - - Lemma cardinal_spec m : cardinal m = length (bindings m). - Proof. apply bindings_cardinal. Qed. - - Definition Equal m m' := forall y, find y m = find y m'. - Definition Equiv (eq_elt:elt->elt->Prop) m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). - Definition Equivb cmp := Equiv (Cmp cmp). - - Lemma Equivb_Equivb cmp m m' : - Equivb cmp m m' <-> Raw.Proofs.Equivb cmp m m'. - Proof. - unfold Equivb, Equiv, Raw.Proofs.Equivb, In. intuition. - generalize (H0 k); do 2 rewrite In_alt; intuition. - generalize (H0 k); do 2 rewrite In_alt; intuition. - generalize (H0 k); do 2 rewrite <- In_alt; intuition. - generalize (H0 k); do 2 rewrite <- In_alt; intuition. - Qed. - - Lemma equal_spec m m' cmp : - equal cmp m m' = true <-> Equivb cmp m m'. - Proof. rewrite Equivb_Equivb. apply equal_Equivb; apply is_bst. Qed. - - End Elt. - - Lemma map_spec {elt elt'} (f:elt->elt') m x : - find x (map f m) = option_map f (find x m). - Proof. apply map_spec. Qed. - - Lemma mapi_spec {elt elt'} (f:key->elt->elt') m x : - exists y:key, E.eq y x /\ find x (mapi f m) = option_map (f y) (find x m). - Proof. apply mapi_spec. Qed. - - Lemma merge_spec1 {elt elt' elt''} - (f:key->option elt->option elt'->option elt'') m m' x : - In x m \/ In x m' -> - exists y:key, E.eq y x /\ - find x (merge f m m') = f y (find x m) (find x m'). - Proof. - unfold In. rewrite !In_alt. apply merge_spec1; apply is_bst. - Qed. - - Lemma merge_spec2 {elt elt' elt''} - (f:key -> option elt->option elt'->option elt'') m m' x : - In x (merge f m m') -> In x m \/ In x m'. - Proof. - unfold In. rewrite !In_alt. apply merge_spec2; apply is_bst. - Qed. - -End IntMake. - - -Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: - Sord with Module Data := D - with Module MapS.E := X. - - Module Data := D. - Module Import MapS := IntMake(I)(X). - Module LO := MMapList.Make_ord(X)(D). - Module R := Raw. - Module P := Raw.Proofs. - - Definition t := MapS.t D.t. - - Definition cmp e e' := - match D.compare e e' with Eq => true | _ => false end. - - (** One step of comparison of bindings *) - - Definition compare_more x1 d1 (cont:R.enumeration D.t -> comparison) e2 := - match e2 with - | R.End _ => Gt - | R.More x2 d2 r2 e2 => - match X.compare x1 x2 with - | Eq => match D.compare d1 d2 with - | Eq => cont (R.cons r2 e2) - | Lt => Lt - | Gt => Gt - end - | Lt => Lt - | Gt => Gt - end - end. - - (** Comparison of left tree, middle element, then right tree *) - - Fixpoint compare_cont s1 (cont:R.enumeration D.t -> comparison) e2 := - match s1 with - | R.Leaf _ => cont e2 - | R.Node l1 x1 d1 r1 _ => - compare_cont l1 (compare_more x1 d1 (compare_cont r1 cont)) e2 - end. - - (** Initial continuation *) - - Definition compare_end (e2:R.enumeration D.t) := - match e2 with R.End _ => Eq | _ => Lt end. - - (** The complete comparison *) - - Definition compare m1 m2 := - compare_cont m1.(this) compare_end (R.cons m2 .(this) (Raw.End _)). - - (** Correctness of this comparison *) - - Definition Cmp c := - match c with - | Eq => LO.eq_list - | Lt => LO.lt_list - | Gt => (fun l1 l2 => LO.lt_list l2 l1) - end. - - Lemma cons_Cmp c x1 x2 d1 d2 l1 l2 : - X.eq x1 x2 -> D.eq d1 d2 -> - Cmp c l1 l2 -> Cmp c ((x1,d1)::l1) ((x2,d2)::l2). - Proof. - destruct c; simpl; intros; case X.compare_spec; auto; try P.MX.order. - intros. right. split; auto. now symmetry. - Qed. - Hint Resolve cons_Cmp. - - Lemma compare_end_Cmp e2 : - Cmp (compare_end e2) nil (P.flatten_e e2). - Proof. - destruct e2; simpl; auto. - Qed. - - Lemma compare_more_Cmp x1 d1 cont x2 d2 r2 e2 l : - Cmp (cont (R.cons r2 e2)) l (R.bindings r2 ++ P.flatten_e e2) -> - Cmp (compare_more x1 d1 cont (R.More x2 d2 r2 e2)) ((x1,d1)::l) - (P.flatten_e (R.More x2 d2 r2 e2)). - Proof. - simpl; case X.compare_spec; simpl; - try case D.compare_spec; simpl; auto; - case X.compare_spec; try P.MX.order; auto. - Qed. - - Lemma compare_cont_Cmp : forall s1 cont e2 l, - (forall e, Cmp (cont e) l (P.flatten_e e)) -> - Cmp (compare_cont s1 cont e2) (R.bindings s1 ++ l) (P.flatten_e e2). - Proof. - induction s1 as [|l1 Hl1 x1 d1 r1 Hr1 h1] using P.tree_ind; - intros; auto. - rewrite <- P.bindings_node; simpl. - apply Hl1; auto. clear e2. intros [|x2 d2 r2 e2]. - simpl; auto. - apply compare_more_Cmp. - rewrite <- P.cons_1; auto. - Qed. - - Lemma compare_Cmp m1 m2 : - Cmp (compare m1 m2) (bindings m1) (bindings m2). - Proof. - destruct m1 as (s1,H1), m2 as (s2,H2). - unfold compare, bindings; simpl. - rewrite <- (app_nil_r (R.bindings s1)). - replace (R.bindings s2) with (P.flatten_e (R.cons s2 (R.End _))) by - (rewrite P.cons_1; simpl; rewrite app_nil_r; auto). - auto using compare_cont_Cmp, compare_end_Cmp. - Qed. - - Definition eq (m1 m2 : t) := LO.eq_list (bindings m1) (bindings m2). - Definition lt (m1 m2 : t) := LO.lt_list (bindings m1) (bindings m2). - - Lemma compare_spec m1 m2 : CompSpec eq lt m1 m2 (compare m1 m2). - Proof. - assert (H := compare_Cmp m1 m2). - unfold Cmp in H. - destruct (compare m1 m2); auto. - Qed. - - (* Proofs about [eq] and [lt] *) - - Definition sbindings (m1 : t) := - LO.MapS.Mk (P.bindings_sort m1.(is_bst)). - - Definition seq (m1 m2 : t) := LO.eq (sbindings m1) (sbindings m2). - Definition slt (m1 m2 : t) := LO.lt (sbindings m1) (sbindings m2). - - Lemma eq_seq : forall m1 m2, eq m1 m2 <-> seq m1 m2. - Proof. - unfold eq, seq, sbindings, bindings, LO.eq; intuition. - Qed. - - Lemma lt_slt : forall m1 m2, lt m1 m2 <-> slt m1 m2. - Proof. - unfold lt, slt, sbindings, bindings, LO.lt; intuition. - Qed. - - Lemma eq_spec m m' : eq m m' <-> Equivb cmp m m'. - Proof. - rewrite eq_seq; unfold seq. - rewrite Equivb_Equivb. - rewrite P.Equivb_bindings. apply LO.eq_spec. - Qed. - - Instance eq_equiv : Equivalence eq. - Proof. - constructor; red; [intros x|intros x y| intros x y z]; - rewrite !eq_seq; apply LO.eq_equiv. - Qed. - - Instance lt_compat : Proper (eq ==> eq ==> iff) lt. - Proof. - intros m1 m2 H1 m1' m2' H2. rewrite !lt_slt. rewrite eq_seq in *. - now apply LO.lt_compat. - Qed. - - Instance lt_strorder : StrictOrder lt. - Proof. - constructor; red; [intros x; red|intros x y z]; - rewrite !lt_slt; apply LO.lt_strorder. - Qed. - -End IntMake_ord. - -(* For concrete use inside Coq, we propose an instantiation of [Int] by [Z]. *) - -Module Make (X: OrderedType) <: S with Module E := X - :=IntMake(Z_as_Int)(X). - -Module Make_ord (X: OrderedType)(D: OrderedType) - <: Sord with Module Data := D - with Module MapS.E := X - :=IntMake_ord(Z_as_Int)(X)(D). diff --git a/theories/MMaps/MMapFacts.v b/theories/MMaps/MMapFacts.v deleted file mode 100644 index 69066a7b6..000000000 --- a/theories/MMaps/MMapFacts.v +++ /dev/null @@ -1,2434 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) -(* \VV/ *************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(***********************************************************************) - -(** * Finite maps library *) - -(** This functor derives additional facts from [MMapInterface.S]. These - facts are mainly the specifications of [MMapInterface.S] written using - different styles: equivalence and boolean equalities. -*) - -Require Import Bool Equalities Orders OrdersFacts OrdersLists. -Require Import Morphisms Permutation SetoidPermutation. -Require Export MMapInterface. -Set Implicit Arguments. -Unset Strict Implicit. - -Lemma eq_bool_alt b b' : b=b' <-> (b=true <-> b'=true). -Proof. - destruct b, b'; intuition. -Qed. - -Lemma eq_option_alt {elt}(o o':option elt) : - o=o' <-> (forall e, o=Some e <-> o'=Some e). -Proof. -split; intros. -- now subst. -- destruct o, o'; rewrite ?H; auto. - symmetry; now apply H. -Qed. - -Lemma option_map_some {A B}(f:A->B) o : - option_map f o <> None <-> o <> None. -Proof. - destruct o; simpl. now split. split; now destruct 1. -Qed. - -(** * Properties about weak maps *) - -Module WProperties_fun (E:DecidableType)(Import M:WSfun E). - -Definition Empty {elt}(m : t elt) := forall x e, ~MapsTo x e m. - -(** A few things about E.eq *) - -Lemma eq_refl x : E.eq x x. Proof. apply E.eq_equiv. Qed. -Lemma eq_sym x y : E.eq x y -> E.eq y x. Proof. apply E.eq_equiv. Qed. -Lemma eq_trans x y z : E.eq x y -> E.eq y z -> E.eq x z. -Proof. apply E.eq_equiv. Qed. -Hint Immediate eq_refl eq_sym : map. -Hint Resolve eq_trans eq_equivalence E.eq_equiv : map. - -Definition eqb x y := if E.eq_dec x y then true else false. - -Lemma eqb_eq x y : eqb x y = true <-> E.eq x y. -Proof. - unfold eqb; case E.eq_dec; now intuition. -Qed. - -Lemma eqb_sym x y : eqb x y = eqb y x. -Proof. - apply eq_bool_alt. rewrite !eqb_eq. split; apply E.eq_equiv. -Qed. - -(** Initial results about MapsTo and In *) - -Lemma mapsto_fun {elt} m x (e e':elt) : - MapsTo x e m -> MapsTo x e' m -> e=e'. -Proof. -rewrite <- !find_spec. congruence. -Qed. - -Lemma in_find {elt} (m : t elt) x : In x m <-> find x m <> None. -Proof. - unfold In. split. - - intros (e,H). rewrite <-find_spec in H. congruence. - - destruct (find x m) as [e|] eqn:H. - + exists e. now apply find_spec. - + now destruct 1. -Qed. - -Lemma not_in_find {elt} (m : t elt) x : ~In x m <-> find x m = None. -Proof. - rewrite in_find. split; auto. - intros; destruct (find x m); trivial. now destruct H. -Qed. - -Notation in_find_iff := in_find (only parsing). -Notation not_find_in_iff := not_in_find (only parsing). - -(** * [Equal] is a setoid equality. *) - -Infix "==" := Equal (at level 30). - -Lemma Equal_refl {elt} (m : t elt) : m == m. -Proof. red; reflexivity. Qed. - -Lemma Equal_sym {elt} (m m' : t elt) : m == m' -> m' == m. -Proof. unfold Equal; auto. Qed. - -Lemma Equal_trans {elt} (m m' m'' : t elt) : - m == m' -> m' == m'' -> m == m''. -Proof. unfold Equal; congruence. Qed. - -Instance Equal_equiv {elt} : Equivalence (@Equal elt). -Proof. -constructor; [exact Equal_refl | exact Equal_sym | exact Equal_trans]. -Qed. - -Arguments Equal {elt} m m'. - -Instance MapsTo_m {elt} : - Proper (E.eq==>Logic.eq==>Equal==>iff) (@MapsTo elt). -Proof. -intros k k' Hk e e' <- m m' Hm. rewrite <- Hk. -now rewrite <- !find_spec, Hm. -Qed. - -Instance In_m {elt} : - Proper (E.eq==>Equal==>iff) (@In elt). -Proof. -intros k k' Hk m m' Hm. unfold In. -split; intros (e,H); exists e; revert H; - now rewrite Hk, <- !find_spec, Hm. -Qed. - -Instance find_m {elt} : Proper (E.eq==>Equal==>Logic.eq) (@find elt). -Proof. -intros k k' Hk m m' <-. -rewrite eq_option_alt. intros. now rewrite !find_spec, Hk. -Qed. - -Instance mem_m {elt} : Proper (E.eq==>Equal==>Logic.eq) (@mem elt). -Proof. -intros k k' Hk m m' Hm. now rewrite eq_bool_alt, !mem_spec, Hk, Hm. -Qed. - -Instance Empty_m {elt} : Proper (Equal==>iff) (@Empty elt). -Proof. -intros m m' Hm. unfold Empty. now setoid_rewrite Hm. -Qed. - -Instance is_empty_m {elt} : Proper (Equal ==> Logic.eq) (@is_empty elt). -Proof. -intros m m' Hm. rewrite eq_bool_alt, !is_empty_spec. - now setoid_rewrite Hm. -Qed. - -Instance add_m {elt} : Proper (E.eq==>Logic.eq==>Equal==>Equal) (@add elt). -Proof. -intros k k' Hk e e' <- m m' Hm y. -destruct (E.eq_dec k y) as [H|H]. -- rewrite <-H, add_spec1. now rewrite Hk, add_spec1. -- rewrite !add_spec2; trivial. now rewrite <- Hk. -Qed. - -Instance remove_m {elt} : Proper (E.eq==>Equal==>Equal) (@remove elt). -Proof. -intros k k' Hk m m' Hm y. -destruct (E.eq_dec k y) as [H|H]. -- rewrite <-H, remove_spec1. now rewrite Hk, remove_spec1. -- rewrite !remove_spec2; trivial. now rewrite <- Hk. -Qed. - -Instance map_m {elt elt'} : - Proper ((Logic.eq==>Logic.eq)==>Equal==>Equal) (@map elt elt'). -Proof. -intros f f' Hf m m' Hm y. rewrite !map_spec, Hm. -destruct (find y m'); simpl; trivial. f_equal. now apply Hf. -Qed. - -Instance mapi_m {elt elt'} : - Proper ((E.eq==>Logic.eq==>Logic.eq)==>Equal==>Equal) (@mapi elt elt'). -Proof. -intros f f' Hf m m' Hm y. -destruct (mapi_spec f m y) as (x,(Hx,->)). -destruct (mapi_spec f' m' y) as (x',(Hx',->)). -rewrite <- Hm. destruct (find y m); trivial. simpl. -f_equal. apply Hf; trivial. now rewrite Hx, Hx'. -Qed. - -Instance merge_m {elt elt' elt''} : - Proper ((E.eq==>Logic.eq==>Logic.eq==>Logic.eq)==>Equal==>Equal==>Equal) - (@merge elt elt' elt''). -Proof. -intros f f' Hf m1 m1' Hm1 m2 m2' Hm2 y. -destruct (find y m1) as [e1|] eqn:H1. -- apply find_spec in H1. - assert (H : In y m1 \/ In y m2) by (left; now exists e1). - destruct (merge_spec1 f H) as (y1,(Hy1,->)). - rewrite Hm1,Hm2 in H. - destruct (merge_spec1 f' H) as (y2,(Hy2,->)). - rewrite <- Hm1, <- Hm2. apply Hf; trivial. now transitivity y. -- destruct (find y m2) as [e2|] eqn:H2. - + apply find_spec in H2. - assert (H : In y m1 \/ In y m2) by (right; now exists e2). - destruct (merge_spec1 f H) as (y1,(Hy1,->)). - rewrite Hm1,Hm2 in H. - destruct (merge_spec1 f' H) as (y2,(Hy2,->)). - rewrite <- Hm1, <- Hm2. apply Hf; trivial. now transitivity y. - + apply not_in_find in H1. apply not_in_find in H2. - assert (H : ~In y (merge f m1 m2)). - { intro H. apply merge_spec2 in H. intuition. } - apply not_in_find in H. rewrite H. - symmetry. apply not_in_find. intro H'. - apply merge_spec2 in H'. rewrite <- Hm1, <- Hm2 in H'. - intuition. -Qed. - -(* Later: compatibility for cardinal, fold, ... *) - -(** ** Earlier specifications (cf. FMaps) *) - -Section OldSpecs. -Variable elt: Type. -Implicit Type m: t elt. -Implicit Type x y z: key. -Implicit Type e: elt. - -Lemma MapsTo_1 m x y e : E.eq x y -> MapsTo x e m -> MapsTo y e m. -Proof. - now intros ->. -Qed. - -Lemma find_1 m x e : MapsTo x e m -> find x m = Some e. -Proof. apply find_spec. Qed. - -Lemma find_2 m x e : find x m = Some e -> MapsTo x e m. -Proof. apply find_spec. Qed. - -Lemma mem_1 m x : In x m -> mem x m = true. -Proof. apply mem_spec. Qed. - -Lemma mem_2 m x : mem x m = true -> In x m. -Proof. apply mem_spec. Qed. - -Lemma empty_1 : Empty (@empty elt). -Proof. - intros x e. now rewrite <- find_spec, empty_spec. -Qed. - -Lemma is_empty_1 m : Empty m -> is_empty m = true. -Proof. - unfold Empty; rewrite is_empty_spec. setoid_rewrite <- find_spec. - intros H x. specialize (H x). - destruct (find x m) as [e|]; trivial. - now destruct (H e). -Qed. - -Lemma is_empty_2 m : is_empty m = true -> Empty m. -Proof. - rewrite is_empty_spec. intros H x e. now rewrite <- find_spec, H. -Qed. - -Lemma add_1 m x y e : E.eq x y -> MapsTo y e (add x e m). -Proof. - intros <-. rewrite <-find_spec. apply add_spec1. -Qed. - -Lemma add_2 m x y e e' : - ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). -Proof. - intro. now rewrite <- !find_spec, add_spec2. -Qed. - -Lemma add_3 m x y e e' : - ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. -Proof. - intro. rewrite <- !find_spec, add_spec2; trivial. -Qed. - -Lemma remove_1 m x y : E.eq x y -> ~ In y (remove x m). -Proof. - intros <-. apply not_in_find. apply remove_spec1. -Qed. - -Lemma remove_2 m x y e : - ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). -Proof. - intro. now rewrite <- !find_spec, remove_spec2. -Qed. - -Lemma remove_3bis m x y e : - find y (remove x m) = Some e -> find y m = Some e. -Proof. - destruct (E.eq_dec x y) as [<-|H]. - - now rewrite remove_spec1. - - now rewrite remove_spec2. -Qed. - -Lemma remove_3 m x y e : MapsTo y e (remove x m) -> MapsTo y e m. -Proof. - rewrite <-!find_spec. apply remove_3bis. -Qed. - -Lemma bindings_1 m x e : - MapsTo x e m -> InA eq_key_elt (x,e) (bindings m). -Proof. apply bindings_spec1. Qed. - -Lemma bindings_2 m x e : - InA eq_key_elt (x,e) (bindings m) -> MapsTo x e m. -Proof. apply bindings_spec1. Qed. - -Lemma bindings_3w m : NoDupA eq_key (bindings m). -Proof. apply bindings_spec2w. Qed. - -Lemma cardinal_1 m : cardinal m = length (bindings m). -Proof. apply cardinal_spec. Qed. - -Lemma fold_1 m (A : Type) (i : A) (f : key -> elt -> A -> A) : - fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i. -Proof. apply fold_spec. Qed. - -Lemma equal_1 m m' cmp : Equivb cmp m m' -> equal cmp m m' = true. -Proof. apply equal_spec. Qed. - -Lemma equal_2 m m' cmp : equal cmp m m' = true -> Equivb cmp m m'. -Proof. apply equal_spec. Qed. - -End OldSpecs. - -Lemma map_1 {elt elt'}(m: t elt)(x:key)(e:elt)(f:elt->elt') : - MapsTo x e m -> MapsTo x (f e) (map f m). -Proof. - rewrite <- !find_spec, map_spec. now intros ->. -Qed. - -Lemma map_2 {elt elt'}(m: t elt)(x:key)(f:elt->elt') : - In x (map f m) -> In x m. -Proof. - rewrite !in_find, map_spec. apply option_map_some. -Qed. - -Lemma mapi_1 {elt elt'}(m: t elt)(x:key)(e:elt)(f:key->elt->elt') : - MapsTo x e m -> - exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). -Proof. - destruct (mapi_spec f m x) as (y,(Hy,Eq)). - intro H. exists y; split; trivial. - rewrite <-find_spec in *. now rewrite Eq, H. -Qed. - -Lemma mapi_2 {elt elt'}(m: t elt)(x:key)(f:key->elt->elt') : - In x (mapi f m) -> In x m. -Proof. - destruct (mapi_spec f m x) as (y,(Hy,Eq)). - rewrite !in_find. intro H; contradict H. now rewrite Eq, H. -Qed. - -(** The ancestor [map2] of the current [merge] was dealing with functions - on datas only, not on keys. *) - -Definition map2 {elt elt' elt''} (f:option elt->option elt'->option elt'') - := merge (fun _ => f). - -Lemma map2_1 {elt elt' elt''}(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt'') : - In x m \/ In x m' -> - find x (map2 f m m') = f (find x m) (find x m'). -Proof. - intros. unfold map2. - now destruct (merge_spec1 (fun _ => f) H) as (y,(_,->)). -Qed. - -Lemma map2_2 {elt elt' elt''}(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt'') : - In x (map2 f m m') -> In x m \/ In x m'. -Proof. apply merge_spec2. Qed. - -Hint Immediate MapsTo_1 mem_2 is_empty_2 - map_2 mapi_2 add_3 remove_3 find_2 : map. -Hint Resolve mem_1 is_empty_1 is_empty_2 add_1 add_2 remove_1 - remove_2 find_1 fold_1 map_1 mapi_1 mapi_2 : map. - -(** ** Specifications written using equivalences *) - -Section IffSpec. -Variable elt: Type. -Implicit Type m: t elt. -Implicit Type x y z: key. -Implicit Type e: elt. - -Lemma in_iff m x y : E.eq x y -> (In x m <-> In y m). -Proof. now intros ->. Qed. - -Lemma mapsto_iff m x y e : E.eq x y -> (MapsTo x e m <-> MapsTo y e m). -Proof. now intros ->. Qed. - -Lemma mem_in_iff m x : In x m <-> mem x m = true. -Proof. symmetry. apply mem_spec. Qed. - -Lemma not_mem_in_iff m x : ~In x m <-> mem x m = false. -Proof. -rewrite mem_in_iff; destruct (mem x m); intuition. -Qed. - -Lemma mem_find m x : mem x m = true <-> find x m <> None. -Proof. - rewrite <- mem_in_iff. apply in_find. -Qed. - -Lemma not_mem_find m x : mem x m = false <-> find x m = None. -Proof. - rewrite <- not_mem_in_iff. apply not_in_find. -Qed. - -Lemma In_dec m x : { In x m } + { ~ In x m }. -Proof. - generalize (mem_in_iff m x). - destruct (mem x m); [left|right]; intuition. -Qed. - -Lemma find_mapsto_iff m x e : MapsTo x e m <-> find x m = Some e. -Proof. symmetry. apply find_spec. Qed. - -Lemma equal_iff m m' cmp : Equivb cmp m m' <-> equal cmp m m' = true. -Proof. symmetry. apply equal_spec. Qed. - -Lemma empty_mapsto_iff x e : MapsTo x e empty <-> False. -Proof. -rewrite <- find_spec, empty_spec. now split. -Qed. - -Lemma not_in_empty x : ~In x (@empty elt). -Proof. -intros (e,H). revert H. apply empty_mapsto_iff. -Qed. - -Lemma empty_in_iff x : In x (@empty elt) <-> False. -Proof. -split; [ apply not_in_empty | destruct 1 ]. -Qed. - -Lemma is_empty_iff m : Empty m <-> is_empty m = true. -Proof. split; [apply is_empty_1 | apply is_empty_2 ]. Qed. - -Lemma add_mapsto_iff m x y e e' : - MapsTo y e' (add x e m) <-> - (E.eq x y /\ e=e') \/ - (~E.eq x y /\ MapsTo y e' m). -Proof. -split. -- intros H. destruct (E.eq_dec x y); [left|right]; split; trivial. - + symmetry. apply (mapsto_fun H); auto with map. - + now apply add_3 with x e. -- destruct 1 as [(H,H')|(H,H')]; subst; auto with map. -Qed. - -Lemma add_mapsto_new m x y e e' : ~In x m -> - MapsTo y e' (add x e m) <-> (E.eq x y /\ e=e') \/ MapsTo y e' m. -Proof. - intros. - rewrite add_mapsto_iff. intuition. - right; split; trivial. contradict H. exists e'. now rewrite H. -Qed. - -Lemma in_add m x y e : In y m -> In y (add x e m). -Proof. - destruct (E.eq_dec x y) as [<-|H']. - - now rewrite !in_find, add_spec1. - - now rewrite !in_find, add_spec2. -Qed. - -Lemma add_in_iff m x y e : In y (add x e m) <-> E.eq x y \/ In y m. -Proof. -split. -- intros H. destruct (E.eq_dec x y); [now left|right]. - rewrite in_find, add_spec2 in H; trivial. now apply in_find. -- intros [<-|H]. - + exists e. now apply add_1. - + now apply in_add. -Qed. - -Lemma add_neq_mapsto_iff m x y e e' : - ~ E.eq x y -> (MapsTo y e' (add x e m) <-> MapsTo y e' m). -Proof. -split; [apply add_3|apply add_2]; auto. -Qed. - -Lemma add_neq_in_iff m x y e : - ~ E.eq x y -> (In y (add x e m) <-> In y m). -Proof. -split; intros (e',H0); exists e'. -- now apply add_3 with x e. -- now apply add_2. -Qed. - -Lemma remove_mapsto_iff m x y e : - MapsTo y e (remove x m) <-> ~E.eq x y /\ MapsTo y e m. -Proof. -split; [split|destruct 1]. -- intro E. revert H. now rewrite <-E, <- find_spec, remove_spec1. -- now apply remove_3 with x. -- now apply remove_2. -Qed. - -Lemma remove_in_iff m x y : In y (remove x m) <-> ~E.eq x y /\ In y m. -Proof. -unfold In; split; [ intros (e,H) | intros (E,(e,H)) ]. -- apply remove_mapsto_iff in H. destruct H; split; trivial. - now exists e. -- exists e. now apply remove_2. -Qed. - -Lemma remove_neq_mapsto_iff : forall m x y e, - ~ E.eq x y -> (MapsTo y e (remove x m) <-> MapsTo y e m). -Proof. -split; [apply remove_3|apply remove_2]; auto. -Qed. - -Lemma remove_neq_in_iff : forall m x y, - ~ E.eq x y -> (In y (remove x m) <-> In y m). -Proof. -split; intros (e',H0); exists e'. -- now apply remove_3 with x. -- now apply remove_2. -Qed. - -Lemma bindings_mapsto_iff m x e : - MapsTo x e m <-> InA eq_key_elt (x,e) (bindings m). -Proof. symmetry. apply bindings_spec1. Qed. - -Lemma bindings_in_iff m x : - In x m <-> exists e, InA eq_key_elt (x,e) (bindings m). -Proof. -unfold In; split; intros (e,H); exists e; now apply bindings_spec1. -Qed. - -End IffSpec. - -Lemma map_mapsto_iff {elt elt'} m x b (f : elt -> elt') : - MapsTo x b (map f m) <-> exists a, b = f a /\ MapsTo x a m. -Proof. -rewrite <-find_spec, map_spec. setoid_rewrite <- find_spec. -destruct (find x m); simpl; split. -- injection 1. now exists e. -- intros (a,(->,H)). now injection H as ->. -- discriminate. -- intros (a,(_,H)); discriminate. -Qed. - -Lemma map_in_iff {elt elt'} m x (f : elt -> elt') : - In x (map f m) <-> In x m. -Proof. -rewrite !in_find, map_spec. apply option_map_some. -Qed. - -Lemma mapi_in_iff {elt elt'} m x (f:key->elt->elt') : - In x (mapi f m) <-> In x m. -Proof. -rewrite !in_find. destruct (mapi_spec f m x) as (y,(_,->)). -apply option_map_some. -Qed. - -(** Unfortunately, we don't have simple equivalences for [mapi] - and [MapsTo]. The only correct one needs compatibility of [f]. *) - -Lemma mapi_inv {elt elt'} m x b (f : key -> elt -> elt') : - MapsTo x b (mapi f m) -> - exists a y, E.eq y x /\ b = f y a /\ MapsTo x a m. -Proof. -rewrite <- find_spec. setoid_rewrite <- find_spec. -destruct (mapi_spec f m x) as (y,(E,->)). -destruct (find x m); simpl. -- injection 1 as <-. now exists e, y. -- discriminate. -Qed. - -Lemma mapi_spec' {elt elt'} (f:key->elt->elt') : - Proper (E.eq==>Logic.eq==>Logic.eq) f -> - forall m x, - find x (mapi f m) = option_map (f x) (find x m). -Proof. - intros. destruct (mapi_spec f m x) as (y,(Hy,->)). - destruct (find x m); simpl; trivial. - now rewrite Hy. -Qed. - -Lemma mapi_1bis {elt elt'} m x e (f:key->elt->elt') : - Proper (E.eq==>Logic.eq==>Logic.eq) f -> - MapsTo x e m -> MapsTo x (f x e) (mapi f m). -Proof. -intros. destruct (mapi_1 f H0) as (y,(->,H2)). trivial. -Qed. - -Lemma mapi_mapsto_iff {elt elt'} m x b (f:key->elt->elt') : - Proper (E.eq==>Logic.eq==>Logic.eq) f -> - (MapsTo x b (mapi f m) <-> exists a, b = f x a /\ MapsTo x a m). -Proof. -rewrite <-find_spec. setoid_rewrite <-find_spec. -intros Pr. rewrite mapi_spec' by trivial. -destruct (find x m); simpl; split. -- injection 1 as <-. now exists e. -- intros (a,(->,H)). now injection H as <-. -- discriminate. -- intros (a,(_,H)). discriminate. -Qed. - -(** Things are even worse for [merge] : we don't try to state any - equivalence, see instead boolean results below. *) - -(** Useful tactic for simplifying expressions like - [In y (add x e (remove z m))] *) - -Ltac map_iff := - repeat (progress ( - rewrite add_mapsto_iff || rewrite add_in_iff || - rewrite remove_mapsto_iff || rewrite remove_in_iff || - rewrite empty_mapsto_iff || rewrite empty_in_iff || - rewrite map_mapsto_iff || rewrite map_in_iff || - rewrite mapi_in_iff)). - -(** ** Specifications written using boolean predicates *) - -Section BoolSpec. - -Lemma mem_find_b {elt}(m:t elt)(x:key) : - mem x m = if find x m then true else false. -Proof. -apply eq_bool_alt. rewrite mem_find. destruct (find x m). -- now split. -- split; (discriminate || now destruct 1). -Qed. - -Variable elt elt' elt'' : Type. -Implicit Types m : t elt. -Implicit Types x y z : key. -Implicit Types e : elt. - -Lemma mem_b m x y : E.eq x y -> mem x m = mem y m. -Proof. now intros ->. Qed. - -Lemma find_o m x y : E.eq x y -> find x m = find y m. -Proof. now intros ->. Qed. - -Lemma empty_o x : find x (@empty elt) = None. -Proof. apply empty_spec. Qed. - -Lemma empty_a x : mem x (@empty elt) = false. -Proof. apply not_mem_find. apply empty_spec. Qed. - -Lemma add_eq_o m x y e : - E.eq x y -> find y (add x e m) = Some e. -Proof. - intros <-. apply add_spec1. -Qed. - -Lemma add_neq_o m x y e : - ~ E.eq x y -> find y (add x e m) = find y m. -Proof. apply add_spec2. Qed. -Hint Resolve add_neq_o : map. - -Lemma add_o m x y e : - find y (add x e m) = if E.eq_dec x y then Some e else find y m. -Proof. -destruct (E.eq_dec x y); auto with map. -Qed. - -Lemma add_eq_b m x y e : - E.eq x y -> mem y (add x e m) = true. -Proof. -intros <-. apply mem_spec, add_in_iff. now left. -Qed. - -Lemma add_neq_b m x y e : - ~E.eq x y -> mem y (add x e m) = mem y m. -Proof. -intros. now rewrite !mem_find_b, add_neq_o. -Qed. - -Lemma add_b m x y e : - mem y (add x e m) = eqb x y || mem y m. -Proof. -rewrite !mem_find_b, add_o. unfold eqb. -now destruct (E.eq_dec x y). -Qed. - -Lemma remove_eq_o m x y : - E.eq x y -> find y (remove x m) = None. -Proof. intros ->. apply remove_spec1. Qed. - -Lemma remove_neq_o m x y : - ~ E.eq x y -> find y (remove x m) = find y m. -Proof. apply remove_spec2. Qed. - -Hint Resolve remove_eq_o remove_neq_o : map. - -Lemma remove_o m x y : - find y (remove x m) = if E.eq_dec x y then None else find y m. -Proof. -destruct (E.eq_dec x y); auto with map. -Qed. - -Lemma remove_eq_b m x y : - E.eq x y -> mem y (remove x m) = false. -Proof. -intros <-. now rewrite mem_find_b, remove_eq_o. -Qed. - -Lemma remove_neq_b m x y : - ~ E.eq x y -> mem y (remove x m) = mem y m. -Proof. -intros. now rewrite !mem_find_b, remove_neq_o. -Qed. - -Lemma remove_b m x y : - mem y (remove x m) = negb (eqb x y) && mem y m. -Proof. -rewrite !mem_find_b, remove_o; unfold eqb. -now destruct (E.eq_dec x y). -Qed. - -Lemma map_o m x (f:elt->elt') : - find x (map f m) = option_map f (find x m). -Proof. apply map_spec. Qed. - -Lemma map_b m x (f:elt->elt') : - mem x (map f m) = mem x m. -Proof. -rewrite !mem_find_b, map_o. now destruct (find x m). -Qed. - -Lemma mapi_b m x (f:key->elt->elt') : - mem x (mapi f m) = mem x m. -Proof. -apply eq_bool_alt; rewrite !mem_spec. apply mapi_in_iff. -Qed. - -Lemma mapi_o m x (f:key->elt->elt') : - Proper (E.eq==>Logic.eq==>Logic.eq) f -> - find x (mapi f m) = option_map (f x) (find x m). -Proof. intros; now apply mapi_spec'. Qed. - -Lemma merge_spec1' (f:key->option elt->option elt'->option elt'') : - Proper (E.eq==>Logic.eq==>Logic.eq==>Logic.eq) f -> - forall (m:t elt)(m':t elt') x, - In x m \/ In x m' -> - find x (merge f m m') = f x (find x m) (find x m'). -Proof. - intros Hf m m' x H. - now destruct (merge_spec1 f H) as (y,(->,->)). -Qed. - -Lemma merge_spec1_none (f:key->option elt->option elt'->option elt'') : - (forall x, f x None None = None) -> - forall (m: t elt)(m': t elt') x, - exists y, E.eq y x /\ find x (merge f m m') = f y (find x m) (find x m'). -Proof. -intros Hf m m' x. -destruct (find x m) as [e|] eqn:Hm. -- assert (H : In x m \/ In x m') by (left; exists e; now apply find_spec). - destruct (merge_spec1 f H) as (y,(Hy,->)). - exists y; split; trivial. now rewrite Hm. -- destruct (find x m') as [e|] eqn:Hm'. - + assert (H : In x m \/ In x m') by (right; exists e; now apply find_spec). - destruct (merge_spec1 f H) as (y,(Hy,->)). - exists y; split; trivial. now rewrite Hm, Hm'. - + exists x. split. reflexivity. rewrite Hf. - apply not_in_find. intro H. - apply merge_spec2 in H. apply not_in_find in Hm. apply not_in_find in Hm'. - intuition. -Qed. - -Lemma merge_spec1'_none (f:key->option elt->option elt'->option elt'') : - Proper (E.eq==>Logic.eq==>Logic.eq==>Logic.eq) f -> - (forall x, f x None None = None) -> - forall (m: t elt)(m': t elt') x, - find x (merge f m m') = f x (find x m) (find x m'). -Proof. - intros Hf Hf' m m' x. - now destruct (merge_spec1_none Hf' m m' x) as (y,(->,->)). -Qed. - -Lemma bindings_o : forall m x, - find x m = findA (eqb x) (bindings m). -Proof. -intros. rewrite eq_option_alt. intro e. -rewrite <- find_mapsto_iff, bindings_mapsto_iff. -unfold eqb. -rewrite <- findA_NoDupA; dintuition; try apply bindings_3w; eauto. -Qed. - -Lemma bindings_b : forall m x, - mem x m = existsb (fun p => eqb x (fst p)) (bindings m). -Proof. -intros. -apply eq_bool_alt. -rewrite mem_spec, bindings_in_iff, existsb_exists. -split. -- intros (e,H). - rewrite InA_alt in H. - destruct H as ((k,e'),((H1,H2),H')); simpl in *; subst e'. - exists (k, e); split; trivial. simpl. now apply eqb_eq. -- intros ((k,e),(H,H')); simpl in *. apply eqb_eq in H'. - exists e. rewrite InA_alt. exists (k,e). now repeat split. -Qed. - -End BoolSpec. - -Section Equalities. -Variable elt:Type. - -(** A few basic equalities *) - -Lemma eq_empty (m: t elt) : m == empty <-> is_empty m = true. -Proof. - unfold Equal. rewrite is_empty_spec. now setoid_rewrite empty_spec. -Qed. - -Lemma add_id (m: t elt) x e : add x e m == m <-> find x m = Some e. -Proof. - split. - - intros H. rewrite <- (H x). apply add_spec1. - - intros H y. rewrite !add_o. now destruct E.eq_dec as [<-|E]. -Qed. - -Lemma add_add_1 (m: t elt) x e : - add x e (add x e m) == add x e m. -Proof. - intros y. rewrite !add_o. destruct E.eq_dec; auto. -Qed. - -Lemma add_add_2 (m: t elt) x x' e e' : - ~E.eq x x' -> add x e (add x' e' m) == add x' e' (add x e m). -Proof. - intros H y. rewrite !add_o. - do 2 destruct E.eq_dec; auto. - elim H. now transitivity y. -Qed. - -Lemma remove_id (m: t elt) x : remove x m == m <-> ~In x m. -Proof. - rewrite not_in_find. split. - - intros H. rewrite <- (H x). apply remove_spec1. - - intros H y. rewrite !remove_o. now destruct E.eq_dec as [<-|E]. -Qed. - -Lemma remove_remove_1 (m: t elt) x : - remove x (remove x m) == remove x m. -Proof. - intros y. rewrite !remove_o. destruct E.eq_dec; auto. -Qed. - -Lemma remove_remove_2 (m: t elt) x x' : - remove x (remove x' m) == remove x' (remove x m). -Proof. - intros y. rewrite !remove_o. do 2 destruct E.eq_dec; auto. -Qed. - -Lemma remove_add_1 (m: t elt) x e : - remove x (add x e m) == remove x m. -Proof. - intro y. rewrite !remove_o, !add_o. now destruct E.eq_dec. -Qed. - -Lemma remove_add_2 (m: t elt) x x' e : - ~E.eq x x' -> remove x' (add x e m) == add x e (remove x' m). -Proof. - intros H y. rewrite !remove_o, !add_o. - do 2 destruct E.eq_dec; auto. - - elim H; now transitivity y. - - symmetry. now apply remove_eq_o. - - symmetry. now apply remove_neq_o. -Qed. - -Lemma add_remove_1 (m: t elt) x e : - add x e (remove x m) == add x e m. -Proof. - intro y. rewrite !add_o, !remove_o. now destruct E.eq_dec. -Qed. - -(** Another characterisation of [Equal] *) - -Lemma Equal_mapsto_iff : forall m1 m2 : t elt, - m1 == m2 <-> (forall k e, MapsTo k e m1 <-> MapsTo k e m2). -Proof. -intros m1 m2. split; [intros Heq k e|intros Hiff]. -rewrite 2 find_mapsto_iff, Heq. split; auto. -intro k. rewrite eq_option_alt. intro e. -rewrite <- 2 find_mapsto_iff; auto. -Qed. - -(** * Relations between [Equal], [Equiv] and [Equivb]. *) - -(** First, [Equal] is [Equiv] with Leibniz on elements. *) - -Lemma Equal_Equiv : forall (m m' : t elt), - m == m' <-> Equiv Logic.eq m m'. -Proof. -intros. rewrite Equal_mapsto_iff. split; intros. -- split. - + split; intros (e,Hin); exists e; [rewrite <- H|rewrite H]; auto. - + intros; apply mapsto_fun with m k; auto; rewrite H; auto. -- split; intros H'. - + destruct H. - assert (Hin : In k m') by (rewrite <- H; exists e; auto). - destruct Hin as (e',He'). - rewrite (H0 k e e'); auto. - + destruct H. - assert (Hin : In k m) by (rewrite H; exists e; auto). - destruct Hin as (e',He'). - rewrite <- (H0 k e' e); auto. -Qed. - -(** [Equivb] and [Equiv] and equivalent when [eq_elt] and [cmp] - are related. *) - -Section Cmp. -Variable eq_elt : elt->elt->Prop. -Variable cmp : elt->elt->bool. - -Definition compat_cmp := - forall e e', cmp e e' = true <-> eq_elt e e'. - -Lemma Equiv_Equivb : compat_cmp -> - forall m m', Equiv eq_elt m m' <-> Equivb cmp m m'. -Proof. - unfold Equivb, Equiv, Cmp; intuition. - red in H; rewrite H; eauto. - red in H; rewrite <-H; eauto. -Qed. -End Cmp. - -(** Composition of the two last results: relation between [Equal] - and [Equivb]. *) - -Lemma Equal_Equivb : forall cmp, - (forall e e', cmp e e' = true <-> e = e') -> - forall (m m':t elt), m == m' <-> Equivb cmp m m'. -Proof. - intros; rewrite Equal_Equiv. - apply Equiv_Equivb; auto. -Qed. - -Lemma Equal_Equivb_eqdec : - forall eq_elt_dec : (forall e e', { e = e' } + { e <> e' }), - let cmp := fun e e' => if eq_elt_dec e e' then true else false in - forall (m m':t elt), m == m' <-> Equivb cmp m m'. -Proof. -intros; apply Equal_Equivb. -unfold cmp; clear cmp; intros. -destruct eq_elt_dec; now intuition. -Qed. - -End Equalities. - -(** * Results about [fold], [bindings], induction principles... *) - -Section Elt. - Variable elt:Type. - - Definition Add x (e:elt) m m' := m' == (add x e m). - - Notation eqke := (@eq_key_elt elt). - Notation eqk := (@eq_key elt). - - Instance eqk_equiv : Equivalence eqk. - Proof. unfold eq_key. destruct E.eq_equiv. constructor; eauto. Qed. - - Instance eqke_equiv : Equivalence eqke. - Proof. - unfold eq_key_elt; split; repeat red; intuition; simpl in *; - etransitivity; eauto. - Qed. - - (** Complements about InA, NoDupA and findA *) - - Lemma InA_eqke_eqk k k' e e' l : - E.eq k k' -> InA eqke (k,e) l -> InA eqk (k',e') l. - Proof. - intros Hk. rewrite 2 InA_alt. - intros ((k'',e'') & (Hk'',He'') & H); simpl in *; subst e''. - exists (k'',e); split; auto. red; simpl. now transitivity k. - Qed. - - Lemma NoDupA_incl {A} (R R':relation A) : - (forall x y, R x y -> R' x y) -> - forall l, NoDupA R' l -> NoDupA R l. - Proof. - intros Incl. - induction 1 as [ | a l E _ IH ]; constructor; auto. - contradict E. revert E. rewrite 2 InA_alt. firstorder. - Qed. - - Lemma NoDupA_eqk_eqke l : NoDupA eqk l -> NoDupA eqke l. - Proof. - apply NoDupA_incl. now destruct 1. - Qed. - - Lemma findA_rev l k : NoDupA eqk l -> - findA (eqb k) l = findA (eqb k) (rev l). - Proof. - intros H. apply eq_option_alt. intros e. unfold eqb. - rewrite <- !findA_NoDupA, InA_rev; eauto with map. reflexivity. - change (NoDupA eqk (rev l)). apply NoDupA_rev; auto using eqk_equiv. - Qed. - - (** * Bindings *) - - Lemma bindings_Empty (m:t elt) : Empty m <-> bindings m = nil. - Proof. - unfold Empty. split; intros H. - - assert (H' : forall a, ~ List.In a (bindings m)). - { intros (k,e) H'. apply (H k e). - rewrite bindings_mapsto_iff, InA_alt. - exists (k,e); repeat split; auto with map. } - destruct (bindings m) as [|p l]; trivial. - destruct (H' p); simpl; auto. - - intros x e. rewrite bindings_mapsto_iff, InA_alt. - rewrite H. now intros (y,(E,H')). - Qed. - - Lemma bindings_empty : bindings (@empty elt) = nil. - Proof. - rewrite <-bindings_Empty; apply empty_1. - Qed. - - (** * Conversions between maps and association lists. *) - - Definition uncurry {U V W : Type} (f : U -> V -> W) : U*V -> W := - fun p => f (fst p) (snd p). - - Definition of_list := - List.fold_right (uncurry (@add _)) (@empty elt). - - Definition to_list := bindings. - - Lemma of_list_1 : forall l k e, - NoDupA eqk l -> - (MapsTo k e (of_list l) <-> InA eqke (k,e) l). - Proof. - induction l as [|(k',e') l IH]; simpl; intros k e Hnodup. - - rewrite empty_mapsto_iff, InA_nil; intuition. - - unfold uncurry; simpl. - inversion_clear Hnodup as [| ? ? Hnotin Hnodup']. - specialize (IH k e Hnodup'); clear Hnodup'. - rewrite add_mapsto_iff, InA_cons, <- IH. - unfold eq_key_elt at 1; simpl. - split; destruct 1 as [H|H]; try (intuition;fail). - destruct (E.eq_dec k k'); [left|right]; split; auto with map. - contradict Hnotin. - apply InA_eqke_eqk with k e; intuition. - Qed. - - Lemma of_list_1b : forall l k, - NoDupA eqk l -> - find k (of_list l) = findA (eqb k) l. - Proof. - induction l as [|(k',e') l IH]; simpl; intros k Hnodup. - apply empty_o. - unfold uncurry; simpl. - inversion_clear Hnodup as [| ? ? Hnotin Hnodup']. - specialize (IH k Hnodup'); clear Hnodup'. - rewrite add_o, IH, eqb_sym. unfold eqb; now destruct E.eq_dec. - Qed. - - Lemma of_list_2 : forall l, NoDupA eqk l -> - equivlistA eqke l (to_list (of_list l)). - Proof. - intros l Hnodup (k,e). - rewrite <- bindings_mapsto_iff, of_list_1; intuition. - Qed. - - Lemma of_list_3 : forall s, Equal (of_list (to_list s)) s. - Proof. - intros s k. - rewrite of_list_1b, bindings_o; auto. - apply bindings_3w. - Qed. - - (** * Fold *) - - (** Alternative specification via [fold_right] *) - - Lemma fold_spec_right m (A:Type)(i:A)(f : key -> elt -> A -> A) : - fold f m i = List.fold_right (uncurry f) i (rev (bindings m)). - Proof. - rewrite fold_1. symmetry. apply fold_left_rev_right. - Qed. - - (** ** Induction principles about fold contributed by S. Lescuyer *) - - (** In the following lemma, the step hypothesis is deliberately restricted - to the precise map m we are considering. *) - - Lemma fold_rec : - forall (A:Type)(P : t elt -> A -> Type)(f : key -> elt -> A -> A), - forall (i:A)(m:t elt), - (forall m, Empty m -> P m i) -> - (forall k e a m' m'', MapsTo k e m -> ~In k m' -> - Add k e m' m'' -> P m' a -> P m'' (f k e a)) -> - P m (fold f m i). - Proof. - intros A P f i m Hempty Hstep. - rewrite fold_spec_right. - set (F:=uncurry f). - set (l:=rev (bindings m)). - assert (Hstep' : forall k e a m' m'', InA eqke (k,e) l -> ~In k m' -> - Add k e m' m'' -> P m' a -> P m'' (F (k,e) a)). - { - intros k e a m' m'' H ? ? ?; eapply Hstep; eauto. - revert H; unfold l; rewrite InA_rev, bindings_mapsto_iff; auto with *. } - assert (Hdup : NoDupA eqk l). - { unfold l. apply NoDupA_rev; try red; unfold eq_key ; eauto with *. - apply bindings_3w. } - assert (Hsame : forall k, find k m = findA (eqb k) l). - { intros k. unfold l. rewrite bindings_o, findA_rev; auto. - apply bindings_3w. } - clearbody l. clearbody F. clear Hstep f. revert m Hsame. induction l. - - (* empty *) - intros m Hsame; simpl. - apply Hempty. intros k e. - rewrite find_mapsto_iff, Hsame; simpl; discriminate. - - (* step *) - intros m Hsame; destruct a as (k,e); simpl. - apply Hstep' with (of_list l); auto. - + rewrite InA_cons; left; red; auto with map. - + inversion_clear Hdup. contradict H. destruct H as (e',He'). - apply InA_eqke_eqk with k e'; auto with map. - rewrite <- of_list_1; auto. - + intro k'. rewrite Hsame, add_o, of_list_1b. simpl. - rewrite eqb_sym. unfold eqb. now destruct E.eq_dec. - inversion_clear Hdup; auto with map. - + apply IHl. - * intros; eapply Hstep'; eauto. - * inversion_clear Hdup; auto. - * intros; apply of_list_1b. inversion_clear Hdup; auto. - Qed. - - (** Same, with [empty] and [add] instead of [Empty] and [Add]. In this - case, [P] must be compatible with equality of sets *) - - Theorem fold_rec_bis : - forall (A:Type)(P : t elt -> A -> Type)(f : key -> elt -> A -> A), - forall (i:A)(m:t elt), - (forall m m' a, Equal m m' -> P m a -> P m' a) -> - (P empty i) -> - (forall k e a m', MapsTo k e m -> ~In k m' -> - P m' a -> P (add k e m') (f k e a)) -> - P m (fold f m i). - Proof. - intros A P f i m Pmorphism Pempty Pstep. - apply fold_rec; intros. - apply Pmorphism with empty; auto. intro k. rewrite empty_o. - case_eq (find k m0); auto; intros e'; rewrite <- find_mapsto_iff. - intro H'; elim (H k e'); auto. - apply Pmorphism with (add k e m'); try intro; auto. - Qed. - - Lemma fold_rec_nodep : - forall (A:Type)(P : A -> Type)(f : key -> elt -> A -> A)(i:A)(m:t elt), - P i -> (forall k e a, MapsTo k e m -> P a -> P (f k e a)) -> - P (fold f m i). - Proof. - intros; apply fold_rec_bis with (P:=fun _ => P); auto. - Qed. - - (** [fold_rec_weak] is a weaker principle than [fold_rec_bis] : - the step hypothesis must here be applicable anywhere. - At the same time, it looks more like an induction principle, - and hence can be easier to use. *) - - Lemma fold_rec_weak : - forall (A:Type)(P : t elt -> A -> Type)(f : key -> elt -> A -> A)(i:A), - (forall m m' a, Equal m m' -> P m a -> P m' a) -> - P empty i -> - (forall k e a m, ~In k m -> P m a -> P (add k e m) (f k e a)) -> - forall m, P m (fold f m i). - Proof. - intros; apply fold_rec_bis; auto. - Qed. - - Lemma fold_rel : - forall (A B:Type)(R : A -> B -> Type) - (f : key -> elt -> A -> A)(g : key -> elt -> B -> B)(i : A)(j : B) - (m : t elt), - R i j -> - (forall k e a b, MapsTo k e m -> R a b -> R (f k e a) (g k e b)) -> - R (fold f m i) (fold g m j). - Proof. - intros A B R f g i j m Rempty Rstep. - rewrite 2 fold_spec_right. set (l:=rev (bindings m)). - assert (Rstep' : forall k e a b, InA eqke (k,e) l -> - R a b -> R (f k e a) (g k e b)). - { intros; apply Rstep; auto. - rewrite bindings_mapsto_iff, <- InA_rev; auto with map. } - clearbody l; clear Rstep m. - induction l; simpl; auto. - apply Rstep'; auto. - destruct a; simpl; rewrite InA_cons; left; red; auto with map. - Qed. - - (** From the induction principle on [fold], we can deduce some general - induction principles on maps. *) - - Lemma map_induction : - forall P : t elt -> Type, - (forall m, Empty m -> P m) -> - (forall m m', P m -> forall x e, ~In x m -> Add x e m m' -> P m') -> - forall m, P m. - Proof. - intros. apply (@fold_rec _ (fun s _ => P s) (fun _ _ _ => tt) tt m); eauto. - Qed. - - Lemma map_induction_bis : - forall P : t elt -> Type, - (forall m m', Equal m m' -> P m -> P m') -> - P empty -> - (forall x e m, ~In x m -> P m -> P (add x e m)) -> - forall m, P m. - Proof. - intros. - apply (@fold_rec_bis _ (fun s _ => P s) (fun _ _ _ => tt) tt m); eauto. - Qed. - - (** [fold] can be used to reconstruct the same initial set. *) - - Lemma fold_identity : forall m : t elt, Equal (fold (@add _) m empty) m. - Proof. - intros. - apply fold_rec with (P:=fun m acc => Equal acc m); auto with map. - intros m' Heq k'. - rewrite empty_o. - case_eq (find k' m'); auto; intros e'; rewrite <- find_mapsto_iff. - intro; elim (Heq k' e'); auto. - intros k e a m' m'' _ _ Hadd Heq k'. - red in Heq. rewrite Hadd, 2 add_o, Heq; auto. - Qed. - - Section Fold_More. - - (** ** Additional properties of fold *) - - (** When a function [f] is compatible and allows transpositions, we can - compute [fold f] in any order. *) - - Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). - - Lemma fold_Empty (f:key->elt->A->A) : - forall m i, Empty m -> eqA (fold f m i) i. - Proof. - intros. apply fold_rec_nodep with (P:=fun a => eqA a i). - reflexivity. - intros. elim (H k e); auto. - Qed. - - Lemma fold_init (f:key->elt->A->A) : - Proper (E.eq==>eq==>eqA==>eqA) f -> - forall m i i', eqA i i' -> eqA (fold f m i) (fold f m i'). - Proof. - intros Hf m i i' Hi. apply fold_rel with (R:=eqA); auto. - intros. now apply Hf. - Qed. - - (** Transpositions of f (a.k.a diamond property). - Could we swap two sequential calls to f, i.e. do we have: - - f k e (f k' e' a) == f k' e' (f k e a) - - First, we do no need this equation for all keys, but only - when k and k' aren't equal, as suggested by Pierre Castéran. - Think for instance of [f] being [M.add] : in general, we don't have - [M.add k e (M.add k e' m) == M.add k e' (M.add k e m)]. - Fortunately, we will never encounter this situation during a real - [fold], since the keys received by this [fold] are unique. - NB: without this condition, this condition would be - [SetoidList.transpose2]. - - Secondly, instead of the equation above, we now use a statement - with more basic equalities, allowing to prove [fold_commutes] even - when [f] isn't a morphism. - NB: When [f] is a morphism, [Diamond f] gives back the equation above. -*) - - Definition Diamond (f:key->elt->A->A) := - forall k k' e e' a b b', ~E.eq k k' -> - eqA (f k e a) b -> eqA (f k' e' a) b' -> eqA (f k e b') (f k' e' b). - - Lemma fold_commutes (f:key->elt->A->A) : - Diamond f -> - forall i m k e, ~In k m -> - eqA (fold f m (f k e i)) (f k e (fold f m i)). - Proof. - intros Hf i m k e H. - apply fold_rel with (R:= fun a b => eqA a (f k e b)); auto. - - reflexivity. - - intros k' e' b a Hm E. - apply Hf with a; try easy. - contradict H; rewrite <- H. now exists e'. - Qed. - - Hint Resolve NoDupA_eqk_eqke NoDupA_rev bindings_3w : map. - - Lemma fold_Proper (f:key->elt->A->A) : - Proper (E.eq==>eq==>eqA==>eqA) f -> - Diamond f -> - Proper (Equal==>eqA==>eqA) (fold f). - Proof. - intros Hf Hf' m1 m2 Hm i j Hi. - rewrite 2 fold_spec_right. - assert (NoDupA eqk (rev (bindings m1))) by (auto with * ). - assert (NoDupA eqk (rev (bindings m2))) by (auto with * ). - apply fold_right_equivlistA_restr2 with (R:=complement eqk)(eqA:=eqke) - ; auto with *. - - intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; simpl in *. now apply Hf. - - unfold complement, eq_key, eq_key_elt; repeat red. intuition eauto with map. - - intros (k,e) (k',e') z z' h h'; unfold eq_key, uncurry;simpl; auto. - rewrite h'. eapply Hf'; now eauto. - - rewrite <- NoDupA_altdef; auto. - - intros (k,e). - rewrite 2 InA_rev, <- 2 bindings_mapsto_iff, 2 find_mapsto_iff, Hm; - auto with *. - Qed. - - Lemma fold_Equal (f:key->elt->A->A) : - Proper (E.eq==>eq==>eqA==>eqA) f -> - Diamond f -> - forall m1 m2 i, - Equal m1 m2 -> - eqA (fold f m1 i) (fold f m2 i). - Proof. - intros. now apply fold_Proper. - Qed. - - Lemma fold_Add (f:key->elt->A->A) : - Proper (E.eq==>eq==>eqA==>eqA) f -> - Diamond f -> - forall m1 m2 k e i, ~In k m1 -> Add k e m1 m2 -> - eqA (fold f m2 i) (f k e (fold f m1 i)). - Proof. - intros Hf Hf' m1 m2 k e i Hm1 Hm2. - rewrite 2 fold_spec_right. - set (f':=uncurry f). - change (f k e (fold_right f' i (rev (bindings m1)))) - with (f' (k,e) (fold_right f' i (rev (bindings m1)))). - assert (NoDupA eqk (rev (bindings m1))) by (auto with * ). - assert (NoDupA eqk (rev (bindings m2))) by (auto with * ). - apply fold_right_add_restr with - (R:=complement eqk)(eqA:=eqke); auto with *. - - intros (k1,e1) (k2,e2) (Hk,He) a a' Ha; unfold f'; simpl in *. now apply Hf. - - unfold complement, eq_key_elt, eq_key; repeat red; intuition eauto with map. - - intros (k1,e1) (k2,e2) z1 z2; unfold eq_key, f', uncurry; simpl. - eapply Hf'; now eauto. - - rewrite <- NoDupA_altdef; auto. - - rewrite InA_rev, <- bindings_mapsto_iff by (auto with * ). firstorder. - - intros (a,b). - rewrite InA_cons, 2 InA_rev, <- 2 bindings_mapsto_iff, - 2 find_mapsto_iff by (auto with * ). - unfold eq_key_elt; simpl. - rewrite Hm2, !find_spec, add_mapsto_new; intuition. - Qed. - - Lemma fold_add (f:key->elt->A->A) : - Proper (E.eq==>eq==>eqA==>eqA) f -> - Diamond f -> - forall m k e i, ~In k m -> - eqA (fold f (add k e m) i) (f k e (fold f m i)). - Proof. - intros. now apply fold_Add. - Qed. - - End Fold_More. - - (** * Cardinal *) - - Lemma cardinal_fold (m : t elt) : - cardinal m = fold (fun _ _ => S) m 0. - Proof. - rewrite cardinal_1, fold_1. - symmetry; apply fold_left_length; auto. - Qed. - - Lemma cardinal_Empty : forall m : t elt, - Empty m <-> cardinal m = 0. - Proof. - intros. - rewrite cardinal_1, bindings_Empty. - destruct (bindings m); intuition; discriminate. - Qed. - - Lemma Equal_cardinal (m m' : t elt) : - Equal m m' -> cardinal m = cardinal m'. - Proof. - intro. rewrite 2 cardinal_fold. - apply fold_Equal with (eqA:=eq); try congruence; auto with map. - Qed. - - Lemma cardinal_0 (m : t elt) : Empty m -> cardinal m = 0. - Proof. - intros; rewrite <- cardinal_Empty; auto. - Qed. - - Lemma cardinal_S m m' x e : - ~ In x m -> Add x e m m' -> cardinal m' = S (cardinal m). - Proof. - intros. rewrite 2 cardinal_fold. - change S with ((fun _ _ => S) x e). - apply fold_Add with (eqA:=eq); try congruence; auto with map. - Qed. - - Lemma cardinal_inv_1 : forall m : t elt, - cardinal m = 0 -> Empty m. - Proof. - intros; rewrite cardinal_Empty; auto. - Qed. - Hint Resolve cardinal_inv_1 : map. - - Lemma cardinal_inv_2 : - forall m n, cardinal m = S n -> { p : key*elt | MapsTo (fst p) (snd p) m }. - Proof. - intros; rewrite M.cardinal_spec in *. - generalize (bindings_mapsto_iff m). - destruct (bindings m); try discriminate. - exists p; auto. - rewrite H0; destruct p; simpl; auto. - constructor; red; auto with map. - Qed. - - Lemma cardinal_inv_2b : - forall m, cardinal m <> 0 -> { p : key*elt | MapsTo (fst p) (snd p) m }. - Proof. - intros. - generalize (@cardinal_inv_2 m); destruct cardinal. - elim H;auto. - eauto. - Qed. - - Lemma not_empty_mapsto (m : t elt) : - ~Empty m -> exists k e, MapsTo k e m. - Proof. - intro. - destruct (@cardinal_inv_2b m) as ((k,e),H'). - contradict H. now apply cardinal_inv_1. - exists k; now exists e. - Qed. - - Lemma not_empty_in (m:t elt) : - ~Empty m -> exists k, In k m. - Proof. - intro. destruct (not_empty_mapsto H) as (k,Hk). - now exists k. - Qed. - - (** * Additional notions over maps *) - - Definition Disjoint (m m' : t elt) := - forall k, ~(In k m /\ In k m'). - - Definition Partition (m m1 m2 : t elt) := - Disjoint m1 m2 /\ - (forall k e, MapsTo k e m <-> MapsTo k e m1 \/ MapsTo k e m2). - - (** * Emulation of some functions lacking in the interface *) - - Definition filter (f : key -> elt -> bool)(m : t elt) := - fold (fun k e m => if f k e then add k e m else m) m empty. - - Definition for_all (f : key -> elt -> bool)(m : t elt) := - fold (fun k e b => if f k e then b else false) m true. - - Definition exists_ (f : key -> elt -> bool)(m : t elt) := - fold (fun k e b => if f k e then true else b) m false. - - Definition partition (f : key -> elt -> bool)(m : t elt) := - (filter f m, filter (fun k e => negb (f k e)) m). - - (** [update] adds to [m1] all the bindings of [m2]. It can be seen as - an [union] operator which gives priority to its 2nd argument - in case of binding conflit. *) - - Definition update (m1 m2 : t elt) := fold (@add _) m2 m1. - - (** [restrict] keeps from [m1] only the bindings whose key is in [m2]. - It can be seen as an [inter] operator, with priority to its 1st argument - in case of binding conflit. *) - - Definition restrict (m1 m2 : t elt) := filter (fun k _ => mem k m2) m1. - - (** [diff] erases from [m1] all bindings whose key is in [m2]. *) - - Definition diff (m1 m2 : t elt) := filter (fun k _ => negb (mem k m2)) m1. - - (** Properties of these abbreviations *) - - Lemma filter_iff (f : key -> elt -> bool) : - Proper (E.eq==>eq==>eq) f -> - forall m k e, - MapsTo k e (filter f m) <-> MapsTo k e m /\ f k e = true. - Proof. - unfold filter. - set (f':=fun k e m => if f k e then add k e m else m). - intros Hf m. pattern m, (fold f' m empty). apply fold_rec. - - - intros m' Hm' k e. rewrite empty_mapsto_iff. intuition. - elim (Hm' k e); auto. - - - intros k e acc m1 m2 Hke Hn Hadd IH k' e'. - change (Equal m2 (add k e m1)) in Hadd; rewrite Hadd. - unfold f'; simpl. - rewrite add_mapsto_new by trivial. - case_eq (f k e); intros Hfke; simpl; - rewrite ?add_mapsto_iff, IH; clear IH; intuition. - + rewrite <- Hfke; apply Hf; auto with map. - + right. repeat split; trivial. contradict Hn. rewrite Hn. now exists e'. - + assert (f k e = f k' e') by (apply Hf; auto). congruence. - Qed. - - Lemma for_all_filter f m : - for_all f m = is_empty (filter (fun k e => negb (f k e)) m). - Proof. - unfold for_all, filter. - eapply fold_rel with (R:=fun x y => x = is_empty y). - - symmetry. apply is_empty_iff. apply empty_1. - - intros; subst. destruct (f k e); simpl; trivial. - symmetry. apply not_true_is_false. rewrite is_empty_spec. - intros H'. specialize (H' k). now rewrite add_spec1 in H'. - Qed. - - Lemma exists_filter f m : - exists_ f m = negb (is_empty (filter f m)). - Proof. - unfold for_all, filter. - eapply fold_rel with (R:=fun x y => x = negb (is_empty y)). - - symmetry. rewrite negb_false_iff. apply is_empty_iff. apply empty_1. - - intros; subst. destruct (f k e); simpl; trivial. - symmetry. rewrite negb_true_iff. apply not_true_is_false. - rewrite is_empty_spec. - intros H'. specialize (H' k). now rewrite add_spec1 in H'. - Qed. - - Lemma for_all_iff f m : - Proper (E.eq==>eq==>eq) f -> - (for_all f m = true <-> (forall k e, MapsTo k e m -> f k e = true)). - Proof. - intros Hf. - rewrite for_all_filter. - rewrite <- is_empty_iff. unfold Empty. - split; intros H k e; specialize (H k e); - rewrite filter_iff in * by solve_proper; intuition. - - destruct (f k e); auto. - - now rewrite H0 in H2. - Qed. - - Lemma exists_iff f m : - Proper (E.eq==>eq==>eq) f -> - (exists_ f m = true <-> - (exists k e, MapsTo k e m /\ f k e = true)). - Proof. - intros Hf. - rewrite exists_filter. rewrite negb_true_iff. - rewrite <- not_true_iff_false, <- is_empty_iff. - split. - - intros H. apply not_empty_mapsto in H. now setoid_rewrite filter_iff in H. - - unfold Empty. setoid_rewrite filter_iff; trivial. firstorder. - Qed. - - Lemma Disjoint_alt : forall m m', - Disjoint m m' <-> - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> False). - Proof. - unfold Disjoint; split. - intros H k v v' H1 H2. - apply H with k; split. - exists v; trivial. - exists v'; trivial. - intros H k ((v,Hv),(v',Hv')). - eapply H; eauto. - Qed. - - Section Partition. - Variable f : key -> elt -> bool. - Hypothesis Hf : Proper (E.eq==>eq==>eq) f. - - Lemma partition_iff_1 : forall m m1 k e, - m1 = fst (partition f m) -> - (MapsTo k e m1 <-> MapsTo k e m /\ f k e = true). - Proof. - unfold partition; simpl; intros. subst m1. - apply filter_iff; auto. - Qed. - - Lemma partition_iff_2 : forall m m2 k e, - m2 = snd (partition f m) -> - (MapsTo k e m2 <-> MapsTo k e m /\ f k e = false). - Proof. - unfold partition; simpl; intros. subst m2. - rewrite filter_iff. - split; intros (H,H'); split; auto. - destruct (f k e); simpl in *; auto. - rewrite H'; auto. - repeat red; intros. f_equal. apply Hf; auto. - Qed. - - Lemma partition_Partition : forall m m1 m2, - partition f m = (m1,m2) -> Partition m m1 m2. - Proof. - intros. split. - rewrite Disjoint_alt. intros k e e'. - rewrite (@partition_iff_1 m m1), (@partition_iff_2 m m2) - by (rewrite H; auto). - intros (U,V) (W,Z). rewrite <- (mapsto_fun U W) in Z; congruence. - intros k e. - rewrite (@partition_iff_1 m m1), (@partition_iff_2 m m2) - by (rewrite H; auto). - destruct (f k e); intuition. - Qed. - - End Partition. - - Lemma Partition_In : forall m m1 m2 k, - Partition m m1 m2 -> In k m -> {In k m1}+{In k m2}. - Proof. - intros m m1 m2 k Hm Hk. - destruct (In_dec m1 k) as [H|H]; [left|right]; auto. - destruct Hm as (Hm,Hm'). - destruct Hk as (e,He); rewrite Hm' in He; destruct He. - elim H; exists e; auto. - exists e; auto. - Defined. - - Lemma Disjoint_sym : forall m1 m2, Disjoint m1 m2 -> Disjoint m2 m1. - Proof. - intros m1 m2 H k (H1,H2). elim (H k); auto. - Qed. - - Lemma Partition_sym : forall m m1 m2, - Partition m m1 m2 -> Partition m m2 m1. - Proof. - intros m m1 m2 (H,H'); split. - apply Disjoint_sym; auto. - intros; rewrite H'; intuition. - Qed. - - Lemma Partition_Empty : forall m m1 m2, Partition m m1 m2 -> - (Empty m <-> (Empty m1 /\ Empty m2)). - Proof. - intros m m1 m2 (Hdisj,Heq). split. - intro He. - split; intros k e Hke; elim (He k e); rewrite Heq; auto. - intros (He1,He2) k e Hke. rewrite Heq in Hke. destruct Hke. - elim (He1 k e); auto. - elim (He2 k e); auto. - Qed. - - Lemma Partition_Add : - forall m m' x e , ~In x m -> Add x e m m' -> - forall m1 m2, Partition m' m1 m2 -> - exists m3, (Add x e m3 m1 /\ Partition m m3 m2 \/ - Add x e m3 m2 /\ Partition m m1 m3). - Proof. - unfold Partition. intros m m' x e Hn Hadd m1 m2 (Hdisj,Hor). - assert (Heq : Equal m (remove x m')). - { change (Equal m' (add x e m)) in Hadd. rewrite Hadd. - intro k. rewrite remove_o, add_o. - destruct E.eq_dec as [He|Hne]; auto. - rewrite <- He, <- not_find_in_iff; auto. } - assert (H : MapsTo x e m'). - { change (Equal m' (add x e m)) in Hadd; rewrite Hadd. - apply add_1; auto with map. } - rewrite Hor in H; destruct H. - - - (* first case : x in m1 *) - exists (remove x m1); left. split; [|split]. - + (* add *) - change (Equal m1 (add x e (remove x m1))). - intro k. - rewrite add_o, remove_o. - destruct E.eq_dec as [He|Hne]; auto. - rewrite <- He; apply find_1; auto. - + (* disjoint *) - intros k (H1,H2). elim (Hdisj k). split; auto. - rewrite remove_in_iff in H1; destruct H1; auto. - + (* mapsto *) - intros k' e'. - rewrite Heq, 2 remove_mapsto_iff, Hor. - intuition. - elim (Hdisj x); split; [exists e|exists e']; auto. - apply MapsTo_1 with k'; auto with map. - - - (* second case : x in m2 *) - exists (remove x m2); right. split; [|split]. - + (* add *) - change (Equal m2 (add x e (remove x m2))). - intro k. - rewrite add_o, remove_o. - destruct E.eq_dec as [He|Hne]; auto. - rewrite <- He; apply find_1; auto. - + (* disjoint *) - intros k (H1,H2). elim (Hdisj k). split; auto. - rewrite remove_in_iff in H2; destruct H2; auto. - + (* mapsto *) - intros k' e'. - rewrite Heq, 2 remove_mapsto_iff, Hor. - intuition. - elim (Hdisj x); split; [exists e'|exists e]; auto. - apply MapsTo_1 with k'; auto with map. - Qed. - - Lemma Partition_fold : - forall (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA)(f:key->elt->A->A), - Proper (E.eq==>eq==>eqA==>eqA) f -> - Diamond eqA f -> - forall m m1 m2 i, - Partition m m1 m2 -> - eqA (fold f m i) (fold f m1 (fold f m2 i)). - Proof. - intros A eqA st f Comp Tra. - induction m as [m Hm|m m' IH k e Hn Hadd] using map_induction. - - - intros m1 m2 i Hp. rewrite (fold_Empty (eqA:=eqA)); auto. - rewrite (Partition_Empty Hp) in Hm. destruct Hm. - rewrite 2 (fold_Empty (eqA:=eqA)); auto. reflexivity. - - - intros m1 m2 i Hp. - destruct (Partition_Add Hn Hadd Hp) as (m3,[(Hadd',Hp')|(Hadd',Hp')]). - + (* fst case: m3 is (k,e)::m1 *) - assert (~In k m3). - { contradict Hn. destruct Hn as (e',He'). - destruct Hp' as (Hp1,Hp2). exists e'. rewrite Hp2; auto. } - transitivity (f k e (fold f m i)). - apply fold_Add with (eqA:=eqA); auto. - symmetry. - transitivity (f k e (fold f m3 (fold f m2 i))). - apply fold_Add with (eqA:=eqA); auto. - apply Comp; auto with map. - symmetry; apply IH; auto. - + (* snd case: m3 is (k,e)::m2 *) - assert (~In k m3). - { contradict Hn. destruct Hn as (e',He'). - destruct Hp' as (Hp1,Hp2). exists e'. rewrite Hp2; auto. } - assert (~In k m1). - { contradict Hn. destruct Hn as (e',He'). - destruct Hp' as (Hp1,Hp2). exists e'. rewrite Hp2; auto. } - transitivity (f k e (fold f m i)). - apply fold_Add with (eqA:=eqA); auto. - transitivity (f k e (fold f m1 (fold f m3 i))). - apply Comp; auto using IH with map. - transitivity (fold f m1 (f k e (fold f m3 i))). - symmetry. - apply fold_commutes with (eqA:=eqA); auto. - apply fold_init with (eqA:=eqA); auto. - symmetry. - apply fold_Add with (eqA:=eqA); auto. - Qed. - - Lemma Partition_cardinal : forall m m1 m2, Partition m m1 m2 -> - cardinal m = cardinal m1 + cardinal m2. - Proof. - intros. - rewrite (cardinal_fold m), (cardinal_fold m1). - set (f:=fun (_:key)(_:elt)=>S). - setoid_replace (fold f m 0) with (fold f m1 (fold f m2 0)). - rewrite <- cardinal_fold. - apply fold_rel with (R:=fun u v => u = v + cardinal m2); simpl; auto. - apply Partition_fold with (eqA:=eq); compute; auto with map. congruence. - Qed. - - Lemma Partition_partition : forall m m1 m2, Partition m m1 m2 -> - let f := fun k (_:elt) => mem k m1 in - Equal m1 (fst (partition f m)) /\ Equal m2 (snd (partition f m)). - Proof. - intros m m1 m2 Hm f. - assert (Hf : Proper (E.eq==>eq==>eq) f). - intros k k' Hk e e' _; unfold f; rewrite Hk; auto. - set (m1':= fst (partition f m)). - set (m2':= snd (partition f m)). - split; rewrite Equal_mapsto_iff; intros k e. - rewrite (@partition_iff_1 f Hf m m1') by auto. - unfold f. - rewrite <- mem_in_iff. - destruct Hm as (Hm,Hm'). - rewrite Hm'. - intuition. - exists e; auto. - elim (Hm k); split; auto; exists e; auto. - rewrite (@partition_iff_2 f Hf m m2') by auto. - unfold f. - rewrite <- not_mem_in_iff. - destruct Hm as (Hm,Hm'). - rewrite Hm'. - intuition. - elim (Hm k); split; auto; exists e; auto. - elim H1; exists e; auto. - Qed. - - Lemma update_mapsto_iff : forall m m' k e, - MapsTo k e (update m m') <-> - (MapsTo k e m' \/ (MapsTo k e m /\ ~In k m')). - Proof. - unfold update. - intros m m'. - pattern m', (fold (@add _) m' m). apply fold_rec. - - - intros m0 Hm0 k e. - assert (~In k m0) by (intros (e0,He0); apply (Hm0 k e0); auto). - intuition. - elim (Hm0 k e); auto. - - - intros k e m0 m1 m2 _ Hn Hadd IH k' e'. - change (Equal m2 (add k e m1)) in Hadd. - rewrite Hadd, 2 add_mapsto_iff, IH, add_in_iff. clear IH. intuition. - Qed. - - Lemma update_dec : forall m m' k e, MapsTo k e (update m m') -> - { MapsTo k e m' } + { MapsTo k e m /\ ~In k m'}. - Proof. - intros m m' k e H. rewrite update_mapsto_iff in H. - destruct (In_dec m' k) as [H'|H']; [left|right]; intuition. - elim H'; exists e; auto. - Defined. - - Lemma update_in_iff : forall m m' k, - In k (update m m') <-> In k m \/ In k m'. - Proof. - intros m m' k. split. - intros (e,H); rewrite update_mapsto_iff in H. - destruct H; [right|left]; exists e; intuition. - destruct (In_dec m' k) as [H|H]. - destruct H as (e,H). intros _; exists e. - rewrite update_mapsto_iff; left; auto. - destruct 1 as [H'|H']; [|elim H; auto]. - destruct H' as (e,H'). exists e. - rewrite update_mapsto_iff; right; auto. - Qed. - - Lemma diff_mapsto_iff : forall m m' k e, - MapsTo k e (diff m m') <-> MapsTo k e m /\ ~In k m'. - Proof. - intros m m' k e. - unfold diff. - rewrite filter_iff. - intuition. - rewrite mem_1 in *; auto; discriminate. - intros ? ? Hk _ _ _; rewrite Hk; auto. - Qed. - - Lemma diff_in_iff : forall m m' k, - In k (diff m m') <-> In k m /\ ~In k m'. - Proof. - intros m m' k. split. - intros (e,H); rewrite diff_mapsto_iff in H. - destruct H; split; auto. exists e; auto. - intros ((e,H),H'); exists e; rewrite diff_mapsto_iff; auto. - Qed. - - Lemma restrict_mapsto_iff : forall m m' k e, - MapsTo k e (restrict m m') <-> MapsTo k e m /\ In k m'. - Proof. - intros m m' k e. - unfold restrict. - rewrite filter_iff. - intuition. - intros ? ? Hk _ _ _; rewrite Hk; auto. - Qed. - - Lemma restrict_in_iff : forall m m' k, - In k (restrict m m') <-> In k m /\ In k m'. - Proof. - intros m m' k. split. - intros (e,H); rewrite restrict_mapsto_iff in H. - destruct H; split; auto. exists e; auto. - intros ((e,H),H'); exists e; rewrite restrict_mapsto_iff; auto. - Qed. - - (** specialized versions analyzing only keys (resp. bindings) *) - - Definition filter_dom (f : key -> bool) := filter (fun k _ => f k). - Definition filter_range (f : elt -> bool) := filter (fun _ => f). - Definition for_all_dom (f : key -> bool) := for_all (fun k _ => f k). - Definition for_all_range (f : elt -> bool) := for_all (fun _ => f). - Definition exists_dom (f : key -> bool) := exists_ (fun k _ => f k). - Definition exists_range (f : elt -> bool) := exists_ (fun _ => f). - Definition partition_dom (f : key -> bool) := partition (fun k _ => f k). - Definition partition_range (f : elt -> bool) := partition (fun _ => f). - - End Elt. - - Instance cardinal_m {elt} : Proper (Equal ==> Logic.eq) (@cardinal elt). - Proof. intros m m'. apply Equal_cardinal. Qed. - - Instance Disjoint_m {elt} : Proper (Equal ==> Equal ==> iff) (@Disjoint elt). - Proof. - intros m1 m1' Hm1 m2 m2' Hm2. unfold Disjoint. split; intros. - rewrite <- Hm1, <- Hm2; auto. - rewrite Hm1, Hm2; auto. - Qed. - - Instance Partition_m {elt} : - Proper (Equal ==> Equal ==> Equal ==> iff) (@Partition elt). - Proof. - intros m1 m1' Hm1 m2 m2' Hm2 m3 m3' Hm3. unfold Partition. - rewrite <- Hm2, <- Hm3. - split; intros (H,H'); split; auto; intros. - rewrite <- Hm1, <- Hm2, <- Hm3; auto. - rewrite Hm1, Hm2, Hm3; auto. - Qed. - -(* - Instance filter_m0 {elt} (f:key->elt->bool) : - Proper (E.eq==>Logic.eq==>Logic.eq) f -> - Proper (Equal==>Equal) (filter f). - Proof. - intros Hf m m' Hm. apply Equal_mapsto_iff. intros. - now rewrite !filter_iff, Hm. - Qed. -*) - - Instance filter_m {elt} : - Proper ((E.eq==>Logic.eq==>Logic.eq)==>Equal==>Equal) (@filter elt). - Proof. - intros f f' Hf m m' Hm. unfold filter. - rewrite 2 fold_spec_right. - set (l := rev (bindings m)). - set (l' := rev (bindings m')). - set (op := fun (f:key->elt->bool) => - uncurry (fun k e acc => if f k e then add k e acc else acc)). - change (Equal (fold_right (op f) empty l) (fold_right (op f') empty l')). - assert (Hl : NoDupA eq_key l). - { apply NoDupA_rev. apply eqk_equiv. apply bindings_spec2w. } - assert (Hl' : NoDupA eq_key l'). - { apply NoDupA_rev. apply eqk_equiv. apply bindings_spec2w. } - assert (H : PermutationA eq_key_elt l l'). - { apply NoDupA_equivlistA_PermutationA. - - apply eqke_equiv. - - now apply NoDupA_eqk_eqke. - - now apply NoDupA_eqk_eqke. - - intros (k,e); unfold l, l'. rewrite 2 InA_rev, 2 bindings_spec1. - rewrite Equal_mapsto_iff in Hm. apply Hm. } - destruct (PermutationA_decompose (eqke_equiv _) H) as (l0,(P,E)). - transitivity (fold_right (op f) empty l0). - - apply fold_right_equivlistA_restr2 - with (eqA:=Logic.eq)(R:=complement eq_key); auto with *. - + intros p p' <- acc acc' Hacc. - destruct p as (k,e); unfold op, uncurry; simpl. - destruct (f k e); now rewrite Hacc. - + intros (k,e) (k',e') z z'. - unfold op, complement, uncurry, eq_key; simpl. - intros Hk Hz. - destruct (f k e), (f k' e'); rewrite <- Hz; try reflexivity. - now apply add_add_2. - + apply NoDupA_incl with eq_key; trivial. intros; subst; now red. - + apply PermutationA_preserves_NoDupA with l; auto with *. - apply Permutation_PermutationA; auto with *. - apply NoDupA_incl with eq_key; trivial. intros; subst; now red. - + apply NoDupA_altdef. apply NoDupA_rev. apply eqk_equiv. - apply bindings_spec2w. - + apply PermutationA_equivlistA; auto with *. - apply Permutation_PermutationA; auto with *. - - clearbody l'. clear l Hl Hl' H P m m' Hm. - induction E. - + reflexivity. - + simpl. destruct x as (k,e), x' as (k',e'). - unfold op, uncurry at 1 3; simpl. - destruct H; simpl in *. rewrite <- (Hf _ _ H _ _ H0). - destruct (f k e); trivial. now f_equiv. - Qed. - - Instance for_all_m {elt} : - Proper ((E.eq==>Logic.eq==>Logic.eq)==>Equal==>Logic.eq) (@for_all elt). - Proof. - intros f f' Hf m m' Hm. rewrite 2 for_all_filter. - (* Strange: we cannot rewrite Hm here... *) - f_equiv. f_equiv; trivial. - intros k k' Hk e e' He. f_equal. now apply Hf. - Qed. - - Instance exists_m {elt} : - Proper ((E.eq==>Logic.eq==>Logic.eq)==>Equal==>Logic.eq) (@exists_ elt). - Proof. - intros f f' Hf m m' Hm. rewrite 2 exists_filter. - f_equal. now apply is_empty_m, filter_m. - Qed. - - Fact diamond_add {elt} : Diamond Equal (@add elt). - Proof. - intros k k' e e' a b b' Hk <- <-. now apply add_add_2. - Qed. - - Instance update_m {elt} : Proper (Equal ==> Equal ==> Equal) (@update elt). - Proof. - intros m1 m1' Hm1 m2 m2' Hm2. - unfold update. - apply fold_Proper; auto using diamond_add with *. - Qed. - - Instance restrict_m {elt} : Proper (Equal==>Equal==>Equal) (@restrict elt). - Proof. - intros m1 m1' Hm1 m2 m2' Hm2 y. - unfold restrict. - apply eq_option_alt. intros e. - rewrite !find_spec, !filter_iff, Hm1, Hm2. reflexivity. - clear. intros x x' Hx e e' He. now rewrite Hx. - clear. intros x x' Hx e e' He. now rewrite Hx. - Qed. - - Instance diff_m {elt} : Proper (Equal==>Equal==>Equal) (@diff elt). - Proof. - intros m1 m1' Hm1 m2 m2' Hm2 y. - unfold diff. - apply eq_option_alt. intros e. - rewrite !find_spec, !filter_iff, Hm1, Hm2. reflexivity. - clear. intros x x' Hx e e' He. now rewrite Hx. - clear. intros x x' Hx e e' He. now rewrite Hx. - Qed. - -End WProperties_fun. - -(** * Same Properties for self-contained weak maps and for full maps *) - -Module WProperties (M:WS) := WProperties_fun M.E M. -Module Properties := WProperties. - -(** * Properties specific to maps with ordered keys *) - -Module OrdProperties (M:S). - Module Import ME := OrderedTypeFacts M.E. - Module Import O:=KeyOrderedType M.E. - Module Import P:=Properties M. - Import M. - - Section Elt. - Variable elt:Type. - - Definition Above x (m:t elt) := forall y, In y m -> E.lt y x. - Definition Below x (m:t elt) := forall y, In y m -> E.lt x y. - - Section Bindings. - - Lemma sort_equivlistA_eqlistA : forall l l' : list (key*elt), - sort ltk l -> sort ltk l' -> equivlistA eqke l l' -> eqlistA eqke l l'. - Proof. - apply SortA_equivlistA_eqlistA; eauto with *. - Qed. - - Ltac klean := unfold O.eqke, O.ltk, RelCompFun in *; simpl in *. - Ltac keauto := klean; intuition; eauto. - - Definition gtb (p p':key*elt) := - match E.compare (fst p) (fst p') with Gt => true | _ => false end. - Definition leb p := fun p' => negb (gtb p p'). - - Definition bindings_lt p m := List.filter (gtb p) (bindings m). - Definition bindings_ge p m := List.filter (leb p) (bindings m). - - Lemma gtb_1 : forall p p', gtb p p' = true <-> ltk p' p. - Proof. - intros (x,e) (y,e'); unfold gtb; klean. - case E.compare_spec; intuition; try discriminate; ME.order. - Qed. - - Lemma leb_1 : forall p p', leb p p' = true <-> ~ltk p' p. - Proof. - intros (x,e) (y,e'); unfold leb, gtb; klean. - case E.compare_spec; intuition; try discriminate; ME.order. - Qed. - - Instance gtb_compat : forall p, Proper (eqke==>eq) (gtb p). - Proof. - red; intros (x,e) (a,e') (b,e'') H; red in H; simpl in *; destruct H. - generalize (gtb_1 (x,e) (a,e'))(gtb_1 (x,e) (b,e'')); - destruct (gtb (x,e) (a,e')); destruct (gtb (x,e) (b,e'')); klean; auto. - - intros. symmetry; rewrite H2. rewrite <-H, <-H1; auto. - - intros. rewrite H1. rewrite H, <- H2; auto. - Qed. - - Instance leb_compat : forall p, Proper (eqke==>eq) (leb p). - Proof. - intros x a b H. unfold leb; f_equal; apply gtb_compat; auto. - Qed. - - Hint Resolve gtb_compat leb_compat bindings_spec2 : map. - - Lemma bindings_split : forall p m, - bindings m = bindings_lt p m ++ bindings_ge p m. - Proof. - unfold bindings_lt, bindings_ge, leb; intros. - apply filter_split with (eqA:=eqk) (ltA:=ltk); eauto with *. - intros; destruct x; destruct y; destruct p. - rewrite gtb_1 in H; klean. - apply not_true_iff_false in H0. rewrite gtb_1 in H0. klean. ME.order. - Qed. - - Lemma bindings_Add : forall m m' x e, ~In x m -> Add x e m m' -> - eqlistA eqke (bindings m') - (bindings_lt (x,e) m ++ (x,e):: bindings_ge (x,e) m). - Proof. - intros; unfold bindings_lt, bindings_ge. - apply sort_equivlistA_eqlistA; auto with *. - - apply (@SortA_app _ eqke); auto with *. - + apply (@filter_sort _ eqke); auto with *; keauto. - + constructor; auto with map. - * apply (@filter_sort _ eqke); auto with *; keauto. - * rewrite (@InfA_alt _ eqke); auto with *; try (keauto; fail). - { intros. - rewrite filter_InA in H1; auto with *; destruct H1. - rewrite leb_1 in H2. - destruct y; klean. - rewrite <- bindings_mapsto_iff in H1. - assert (~E.eq x t0). - { contradict H. - exists e0; apply MapsTo_1 with t0; auto. - ME.order. } - ME.order. } - { apply (@filter_sort _ eqke); auto with *; keauto. } - + intros. - rewrite filter_InA in H1; auto with *; destruct H1. - rewrite gtb_1 in H3. - destruct y; destruct x0; klean. - inversion_clear H2. - * red in H4; klean; destruct H4; simpl in *. ME.order. - * rewrite filter_InA in H4; auto with *; destruct H4. - rewrite leb_1 in H4. klean; ME.order. - - intros (k,e'). - rewrite InA_app_iff, InA_cons, 2 filter_InA, - <-2 bindings_mapsto_iff, leb_1, gtb_1, - find_mapsto_iff, (H0 k), <- find_mapsto_iff, - add_mapsto_iff by (auto with * ). - change (eqke (k,e') (x,e)) with (E.eq k x /\ e' = e). - klean. - split. - + intros [(->,->)|(Hk,Hm)]. - * right; now left. - * destruct (lt_dec k x); intuition. - + intros [(Hm,LT)|[(->,->)|(Hm,EQ)]]. - * right; split; trivial; ME.order. - * now left. - * destruct (eq_dec x k) as [Hk|Hk]. - elim H. exists e'. now rewrite Hk. - right; auto. - Qed. - - Lemma bindings_Add_Above : forall m m' x e, - Above x m -> Add x e m m' -> - eqlistA eqke (bindings m') (bindings m ++ (x,e)::nil). - Proof. - intros. - apply sort_equivlistA_eqlistA; auto with *. - apply (@SortA_app _ eqke); auto with *. - intros. - inversion_clear H2. - destruct x0; destruct y. - rewrite <- bindings_mapsto_iff in H1. - destruct H3; klean. - rewrite H2. - apply H; firstorder. - inversion H3. - red; intros a; destruct a. - rewrite InA_app_iff, InA_cons, InA_nil, <- 2 bindings_mapsto_iff, - find_mapsto_iff, (H0 t0), <- find_mapsto_iff, - add_mapsto_iff by (auto with *). - change (eqke (t0,e0) (x,e)) with (E.eq t0 x /\ e0 = e). - intuition. - destruct (E.eq_dec x t0) as [Heq|Hneq]; auto. - exfalso. - assert (In t0 m) by (exists e0; auto). - generalize (H t0 H1). - ME.order. - Qed. - - Lemma bindings_Add_Below : forall m m' x e, - Below x m -> Add x e m m' -> - eqlistA eqke (bindings m') ((x,e)::bindings m). - Proof. - intros. - apply sort_equivlistA_eqlistA; auto with *. - change (sort ltk (((x,e)::nil) ++ bindings m)). - apply (@SortA_app _ eqke); auto with *. - intros. - inversion_clear H1. - destruct y; destruct x0. - rewrite <- bindings_mapsto_iff in H2. - destruct H3; klean. - rewrite H1. - apply H; firstorder. - inversion H3. - red; intros a; destruct a. - rewrite InA_cons, <- 2 bindings_mapsto_iff, - find_mapsto_iff, (H0 t0), <- find_mapsto_iff, - add_mapsto_iff by (auto with * ). - change (eqke (t0,e0) (x,e)) with (E.eq t0 x /\ e0 = e). - intuition. - destruct (E.eq_dec x t0) as [Heq|Hneq]; auto. - exfalso. - assert (In t0 m) by (exists e0; auto). - generalize (H t0 H1). - ME.order. - Qed. - - Lemma bindings_Equal_eqlistA : forall (m m': t elt), - Equal m m' -> eqlistA eqke (bindings m) (bindings m'). - Proof. - intros. - apply sort_equivlistA_eqlistA; auto with *. - red; intros. - destruct x; do 2 rewrite <- bindings_mapsto_iff. - do 2 rewrite find_mapsto_iff; rewrite H; split; auto. - Qed. - - End Bindings. - - Section Min_Max_Elt. - - (** We emulate two [max_elt] and [min_elt] functions. *) - - Fixpoint max_elt_aux (l:list (key*elt)) := match l with - | nil => None - | (x,e)::nil => Some (x,e) - | (x,e)::l => max_elt_aux l - end. - Definition max_elt m := max_elt_aux (bindings m). - - Lemma max_elt_Above : - forall m x e, max_elt m = Some (x,e) -> Above x (remove x m). - Proof. - red; intros. - rewrite remove_in_iff in H0. - destruct H0. - rewrite bindings_in_iff in H1. - destruct H1. - unfold max_elt in *. - generalize (bindings_spec2 m). - revert x e H y x0 H0 H1. - induction (bindings m). - simpl; intros; try discriminate. - intros. - destruct a; destruct l; simpl in *. - injection H; clear H; intros; subst. - inversion_clear H1. - red in H; simpl in *; intuition. - now elim H0. - inversion H. - change (max_elt_aux (p::l) = Some (x,e)) in H. - generalize (IHl x e H); clear IHl; intros IHl. - inversion_clear H1; [ | inversion_clear H2; eauto ]. - red in H3; simpl in H3; destruct H3. - destruct p as (p1,p2). - destruct (E.eq_dec p1 x) as [Heq|Hneq]. - rewrite <- Heq; auto. - inversion_clear H2. - inversion_clear H5. - red in H2; simpl in H2; ME.order. - transitivity p1; auto. - inversion_clear H2. - inversion_clear H5. - red in H2; simpl in H2; ME.order. - eapply IHl; eauto with *. - econstructor; eauto. - red; eauto with *. - inversion H2; auto. - Qed. - - Lemma max_elt_MapsTo : - forall m x e, max_elt m = Some (x,e) -> MapsTo x e m. - Proof. - intros. - unfold max_elt in *. - rewrite bindings_mapsto_iff. - induction (bindings m). - simpl; try discriminate. - destruct a; destruct l; simpl in *. - injection H; intros; subst; constructor; red; auto with *. - constructor 2; auto. - Qed. - - Lemma max_elt_Empty : - forall m, max_elt m = None -> Empty m. - Proof. - intros. - unfold max_elt in *. - rewrite bindings_Empty. - induction (bindings m); auto. - destruct a; destruct l; simpl in *; try discriminate. - assert (H':=IHl H); discriminate. - Qed. - - Definition min_elt m : option (key*elt) := match bindings m with - | nil => None - | (x,e)::_ => Some (x,e) - end. - - Lemma min_elt_Below : - forall m x e, min_elt m = Some (x,e) -> Below x (remove x m). - Proof. - unfold min_elt, Below; intros. - rewrite remove_in_iff in H0; destruct H0. - rewrite bindings_in_iff in H1. - destruct H1. - generalize (bindings_spec2 m). - destruct (bindings m). - try discriminate. - destruct p; injection H; intros; subst. - inversion_clear H1. - red in H2; destruct H2; simpl in *; ME.order. - inversion_clear H4. - rewrite (@InfA_alt _ eqke) in H3; eauto with *. - apply (H3 (y,x0)); auto. - Qed. - - Lemma min_elt_MapsTo : - forall m x e, min_elt m = Some (x,e) -> MapsTo x e m. - Proof. - intros. - unfold min_elt in *. - rewrite bindings_mapsto_iff. - destruct (bindings m). - simpl; try discriminate. - destruct p; simpl in *. - injection H; intros; subst; constructor; red; auto with *. - Qed. - - Lemma min_elt_Empty : - forall m, min_elt m = None -> Empty m. - Proof. - intros. - unfold min_elt in *. - rewrite bindings_Empty. - destruct (bindings m); auto. - destruct p; simpl in *; discriminate. - Qed. - - End Min_Max_Elt. - - Section Induction_Principles. - - Lemma map_induction_max : - forall P : t elt -> Type, - (forall m, Empty m -> P m) -> - (forall m m', P m -> forall x e, Above x m -> Add x e m m' -> P m') -> - forall m, P m. - Proof. - intros; remember (cardinal m) as n; revert m Heqn; induction n; intros. - apply X; apply cardinal_inv_1; auto. - - case_eq (max_elt m); intros. - destruct p. - assert (Add k e (remove k m) m). - { apply max_elt_MapsTo, find_spec, add_id in H. - unfold Add. symmetry. now rewrite add_remove_1. } - apply X0 with (remove k m) k e; auto with map. - apply IHn. - assert (S n = S (cardinal (remove k m))). - { rewrite Heqn. - eapply cardinal_S; eauto with map. } - inversion H1; auto. - eapply max_elt_Above; eauto. - - apply X; apply max_elt_Empty; auto. - Qed. - - Lemma map_induction_min : - forall P : t elt -> Type, - (forall m, Empty m -> P m) -> - (forall m m', P m -> forall x e, Below x m -> Add x e m m' -> P m') -> - forall m, P m. - Proof. - intros; remember (cardinal m) as n; revert m Heqn; induction n; intros. - apply X; apply cardinal_inv_1; auto. - - case_eq (min_elt m); intros. - destruct p. - assert (Add k e (remove k m) m). - { apply min_elt_MapsTo, find_spec, add_id in H. - unfold Add. symmetry. now rewrite add_remove_1. } - apply X0 with (remove k m) k e; auto. - apply IHn. - assert (S n = S (cardinal (remove k m))). - { rewrite Heqn. - eapply cardinal_S; eauto with map. } - inversion H1; auto. - eapply min_elt_Below; eauto. - - apply X; apply min_elt_Empty; auto. - Qed. - - End Induction_Principles. - - Section Fold_properties. - - (** The following lemma has already been proved on Weak Maps, - but with one additionnal hypothesis (some [transpose] fact). *) - - Lemma fold_Equal : forall m1 m2 (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) - (f:key->elt->A->A)(i:A), - Proper (E.eq==>eq==>eqA==>eqA) f -> - Equal m1 m2 -> - eqA (fold f m1 i) (fold f m2 i). - Proof. - intros m1 m2 A eqA st f i Hf Heq. - rewrite 2 fold_spec_right. - apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto. - intros (k,e) (k',e') (Hk,He) a a' Ha; simpl in *; apply Hf; auto. - apply eqlistA_rev. apply bindings_Equal_eqlistA. auto. - Qed. - - Lemma fold_Add_Above : forall m1 m2 x e (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) - (f:key->elt->A->A)(i:A) (P:Proper (E.eq==>eq==>eqA==>eqA) f), - Above x m1 -> Add x e m1 m2 -> - eqA (fold f m2 i) (f x e (fold f m1 i)). - Proof. - intros. rewrite 2 fold_spec_right. set (f':=uncurry f). - transitivity (fold_right f' i (rev (bindings m1 ++ (x,e)::nil))). - apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto. - intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; unfold f'; simpl in *. apply P; auto. - apply eqlistA_rev. - apply bindings_Add_Above; auto. - rewrite distr_rev; simpl. - reflexivity. - Qed. - - Lemma fold_Add_Below : forall m1 m2 x e (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) - (f:key->elt->A->A)(i:A) (P:Proper (E.eq==>eq==>eqA==>eqA) f), - Below x m1 -> Add x e m1 m2 -> - eqA (fold f m2 i) (fold f m1 (f x e i)). - Proof. - intros. rewrite 2 fold_spec_right. set (f':=uncurry f). - transitivity (fold_right f' i (rev (((x,e)::nil)++bindings m1))). - apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto. - intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; unfold f'; simpl in *; apply P; auto. - apply eqlistA_rev. - simpl; apply bindings_Add_Below; auto. - rewrite distr_rev; simpl. - rewrite fold_right_app. - reflexivity. - Qed. - - End Fold_properties. - - End Elt. - -End OrdProperties. diff --git a/theories/MMaps/MMapInterface.v b/theories/MMaps/MMapInterface.v deleted file mode 100644 index 05c5e5d8f..000000000 --- a/theories/MMaps/MMapInterface.v +++ /dev/null @@ -1,292 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) -(* \VV/ *************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(***********************************************************************) - -(** * Finite map library *) - -(** This file proposes interfaces for finite maps *) - -Require Export Bool Equalities Orders SetoidList. -Set Implicit Arguments. -Unset Strict Implicit. - -(** When compared with Ocaml Map, this signature has been split in - several parts : - - - The first parts [WSfun] and [WS] propose signatures for weak - maps, which are maps with no ordering on the key type nor the - data type. [WSfun] and [WS] are almost identical, apart from the - fact that [WSfun] is expressed in a functorial way whereas [WS] - is self-contained. For obtaining an instance of such signatures, - a decidable equality on keys in enough (see for example - [FMapWeakList]). These signatures contain the usual operators - (add, find, ...). The only function that asks for more is - [equal], whose first argument should be a comparison on data. - - - Then comes [Sfun] and [S], that extend [WSfun] and [WS] to the - case where the key type is ordered. The main novelty is that - [bindings] is required to produce sorted lists. - - - Finally, [Sord] extends [S] with a complete comparison function. For - that, the data type should have a decidable total ordering as well. - - If unsure, what you're looking for is probably [S]: apart from [Sord], - all other signatures are subsets of [S]. - - Some additional differences with Ocaml: - - - no [iter] function, useless since Coq is purely functional - - [option] types are used instead of [Not_found] exceptions - -*) - - -Definition Cmp {elt:Type}(cmp:elt->elt->bool) e1 e2 := cmp e1 e2 = true. - -(** ** Weak signature for maps - - No requirements for an ordering on keys nor elements, only decidability - of equality on keys. First, a functorial signature: *) - -Module Type WSfun (E : DecidableType). - - Definition key := E.t. - Hint Transparent key. - - Definition eq_key {elt} (p p':key*elt) := E.eq (fst p) (fst p'). - - Definition eq_key_elt {elt} (p p':key*elt) := - E.eq (fst p) (fst p') /\ (snd p) = (snd p'). - - Parameter t : Type -> Type. - (** the abstract type of maps *) - - Section Ops. - - Parameter empty : forall {elt}, t elt. - (** The empty map. *) - - Variable elt:Type. - - Parameter is_empty : t elt -> bool. - (** Test whether a map is empty or not. *) - - Parameter add : key -> elt -> t elt -> t elt. - (** [add x y m] returns a map containing the same bindings as [m], - plus a binding of [x] to [y]. If [x] was already bound in [m], - its previous binding disappears. *) - - Parameter find : key -> t elt -> option elt. - (** [find x m] returns the current binding of [x] in [m], - or [None] if no such binding exists. *) - - Parameter remove : key -> t elt -> t elt. - (** [remove x m] returns a map containing the same bindings as [m], - except for [x] which is unbound in the returned map. *) - - Parameter mem : key -> t elt -> bool. - (** [mem x m] returns [true] if [m] contains a binding for [x], - and [false] otherwise. *) - - Parameter bindings : t elt -> list (key*elt). - (** [bindings m] returns an assoc list corresponding to the bindings - of [m], in any order. *) - - Parameter cardinal : t elt -> nat. - (** [cardinal m] returns the number of bindings in [m]. *) - - Parameter fold : forall A: Type, (key -> elt -> A -> A) -> t elt -> A -> A. - (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)], - where [k1] ... [kN] are the keys of all bindings in [m] - (in any order), and [d1] ... [dN] are the associated data. *) - - Parameter equal : (elt -> elt -> bool) -> t elt -> t elt -> bool. - (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are equal, - that is, contain equal keys and associate them with equal data. - [cmp] is the equality predicate used to compare the data associated - with the keys. *) - - Variable elt' elt'' : Type. - - Parameter map : (elt -> elt') -> t elt -> t elt'. - (** [map f m] returns a map with same domain as [m], where the associated - value a of all bindings of [m] has been replaced by the result of the - application of [f] to [a]. Since Coq is purely functional, the order - in which the bindings are passed to [f] is irrelevant. *) - - Parameter mapi : (key -> elt -> elt') -> t elt -> t elt'. - (** Same as [map], but the function receives as arguments both the - key and the associated value for each binding of the map. *) - - Parameter merge : (key -> option elt -> option elt' -> option elt'') -> - t elt -> t elt' -> t elt''. - (** [merge f m m'] creates a new map whose bindings belong to the ones - of either [m] or [m']. The presence and value for a key [k] is - determined by [f k e e'] where [e] and [e'] are the (optional) - bindings of [k] in [m] and [m']. *) - - End Ops. - Section Specs. - - Variable elt:Type. - - Parameter MapsTo : key -> elt -> t elt -> Prop. - - Definition In (k:key)(m: t elt) : Prop := exists e:elt, MapsTo k e m. - - Global Declare Instance MapsTo_compat : - Proper (E.eq==>Logic.eq==>Logic.eq==>iff) MapsTo. - - Variable m m' : t elt. - Variable x y : key. - Variable e : elt. - - Parameter find_spec : find x m = Some e <-> MapsTo x e m. - Parameter mem_spec : mem x m = true <-> In x m. - Parameter empty_spec : find x (@empty elt) = None. - Parameter is_empty_spec : is_empty m = true <-> forall x, find x m = None. - Parameter add_spec1 : find x (add x e m) = Some e. - Parameter add_spec2 : ~E.eq x y -> find y (add x e m) = find y m. - Parameter remove_spec1 : find x (remove x m) = None. - Parameter remove_spec2 : ~E.eq x y -> find y (remove x m) = find y m. - - (** Specification of [bindings] *) - Parameter bindings_spec1 : - InA eq_key_elt (x,e) (bindings m) <-> MapsTo x e m. - (** When compared with ordered maps, here comes the only - property that is really weaker: *) - Parameter bindings_spec2w : NoDupA eq_key (bindings m). - - (** Specification of [cardinal] *) - Parameter cardinal_spec : cardinal m = length (bindings m). - - (** Specification of [fold] *) - Parameter fold_spec : - forall {A} (i : A) (f : key -> elt -> A -> A), - fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i. - - (** Equality of maps *) - - (** Caveat: there are at least three distinct equality predicates on maps. - - The simpliest (and maybe most natural) way is to consider keys up to - their equivalence [E.eq], but elements up to Leibniz equality, in - the spirit of [eq_key_elt] above. This leads to predicate [Equal]. - - Unfortunately, this [Equal] predicate can't be used to describe - the [equal] function, since this function (for compatibility with - ocaml) expects a boolean comparison [cmp] that may identify more - elements than Leibniz. So logical specification of [equal] is done - via another predicate [Equivb] - - This predicate [Equivb] is quite ad-hoc with its boolean [cmp], - it can be generalized in a [Equiv] expecting a more general - (possibly non-decidable) equality predicate on elements *) - - Definition Equal (m m':t elt) := forall y, find y m = find y m'. - Definition Equiv (eq_elt:elt->elt->Prop) m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). - Definition Equivb (cmp: elt->elt->bool) := Equiv (Cmp cmp). - - (** Specification of [equal] *) - Parameter equal_spec : forall cmp : elt -> elt -> bool, - equal cmp m m' = true <-> Equivb cmp m m'. - - End Specs. - Section SpecMaps. - - Variables elt elt' elt'' : Type. - - Parameter map_spec : forall (f:elt->elt') m x, - find x (map f m) = option_map f (find x m). - - Parameter mapi_spec : forall (f:key->elt->elt') m x, - exists y:key, E.eq y x /\ find x (mapi f m) = option_map (f y) (find x m). - - Parameter merge_spec1 : - forall (f:key->option elt->option elt'->option elt'') m m' x, - In x m \/ In x m' -> - exists y:key, E.eq y x /\ - find x (merge f m m') = f y (find x m) (find x m'). - - Parameter merge_spec2 : - forall (f:key -> option elt->option elt'->option elt'') m m' x, - In x (merge f m m') -> In x m \/ In x m'. - - End SpecMaps. -End WSfun. - -(** ** Static signature for Weak Maps - - Similar to [WSfun] but expressed in a self-contained way. *) - -Module Type WS. - Declare Module E : DecidableType. - Include WSfun E. -End WS. - - - -(** ** Maps on ordered keys, functorial signature *) - -Module Type Sfun (E : OrderedType). - Include WSfun E. - - Definition lt_key {elt} (p p':key*elt) := E.lt (fst p) (fst p'). - - (** Additional specification of [bindings] *) - - Parameter bindings_spec2 : forall {elt}(m : t elt), sort lt_key (bindings m). - - (** Remark: since [fold] is specified via [bindings], this stronger - specification of [bindings] has an indirect impact on [fold], - which can now be proved to receive bindings in increasing order. *) - -End Sfun. - - -(** ** Maps on ordered keys, self-contained signature *) - -Module Type S. - Declare Module E : OrderedType. - Include Sfun E. -End S. - - - -(** ** Maps with ordering both on keys and datas *) - -Module Type Sord. - - Declare Module Data : OrderedType. - Declare Module MapS : S. - Import MapS. - - Definition t := MapS.t Data.t. - - Include HasEq <+ HasLt <+ IsEq <+ IsStrOrder. - - Definition cmp e e' := - match Data.compare e e' with Eq => true | _ => false end. - - Parameter eq_spec : forall m m', eq m m' <-> Equivb cmp m m'. - - Parameter compare : t -> t -> comparison. - - Parameter compare_spec : forall m1 m2, CompSpec eq lt m1 m2 (compare m1 m2). - -End Sord. - - -(* TODO: provides filter + partition *) - -(* TODO: provide split - Parameter split : key -> t elt -> t elt * option elt * t elt. - - Parameter split_spec k m : - split k m = (filter (fun x -> E.compare x k) m, find k m, filter ...) - - min_binding, max_binding, choose ? -*) diff --git a/theories/MMaps/MMapList.v b/theories/MMaps/MMapList.v deleted file mode 100644 index c521178cb..000000000 --- a/theories/MMaps/MMapList.v +++ /dev/null @@ -1,1144 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) -(* \VV/ *************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(***********************************************************************) - -(** * Finite map library *) - -(** This file proposes an implementation of the non-dependant interface - [MMapInterface.S] using lists of pairs ordered (increasing) with respect to - left projection. *) - -Require Import MMapInterface OrdersFacts OrdersLists. - -Set Implicit Arguments. -Unset Strict Implicit. - -Module Raw (X:OrderedType). - -Module Import MX := OrderedTypeFacts X. -Module Import PX := KeyOrderedType X. - -Definition key := X.t. -Definition t (elt:Type) := list (X.t * elt). - -Local Notation Sort := (sort ltk). -Local Notation Inf := (lelistA (ltk)). - -Section Elt. -Variable elt : Type. - -Ltac SortLt := - match goal with - | H1 : Sort ?m, H2:Inf (?k',?e') ?m, H3:In ?k ?m |- _ => - assert (X.lt k' k); - [let e := fresh "e" in destruct H3 as (e,H3); - change (ltk (k',e') (k,e)); - apply (Sort_Inf_In H1 H2 (InA_eqke_eqk H3)) | ] - | H1:Sort ?m, H2:Inf (?k',?e') ?m, H3:MapsTo ?k ?e ?m |- _ => - assert (X.lt k' k); - [change (ltk (k',e') (k,e)); - apply (Sort_Inf_In H1 H2 (InA_eqke_eqk H3)) | ] - | H1:Sort ?m, H2:Inf (?k',?e') ?m, H3:InA eqke (?k,?e) ?m |- _ => - assert (X.lt k' k); - [change (ltk (k',e') (k,e)); - apply (Sort_Inf_In H1 H2 (InA_eqke_eqk H3)) | ] - end. - -(** * [find] *) - -Fixpoint find (k:key) (m: t elt) : option elt := - match m with - | nil => None - | (k',x)::m' => - match X.compare k k' with - | Lt => None - | Eq => Some x - | Gt => find k m' - end - end. - -Lemma find_spec m (Hm:Sort m) x e : - find x m = Some e <-> MapsTo x e m. -Proof. - induction m as [|(k,e') m IH]; simpl. - - split. discriminate. inversion 1. - - inversion_clear Hm. - unfold MapsTo in *. rewrite InA_cons, eqke_def. - case X.compare_spec; intros. - + split. injection 1 as ->; auto. - intros [(_,<-)|IN]; trivial. SortLt. MX.order. - + split. discriminate. - intros [(E,<-)|IN]; trivial; try SortLt; MX.order. - + rewrite IH; trivial. split; auto. - intros [(E,<-)|IN]; trivial. MX.order. -Qed. - -(** * [mem] *) - -Fixpoint mem (k : key) (m : t elt) : bool := - match m with - | nil => false - | (k',_) :: l => - match X.compare k k' with - | Lt => false - | Eq => true - | Gt => mem k l - end - end. - -Lemma mem_spec m (Hm:Sort m) x : mem x m = true <-> In x m. -Proof. - induction m as [|(k,e') m IH]; simpl. - - split. discriminate. inversion 1. inversion_clear H0. - - inversion_clear Hm. - rewrite In_cons; simpl. - case X.compare_spec; intros. - + intuition. - + split. discriminate. intros [E|(e,IN)]. MX.order. - SortLt. MX.order. - + rewrite IH; trivial. split; auto. intros [E|IN]; trivial. - MX.order. -Qed. - -(** * [empty] *) - -Definition empty : t elt := nil. - -Lemma empty_spec x : find x empty = None. -Proof. - reflexivity. -Qed. - -Lemma empty_sorted : Sort empty. -Proof. - unfold empty; auto. -Qed. - -(** * [is_empty] *) - -Definition is_empty (l : t elt) : bool := if l then true else false. - -Lemma is_empty_spec m : - is_empty m = true <-> forall x, find x m = None. -Proof. - destruct m as [|(k,e) m]; simpl; split; trivial; try discriminate. - intros H. specialize (H k). now rewrite compare_refl in H. -Qed. - -(** * [add] *) - -Fixpoint add (k : key) (x : elt) (s : t elt) : t elt := - match s with - | nil => (k,x) :: nil - | (k',y) :: l => - match X.compare k k' with - | Lt => (k,x)::s - | Eq => (k,x)::l - | Gt => (k',y) :: add k x l - end - end. - -Lemma add_spec1 m x e : find x (add x e m) = Some e. -Proof. - induction m as [|(k,e') m IH]; simpl. - - now rewrite compare_refl. - - case X.compare_spec; simpl; rewrite ?compare_refl; trivial. - rewrite <- compare_gt_iff. now intros ->. -Qed. - -Lemma add_spec2 m x y e : ~X.eq x y -> find y (add x e m) = find y m. -Proof. - induction m as [|(k,e') m IH]; simpl. - - case X.compare_spec; trivial; MX.order. - - case X.compare_spec; simpl; intros; trivial. - + rewrite <-H. case X.compare_spec; trivial; MX.order. - + do 2 (case X.compare_spec; trivial; try MX.order). - + now rewrite IH. -Qed. - -Lemma add_Inf : forall (m:t elt)(x x':key)(e e':elt), - Inf (x',e') m -> ltk (x',e') (x,e) -> Inf (x',e') (add x e m). -Proof. - induction m. - simpl; intuition. - intros. - destruct a as (x'',e''). - inversion_clear H. - compute in H0,H1. - simpl; case X.compare; intuition. -Qed. -Hint Resolve add_Inf. - -Lemma add_sorted : forall m (Hm:Sort m) x e, Sort (add x e m). -Proof. - induction m. - simpl; intuition. - intros. - destruct a as (x',e'). - simpl; case (X.compare_spec x x'); intuition; inversion_clear Hm; auto. - constructor; auto. - apply Inf_eq with (x',e'); auto. -Qed. - -(** * [remove] *) - -Fixpoint remove (k : key) (s : t elt) : t elt := - match s with - | nil => nil - | (k',x) :: l => - match X.compare k k' with - | Lt => s - | Eq => l - | Gt => (k',x) :: remove k l - end - end. - -Lemma remove_spec1 m (Hm:Sort m) x : find x (remove x m) = None. -Proof. - induction m as [|(k,e') m IH]; simpl; trivial. - inversion_clear Hm. - case X.compare_spec; simpl. - - intros E. rewrite <- E in H0. - apply Sort_Inf_NotIn in H0; trivial. unfold In in H0. - setoid_rewrite <- find_spec in H0; trivial. - destruct (find x m); trivial. - elim H0; now exists e. - - rewrite <- compare_lt_iff. now intros ->. - - rewrite <- compare_gt_iff. intros ->; auto. -Qed. - -Lemma remove_spec2 m (Hm:Sort m) x y : - ~X.eq x y -> find y (remove x m) = find y m. -Proof. - induction m as [|(k,e') m IH]; simpl; trivial. - inversion_clear Hm. - case X.compare_spec; simpl; intros E E'; try rewrite IH; auto. - case X.compare_spec; simpl; trivial; try MX.order. - intros. rewrite <- E in H0,H1. clear E E'. - destruct (find y m) eqn:F; trivial. - apply find_spec in F; trivial. - SortLt. MX.order. -Qed. - -Lemma remove_Inf : forall (m:t elt)(Hm : Sort m)(x x':key)(e':elt), - Inf (x',e') m -> Inf (x',e') (remove x m). -Proof. - induction m. - simpl; intuition. - intros. - destruct a as (x'',e''). - inversion_clear H. - compute in H0. - simpl; case X.compare; intuition. - inversion_clear Hm. - apply Inf_lt with (x'',e''); auto. -Qed. -Hint Resolve remove_Inf. - -Lemma remove_sorted : forall m (Hm:Sort m) x, Sort (remove x m). -Proof. - induction m. - simpl; intuition. - intros. - destruct a as (x',e'). - simpl; case X.compare_spec; intuition; inversion_clear Hm; auto. -Qed. - -(** * [bindings] *) - -Definition bindings (m: t elt) := m. - -Lemma bindings_spec1 m x e : - InA eqke (x,e) (bindings m) <-> MapsTo x e m. -Proof. - reflexivity. -Qed. - -Lemma bindings_spec2 m (Hm:Sort m) : sort ltk (bindings m). -Proof. - auto. -Qed. - -Lemma bindings_spec2w m (Hm:Sort m) : NoDupA eqk (bindings m). -Proof. - now apply Sort_NoDupA. -Qed. - -(** * [fold] *) - -Fixpoint fold (A:Type)(f:key->elt->A->A)(m:t elt) (acc:A) : A := - match m with - | nil => acc - | (k,e)::m' => fold f m' (f k e acc) - end. - -Lemma fold_spec m : forall (A:Type)(i:A)(f:key->elt->A->A), - fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i. -Proof. - induction m as [|(k,e) m IH]; simpl; auto. -Qed. - -(** * [equal] *) - -Fixpoint equal (cmp:elt->elt->bool)(m m' : t elt) : bool := - match m, m' with - | nil, nil => true - | (x,e)::l, (x',e')::l' => - match X.compare x x' with - | Eq => cmp e e' && equal cmp l l' - | _ => false - end - | _, _ => false - end. - -Definition Equivb (cmp:elt->elt->bool) m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). - -Lemma equal_1 : forall m (Hm:Sort m) m' (Hm': Sort m') cmp, - Equivb cmp m m' -> equal cmp m m' = true. -Proof. - induction m as [|(k,e) m IH]; destruct m' as [|(k',e') m']; simpl. - - trivial. - - intros _ cmp (H,_). - exfalso. apply (@In_nil elt k'). rewrite H, In_cons. now left. - - intros _ cmp (H,_). - exfalso. apply (@In_nil elt k). rewrite <- H, In_cons. now left. - - intros Hm' cmp E. - inversion_clear Hm; inversion_clear Hm'. - case X.compare_spec; intros E'. - + apply andb_true_intro; split. - * eapply E; eauto. apply InA_cons; now left. - * apply IH; clear IH; trivial. - destruct E as (E1,E2). split. - { intros x. clear E2. - split; intros; SortLt. - specialize (E1 x); rewrite 2 In_cons in E1; simpl in E1. - destruct E1 as ([E1|E1],_); eauto. MX.order. - specialize (E1 x); rewrite 2 In_cons in E1; simpl in E1. - destruct E1 as (_,[E1|E1]); eauto. MX.order. } - { intros x xe xe' Hx HX'. eapply E2; eauto. } - + assert (IN : In k ((k',e')::m')). - { apply E. apply In_cons; now left. } - apply In_cons in IN. simpl in IN. destruct IN as [?|IN]. MX.order. - SortLt. MX.order. - + assert (IN : In k' ((k,e)::m)). - { apply E. apply In_cons; now left. } - apply In_cons in IN. simpl in IN. destruct IN as [?|IN]. MX.order. - SortLt. MX.order. -Qed. - -Lemma equal_2 m (Hm:Sort m) m' (Hm':Sort m') cmp : - equal cmp m m' = true -> Equivb cmp m m'. -Proof. - revert m' Hm'. - induction m as [|(k,e) m IH]; destruct m' as [|(k',e') m']; simpl; - try discriminate. - - split. reflexivity. inversion 1. - - intros Hm'. case X.compare_spec; try discriminate. - rewrite andb_true_iff. intros E (C,EQ). - inversion_clear Hm; inversion_clear Hm'. - apply IH in EQ; trivial. - destruct EQ as (E1,E2). - split. - + intros x. rewrite 2 In_cons; simpl. rewrite <- E1. - intuition; now left; MX.order. - + intros x ex ex'. unfold MapsTo in *. rewrite 2 InA_cons, 2 eqke_def. - intuition; subst. - * trivial. - * SortLt. MX.order. - * SortLt. MX.order. - * eapply E2; eauto. -Qed. - -Lemma equal_spec m (Hm:Sort m) m' (Hm':Sort m') cmp : - equal cmp m m' = true <-> Equivb cmp m m'. -Proof. - split. now apply equal_2. now apply equal_1. -Qed. - -(** This lemma isn't part of the spec of [Equivb], but is used in [MMapAVL] *) - -Lemma equal_cons : forall cmp l1 l2 x y, Sort (x::l1) -> Sort (y::l2) -> - eqk x y -> cmp (snd x) (snd y) = true -> - (Equivb cmp l1 l2 <-> Equivb cmp (x :: l1) (y :: l2)). -Proof. - intros. - inversion H; subst. - inversion H0; subst. - destruct x; destruct y; compute in H1, H2. - split; intros. - apply equal_2; auto. - simpl. - case X.compare_spec; intros; try MX.order. - rewrite H2; simpl. - apply equal_1; auto. - apply equal_2; auto. - generalize (equal_1 H H0 H3). - simpl. - case X.compare_spec; try discriminate. - rewrite andb_true_iff. intuition. -Qed. - -Variable elt':Type. - -(** * [map] and [mapi] *) - -Fixpoint map (f:elt -> elt') (m:t elt) : t elt' := - match m with - | nil => nil - | (k,e)::m' => (k,f e) :: map f m' - end. - -Fixpoint mapi (f: key -> elt -> elt') (m:t elt) : t elt' := - match m with - | nil => nil - | (k,e)::m' => (k,f k e) :: mapi f m' - end. - -End Elt. -Arguments find {elt} k m. -Section Elt2. -Variable elt elt' : Type. - -(** Specification of [map] *) - -Lemma map_spec (f:elt->elt') m x : - find x (map f m) = option_map f (find x m). -Proof. - induction m as [|(k,e) m IH]; simpl; trivial. - now case X.compare_spec. -Qed. - -Lemma map_Inf (f:elt->elt') m x e e' : - Inf (x,e) m -> Inf (x,e') (map f m). -Proof. - induction m as [|(x0,e0) m IH]; simpl; auto. - inversion_clear 1; auto. -Qed. -Hint Resolve map_Inf. - -Lemma map_sorted (f:elt->elt')(m: t elt)(Hm : Sort m) : - Sort (map f m). -Proof. - induction m as [|(x,e) m IH]; simpl; auto. - inversion_clear Hm. constructor; eauto. -Qed. - -(** Specification of [mapi] *) - -Lemma mapi_spec (f:key->elt->elt') m x : - exists y, X.eq y x /\ find x (mapi f m) = option_map (f y) (find x m). -Proof. - induction m as [|(k,e) m IH]; simpl. - - now exists x. - - elim X.compare_spec; intros; simpl. - + now exists k. - + now exists x. - + apply IH. -Qed. - -Lemma mapi_Inf (f:key->elt->elt') m x e : - Inf (x,e) m -> Inf (x,f x e) (mapi f m). -Proof. - induction m as [|(x0,e0) m IH]; simpl; auto. - inversion_clear 1; auto. -Qed. -Hint Resolve mapi_Inf. - -Lemma mapi_sorted (f:key->elt->elt') m (Hm : Sort m) : - Sort (mapi f m). -Proof. - induction m as [|(x,e) m IH]; simpl; auto. - inversion_clear Hm; auto. -Qed. - -End Elt2. -Section Elt3. - -(** * [merge] *) - -Variable elt elt' elt'' : Type. -Variable f : key -> option elt -> option elt' -> option elt''. - -Definition option_cons {A}(k:key)(o:option A)(l:list (key*A)) := - match o with - | Some e => (k,e)::l - | None => l - end. - -Fixpoint merge_l (m : t elt) : t elt'' := - match m with - | nil => nil - | (k,e)::l => option_cons k (f k (Some e) None) (merge_l l) - end. - -Fixpoint merge_r (m' : t elt') : t elt'' := - match m' with - | nil => nil - | (k,e')::l' => option_cons k (f k None (Some e')) (merge_r l') - end. - -Fixpoint merge (m : t elt) : t elt' -> t elt'' := - match m with - | nil => merge_r - | (k,e) :: l => - fix merge_aux (m' : t elt') : t elt'' := - match m' with - | nil => merge_l m - | (k',e') :: l' => - match X.compare k k' with - | Lt => option_cons k (f k (Some e) None) (merge l m') - | Eq => option_cons k (f k (Some e) (Some e')) (merge l l') - | Gt => option_cons k' (f k' None (Some e')) (merge_aux l') - end - end - end. - -Notation oee' := (option elt * option elt')%type. - -Fixpoint combine (m : t elt) : t elt' -> t oee' := - match m with - | nil => map (fun e' => (None,Some e')) - | (k,e) :: l => - fix combine_aux (m':t elt') : list (key * oee') := - match m' with - | nil => map (fun e => (Some e,None)) m - | (k',e') :: l' => - match X.compare k k' with - | Lt => (k,(Some e, None))::combine l m' - | Eq => (k,(Some e, Some e'))::combine l l' - | Gt => (k',(None,Some e'))::combine_aux l' - end - end - end. - -Definition fold_right_pair {A B C}(f: A->B->C->C)(l:list (A*B))(i:C) := - List.fold_right (fun p => f (fst p) (snd p)) i l. - -Definition merge' m m' := - let m0 : t oee' := combine m m' in - let m1 : t (option elt'') := mapi (fun k p => f k (fst p) (snd p)) m0 in - fold_right_pair (option_cons (A:=elt'')) m1 nil. - -Lemma merge_equiv : forall m m', merge' m m' = merge m m'. -Proof. - unfold merge'. - induction m as [|(k,e) m IHm]; intros. - - (* merge_r *) - simpl. - induction m' as [|(k',e') m' IHm']; simpl; rewrite ?IHm'; auto. - - induction m' as [|(k',e') m' IHm']; simpl. - + f_equal. - (* merge_l *) - clear k e IHm. - induction m as [|(k,e) m IHm]; simpl; rewrite ?IHm; auto. - + elim X.compare_spec; intros; simpl; f_equal. - * apply IHm. - * apply IHm. - * apply IHm'. -Qed. - -Lemma combine_Inf : - forall m m' (x:key)(e:elt)(e':elt')(e'':oee'), - Inf (x,e) m -> - Inf (x,e') m' -> - Inf (x,e'') (combine m m'). -Proof. - induction m. - - intros. simpl. eapply map_Inf; eauto. - - induction m'; intros. - + destruct a. - replace (combine ((t0, e0) :: m) nil) with - (map (fun e => (Some e,None (A:=elt'))) ((t0,e0)::m)); auto. - eapply map_Inf; eauto. - + simpl. - destruct a as (k,e0); destruct a0 as (k',e0'). - elim X.compare_spec. - * inversion_clear H; auto. - * inversion_clear H; auto. - * inversion_clear H0; auto. -Qed. -Hint Resolve combine_Inf. - -Lemma combine_sorted m (Hm : Sort m) m' (Hm' : Sort m') : - Sort (combine m m'). -Proof. - revert m' Hm'. - induction m. - - intros; clear Hm. simpl. apply map_sorted; auto. - - induction m'; intros. - + clear Hm'. - destruct a. - replace (combine ((t0, e) :: m) nil) with - (map (fun e => (Some e,None (A:=elt'))) ((t0,e)::m)); auto. - apply map_sorted; auto. - + simpl. - destruct a as (k,e); destruct a0 as (k',e'). - inversion_clear Hm; inversion_clear Hm'. - case X.compare_spec; [intros Heq| intros Hlt| intros Hlt]; - constructor; auto. - * assert (Inf (k, e') m') by (apply Inf_eq with (k',e'); auto). - exact (combine_Inf _ H0 H3). - * assert (Inf (k, e') ((k',e')::m')) by auto. - exact (combine_Inf _ H0 H3). - * assert (Inf (k', e) ((k,e)::m)) by auto. - exact (combine_Inf _ H3 H2). -Qed. - -Lemma merge_sorted m (Hm : Sort m) m' (Hm' : Sort m') : - Sort (merge m m'). -Proof. - intros. - rewrite <- merge_equiv. - unfold merge'. - assert (Hmm':=combine_sorted Hm Hm'). - set (l0:=combine m m') in *; clearbody l0. - set (f':= fun k p => f k (fst p) (snd p)). - assert (H1:=mapi_sorted f' Hmm'). - set (l1:=mapi f' l0) in *; clearbody l1. - clear f' f Hmm' l0 Hm Hm' m m'. - (* Sort fold_right_pair *) - induction l1. - - simpl; auto. - - inversion_clear H1. - destruct a; destruct o; auto. - simpl. - constructor; auto. - clear IHl1. - (* Inf fold_right_pair *) - induction l1. - + simpl; auto. - + destruct a; destruct o; simpl; auto. - * inversion_clear H0; auto. - * inversion_clear H0. inversion_clear H. - compute in H1. - apply IHl1; auto. - apply Inf_lt with (t1, None); auto. -Qed. - -Definition at_least_one (o:option elt)(o':option elt') := - match o, o' with - | None, None => None - | _, _ => Some (o,o') - end. - -Lemma combine_spec m (Hm : Sort m) m' (Hm' : Sort m') (x:key) : - find x (combine m m') = at_least_one (find x m) (find x m'). -Proof. - revert m' Hm'. - induction m. - intros. - simpl. - induction m'. - intros; simpl; auto. - simpl; destruct a. - simpl; destruct (X.compare x t0); simpl; auto. - inversion_clear Hm'; auto. - induction m'. - (* m' = nil *) - intros; destruct a; simpl. - destruct (X.compare_spec x t0) as [ |Hlt|Hlt]; simpl; auto. - inversion_clear Hm; clear H0 Hlt Hm' IHm t0. - induction m; simpl; auto. - inversion_clear H. - destruct a. - simpl; destruct (X.compare x t0); simpl; auto. - (* m' <> nil *) - intros. - destruct a as (k,e); destruct a0 as (k',e'); simpl. - inversion Hm; inversion Hm'; subst. - destruct (X.compare_spec k k'); simpl; - destruct (X.compare_spec x k); - MX.order || destruct (X.compare_spec x k'); - simpl; try MX.order; auto. - - rewrite IHm; auto; simpl. elim X.compare_spec; auto; MX.order. - - rewrite IHm; auto; simpl. elim X.compare_spec; auto; MX.order. - - rewrite IHm; auto; simpl. elim X.compare_spec; auto; MX.order. - - change (find x (combine ((k, e) :: m) m') = Some (Some e, find x m')). - rewrite IHm'; auto; simpl. elim X.compare_spec; auto; MX.order. - - change (find x (combine ((k, e) :: m) m') = at_least_one None (find x m')). - rewrite IHm'; auto; simpl. elim X.compare_spec; auto; MX.order. - - change (find x (combine ((k, e) :: m) m') = - at_least_one (find x m) (find x m')). - rewrite IHm'; auto; simpl. elim X.compare_spec; auto; MX.order. -Qed. - -Definition at_least_one_then_f k (o:option elt)(o':option elt') := - match o, o' with - | None, None => None - | _, _ => f k o o' - end. - -Lemma merge_spec0 m (Hm : Sort m) m' (Hm' : Sort m') (x:key) : - exists y, X.eq y x /\ - find x (merge m m') = at_least_one_then_f y (find x m) (find x m'). -Proof. - intros. - rewrite <- merge_equiv. - unfold merge'. - assert (H:=combine_spec Hm Hm' x). - assert (H2:=combine_sorted Hm Hm'). - set (f':= fun k p => f k (fst p) (snd p)). - set (m0 := combine m m') in *; clearbody m0. - set (o:=find x m) in *; clearbody o. - set (o':=find x m') in *; clearbody o'. - clear Hm Hm' m m'. revert H. - match goal with |- ?G => - assert (G/\(find x m0 = None -> - find x (fold_right_pair option_cons (mapi f' m0) nil) = None)); - [|intuition] end. - induction m0; simpl in *; intuition. - - exists x; split; [easy|]. - destruct o; destruct o'; simpl in *; try discriminate; auto. - - destruct a as (k,(oo,oo')); simpl in *. - inversion_clear H2. - destruct (X.compare_spec x k) as [Heq|Hlt|Hlt]; simpl in *. - + (* x = k *) - exists k; split; [easy|]. - assert (at_least_one_then_f k o o' = f k oo oo'). - { destruct o; destruct o'; simpl in *; inversion_clear H; auto. } - rewrite H2. - unfold f'; simpl. - destruct (f k oo oo'); simpl. - * elim X.compare_spec; trivial; try MX.order. - * destruct (IHm0 H0) as (_,H4); apply H4; auto. - case_eq (find x m0); intros; auto. - assert (eqk (elt:=oee') (k,(oo,oo')) (x,(oo,oo'))). - now compute. - symmetry in H5. - destruct (Sort_Inf_NotIn H0 (Inf_eq H5 H1)). - exists p; apply find_spec; auto. - + (* x < k *) - destruct (f' k (oo,oo')); simpl. - * elim X.compare_spec; trivial; try MX.order. - destruct o; destruct o'; simpl in *; try discriminate; auto. - now exists x. - * apply IHm0; trivial. - rewrite <- H. - case_eq (find x m0); intros; auto. - assert (ltk (elt:=oee') (x,(oo,oo')) (k,(oo,oo'))). - red; auto. - destruct (Sort_Inf_NotIn H0 (Inf_lt H3 H1)). - exists p; apply find_spec; auto. - + (* k < x *) - unfold f'; simpl. - destruct (f k oo oo'); simpl. - * elim X.compare_spec; trivial; try MX.order. - intros. apply IHm0; auto. - * apply IHm0; auto. - - - (* None -> None *) - destruct a as (k,(oo,oo')). - simpl. - inversion_clear H2. - destruct (X.compare_spec x k) as [Hlt|Heq|Hlt]; try discriminate. - + (* x < k *) - unfold f'; simpl. - destruct (f k oo oo'); simpl. - elim X.compare_spec; trivial; try MX.order. intros. - apply IHm0; auto. - case_eq (find x m0); intros; auto. - assert (ltk (elt:=oee') (x,(oo,oo')) (k,(oo,oo'))). - now compute. - destruct (Sort_Inf_NotIn H0 (Inf_lt H3 H1)). - exists p; apply find_spec; auto. - + (* k < x *) - unfold f'; simpl. - destruct (f k oo oo'); simpl. - elim X.compare_spec; trivial; try MX.order. intros. - apply IHm0; auto. - apply IHm0; auto. -Qed. - -(** Specification of [merge] *) - -Lemma merge_spec1 m (Hm : Sort m) m' (Hm' : Sort m')(x:key) : - In x m \/ In x m' -> - exists y, X.eq y x /\ - find x (merge m m') = f y (find x m) (find x m'). -Proof. - intros. - destruct (merge_spec0 Hm Hm' x) as (y,(Hy,H')). - exists y; split; [easy|]. rewrite H'. - destruct H as [(e,H)|(e,H)]; - apply find_spec in H; trivial; rewrite H; simpl; auto. - now destruct (find x m). -Qed. - -Lemma merge_spec2 m (Hm : Sort m) m' (Hm' : Sort m')(x:key) : - In x (merge m m') -> In x m \/ In x m'. -Proof. - intros. - destruct H as (e,H). - apply find_spec in H; auto using merge_sorted. - destruct (merge_spec0 Hm Hm' x) as (y,(Hy,H')). - rewrite H in H'. - destruct (find x m) eqn:F. - - apply find_spec in F; eauto. - - destruct (find x m') eqn:F'. - + apply find_spec in F'; eauto. - + simpl in H'. discriminate. -Qed. - -End Elt3. -End Raw. - -Module Make (X: OrderedType) <: S with Module E := X. -Module Raw := Raw X. -Module E := X. - -Definition key := E.t. -Definition eq_key {elt} := @Raw.PX.eqk elt. -Definition eq_key_elt {elt} := @Raw.PX.eqke elt. -Definition lt_key {elt} := @Raw.PX.ltk elt. - -Record t_ (elt:Type) := Mk - {this :> Raw.t elt; - sorted : sort Raw.PX.ltk this}. -Definition t := t_. - -Definition empty {elt} := Mk (Raw.empty_sorted elt). - -Section Elt. - Variable elt elt' elt'':Type. - - Implicit Types m : t elt. - Implicit Types x y : key. - Implicit Types e : elt. - - Definition is_empty m : bool := Raw.is_empty m.(this). - Definition add x e m : t elt := Mk (Raw.add_sorted m.(sorted) x e). - Definition find x m : option elt := Raw.find x m.(this). - Definition remove x m : t elt := Mk (Raw.remove_sorted m.(sorted) x). - Definition mem x m : bool := Raw.mem x m.(this). - Definition map f m : t elt' := Mk (Raw.map_sorted f m.(sorted)). - Definition mapi (f:key->elt->elt') m : t elt' := - Mk (Raw.mapi_sorted f m.(sorted)). - Definition merge f m (m':t elt') : t elt'' := - Mk (Raw.merge_sorted f m.(sorted) m'.(sorted)). - Definition bindings m : list (key*elt) := Raw.bindings m.(this). - Definition cardinal m := length m.(this). - Definition fold {A:Type}(f:key->elt->A->A) m (i:A) : A := - Raw.fold f m.(this) i. - Definition equal cmp m m' : bool := Raw.equal cmp m.(this) m'.(this). - - Definition MapsTo x e m : Prop := Raw.PX.MapsTo x e m.(this). - Definition In x m : Prop := Raw.PX.In x m.(this). - - Definition Equal m m' := forall y, find y m = find y m'. - Definition Equiv (eq_elt:elt->elt->Prop) m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). - Definition Equivb cmp m m' : Prop := @Raw.Equivb elt cmp m.(this) m'.(this). - - Instance MapsTo_compat : - Proper (E.eq==>Logic.eq==>Logic.eq==>iff) MapsTo. - Proof. - intros x x' Hx e e' <- m m' <-. unfold MapsTo. now rewrite Hx. - Qed. - - Lemma find_spec m : forall x e, find x m = Some e <-> MapsTo x e m. - Proof. exact (Raw.find_spec m.(sorted)). Qed. - - Lemma mem_spec m : forall x, mem x m = true <-> In x m. - Proof. exact (Raw.mem_spec m.(sorted)). Qed. - - Lemma empty_spec : forall x, find x empty = None. - Proof. exact (Raw.empty_spec _). Qed. - - Lemma is_empty_spec m : is_empty m = true <-> (forall x, find x m = None). - Proof. exact (Raw.is_empty_spec m.(this)). Qed. - - Lemma add_spec1 m : forall x e, find x (add x e m) = Some e. - Proof. exact (Raw.add_spec1 m.(this)). Qed. - Lemma add_spec2 m : forall x y e, ~E.eq x y -> find y (add x e m) = find y m. - Proof. exact (Raw.add_spec2 m.(this)). Qed. - - Lemma remove_spec1 m : forall x, find x (remove x m) = None. - Proof. exact (Raw.remove_spec1 m.(sorted)). Qed. - Lemma remove_spec2 m : forall x y, ~E.eq x y -> find y (remove x m) = find y m. - Proof. exact (Raw.remove_spec2 m.(sorted)). Qed. - - Lemma bindings_spec1 m : forall x e, - InA eq_key_elt (x,e) (bindings m) <-> MapsTo x e m. - Proof. exact (Raw.bindings_spec1 m.(this)). Qed. - Lemma bindings_spec2w m : NoDupA eq_key (bindings m). - Proof. exact (Raw.bindings_spec2w m.(sorted)). Qed. - Lemma bindings_spec2 m : sort lt_key (bindings m). - Proof. exact (Raw.bindings_spec2 m.(sorted)). Qed. - - Lemma cardinal_spec m : cardinal m = length (bindings m). - Proof. reflexivity. Qed. - - Lemma fold_spec m : forall (A : Type) (i : A) (f : key -> elt -> A -> A), - fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i. - Proof. exact (Raw.fold_spec m.(this)). Qed. - - Lemma equal_spec m m' : forall cmp, equal cmp m m' = true <-> Equivb cmp m m'. - Proof. exact (Raw.equal_spec m.(sorted) m'.(sorted)). Qed. - -End Elt. - - Lemma map_spec {elt elt'} (f:elt->elt') m : - forall x, find x (map f m) = option_map f (find x m). - Proof. exact (Raw.map_spec f m.(this)). Qed. - - Lemma mapi_spec {elt elt'} (f:key->elt->elt') m : - forall x, exists y, - E.eq y x /\ find x (mapi f m) = option_map (f y) (find x m). - Proof. exact (Raw.mapi_spec f m.(this)). Qed. - - Lemma merge_spec1 {elt elt' elt''} - (f:key->option elt->option elt'->option elt'') m m' : - forall x, - In x m \/ In x m' -> - exists y, E.eq y x /\ find x (merge f m m') = f y (find x m) (find x m'). - Proof. exact (Raw.merge_spec1 f m.(sorted) m'.(sorted)). Qed. - - Lemma merge_spec2 {elt elt' elt''} - (f:key->option elt->option elt'->option elt'') m m' : - forall x, - In x (merge f m m') -> In x m \/ In x m'. - Proof. exact (Raw.merge_spec2 m.(sorted) m'.(sorted)). Qed. - -End Make. - -Module Make_ord (X: OrderedType)(D : OrderedType) <: -Sord with Module Data := D - with Module MapS.E := X. - -Module Data := D. -Module MapS := Make(X). -Import MapS. - -Module MD := OrderedTypeFacts(D). -Import MD. - -Definition t := MapS.t D.t. - -Definition cmp e e' := - match D.compare e e' with Eq => true | _ => false end. - -Fixpoint eq_list (m m' : list (X.t * D.t)) : Prop := - match m, m' with - | nil, nil => True - | (x,e)::l, (x',e')::l' => - match X.compare x x' with - | Eq => D.eq e e' /\ eq_list l l' - | _ => False - end - | _, _ => False - end. - -Definition eq m m' := eq_list m.(this) m'.(this). - -Fixpoint lt_list (m m' : list (X.t * D.t)) : Prop := - match m, m' with - | nil, nil => False - | nil, _ => True - | _, nil => False - | (x,e)::l, (x',e')::l' => - match X.compare x x' with - | Lt => True - | Gt => False - | Eq => D.lt e e' \/ (D.eq e e' /\ lt_list l l') - end - end. - -Definition lt m m' := lt_list m.(this) m'.(this). - -Lemma eq_equal : forall m m', eq m m' <-> equal cmp m m' = true. -Proof. - intros (l,Hl); induction l. - intros (l',Hl'); unfold eq; simpl. - destruct l'; unfold equal; simpl; intuition. - intros (l',Hl'); unfold eq. - destruct l'. - destruct a; unfold equal; simpl; intuition. - destruct a as (x,e). - destruct p as (x',e'). - unfold equal; simpl. - destruct (X.compare_spec x x') as [Hlt|Heq|Hlt]; simpl; intuition. - unfold cmp at 1. - elim D.compare_spec; try MD.order; simpl. - inversion_clear Hl. - inversion_clear Hl'. - destruct (IHl H (Mk H3)). - unfold equal, eq in H5; simpl in H5; auto. - destruct (andb_prop _ _ H); clear H. - generalize H0; unfold cmp. - elim D.compare_spec; try MD.order; simpl; try discriminate. - destruct (andb_prop _ _ H); clear H. - inversion_clear Hl. - inversion_clear Hl'. - destruct (IHl H (Mk H3)). - unfold equal, eq in H6; simpl in H6; auto. -Qed. - -Lemma eq_spec m m' : eq m m' <-> Equivb cmp m m'. -Proof. - now rewrite eq_equal, equal_spec. -Qed. - -Lemma eq_refl : forall m : t, eq m m. -Proof. - intros (m,Hm); induction m; unfold eq; simpl; auto. - destruct a. - destruct (X.compare_spec t0 t0) as [Hlt|Heq|Hlt]; auto. - - split. reflexivity. inversion_clear Hm. apply (IHm H). - - MapS.Raw.MX.order. - - MapS.Raw.MX.order. -Qed. - -Lemma eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1. -Proof. - intros (m,Hm); induction m; - intros (m', Hm'); destruct m'; unfold eq; simpl; - try destruct a as (x,e); try destruct p as (x',e'); auto. - destruct (X.compare_spec x x') as [Hlt|Heq|Hlt]; - elim X.compare_spec; try MapS.Raw.MX.order; intuition. - inversion_clear Hm; inversion_clear Hm'. - apply (IHm H0 (Mk H4)); auto. -Qed. - -Lemma eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3. -Proof. - intros (m1,Hm1); induction m1; - intros (m2, Hm2); destruct m2; - intros (m3, Hm3); destruct m3; unfold eq; simpl; - try destruct a as (x,e); - try destruct p as (x',e'); - try destruct p0 as (x'',e''); try contradiction; auto. - destruct (X.compare_spec x x') as [Hlt|Heq|Hlt]; - destruct (X.compare_spec x' x'') as [Hlt'|Heq'|Hlt']; - elim X.compare_spec; try MapS.Raw.MX.order; intuition. - now transitivity e'. - inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm3. - apply (IHm1 H1 (Mk H6) (Mk H8)); intuition. -Qed. - -Instance eq_equiv : Equivalence eq. -Proof. split; [exact eq_refl|exact eq_sym|exact eq_trans]. Qed. - -Lemma lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3. -Proof. - intros (m1,Hm1); induction m1; - intros (m2, Hm2); destruct m2; - intros (m3, Hm3); destruct m3; unfold lt; simpl; - try destruct a as (x,e); - try destruct p as (x',e'); - try destruct p0 as (x'',e''); try contradiction; auto. - destruct (X.compare_spec x x') as [Hlt|Heq|Hlt]; - destruct (X.compare_spec x' x'') as [Hlt'|Heq'|Hlt']; - elim X.compare_spec; try MapS.Raw.MX.order; intuition. - left; transitivity e'; auto. - left; MD.order. - left; MD.order. - right. - split. - transitivity e'; auto. - inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm3. - apply (IHm1 H2 (Mk H6) (Mk H8)); intuition. -Qed. - -Lemma lt_irrefl : forall m, ~ lt m m. -Proof. - intros (m,Hm); induction m; unfold lt; simpl; auto. - destruct a. - destruct (X.compare_spec t0 t0) as [Hlt|Heq|Hlt]; auto. - - intuition. MD.order. inversion_clear Hm. now apply (IHm H0). - - MapS.Raw.MX.order. -Qed. - -Instance lt_strorder : StrictOrder lt. -Proof. split; [exact lt_irrefl|exact lt_trans]. Qed. - -Lemma lt_compat1 : forall m1 m1' m2, eq m1 m1' -> lt m1 m2 -> lt m1' m2. -Proof. - intros (m1,Hm1); induction m1; - intros (m1',Hm1'); destruct m1'; - intros (m2,Hm2); destruct m2; unfold eq, lt; - try destruct a as (x,e); - try destruct p as (x',e'); - try destruct p0 as (x'',e''); try contradiction; simpl; auto. - destruct (X.compare_spec x x') as [Hlt|Heq|Hlt]; - destruct (X.compare_spec x' x'') as [Hlt'|Heq'|Hlt']; - elim X.compare_spec; try MapS.Raw.MX.order; intuition. - left; MD.order. - right. - split. - MD.order. - inversion_clear Hm1; inversion_clear Hm1'; inversion_clear Hm2. - apply (IHm1 H0 (Mk H6) (Mk H8)); intuition. -Qed. - -Lemma lt_compat2 : forall m1 m2 m2', eq m2 m2' -> lt m1 m2 -> lt m1 m2'. -Proof. - intros (m1,Hm1); induction m1; - intros (m2,Hm2); destruct m2; - intros (m2',Hm2'); destruct m2'; unfold eq, lt; - try destruct a as (x,e); - try destruct p as (x',e'); - try destruct p0 as (x'',e''); try contradiction; simpl; auto. - destruct (X.compare_spec x x') as [Hlt|Heq|Hlt]; - destruct (X.compare_spec x' x'') as [Hlt'|Heq'|Hlt']; - elim X.compare_spec; try MapS.Raw.MX.order; intuition. - left; MD.order. - right. - split. - MD.order. - inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm2'. - apply (IHm1 H0 (Mk H6) (Mk H8)); intuition. -Qed. - -Instance lt_compat : Proper (eq==>eq==>iff) lt. -Proof. - intros m1 m1' H1 m2 m2' H2. split; intros. - now apply (lt_compat2 H2), (lt_compat1 H1). - symmetry in H1, H2. - now apply (lt_compat2 H2), (lt_compat1 H1). -Qed. - -Ltac cmp_solve := - unfold eq, lt; simpl; elim X.compare_spec; try Raw.MX.order; auto. - -Fixpoint compare_list m1 m2 := match m1, m2 with -| nil, nil => Eq -| nil, _ => Lt -| _, nil => Gt -| (k1,e1)::m1, (k2,e2)::m2 => - match X.compare k1 k2 with - | Lt => Lt - | Gt => Gt - | Eq => match D.compare e1 e2 with - | Lt => Lt - | Gt => Gt - | Eq => compare_list m1 m2 - end - end -end. - -Definition compare m1 m2 := compare_list m1.(this) m2.(this). - -Lemma compare_spec : forall m1 m2, CompSpec eq lt m1 m2 (compare m1 m2). -Proof. - unfold CompSpec. - intros (m1,Hm1)(m2,Hm2). unfold compare, eq, lt; simpl. - revert m2 Hm2. - induction m1 as [|(k1,e1) m1 IH1]; destruct m2 as [|(k2,e2) m2]; - try constructor; simpl; intros; auto. - elim X.compare_spec; simpl; try constructor; auto; intros. - elim D.compare_spec; simpl; try constructor; auto; intros. - inversion_clear Hm1; inversion_clear Hm2. - destruct (IH1 H1 _ H3); simpl; try constructor; auto. - elim X.compare_spec; try Raw.MX.order. right. now split. - elim X.compare_spec; try Raw.MX.order. now left. - elim X.compare_spec; try Raw.MX.order; auto. -Qed. - -End Make_ord. diff --git a/theories/MMaps/MMapPositive.v b/theories/MMaps/MMapPositive.v deleted file mode 100644 index d3aab2389..000000000 --- a/theories/MMaps/MMapPositive.v +++ /dev/null @@ -1,698 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) -(* \VV/ *************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(***********************************************************************) - -(** * MMapPositive : an implementation of MMapInterface for [positive] keys. *) - -Require Import Bool PeanoNat BinPos Orders OrdersEx OrdersLists MMapInterface. - -Set Implicit Arguments. -Local Open Scope lazy_bool_scope. -Local Open Scope positive_scope. -Local Unset Elimination Schemes. - -(** This file is an adaptation to the [MMap] framework of a work by - Xavier Leroy and Sandrine Blazy (used for building certified compilers). - Keys are of type [positive], and maps are binary trees: the sequence - of binary digits of a positive number corresponds to a path in such a tree. - This is quite similar to the [IntMap] library, except that no path - compression is implemented, and that the current file is simple enough to be - self-contained. *) - -(** Reverses the positive [y] and concatenate it with [x] *) - -Fixpoint rev_append (y x : positive) : positive := - match y with - | 1 => x - | y~1 => rev_append y x~1 - | y~0 => rev_append y x~0 - end. -Local Infix "@" := rev_append (at level 60). -Definition rev x := x@1. - -(** The module of maps over positive keys *) - -Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. - - Module E:=PositiveOrderedTypeBits. - Module ME:=KeyOrderedType E. - - Definition key := positive : Type. - - Definition eq_key {A} (p p':key*A) := E.eq (fst p) (fst p'). - - Definition eq_key_elt {A} (p p':key*A) := - E.eq (fst p) (fst p') /\ (snd p) = (snd p'). - - Definition lt_key {A} (p p':key*A) := E.lt (fst p) (fst p'). - - Instance eqk_equiv {A} : Equivalence (@eq_key A) := _. - Instance eqke_equiv {A} : Equivalence (@eq_key_elt A) := _. - Instance ltk_strorder {A} : StrictOrder (@lt_key A) := _. - - Inductive tree (A : Type) := - | Leaf : tree A - | Node : tree A -> option A -> tree A -> tree A. - - Arguments Leaf {A}. - - Scheme tree_ind := Induction for tree Sort Prop. - - Definition t := tree. - - Definition empty {A} : t A := Leaf. - - Section A. - Variable A:Type. - - Fixpoint is_empty (m : t A) : bool := - match m with - | Leaf => true - | Node l None r => (is_empty l) &&& (is_empty r) - | _ => false - end. - - Fixpoint find (i : key) (m : t A) : option A := - match m with - | Leaf => None - | Node l o r => - match i with - | xH => o - | xO ii => find ii l - | xI ii => find ii r - end - end. - - Fixpoint mem (i : key) (m : t A) : bool := - match m with - | Leaf => false - | Node l o r => - match i with - | xH => match o with None => false | _ => true end - | xO ii => mem ii l - | xI ii => mem ii r - end - end. - - Fixpoint add (i : key) (v : A) (m : t A) : t A := - match m with - | Leaf => - match i with - | xH => Node Leaf (Some v) Leaf - | xO ii => Node (add ii v Leaf) None Leaf - | xI ii => Node Leaf None (add ii v Leaf) - end - | Node l o r => - match i with - | xH => Node l (Some v) r - | xO ii => Node (add ii v l) o r - | xI ii => Node l o (add ii v r) - end - end. - - (** helper function to avoid creating empty trees that are not leaves *) - - Definition node (l : t A) (o: option A) (r : t A) : t A := - match o,l,r with - | None,Leaf,Leaf => Leaf - | _,_,_ => Node l o r - end. - - Fixpoint remove (i : key) (m : t A) : t A := - match m with - | Leaf => Leaf - | Node l o r => - match i with - | xH => node l None r - | xO ii => node (remove ii l) o r - | xI ii => node l o (remove ii r) - end - end. - - (** [bindings] *) - - Fixpoint xbindings (m : t A) (i : positive) (a: list (key*A)) := - match m with - | Leaf => a - | Node l None r => xbindings l i~0 (xbindings r i~1 a) - | Node l (Some e) r => xbindings l i~0 ((rev i,e) :: xbindings r i~1 a) - end. - - Definition bindings (m : t A) := xbindings m 1 nil. - - (** [cardinal] *) - - Fixpoint cardinal (m : t A) : nat := - match m with - | Leaf => 0%nat - | Node l None r => (cardinal l + cardinal r)%nat - | Node l (Some _) r => S (cardinal l + cardinal r) - end. - - (** Specification proofs *) - - Definition MapsTo (i:key)(v:A)(m:t A) := find i m = Some v. - Definition In (i:key)(m:t A) := exists e:A, MapsTo i e m. - - Lemma MapsTo_compat : Proper (E.eq==>eq==>eq==>iff) MapsTo. - Proof. - intros k k' Hk e e' He m m' Hm. red in Hk. now subst. - Qed. - - Lemma find_spec m x e : find x m = Some e <-> MapsTo x e m. - Proof. reflexivity. Qed. - - Lemma mem_find : - forall m x, mem x m = match find x m with None => false | _ => true end. - Proof. - induction m; destruct x; simpl; auto. - Qed. - - Lemma mem_spec : forall m x, mem x m = true <-> In x m. - Proof. - unfold In, MapsTo; intros m x; rewrite mem_find. - split. - - destruct (find x m). - exists a; auto. - intros; discriminate. - - destruct 1 as (e0,H0); rewrite H0; auto. - Qed. - - Lemma gleaf : forall (i : key), find i Leaf = None. - Proof. destruct i; simpl; auto. Qed. - - Theorem empty_spec: - forall (i: key), find i empty = None. - Proof. exact gleaf. Qed. - - Lemma is_empty_spec m : - is_empty m = true <-> forall k, find k m = None. - Proof. - induction m; simpl. - - intuition. apply empty_spec. - - destruct o. split; try discriminate. - intros H. now specialize (H xH). - rewrite <- andb_lazy_alt, andb_true_iff, IHm1, IHm2. - clear IHm1 IHm2. - split. - + intros (H1,H2) k. destruct k; simpl; auto. - + intros H; split; intros k. apply (H (xO k)). apply (H (xI k)). - Qed. - - Theorem add_spec1: - forall (m: t A) (i: key) (x: A), find i (add i x m) = Some x. - Proof. - intros m i; revert m. - induction i; destruct m; simpl; auto. - Qed. - - Theorem add_spec2: - forall (m: t A) (i j: key) (x: A), - i <> j -> find j (add i x m) = find j m. - Proof. - intros m i j; revert m i. - induction j; destruct i, m; simpl; intros; - rewrite ?IHj, ?gleaf; auto; try congruence. - Qed. - - Lemma rleaf : forall (i : key), remove i Leaf = Leaf. - Proof. destruct i; simpl; auto. Qed. - - Lemma gnode l o r i : find i (node l o r) = find i (Node l o r). - Proof. - destruct o,l,r; simpl; trivial. - destruct i; simpl; now rewrite ?gleaf. - Qed. - - Opaque node. - - Theorem remove_spec1: - forall (m: t A)(i: key), find i (remove i m) = None. - Proof. - induction m; simpl. - - intros; rewrite rleaf. apply gleaf. - - destruct i; simpl remove; rewrite gnode; simpl; auto. - Qed. - - Theorem remove_spec2: - forall (m: t A)(i j: key), - i <> j -> find j (remove i m) = find j m. - Proof. - induction m; simpl; intros. - - now rewrite rleaf. - - destruct i; simpl; rewrite gnode; destruct j; simpl; trivial; - try apply IHm1; try apply IHm2; congruence. - Qed. - - Local Notation InL := (InA eq_key_elt). - - Lemma xbindings_spec: forall m j acc k e, - InL (k,e) (xbindings m j acc) <-> - InL (k,e) acc \/ exists x, k=(j@x) /\ find x m = Some e. - Proof. - induction m as [|l IHl o r IHr]; simpl. - - intros. split; intro H. - + now left. - + destruct H as [H|[x [_ H]]]. assumption. - now rewrite gleaf in H. - - intros j acc k e. case o as [e'|]; - rewrite IHl, ?InA_cons, IHr; clear IHl IHr; split. - + intros [[H|[H|H]]|H]; auto. - * unfold eq_key_elt, E.eq, fst, snd in H. destruct H as (->,<-). - right. now exists 1. - * destruct H as (x,(->,H)). right. now exists x~1. - * destruct H as (x,(->,H)). right. now exists x~0. - + intros [H|H]; auto. - destruct H as (x,(->,H)). - destruct x; simpl in *. - * left. right. right. now exists x. - * right. now exists x. - * left. left. injection H as ->. reflexivity. - + intros [[H|H]|H]; auto. - * destruct H as (x,(->,H)). right. now exists x~1. - * destruct H as (x,(->,H)). right. now exists x~0. - + intros [H|H]; auto. - destruct H as (x,(->,H)). - destruct x; simpl in *. - * left. right. now exists x. - * right. now exists x. - * discriminate. - Qed. - - Lemma lt_rev_append: forall j x y, E.lt x y -> E.lt (j@x) (j@y). - Proof. induction j; intros; simpl; auto. Qed. - - Lemma xbindings_sort m j acc : - sort lt_key acc -> - (forall x p, In x m -> InL p acc -> E.lt (j@x) (fst p)) -> - sort lt_key (xbindings m j acc). - Proof. - revert j acc. - induction m as [|l IHl o r IHr]; simpl; trivial. - intros j acc Hacc Hsacc. destruct o as [e|]. - - apply IHl;[constructor;[apply IHr; [apply Hacc|]|]|]. - + intros. now apply Hsacc. - + case_eq (xbindings r j~1 acc); [constructor|]. - intros (z,e') q H. constructor. - assert (H': InL (z,e') (xbindings r j~1 acc)). - { rewrite H. now constructor. } - clear H q. rewrite xbindings_spec in H'. - destruct H' as [H'|H']. - * apply (Hsacc 1 (z,e')); trivial. now exists e. - * destruct H' as (x,(->,H)). - red. simpl. now apply lt_rev_append. - + intros x (y,e') Hx Hy. inversion_clear Hy. - rewrite H. simpl. now apply lt_rev_append. - rewrite xbindings_spec in H. - destruct H as [H|H]. - * now apply Hsacc. - * destruct H as (z,(->,H)). simpl. - now apply lt_rev_append. - - apply IHl; [apply IHr; [apply Hacc|]|]. - + intros. now apply Hsacc. - + intros x (y,e') Hx H. rewrite xbindings_spec in H. - destruct H as [H|H]. - * now apply Hsacc. - * destruct H as (z,(->,H)). simpl. - now apply lt_rev_append. - Qed. - - Lemma bindings_spec1 m k e : - InA eq_key_elt (k,e) (bindings m) <-> MapsTo k e m. - Proof. - unfold bindings, MapsTo. rewrite xbindings_spec. - split; [ intros [H|(y & H & H')] | intros IN ]. - - inversion H. - - simpl in *. now subst. - - right. now exists k. - Qed. - - Lemma bindings_spec2 m : sort lt_key (bindings m). - Proof. - unfold bindings. - apply xbindings_sort. constructor. inversion 2. - Qed. - - Lemma bindings_spec2w m : NoDupA eq_key (bindings m). - Proof. - apply ME.Sort_NoDupA. - apply bindings_spec2. - Qed. - - Lemma xbindings_length m j acc : - length (xbindings m j acc) = (cardinal m + length acc)%nat. - Proof. - revert j acc. - induction m; simpl; trivial; intros. - destruct o; simpl; rewrite IHm1; simpl; rewrite IHm2; - now rewrite ?Nat.add_succ_r, Nat.add_assoc. - Qed. - - Lemma cardinal_spec m : cardinal m = length (bindings m). - Proof. - unfold bindings. rewrite xbindings_length. simpl. - symmetry. apply Nat.add_0_r. - Qed. - - (** [map] and [mapi] *) - - Variable B : Type. - - Section Mapi. - - Variable f : key -> option A -> option B. - - Fixpoint xmapi (m : t A) (i : key) : t B := - match m with - | Leaf => Leaf - | Node l o r => Node (xmapi l (i~0)) - (f (rev i) o) - (xmapi r (i~1)) - end. - - End Mapi. - - Definition mapi (f : key -> A -> B) m := - xmapi (fun k => option_map (f k)) m 1. - - Definition map (f : A -> B) m := mapi (fun _ => f) m. - - End A. - - Lemma xgmapi: - forall (A B: Type) (f: key -> option A -> option B) (i j : key) (m: t A), - (forall k, f k None = None) -> - find i (xmapi f m j) = f (j@i) (find i m). - Proof. - induction i; intros; destruct m; simpl; rewrite ?IHi; auto. - Qed. - - Theorem mapi_spec0 : - forall (A B: Type) (f: key -> A -> B) (i: key) (m: t A), - find i (mapi f m) = option_map (f i) (find i m). - Proof. - intros. unfold mapi. rewrite xgmapi; simpl; auto. - Qed. - - Lemma mapi_spec : - forall (A B: Type) (f: key -> A -> B) (m: t A) (i:key), - exists j, E.eq j i /\ - find i (mapi f m) = option_map (f j) (find i m). - Proof. - intros. - exists i. split. reflexivity. apply mapi_spec0. - Qed. - - Lemma map_spec : - forall (elt elt':Type)(f:elt->elt')(m: t elt)(x:key), - find x (map f m) = option_map f (find x m). - Proof. - intros; unfold map. apply mapi_spec0. - Qed. - - Section merge. - Variable A B C : Type. - Variable f : key -> option A -> option B -> option C. - - Fixpoint xmerge (m1 : t A)(m2 : t B)(i:positive) : t C := - match m1 with - | Leaf => xmapi (fun k => f k None) m2 i - | Node l1 o1 r1 => - match m2 with - | Leaf => xmapi (fun k o => f k o None) m1 i - | Node l2 o2 r2 => - Node (xmerge l1 l2 (i~0)) - (f (rev i) o1 o2) - (xmerge r1 r2 (i~1)) - end - end. - - Lemma xgmerge: forall (i j: key)(m1:t A)(m2: t B), - (forall i, f i None None = None) -> - find i (xmerge m1 m2 j) = f (j@i) (find i m1) (find i m2). - Proof. - induction i; intros; destruct m1; destruct m2; simpl; auto; - rewrite ?xgmapi, ?IHi; simpl; auto. - Qed. - - End merge. - - Definition merge {A B C}(f:key->option A->option B->option C) m1 m2 := - xmerge - (fun k o1 o2 => match o1,o2 with - | None,None => None - | _, _ => f k o1 o2 - end) - m1 m2 xH. - - Lemma merge_spec1 {A B C}(f:key->option A->option B->option C) : - forall m m' x, - In x m \/ In x m' -> - exists y, E.eq y x /\ - find x (merge f m m') = f y (find x m) (find x m'). - Proof. - intros. exists x. split. reflexivity. - unfold merge. - rewrite xgmerge; simpl; auto. - rewrite <- 2 mem_spec, 2 mem_find in H. - destruct (find x m); simpl; auto. - destruct (find x m'); simpl; auto. intuition discriminate. - Qed. - - Lemma merge_spec2 {A B C}(f:key->option A->option B->option C) : - forall m m' x, In x (merge f m m') -> In x m \/ In x m'. - Proof. - intros. - rewrite <-mem_spec, mem_find in H. - unfold merge in H. - rewrite xgmerge in H; simpl; auto. - rewrite <- 2 mem_spec, 2 mem_find. - destruct (find x m); simpl in *; auto. - destruct (find x m'); simpl in *; auto. - Qed. - - Section Fold. - - Variables A B : Type. - Variable f : key -> A -> B -> B. - - (** the additional argument, [i], records the current path, in - reverse order (this should be more efficient: we reverse this argument - only at present nodes only, rather than at each node of the tree). - we also use this convention in all functions below - *) - - Fixpoint xfold (m : t A) (v : B) (i : key) := - match m with - | Leaf => v - | Node l (Some x) r => - xfold r (f (rev i) x (xfold l v i~0)) i~1 - | Node l None r => - xfold r (xfold l v i~0) i~1 - end. - Definition fold m i := xfold m i 1. - - End Fold. - - Lemma fold_spec : - forall {A}(m:t A){B}(i : B) (f : key -> A -> B -> B), - fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i. - Proof. - unfold fold, bindings. intros A m B i f. revert m i. - set (f' := fun a p => f (fst p) (snd p) a). - assert (H: forall m i j acc, - fold_left f' acc (xfold f m i j) = - fold_left f' (xbindings m j acc) i). - { induction m as [|l IHl o r IHr]; intros; trivial. - destruct o; simpl; now rewrite IHr, <- IHl. } - intros. exact (H m i 1 nil). - Qed. - - Fixpoint equal (A:Type)(cmp : A -> A -> bool)(m1 m2 : t A) : bool := - match m1, m2 with - | Leaf, _ => is_empty m2 - | _, Leaf => is_empty m1 - | Node l1 o1 r1, Node l2 o2 r2 => - (match o1, o2 with - | None, None => true - | Some v1, Some v2 => cmp v1 v2 - | _, _ => false - end) - &&& equal cmp l1 l2 &&& equal cmp r1 r2 - end. - - Definition Equal (A:Type)(m m':t A) := - forall y, find y m = find y m'. - Definition Equiv (A:Type)(eq_elt:A->A->Prop) m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). - Definition Equivb (A:Type)(cmp: A->A->bool) := Equiv (Cmp cmp). - - Lemma equal_1 : forall (A:Type)(m m':t A)(cmp:A->A->bool), - Equivb cmp m m' -> equal cmp m m' = true. - Proof. - induction m. - - (* m = Leaf *) - destruct 1 as (E,_); simpl. - apply is_empty_spec; intros k. - destruct (find k m') eqn:F; trivial. - assert (H : In k m') by now exists a. - rewrite <- E in H. - destruct H as (x,H). red in H. now rewrite gleaf in H. - - (* m = Node *) - destruct m'. - + (* m' = Leaf *) - destruct 1 as (E,_); simpl. - destruct o. - * assert (H : In xH (@Leaf A)). - { rewrite <- E. now exists a. } - destruct H as (e,H). now red in H. - * apply andb_true_intro; split; apply is_empty_spec; intros k. - destruct (find k m1) eqn:F; trivial. - assert (H : In (xO k) (@Leaf A)). - { rewrite <- E. exists a; auto. } - destruct H as (x,H). red in H. now rewrite gleaf in H. - destruct (find k m2) eqn:F; trivial. - assert (H : In (xI k) (@Leaf A)). - { rewrite <- E. exists a; auto. } - destruct H as (x,H). red in H. now rewrite gleaf in H. - + (* m' = Node *) - destruct 1. - assert (Equivb cmp m1 m'1). - { split. - intros k; generalize (H (xO k)); unfold In, MapsTo; simpl; auto. - intros k e e'; generalize (H0 (xO k) e e'); unfold In, MapsTo; simpl; auto. } - assert (Equivb cmp m2 m'2). - { split. - intros k; generalize (H (xI k)); unfold In, MapsTo; simpl; auto. - intros k e e'; generalize (H0 (xI k) e e'); unfold In, MapsTo; simpl; auto. } - simpl. - destruct o; destruct o0; simpl. - repeat (apply andb_true_intro; split); auto. - apply (H0 xH); red; auto. - generalize (H xH); unfold In, MapsTo; simpl; intuition. - destruct H4; try discriminate; eauto. - generalize (H xH); unfold In, MapsTo; simpl; intuition. - destruct H5; try discriminate; eauto. - apply andb_true_intro; split; auto. - Qed. - - Lemma equal_2 : forall (A:Type)(m m':t A)(cmp:A->A->bool), - equal cmp m m' = true -> Equivb cmp m m'. - Proof. - induction m. - (* m = Leaf *) - simpl. - split; intros. - split. - destruct 1; red in H0; destruct k; discriminate. - rewrite is_empty_spec in H. - intros (e,H'). red in H'. now rewrite H in H'. - red in H0; destruct k; discriminate. - (* m = Node *) - destruct m'. - (* m' = Leaf *) - simpl. - destruct o; intros; try discriminate. - destruct (andb_prop _ _ H); clear H. - split; intros. - split; unfold In, MapsTo; destruct 1. - destruct k; simpl in *; try discriminate. - rewrite is_empty_spec in H1. - now rewrite H1 in H. - rewrite is_empty_spec in H0. - now rewrite H0 in H. - destruct k; simpl in *; discriminate. - unfold In, MapsTo; destruct k; simpl in *; discriminate. - (* m' = Node *) - destruct o; destruct o0; simpl; intros; try discriminate. - destruct (andb_prop _ _ H); clear H. - destruct (andb_prop _ _ H0); clear H0. - destruct (IHm1 _ _ H2); clear H2 IHm1. - destruct (IHm2 _ _ H1); clear H1 IHm2. - split; intros. - destruct k; unfold In, MapsTo in *; simpl; auto. - split; eauto. - destruct k; unfold In, MapsTo in *; simpl in *. - eapply H4; eauto. - eapply H3; eauto. - congruence. - destruct (andb_prop _ _ H); clear H. - destruct (IHm1 _ _ H0); clear H0 IHm1. - destruct (IHm2 _ _ H1); clear H1 IHm2. - split; intros. - destruct k; unfold In, MapsTo in *; simpl; auto. - split; eauto. - destruct k; unfold In, MapsTo in *; simpl in *. - eapply H3; eauto. - eapply H2; eauto. - try discriminate. - Qed. - - Lemma equal_spec : forall (A:Type)(m m':t A)(cmp:A->A->bool), - equal cmp m m' = true <-> Equivb cmp m m'. - Proof. - split. apply equal_2. apply equal_1. - Qed. - -End PositiveMap. - -(** Here come some additionnal facts about this implementation. - Most are facts that cannot be derivable from the general interface. *) - -Module PositiveMapAdditionalFacts. - Import PositiveMap. - - (* Derivable from the Map interface *) - Theorem gsspec {A} i j x (m: t A) : - find i (add j x m) = if E.eq_dec i j then Some x else find i m. - Proof. - destruct (E.eq_dec i j) as [->|]; - [ apply add_spec1 | apply add_spec2; auto ]. - Qed. - - (* Not derivable from the Map interface *) - Theorem gsident {A} i (m:t A) v : - find i m = Some v -> add i v m = m. - Proof. - revert m. - induction i; destruct m; simpl in *; try congruence. - - intro H; now rewrite (IHi m2 H). - - intro H; now rewrite (IHi m1 H). - Qed. - - Lemma xmapi_ext {A B}(f g: key -> option A -> option B) : - (forall k (o : option A), f k o = g k o) -> - forall m i, xmapi f m i = xmapi g m i. - Proof. - induction m; intros; simpl; auto. now f_equal. - Qed. - - Theorem xmerge_commut{A B C} - (f: key -> option A -> option B -> option C) - (g: key -> option B -> option A -> option C) : - (forall k o1 o2, f k o1 o2 = g k o2 o1) -> - forall m1 m2 i, xmerge f m1 m2 i = xmerge g m2 m1 i. - Proof. - intros E. - induction m1; destruct m2; intros i; simpl; trivial; f_equal; - try apply IHm1_1; try apply IHm1_2; try apply xmapi_ext; - intros; apply E. - Qed. - - Theorem merge_commut{A B C} - (f: key -> option A -> option B -> option C) - (g: key -> option B -> option A -> option C) : - (forall k o1 o2, f k o1 o2 = g k o2 o1) -> - forall m1 m2, merge f m1 m2 = merge g m2 m1. - Proof. - intros E m1 m2. - unfold merge. apply xmerge_commut. - intros k [x1|] [x2|]; trivial. - Qed. - -End PositiveMapAdditionalFacts. diff --git a/theories/MMaps/MMapWeakList.v b/theories/MMaps/MMapWeakList.v deleted file mode 100644 index 656c61e11..000000000 --- a/theories/MMaps/MMapWeakList.v +++ /dev/null @@ -1,687 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) -(* \VV/ *************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(***********************************************************************) - -(** * Finite map library *) - -(** This file proposes an implementation of the non-dependant interface - [MMapInterface.WS] using lists of pairs, unordered but without redundancy. *) - -Require Import MMapInterface EqualitiesFacts. - -Set Implicit Arguments. -Unset Strict Implicit. - -Lemma Some_iff {A} (a a' : A) : Some a = Some a' <-> a = a'. -Proof. split; congruence. Qed. - -Module Raw (X:DecidableType). - -Module Import PX := KeyDecidableType X. - -Definition key := X.t. -Definition t (elt:Type) := list (X.t * elt). - -Ltac dec := match goal with - | |- context [ X.eq_dec ?x ?x ] => - let E := fresh "E" in destruct (X.eq_dec x x) as [E|E]; [ | now elim E] - | H : X.eq ?x ?y |- context [ X.eq_dec ?x ?y ] => - let E := fresh "E" in destruct (X.eq_dec x y) as [_|E]; [ | now elim E] - | H : ~X.eq ?x ?y |- context [ X.eq_dec ?x ?y ] => - let E := fresh "E" in destruct (X.eq_dec x y) as [E|_]; [ now elim H | ] - | |- context [ X.eq_dec ?x ?y ] => - let E := fresh "E" in destruct (X.eq_dec x y) as [E|E] -end. - -Section Elt. - -Variable elt : Type. -Notation NoDupA := (@NoDupA _ eqk). - -(** * [find] *) - -Fixpoint find (k:key) (s: t elt) : option elt := - match s with - | nil => None - | (k',x)::s' => if X.eq_dec k k' then Some x else find k s' - end. - -Lemma find_spec : forall m (Hm:NoDupA m) x e, - find x m = Some e <-> MapsTo x e m. -Proof. - unfold PX.MapsTo. - induction m as [ | (k,e) m IH]; simpl. - - split; inversion 1. - - intros Hm k' e'. rewrite InA_cons. - change (eqke (k',e') (k,e)) with (X.eq k' k /\ e' = e). - inversion_clear Hm. dec. - + rewrite Some_iff; intuition. - elim H. apply InA_eqk with (k',e'); auto. - + rewrite IH; intuition. -Qed. - -(** * [mem] *) - -Fixpoint mem (k : key) (s : t elt) : bool := - match s with - | nil => false - | (k',_) :: l => if X.eq_dec k k' then true else mem k l - end. - -Lemma mem_spec : forall m (Hm:NoDupA m) x, mem x m = true <-> In x m. -Proof. - induction m as [ | (k,e) m IH]; simpl; intros Hm x. - - split. discriminate. inversion_clear 1. inversion H0. - - inversion_clear Hm. rewrite PX.In_cons; simpl. - rewrite <- IH by trivial. - dec; intuition. -Qed. - -(** * [empty] *) - -Definition empty : t elt := nil. - -Lemma empty_spec x : find x empty = None. -Proof. - reflexivity. -Qed. - -Lemma empty_NoDup : NoDupA empty. -Proof. - unfold empty; auto. -Qed. - -(** * [is_empty] *) - -Definition is_empty (l : t elt) : bool := if l then true else false. - -Lemma is_empty_spec m : is_empty m = true <-> forall x, find x m = None. -Proof. - destruct m; simpl; intuition; try discriminate. - specialize (H a). - revert H. now dec. -Qed. - -(* Not part of the exported specifications, used later for [merge]. *) - -Lemma find_eq : forall m (Hm:NoDupA m) x x', - X.eq x x' -> find x m = find x' m. -Proof. - induction m; simpl; auto; destruct a; intros. - inversion_clear Hm. - rewrite (IHm H1 x x'); auto. - dec; dec; trivial. - elim E0. now transitivity x. - elim E. now transitivity x'. -Qed. - -(** * [add] *) - -Fixpoint add (k : key) (x : elt) (s : t elt) : t elt := - match s with - | nil => (k,x) :: nil - | (k',y) :: l => if X.eq_dec k k' then (k,x)::l else (k',y)::add k x l - end. - -Lemma add_spec1 m x e : find x (add x e m) = Some e. -Proof. - induction m as [ | (k,e') m IH]; simpl. - - now dec. - - dec; simpl; now dec. -Qed. - -Lemma add_spec2 m x y e : ~X.eq x y -> find y (add x e m) = find y m. -Proof. - intros N. - assert (N' : ~X.eq y x) by now contradict N. - induction m as [ | (k,e') m IH]; simpl. - - dec; trivial. - - repeat (dec; simpl); trivial. elim N. now transitivity k. -Qed. - -Lemma add_InA : forall m x y e e', - ~ X.eq x y -> InA eqk (y,e) (add x e' m) -> InA eqk (y,e) m. -Proof. - induction m as [ | (k,e') m IH]; simpl; intros. - - inversion_clear H0. elim H. symmetry; apply H1. inversion_clear H1. - - revert H0; dec; rewrite !InA_cons. - + rewrite E. intuition. - + intuition. right; eapply IH; eauto. -Qed. - -Lemma add_NoDup : forall m (Hm:NoDupA m) x e, NoDupA (add x e m). -Proof. - induction m as [ | (k,e') m IH]; simpl; intros Hm x e. - - constructor; auto. now inversion 1. - - inversion_clear Hm. dec; constructor; auto. - + contradict H. apply InA_eqk with (x,e); auto. - + contradict H; apply add_InA with x e; auto. -Qed. - -(** * [remove] *) - -Fixpoint remove (k : key) (s : t elt) : t elt := - match s with - | nil => nil - | (k',x) :: l => if X.eq_dec k k' then l else (k',x) :: remove k l - end. - -Lemma remove_spec1 m (Hm: NoDupA m) x : find x (remove x m) = None. -Proof. - induction m as [ | (k,e') m IH]; simpl; trivial. - inversion_clear Hm. - repeat (dec; simpl); auto. - destruct (find x m) eqn:F; trivial. - apply find_spec in F; trivial. - elim H. apply InA_eqk with (x,e); auto. -Qed. - -Lemma remove_spec2 m (Hm: NoDupA m) x y : ~X.eq x y -> - find y (remove x m) = find y m. -Proof. - induction m as [ | (k,e') m IH]; simpl; trivial; intros E. - inversion_clear Hm. - repeat (dec; simpl); auto. - elim E. now transitivity k. -Qed. - -Lemma remove_InA : forall m (Hm:NoDupA m) x y e, - InA eqk (y,e) (remove x m) -> InA eqk (y,e) m. -Proof. - induction m as [ | (k,e') m IH]; simpl; trivial; intros. - inversion_clear Hm. - revert H; dec; rewrite !InA_cons; intuition. - right; eapply H; eauto. -Qed. - -Lemma remove_NoDup : forall m (Hm:NoDupA m) x, NoDupA (remove x m). -Proof. - induction m. - simpl; intuition. - intros. - inversion_clear Hm. - destruct a as (x',e'). - simpl; case (X.eq_dec x x'); auto. - constructor; auto. - contradict H; apply remove_InA with x; auto. -Qed. - -(** * [bindings] *) - -Definition bindings (m: t elt) := m. - -Lemma bindings_spec1 m x e : InA eqke (x,e) (bindings m) <-> MapsTo x e m. -Proof. - reflexivity. -Qed. - -Lemma bindings_spec2w m (Hm:NoDupA m) : NoDupA (bindings m). -Proof. - trivial. -Qed. - -(** * [fold] *) - -Fixpoint fold (A:Type)(f:key->elt->A->A)(m:t elt) (acc : A) : A := - match m with - | nil => acc - | (k,e)::m' => fold f m' (f k e acc) - end. - -Lemma fold_spec : forall m (A:Type)(i:A)(f:key->elt->A->A), - fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i. -Proof. - induction m as [ | (k,e) m IH]; simpl; auto. -Qed. - -(** * [equal] *) - -Definition check (cmp : elt -> elt -> bool)(k:key)(e:elt)(m': t elt) := - match find k m' with - | None => false - | Some e' => cmp e e' - end. - -Definition submap (cmp : elt -> elt -> bool)(m m' : t elt) : bool := - fold (fun k e b => andb (check cmp k e m') b) m true. - -Definition equal (cmp : elt -> elt -> bool)(m m' : t elt) : bool := - andb (submap cmp m m') (submap (fun e' e => cmp e e') m' m). - -Definition Submap (cmp:elt->elt->bool) m m' := - (forall k, In k m -> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). - -Definition Equivb (cmp:elt->elt->bool) m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). - -Lemma submap_1 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, - Submap cmp m m' -> submap cmp m m' = true. -Proof. - unfold Submap, submap. - induction m. - simpl; auto. - destruct a; simpl; intros. - destruct H. - inversion_clear Hm. - assert (H3 : In t0 m'). - { apply H; exists e; auto with *. } - destruct H3 as (e', H3). - assert (H4 : find t0 m' = Some e') by now apply find_spec. - unfold check at 2. rewrite H4. - rewrite (H0 t0); simpl; auto with *. - eapply IHm; auto. - split; intuition. - apply H. - destruct H6 as (e'',H6); exists e''; auto. - apply H0 with k; auto. -Qed. - -Lemma submap_2 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, - submap cmp m m' = true -> Submap cmp m m'. -Proof. - unfold Submap, submap. - induction m. - simpl; auto. - intuition. - destruct H0; inversion H0. - inversion H0. - - destruct a; simpl; intros. - inversion_clear Hm. - rewrite andb_b_true in H. - assert (check cmp t0 e m' = true). - clear H1 H0 Hm' IHm. - set (b:=check cmp t0 e m') in *. - generalize H; clear H; generalize b; clear b. - induction m; simpl; auto; intros. - destruct a; simpl in *. - destruct (andb_prop _ _ (IHm _ H)); auto. - rewrite H2 in H. - destruct (IHm H1 m' Hm' cmp H); auto. - unfold check in H2. - case_eq (find t0 m'); [intros e' H5 | intros H5]; - rewrite H5 in H2; try discriminate. - split; intros. - destruct H6 as (e0,H6); inversion_clear H6. - compute in H7; destruct H7; subst. - exists e'. - apply PX.MapsTo_eq with t0; auto with *. - apply find_spec; auto. - apply H3. - exists e0; auto. - inversion_clear H6. - compute in H8; destruct H8; subst. - assert (H8 : MapsTo t0 e'0 m'). { eapply PX.MapsTo_eq; eauto. } - apply find_spec in H8; trivial. congruence. - apply H4 with k; auto. -Qed. - -(** Specification of [equal] *) - -Lemma equal_spec : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, - equal cmp m m' = true <-> Equivb cmp m m'. -Proof. - unfold Equivb, equal. - split. - - intros. - destruct (andb_prop _ _ H); clear H. - generalize (submap_2 Hm Hm' H0). - generalize (submap_2 Hm' Hm H1). - firstorder. - - intuition. - apply andb_true_intro; split; apply submap_1; unfold Submap; firstorder. -Qed. -End Elt. -Section Elt2. -Variable elt elt' : Type. - -(** * [map] and [mapi] *) - -Fixpoint map (f:elt -> elt') (m:t elt) : t elt' := - match m with - | nil => nil - | (k,e)::m' => (k,f e) :: map f m' - end. - -Fixpoint mapi (f: key -> elt -> elt') (m:t elt) : t elt' := - match m with - | nil => nil - | (k,e)::m' => (k,f k e) :: mapi f m' - end. - -(** Specification of [map] *) - -Lemma map_spec (f:elt->elt')(m:t elt)(x:key) : - find x (map f m) = option_map f (find x m). -Proof. - induction m as [ | (k,e) m IH]; simpl; trivial. - dec; simpl; trivial. -Qed. - -Lemma map_NoDup m (Hm : NoDupA (@eqk elt) m)(f:elt->elt') : - NoDupA (@eqk elt') (map f m). -Proof. - induction m; simpl; auto. - intros. - destruct a as (x',e'). - inversion_clear Hm. - constructor; auto. - contradict H. - clear IHm H0. - induction m; simpl in *; auto. - inversion H. - destruct a; inversion H; auto. -Qed. - -(** Specification of [mapi] *) - -Lemma mapi_spec (f:key->elt->elt')(m:t elt)(x:key) : - exists y, X.eq y x /\ find x (mapi f m) = option_map (f y) (find x m). -Proof. - induction m as [ | (k,e) m IH]; simpl; trivial. - - now exists x. - - dec; simpl. - + now exists k. - + destruct IH as (y,(Hy,H)). now exists y. -Qed. - -Lemma mapi_NoDup : forall m (Hm : NoDupA (@eqk elt) m)(f: key->elt->elt'), - NoDupA (@eqk elt') (mapi f m). -Proof. - induction m; simpl; auto. - intros. - destruct a as (x',e'). - inversion_clear Hm; auto. - constructor; auto. - contradict H. - clear IHm H0. - induction m; simpl in *; auto. - inversion_clear H. - destruct a; inversion_clear H; auto. -Qed. - -End Elt2. - -Lemma mapfst_InA {elt}(m:t elt) x : - InA X.eq x (List.map fst m) <-> In x m. -Proof. - induction m as [| (k,e) m IH]; simpl; auto. - - split; inversion 1. inversion H0. - - rewrite InA_cons, In_cons. simpl. now rewrite IH. -Qed. - -Lemma mapfst_NoDup {elt}(m:t elt) : - NoDupA X.eq (List.map fst m) <-> NoDupA eqk m. -Proof. - induction m as [| (k,e) m IH]; simpl. - - split; constructor. - - split; inversion_clear 1; constructor; try apply IH; trivial. - + contradict H0. rewrite mapfst_InA. eapply In_alt'; eauto. - + rewrite mapfst_InA. contradict H0. now apply In_alt'. -Qed. - -Lemma filter_NoDup f (m:list key) : - NoDupA X.eq m -> NoDupA X.eq (List.filter f m). -Proof. - induction 1; simpl. - - constructor. - - destruct (f x); trivial. constructor; trivial. - contradict H. rewrite InA_alt in *. destruct H as (y,(Hy,H)). - exists y; split; trivial. now rewrite filter_In in H. -Qed. - -Lemma NoDupA_unique_repr (l:list key) x y : - NoDupA X.eq l -> X.eq x y -> List.In x l -> List.In y l -> x = y. -Proof. - intros H E Hx Hy. - induction H; simpl in *. - - inversion Hx. - - intuition; subst; trivial. - elim H. apply InA_alt. now exists y. - elim H. apply InA_alt. now exists x. -Qed. - -Section Elt3. - -Variable elt elt' elt'' : Type. - -Definition restrict (m:t elt)(k:key) := - match find k m with - | None => true - | Some _ => false - end. - -Definition domains (m:t elt)(m':t elt') := - List.map fst m ++ List.filter (restrict m) (List.map fst m'). - -Lemma domains_InA m m' (Hm : NoDupA eqk m) x : - InA X.eq x (domains m m') <-> In x m \/ In x m'. -Proof. - unfold domains. - assert (Proper (X.eq==>eq) (restrict m)). - { intros k k' Hk. unfold restrict. now rewrite (find_eq Hm Hk). } - rewrite InA_app_iff, filter_InA, !mapfst_InA; intuition. - unfold restrict. - destruct (find x m) eqn:F. - - left. apply find_spec in F; trivial. now exists e. - - now right. -Qed. - -Lemma domains_NoDup m m' : NoDupA eqk m -> NoDupA eqk m' -> - NoDupA X.eq (domains m m'). -Proof. - intros Hm Hm'. unfold domains. - apply NoDupA_app; auto with *. - - now apply mapfst_NoDup. - - now apply filter_NoDup, mapfst_NoDup. - - intros x. - rewrite mapfst_InA. intros (e,H). - apply find_spec in H; trivial. - rewrite InA_alt. intros (y,(Hy,H')). - rewrite (find_eq Hm Hy) in H. - rewrite filter_In in H'. destruct H' as (_,H'). - unfold restrict in H'. now rewrite H in H'. -Qed. - -Fixpoint fold_keys (f:key->option elt'') l := - match l with - | nil => nil - | k::l => - match f k with - | Some e => (k,e)::fold_keys f l - | None => fold_keys f l - end - end. - -Lemma fold_keys_In f l x e : - List.In (x,e) (fold_keys f l) <-> List.In x l /\ f x = Some e. -Proof. - induction l as [|k l IH]; simpl. - - intuition. - - destruct (f k) eqn:F; simpl; rewrite IH; clear IH; intuition; - try left; congruence. -Qed. - -Lemma fold_keys_NoDup f l : - NoDupA X.eq l -> NoDupA eqk (fold_keys f l). -Proof. - induction 1; simpl. - - constructor. - - destruct (f x); trivial. - constructor; trivial. contradict H. - apply InA_alt in H. destruct H as ((k,e'),(E,H)). - rewrite fold_keys_In in H. - apply InA_alt. exists k. now split. -Qed. - -Variable f : key -> option elt -> option elt' -> option elt''. - -Definition merge m m' : t elt'' := - fold_keys (fun k => f k (find k m) (find k m')) (domains m m'). - -Lemma merge_NoDup m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m') : - NoDupA (@eqk elt'') (merge m m'). -Proof. - now apply fold_keys_NoDup, domains_NoDup. -Qed. - -Lemma merge_spec1 m (Hm:NoDupA eqk m) m' (Hm':NoDupA eqk m') x : - In x m \/ In x m' -> - exists y:key, X.eq y x /\ - find x (merge m m') = f y (find x m) (find x m'). -Proof. - assert (Hmm' : NoDupA eqk (merge m m')) by now apply merge_NoDup. - rewrite <- domains_InA; trivial. - rewrite InA_alt. intros (y,(Hy,H)). - exists y; split; [easy|]. - rewrite (find_eq Hm Hy), (find_eq Hm' Hy). - destruct (f y (find y m) (find y m')) eqn:F. - - apply find_spec; trivial. - red. apply InA_alt. exists (y,e). split. now split. - unfold merge. apply fold_keys_In. now split. - - destruct (find x (merge m m')) eqn:F'; trivial. - rewrite <- F; clear F. symmetry. - apply find_spec in F'; trivial. - red in F'. rewrite InA_alt in F'. - destruct F' as ((y',e'),(E,F')). - unfold merge in F'; rewrite fold_keys_In in F'. - destruct F' as (H',F'). - compute in E; destruct E as (Hy',<-). - replace y with y'; trivial. - apply (@NoDupA_unique_repr (domains m m')); auto. - now apply domains_NoDup. - now transitivity x. -Qed. - -Lemma merge_spec2 m (Hm:NoDupA eqk m) m' (Hm':NoDupA eqk m') x : - In x (merge m m') -> In x m \/ In x m'. -Proof. - rewrite <- domains_InA; trivial. - intros (e,H). red in H. rewrite InA_alt in H. destruct H as ((k,e'),(E,H)). - unfold merge in H; rewrite fold_keys_In in H. destruct H as (H,_). - apply InA_alt. exists k. split; trivial. now destruct E. -Qed. - -End Elt3. -End Raw. - - -Module Make (X: DecidableType) <: WS with Module E:=X. - Module Raw := Raw X. - - Module E := X. - Definition key := E.t. - Definition eq_key {elt} := @Raw.PX.eqk elt. - Definition eq_key_elt {elt} := @Raw.PX.eqke elt. - - Record t_ (elt:Type) := Mk - {this :> Raw.t elt; - nodup : NoDupA Raw.PX.eqk this}. - Definition t := t_. - - Definition empty {elt} : t elt := Mk (Raw.empty_NoDup elt). - -Section Elt. - Variable elt elt' elt'':Type. - Implicit Types m : t elt. - Implicit Types x y : key. - Implicit Types e : elt. - - Definition find x m : option elt := Raw.find x m.(this). - Definition mem x m : bool := Raw.mem x m.(this). - Definition is_empty m : bool := Raw.is_empty m.(this). - Definition add x e m : t elt := Mk (Raw.add_NoDup m.(nodup) x e). - Definition remove x m : t elt := Mk (Raw.remove_NoDup m.(nodup) x). - Definition map f m : t elt' := Mk (Raw.map_NoDup m.(nodup) f). - Definition mapi (f:key->elt->elt') m : t elt' := - Mk (Raw.mapi_NoDup m.(nodup) f). - Definition merge f m (m':t elt') : t elt'' := - Mk (Raw.merge_NoDup f m.(nodup) m'.(nodup)). - Definition bindings m : list (key*elt) := Raw.bindings m.(this). - Definition cardinal m := length m.(this). - Definition fold {A}(f:key->elt->A->A) m (i:A) : A := Raw.fold f m.(this) i. - Definition equal cmp m m' : bool := Raw.equal cmp m.(this) m'.(this). - Definition MapsTo x e m : Prop := Raw.PX.MapsTo x e m.(this). - Definition In x m : Prop := Raw.PX.In x m.(this). - - Definition Equal m m' := forall y, find y m = find y m'. - Definition Equiv (eq_elt:elt->elt->Prop) m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). - Definition Equivb cmp m m' : Prop := Raw.Equivb cmp m.(this) m'.(this). - - Instance MapsTo_compat : - Proper (E.eq==>Logic.eq==>Logic.eq==>iff) MapsTo. - Proof. - intros x x' Hx e e' <- m m' <-. unfold MapsTo. now rewrite Hx. - Qed. - - Lemma find_spec m : forall x e, find x m = Some e <-> MapsTo x e m. - Proof. exact (Raw.find_spec m.(nodup)). Qed. - - Lemma mem_spec m : forall x, mem x m = true <-> In x m. - Proof. exact (Raw.mem_spec m.(nodup)). Qed. - - Lemma empty_spec : forall x, find x empty = None. - Proof. exact (Raw.empty_spec _). Qed. - - Lemma is_empty_spec m : is_empty m = true <-> (forall x, find x m = None). - Proof. exact (Raw.is_empty_spec m.(this)). Qed. - - Lemma add_spec1 m : forall x e, find x (add x e m) = Some e. - Proof. exact (Raw.add_spec1 m.(this)). Qed. - Lemma add_spec2 m : forall x y e, ~E.eq x y -> find y (add x e m) = find y m. - Proof. exact (Raw.add_spec2 m.(this)). Qed. - - Lemma remove_spec1 m : forall x, find x (remove x m) = None. - Proof. exact (Raw.remove_spec1 m.(nodup)). Qed. - Lemma remove_spec2 m : forall x y, ~E.eq x y -> find y (remove x m) = find y m. - Proof. exact (Raw.remove_spec2 m.(nodup)). Qed. - - Lemma bindings_spec1 m : forall x e, - InA eq_key_elt (x,e) (bindings m) <-> MapsTo x e m. - Proof. exact (Raw.bindings_spec1 m.(this)). Qed. - Lemma bindings_spec2w m : NoDupA eq_key (bindings m). - Proof. exact (Raw.bindings_spec2w m.(nodup)). Qed. - - Lemma cardinal_spec m : cardinal m = length (bindings m). - Proof. reflexivity. Qed. - - Lemma fold_spec m : forall (A : Type) (i : A) (f : key -> elt -> A -> A), - fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i. - Proof. exact (Raw.fold_spec m.(this)). Qed. - - Lemma equal_spec m m' : forall cmp, equal cmp m m' = true <-> Equivb cmp m m'. - Proof. exact (Raw.equal_spec m.(nodup) m'.(nodup)). Qed. - -End Elt. - - Lemma map_spec {elt elt'} (f:elt->elt') m : - forall x, find x (map f m) = option_map f (find x m). - Proof. exact (Raw.map_spec f m.(this)). Qed. - - Lemma mapi_spec {elt elt'} (f:key->elt->elt') m : - forall x, exists y, - E.eq y x /\ find x (mapi f m) = option_map (f y) (find x m). - Proof. exact (Raw.mapi_spec f m.(this)). Qed. - - Lemma merge_spec1 {elt elt' elt''} - (f:key->option elt->option elt'->option elt'') m m' : - forall x, - In x m \/ In x m' -> - exists y, E.eq y x /\ find x (merge f m m') = f y (find x m) (find x m'). - Proof. exact (Raw.merge_spec1 f m.(nodup) m'.(nodup)). Qed. - - Lemma merge_spec2 {elt elt' elt''} - (f:key->option elt->option elt'->option elt'') m m' : - forall x, - In x (merge f m m') -> In x m \/ In x m'. - Proof. exact (Raw.merge_spec2 m.(nodup) m'.(nodup)). Qed. - -End Make. diff --git a/theories/MMaps/vo.itarget b/theories/MMaps/vo.itarget deleted file mode 100644 index a7bbd266e..000000000 --- a/theories/MMaps/vo.itarget +++ /dev/null @@ -1,7 +0,0 @@ -MMapInterface.vo -MMapFacts.vo -MMapWeakList.vo -MMapList.vo -MMapPositive.vo -MMaps.vo -MMapAVL.vo
\ No newline at end of file diff --git a/theories/NArith/BinNat.v b/theories/NArith/BinNat.v index 641ec02fa..4c3985737 100644 --- a/theories/NArith/BinNat.v +++ b/theories/NArith/BinNat.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/NArith/BinNatDef.v b/theories/NArith/BinNatDef.v index 9de2e7e10..4df4242e8 100644 --- a/theories/NArith/BinNatDef.v +++ b/theories/NArith/BinNatDef.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/NArith/NArith.v b/theories/NArith/NArith.v index 436145430..12d3ad2fd 100644 --- a/theories/NArith/NArith.v +++ b/theories/NArith/NArith.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/NArith/Ndec.v b/theories/NArith/Ndec.v index 5b1815bd4..37fd9dded 100644 --- a/theories/NArith/Ndec.v +++ b/theories/NArith/Ndec.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/NArith/Ndigits.v b/theories/NArith/Ndigits.v index 55ef451ee..a1e51c9d3 100644 --- a/theories/NArith/Ndigits.v +++ b/theories/NArith/Ndigits.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/NArith/Ndist.v b/theories/NArith/Ndist.v index 5467f9cb0..0ab8be587 100644 --- a/theories/NArith/Ndist.v +++ b/theories/NArith/Ndist.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/NArith/Ndiv_def.v b/theories/NArith/Ndiv_def.v index 5ae388e31..4bdf6529f 100644 --- a/theories/NArith/Ndiv_def.v +++ b/theories/NArith/Ndiv_def.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/NArith/Ngcd_def.v b/theories/NArith/Ngcd_def.v index 1750ffeb9..277fd26f0 100644 --- a/theories/NArith/Ngcd_def.v +++ b/theories/NArith/Ngcd_def.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/NArith/Nnat.v b/theories/NArith/Nnat.v index 0dcaa71de..4e007878f 100644 --- a/theories/NArith/Nnat.v +++ b/theories/NArith/Nnat.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/NArith/Nsqrt_def.v b/theories/NArith/Nsqrt_def.v index da7829a9c..dd44b6e2d 100644 --- a/theories/NArith/Nsqrt_def.v +++ b/theories/NArith/Nsqrt_def.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/BigNumPrelude.v b/theories/Numbers/BigNumPrelude.v index 6817947c8..45a7527c9 100644 --- a/theories/Numbers/BigNumPrelude.v +++ b/theories/Numbers/BigNumPrelude.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/BinNums.v b/theories/Numbers/BinNums.v index 1dd5d82ab..e4f3cd6cf 100644 --- a/theories/Numbers/BinNums.v +++ b/theories/Numbers/BinNums.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v index 8b84a484b..3312161ae 100644 --- a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v +++ b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Cyclic/Abstract/NZCyclic.v b/theories/Numbers/Cyclic/Abstract/NZCyclic.v index 8adeda37d..df9b83392 100644 --- a/theories/Numbers/Cyclic/Abstract/NZCyclic.v +++ b/theories/Numbers/Cyclic/Abstract/NZCyclic.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v index a7c288624..407bcca4b 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v index e68cd0336..e94a891dd 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v index e137349ef..4ebe8fac1 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v index cd55f9d8c..09d7329b6 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v index 6a1d741ea..195527dd5 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v index ff9f50a55..f65b47c8c 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v index 537f557db..b99013900 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v index ab8c8617a..d07ce3018 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v index c1f314e9f..abd567a85 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Cyclic/Int31/Cyclic31.v b/theories/Numbers/Cyclic/Int31/Cyclic31.v index aca572166..0e58b8155 100644 --- a/theories/Numbers/Cyclic/Int31/Cyclic31.v +++ b/theories/Numbers/Cyclic/Int31/Cyclic31.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Cyclic/Int31/Int31.v b/theories/Numbers/Cyclic/Int31/Int31.v index f5e936cf0..ff4b998e7 100644 --- a/theories/Numbers/Cyclic/Int31/Int31.v +++ b/theories/Numbers/Cyclic/Int31/Int31.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Cyclic/Int31/Ring31.v b/theories/Numbers/Cyclic/Int31/Ring31.v index 4fde3f53e..d160f5f1d 100644 --- a/theories/Numbers/Cyclic/Int31/Ring31.v +++ b/theories/Numbers/Cyclic/Int31/Ring31.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -19,13 +19,13 @@ Local Open Scope list_scope. Ltac isInt31cst_lst l := match l with - | nil => constr:true + | nil => constr:(true) | ?t::?l => match t with | D1 => isInt31cst_lst l | D0 => isInt31cst_lst l - | _ => constr:false + | _ => constr:(false) end - | _ => constr:false + | _ => constr:(false) end. Ltac isInt31cst t := @@ -38,17 +38,17 @@ Ltac isInt31cst t := ::i11::i12::i13::i14::i15::i16::i17::i18::i19::i20 ::i21::i22::i23::i24::i25::i26::i27::i28::i29::i30::nil) in isInt31cst_lst l - | Int31.On => constr:true - | Int31.In => constr:true - | Int31.Tn => constr:true - | Int31.Twon => constr:true - | _ => constr:false + | Int31.On => constr:(true) + | Int31.In => constr:(true) + | Int31.Tn => constr:(true) + | Int31.Twon => constr:(true) + | _ => constr:(false) end. Ltac Int31cst t := match isInt31cst t with - | true => constr:t - | false => constr:NotConstant + | true => constr:(t) + | false => constr:(NotConstant) end. (** The generic ring structure inferred from the Cyclic structure *) diff --git a/theories/Numbers/Cyclic/ZModulo/ZModulo.v b/theories/Numbers/Cyclic/ZModulo/ZModulo.v index b93b4eb39..c115a831d 100644 --- a/theories/Numbers/Cyclic/ZModulo/ZModulo.v +++ b/theories/Numbers/Cyclic/ZModulo/ZModulo.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Integer/Abstract/ZAdd.v b/theories/Numbers/Integer/Abstract/ZAdd.v index ec8801c4e..f7fdc1795 100644 --- a/theories/Numbers/Integer/Abstract/ZAdd.v +++ b/theories/Numbers/Integer/Abstract/ZAdd.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Integer/Abstract/ZAddOrder.v b/theories/Numbers/Integer/Abstract/ZAddOrder.v index e341ea8a5..6bf5e9d4c 100644 --- a/theories/Numbers/Integer/Abstract/ZAddOrder.v +++ b/theories/Numbers/Integer/Abstract/ZAddOrder.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Integer/Abstract/ZAxioms.v b/theories/Numbers/Integer/Abstract/ZAxioms.v index 2a9fa539a..ad10e65f0 100644 --- a/theories/Numbers/Integer/Abstract/ZAxioms.v +++ b/theories/Numbers/Integer/Abstract/ZAxioms.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Integer/Abstract/ZBase.v b/theories/Numbers/Integer/Abstract/ZBase.v index 6634eab1d..9b1b30f87 100644 --- a/theories/Numbers/Integer/Abstract/ZBase.v +++ b/theories/Numbers/Integer/Abstract/ZBase.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Integer/Abstract/ZBits.v b/theories/Numbers/Integer/Abstract/ZBits.v index 9dd0ec0ee..c919e121d 100644 --- a/theories/Numbers/Integer/Abstract/ZBits.v +++ b/theories/Numbers/Integer/Abstract/ZBits.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Integer/Abstract/ZDivEucl.v b/theories/Numbers/Integer/Abstract/ZDivEucl.v index d0df8fb4a..278e1bcff 100644 --- a/theories/Numbers/Integer/Abstract/ZDivEucl.v +++ b/theories/Numbers/Integer/Abstract/ZDivEucl.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -391,7 +391,7 @@ rewrite <- (add_0_r (b*(a/b))) at 2. apply add_cancel_l. Qed. -(** Some additionnal inequalities about div. *) +(** Some additional inequalities about div. *) Theorem div_lt_upper_bound: forall a b q, 0<b -> a < b*q -> a/b < q. diff --git a/theories/Numbers/Integer/Abstract/ZDivFloor.v b/theories/Numbers/Integer/Abstract/ZDivFloor.v index d5f3f4ada..310748ddb 100644 --- a/theories/Numbers/Integer/Abstract/ZDivFloor.v +++ b/theories/Numbers/Integer/Abstract/ZDivFloor.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -436,7 +436,7 @@ rewrite <- (add_0_r (b*(a/b))) at 2. apply add_cancel_l. Qed. -(** Some additionnal inequalities about div. *) +(** Some additional inequalities about div. *) Theorem div_lt_upper_bound: forall a b q, 0<b -> a < b*q -> a/b < q. diff --git a/theories/Numbers/Integer/Abstract/ZDivTrunc.v b/theories/Numbers/Integer/Abstract/ZDivTrunc.v index de2e99ec3..043010779 100644 --- a/theories/Numbers/Integer/Abstract/ZDivTrunc.v +++ b/theories/Numbers/Integer/Abstract/ZDivTrunc.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -404,7 +404,7 @@ Proof. intros. rewrite rem_eq by order. rewrite sub_move_r; nzsimpl; tauto. Qed. -(** Some additionnal inequalities about quot. *) +(** Some additional inequalities about quot. *) Theorem quot_lt_upper_bound: forall a b q, 0<=a -> 0<b -> a < b*q -> a÷b < q. diff --git a/theories/Numbers/Integer/Abstract/ZGcd.v b/theories/Numbers/Integer/Abstract/ZGcd.v index cf6ff79ec..30adaeb4b 100644 --- a/theories/Numbers/Integer/Abstract/ZGcd.v +++ b/theories/Numbers/Integer/Abstract/ZGcd.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Integer/Abstract/ZLcm.v b/theories/Numbers/Integer/Abstract/ZLcm.v index 9a1768eb1..ef33308c2 100644 --- a/theories/Numbers/Integer/Abstract/ZLcm.v +++ b/theories/Numbers/Integer/Abstract/ZLcm.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Integer/Abstract/ZLt.v b/theories/Numbers/Integer/Abstract/ZLt.v index 6d0cdb019..0c92918d1 100644 --- a/theories/Numbers/Integer/Abstract/ZLt.v +++ b/theories/Numbers/Integer/Abstract/ZLt.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Integer/Abstract/ZMaxMin.v b/theories/Numbers/Integer/Abstract/ZMaxMin.v index 07c78ead3..24a47f002 100644 --- a/theories/Numbers/Integer/Abstract/ZMaxMin.v +++ b/theories/Numbers/Integer/Abstract/ZMaxMin.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Integer/Abstract/ZMul.v b/theories/Numbers/Integer/Abstract/ZMul.v index 2d78d8f30..830c0a7da 100644 --- a/theories/Numbers/Integer/Abstract/ZMul.v +++ b/theories/Numbers/Integer/Abstract/ZMul.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Integer/Abstract/ZMulOrder.v b/theories/Numbers/Integer/Abstract/ZMulOrder.v index 487aaae1c..320c8f355 100644 --- a/theories/Numbers/Integer/Abstract/ZMulOrder.v +++ b/theories/Numbers/Integer/Abstract/ZMulOrder.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Integer/Abstract/ZParity.v b/theories/Numbers/Integer/Abstract/ZParity.v index 195a0277e..952d8e9c1 100644 --- a/theories/Numbers/Integer/Abstract/ZParity.v +++ b/theories/Numbers/Integer/Abstract/ZParity.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Integer/Abstract/ZPow.v b/theories/Numbers/Integer/Abstract/ZPow.v index 87de2c782..02b8501c7 100644 --- a/theories/Numbers/Integer/Abstract/ZPow.v +++ b/theories/Numbers/Integer/Abstract/ZPow.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Integer/Abstract/ZProperties.v b/theories/Numbers/Integer/Abstract/ZProperties.v index 5cfeeb216..1dec3c586 100644 --- a/theories/Numbers/Integer/Abstract/ZProperties.v +++ b/theories/Numbers/Integer/Abstract/ZProperties.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Integer/Abstract/ZSgnAbs.v b/theories/Numbers/Integer/Abstract/ZSgnAbs.v index b379853ed..a10552ab3 100644 --- a/theories/Numbers/Integer/Abstract/ZSgnAbs.v +++ b/theories/Numbers/Integer/Abstract/ZSgnAbs.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Integer/BigZ/BigZ.v b/theories/Numbers/Integer/BigZ/BigZ.v index b28bc40f8..56cb9bbc2 100644 --- a/theories/Numbers/Integer/BigZ/BigZ.v +++ b/theories/Numbers/Integer/BigZ/BigZ.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -148,26 +148,26 @@ Ltac isBigZcst t := match t with | BigZ.Pos ?t => isBigNcst t | BigZ.Neg ?t => isBigNcst t - | BigZ.zero => constr:true - | BigZ.one => constr:true - | BigZ.two => constr:true - | BigZ.minus_one => constr:true - | _ => constr:false + | BigZ.zero => constr:(true) + | BigZ.one => constr:(true) + | BigZ.two => constr:(true) + | BigZ.minus_one => constr:(true) + | _ => constr:(false) end. Ltac BigZcst t := match isBigZcst t with - | true => constr:t - | false => constr:NotConstant + | true => constr:(t) + | false => constr:(NotConstant) end. Ltac BigZ_to_N t := match t with | BigZ.Pos ?t => BigN_to_N t - | BigZ.zero => constr:0%N - | BigZ.one => constr:1%N - | BigZ.two => constr:2%N - | _ => constr:NotConstant + | BigZ.zero => constr:(0%N) + | BigZ.one => constr:(1%N) + | BigZ.two => constr:(2%N) + | _ => constr:(NotConstant) end. (** Registration for the "ring" tactic *) diff --git a/theories/Numbers/Integer/BigZ/ZMake.v b/theories/Numbers/Integer/BigZ/ZMake.v index af4f1d937..8673b8a58 100644 --- a/theories/Numbers/Integer/BigZ/ZMake.v +++ b/theories/Numbers/Integer/BigZ/ZMake.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Integer/Binary/ZBinary.v b/theories/Numbers/Integer/Binary/ZBinary.v index 042081066..eae8204d4 100644 --- a/theories/Numbers/Integer/Binary/ZBinary.v +++ b/theories/Numbers/Integer/Binary/ZBinary.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Integer/NatPairs/ZNatPairs.v b/theories/Numbers/Integer/NatPairs/ZNatPairs.v index 02f02fbc5..0aaf33657 100644 --- a/theories/Numbers/Integer/NatPairs/ZNatPairs.v +++ b/theories/Numbers/Integer/NatPairs/ZNatPairs.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Integer/SpecViaZ/ZSig.v b/theories/Numbers/Integer/SpecViaZ/ZSig.v index 30ac32b53..a360327a4 100644 --- a/theories/Numbers/Integer/SpecViaZ/ZSig.v +++ b/theories/Numbers/Integer/SpecViaZ/ZSig.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v b/theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v index c9dc687cb..32410d1d0 100644 --- a/theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v +++ b/theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/NaryFunctions.v b/theories/Numbers/NaryFunctions.v index 376620ddc..eaac7d690 100644 --- a/theories/Numbers/NaryFunctions.v +++ b/theories/Numbers/NaryFunctions.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/NatInt/NZAdd.v b/theories/Numbers/NatInt/NZAdd.v index 501583ae9..8cc52940a 100644 --- a/theories/Numbers/NatInt/NZAdd.v +++ b/theories/Numbers/NatInt/NZAdd.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/NatInt/NZAddOrder.v b/theories/Numbers/NatInt/NZAddOrder.v index 619a66348..705f29102 100644 --- a/theories/Numbers/NatInt/NZAddOrder.v +++ b/theories/Numbers/NatInt/NZAddOrder.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/NatInt/NZAxioms.v b/theories/Numbers/NatInt/NZAxioms.v index c88341fa9..5a7f20728 100644 --- a/theories/Numbers/NatInt/NZAxioms.v +++ b/theories/Numbers/NatInt/NZAxioms.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/NatInt/NZBase.v b/theories/Numbers/NatInt/NZBase.v index c0afa0982..cf4ad3544 100644 --- a/theories/Numbers/NatInt/NZBase.v +++ b/theories/Numbers/NatInt/NZBase.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/NatInt/NZBits.v b/theories/Numbers/NatInt/NZBits.v index 1c1185972..209bd9471 100644 --- a/theories/Numbers/NatInt/NZBits.v +++ b/theories/Numbers/NatInt/NZBits.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/NatInt/NZDiv.v b/theories/Numbers/NatInt/NZDiv.v index 4a127216f..b2c0be6f5 100644 --- a/theories/Numbers/NatInt/NZDiv.v +++ b/theories/Numbers/NatInt/NZDiv.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -307,7 +307,7 @@ rewrite <- (add_0_r (b*(a/b))) at 2. apply add_cancel_l. Qed. -(** Some additionnal inequalities about div. *) +(** Some additional inequalities about div. *) Theorem div_lt_upper_bound: forall a b q, 0<=a -> 0<b -> a < b*q -> a/b < q. diff --git a/theories/Numbers/NatInt/NZDomain.v b/theories/Numbers/NatInt/NZDomain.v index ffb04f080..3881a27ff 100644 --- a/theories/Numbers/NatInt/NZDomain.v +++ b/theories/Numbers/NatInt/NZDomain.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/NatInt/NZGcd.v b/theories/Numbers/NatInt/NZGcd.v index 42bee3151..1d3672943 100644 --- a/theories/Numbers/NatInt/NZGcd.v +++ b/theories/Numbers/NatInt/NZGcd.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/NatInt/NZLog.v b/theories/Numbers/NatInt/NZLog.v index 9cd1f8776..3dfa2eef2 100644 --- a/theories/Numbers/NatInt/NZLog.v +++ b/theories/Numbers/NatInt/NZLog.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/NatInt/NZMul.v b/theories/Numbers/NatInt/NZMul.v index 89ace4deb..36cd08271 100644 --- a/theories/Numbers/NatInt/NZMul.v +++ b/theories/Numbers/NatInt/NZMul.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/NatInt/NZMulOrder.v b/theories/Numbers/NatInt/NZMulOrder.v index e79e50a9f..8569fc56b 100644 --- a/theories/Numbers/NatInt/NZMulOrder.v +++ b/theories/Numbers/NatInt/NZMulOrder.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/NatInt/NZOrder.v b/theories/Numbers/NatInt/NZOrder.v index c1e83529f..0b9d65983 100644 --- a/theories/Numbers/NatInt/NZOrder.v +++ b/theories/Numbers/NatInt/NZOrder.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/NatInt/NZParity.v b/theories/Numbers/NatInt/NZParity.v index 6b9a680a8..4a1352ccd 100644 --- a/theories/Numbers/NatInt/NZParity.v +++ b/theories/Numbers/NatInt/NZParity.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/NatInt/NZPow.v b/theories/Numbers/NatInt/NZPow.v index 384521192..261febbcf 100644 --- a/theories/Numbers/NatInt/NZPow.v +++ b/theories/Numbers/NatInt/NZPow.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/NatInt/NZProperties.v b/theories/Numbers/NatInt/NZProperties.v index 0f3a5caf7..79a9d7335 100644 --- a/theories/Numbers/NatInt/NZProperties.v +++ b/theories/Numbers/NatInt/NZProperties.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/NatInt/NZSqrt.v b/theories/Numbers/NatInt/NZSqrt.v index 894c08063..7f9bb9c25 100644 --- a/theories/Numbers/NatInt/NZSqrt.v +++ b/theories/Numbers/NatInt/NZSqrt.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Natural/Abstract/NAdd.v b/theories/Numbers/Natural/Abstract/NAdd.v index 638cfc7ec..eecec3ac1 100644 --- a/theories/Numbers/Natural/Abstract/NAdd.v +++ b/theories/Numbers/Natural/Abstract/NAdd.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Natural/Abstract/NAddOrder.v b/theories/Numbers/Natural/Abstract/NAddOrder.v index 144bce72b..9d68a006e 100644 --- a/theories/Numbers/Natural/Abstract/NAddOrder.v +++ b/theories/Numbers/Natural/Abstract/NAddOrder.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Natural/Abstract/NAxioms.v b/theories/Numbers/Natural/Abstract/NAxioms.v index d300f857d..25e285d59 100644 --- a/theories/Numbers/Natural/Abstract/NAxioms.v +++ b/theories/Numbers/Natural/Abstract/NAxioms.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Natural/Abstract/NBase.v b/theories/Numbers/Natural/Abstract/NBase.v index 40453214c..f949a0f6f 100644 --- a/theories/Numbers/Natural/Abstract/NBase.v +++ b/theories/Numbers/Natural/Abstract/NBase.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Natural/Abstract/NBits.v b/theories/Numbers/Natural/Abstract/NBits.v index 6f8a8fe52..3dd603e26 100644 --- a/theories/Numbers/Natural/Abstract/NBits.v +++ b/theories/Numbers/Natural/Abstract/NBits.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Natural/Abstract/NDefOps.v b/theories/Numbers/Natural/Abstract/NDefOps.v index 892b9266b..b3a53617b 100644 --- a/theories/Numbers/Natural/Abstract/NDefOps.v +++ b/theories/Numbers/Natural/Abstract/NDefOps.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Natural/Abstract/NDiv.v b/theories/Numbers/Natural/Abstract/NDiv.v index fb68c139b..84e1219ef 100644 --- a/theories/Numbers/Natural/Abstract/NDiv.v +++ b/theories/Numbers/Natural/Abstract/NDiv.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -137,7 +137,7 @@ Proof. intros; apply mul_succ_div_gt; auto'. Qed. Lemma div_exact : forall a b, b~=0 -> (a == b*(a/b) <-> a mod b == 0). Proof. intros. apply div_exact; auto'. Qed. -(** Some additionnal inequalities about div. *) +(** Some additional inequalities about div. *) Theorem div_lt_upper_bound: forall a b q, b~=0 -> a < b*q -> a/b < q. diff --git a/theories/Numbers/Natural/Abstract/NGcd.v b/theories/Numbers/Natural/Abstract/NGcd.v index a1f4ddf88..1eac134d5 100644 --- a/theories/Numbers/Natural/Abstract/NGcd.v +++ b/theories/Numbers/Natural/Abstract/NGcd.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Natural/Abstract/NIso.v b/theories/Numbers/Natural/Abstract/NIso.v index c296315d5..e6cac0ba9 100644 --- a/theories/Numbers/Natural/Abstract/NIso.v +++ b/theories/Numbers/Natural/Abstract/NIso.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Natural/Abstract/NLcm.v b/theories/Numbers/Natural/Abstract/NLcm.v index 0fe8e1055..3d7497997 100644 --- a/theories/Numbers/Natural/Abstract/NLcm.v +++ b/theories/Numbers/Natural/Abstract/NLcm.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Natural/Abstract/NLog.v b/theories/Numbers/Natural/Abstract/NLog.v index 605c0aadf..0c9da29bb 100644 --- a/theories/Numbers/Natural/Abstract/NLog.v +++ b/theories/Numbers/Natural/Abstract/NLog.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Natural/Abstract/NMaxMin.v b/theories/Numbers/Natural/Abstract/NMaxMin.v index e0710561e..b4c9db916 100644 --- a/theories/Numbers/Natural/Abstract/NMaxMin.v +++ b/theories/Numbers/Natural/Abstract/NMaxMin.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Natural/Abstract/NMulOrder.v b/theories/Numbers/Natural/Abstract/NMulOrder.v index c41275d21..a4b523963 100644 --- a/theories/Numbers/Natural/Abstract/NMulOrder.v +++ b/theories/Numbers/Natural/Abstract/NMulOrder.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Natural/Abstract/NOrder.v b/theories/Numbers/Natural/Abstract/NOrder.v index 90053a736..60e955f5f 100644 --- a/theories/Numbers/Natural/Abstract/NOrder.v +++ b/theories/Numbers/Natural/Abstract/NOrder.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Natural/Abstract/NParity.v b/theories/Numbers/Natural/Abstract/NParity.v index b3526c9a1..e1f573f65 100644 --- a/theories/Numbers/Natural/Abstract/NParity.v +++ b/theories/Numbers/Natural/Abstract/NParity.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,7 +8,7 @@ Require Import Bool NSub NZParity. -(** Some additionnal properties of [even], [odd]. *) +(** Some additional properties of [even], [odd]. *) Module Type NParityProp (Import N : NAxiomsSig')(Import NP : NSubProp N). diff --git a/theories/Numbers/Natural/Abstract/NPow.v b/theories/Numbers/Natural/Abstract/NPow.v index 9cc23004a..c9b2177f9 100644 --- a/theories/Numbers/Natural/Abstract/NPow.v +++ b/theories/Numbers/Natural/Abstract/NPow.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Natural/Abstract/NProperties.v b/theories/Numbers/Natural/Abstract/NProperties.v index cb3501d41..819a5be93 100644 --- a/theories/Numbers/Natural/Abstract/NProperties.v +++ b/theories/Numbers/Natural/Abstract/NProperties.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Natural/Abstract/NSqrt.v b/theories/Numbers/Natural/Abstract/NSqrt.v index 8dc66884f..4ae414071 100644 --- a/theories/Numbers/Natural/Abstract/NSqrt.v +++ b/theories/Numbers/Natural/Abstract/NSqrt.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Natural/Abstract/NStrongRec.v b/theories/Numbers/Natural/Abstract/NStrongRec.v index 896ffc182..fa3a5351e 100644 --- a/theories/Numbers/Natural/Abstract/NStrongRec.v +++ b/theories/Numbers/Natural/Abstract/NStrongRec.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Natural/Abstract/NSub.v b/theories/Numbers/Natural/Abstract/NSub.v index 18ebe77b7..21f12037c 100644 --- a/theories/Numbers/Natural/Abstract/NSub.v +++ b/theories/Numbers/Natural/Abstract/NSub.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Natural/BigN/BigN.v b/theories/Numbers/Natural/BigN/BigN.v index f7f4347b0..ec1017f50 100644 --- a/theories/Numbers/Natural/BigN/BigN.v +++ b/theories/Numbers/Natural/BigN/BigN.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -119,10 +119,10 @@ Qed. Ltac isStaticWordCst t := match t with - | W0 => constr:true + | W0 => constr:(true) | WW ?t1 ?t2 => match isStaticWordCst t1 with - | false => constr:false + | false => constr:(false) | true => isStaticWordCst t2 end | _ => isInt31cst t @@ -139,30 +139,30 @@ Ltac isBigNcst t := | BigN.N6 ?t => isStaticWordCst t | BigN.Nn ?n ?t => match isnatcst n with | true => isStaticWordCst t - | false => constr:false + | false => constr:(false) end - | BigN.zero => constr:true - | BigN.one => constr:true - | BigN.two => constr:true - | _ => constr:false + | BigN.zero => constr:(true) + | BigN.one => constr:(true) + | BigN.two => constr:(true) + | _ => constr:(false) end. Ltac BigNcst t := match isBigNcst t with - | true => constr:t - | false => constr:NotConstant + | true => constr:(t) + | false => constr:(NotConstant) end. Ltac BigN_to_N t := match isBigNcst t with | true => eval vm_compute in (BigN.to_N t) - | false => constr:NotConstant + | false => constr:(NotConstant) end. Ltac Ncst t := match isNcst t with - | true => constr:t - | false => constr:NotConstant + | true => constr:(t) + | false => constr:(NotConstant) end. (** Registration for the "ring" tactic *) diff --git a/theories/Numbers/Natural/BigN/NMake.v b/theories/Numbers/Natural/BigN/NMake.v index bdcdd5ca3..98949736c 100644 --- a/theories/Numbers/Natural/BigN/NMake.v +++ b/theories/Numbers/Natural/BigN/NMake.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Natural/BigN/NMake_gen.ml b/theories/Numbers/Natural/BigN/NMake_gen.ml index 6de77e0a9..601fa108f 100644 --- a/theories/Numbers/Natural/BigN/NMake_gen.ml +++ b/theories/Numbers/Natural/BigN/NMake_gen.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Natural/BigN/Nbasic.v b/theories/Numbers/Natural/BigN/Nbasic.v index 8fe9ea924..18d0262c9 100644 --- a/theories/Numbers/Natural/BigN/Nbasic.v +++ b/theories/Numbers/Natural/BigN/Nbasic.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Natural/Binary/NBinary.v b/theories/Numbers/Natural/Binary/NBinary.v index d54bedd1a..037b10d99 100644 --- a/theories/Numbers/Natural/Binary/NBinary.v +++ b/theories/Numbers/Natural/Binary/NBinary.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Natural/Peano/NPeano.v b/theories/Numbers/Natural/Peano/NPeano.v index 96eb7b352..58b1b0180 100644 --- a/theories/Numbers/Natural/Peano/NPeano.v +++ b/theories/Numbers/Natural/Peano/NPeano.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Natural/SpecViaZ/NSig.v b/theories/Numbers/Natural/SpecViaZ/NSig.v index 1049c1567..258e03159 100644 --- a/theories/Numbers/Natural/SpecViaZ/NSig.v +++ b/theories/Numbers/Natural/SpecViaZ/NSig.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v b/theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v index 11569b3f9..355da4cc6 100644 --- a/theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v +++ b/theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/NumPrelude.v b/theories/Numbers/NumPrelude.v index f67e0e966..f323aaeb1 100644 --- a/theories/Numbers/NumPrelude.v +++ b/theories/Numbers/NumPrelude.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Numbers/Rational/BigQ/BigQ.v b/theories/Numbers/Rational/BigQ/BigQ.v index b64cfb643..850afe534 100644 --- a/theories/Numbers/Rational/BigQ/BigQ.v +++ b/theories/Numbers/Rational/BigQ/BigQ.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -104,18 +104,18 @@ Ltac isBigQcst t := | BigQ.Qz ?t => isBigZcst t | BigQ.Qq ?n ?d => match isBigZcst n with | true => isBigNcst d - | false => constr:false + | false => constr:(false) end - | BigQ.zero => constr:true - | BigQ.one => constr:true - | BigQ.minus_one => constr:true - | _ => constr:false + | BigQ.zero => constr:(true) + | BigQ.one => constr:(true) + | BigQ.minus_one => constr:(true) + | _ => constr:(false) end. Ltac BigQcst t := match isBigQcst t with - | true => constr:t - | false => constr:NotConstant + | true => constr:(t) + | false => constr:(NotConstant) end. Add Field BigQfield : BigQfieldth diff --git a/theories/Numbers/Rational/BigQ/QMake.v b/theories/Numbers/Rational/BigQ/QMake.v index c11e07fa5..b9fed9d56 100644 --- a/theories/Numbers/Rational/BigQ/QMake.v +++ b/theories/Numbers/Rational/BigQ/QMake.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -1050,13 +1050,13 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType. Theorem spec_of_Qc: forall q, [[of_Qc q]] = q. Proof. intros; apply Qc_decomp; simpl; intros. - rewrite strong_spec_of_Qc; auto. + rewrite strong_spec_of_Qc. apply canon. Qed. Theorem spec_oppc: forall q, [[opp q]] = -[[q]]. Proof. intros q; unfold Qcopp, to_Qc, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. + apply Qc_decomp; unfold this. apply Qred_complete. rewrite spec_opp, <- Qred_opp, Qred_correct. apply Qeq_refl. @@ -1085,10 +1085,10 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType. unfold to_Qc. transitivity (Q2Qc ([x] + [y])). unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. + apply Qc_decomp; unfold this. apply Qred_complete; apply spec_add; auto. unfold Qcplus, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. + apply Qc_decomp; unfold this. apply Qred_complete. apply Qplus_comp; apply Qeq_sym; apply Qred_correct. Qed. @@ -1099,10 +1099,10 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType. unfold to_Qc. transitivity (Q2Qc ([x] + [y])). unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. + apply Qc_decomp; unfold this. apply Qred_complete; apply spec_add_norm; auto. unfold Qcplus, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. + apply Qc_decomp; unfold this. apply Qred_complete. apply Qplus_comp; apply Qeq_sym; apply Qred_correct. Qed. @@ -1147,10 +1147,10 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType. unfold to_Qc. transitivity (Q2Qc ([x] * [y])). unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. + apply Qc_decomp; unfold this. apply Qred_complete; apply spec_mul; auto. unfold Qcmult, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. + apply Qc_decomp; unfold this. apply Qred_complete. apply Qmult_comp; apply Qeq_sym; apply Qred_correct. Qed. @@ -1161,10 +1161,10 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType. unfold to_Qc. transitivity (Q2Qc ([x] * [y])). unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. + apply Qc_decomp; unfold this. apply Qred_complete; apply spec_mul_norm; auto. unfold Qcmult, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. + apply Qc_decomp; unfold this. apply Qred_complete. apply Qmult_comp; apply Qeq_sym; apply Qred_correct. Qed. @@ -1185,10 +1185,10 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType. unfold to_Qc. transitivity (Q2Qc (/[x])). unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. + apply Qc_decomp; unfold this. apply Qred_complete; apply spec_inv; auto. unfold Qcinv, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. + apply Qc_decomp; unfold this. apply Qred_complete. apply Qinv_comp; apply Qeq_sym; apply Qred_correct. Qed. @@ -1199,10 +1199,10 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType. unfold to_Qc. transitivity (Q2Qc (/[x])). unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. + apply Qc_decomp; unfold this. apply Qred_complete; apply spec_inv_norm; auto. unfold Qcinv, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. + apply Qc_decomp; unfold this. apply Qred_complete. apply Qinv_comp; apply Qeq_sym; apply Qred_correct. Qed. @@ -1247,13 +1247,13 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType. unfold to_Qc. transitivity (Q2Qc ([x]^2)). unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. + apply Qc_decomp; unfold this. apply Qred_complete; apply spec_square; auto. simpl Qcpower. replace (Q2Qc [x] * 1) with (Q2Qc [x]); try ring. simpl. unfold Qcmult, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. + apply Qc_decomp; unfold this. apply Qred_complete. apply Qmult_comp; apply Qeq_sym; apply Qred_correct. Qed. @@ -1264,14 +1264,14 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType. unfold to_Qc. transitivity (Q2Qc ([x]^Zpos p)). unfold Q2Qc. - apply Qc_decomp; intros _ _; unfold this. + apply Qc_decomp; unfold this. apply Qred_complete; apply spec_power_pos; auto. induction p using Pos.peano_ind. simpl; ring. rewrite Pos2Nat.inj_succ; simpl Qcpower. rewrite <- IHp; clear IHp. unfold Qcmult, Q2Qc. - apply Qc_decomp; intros _ _; unfold this. + apply Qc_decomp; unfold this. apply Qred_complete. setoid_replace ([x] ^ ' Pos.succ p)%Q with ([x] * [x] ^ ' p)%Q. apply Qmult_comp; apply Qeq_sym; apply Qred_correct. @@ -1281,4 +1281,3 @@ Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType. Qed. End Make. - diff --git a/theories/Numbers/Rational/SpecViaQ/QSig.v b/theories/Numbers/Rational/SpecViaQ/QSig.v index 5f831bfc2..a40d94059 100644 --- a/theories/Numbers/Rational/SpecViaQ/QSig.v +++ b/theories/Numbers/Rational/SpecViaQ/QSig.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/PArith/BinPos.v b/theories/PArith/BinPos.v index 921e2d67e..0ccfad7b2 100644 --- a/theories/PArith/BinPos.v +++ b/theories/PArith/BinPos.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/PArith/BinPosDef.v b/theories/PArith/BinPosDef.v index fefd1d76f..74a292c63 100644 --- a/theories/PArith/BinPosDef.v +++ b/theories/PArith/BinPosDef.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/PArith/PArith.v b/theories/PArith/PArith.v index 93352c6ba..6ee8d6d7b 100644 --- a/theories/PArith/PArith.v +++ b/theories/PArith/PArith.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/PArith/POrderedType.v b/theories/PArith/POrderedType.v index 92483ac83..7619f6395 100644 --- a/theories/PArith/POrderedType.v +++ b/theories/PArith/POrderedType.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/PArith/Pnat.v b/theories/PArith/Pnat.v index e529a8c41..9c2608f4a 100644 --- a/theories/PArith/Pnat.v +++ b/theories/PArith/Pnat.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Program/Basics.v b/theories/Program/Basics.v index e5be0ca92..644b9b5a7 100644 --- a/theories/Program/Basics.v +++ b/theories/Program/Basics.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Program/Combinators.v b/theories/Program/Combinators.v index e246041b6..772018aa0 100644 --- a/theories/Program/Combinators.v +++ b/theories/Program/Combinators.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Program/Equality.v b/theories/Program/Equality.v index ae6fe7dd0..17f05c511 100644 --- a/theories/Program/Equality.v +++ b/theories/Program/Equality.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -238,8 +238,8 @@ Ltac inject_left H := Ltac inject_right H := progress (inversion H ; subst_right_no_fail ; clear_dups) ; clear H. -Ltac autoinjections_left := repeat autoinjection ltac:inject_left. -Ltac autoinjections_right := repeat autoinjection ltac:inject_right. +Ltac autoinjections_left := repeat autoinjection ltac:(inject_left). +Ltac autoinjections_right := repeat autoinjection ltac:(inject_right). Ltac simpl_depind := subst_no_fail ; autoinjections ; try discriminates ; simpl_JMeq ; simpl_existTs ; simplify_IH_hyps. diff --git a/theories/Program/Program.v b/theories/Program/Program.v index 5af6f4d74..4a6f2786f 100644 --- a/theories/Program/Program.v +++ b/theories/Program/Program.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Program/Subset.v b/theories/Program/Subset.v index 50b89b5c0..c8f37318d 100644 --- a/theories/Program/Subset.v +++ b/theories/Program/Subset.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -82,7 +82,7 @@ Qed. Definition match_eq (A B : Type) (x : A) (fn : {y : A | y = x} -> B) : B := fn (exist _ x eq_refl). -(* This is what we want to be able to do: replace the originaly matched object by a new, +(* This is what we want to be able to do: replace the originally matched object by a new, propositionally equal one. If [fn] works on [x] it should work on any [y | y = x]. *) Lemma match_eq_rewrite : forall (A B : Type) (x : A) (fn : {y : A | y = x} -> B) diff --git a/theories/Program/Syntax.v b/theories/Program/Syntax.v index 892305b49..2fccf6249 100644 --- a/theories/Program/Syntax.v +++ b/theories/Program/Syntax.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Program/Tactics.v b/theories/Program/Tactics.v index c1d958b9d..7384790da 100644 --- a/theories/Program/Tactics.v +++ b/theories/Program/Tactics.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -252,7 +252,7 @@ Ltac autoinjection tac := Ltac inject H := progress (inversion H ; subst*; clear_dups) ; clear H. -Ltac autoinjections := repeat (clear_dups ; autoinjection ltac:inject). +Ltac autoinjections := repeat (clear_dups ; autoinjection ltac:(inject)). (** Destruct an hypothesis by first copying it to avoid dependencies. *) diff --git a/theories/Program/Utils.v b/theories/Program/Utils.v index 65fe87801..396c96181 100644 --- a/theories/Program/Utils.v +++ b/theories/Program/Utils.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Program/Wf.v b/theories/Program/Wf.v index d89919b0a..a2fd05cd9 100644 --- a/theories/Program/Wf.v +++ b/theories/Program/Wf.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -89,7 +89,7 @@ Section Measure_well_founded. Lemma measure_wf: well_founded MR. Proof with auto. unfold well_founded. - cut (forall a: M, (fun mm: M => forall a0: T, m a0 = mm -> Acc MR a0) a). + cut (forall (a: M) (a0: T), m a0 = a -> Acc MR a0). intros. apply (H (m a))... apply (@well_founded_ind M R wf (fun mm => forall a, m a = mm -> Acc MR a)). diff --git a/theories/QArith/QArith.v b/theories/QArith/QArith.v index c32fb9509..5ad08b650 100644 --- a/theories/QArith/QArith.v +++ b/theories/QArith/QArith.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/QArith/QArith_base.v b/theories/QArith/QArith_base.v index 7f19b4ce5..62304876e 100644 --- a/theories/QArith/QArith_base.v +++ b/theories/QArith/QArith_base.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/QArith/QOrderedType.v b/theories/QArith/QOrderedType.v index fa0b92091..25e98f0b0 100644 --- a/theories/QArith/QOrderedType.v +++ b/theories/QArith/QOrderedType.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/QArith/Qabs.v b/theories/QArith/Qabs.v index f77f409e7..c60d04517 100644 --- a/theories/QArith/Qabs.v +++ b/theories/QArith/Qabs.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/QArith/Qcabs.v b/theories/QArith/Qcabs.v new file mode 100644 index 000000000..c0ababfff --- /dev/null +++ b/theories/QArith/Qcabs.v @@ -0,0 +1,129 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** * An absolute value for normalized rational numbers. *) + +(** Contributed by Cédric Auger *) + +Require Import Qabs Qcanon. + +Lemma Qred_abs (x : Q) : Qred (Qabs x) = Qabs (Qred x). +Proof. + destruct x as [[|a|a] d]; simpl; auto; + destruct (Pos.ggcd a d) as [x [y z]]; simpl; auto. +Qed. + +Lemma Qcabs_canon (x : Q) : Qred x = x -> Qred (Qabs x) = Qabs x. +Proof. intros H; now rewrite (Qred_abs x), H. Qed. + +Definition Qcabs (x:Qc) : Qc := {| canon := Qcabs_canon x (canon x) |}. +Notation "[ q ]" := (Qcabs q) (q at next level, format "[ q ]") : Qc_scope. + +Ltac Qc_unfolds := + unfold Qcabs, Qcminus, Qcopp, Qcplus, Qcmult, Qcle, Q2Qc, this. + +Lemma Qcabs_case (x:Qc) (P : Qc -> Type) : + (0 <= x -> P x) -> (x <= 0 -> P (- x)) -> P [x]. +Proof. + intros A B. + apply (Qabs_case x (fun x => forall Hx, P {|this:=x;canon:=Hx|})). + intros; case (Qc_decomp x {|canon:=Hx|}); auto. + intros; case (Qc_decomp (-x) {|canon:=Hx|}); auto. +Qed. + +Lemma Qcabs_pos x : 0 <= x -> [x] = x. +Proof. + intro Hx; apply Qc_decomp; Qc_unfolds; fold (this x). + set (K := canon [x]); simpl in K; case K; clear K. + set (a := x) at 1; case (canon x); subst a; apply Qred_complete. + now apply Qabs_pos. +Qed. + +Lemma Qcabs_neg x : x <= 0 -> [x] = - x. +Proof. + intro Hx; apply Qc_decomp; Qc_unfolds; fold (this x). + set (K := canon [x]); simpl in K; case K; clear K. + now apply Qred_complete; apply Qabs_neg. +Qed. + +Lemma Qcabs_nonneg x : 0 <= [x]. +Proof. intros; apply Qabs_nonneg. Qed. + +Lemma Qcabs_opp x : [(-x)] = [x]. +Proof. + apply Qc_decomp; Qc_unfolds; fold (this x). + set (K := canon [x]); simpl in K; case K; clear K. + case Qred_abs; apply Qred_complete; apply Qabs_opp. +Qed. + +Lemma Qcabs_triangle x y : [x+y] <= [x] + [y]. +Proof. + Qc_unfolds; case Qred_abs; rewrite !Qred_le; apply Qabs_triangle. +Qed. + +Lemma Qcabs_Qcmult x y : [x*y] = [x]*[y]. +Proof. + apply Qc_decomp; Qc_unfolds; fold (this x) (this y); case Qred_abs. + apply Qred_complete; apply Qabs_Qmult. +Qed. + +Lemma Qcabs_Qcminus x y: [x-y] = [y-x]. +Proof. + apply Qc_decomp; Qc_unfolds; fold (this x) (this y) (this (-x)) (this (-y)). + set (a := x) at 2; case (canon x); subst a. + set (a := y) at 1; case (canon y); subst a. + rewrite !Qred_opp; fold (Qred x - Qred y)%Q (Qred y - Qred x)%Q. + repeat case Qred_abs; f_equal; apply Qabs_Qminus. +Qed. + +Lemma Qcle_Qcabs x : x <= [x]. +Proof. apply Qle_Qabs. Qed. + +Lemma Qcabs_triangle_reverse x y : [x] - [y] <= [x - y]. +Proof. + unfold Qcle, Qcabs, Qcminus, Qcplus, Qcopp, Q2Qc, this; + fold (this x) (this y) (this (-x)) (this (-y)). + case Qred_abs; rewrite !Qred_le, !Qred_opp, Qred_abs. + apply Qabs_triangle_reverse. +Qed. + +Lemma Qcabs_Qcle_condition x y : [x] <= y <-> -y <= x <= y. +Proof. + Qc_unfolds; fold (this x) (this y). + destruct (Qabs_Qle_condition x y) as [A B]. + split; intros H. + + destruct (A H) as [X Y]; split; auto. + now case (canon x); apply Qred_le. + + destruct H as [X Y]; apply B; split; auto. + now case (canon y); case Qred_opp. +Qed. + +Lemma Qcabs_diff_Qcle_condition x y r : [x-y] <= r <-> x - r <= y <= x + r. +Proof. + Qc_unfolds; fold (this x) (this y) (this r). + case Qred_abs; repeat rewrite Qred_opp. + set (a := y) at 1; case (canon y); subst a. + set (a := r) at 2; case (canon r); subst a. + set (a := Qred r) at 2 3; + assert (K := canon (Q2Qc r)); simpl in K; case K; clear K; subst a. + set (a := Qred y) at 1; + assert (K := canon (Q2Qc y)); simpl in K; case K; clear K; subst a. + fold (x - Qred y)%Q (x - Qred r)%Q. + destruct (Qabs_diff_Qle_condition x (Qred y) (Qred r)) as [A B]. + split. + + clear B; rewrite !Qred_le. auto. + + clear A; rewrite !Qred_le. auto. +Qed. + +Lemma Qcabs_null x : [x] = 0 -> x = 0. +Proof. + intros H. + destruct (proj1 (Qcabs_Qcle_condition x 0)) as [A B]. + + rewrite H; apply Qcle_refl. + + apply Qcle_antisym; auto. +Qed.
\ No newline at end of file diff --git a/theories/QArith/Qcanon.v b/theories/QArith/Qcanon.v index f7f83bf03..6bfa47bc5 100644 --- a/theories/QArith/Qcanon.v +++ b/theories/QArith/Qcanon.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -21,37 +21,30 @@ Bind Scope Qc_scope with Qc. Arguments Qcmake this%Q _. Open Scope Qc_scope. +(** An alternative statement of [Qred q = q] via [Z.gcd] *) + Lemma Qred_identity : forall q:Q, Z.gcd (Qnum q) (QDen q) = 1%Z -> Qred q = q. Proof. - unfold Qred; intros (a,b); simpl. - generalize (Z.ggcd_gcd a ('b)) (Z.ggcd_correct_divisors a ('b)). - intros. - rewrite H1 in H; clear H1. - destruct (Z.ggcd a ('b)) as (g,(aa,bb)); simpl in *; subst. - destruct H0. - rewrite Z.mul_1_l in H, H0. - subst; simpl; auto. + intros (a,b) H; simpl in *. + rewrite <- Z.ggcd_gcd in H. + generalize (Z.ggcd_correct_divisors a ('b)). + destruct Z.ggcd as (g,(aa,bb)); simpl in *; subst. + rewrite !Z.mul_1_l. now intros (<-,<-). Qed. Lemma Qred_identity2 : forall q:Q, Qred q = q -> Z.gcd (Qnum q) (QDen q) = 1%Z. Proof. - unfold Qred; intros (a,b); simpl. - generalize (Z.ggcd_gcd a ('b)) (Z.ggcd_correct_divisors a ('b)) (Z.gcd_nonneg a ('b)). - intros. - rewrite <- H; rewrite <- H in H1; clear H. - destruct (Z.ggcd a ('b)) as (g,(aa,bb)); simpl in *; subst. - injection H2; intros; clear H2. - destruct H0. - clear H0 H3. - destruct g as [|g|g]; destruct bb as [|bb|bb]; simpl in *; try discriminate. - f_equal. - apply Pos.mul_reg_r with bb. - injection H2; intros. - rewrite <- H0. - rewrite H; simpl; auto. - elim H1; auto. + intros (a,b) H; simpl in *. + generalize (Z.gcd_nonneg a ('b)) (Z.ggcd_correct_divisors a ('b)). + rewrite <- Z.ggcd_gcd. + destruct Z.ggcd as (g,(aa,bb)); simpl in *. + injection H as <- <-. intros H (_,H'). + destruct g as [|g|g]; [ discriminate | | now elim H ]. + destruct bb as [|b|b]; simpl in *; try discriminate. + injection H' as H'. f_equal. + apply Pos.mul_reg_r with b. now rewrite Pos.mul_1_l. Qed. Lemma Qred_iff : forall q:Q, Qred q = q <-> Z.gcd (Qnum q) (QDen q) = 1%Z. @@ -61,6 +54,23 @@ Proof. apply Qred_identity; auto. Qed. +(** Coercion from [Qc] to [Q] and equality *) + +Lemma Qc_is_canon : forall q q' : Qc, q == q' -> q = q'. +Proof. + intros (q,hq) (q',hq') H. simpl in *. + assert (H' := Qred_complete _ _ H). + rewrite hq, hq' in H'. subst q'. f_equal. + apply eq_proofs_unicity. intros. repeat decide equality. +Qed. +Hint Resolve Qc_is_canon. + +Theorem Qc_decomp: forall q q': Qc, (q:Q) = q' -> q = q'. +Proof. + intros. apply Qc_is_canon. now rewrite H. +Qed. + +(** [Q2Qc] : a conversion from [Q] to [Qc]. *) Lemma Qred_involutive : forall q:Q, Qred (Qred q) = Qred q. Proof. @@ -71,20 +81,12 @@ Qed. Definition Q2Qc (q:Q) : Qc := Qcmake (Qred q) (Qred_involutive q). Arguments Q2Qc q%Q. -Lemma Qc_is_canon : forall q q' : Qc, q == q' -> q = q'. +Lemma Q2Qc_eq_iff (q q' : Q) : Q2Qc q = Q2Qc q' <-> q == q'. Proof. - intros (q,proof_q) (q',proof_q'). - simpl. - intros H. - assert (H0:=Qred_complete _ _ H). - assert (q = q') by congruence. - subst q'. - assert (proof_q = proof_q'). - apply eq_proofs_unicity; auto; intros. - repeat decide equality. - congruence. + split; intro H. + - injection H. apply Qred_eq_iff. + - apply Qc_is_canon. simpl. now rewrite H. Qed. -Hint Resolve Qc_is_canon. Notation " 0 " := (Q2Qc 0) : Qc_scope. Notation " 1 " := (Q2Qc 1) : Qc_scope. @@ -107,8 +109,7 @@ Lemma Qceq_alt : forall p q, (p = q) <-> (p ?= q) = Eq. Proof. unfold Qccompare. intros; rewrite <- Qeq_alt. - split; auto. - intro H; rewrite H; auto with qarith. + split; auto. now intros <-. Qed. Lemma Qclt_alt : forall p q, (p<q) <-> (p?=q = Lt). @@ -121,12 +122,12 @@ Proof. intros; exact (Qgt_alt p q). Qed. -Lemma Qle_alt : forall p q, (p<=q) <-> (p?=q <> Gt). +Lemma Qcle_alt : forall p q, (p<=q) <-> (p?=q <> Gt). Proof. intros; exact (Qle_alt p q). Qed. -Lemma Qge_alt : forall p q, (p>=q) <-> (p?=q <> Lt). +Lemma Qcge_alt : forall p q, (p>=q) <-> (p?=q <> Lt). Proof. intros; exact (Qge_alt p q). Qed. @@ -166,7 +167,7 @@ Qed. Ltac qc := match goal with | q:Qc |- _ => destruct q; qc - | _ => apply Qc_is_canon; simpl; repeat rewrite Qred_correct + | _ => apply Qc_is_canon; simpl; rewrite !Qred_correct end. Opaque Qred. @@ -216,6 +217,18 @@ Proof. intros; qc; apply Qmult_assoc. Qed. +(** [0] is absorbing for multiplication: *) + +Lemma Qcmult_0_l : forall n, 0*n = 0. +Proof. + intros; qc; split. +Qed. + +Theorem Qcmult_0_r : forall n, n*0=0. +Proof. + intros; qc; rewrite Qmult_comm; split. +Qed. + (** [1] is a neutral element for multiplication: *) Lemma Qcmult_1_l : forall n, 1*n = n. @@ -303,7 +316,7 @@ Proof. apply Qcmult_1_l. Qed. -(** Properties of order upon Q. *) +(** Properties of order upon Qc. *) Lemma Qcle_refl : forall x, x<=x. Proof. @@ -372,9 +385,11 @@ Proof. unfold Qcle, Qclt; intros; apply Qle_not_lt; auto. Qed. -Lemma Qcle_lt_or_eq : forall x y, x<=y -> x<y \/ x==y. +Lemma Qcle_lt_or_eq : forall x y, x<=y -> x<y \/ x=y. Proof. - unfold Qcle, Qclt; intros; apply Qle_lt_or_eq; auto. + unfold Qcle, Qclt; intros x y H. + destruct (Qle_lt_or_eq _ _ H); [left|right]; trivial. + now apply Qc_is_canon. Qed. (** Some decidability results about orders. *) @@ -459,13 +474,13 @@ Proof. induction n; simpl; auto with qarith. rewrite IHn; auto with qarith. Qed. -Transparent Qred. + Lemma Qcpower_0 : forall n, n<>O -> 0^n = 0. Proof. destruct n; simpl. destruct 1; auto. intros. - now apply Qc_is_canon. + now apply Qc_is_canon. Qed. Lemma Qcpower_pos : forall p n, 0 <= p -> 0 <= p^n. @@ -525,16 +540,3 @@ intros. field. auto. Qed. - - -Theorem Qc_decomp: forall x y: Qc, - (Qred x = x -> Qred y = y -> (x:Q) = y)-> x = y. -Proof. - intros (q, Hq) (q', Hq'); simpl; intros H. - assert (H1 := H Hq Hq'). - subst q'. - assert (Hq = Hq'). - apply Eqdep_dec.eq_proofs_unicity; auto; intros. - repeat decide equality. - congruence. -Qed. diff --git a/theories/QArith/Qfield.v b/theories/QArith/Qfield.v index 083e40aed..bbaf6027e 100644 --- a/theories/QArith/Qfield.v +++ b/theories/QArith/Qfield.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/QArith/Qminmax.v b/theories/QArith/Qminmax.v index 0fd053252..86584d9ee 100644 --- a/theories/QArith/Qminmax.v +++ b/theories/QArith/Qminmax.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/QArith/Qpower.v b/theories/QArith/Qpower.v index 8bd643aa7..af89d3005 100644 --- a/theories/QArith/Qpower.v +++ b/theories/QArith/Qpower.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/QArith/Qreals.v b/theories/QArith/Qreals.v index add43b960..048e409cd 100644 --- a/theories/QArith/Qreals.v +++ b/theories/QArith/Qreals.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/QArith/Qreduction.v b/theories/QArith/Qreduction.v index 1d304964b..131214f51 100644 --- a/theories/QArith/Qreduction.v +++ b/theories/QArith/Qreduction.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -93,11 +93,17 @@ Proof. Close Scope Z_scope. Qed. +Lemma Qred_eq_iff q q' : Qred q = Qred q' <-> q == q'. +Proof. + split. + - intros E. rewrite <- (Qred_correct q), <- (Qred_correct q'). + now rewrite E. + - apply Qred_complete. +Qed. + Add Morphism Qred : Qred_comp. Proof. - intros q q' H. - rewrite (Qred_correct q); auto. - rewrite (Qred_correct q'); auto. + intros. now rewrite !Qred_correct. Qed. Definition Qplus' (p q : Q) := Qred (Qplus p q). @@ -149,3 +155,13 @@ Theorem Qred_compare: forall x y, Proof. intros x y; apply Qcompare_comp; apply Qeq_sym; apply Qred_correct. Qed. + +Lemma Qred_le q q' : Qred q <= Qred q' <-> q <= q'. +Proof. + now rewrite !Qle_alt, <- Qred_compare. +Qed. + +Lemma Qred_lt q q' : Qred q < Qred q' <-> q < q'. +Proof. + now rewrite !Qlt_alt, <- Qred_compare. +Qed. diff --git a/theories/QArith/Qring.v b/theories/QArith/Qring.v index 78c464ae7..da11c2b1d 100644 --- a/theories/QArith/Qring.v +++ b/theories/QArith/Qring.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/QArith/Qround.v b/theories/QArith/Qround.v index 964a4bae0..0ed6d557c 100644 --- a/theories/QArith/Qround.v +++ b/theories/QArith/Qround.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/QArith/vo.itarget b/theories/QArith/vo.itarget index b3faef881..b550b4712 100644 --- a/theories/QArith/vo.itarget +++ b/theories/QArith/vo.itarget @@ -2,6 +2,7 @@ Qabs.vo QArith_base.vo QArith.vo Qcanon.vo +Qcabs.vo Qfield.vo Qpower.vo Qreals.vo diff --git a/theories/Reals/Alembert.v b/theories/Reals/Alembert.v index 011328ec0..a98d529fa 100644 --- a/theories/Reals/Alembert.v +++ b/theories/Reals/Alembert.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/AltSeries.v b/theories/Reals/AltSeries.v index 3e99c9893..c3ab8edc5 100644 --- a/theories/Reals/AltSeries.v +++ b/theories/Reals/AltSeries.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/ArithProp.v b/theories/Reals/ArithProp.v index c4e410ed5..6fca9c8ad 100644 --- a/theories/Reals/ArithProp.v +++ b/theories/Reals/ArithProp.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/Binomial.v b/theories/Reals/Binomial.v index d48f42fc3..f878abfab 100644 --- a/theories/Reals/Binomial.v +++ b/theories/Reals/Binomial.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/Cauchy_prod.v b/theories/Reals/Cauchy_prod.v index 28de11863..5cf6f17d4 100644 --- a/theories/Reals/Cauchy_prod.v +++ b/theories/Reals/Cauchy_prod.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/Cos_plus.v b/theories/Reals/Cos_plus.v index 49ba9a6ed..b14d807d2 100644 --- a/theories/Reals/Cos_plus.v +++ b/theories/Reals/Cos_plus.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/Cos_rel.v b/theories/Reals/Cos_rel.v index 6d30319c9..f5fcac47d 100644 --- a/theories/Reals/Cos_rel.v +++ b/theories/Reals/Cos_rel.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/DiscrR.v b/theories/Reals/DiscrR.v index 75fd4c0aa..4e2a7c3c6 100644 --- a/theories/Reals/DiscrR.v +++ b/theories/Reals/DiscrR.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/Exp_prop.v b/theories/Reals/Exp_prop.v index be96b94e9..569518f7b 100644 --- a/theories/Reals/Exp_prop.v +++ b/theories/Reals/Exp_prop.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/Integration.v b/theories/Reals/Integration.v index 222d106fb..e3760e01e 100644 --- a/theories/Reals/Integration.v +++ b/theories/Reals/Integration.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/MVT.v b/theories/Reals/MVT.v index 599769578..26c51583b 100644 --- a/theories/Reals/MVT.v +++ b/theories/Reals/MVT.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/Machin.v b/theories/Reals/Machin.v index 1a94f6a8f..19db476fd 100644 --- a/theories/Reals/Machin.v +++ b/theories/Reals/Machin.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/NewtonInt.v b/theories/Reals/NewtonInt.v index 832e7adc4..ed5ae90c2 100644 --- a/theories/Reals/NewtonInt.v +++ b/theories/Reals/NewtonInt.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/PSeries_reg.v b/theories/Reals/PSeries_reg.v index 94b881ccc..03ac6582b 100644 --- a/theories/Reals/PSeries_reg.v +++ b/theories/Reals/PSeries_reg.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/PartSum.v b/theories/Reals/PartSum.v index b710c75cc..37d54a6df 100644 --- a/theories/Reals/PartSum.v +++ b/theories/Reals/PartSum.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/RIneq.v b/theories/Reals/RIneq.v index 8dca0197e..f26bac2bb 100644 --- a/theories/Reals/RIneq.v +++ b/theories/Reals/RIneq.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/RList.v b/theories/Reals/RList.v index abf8a99d2..924d5117b 100644 --- a/theories/Reals/RList.v +++ b/theories/Reals/RList.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/ROrderedType.v b/theories/Reals/ROrderedType.v index 0531bd0a1..f2dc7fd09 100644 --- a/theories/Reals/ROrderedType.v +++ b/theories/Reals/ROrderedType.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/R_Ifp.v b/theories/Reals/R_Ifp.v index 57ee1d9a6..b6d072837 100644 --- a/theories/Reals/R_Ifp.v +++ b/theories/Reals/R_Ifp.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/R_sqr.v b/theories/Reals/R_sqr.v index f1e2d6fa4..445ffcb21 100644 --- a/theories/Reals/R_sqr.v +++ b/theories/Reals/R_sqr.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/R_sqrt.v b/theories/Reals/R_sqrt.v index 20319a2b1..a6b1a26e0 100644 --- a/theories/Reals/R_sqrt.v +++ b/theories/Reals/R_sqrt.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/Ranalysis.v b/theories/Reals/Ranalysis.v index 3cda675a4..88ebb88b2 100644 --- a/theories/Reals/Ranalysis.v +++ b/theories/Reals/Ranalysis.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/Ranalysis1.v b/theories/Reals/Ranalysis1.v index 875eebbbd..9e3abd815 100644 --- a/theories/Reals/Ranalysis1.v +++ b/theories/Reals/Ranalysis1.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/Ranalysis2.v b/theories/Reals/Ranalysis2.v index eb646913c..0254218c4 100644 --- a/theories/Reals/Ranalysis2.v +++ b/theories/Reals/Ranalysis2.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/Ranalysis3.v b/theories/Reals/Ranalysis3.v index 407f64100..4e88714d6 100644 --- a/theories/Reals/Ranalysis3.v +++ b/theories/Reals/Ranalysis3.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/Ranalysis4.v b/theories/Reals/Ranalysis4.v index ae2013f01..661bc8c76 100644 --- a/theories/Reals/Ranalysis4.v +++ b/theories/Reals/Ranalysis4.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/Ranalysis5.v b/theories/Reals/Ranalysis5.v index 27615c597..d172139f5 100644 --- a/theories/Reals/Ranalysis5.v +++ b/theories/Reals/Ranalysis5.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/Ranalysis_reg.v b/theories/Reals/Ranalysis_reg.v index 4cf908865..e57af7311 100644 --- a/theories/Reals/Ranalysis_reg.v +++ b/theories/Reals/Ranalysis_reg.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -35,7 +35,7 @@ Qed. (**********) Ltac intro_hyp_glob trm := - match constr:trm with + match constr:(trm) with | (?X1 + ?X2)%F => match goal with | |- (derivable _) => intro_hyp_glob X1; intro_hyp_glob X2 @@ -55,7 +55,7 @@ Ltac intro_hyp_glob trm := | _ => idtac end | (?X1 / ?X2)%F => - let aux := constr:X2 in + let aux := constr:(X2) in match goal with | _:(forall x0:R, aux x0 <> 0) |- (derivable _) => intro_hyp_glob X1; intro_hyp_glob X2 @@ -82,7 +82,7 @@ Ltac intro_hyp_glob trm := | _ => idtac end | (/ ?X1)%F => - let aux := constr:X1 in + let aux := constr:(X1) in match goal with | _:(forall x0:R, aux x0 <> 0) |- (derivable _) => intro_hyp_glob X1 @@ -108,7 +108,7 @@ Ltac intro_hyp_glob trm := | (pow_fct _) => idtac | Rabs => idtac | ?X1 => - let p := constr:X1 in + let p := constr:(X1) in match goal with | _:(derivable p) |- _ => idtac | |- (derivable p) => idtac @@ -130,7 +130,7 @@ Ltac intro_hyp_glob trm := (**********) Ltac intro_hyp_pt trm pt := - match constr:trm with + match constr:(trm) with | (?X1 + ?X2)%F => match goal with | |- (derivable_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt @@ -156,7 +156,7 @@ Ltac intro_hyp_pt trm pt := | _ => idtac end | (?X1 / ?X2)%F => - let aux := constr:X2 in + let aux := constr:(X2) in match goal with | _:(aux pt <> 0) |- (derivable_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt @@ -202,7 +202,7 @@ Ltac intro_hyp_pt trm pt := | _ => idtac end | (/ ?X1)%F => - let aux := constr:X1 in + let aux := constr:(X1) in match goal with | _:(aux pt <> 0) |- (derivable_pt _ _) => intro_hyp_pt X1 pt @@ -249,7 +249,7 @@ Ltac intro_hyp_pt trm pt := | _ => idtac end | ?X1 => - let p := constr:X1 in + let p := constr:(X1) in match goal with | _:(derivable_pt p pt) |- _ => idtac | |- (derivable_pt p pt) => idtac @@ -578,89 +578,89 @@ Ltac is_cont_glob := (**********) Ltac rew_term trm := - match constr:trm with + match constr:(trm) with | (?X1 + ?X2) => let p1 := rew_term X1 with p2 := rew_term X2 in - match constr:p1 with + match constr:(p1) with | (fct_cte ?X3) => - match constr:p2 with + match constr:(p2) with | (fct_cte ?X4) => constr:(fct_cte (X3 + X4)) - | _ => constr:(p1 + p2)%F + | _ => constr:((p1 + p2)%F) end - | _ => constr:(p1 + p2)%F + | _ => constr:((p1 + p2)%F) end | (?X1 - ?X2) => let p1 := rew_term X1 with p2 := rew_term X2 in - match constr:p1 with + match constr:(p1) with | (fct_cte ?X3) => - match constr:p2 with + match constr:(p2) with | (fct_cte ?X4) => constr:(fct_cte (X3 - X4)) - | _ => constr:(p1 - p2)%F + | _ => constr:((p1 - p2)%F) end - | _ => constr:(p1 - p2)%F + | _ => constr:((p1 - p2)%F) end | (?X1 / ?X2) => let p1 := rew_term X1 with p2 := rew_term X2 in - match constr:p1 with + match constr:(p1) with | (fct_cte ?X3) => - match constr:p2 with + match constr:(p2) with | (fct_cte ?X4) => constr:(fct_cte (X3 / X4)) - | _ => constr:(p1 / p2)%F + | _ => constr:((p1 / p2)%F) end | _ => - match constr:p2 with - | (fct_cte ?X4) => constr:(p1 * fct_cte (/ X4))%F - | _ => constr:(p1 / p2)%F + match constr:(p2) with + | (fct_cte ?X4) => constr:((p1 * fct_cte (/ X4))%F) + | _ => constr:((p1 / p2)%F) end end | (?X1 * / ?X2) => let p1 := rew_term X1 with p2 := rew_term X2 in - match constr:p1 with + match constr:(p1) with | (fct_cte ?X3) => - match constr:p2 with + match constr:(p2) with | (fct_cte ?X4) => constr:(fct_cte (X3 / X4)) - | _ => constr:(p1 / p2)%F + | _ => constr:((p1 / p2)%F) end | _ => - match constr:p2 with - | (fct_cte ?X4) => constr:(p1 * fct_cte (/ X4))%F - | _ => constr:(p1 / p2)%F + match constr:(p2) with + | (fct_cte ?X4) => constr:((p1 * fct_cte (/ X4))%F) + | _ => constr:((p1 / p2)%F) end end | (?X1 * ?X2) => let p1 := rew_term X1 with p2 := rew_term X2 in - match constr:p1 with + match constr:(p1) with | (fct_cte ?X3) => - match constr:p2 with + match constr:(p2) with | (fct_cte ?X4) => constr:(fct_cte (X3 * X4)) - | _ => constr:(p1 * p2)%F + | _ => constr:((p1 * p2)%F) end - | _ => constr:(p1 * p2)%F + | _ => constr:((p1 * p2)%F) end | (- ?X1) => let p := rew_term X1 in - match constr:p with + match constr:(p) with | (fct_cte ?X2) => constr:(fct_cte (- X2)) - | _ => constr:(- p)%F + | _ => constr:((- p)%F) end | (/ ?X1) => let p := rew_term X1 in - match constr:p with + match constr:(p) with | (fct_cte ?X2) => constr:(fct_cte (/ X2)) - | _ => constr:(/ p)%F + | _ => constr:((/ p)%F) end - | (?X1 AppVar) => constr:X1 + | (?X1 AppVar) => constr:(X1) | (?X1 ?X2) => let p := rew_term X2 in - match constr:p with + match constr:(p) with | (fct_cte ?X3) => constr:(fct_cte (X1 X3)) | _ => constr:(comp X1 p) end - | AppVar => constr:id + | AppVar => constr:(id) | (AppVar ^ ?X1) => constr:(pow_fct X1) | (?X1 ^ ?X2) => let p := rew_term X1 in - match constr:p with + match constr:(p) with | (fct_cte ?X3) => constr:(fct_cte (pow_fct X2 X3)) | _ => constr:(comp (pow_fct X2) p) end @@ -669,7 +669,7 @@ Ltac rew_term trm := (**********) Ltac deriv_proof trm pt := - match constr:trm with + match constr:(trm) with | (?X1 + ?X2)%F => let p1 := deriv_proof X1 pt with p2 := deriv_proof X2 pt in constr:(derivable_pt_plus X1 X2 pt p1 p2) @@ -684,14 +684,14 @@ Ltac deriv_proof trm pt := | id:(?X2 pt <> 0) |- _ => let p1 := deriv_proof X1 pt with p2 := deriv_proof X2 pt in constr:(derivable_pt_div X1 X2 pt p1 p2 id) - | _ => constr:False + | _ => constr:(False) end | (/ ?X1)%F => match goal with | id:(?X1 pt <> 0) |- _ => let p1 := deriv_proof X1 pt in constr:(derivable_pt_inv X1 pt p1 id) - | _ => constr:False + | _ => constr:(False) end | (comp ?X1 ?X2) => let pt_f1 := eval cbv beta in (X2 pt) in @@ -710,21 +710,21 @@ Ltac deriv_proof trm pt := | sqrt => match goal with | id:(0 < pt) |- _ => constr:(derivable_pt_sqrt pt id) - | _ => constr:False + | _ => constr:(False) end | (fct_cte ?X1) => constr:(derivable_pt_const X1 pt) | ?X1 => - let aux := constr:X1 in + let aux := constr:(X1) in match goal with - | id:(derivable_pt aux pt) |- _ => constr:id + | id:(derivable_pt aux pt) |- _ => constr:(id) | id:(derivable aux) |- _ => constr:(id pt) - | _ => constr:False + | _ => constr:(False) end end. (**********) Ltac simplify_derive trm pt := - match constr:trm with + match constr:(trm) with | (?X1 + ?X2)%F => try rewrite derive_pt_plus; simplify_derive X1 pt; simplify_derive X2 pt @@ -753,7 +753,7 @@ Ltac simplify_derive trm pt := | Rsqr => try rewrite derive_pt_Rsqr | sqrt => try rewrite derive_pt_sqrt | ?X1 => - let aux := constr:X1 in + let aux := constr:(X1) in match goal with | id:(derive_pt aux pt ?X2 = _),H:(derivable aux) |- _ => try replace (derive_pt aux pt (H pt)) with (derive_pt aux pt X2); diff --git a/theories/Reals/Ratan.v b/theories/Reals/Ratan.v index cc45139d2..e13ef1f2c 100644 --- a/theories/Reals/Ratan.v +++ b/theories/Reals/Ratan.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/Raxioms.v b/theories/Reals/Raxioms.v index f545d3a08..9d55e4e63 100644 --- a/theories/Reals/Raxioms.v +++ b/theories/Reals/Raxioms.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/Rbase.v b/theories/Reals/Rbase.v index 7a879f458..e56ce28d6 100644 --- a/theories/Reals/Rbase.v +++ b/theories/Reals/Rbase.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/Rbasic_fun.v b/theories/Reals/Rbasic_fun.v index bb30c0ef3..c889d7347 100644 --- a/theories/Reals/Rbasic_fun.v +++ b/theories/Reals/Rbasic_fun.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/Rcomplete.v b/theories/Reals/Rcomplete.v index 1766f3773..3520c26c3 100644 --- a/theories/Reals/Rcomplete.v +++ b/theories/Reals/Rcomplete.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/Rdefinitions.v b/theories/Reals/Rdefinitions.v index 50eb59b22..f3f8f7409 100644 --- a/theories/Reals/Rdefinitions.v +++ b/theories/Reals/Rdefinitions.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/Rderiv.v b/theories/Reals/Rderiv.v index 3a332d21e..bd330ac9b 100644 --- a/theories/Reals/Rderiv.v +++ b/theories/Reals/Rderiv.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/Reals.v b/theories/Reals/Reals.v index 9cb8a10bc..8265f65ad 100644 --- a/theories/Reals/Reals.v +++ b/theories/Reals/Reals.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/Rfunctions.v b/theories/Reals/Rfunctions.v index 1c353803f..0a49d4983 100644 --- a/theories/Reals/Rfunctions.v +++ b/theories/Reals/Rfunctions.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/Rgeom.v b/theories/Reals/Rgeom.v index d930c5aaf..7423ffce7 100644 --- a/theories/Reals/Rgeom.v +++ b/theories/Reals/Rgeom.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/RiemannInt.v b/theories/Reals/RiemannInt.v index 856fff80a..4c0466ac0 100644 --- a/theories/Reals/RiemannInt.v +++ b/theories/Reals/RiemannInt.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/RiemannInt_SF.v b/theories/Reals/RiemannInt_SF.v index 1484ab2a8..7885d697f 100644 --- a/theories/Reals/RiemannInt_SF.v +++ b/theories/Reals/RiemannInt_SF.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/Rlimit.v b/theories/Reals/Rlimit.v index c8887dfb5..e424a732a 100644 --- a/theories/Reals/Rlimit.v +++ b/theories/Reals/Rlimit.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/Rlogic.v b/theories/Reals/Rlogic.v index 07792942e..b9a9458c8 100644 --- a/theories/Reals/Rlogic.v +++ b/theories/Reals/Rlogic.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/Rminmax.v b/theories/Reals/Rminmax.v index ba1fe90f4..152988dcc 100644 --- a/theories/Reals/Rminmax.v +++ b/theories/Reals/Rminmax.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/Rpow_def.v b/theories/Reals/Rpow_def.v index 1d697f3c9..791718a45 100644 --- a/theories/Reals/Rpow_def.v +++ b/theories/Reals/Rpow_def.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/Rpower.v b/theories/Reals/Rpower.v index e30ea334b..b3ce6fa33 100644 --- a/theories/Reals/Rpower.v +++ b/theories/Reals/Rpower.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/Rprod.v b/theories/Reals/Rprod.v index 1ee9410fb..883e4e1a9 100644 --- a/theories/Reals/Rprod.v +++ b/theories/Reals/Rprod.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/Rseries.v b/theories/Reals/Rseries.v index fd16ea610..744fd6641 100644 --- a/theories/Reals/Rseries.v +++ b/theories/Reals/Rseries.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/Rsigma.v b/theories/Reals/Rsigma.v index 458d1f8c3..ced2b3dac 100644 --- a/theories/Reals/Rsigma.v +++ b/theories/Reals/Rsigma.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/Rsqrt_def.v b/theories/Reals/Rsqrt_def.v index b8ec8d3ca..b3c9c7449 100644 --- a/theories/Reals/Rsqrt_def.v +++ b/theories/Reals/Rsqrt_def.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/Rtopology.v b/theories/Reals/Rtopology.v index 72e4142b8..df3b95be4 100644 --- a/theories/Reals/Rtopology.v +++ b/theories/Reals/Rtopology.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/Rtrigo.v b/theories/Reals/Rtrigo.v index 440583582..ecef0d682 100644 --- a/theories/Reals/Rtrigo.v +++ b/theories/Reals/Rtrigo.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/Rtrigo1.v b/theories/Reals/Rtrigo1.v index 9e485ec5e..4d2418639 100644 --- a/theories/Reals/Rtrigo1.v +++ b/theories/Reals/Rtrigo1.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/Rtrigo_alt.v b/theories/Reals/Rtrigo_alt.v index 3d36cb341..a5092d22d 100644 --- a/theories/Reals/Rtrigo_alt.v +++ b/theories/Reals/Rtrigo_alt.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/Rtrigo_calc.v b/theories/Reals/Rtrigo_calc.v index 281c152ba..9ba14ee73 100644 --- a/theories/Reals/Rtrigo_calc.v +++ b/theories/Reals/Rtrigo_calc.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/Rtrigo_def.v b/theories/Reals/Rtrigo_def.v index ef3e31f12..0d2a9a8ba 100644 --- a/theories/Reals/Rtrigo_def.v +++ b/theories/Reals/Rtrigo_def.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/Rtrigo_fun.v b/theories/Reals/Rtrigo_fun.v index b921ee7b4..f395f9ae3 100644 --- a/theories/Reals/Rtrigo_fun.v +++ b/theories/Reals/Rtrigo_fun.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/Rtrigo_reg.v b/theories/Reals/Rtrigo_reg.v index 7845e6c46..eed612d94 100644 --- a/theories/Reals/Rtrigo_reg.v +++ b/theories/Reals/Rtrigo_reg.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/SeqProp.v b/theories/Reals/SeqProp.v index 9a6fb945e..5a2a07c42 100644 --- a/theories/Reals/SeqProp.v +++ b/theories/Reals/SeqProp.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/SeqSeries.v b/theories/Reals/SeqSeries.v index 25fe4848b..1123e7ee7 100644 --- a/theories/Reals/SeqSeries.v +++ b/theories/Reals/SeqSeries.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/SplitAbsolu.v b/theories/Reals/SplitAbsolu.v index 64f4f1c9e..a78a6e198 100644 --- a/theories/Reals/SplitAbsolu.v +++ b/theories/Reals/SplitAbsolu.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/SplitRmult.v b/theories/Reals/SplitRmult.v index fec285188..074a76315 100644 --- a/theories/Reals/SplitRmult.v +++ b/theories/Reals/SplitRmult.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Reals/Sqrt_reg.v b/theories/Reals/Sqrt_reg.v index dd8738e18..10527442e 100644 --- a/theories/Reals/Sqrt_reg.v +++ b/theories/Reals/Sqrt_reg.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Relations/Operators_Properties.v b/theories/Relations/Operators_Properties.v index 95d9cfa98..220cebeac 100644 --- a/theories/Relations/Operators_Properties.v +++ b/theories/Relations/Operators_Properties.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Relations/Relation_Definitions.v b/theories/Relations/Relation_Definitions.v index a187f955f..b6005b9d1 100644 --- a/theories/Relations/Relation_Definitions.v +++ b/theories/Relations/Relation_Definitions.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Relations/Relation_Operators.v b/theories/Relations/Relation_Operators.v index 4e52017ec..ffd682d62 100644 --- a/theories/Relations/Relation_Operators.v +++ b/theories/Relations/Relation_Operators.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Relations/Relations.v b/theories/Relations/Relations.v index ce849a167..ce6bdbc60 100644 --- a/theories/Relations/Relations.v +++ b/theories/Relations/Relations.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Setoids/Setoid.v b/theories/Setoids/Setoid.v index 75cffa7f6..55b301c37 100644 --- a/theories/Setoids/Setoid.v +++ b/theories/Setoids/Setoid.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Sets/Classical_sets.v b/theories/Sets/Classical_sets.v index aa2c144bf..8a4bb9f42 100644 --- a/theories/Sets/Classical_sets.v +++ b/theories/Sets/Classical_sets.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Sets/Constructive_sets.v b/theories/Sets/Constructive_sets.v index 193bec780..8d2344f93 100644 --- a/theories/Sets/Constructive_sets.v +++ b/theories/Sets/Constructive_sets.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Sets/Cpo.v b/theories/Sets/Cpo.v index f2fac097a..b5db90306 100644 --- a/theories/Sets/Cpo.v +++ b/theories/Sets/Cpo.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Sets/Ensembles.v b/theories/Sets/Ensembles.v index c0cddbe18..8f579214a 100644 --- a/theories/Sets/Ensembles.v +++ b/theories/Sets/Ensembles.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Sets/Finite_sets.v b/theories/Sets/Finite_sets.v index 22cb3dae5..f38dd6fdf 100644 --- a/theories/Sets/Finite_sets.v +++ b/theories/Sets/Finite_sets.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Sets/Finite_sets_facts.v b/theories/Sets/Finite_sets_facts.v index b1c12c7f9..31cc11e1a 100644 --- a/theories/Sets/Finite_sets_facts.v +++ b/theories/Sets/Finite_sets_facts.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Sets/Image.v b/theories/Sets/Image.v index 6cf4d2507..34ea857d1 100644 --- a/theories/Sets/Image.v +++ b/theories/Sets/Image.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Sets/Infinite_sets.v b/theories/Sets/Infinite_sets.v index 5860f960b..98eeb7d74 100644 --- a/theories/Sets/Infinite_sets.v +++ b/theories/Sets/Infinite_sets.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Sets/Integers.v b/theories/Sets/Integers.v index 944e0dd16..057fc9b66 100644 --- a/theories/Sets/Integers.v +++ b/theories/Sets/Integers.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Sets/Multiset.v b/theories/Sets/Multiset.v index 46dbe9942..ec38b8923 100644 --- a/theories/Sets/Multiset.v +++ b/theories/Sets/Multiset.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Sets/Partial_Order.v b/theories/Sets/Partial_Order.v index 35d5f91af..3610ebce6 100644 --- a/theories/Sets/Partial_Order.v +++ b/theories/Sets/Partial_Order.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Sets/Permut.v b/theories/Sets/Permut.v index c9c1e5b71..adbde18e6 100644 --- a/theories/Sets/Permut.v +++ b/theories/Sets/Permut.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Sets/Powerset.v b/theories/Sets/Powerset.v index 587d48ab1..d636e0468 100644 --- a/theories/Sets/Powerset.v +++ b/theories/Sets/Powerset.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Sets/Powerset_Classical_facts.v b/theories/Sets/Powerset_Classical_facts.v index 40fd5e67c..09c90506b 100644 --- a/theories/Sets/Powerset_Classical_facts.v +++ b/theories/Sets/Powerset_Classical_facts.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Sets/Powerset_facts.v b/theories/Sets/Powerset_facts.v index e9347ce31..63e84199d 100644 --- a/theories/Sets/Powerset_facts.v +++ b/theories/Sets/Powerset_facts.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Sets/Relations_1.v b/theories/Sets/Relations_1.v index c9148e007..de96fa560 100644 --- a/theories/Sets/Relations_1.v +++ b/theories/Sets/Relations_1.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Sets/Relations_1_facts.v b/theories/Sets/Relations_1_facts.v index f650a50cd..bf8a42612 100644 --- a/theories/Sets/Relations_1_facts.v +++ b/theories/Sets/Relations_1_facts.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Sets/Relations_2.v b/theories/Sets/Relations_2.v index ea48fd918..f1026e31a 100644 --- a/theories/Sets/Relations_2.v +++ b/theories/Sets/Relations_2.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Sets/Relations_2_facts.v b/theories/Sets/Relations_2_facts.v index e05435019..da93e922d 100644 --- a/theories/Sets/Relations_2_facts.v +++ b/theories/Sets/Relations_2_facts.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Sets/Relations_3.v b/theories/Sets/Relations_3.v index de6770ee0..92b299885 100644 --- a/theories/Sets/Relations_3.v +++ b/theories/Sets/Relations_3.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Sets/Relations_3_facts.v b/theories/Sets/Relations_3_facts.v index 0180c7d47..89fb900ce 100644 --- a/theories/Sets/Relations_3_facts.v +++ b/theories/Sets/Relations_3_facts.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Sets/Uniset.v b/theories/Sets/Uniset.v index 86ba903fd..e297d97e3 100644 --- a/theories/Sets/Uniset.v +++ b/theories/Sets/Uniset.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Sorting/Heap.v b/theories/Sorting/Heap.v index 6313dbf66..20c6feb9a 100644 --- a/theories/Sorting/Heap.v +++ b/theories/Sorting/Heap.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Sorting/Mergesort.v b/theories/Sorting/Mergesort.v index 593b2e9be..4b967c163 100644 --- a/theories/Sorting/Mergesort.v +++ b/theories/Sorting/Mergesort.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Sorting/PermutEq.v b/theories/Sorting/PermutEq.v index 9bae43c26..45d27e35e 100644 --- a/theories/Sorting/PermutEq.v +++ b/theories/Sorting/PermutEq.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Sorting/PermutSetoid.v b/theories/Sorting/PermutSetoid.v index 64dda4487..0697a5e47 100644 --- a/theories/Sorting/PermutSetoid.v +++ b/theories/Sorting/PermutSetoid.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Sorting/Permutation.v b/theories/Sorting/Permutation.v index fcb4e7876..8470b7955 100644 --- a/theories/Sorting/Permutation.v +++ b/theories/Sorting/Permutation.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -321,7 +321,7 @@ Proof. induction H; intros; try (injection Heqm; intros; subst; clear Heqm); discriminate || (try tauto). apply Permutation_length_1_inv in H as ->; left; auto. - apply IHPermutation1 in Heqm as [H1|H1]; apply IHPermutation2 in H1 as (); + apply IHPermutation1 in Heqm as [H1|H1]; apply IHPermutation2 in H1 as []; auto. Qed. diff --git a/theories/Sorting/Sorted.v b/theories/Sorting/Sorted.v index dc4a1e0a7..df03ff1c6 100644 --- a/theories/Sorting/Sorted.v +++ b/theories/Sorting/Sorted.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Sorting/Sorting.v b/theories/Sorting/Sorting.v index 712b8fd69..6e9702f29 100644 --- a/theories/Sorting/Sorting.v +++ b/theories/Sorting/Sorting.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Strings/Ascii.v b/theories/Strings/Ascii.v index 3dbd9cb4e..97cb746f3 100644 --- a/theories/Strings/Ascii.v +++ b/theories/Strings/Ascii.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Strings/String.v b/theories/Strings/String.v index ac1f158a3..943bb48e9 100644 --- a/theories/Strings/String.v +++ b/theories/Strings/String.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Structures/EqualitiesFacts.v b/theories/Structures/EqualitiesFacts.v index 8e2b2d081..cee3d63f0 100644 --- a/theories/Structures/EqualitiesFacts.v +++ b/theories/Structures/EqualitiesFacts.v @@ -10,7 +10,7 @@ Require Import Equalities Bool SetoidList RelationPairs. Set Implicit Arguments. -(** * Keys and datas used in MMap *) +(** * Keys and datas used in the future MMaps *) Module KeyDecidableType(D:DecidableType). @@ -60,7 +60,7 @@ Module KeyDecidableType(D:DecidableType). Hint Resolve eqke_1 eqke_2 eqk_1. - (* Additionnal facts *) + (* Additional facts *) Lemma InA_eqke_eqk {elt} p (m:list (key*elt)) : InA eqke p m -> InA eqk p m. diff --git a/theories/Structures/OrderedType.v b/theories/Structures/OrderedType.v index cc8c2261b..93ca383b2 100644 --- a/theories/Structures/OrderedType.v +++ b/theories/Structures/OrderedType.v @@ -342,7 +342,7 @@ Module KeyOrderedType(O:OrderedType). compute in Hxx'; compute in Hyy'. rewrite Hxx', Hyy'; auto. Qed. - (* Additionnal facts *) + (* Additional facts *) Lemma eqk_not_ltk : forall x x', eqk x x' -> ~ltk x x'. Proof. diff --git a/theories/Structures/OrdersEx.v b/theories/Structures/OrdersEx.v index b484257b9..89c563882 100644 --- a/theories/Structures/OrdersEx.v +++ b/theories/Structures/OrdersEx.v @@ -87,7 +87,7 @@ End PairOrderedType. (** Even if [positive] can be seen as an ordered type with respect to the usual order (see above), we can also use a lexicographic order over bits (lower bits are considered first). This is more natural when using - [positive] as indexes for sets or maps (see MSetPositive and MMapPositive. *) + [positive] as indexes for sets or maps (see MSetPositive). *) Local Open Scope positive. diff --git a/theories/Structures/OrdersFacts.v b/theories/Structures/OrdersFacts.v index 88fbd8c11..954d3df20 100644 --- a/theories/Structures/OrdersFacts.v +++ b/theories/Structures/OrdersFacts.v @@ -90,7 +90,7 @@ Module Type OrderedTypeFullFacts (Import O:OrderedTypeFull'). Instance le_order : PartialOrder eq le. Proof. compute; iorder. Qed. - Instance le_antisym : Antisymmetric eq le. + Instance le_antisym : Antisymmetric _ eq le. Proof. apply partial_order_antisym; auto with *. Qed. Lemma le_not_gt_iff : forall x y, x<=y <-> ~y<x. diff --git a/theories/Structures/OrdersLists.v b/theories/Structures/OrdersLists.v index 4d49ac84e..bf8529bc7 100644 --- a/theories/Structures/OrdersLists.v +++ b/theories/Structures/OrdersLists.v @@ -54,7 +54,7 @@ Hint Immediate In_eq Inf_lt. End OrderedTypeLists. -(** * Results about keys and data as manipulated in MMaps. *) +(** * Results about keys and data as manipulated in the future MMaps. *) Module KeyOrderedType(O:OrderedType). Include KeyDecidableType(O). (* provides eqk, eqke *) @@ -76,7 +76,7 @@ Module KeyOrderedType(O:OrderedType). Instance ltk_compat' {elt} : Proper (eqke==>eqke==>iff) (@ltk elt). Proof. eapply subrelation_proper; eauto with *. Qed. - (* Additionnal facts *) + (* Additional facts *) Instance pair_compat {elt} : Proper (O.eq==>Logic.eq==>eqke) (@pair key elt). Proof. apply pair_compat. Qed. diff --git a/theories/Unicode/Utf8.v b/theories/Unicode/Utf8.v index 3b4beda96..d5c2fa739 100644 --- a/theories/Unicode/Utf8.v +++ b/theories/Unicode/Utf8.v @@ -1,7 +1,7 @@ (* -*- coding:utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Unicode/Utf8_core.v b/theories/Unicode/Utf8_core.v index fe13f0ef0..44a0700af 100644 --- a/theories/Unicode/Utf8_core.v +++ b/theories/Unicode/Utf8_core.v @@ -1,7 +1,7 @@ (* -*- coding:utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Wellfounded/Disjoint_Union.v b/theories/Wellfounded/Disjoint_Union.v index ee4329bd7..ebfc27b38 100644 --- a/theories/Wellfounded/Disjoint_Union.v +++ b/theories/Wellfounded/Disjoint_Union.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Wellfounded/Inclusion.v b/theories/Wellfounded/Inclusion.v index d09c4112a..1ff9b0055 100644 --- a/theories/Wellfounded/Inclusion.v +++ b/theories/Wellfounded/Inclusion.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Wellfounded/Inverse_Image.v b/theories/Wellfounded/Inverse_Image.v index aa6fa6ee6..7786c8b3b 100644 --- a/theories/Wellfounded/Inverse_Image.v +++ b/theories/Wellfounded/Inverse_Image.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Wellfounded/Lexicographic_Exponentiation.v b/theories/Wellfounded/Lexicographic_Exponentiation.v index dd9e4c986..d90f9956b 100644 --- a/theories/Wellfounded/Lexicographic_Exponentiation.v +++ b/theories/Wellfounded/Lexicographic_Exponentiation.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -75,7 +75,7 @@ Section Wf_Lexicographic_Exponentiation. Proof. intros. inversion H. - - apply app_cons_not_nil in H1 as (). + - apply app_cons_not_nil in H1 as []. - assert (x ++ [a] = [x0]) by auto with sets. apply app_eq_unit in H0 as [(->, _)| (_, [=])]. auto using d_nil. @@ -95,10 +95,10 @@ Section Wf_Lexicographic_Exponentiation. intros. - inversion H. assert ([b; a] = ([] ++ [b]) ++ [a]) by auto with sets. - destruct (app_inj_tail (l ++ [y]) ([] ++ [b]) _ _ H0) as ((?, <-)/app_inj_tail, <-). + destruct (app_inj_tail (l ++ [y]) ([] ++ [b]) _ _ H0) as ((?, <-)%app_inj_tail, <-). inversion H1; subst; [ apply rt_step; assumption | apply rt_refl ]. - inversion H0. - + apply app_cons_not_nil in H3 as (). + + apply app_cons_not_nil in H3 as []. + rewrite app_comm_cons in H0, H1. apply desc_prefix in H0. pose proof (H x0 b H0). apply rt_trans with (y := x0); auto with sets. @@ -145,7 +145,7 @@ Section Wf_Lexicographic_Exponentiation. pose proof H0 as H0'. apply app_inj_tail in H0' as (_, ->). rewrite app_assoc_reverse in H0. - apply Hind in H0 as (). + apply Hind in H0 as []. split. assumption. apply d_conc; auto with sets. diff --git a/theories/Wellfounded/Lexicographic_Product.v b/theories/Wellfounded/Lexicographic_Product.v index 0d8ed8dd1..4b8447f49 100644 --- a/theories/Wellfounded/Lexicographic_Product.v +++ b/theories/Wellfounded/Lexicographic_Product.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Wellfounded/Transitive_Closure.v b/theories/Wellfounded/Transitive_Closure.v index b76e9661c..eb12d5d7b 100644 --- a/theories/Wellfounded/Transitive_Closure.v +++ b/theories/Wellfounded/Transitive_Closure.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Wellfounded/Union.v b/theories/Wellfounded/Union.v index b2e8ea928..61355c8d1 100644 --- a/theories/Wellfounded/Union.v +++ b/theories/Wellfounded/Union.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Wellfounded/Well_Ordering.v b/theories/Wellfounded/Well_Ordering.v index f8a17b56f..b5acc2877 100644 --- a/theories/Wellfounded/Well_Ordering.v +++ b/theories/Wellfounded/Well_Ordering.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/Wellfounded/Wellfounded.v b/theories/Wellfounded/Wellfounded.v index a76d5e951..397f35aab 100644 --- a/theories/Wellfounded/Wellfounded.v +++ b/theories/Wellfounded/Wellfounded.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/ZArith/BinInt.v b/theories/ZArith/BinInt.v index cb0c6880c..5aa397f8a 100644 --- a/theories/ZArith/BinInt.v +++ b/theories/ZArith/BinInt.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/ZArith/BinIntDef.v b/theories/ZArith/BinIntDef.v index 9bb86fd53..8c2e7d941 100644 --- a/theories/ZArith/BinIntDef.v +++ b/theories/ZArith/BinIntDef.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/ZArith/Int.v b/theories/ZArith/Int.v index d210792f9..32e13d389 100644 --- a/theories/ZArith/Int.v +++ b/theories/ZArith/Int.v @@ -225,11 +225,11 @@ Module MoreInt (Import I:Int). (** [int] to [ExprI] *) Ltac i2ei trm := - match constr:trm with - | 0 => constr:EI0 - | 1 => constr:EI1 - | 2 => constr:EI2 - | 3 => constr:EI3 + match constr:(trm) with + | 0 => constr:(EI0) + | 1 => constr:(EI1) + | 2 => constr:(EI2) + | 3 => constr:(EI3) | ?x + ?y => let ex := i2ei x with ey := i2ei y in constr:(EIadd ex ey) | ?x - ?y => let ex := i2ei x with ey := i2ei y in constr:(EIsub ex ey) | ?x * ?y => let ex := i2ei x with ey := i2ei y in constr:(EImul ex ey) @@ -241,7 +241,7 @@ Module MoreInt (Import I:Int). (** [Z] to [ExprZ] *) with z2ez trm := - match constr:trm with + match constr:(trm) with | (?x + ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZadd ex ey) | (?x - ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZsub ex ey) | (?x * ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZmul ex ey) @@ -254,7 +254,7 @@ Module MoreInt (Import I:Int). (** [Prop] to [ExprP] *) Ltac p2ep trm := - match constr:trm with + match constr:(trm) with | (?x <-> ?y) => let ex := p2ep x with ey := p2ep y in constr:(EPequiv ex ey) | (?x -> ?y) => let ex := p2ep x with ey := p2ep y in constr:(EPimpl ex ey) | (?x /\ ?y) => let ex := p2ep x with ey := p2ep y in constr:(EPand ex ey) diff --git a/theories/ZArith/Wf_Z.v b/theories/ZArith/Wf_Z.v index 09909bdb6..4fbbac268 100644 --- a/theories/ZArith/Wf_Z.v +++ b/theories/ZArith/Wf_Z.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/ZArith/ZArith.v b/theories/ZArith/ZArith.v index 04cccd048..f86a7e52a 100644 --- a/theories/ZArith/ZArith.v +++ b/theories/ZArith/ZArith.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/ZArith/ZArith_base.v b/theories/ZArith/ZArith_base.v index 4c93173bf..a1da544de 100644 --- a/theories/ZArith/ZArith_base.v +++ b/theories/ZArith/ZArith_base.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/ZArith/ZArith_dec.v b/theories/ZArith/ZArith_dec.v index ac69cebd0..8947295e0 100644 --- a/theories/ZArith/ZArith_dec.v +++ b/theories/ZArith/ZArith_dec.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/ZArith/Zabs.v b/theories/ZArith/Zabs.v index 146009bcc..df9db5b22 100644 --- a/theories/ZArith/Zabs.v +++ b/theories/ZArith/Zabs.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/ZArith/Zbool.v b/theories/ZArith/Zbool.v index 61eb2a340..41d1b2b50 100644 --- a/theories/ZArith/Zbool.v +++ b/theories/ZArith/Zbool.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/ZArith/Zcompare.v b/theories/ZArith/Zcompare.v index d4ac72e94..2627f1743 100644 --- a/theories/ZArith/Zcompare.v +++ b/theories/ZArith/Zcompare.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/ZArith/Zcomplements.v b/theories/ZArith/Zcomplements.v index 9604a06e4..5bdb32fcf 100644 --- a/theories/ZArith/Zcomplements.v +++ b/theories/ZArith/Zcomplements.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/ZArith/Zdigits.v b/theories/ZArith/Zdigits.v index b5d04719c..bc3694bc1 100644 --- a/theories/ZArith/Zdigits.v +++ b/theories/ZArith/Zdigits.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/ZArith/Zdiv.v b/theories/ZArith/Zdiv.v index d0d10891a..2ba865bd0 100644 --- a/theories/ZArith/Zdiv.v +++ b/theories/ZArith/Zdiv.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -279,7 +279,7 @@ Proof. intros; rewrite Z.div_exact; auto. Qed. Theorem Zmod_le: forall a b, 0 < b -> 0 <= a -> a mod b <= a. Proof. intros. apply Z.mod_le; auto. Qed. -(** Some additionnal inequalities about Z.div. *) +(** Some additional inequalities about Z.div. *) Theorem Zdiv_lt_upper_bound: forall a b q, 0 < b -> a < q*b -> a/b < q. diff --git a/theories/ZArith/Zeuclid.v b/theories/ZArith/Zeuclid.v index f5cacc7ec..38a824cd4 100644 --- a/theories/ZArith/Zeuclid.v +++ b/theories/ZArith/Zeuclid.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/ZArith/Zeven.v b/theories/ZArith/Zeven.v index d88bf7a98..d4051ef71 100644 --- a/theories/ZArith/Zeven.v +++ b/theories/ZArith/Zeven.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/ZArith/Zgcd_alt.v b/theories/ZArith/Zgcd_alt.v index 14286bde1..3977ca9d3 100644 --- a/theories/ZArith/Zgcd_alt.v +++ b/theories/ZArith/Zgcd_alt.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/ZArith/Zhints.v b/theories/ZArith/Zhints.v index 1942c2ab0..c4e201e32 100644 --- a/theories/ZArith/Zhints.v +++ b/theories/ZArith/Zhints.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/ZArith/Zlogarithm.v b/theories/ZArith/Zlogarithm.v index 6e3495690..fdfd71e12 100644 --- a/theories/ZArith/Zlogarithm.v +++ b/theories/ZArith/Zlogarithm.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/ZArith/Zmax.v b/theories/ZArith/Zmax.v index c436b3ad8..529e9f1d4 100644 --- a/theories/ZArith/Zmax.v +++ b/theories/ZArith/Zmax.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/ZArith/Zmin.v b/theories/ZArith/Zmin.v index 1cfa2e035..782a51586 100644 --- a/theories/ZArith/Zmin.v +++ b/theories/ZArith/Zmin.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/ZArith/Zminmax.v b/theories/ZArith/Zminmax.v index 05a94a8e9..ea9a5f861 100644 --- a/theories/ZArith/Zminmax.v +++ b/theories/ZArith/Zminmax.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/ZArith/Zmisc.v b/theories/ZArith/Zmisc.v index b401e6b66..65831c783 100644 --- a/theories/ZArith/Zmisc.v +++ b/theories/ZArith/Zmisc.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/ZArith/Znat.v b/theories/ZArith/Znat.v index 20e7c2e88..06428a7c4 100644 --- a/theories/ZArith/Znat.v +++ b/theories/ZArith/Znat.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/ZArith/Znumtheory.v b/theories/ZArith/Znumtheory.v index f69cf3156..ee6efb3cb 100644 --- a/theories/ZArith/Znumtheory.v +++ b/theories/ZArith/Znumtheory.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/ZArith/Zorder.v b/theories/ZArith/Zorder.v index e090302ed..73dee0cf2 100644 --- a/theories/ZArith/Zorder.v +++ b/theories/ZArith/Zorder.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/ZArith/Zpow_alt.v b/theories/ZArith/Zpow_alt.v index 8f661a9c8..79a5a555e 100644 --- a/theories/ZArith/Zpow_alt.v +++ b/theories/ZArith/Zpow_alt.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -11,7 +11,7 @@ Local Open Scope Z_scope. (** An alternative power function for Z *) -(** This [Zpower_alt] is extensionnaly equal to [Z.pow], +(** This [Zpower_alt] is extensionally equal to [Z.pow], but not convertible with it. The number of multiplications is logarithmic instead of linear, but these multiplications are bigger. Experimentally, it seems diff --git a/theories/ZArith/Zpow_def.v b/theories/ZArith/Zpow_def.v index 740c45fd1..9eafa0769 100644 --- a/theories/ZArith/Zpow_def.v +++ b/theories/ZArith/Zpow_def.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/ZArith/Zpow_facts.v b/theories/ZArith/Zpow_facts.v index ac41a98f6..2930e677d 100644 --- a/theories/ZArith/Zpow_facts.v +++ b/theories/ZArith/Zpow_facts.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/ZArith/Zpower.v b/theories/ZArith/Zpower.v index 747bd4fd2..6f3a89f18 100644 --- a/theories/ZArith/Zpower.v +++ b/theories/ZArith/Zpower.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/ZArith/Zquot.v b/theories/ZArith/Zquot.v index 3ef111898..0d92f1d54 100644 --- a/theories/ZArith/Zquot.v +++ b/theories/ZArith/Zquot.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -243,7 +243,7 @@ Proof. intros. zero_or_not b. intuition. apply Z.quot_exact; auto. Qed. Theorem Zrem_le a b : 0 <= a -> 0 <= b -> Z.rem a b <= a. Proof. intros. zero_or_not b. apply Z.rem_le; auto with zarith. Qed. -(** Some additionnal inequalities about Zdiv. *) +(** Some additional inequalities about Zdiv. *) Theorem Zquot_le_upper_bound: forall a b q, 0 < b -> a <= q*b -> a÷b <= q. diff --git a/theories/ZArith/Zsqrt_compat.v b/theories/ZArith/Zsqrt_compat.v index 65959a69b..f4baba190 100644 --- a/theories/ZArith/Zsqrt_compat.v +++ b/theories/ZArith/Zsqrt_compat.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -30,12 +30,12 @@ Local Open Scope Z_scope. Ltac compute_POS := match goal with | |- context [(Zpos (xI ?X1))] => - match constr:X1 with + match constr:(X1) with | context [1%positive] => fail 1 | _ => rewrite (Pos2Z.inj_xI X1) end | |- context [(Zpos (xO ?X1))] => - match constr:X1 with + match constr:(X1) with | context [1%positive] => fail 1 | _ => rewrite (Pos2Z.inj_xO X1) end diff --git a/theories/ZArith/Zwf.v b/theories/ZArith/Zwf.v index cba709e86..1ac00bddd 100644 --- a/theories/ZArith/Zwf.v +++ b/theories/ZArith/Zwf.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/ZArith/auxiliary.v b/theories/ZArith/auxiliary.v index 25ef852a5..c6c389760 100644 --- a/theories/ZArith/auxiliary.v +++ b/theories/ZArith/auxiliary.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/theories/theories.itarget b/theories/theories.itarget index b7de41641..aacab2d97 100644 --- a/theories/theories.itarget +++ b/theories/theories.itarget @@ -4,7 +4,6 @@ Classes/vo.otarget Compat/vo.otarget FSets/vo.otarget MSets/vo.otarget -MMaps/vo.otarget Structures/vo.otarget Init/vo.otarget Lists/vo.otarget diff --git a/tools/compat5.ml b/tools/compat5.ml index 041ced004..33c1cd602 100644 --- a/tools/compat5.ml +++ b/tools/compat5.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/tools/compat5.mlp b/tools/compat5.mlp index 91e3cdae5..8473a1fb7 100644 --- a/tools/compat5.mlp +++ b/tools/compat5.mlp @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/tools/compat5b.ml b/tools/compat5b.ml index a2336e101..37cb487c5 100644 --- a/tools/compat5b.ml +++ b/tools/compat5b.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/tools/compat5b.mlp b/tools/compat5b.mlp index d4dfcc07d..46802a825 100644 --- a/tools/compat5b.mlp +++ b/tools/compat5b.mlp @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml index e0475646f..7b76514e4 100644 --- a/tools/coq_makefile.ml +++ b/tools/coq_makefile.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -43,6 +43,16 @@ let section s = print_com (String.make (l+2) '#'); print "\n" +(* These are the Coq library directories that are used for + * plugin development + *) +let lib_dirs = + ["kernel"; "lib"; "library"; "parsing"; + "pretyping"; "interp"; "printing"; "intf"; + "proofs"; "tactics"; "tools"; "toplevel"; + "stm"; "grammar"; "config"; "ltac"; "engine"] + + let usage () = output_string stderr "Usage summary: @@ -99,7 +109,13 @@ let string_prefix a b = let is_prefix dir1 dir2 = let l1 = String.length dir1 in let l2 = String.length dir2 in - dir1 = dir2 || (l1 < l2 && String.sub dir2 0 l1 = dir1 && dir2.[l1] = '/') + let sep = Filename.dir_sep in + if dir1 = dir2 then true + else if l1 + String.length sep <= l2 then + let dir1' = String.sub dir2 0 l1 in + let sep' = String.sub dir2 l1 (String.length sep) in + dir1' = dir1 && sep' = sep + else false let physical_dir_of_logical_dir ldir = let le = String.length ldir - 1 in @@ -446,12 +462,8 @@ let variables is_install opt (args,defs) = end; (* Caml executables and relative variables *) if !some_ml4file || !some_mlfile || !some_mlifile then begin - print "COQSRCLIBS?=-I \"$(COQLIB)kernel\" -I \"$(COQLIB)lib\" \\ - -I \"$(COQLIB)library\" -I \"$(COQLIB)parsing\" -I \"$(COQLIB)engine\" -I \"$(COQLIB)pretyping\" \\ - -I \"$(COQLIB)interp\" -I \"$(COQLIB)printing\" -I \"$(COQLIB)intf\" \\ - -I \"$(COQLIB)proofs\" -I \"$(COQLIB)tactics\" -I \"$(COQLIB)tools\" \\ - -I \"$(COQLIB)toplevel\" -I \"$(COQLIB)stm\" -I \"$(COQLIB)grammar\" \\ - -I \"$(COQLIB)config\""; + print "COQSRCLIBS?=" ; + List.iter (fun c -> print "-I \"$(COQLIB)"; print c ; print "\" \\\n") lib_dirs ; List.iter (fun c -> print " \\ -I \"$(COQLIB)/"; print c; print "\"") Coq_config.plugins_dirs; print "\n"; print "ZFLAGS=$(OCAMLLIBS) $(COQSRCLIBS) -I $(CAMLP4LIB)\n\n"; @@ -794,6 +806,21 @@ let check_overlapping_include (_,inc_i,inc_r) = Printf.eprintf "Warning: in options -R/-Q, %s and %s overlap\n" pdir pdir') l; in aux (inc_i@inc_r) +(* Generate a .merlin file that references the standard library and + * any -I included paths. + *) +let merlin targets (ml_inc,_,_) = + print ".merlin:\n"; + print "\t@echo 'FLG -rectypes' > .merlin\n" ; + List.iter (fun c -> + printf "\t@echo \"B $(COQLIB) %s\" >> .merlin\n" c) + lib_dirs ; + List.iter (fun (_,c) -> + printf "\t@echo \"B %s\" >> .merlin\n" c; + printf "\t@echo \"S %s\" >> .merlin\n" c) + ml_inc; + print "\n" + let do_makefile args = let has_file var = function |[] -> var := false @@ -836,6 +863,7 @@ let do_makefile args = section "Special targets."; standard opt; install targets inc is_install; + merlin targets inc; clean sds sps; make_makefile sds; implicit (); diff --git a/tools/coq_tex.ml b/tools/coq_tex.ml index dbdc2e9db..e17011b39 100644 --- a/tools/coq_tex.ml +++ b/tools/coq_tex.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/tools/coqc.ml b/tools/coqc.ml index e7239da68..f957200ab 100644 --- a/tools/coqc.ml +++ b/tools/coqc.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -70,17 +70,6 @@ let parse_args () = | "-byte" :: rem -> binary := "coqtop.byte"; parse (cfiles,args) rem | "-opt" :: rem -> binary := "coqtop"; parse (cfiles,args) rem -(* Obsolete options *) - - | "-libdir" :: _ :: rem -> - print_string "Warning: option -libdir deprecated and ignored\n"; - flush stdout; - parse (cfiles,args) rem - | ("-db"|"-debugger") :: rem -> - print_string "Warning: option -db/-debugger deprecated and ignored\n"; - flush stdout; - parse (cfiles,args) rem - (* Informative options *) | ("-?"|"-h"|"-H"|"-help"|"--help") :: _ -> usage () @@ -124,21 +113,11 @@ let parse_args () = | s :: rem' -> parse (cfiles,s::o::args) rem' | [] -> usage () end + | ("-I"|"-include" as o) :: s :: rem -> parse (cfiles,s::o::args) rem (* Options for coqtop : c) options with 1 argument and possibly more *) - | ("-I"|"-include" as o) :: rem -> - begin - match rem with - | s :: "-as" :: t :: rem' -> parse (cfiles,t::"-as"::s::o::args) rem' - | s :: "-as" :: [] -> usage () - | s :: rem' -> parse (cfiles,s::o::args) rem' - | [] -> usage () - end - | "-R" :: s :: "-as" :: t :: rem -> parse (cfiles,t::"-as"::s::"-R"::args) rem - | "-R" :: s :: "-as" :: [] -> usage () - | "-R" :: s :: t :: rem -> parse (cfiles,t::s::"-R"::args) rem - | "-Q" :: s :: t :: rem -> parse (cfiles,t::s::"-Q"::args) rem + | ("-R"|"-Q" as o) :: s :: t :: rem -> parse (cfiles,t::s::o::args) rem | ("-schedule-vio-checking" |"-check-vio-tasks" | "-schedule-vio2vo" as o) :: s :: rem -> let nodash, rem = diff --git a/tools/coqdep.ml b/tools/coqdep.ml index be50b0e1c..13705edaa 100644 --- a/tools/coqdep.ml +++ b/tools/coqdep.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -427,11 +427,28 @@ let coq_dependencies_dump chan dumpboxes = end let usage () = - eprintf " usage: coqdep [-w] [-c] [-D] [-I dir] [-R dir coqdir] <filename>+\n"; - eprintf " extra options:\n"; - eprintf " -coqlib dir : set the coq standard library directory\n"; - eprintf " -exclude-dir f : skip subdirectories named 'f' during -R search\n"; + eprintf " usage: coqdep [options] <filename>+\n"; + eprintf " options:\n"; + eprintf " -c : Also print the dependencies of caml modules (=ocamldep).\n"; + (* Does not work anymore *) + (* eprintf " -w : Print informations on missing or wrong \"Declare + ML Module\" commands in coq files.\n"; *) + (* Does not work anymore: *) + (* eprintf " -D : Prints the missing ocmal module names. No dependency computed.\n"; *) + eprintf " -boot : For coq developpers, prints dependencies over coq library files (omitted by default).\n"; + eprintf " -sort : output the given file name ordered by dependencies\n"; + eprintf " -noglob | -no-glob : \n"; + eprintf " -I dir -as logname : add (non recursively) dir to coq load path under logical name logname\n"; + eprintf " -I dir : add (non recursively) dir to ocaml path\n"; + eprintf " -R dir -as logname : add and import dir recursively to coq load path under logical name logname\n"; (* deprecate? *) + eprintf " -R dir logname : add and import dir recursively to coq load path under logical name logname\n"; + eprintf " -Q dir logname : add (recusively) and open (non recursively) dir to coq load path under logical name logname\n"; eprintf " -dumpgraph f : print a dot dependency graph in file 'f'\n"; + eprintf " -dumpgraphbox f : print a dot dependency graph box in file 'f'\n"; + eprintf " -exclude-dir dir : skip subdirectories named 'dir' during -R/-Q search\n"; + eprintf " -coqlib dir : set the coq standard library directory\n"; + eprintf " -suffix s : \n"; + eprintf " -slash : deprecated, no effect\n"; exit 1 let split_period = Str.split (Str.regexp (Str.quote ".")) @@ -443,16 +460,10 @@ let rec parse = function | "-boot" :: ll -> option_boot := true; parse ll | "-sort" :: ll -> option_sort := true; parse ll | ("-noglob" | "-no-glob") :: ll -> option_noglob := true; parse ll - | "-I" :: r :: "-as" :: ln :: ll -> add_dir add_known r []; - add_dir add_known r (split_period ln); - parse ll - | "-I" :: r :: "-as" :: [] -> usage () | "-I" :: r :: ll -> add_caml_dir r; parse ll | "-I" :: [] -> usage () - | "-R" :: r :: "-as" :: ln :: ll -> add_rec_dir add_known r (split_period ln); parse ll - | "-R" :: r :: "-as" :: [] -> usage () - | "-R" :: r :: ln :: ll -> add_rec_dir add_known r (split_period ln); parse ll - | "-Q" :: r :: ln :: ll -> add_dir add_known r (split_period ln); parse ll + | "-R" :: r :: ln :: ll -> add_rec_dir_import add_known r (split_period ln); parse ll + | "-Q" :: r :: ln :: ll -> add_rec_dir_no_import add_known r (split_period ln); parse ll | "-R" :: ([] | [_]) -> usage () | "-dumpgraph" :: f :: ll -> option_dump := Some (false, f); parse ll | "-dumpgraphbox" :: f :: ll -> option_dump := Some (true, f); parse ll @@ -472,24 +483,27 @@ let rec parse = function let coqdep () = if Array.length Sys.argv < 2 then usage (); parse (List.tl (Array.to_list Sys.argv)); + (* Add current dir with empty logical path if not set by options above. *) + (try ignore (Coqdep_common.find_dir_logpath (Sys.getcwd())) + with Not_found -> add_norec_dir_import add_known "." []); if not Coq_config.has_natdynlink then option_natdynlk := false; (* NOTE: These directories are searched from last to first *) if !option_boot then begin - add_rec_dir add_known "theories" ["Coq"]; - add_rec_dir add_known "plugins" ["Coq"]; + add_rec_dir_import add_known "theories" ["Coq"]; + add_rec_dir_import add_known "plugins" ["Coq"]; add_caml_dir "tactics"; - add_rec_dir (fun _ -> add_caml_known) "theories" ["Coq"]; - add_rec_dir (fun _ -> add_caml_known) "plugins" ["Coq"]; + add_rec_dir_import (fun _ -> add_caml_known) "theories" ["Coq"]; + add_rec_dir_import (fun _ -> add_caml_known) "plugins" ["Coq"]; end else begin Envars.set_coqlib ~fail:Errors.error; let coqlib = Envars.coqlib () in - add_rec_dir add_coqlib_known (coqlib//"theories") ["Coq"]; - add_rec_dir add_coqlib_known (coqlib//"plugins") ["Coq"]; + add_rec_dir_import add_coqlib_known (coqlib//"theories") ["Coq"]; + add_rec_dir_import add_coqlib_known (coqlib//"plugins") ["Coq"]; let user = coqlib//"user-contrib" in - if Sys.file_exists user then add_dir add_coqlib_known user []; - List.iter (fun s -> add_dir add_coqlib_known s []) + if Sys.file_exists user then add_rec_dir_no_import add_coqlib_known user []; + List.iter (fun s -> add_rec_dir_no_import add_coqlib_known s []) (Envars.xdg_dirs (fun x -> Pp.msg_warning (Pp.str x))); - List.iter (fun s -> add_dir add_coqlib_known s []) Envars.coqpath; + List.iter (fun s -> add_rec_dir_no_import add_coqlib_known s []) Envars.coqpath; end; List.iter (fun (f,d) -> add_mli_known f d ".mli") !mliAccu; List.iter (fun (f,d) -> add_mllib_known f d ".mllib") !mllibAccu; diff --git a/tools/coqdep_boot.ml b/tools/coqdep_boot.ml new file mode 100644 index 000000000..6fc826833 --- /dev/null +++ b/tools/coqdep_boot.ml @@ -0,0 +1,49 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Coqdep_common + +(** [coqdep_boot] is a stripped-down version of [coqdep], whose + behavior is the one of [coqdep -boot]. Its only dependencies + are [Coqdep_lexer], [Coqdep_common] and [Unix], and it should stay so. + If it needs someday some additional information, pass it via + options (see for instance [option_natdynlk] below). +*) + +let rec parse = function + | "-natdynlink" :: "no" :: ll -> option_natdynlk := false; parse ll + | "-c" :: ll -> option_c := true; parse ll + | "-boot" :: ll -> parse ll (* We're already in boot mode by default *) + | "-mldep" :: ocamldep :: ll -> + option_mldep := Some ocamldep; option_c := true; parse ll + | "-I" :: r :: ll -> + (* To solve conflict (e.g. same filename in kernel and checker) + we allow to state an explicit order *) + add_caml_dir r; + norec_dirs := StrSet.add r !norec_dirs; + parse ll + | f :: ll -> treat_file None f; parse ll + | [] -> () + +let _ = + let () = option_boot := true in + if Array.length Sys.argv < 2 then exit 1; + parse (List.tl (Array.to_list Sys.argv)); + if !option_c then begin + add_rec_dir_import add_known "." []; + add_rec_dir_import (fun _ -> add_caml_known) "." ["Coq"]; + end + else begin + add_rec_dir_import add_known "theories" ["Coq"]; + add_rec_dir_import add_known "plugins" ["Coq"]; + add_caml_dir "tactics"; + add_rec_dir_import (fun _ -> add_caml_known) "theories" ["Coq"]; + add_rec_dir_import (fun _ -> add_caml_known) "plugins" ["Coq"]; + end; + if !option_c then mL_dependencies (); + coq_dependencies () diff --git a/tools/coqdep_common.ml b/tools/coqdep_common.ml index 2cdb66aa7..c63e4aaa6 100644 --- a/tools/coqdep_common.ml +++ b/tools/coqdep_common.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -165,11 +165,6 @@ let warning_module_notfound f s = 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; - eprintf "%s.v is required and has not been found!\n" s; - flush stderr - let warning_declare f s = eprintf "*** Warning: in file %s, declared ML module " f; eprintf "%s has not been found!\n" s; @@ -210,6 +205,18 @@ let absolute_file_name basename odir = let dir = match odir with Some dir -> dir | None -> "." in absolute_dir dir // basename +(** [find_dir_logpath dir] Return the logical path of directory [dir] + if it has been given one. Raise [Not_found] otherwise. In + particular we can check if "." has been attributed a logical path + after processing all options and silently give the default one if + it hasn't. We may also use this to warn if ap hysical path is met + twice.*) +let register_dir_logpath,find_dir_logpath = + let tbl: (string, string list) Hashtbl.t = Hashtbl.create 19 in + let reg physdir logpath = Hashtbl.add tbl (absolute_dir physdir) logpath in + let fnd physdir = Hashtbl.find tbl (absolute_dir physdir) in + reg,fnd + let file_name s = function | None -> s | Some "." -> s @@ -329,7 +336,8 @@ let escape = Buffer.contents s' let compare_file f1 f2 = - absolute_dir (Filename.dirname f1) = absolute_dir (Filename.dirname f2) + absolute_file_name (Filename.basename f1) (Some (Filename.dirname f1)) + = absolute_file_name (Filename.basename f2) (Some (Filename.dirname f2)) let canonize f = let f' = absolute_dir (Filename.dirname f) // Filename.basename f in @@ -481,15 +489,15 @@ let add_caml_known phys_dir _ f = | _ -> () let add_coqlib_known recur phys_dir log_dir f = - match get_extension f [".vo"] with - | (basename,".vo") -> + match get_extension f [".vo"; ".vio"] with + | (basename, (".vo" | ".vio")) -> 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 + match get_extension f [".v"; ".vo"; ".vio"] with | (basename,".v") -> let name = log_dir@[basename] in let file = phys_dir//basename in @@ -498,7 +506,7 @@ let add_known recur phys_dir log_dir f = 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) -> + | (basename, (".vo" | ".vio")) when not(!option_boot) -> 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 @@ -509,11 +517,12 @@ let add_known recur phys_dir log_dir f = let is_not_seen_directory phys_f = not (StrSet.mem phys_f !norec_dirs) -let rec add_directory add_file phys_dir log_dir = +let rec add_directory recur add_file phys_dir log_dir = + register_dir_logpath phys_dir log_dir; let f = function | FileDir (phys_f,f) -> - if is_not_seen_directory phys_f then - add_directory add_file phys_f (log_dir @ [f]) + if is_not_seen_directory phys_f && recur then + add_directory true add_file phys_f (log_dir @ [f]) | FileRegular f -> add_file phys_dir log_dir f in @@ -523,24 +532,29 @@ let rec add_directory add_file phys_dir log_dir = else warning_cannot_open_dir phys_dir +(** Simply add this directory and imports it, no subdirs. This is used + by the implicit adding of the current path (which is not recursive). *) +let add_norec_dir_import add_file phys_dir log_dir = + try add_directory false (add_file true) phys_dir log_dir with Unix_error _ -> () + (** -Q semantic: go in subdirs but only full logical paths are known. *) -let add_dir add_file phys_dir log_dir = - try add_directory (add_file false) phys_dir log_dir with Unix_error _ -> () +let add_rec_dir_no_import add_file phys_dir log_dir = + try add_directory true (add_file false) phys_dir log_dir with Unix_error _ -> () (** -R semantic: go in subdirs and suffixes of logical paths are known. *) -let add_rec_dir add_file phys_dir log_dir = - add_directory (add_file true) phys_dir log_dir +let add_rec_dir_import add_file phys_dir log_dir = + add_directory true (add_file true) phys_dir log_dir (** -R semantic but only on immediate capitalized subdirs *) let add_rec_uppercase_subdirs add_file phys_dir log_dir = process_subdirectories (fun phys_dir f -> - add_directory (add_file true) phys_dir (log_dir@[String.capitalize f])) + add_directory true (add_file true) phys_dir (log_dir@[String.capitalize f])) phys_dir (** -I semantic: do not go in subdirs. *) let add_caml_dir phys_dir = - add_directory add_caml_known phys_dir [] + add_directory false add_caml_known phys_dir [] let rec treat_file old_dirname old_name = let name = Filename.basename old_name @@ -555,15 +569,12 @@ let rec treat_file old_dirname old_name = match try (stat complete_name).st_kind with _ -> S_BLK with | S_DIR -> (if name.[0] <> '.' then - let dir=opendir complete_name in let newdirname = match dirname with | None -> name | Some d -> d//name in - try - while true do treat_file (Some newdirname) (readdir dir) done - with End_of_file -> closedir dir) + Array.iter (treat_file (Some newdirname)) (Sys.readdir complete_name)) | S_REG -> (match get_extension name [".v";".ml";".mli";".ml4";".mllib";".mlpack"] with | (base,".v") -> diff --git a/tools/coqdep_common.mli b/tools/coqdep_common.mli index c3570f811..633c474ad 100644 --- a/tools/coqdep_common.mli +++ b/tools/coqdep_common.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,6 +8,14 @@ module StrSet : Set.S with type elt = string +(** [find_dir_logpath dir] Return the logical path of directory [dir] + if it has been given one. Raise [Not_found] otherwise. In + particular we can check if "." has been attributed a logical path + after processing all options and silently give the default one if + it hasn't. We may also use this to warn if ap hysical path is met + twice.*) +val find_dir_logpath: string -> string list + val option_c : bool ref val option_noglob : bool ref val option_boot : bool ref @@ -42,11 +50,22 @@ 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_caml_dir : string -> unit -val add_dir : + +(** Simply add this directory and imports it, no subdirs. This is used + by the implicit adding of the current path. *) +val add_norec_dir_import : (bool -> string -> string list -> string -> unit) -> string -> string list -> unit -val add_rec_dir : + +(** -Q semantic: go in subdirs but only full logical paths are known. *) +val add_rec_dir_no_import : (bool -> string -> string list -> string -> unit) -> string -> string list -> unit + +(** -R semantic: go in subdirs and suffixes of logical paths are known. *) +val add_rec_dir_import : + (bool -> string -> string list -> string -> unit) -> string -> string list -> unit + val add_rec_uppercase_subdirs : (bool -> string -> string list -> string -> unit) -> string -> string list -> unit + val treat_file : dir -> string -> unit val error_cannot_parse : string -> int * int -> 'a diff --git a/tools/coqdep_lexer.mli b/tools/coqdep_lexer.mli index 84c9ba798..bb17fdf9f 100644 --- a/tools/coqdep_lexer.mli +++ b/tools/coqdep_lexer.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/tools/coqdep_lexer.mll b/tools/coqdep_lexer.mll index 291bc55fb..eb233b8f9 100644 --- a/tools/coqdep_lexer.mll +++ b/tools/coqdep_lexer.mll @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -25,13 +25,6 @@ exception Fin_fichier exception Syntax_error of int*int - let module_current_name = ref [] - let module_names = ref [] - let ml_module_name = ref "" - let loadpath = ref "" - - let mllist = ref ([] : string list) - let field_name s = String.sub s 1 (String.length s - 1) let unquote_string s = @@ -46,11 +39,6 @@ let syntax_error lexbuf = raise (Syntax_error (Lexing.lexeme_start lexbuf, Lexing.lexeme_end lexbuf)) - - (** This is the prefix that should be pre-prepended to files due to the use - ** of [From], i.e. [From Xxx... Require ...] - **) - let from_pre_ident = ref None } let space = [' ' '\t' '\n' '\r'] @@ -81,9 +69,9 @@ let dot = '.' ( space+ | eof) rule coq_action = parse | "Require" space+ - { require_modifiers lexbuf } + { require_modifiers None lexbuf } | "Local"? "Declare" space+ "ML" space+ "Module" space+ - { mllist := []; modules lexbuf } + { modules [] lexbuf } | "Load" space+ { load_file lexbuf } | "Add" space+ "LoadPath" space+ @@ -109,38 +97,34 @@ and from_rule = parse | space+ { from_rule lexbuf } | coq_ident - { module_current_name := [Lexing.lexeme lexbuf]; - from_pre_ident := Some (coq_qual_id_tail lexbuf); - module_names := []; - consume_require lexbuf } + { let from = coq_qual_id_tail [Lexing.lexeme lexbuf] lexbuf in + consume_require (Some from) lexbuf } | eof { syntax_error lexbuf } | _ { syntax_error lexbuf } -and require_modifiers = parse +and require_modifiers from = parse | "(*" - { comment lexbuf; require_modifiers lexbuf } + { comment lexbuf; require_modifiers from lexbuf } | "Import" space+ - { require_file lexbuf } + { require_file from lexbuf } | "Export" space+ - { require_file lexbuf } + { require_file from lexbuf } | space+ - { require_modifiers lexbuf } + { require_modifiers from lexbuf } | eof { syntax_error lexbuf } | _ - { backtrack lexbuf ; require_file lexbuf } + { backtrack lexbuf ; require_file from lexbuf } -and consume_require = parse +and consume_require from = parse | "(*" - { comment lexbuf; consume_require lexbuf } + { comment lexbuf; consume_require from lexbuf } | space+ - { consume_require lexbuf } + { consume_require from lexbuf } | "Require" space+ - { require_modifiers lexbuf } - | eof - { syntax_error lexbuf } + { require_modifiers from lexbuf } | _ { syntax_error lexbuf } @@ -152,20 +136,19 @@ and add_loadpath = parse | eof { syntax_error lexbuf } | '"' [^ '"']* '"' (*'"'*) - { loadpath := unquote_string (lexeme lexbuf); - add_loadpath_as lexbuf } + { add_loadpath_as (unquote_string (lexeme lexbuf)) lexbuf } -and add_loadpath_as = parse +and add_loadpath_as path = parse | "(*" - { comment lexbuf; add_loadpath_as lexbuf } + { comment lexbuf; add_loadpath_as path lexbuf } | space+ - { add_loadpath_as lexbuf } + { add_loadpath_as path lexbuf } | "as" { let qid = coq_qual_id lexbuf in skip_to_dot lexbuf; - AddRecLoadPath (!loadpath,qid) } + AddRecLoadPath (path, qid) } | dot - { AddLoadPath !loadpath } + { AddLoadPath path } and caml_action = parse | space + @@ -176,8 +159,7 @@ and caml_action = parse { caml_action lexbuf } | caml_low_ident { caml_action lexbuf } | caml_up_ident - { ml_module_name := Lexing.lexeme lexbuf; - qual_id lexbuf } + { qual_id (Lexing.lexeme lexbuf) lexbuf } | ['0'-'9']+ | '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']+ | '0' ['o' 'O'] ['0'-'7']+ @@ -260,18 +242,15 @@ and load_file = parse | _ { syntax_error lexbuf } -and require_file = parse +and require_file from = parse | "(*" - { comment lexbuf; require_file lexbuf } + { comment lexbuf; require_file from lexbuf } | space+ - { require_file lexbuf } + { require_file from lexbuf } | coq_ident - { module_current_name := [Lexing.lexeme lexbuf]; - module_names := [coq_qual_id_tail lexbuf]; - let qid = coq_qual_id_list lexbuf in + { let name = coq_qual_id_tail [Lexing.lexeme lexbuf] lexbuf in + let qid = coq_qual_id_list [name] lexbuf in parse_dot lexbuf; - let from = !from_pre_ident in - from_pre_ident := None; Require (from, qid) } | eof { syntax_error lexbuf } @@ -294,66 +273,55 @@ and coq_qual_id = parse | space+ { coq_qual_id lexbuf } | coq_ident - { module_current_name := [Lexing.lexeme lexbuf]; - coq_qual_id_tail lexbuf } - | eof - { syntax_error lexbuf } + { coq_qual_id_tail [Lexing.lexeme lexbuf] lexbuf } | _ - { backtrack lexbuf; - let qid = List.rev !module_current_name in - module_current_name := []; - qid } + { syntax_error lexbuf } -and coq_qual_id_tail = parse +and coq_qual_id_tail module_name = parse | "(*" - { comment lexbuf; coq_qual_id_tail lexbuf } + { comment lexbuf; coq_qual_id_tail module_name lexbuf } | space+ - { coq_qual_id_tail lexbuf } + { coq_qual_id_tail module_name lexbuf } | coq_field - { module_current_name := - field_name (Lexing.lexeme lexbuf) :: !module_current_name; - coq_qual_id_tail lexbuf } + { coq_qual_id_tail (field_name (Lexing.lexeme lexbuf) :: module_name) lexbuf } | eof { syntax_error lexbuf } | _ { backtrack lexbuf; - let qid = List.rev !module_current_name in - module_current_name := []; - qid } + List.rev module_name } -and coq_qual_id_list = parse +and coq_qual_id_list module_names = parse | "(*" - { comment lexbuf; coq_qual_id_list lexbuf } + { comment lexbuf; coq_qual_id_list module_names lexbuf } | space+ - { coq_qual_id_list lexbuf } + { coq_qual_id_list module_names lexbuf } | coq_ident - { module_current_name := [Lexing.lexeme lexbuf]; - module_names := coq_qual_id_tail lexbuf :: !module_names; - coq_qual_id_list lexbuf + { let name = coq_qual_id_tail [Lexing.lexeme lexbuf] lexbuf in + coq_qual_id_list (name :: module_names) lexbuf } | eof { syntax_error lexbuf } | _ { backtrack lexbuf; - List.rev !module_names } + List.rev module_names } -and modules = parse +and modules mllist = parse | space+ - { modules lexbuf } + { modules mllist lexbuf } | "(*" - { comment lexbuf; modules lexbuf } + { comment lexbuf; modules mllist lexbuf } | '"' [^'"']* '"' { let lex = (Lexing.lexeme lexbuf) in let str = String.sub lex 1 (String.length lex - 2) in - mllist := str :: !mllist; modules lexbuf} + modules (str :: mllist) lexbuf} | eof { syntax_error lexbuf } | _ - { (Declare (List.rev !mllist)) } + { Declare (List.rev mllist) } -and qual_id = parse - | '.' [^ '.' '(' '['] { - Use_module (String.uncapitalize !ml_module_name) } +and qual_id ml_module_name = parse + | '.' [^ '.' '(' '['] + { Use_module (String.uncapitalize ml_module_name) } | eof { raise Fin_fichier } | _ { caml_action lexbuf } diff --git a/tools/coqdoc/alpha.ml b/tools/coqdoc/alpha.ml index c3db3a265..f817ed5a2 100644 --- a/tools/coqdoc/alpha.ml +++ b/tools/coqdoc/alpha.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/tools/coqdoc/alpha.mli b/tools/coqdoc/alpha.mli index 46005741d..f6d47a55d 100644 --- a/tools/coqdoc/alpha.mli +++ b/tools/coqdoc/alpha.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/tools/coqdoc/cdglobals.ml b/tools/coqdoc/cdglobals.ml index de7290a44..5d48473d8 100644 --- a/tools/coqdoc/cdglobals.ml +++ b/tools/coqdoc/cdglobals.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/tools/coqdoc/cpretty.mli b/tools/coqdoc/cpretty.mli index 4e132ba03..58b19184e 100644 --- a/tools/coqdoc/cpretty.mli +++ b/tools/coqdoc/cpretty.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/tools/coqdoc/cpretty.mll b/tools/coqdoc/cpretty.mll index d28921674..431080c6b 100644 --- a/tools/coqdoc/cpretty.mll +++ b/tools/coqdoc/cpretty.mll @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/tools/coqdoc/index.ml b/tools/coqdoc/index.ml index 4a5ff5924..47acc7b43 100644 --- a/tools/coqdoc/index.ml +++ b/tools/coqdoc/index.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/tools/coqdoc/index.mli b/tools/coqdoc/index.mli index 69b4e4dae..e44bbd593 100644 --- a/tools/coqdoc/index.mli +++ b/tools/coqdoc/index.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/tools/coqdoc/main.ml b/tools/coqdoc/main.ml index 22febd6a6..fe4387381 100644 --- a/tools/coqdoc/main.ml +++ b/tools/coqdoc/main.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/tools/coqdoc/output.ml b/tools/coqdoc/output.ml index 8589f94a0..2b2690968 100644 --- a/tools/coqdoc/output.ml +++ b/tools/coqdoc/output.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/tools/coqdoc/output.mli b/tools/coqdoc/output.mli index c4628dd84..853bc29aa 100644 --- a/tools/coqdoc/output.mli +++ b/tools/coqdoc/output.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/tools/coqdoc/tokens.ml b/tools/coqdoc/tokens.ml index a93ae8557..b6a1057aa 100644 --- a/tools/coqdoc/tokens.ml +++ b/tools/coqdoc/tokens.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/tools/coqdoc/tokens.mli b/tools/coqdoc/tokens.mli index c4fe3bc8f..f07efedf9 100644 --- a/tools/coqdoc/tokens.mli +++ b/tools/coqdoc/tokens.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/tools/coqmktop.ml b/tools/coqmktop.ml index a6254b2a4..6f3d8e2b8 100644 --- a/tools/coqmktop.ml +++ b/tools/coqmktop.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -279,7 +279,7 @@ let main () = (* - We add topstart.cmo explicitly because we shunted ocamlmktop wrapper. - With the coq .cma, we MUST use the -linkall option. *) let args = - "-linkall" :: "-rectypes" :: flags @ copts @ options @ + "-linkall" :: "-rectypes" :: "-w" :: "-31" :: flags @ copts @ options @ (std_includes basedir) @ tolink @ [ main_file ] @ topstart in if !echo then begin diff --git a/tools/coqwc.mll b/tools/coqwc.mll index 9a42553da..b4fc738d0 100644 --- a/tools/coqwc.mll +++ b/tools/coqwc.mll @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/tools/coqworkmgr.ml b/tools/coqworkmgr.ml index 8c0891505..d7bdf907a 100644 --- a/tools/coqworkmgr.ml +++ b/tools/coqworkmgr.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/tools/fake_ide.ml b/tools/fake_ide.ml index dfe6093d6..e81f4038d 100644 --- a/tools/fake_ide.ml +++ b/tools/fake_ide.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/tools/gallina.ml b/tools/gallina.ml index 5ce19e7f8..0bf98a8f0 100644 --- a/tools/gallina.ml +++ b/tools/gallina.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/tools/gallina_lexer.mll b/tools/gallina_lexer.mll index 9dd49b90a..449efd57c 100644 --- a/tools/gallina_lexer.mll +++ b/tools/gallina_lexer.mll @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/tools/ocamllibdep.mll b/tools/ocamllibdep.mll index 4e5edcf6c..670ff487c 100644 --- a/tools/ocamllibdep.mll +++ b/tools/ocamllibdep.mll @@ -98,23 +98,14 @@ let file_name s = function type dir = string option -(* Visits all the directories under [dir], including [dir], - or just [dir] if [recur=false] *) - -let rec add_directory add_file phys_dir = - let dirh = opendir phys_dir in - try - while true do - let f = readdir dirh in - (* we avoid all files and subdirs starting by '.' (e.g. .svn), - plus CVS and _darcs and any subdirs given via -exclude-dirs *) - if f.[0] <> '.' then - 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_REG -> add_file phys_dir f - | _ -> () - done - with End_of_file -> closedir dirh +let add_directory add_file phys_dir = + Array.iter (fun f -> + (* we avoid all files starting by '.' *) + if f.[0] <> '.' then + 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_REG -> add_file phys_dir f + | _ -> ()) (Sys.readdir phys_dir) let error_cannot_parse s (i,j) = Printf.eprintf "File \"%s\", characters %i-%i: Syntax error\n" s i j; @@ -173,7 +164,7 @@ let traite_fichier_modules md ext = let addQueue q v = q := v :: !q -let rec treat_file old_name = +let treat_file old_name = let name = Filename.basename old_name in let dirname = Some (Filename.dirname old_name) in match get_extension name [".mllib"] with diff --git a/toplevel/assumptions.ml b/toplevel/assumptions.ml index a6bd968ef..b29ceb78b 100644 --- a/toplevel/assumptions.ml +++ b/toplevel/assumptions.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -23,6 +23,7 @@ open Declarations open Mod_subst open Globnames open Printer +open Context.Named.Declaration (** 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] @@ -141,11 +142,11 @@ let label_of = function | 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 push (r : Context.Rel.Declaration.t) (ctx : Context.Rel.t) = 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 + let body () = Global.lookup_named id |> get_value in traverse_object accu body (VarRef id) | Const (kn, _) -> let body () = Global.body_of_constant_body (lookup_constant kn) in @@ -158,7 +159,7 @@ let rec traverse current ctx accu t = match kind_of_term t with | 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, _) + | Lambda(_,_,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 @@ -208,8 +209,8 @@ let assumptions ?(add_opaque=false) ?(add_transparent=false) st gr t = 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 - if Option.is_empty body then ContextObjectMap.add (Variable id) t accu + let decl = Global.lookup_named id in + if is_local_assum decl then ContextObjectMap.add (Variable id) t accu else accu | ConstRef kn -> let cb = lookup_constant kn in diff --git a/toplevel/assumptions.mli b/toplevel/assumptions.mli index 9c9f81bd2..072675783 100644 --- a/toplevel/assumptions.mli +++ b/toplevel/assumptions.mli @@ -1,12 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Util open Names open Term open Globnames @@ -22,7 +21,7 @@ open Printer val traverse : Label.t -> constr -> (Refset_env.t * Refset_env.t Refmap_env.t * - (label * Context.rel_context * types) list Refmap_env.t) + (label * Context.Rel.t * 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 diff --git a/toplevel/auto_ind_decl.ml b/toplevel/auto_ind_decl.ml index 8282ce30b..3d053c2e1 100644 --- a/toplevel/auto_ind_decl.ml +++ b/toplevel/auto_ind_decl.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -25,6 +25,7 @@ open Tactics open Ind_tables open Misctypes open Proofview.Notations +open Context.Rel.Declaration let out_punivs = Univ.out_punivs @@ -85,7 +86,7 @@ let destruct_on c = destruct false None c None None let destruct_on_using c id = destruct false None c - (Some (dl,[[dl,IntroNaming IntroAnonymous]; + (Some (dl,IntroOrPattern [[dl,IntroNaming IntroAnonymous]; [dl,IntroNaming (IntroIdentifier id)]])) None @@ -102,7 +103,7 @@ let mkFullInd (ind,u) n = context_chop (nparams-nparrec) mib.mind_params_ctxt in if nparrec > 0 then mkApp (mkIndU (ind,u), - Array.of_list(extended_rel_list (nparrec+n) lnamesparrec)) + Array.of_list(Context.Rel.to_extended_list (nparrec+n) lnamesparrec)) else mkIndU (ind,u) let check_bool_is_defined () = @@ -137,7 +138,7 @@ let build_beq_scheme mode kn = | Name s -> Id.of_string ("eq_"^(Id.to_string s)) | Anonymous -> Id.of_string "eq_A" in - let ext_rel_list = extended_rel_list 0 lnamesparrec in + let ext_rel_list = Context.Rel.to_extended_list 0 lnamesparrec in let lift_cnt = ref 0 in let eqs_typ = List.map (fun aa -> let a = lift !lift_cnt aa in @@ -146,17 +147,17 @@ let build_beq_scheme mode kn = ) ext_rel_list in let eq_input = List.fold_left2 - ( fun a b (n,_,_) -> (* mkLambda(n,b,a) ) *) + ( fun a b decl -> (* mkLambda(n,b,a) ) *) (* here I leave the Naming thingy so that the type of the function is more readable for the user *) - mkNamedLambda (eqName n) b a ) + mkNamedLambda (eqName (get_name decl)) b a ) c (List.rev eqs_typ) lnamesparrec in - List.fold_left (fun a (n,_,t) ->(* mkLambda(n,t,a)) eq_input rel_list *) + List.fold_left (fun a decl ->(* mkLambda(n,t,a)) eq_input rel_list *) (* Same here , hoping the auto renaming will do something good ;) *) mkNamedLambda - (match n with Name s -> s | Anonymous -> Id.of_string "A") - t a) eq_input lnamesparrec + (match get_name decl with Name s -> s | Anonymous -> Id.of_string "A") + (get_type decl) a) eq_input lnamesparrec in let make_one_eq cur = let u = Univ.Instance.empty in @@ -179,12 +180,12 @@ let build_beq_scheme mode 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 = @@ -193,9 +194,8 @@ let build_beq_scheme mode kn = 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 @@ -234,11 +234,11 @@ let build_beq_scheme mode kn = Cn => match Y with ... end |] part *) let ci = make_case_info env (fst ind) MatchStyle in let constrs n = get_constructors env (make_ind_family (ind, - extended_rel_list (n+nb_ind-1) mib.mind_params_ctxt)) in + Context.Rel.to_extended_list (n+nb_ind-1) mib.mind_params_ctxt)) in 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 @@ -249,14 +249,14 @@ let build_beq_scheme mode kn = | 0 -> Lazy.force tt | _ -> let eqs = Array.make nb_cstr_args (Lazy.force tt) in for ndx = 0 to nb_cstr_args-1 do - let _,_,cc = List.nth constrsi.(i).cs_args ndx in + let cc = get_type (List.nth constrsi.(i).cs_args ndx) in let eqA, eff' = compute_A_equality rel_list nparrec (nparrec+3+2*nb_cstr_args) (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)|] @@ -268,14 +268,14 @@ let build_beq_scheme mode kn = (Array.sub eqs 1 (nb_cstr_args - 1)) ) in - (List.fold_left (fun a (p,q,r) -> mkLambda (p,r,a)) cc + (List.fold_left (fun a decl -> mkLambda (get_name decl, get_type decl, a)) cc (constrsj.(j).cs_args) ) - else ar2.(j) <- (List.fold_left (fun a (p,q,r) -> - mkLambda (p,r,a)) (Lazy.force ff) (constrsj.(j).cs_args) ) + else ar2.(j) <- (List.fold_left (fun a decl -> + mkLambda (get_name decl, get_type decl, a)) (Lazy.force ff) (constrsj.(j).cs_args) ) done; - ar.(i) <- (List.fold_left (fun a (p,q,r) -> mkLambda (p,r,a)) + ar.(i) <- (List.fold_left (fun a decl -> mkLambda (get_name decl, get_type decl, a)) (mkCase (ci,do_predicate rel_list nb_cstr_args, mkVar (Id.of_string "Y") ,ar2)) (constrsi.(i).cs_args)) @@ -288,7 +288,7 @@ let build_beq_scheme mode 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)); @@ -296,7 +296,7 @@ let build_beq_scheme mode 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 @@ -488,8 +488,8 @@ let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt = create, from a list of ids [i1,i2,...,in] the list [(in,eq_in,in_bl,in_al),,...,(i1,eq_i1,i1_bl_i1_al )] *) -let list_id l = List.fold_left ( fun a (n,_,t) -> let s' = - match n with +let list_id l = List.fold_left ( fun a decl -> let s' = + match get_name decl with Name s -> Id.to_string s | Anonymous -> "A" in (Id.of_string s',Id.of_string ("eq_"^s'), @@ -536,9 +536,9 @@ let compute_bl_goal ind lnamesparrec nparrec = let eq_input = List.fold_left2 ( fun a (s,seq,_,_) b -> mkNamedProd seq b a ) bl_input (List.rev list_id) (List.rev eqs_typ) in - List.fold_left (fun a (n,_,t) -> mkNamedProd - (match n with Name s -> s | Anonymous -> Id.of_string "A") - t a) eq_input lnamesparrec + List.fold_left (fun a decl -> mkNamedProd + (match get_name decl with Name s -> s | Anonymous -> Id.of_string "A") + (get_type decl) a) eq_input lnamesparrec in let n = Id.of_string "x" and m = Id.of_string "y" in @@ -581,7 +581,7 @@ let compute_bl_tact mode bl_scheme_key ind lnamesparrec nparrec = Tacticals.New.tclTRY ( Tacticals.New.tclORELSE reflexivity (Equality.discr_tac false None) ); - Proofview.V82.tactic (simpl_in_hyp (freshz,Locus.InHyp)); + simpl_in_hyp (freshz,Locus.InHyp); (* repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]). *) @@ -590,8 +590,8 @@ repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]). Simple.apply_in freshz (andb_prop()); Proofview.Goal.nf_enter { enter = begin fun gl -> let fresht = fresh_id (Id.of_string "Z") gl in - (destruct_on_as (mkVar freshz) - [[dl,IntroNaming (IntroIdentifier fresht); + destruct_on_as (mkVar freshz) + (IntroOrPattern [[dl,IntroNaming (IntroIdentifier fresht); dl,IntroNaming (IntroIdentifier freshz)]]) end } ]); @@ -679,9 +679,9 @@ let compute_lb_goal ind lnamesparrec nparrec = let eq_input = List.fold_left2 ( fun a (s,seq,_,_) b -> mkNamedProd seq b a ) lb_input (List.rev list_id) (List.rev eqs_typ) in - List.fold_left (fun a (n,_,t) -> mkNamedProd - (match n with Name s -> s | Anonymous -> Id.of_string "A") - t a) eq_input lnamesparrec + List.fold_left (fun a decl -> mkNamedProd + (match (get_name decl) with Name s -> s | Anonymous -> Id.of_string "A") + (get_type decl) a) eq_input lnamesparrec in let n = Id.of_string "x" and m = Id.of_string "y" in @@ -725,7 +725,7 @@ let compute_lb_tact mode lb_scheme_key ind lnamesparrec nparrec = Tacticals.New.tclORELSE reflexivity (Equality.discr_tac false None) ); Equality.inj None false None (mkVar freshz,NoBindings); - intros; (Proofview.V82.tactic simpl_in_concl); + intros; simpl_in_concl; Auto.default_auto; Tacticals.New.tclREPEAT ( Tacticals.New.tclTHENLIST [apply (andb_true_intro()); @@ -820,9 +820,9 @@ let compute_dec_goal ind lnamesparrec nparrec = let eq_input = List.fold_left2 ( fun a (s,seq,_,_) b -> mkNamedProd seq b a ) bl_input (List.rev list_id) (List.rev eqs_typ) in - List.fold_left (fun a (n,_,t) -> mkNamedProd - (match n with Name s -> s | Anonymous -> Id.of_string "A") - t a) eq_input lnamesparrec + List.fold_left (fun a decl -> mkNamedProd + (match get_name decl with Name s -> s | Anonymous -> Id.of_string "A") + (get_type decl) a) eq_input lnamesparrec in let n = Id.of_string "x" and m = Id.of_string "y" in @@ -875,7 +875,7 @@ let compute_dec_tact ind lnamesparrec nparrec = Not_found -> 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; @@ -902,7 +902,7 @@ let compute_dec_tact ind lnamesparrec nparrec = let freshH3 = fresh_id (Id.of_string "H") gl in Tacticals.New.tclTHENLIST [ simplest_right ; - Proofview.V82.tactic (unfold_constr (Lazy.force Coqlib.coq_not_ref)); + unfold_constr (Lazy.force Coqlib.coq_not_ref); intro; Equality.subst_all (); assert_by (Name freshH3) @@ -942,7 +942,7 @@ let make_eq_decidability mode mind = (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 20a3d5d74..b6c66a1e8 100644 --- a/toplevel/auto_ind_decl.mli +++ b/toplevel/auto_ind_decl.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/toplevel/cerrors.ml b/toplevel/cerrors.ml index accba3121..4f3ffbcae 100644 --- a/toplevel/cerrors.ml +++ b/toplevel/cerrors.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -110,6 +110,11 @@ let rec strip_wrapping_exceptions = function strip_wrapping_exceptions e | exc -> exc +let additional_error_info = ref [] + +let register_additional_error_info f = + additional_error_info := f :: !additional_error_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 @@ -120,19 +125,12 @@ let process_vernac_interp_error ?(allow_uncaught=true) ?(with_header=true) (exc, 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 + let e' = + try Some (CList.find_map (fun f -> f e) !additional_error_info) + with _ -> None + in + match e' with | None -> e - | Some trace -> - let (e, info) = e in - match Himsg.extract_ltac_trace trace loc with - | None, loc -> (e, Loc.add_loc info loc) - | Some msg, loc -> - (EvaluatedError (msg, Some e), Loc.add_loc info loc) - -let _ = Tactic_debug.explain_logic_error := - (fun e -> Errors.print (fst (process_vernac_interp_error (e, Exninfo.null)))) - -let _ = Tactic_debug.explain_logic_error_no_anomaly := - (fun e -> Errors.print_no_report (fst (process_vernac_interp_error (e, Exninfo.null)))) + | Some (None, loc) -> (fst e, Loc.add_loc (snd e) loc) + | Some (Some msg, loc) -> + (EvaluatedError (msg, Some (fst e)), Loc.add_loc (snd e) loc) diff --git a/toplevel/cerrors.mli b/toplevel/cerrors.mli index 729686f32..a0e3e3c19 100644 --- a/toplevel/cerrors.mli +++ b/toplevel/cerrors.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -19,3 +19,4 @@ val process_vernac_interp_error : ?allow_uncaught:bool -> ?with_header:bool -> U val explain_exn_default : exn -> Pp.std_ppcmds +val register_additional_error_info : (Util.iexn -> (Pp.std_ppcmds option * Loc.t) option) -> unit diff --git a/toplevel/class.ml b/toplevel/class.ml index f925a2d07..a9c53b4d4 100644 --- a/toplevel/class.ml +++ b/toplevel/class.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -197,13 +197,13 @@ let build_id_coercion idf_opt source poly = let val_f = it_mkLambda_or_LetIn (mkLambda (Name Namegen.default_dependent_ident, - applistc vs (extended_rel_list 0 lams), + applistc vs (Context.Rel.to_extended_list 0 lams), mkRel 1)) lams in let typ_f = it_mkProd_wo_LetIn - (mkProd (Anonymous, applistc vs (extended_rel_list 0 lams), lift 1 t)) + (mkProd (Anonymous, applistc vs (Context.Rel.to_extended_list 0 lams), lift 1 t)) lams in (* juste pour verification *) @@ -225,7 +225,7 @@ let build_id_coercion idf_opt source poly = in let constr_entry = (* Cast is necessary to express [val_f] is identity *) DefinitionEntry - (definition_entry ~types:typ_f ~poly ~univs:(Evd.universe_context sigma) + (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/class.mli b/toplevel/class.mli index bd6c7a6d1..5f9ae28f6 100644 --- a/toplevel/class.mli +++ b/toplevel/class.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/toplevel/classes.ml b/toplevel/classes.ml index 439e20a86..2fc0f5ff1 100644 --- a/toplevel/classes.ml +++ b/toplevel/classes.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -21,6 +21,7 @@ open Globnames open Constrintern open Constrexpr open Sigma.Notations +open Context.Rel.Declaration (*i*) open Decl_kinds @@ -75,14 +76,14 @@ let mismatched_props env n m = mismatched_ctx_inst env Properties n m let type_ctx_instance evars env ctx inst subst = let rec aux (subst, instctx) l = function - (na, b, t) :: ctx -> - let t' = substl subst t in + decl :: ctx -> + let t' = substl subst (get_type decl) in let c', l = - match b with - | None -> interp_casted_constr_evars env evars (List.hd l) t', List.tl l - | Some b -> substl subst b, l + match decl with + | LocalAssum _ -> interp_casted_constr_evars env evars (List.hd l) t', List.tl l + | LocalDef (_,b,_) -> substl subst b, l in - let d = na, Some c', t' in + let d = get_name decl, Some c', t' in aux (c' :: subst, d :: instctx) l ctx | [] -> subst in aux (subst, []) inst (List.rev ctx) @@ -102,19 +103,21 @@ let instance_hook k pri global imps ?hook cst = Typeclasses.declare_instance pri (not global) cst; (match hook with Some h -> h cst | None -> ()) -let declare_instance_constant k pri global imps ?hook id poly uctx term termtype = +let declare_instance_constant k pri global imps ?hook id pl poly evm term termtype = let kind = IsDefinition Instance in - let uctx = + let evm = let levels = Univ.LSet.union (Universes.universes_of_constr termtype) (Universes.universes_of_constr term) in - Universes.restrict_universe_context uctx levels + Evd.restrict_universe_context evm levels in + let pl, uctx = Evd.universe_context ?names:pl evm in let entry = - Declare.definition_entry ~types:termtype ~poly ~univs:(Univ.ContextSet.to_context uctx) term + Declare.definition_entry ~types:termtype ~poly ~univs:uctx term in let cdecl = (DefinitionEntry entry, kind) in let kn = Declare.declare_constant id cdecl in Declare.definition_message id; + Universes.register_universe_binders (ConstRef kn) pl; instance_hook k pri global imps ?hook (ConstRef kn); id @@ -122,12 +125,14 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro ?(generalize=true) ?(tac:unit Proofview.tactic option) ?hook pri = let env = Global.env() in - let evars = ref (Evd.from_env env) in + let ((loc, instid), pl) = instid in + let uctx = Evd.make_evar_universe_context env pl in + let evars = ref (Evd.from_ctx uctx) in let tclass, ids = match bk with | Implicit -> Implicit_quantifiers.implicit_application Id.Set.empty ~allow_partial:false - (fun avoid (clname, (id, _, t)) -> + (fun avoid (clname, _) -> match clname with | Some (cl, b) -> let t = CHole (Loc.ghost, None, Misctypes.IntroAnonymous, None) in @@ -150,16 +155,17 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro let k, args = Typeclasses.dest_class_app (push_rel_context ctx'' env) c in let cl, u = Typeclasses.typeclass_univ_instance k in let _, args = - List.fold_right (fun (na, b, t) (args, args') -> - match b with - | None -> (List.tl args, List.hd args :: args') - | Some b -> (args, substl args' b :: args')) + List.fold_right (fun decl (args, args') -> + let open Context.Rel.Declaration in + match decl with + | LocalAssum _ -> (List.tl args, List.hd args :: args') + | LocalDef (_,b,_) -> (args, substl args' b :: args')) (snd cl.cl_context) (args, []) in cl, u, c', ctx', ctx, len, imps, args in let id = - match snd instid with + match instid with Name id -> let sp = Lib.make_path id in if Nametab.exists_cci sp then @@ -176,7 +182,7 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro if abstract then begin let subst = List.fold_left2 - (fun subst' s (_, b, _) -> if Option.is_empty b then s :: subst' else subst') + (fun subst' s decl -> if is_local_assum decl then s :: subst' else subst') [] subst (snd k.cl_context) in let (_, ty_constr) = instance_constructor (k,u) subst in @@ -185,17 +191,19 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro let t = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in nf t in - Evarutil.check_evars env Evd.empty !evars termtype; - let ctx = Evd.universe_context !evars in + Pretyping.check_evars env Evd.empty !evars termtype; + let pl, ctx = Evd.universe_context ?names:pl !evars in let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest id - (Entries.ParameterEntry + (ParameterEntry (None,poly,(termtype,ctx),None), Decl_kinds.IsAssumption Decl_kinds.Logical) - in instance_hook k None global imps ?hook (ConstRef cst); id + in + Universes.register_universe_binders (ConstRef cst) pl; + instance_hook k pri global imps ?hook (ConstRef cst); id end else ( let props = match props with - | Some (true, CRecord (loc, _, fs)) -> + | Some (true, CRecord (loc, fs)) -> if List.length fs > List.length k.cl_props then mismatched_props env' (List.map snd fs) k.cl_props; Some (Inl fs) @@ -218,10 +226,10 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro in let props, rest = List.fold_left - (fun (props, rest) (id,b,_) -> - if Option.is_empty b then + (fun (props, rest) decl -> + if is_local_assum decl then try - let is_id (id', _) = match id, get_id id' with + let is_id (id', _) = match get_name decl, get_id id' with | Name id, (_, id') -> Id.equal id id' | Anonymous, _ -> false in @@ -255,7 +263,7 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro None, termtype | Some (Inl subst) -> let subst = List.fold_left2 - (fun subst' s (_, b, _) -> if Option.is_empty b then s :: subst' else subst') + (fun subst' s decl -> if is_local_assum decl then s :: subst' else subst') [] subst (k.cl_props @ snd k.cl_context) in let (app, ty_constr) = instance_constructor (k,u) subst in @@ -279,17 +287,16 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro let evm, nf = Evarutil.nf_evar_map_universes !evars in let termtype = nf termtype in let _ = (* Check that the type is free of evars now. *) - Evarutil.check_evars env Evd.empty evm termtype + Pretyping.check_evars env Evd.empty evm termtype in let term = Option.map nf term in if not (Evd.has_undefined evm) && not (Option.is_empty term) then - let ctx = Evd.universe_context_set evm in - declare_instance_constant k pri global imps ?hook id - poly ctx (Option.get term) termtype - else if !refine_instance || Option.is_empty term then begin + declare_instance_constant k pri global imps ?hook id pl + poly evm (Option.get term) termtype + else if Flags.is_program_mode () || !refine_instance || Option.is_empty term then begin let kind = Decl_kinds.Global, poly, Decl_kinds.DefinitionBody Decl_kinds.Instance in if Flags.is_program_mode () then - let hook vis gr = + let hook vis gr _ = let cst = match gr with ConstRef kn -> kn | _ -> assert false in Impargs.declare_manual_implicits false gr ~enriching:false [imps]; Typeclasses.declare_instance pri (not global) (ConstRef cst) @@ -305,7 +312,7 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro let hook = Lemmas.mk_hook hook in let ctx = Evd.evar_universe_context evm in ignore (Obligations.add_definition id ?term:constr - typ ctx ~kind:(Global,poly,Instance) ~hook obls); + ?pl typ ctx ~kind:(Global,poly,Instance) ~hook obls); id else (Flags.silently @@ -323,7 +330,7 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro if not (Option.is_empty term) then let init_refine = Tacticals.New.tclTHENLIST [ - Proofview.Refine.refine { run = fun evm -> Sigma (Option.get term, evm, Sigma.refl) }; + Refine.refine { run = fun evm -> Sigma (Option.get term, evm, Sigma.refl) }; Proofview.Unsafe.tclNEWGOALS gls; Tactics.New.reduce_after_refine; ] @@ -339,9 +346,11 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro let named_of_rel_context l = let acc, ctx = List.fold_right - (fun (na, b, t) (subst, ctx) -> - let id = match na with Anonymous -> invalid_arg "named_of_rel_context" | Name id -> id in - let d = (id, Option.map (substl subst) b, substl subst t) in + (fun decl (subst, ctx) -> + let id = match get_name decl with Anonymous -> invalid_arg "named_of_rel_context" | Name id -> id in + let d = match decl with + | LocalAssum (_,t) -> id, None, substl subst t + | LocalDef (_,b,t) -> id, Some (substl subst b), substl subst t in (mkVar id :: subst, d :: ctx)) l ([], []) in ctx @@ -351,9 +360,9 @@ let context poly l = 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 - let ce t = Evarutil.check_evars env Evd.empty !evars t in - let () = List.iter (fun (n, b, t) -> Option.iter ce b; ce t) fullctx in + let fullctx = Context.Rel.map subst fullctx in + let ce t = Pretyping.check_evars env Evd.empty !evars t in + let () = List.iter (fun decl -> Context.Rel.Declaration.iter_constr ce decl) fullctx in let ctx = try named_of_rel_context fullctx with e when Errors.noncritical e -> @@ -382,7 +391,7 @@ 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 let () = uctx := Univ.ContextSet.empty in diff --git a/toplevel/classes.mli b/toplevel/classes.mli index 2b7e9e4fe..a3e948d96 100644 --- a/toplevel/classes.mli +++ b/toplevel/classes.mli @@ -1,13 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) open Names -open Context open Environ open Constrexpr open Typeclasses @@ -15,9 +14,9 @@ open Libnames (** Errors *) -val mismatched_params : env -> constr_expr list -> rel_context -> 'a +val mismatched_params : env -> constr_expr list -> Context.Rel.t -> 'a -val mismatched_props : env -> constr_expr list -> rel_context -> 'a +val mismatched_props : env -> constr_expr list -> Context.Rel.t -> 'a (** Instance declaration *) @@ -31,8 +30,9 @@ val declare_instance_constant : Impargs.manual_explicitation list -> (** implicits *) ?hook:(Globnames.global_reference -> unit) -> Id.t -> (** name *) + Id.t Loc.located list option -> bool -> (* polymorphic *) - Univ.universe_context_set -> (* Universes *) + Evd.evar_map -> (* Universes *) Constr.t -> (** body *) Term.types -> (** type *) Names.Id.t diff --git a/toplevel/command.ml b/toplevel/command.ml index 06e2be72d..38bc0e568 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -12,7 +12,6 @@ open Util open Flags open Term open Vars -open Context open Termops open Entries open Environ @@ -37,17 +36,20 @@ open Evarconv open Indschemes open Misctypes open Vernacexpr +open Sigma.Notations +open Context.Rel.Declaration +open Entries -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 sigma f n c = - if Int.equal n 0 then snd (f env sigma c) else + if Int.equal n 0 then 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) sigma f (n-1) c) + mkLambda (x,t,under_binders (push_rel (LocalAssum (x,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) sigma f (n-1) c) + mkLetIn (x,b,t,under_binders (push_rel (LocalDef (x,b,t)) env) sigma f (n-1) c) | _ -> assert false let rec complete_conclusion a cs = function @@ -72,10 +74,14 @@ let red_constant_entry n ce sigma = function | Some red -> let proof_out = ce.const_entry_body in let env = Global.env () in + let (redfun, _) = reduction_of_red_expr env red in + let redfun env sigma c = + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma (c, _, _) = redfun.e_redfun env sigma c in + c + in { ce with const_entry_body = Future.chain ~greedy:true ~pure:true proof_out - (fun ((body,ctx),eff) -> - (under_binders env sigma - (fst (reduction_of_red_expr env red)) n body,ctx),eff) } + (fun ((body,ctx),eff) -> (under_binders env sigma redfun n body,ctx),eff) } let interp_definition pl bl p red_option c ctypopt = let env = Global.env() in @@ -83,24 +89,24 @@ let interp_definition pl bl p red_option c ctypopt = 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 - let ctx = map_rel_context (Vars.subst_univs_constr subst) ctx in + let ctx = Context.Rel.map (Vars.subst_univs_constr subst) ctx in let env_bl = push_rel_context ctx env in let c, imps2 = interp_constr_evars_impls ~impls env_bl evdref c in 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 evd = Evd.restrict_universe_context !evdref vars in - let uctx = Evd.universe_context ?names:pl evd in - imps1@(Impargs.lift_implicits nb_args imps2), + 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 - let ctx = map_rel_context (Vars.subst_univs_constr subst) ctx in + let ctx = Context.Rel.map (Vars.subst_univs_constr subst) ctx in let env_bl = push_rel_context ctx env in let c, imps2 = interp_casted_constr_evars_impls ~impls env_bl evdref c ty in let nf, subst = Evarutil.e_nf_evars_and_universes evdref in @@ -120,14 +126,14 @@ let interp_definition pl bl p red_option c ctypopt = let vars = Univ.LSet.union (Universes.universes_of_constr body) (Universes.universes_of_constr typ) in let ctx = Evd.restrict_universe_context !evdref vars in - let uctx = Evd.universe_context ?names:pl ctx in - imps1@(Impargs.lift_implicits nb_args impsty), + 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:uctx body in - red_constant_entry (rel_context_length ctx) ce !evdref red_option, !evdref, imps + red_constant_entry (Context.Rel.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 @@ -140,11 +146,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 @@ -152,7 +159,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 () -> @@ -168,17 +176,20 @@ 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 pl bl red_option c ctypopt hook = - let (ce, evd, imps as def) = interp_definition pl bl (pi2 k) red_option c ctypopt in + 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 @@ -189,16 +200,18 @@ let do_definition ident k pl bl red_option c ctypopt hook = Obligations.eterm_obligations env ident evd 0 c typ in let ctx = Evd.evar_universe_context evd in + let hook = Lemmas.mk_hook (fun l r _ -> Lemmas.call_hook (fun exn -> exn) hook l r) in ignore(Obligations.add_definition - ident ~term:c cty ctx ~implicits:imps ~kind:k ~hook obls) + ident ~term:c cty ctx ?pl ~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 @@ -225,6 +238,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 @@ -241,17 +255,18 @@ 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,ctx) imps impl_is_on nl = +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) imps impl_is_on nl id in + 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_unbound_univs (_, poly, _ as kind) nl l = + let open Context.Named.Declaration in let env = Global.env () in let evdref = ref (Evd.from_env env) in let l = @@ -266,7 +281,7 @@ let do_assumptions_unbound_univs (_, poly, _ as kind) nl l = let _,l = List.fold_map (fun (env,ienv) (is_coe,(idl,c)) -> let (t,ctx),imps = interp_assumption evdref env ienv [] c in let env = - push_named_context (List.map (fun (_,id) -> (id,None,t)) idl) env in + push_named_context (List.map (fun (_,id) -> LocalAssum (id,t)) idl) env in let ienv = List.fold_right (fun (_,id) ienv -> let impls = compute_internalization_data env Variable t imps in Id.Map.add id impls ienv) idl ienv in @@ -277,7 +292,7 @@ let do_assumptions_unbound_univs (_, 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 @@ -293,9 +308,9 @@ let do_assumptions_bound_univs coe kind nl id pl c = let ty = nf ty in let vars = Universes.universes_of_constr ty in let evd = Evd.restrict_universe_context !evdref vars in - let uctx = Evd.universe_context ?names:pl evd 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) impls false nl id 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 @@ -314,7 +329,8 @@ let do_assumptions kind nl l = match l with | None -> id | Some _ -> let loc = fst id in - let msg = Pp.str "Assumptions with bound universes can only be defined once at a time." 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)) @@ -327,7 +343,7 @@ let do_assumptions kind nl l = match l with (* 3b| Mutual inductive definitions *) let push_types env idl tl = - List.fold_left2 (fun env id t -> Environ.push_rel (Name id,None,t) env) + List.fold_left2 (fun env id t -> Environ.push_rel (LocalAssum (Name id,t)) env) env idl tl type structured_one_inductive_expr = { @@ -370,8 +386,8 @@ let mk_mltype_data evdref env assums arity indname = (is_ml_type,indname,assums) let prepare_param = function - | (na,None,t) -> out_name na, LocalAssum t - | (na,Some b,_) -> out_name na, LocalDef b + | LocalAssum (na,t) -> out_name na, LocalAssumEntry t + | LocalDef (na,b,_) -> out_name na, LocalDefEntry b (** Make the arity conclusion flexible to avoid generating an upper bound universe now, only if the universe does not appear anywhere else. @@ -425,12 +441,12 @@ let interp_cstrs evdref env impls mldata arity ind = let sign_level env evd sign = fst (List.fold_right - (fun (_,b,t as d) (lev,env) -> - match b with - | Some _ -> (lev, push_rel d env) - | None -> + (fun d (lev,env) -> + match d with + | LocalDef _ -> lev, push_rel d env + | LocalAssum _ -> let s = destSort (Reduction.whd_betadeltaiota env - (nf_evar evd (Retyping.get_type_of env evd t))) + (nf_evar evd (Retyping.get_type_of env evd (get_type d)))) in let u = univ_of_sort s in (Univ.sup u lev, push_rel d env)) @@ -441,7 +457,7 @@ let sup_list min = List.fold_left Univ.sup min let extract_level env evd min tys = let sorts = List.map (fun ty -> let ctx, concl = Reduction.dest_prod_assum env ty in - sign_level env evd ((Anonymous, None, concl) :: ctx)) tys + sign_level env evd (LocalAssum (Anonymous, concl) :: ctx)) tys in sup_list min sorts let is_flexible_sort evd u = @@ -547,8 +563,8 @@ let interp_mutual_inductive (paramsl,indl) notations poly prv finite = 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 + let assums = List.filter is_local_assum ctx_params in + let params = List.map (fun decl -> out_name (get_name decl)) assums in (* Interpret the arities *) let arities = List.map (interp_ind_arity env_params evdref) indl in @@ -559,7 +575,7 @@ let interp_mutual_inductive (paramsl,indl) notations poly prv finite = (* Compute interpretation metadatas *) let indimpls = List.map (fun (_, _, impls) -> userimpls @ - lift_implicits (rel_context_nhyps ctx_params) impls) arities in + lift_implicits (Context.Rel.nhyps ctx_params) impls) arities in let arities = List.map pi1 arities and aritypoly = List.map pi2 arities in let impls = compute_internalization_env env0 (Inductive params) indnames fullarities indimpls in let mldatas = List.map2 (mk_mltype_data evdref env_params params) arities indnames in @@ -585,11 +601,11 @@ let interp_mutual_inductive (paramsl,indl) notations poly prv finite = let nf x = nf' (nf x) in let arities = List.map nf' arities in 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 ctx_params = Context.Rel.map nf ctx_params in let evd = !evdref in - let uctx = Evd.universe_context ?names:pl evd 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; + Context.Rel.iter (check_evars env0 Evd.empty evd) ctx_params; List.iter (fun (_,ctyps,_) -> List.iter (check_evars env_ar_params Evd.empty evd) ctyps) constructors; @@ -603,7 +619,7 @@ let interp_mutual_inductive (paramsl,indl) notations poly prv finite = mind_entry_lc = ctypes }) indl arities aritypoly constructors in let impls = - let len = rel_context_nhyps ctx_params in + let len = Context.Rel.nhyps ctx_params in List.map2 (fun indimpls (_,_,cimpls) -> indimpls, List.map (fun impls -> userimpls @ (lift_implicits len impls)) cimpls) indimpls constructors @@ -616,7 +632,7 @@ let interp_mutual_inductive (paramsl,indl) notations poly prv finite = mind_entry_polymorphic = poly; mind_entry_private = if prv then Some false else None; mind_entry_universes = uctx }, - impls + pl, impls (* Very syntactical equality *) let eq_local_binders bl1 bl2 = @@ -665,7 +681,7 @@ 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 @@ -680,12 +696,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); @@ -700,14 +719,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... @@ -811,11 +830,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 @@ -857,19 +877,20 @@ let well_founded = init_constant ["Init"; "Wf"] "well_founded" let mkSubset name typ prop = mkApp (Universes.constr_of_global (delayed_force build_sigma).typ, [| typ; mkLambda (name, typ, prop) |]) -let sigT = Lazy.lazy_from_fun build_sigma_type +let sigT = Lazy.from_fun build_sigma_type let make_qref s = Qualid (Loc.ghost, qualid_of_string s) let lt_ref = make_qref "Init.Peano.lt" let rec telescope = function | [] -> assert false - | [(n, None, t)] -> t, [n, Some (mkRel 1), t], mkRel 1 - | (n, None, t) :: tl -> + | [LocalAssum (n, t)] -> t, [LocalDef (n, mkRel 1, t)], mkRel 1 + | LocalAssum (n, t) :: tl -> let ty, tys, (k, constr) = List.fold_left - (fun (ty, tys, (k, constr)) (n, b, t) -> - let pred = mkLambda (n, t, ty) in + (fun (ty, tys, (k, constr)) decl -> + let t = get_type decl in + let pred = mkLambda (get_name decl, t, ty) in let ty = Universes.constr_of_global (Lazy.force sigT).typ in let intro = Universes.constr_of_global (Lazy.force sigT).intro in let sigty = mkApp (ty, [|t; pred|]) in @@ -878,26 +899,27 @@ let rec telescope = function (t, [], (2, mkRel 1)) tl in let (last, subst) = List.fold_right2 - (fun pred (n, b, t) (prev, subst) -> + (fun pred decl (prev, subst) -> + let t = get_type decl in let p1 = Universes.constr_of_global (Lazy.force sigT).proj1 in let p2 = Universes.constr_of_global (Lazy.force sigT).proj2 in let proj1 = applistc p1 [t; pred; prev] in let proj2 = applistc p2 [t; pred; prev] in - (lift 1 proj2, (n, Some proj1, t) :: subst)) + (lift 1 proj2, LocalDef (get_name decl, proj1, t) :: subst)) (List.rev tys) tl (mkRel 1, []) - in ty, ((n, Some last, t) :: subst), constr + in ty, (LocalDef (n, last, t) :: subst), constr - | (n, Some b, t) :: tl -> let ty, subst, term = telescope tl in - ty, ((n, Some b, t) :: subst), lift 1 term + | LocalDef (n, b, t) :: tl -> let ty, subst, term = telescope tl in + ty, (LocalDef (n, b, t) :: subst), lift 1 term let nf_evar_context sigma ctx = - List.map (fun (n, b, t) -> - (n, Option.map (Evarutil.nf_evar sigma) b, Evarutil.nf_evar sigma t)) ctx + List.map (map_constr (Evarutil.nf_evar sigma)) ctx -let build_wellfounded (recname,n,bl,arityc,body) r measure notation = +let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = Coqlib.check_required_library ["Coq";"Program";"Wf"]; 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 _, ((env', binders_rel), impls) = interp_context_evars env evdref bl in let len = List.length binders_rel in let top_env = push_rel_context binders_rel env in @@ -905,7 +927,7 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation = let full_arity = it_mkProd_or_LetIn top_arity binders_rel in let argtyp, letbinders, make = telescope binders_rel in let argname = Id.of_string "recarg" in - let arg = (Name argname, None, argtyp) in + let arg = LocalAssum (Name argname, argtyp) in let binders = letbinders @ [arg] in let binders_env = push_rel_context binders_rel env in let rel, _ = interp_constr_evars_impls env evdref r in @@ -920,7 +942,7 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation = try let ctx, ar = Reductionops.splay_prod_n env !evdref 2 relty in match ctx, kind_of_term ar with - | [(_, None, t); (_, None, u)], Sort (Prop Null) + | [LocalAssum (_,t); LocalAssum (_,u)], Sort (Prop Null) when Reductionops.is_conv env !evdref t u -> t | _, _ -> error () with e when Errors.noncritical e -> error () @@ -940,9 +962,9 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation = in let wf_proof = mkApp (delayed_force well_founded, [| argtyp ; wf_rel |]) in let argid' = Id.of_string (Id.to_string argname ^ "'") in - let wfarg len = (Name argid', None, - mkSubset (Name argid') argtyp - (wf_rel_fun (mkRel 1) (mkRel (len + 1)))) + let wfarg len = LocalAssum (Name argid', + mkSubset (Name argid') argtyp + (wf_rel_fun (mkRel 1) (mkRel (len + 1)))) in let intern_bl = wfarg 1 :: [arg] in let _intern_env = push_rel_context intern_bl env in @@ -956,22 +978,22 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation = (* substitute the projection of wfarg for something, now intern_arity is in wfarg :: arg *) let intern_fun_arity_prod = it_mkProd_or_LetIn intern_arity [wfarg 1] in - let intern_fun_binder = (Name (add_suffix recname "'"), None, intern_fun_arity_prod) in + let intern_fun_binder = LocalAssum (Name (add_suffix recname "'"), intern_fun_arity_prod) in let curry_fun = let wfpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel (2 * len + 4))) in let intro = (*FIXME*)Universes.constr_of_global (delayed_force build_sigma).Coqlib.intro in let arg = mkApp (intro, [| argtyp; wfpred; lift 1 make; mkRel 1 |]) in let app = mkApp (mkRel (2 * len + 2 (* recproof + orig binders + current binders *)), [| arg |]) in let rcurry = mkApp (rel, [| measure; lift len measure |]) in - let lam = (Name (Id.of_string "recproof"), None, rcurry) in + let lam = LocalAssum (Name (Id.of_string "recproof"), rcurry) in let body = it_mkLambda_or_LetIn app (lam :: binders_rel) in let ty = it_mkProd_or_LetIn (lift 1 top_arity) (lam :: binders_rel) in - (Name recname, Some body, ty) + LocalDef (Name recname, body, ty) in let fun_bl = intern_fun_binder :: [arg] in let lift_lets = Termops.lift_rel_context 1 letbinders in let intern_body = - let ctx = (Name recname, None, pi3 curry_fun) :: binders_rel in + let ctx = LocalAssum (Name recname, get_type curry_fun) :: binders_rel in let (r, l, impls, scopes) = Constrintern.compute_internalization_data env Constrintern.Recursive full_arity impls @@ -991,7 +1013,7 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation = ~src:(Loc.ghost, Evar_kinds.QuestionMark (Evar_kinds.Define false)) wf_proof; prop |]) in - let def = Typing.solve_evars env evdref def in + let def = Typing.e_solve_evars env evdref def in let _ = evdref := Evarutil.nf_evar_map !evdref in let def = mkApp (def, [|intern_body_lam|]) in let binders_rel = nf_evar_context !evdref binders_rel in @@ -1000,12 +1022,12 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation = let hook, recname, typ = if List.length binders_rel > 1 then let name = add_suffix recname "_func" in - let hook l gr = + 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 ?names:pl !evdref in (*FIXME poly? *) - let ce = definition_entry ~types:ty ~univs (Evarutil.nf_evar !evdref body) in + let ce = definition_entry ~poly ~types:ty ~univs (Evarutil.nf_evar !evdref body) in (** FIXME: include locality *) let c = Declare.declare_constant recname (DefinitionEntry ce, IsDefinition Definition) in let gr = ConstRef c in @@ -1016,7 +1038,7 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation = hook, name, typ else let typ = it_mkProd_or_LetIn top_arity binders_rel in - let hook l gr = + let hook l gr _ = if Impargs.is_implicit_args () || not (List.is_empty impls) then Impargs.declare_manual_implicits false gr [impls] in hook, recname, typ @@ -1029,15 +1051,26 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation = Obligations.eterm_obligations env recname !evdref 0 fullcoqc fullctyp in let ctx = Evd.evar_universe_context !evdref in - ignore(Obligations.add_definition recname ~term:evars_def + ignore(Obligations.add_definition recname ~term:evars_def ?pl evars_typ ctx evars ~hook) let interp_recursive isfix fixl notations = + let open Context.Named.Declaration in let env = Global.env() in 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 @@ -1055,11 +1088,11 @@ let interp_recursive isfix fixl notations = let fixprot = try let app = mkApp (delayed_force fix_proto, [|sort; t|]) in - Typing.solve_evars env evdref app + Typing.e_solve_evars env evdref app with e when Errors.noncritical e -> t in - (id,None,fixprot) :: env' - else (id,None,t) :: env') + LocalAssum (id,fixprot) :: env' + else LocalAssum (id,t) :: env') [] fixnames fixtypes in let env_rec = push_named_context rec_sign env in @@ -1081,10 +1114,10 @@ let interp_recursive isfix fixl notations = let evd, nf = nf_evars_and_universes evd in let fixdefs = List.map (Option.map nf) fixdefs in let fixtypes = List.map nf fixtypes in - let fixctxnames = List.map (fun (_,ctx) -> List.map pi1 ctx) fixctxs in + let fixctxnames = List.map (fun (_,ctx) -> List.map get_name 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); @@ -1094,20 +1127,21 @@ 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 = - List.map3 (fun id t (len,imps,_) -> (id,(t,(len,imps)))) fixnames fixtypes fiximps in + List.map3 (fun id t (len,imps,_) -> ((id,pl),(t,(len,imps)))) + fixnames fixtypes fiximps in let init_tac = Some (List.map (Option.cata Tacmach.refine_no_check Tacticals.tclIDTAC) fixdefs) in @@ -1127,11 +1161,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 = UState.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; @@ -1139,11 +1173,12 @@ 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 = - List.map3 (fun id t (len,imps,_) -> (id,(t,(len,imps)))) fixnames fixtypes fiximps in + List.map3 (fun id t (len,imps,_) -> ((id,pl),(t,(len,imps)))) + fixnames fixtypes fiximps in let init_tac = Some (List.map (Option.cata Tacmach.refine_no_check Tacticals.tclIDTAC) fixdefs) in @@ -1158,11 +1193,13 @@ let declare_cofixpoint local poly ((fixnames,fixdefs,fixtypes),ctx,fiximps) ntns 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 = UState.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 @@ -1197,7 +1234,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 *) @@ -1236,22 +1273,22 @@ let do_program_recursive local p fixkind fixl ntns = | Obligations.IsFixpoint _ -> (local, p, Fixpoint) | Obligations.IsCoFixpoint -> (local, p, CoFixpoint) in - Obligations.add_mutual_definitions defs ~kind ctx ntns fixkind + Obligations.add_mutual_definitions defs ~kind ?pl ctx ntns fixkind 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),pl),_,bl,typ,def),ntn)] -> let recarg = match n with | Some n -> mkIdentC (snd n) | None -> errorlabstrm "do_program_fixpoint" (str "Recursive argument required for well-founded fixpoints") - in build_wellfounded (id, n, bl, typ, out_def def) r recarg ntn + in build_wellfounded (id, pl, n, bl, typ, out_def def) poly r recarg ntn - | [(n, CMeasureRec (m, r))], [((((_,id),_),_,bl,typ,def),ntn)] -> - build_wellfounded (id, n, bl, typ, out_def def) + | [(n, CMeasureRec (m, r))], [((((_,id),pl),_,bl,typ,def),ntn)] -> + build_wellfounded (id, pl, n, bl, typ, out_def def) poly (Option.default (CRef (lt_ref,None)) r) m ntn | _, _ when List.for_all (fun (n, ro) -> ro == CStructRec) g -> @@ -1267,9 +1304,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 b1e1d7d06..b97cb487d 100644 --- a/toplevel/command.mli +++ b/toplevel/command.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -20,22 +20,24 @@ 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 : lident list option -> local_binder list -> polymorphic -> red_expr option -> constr_expr -> - constr_expr option -> definition_entry * Evd.evar_map * Impargs.manual_implicits + 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 -> lident list option -> @@ -52,7 +54,7 @@ val do_definition : Id.t -> definition_kind -> lident list option -> 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 @@ -91,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 *) @@ -135,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 @@ -168,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 f0cac72d0..b81c8da71 100644 --- a/toplevel/coqinit.ml +++ b/toplevel/coqinit.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -130,6 +130,7 @@ 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 diff --git a/toplevel/coqinit.mli b/toplevel/coqinit.mli index c019cc1ce..4ff87628c 100644 --- a/toplevel/coqinit.mli +++ b/toplevel/coqinit.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index caaf8054b..063ed8964 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/toplevel/coqloop.mli b/toplevel/coqloop.mli index 8ed661e67..00554da30 100644 --- a/toplevel/coqloop.mli +++ b/toplevel/coqloop.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 4852a6d33..f46b90111 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -35,7 +35,7 @@ let print_header () = ppnl (str "Welcome to Coq " ++ str ver ++ str " (" ++ str rev ++ str ")"); pp_flush () -let warning s = msg_warning (strbrk s) +let warning s = with_option Flags.warn msg_warning (strbrk s) let toploop = ref None @@ -196,6 +196,11 @@ let require () = let map dir = Qualid (Loc.ghost, qualid_of_string dir) in Vernacentries.vernac_require None (Some false) (List.rev_map map !require_list) +let add_compat_require v = + match v with + | Flags.V8_4 -> add_require "Coq.Compat.Coq84" + | _ -> () + let compile_list = ref ([] : (bool * string) list) let glob_opt = ref false @@ -252,18 +257,19 @@ let set_emacs () = *) let init_gc () = - let param = - try ignore (Sys.getenv "OCAMLRUNPARAM"); true - with Not_found -> false - in - let control = Gc.get () in - let tweaked_control = { control with - Gc.minor_heap_size = 33554432; (** 4M *) -(* Gc.major_heap_increment = 268435456; (** 32M *) *) - Gc.space_overhead = 120; - } in - if param then () - else Gc.set tweaked_control + try + (* OCAMLRUNPARAM environment variable is set. + * In that case, we let ocamlrun to use the values provided by the user. + *) + ignore (Sys.getenv "OCAMLRUNPARAM") + + with Not_found -> + (* OCAMLRUNPARAM environment variable is not set. + * In this case, we put in place our preferred configuration. + *) + Gc.set { (Gc.get ()) with + Gc.minor_heap_size = 33554432; (** 4M *) + Gc.space_overhead = 120} (*s Parsing of the command line. We no longer use [Arg.parse], in order to use share [Usage.print_usage] @@ -437,10 +443,6 @@ let parse_args arglist = end |"-R" -> begin match rem with - | d :: "-as" :: [] -> error_missing_arg opt - | d :: "-as" :: p :: rem -> - warning "option -R * -as * deprecated, remove the -as"; - set_include d p true; args := rem | d :: p :: rem -> set_include d p true; args := rem | _ -> error_missing_arg opt end @@ -475,7 +477,7 @@ let parse_args arglist = |"-async-proofs-private-flags" -> Flags.async_proofs_private_flags := Some (next ()); |"-worker-id" -> set_worker_id opt (next ()) - |"-compat" -> Flags.compat_version := get_compat_version (next ()) + |"-compat" -> let v = get_compat_version (next ()) in Flags.compat_version := v; add_compat_require v |"-compile" -> add_compile false (next ()) |"-compile-verbose" -> add_compile true (next ()) |"-dump-glob" -> Dumpglob.dump_into_file (next ()); glob_opt := true @@ -541,6 +543,7 @@ let parse_args arglist = |"-v"|"--version" -> Usage.version (exitcode ()) |"-verbose-compat-notations" -> verb_compat_ntn := true |"-where" -> print_where := true + |"-xml" -> Flags.xml_export := true (* Deprecated options *) |"-byte" -> warning "option -byte deprecated, call with .byte suffix" @@ -556,7 +559,6 @@ let parse_args arglist = |"-force-load-proofs" -> warning "Obsolete option \"-force-load-proofs\"." |"-unsafe" -> warning "Obsolete option \"-unsafe\"."; ignore (next ()) |"-quality" -> warning "Obsolete option \"-quality\"." - |"-xml" -> warning "Obsolete option \"-xml\"." (* Unknown option *) | s -> extras := s :: !extras @@ -571,7 +573,7 @@ let parse_args arglist = else fatal_error (Errors.print e) false | any -> fatal_error (Errors.print any) (Errors.is_anomaly any) -let init arglist = +let init_toplevel arglist = init_gc (); Sys.catch_break false; (* Ctrl-C is fatal during the initialisation *) Lib.init(); @@ -635,8 +637,6 @@ let init arglist = exit 0 end -let init_toplevel = init - 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, diff --git a/toplevel/coqtop.mli b/toplevel/coqtop.mli index 670447452..c9d1ba45d 100644 --- a/toplevel/coqtop.mli +++ b/toplevel/coqtop.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/toplevel/discharge.ml b/toplevel/discharge.ml index 7d5d61fb8..ffa11679c 100644 --- a/toplevel/discharge.ml +++ b/toplevel/discharge.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -9,20 +9,22 @@ open Names open Errors open Util -open Context open Term open Vars open Entries open Declarations open Cooking +open Entries +open Context.Rel.Declaration (********************************) (* Discharging mutual inductive *) -let detype_param = function - | (Name id,None,p) -> id, Entries.LocalAssum p - | (Name id,Some p,_) -> id, Entries.LocalDef p - | (Anonymous,_,_) -> anomaly (Pp.str "Unnamed inductive local variable") +let detype_param = + function + | LocalAssum (Name id, p) -> id, LocalAssumEntry p + | LocalDef (Name id, p,_) -> id, LocalDefEntry p + | _ -> anomaly (Pp.str "Unnamed inductive local variable") (* Replace @@ -37,8 +39,8 @@ let detype_param = function let abstract_inductive hyps nparams inds = let ntyp = List.length inds in - let nhyp = named_context_length hyps in - let args = instance_from_named_context (List.rev hyps) in + let nhyp = Context.Named.length hyps in + let args = Context.Named.to_instance (List.rev hyps) in let args = Array.of_list args in let subs = List.init ntyp (fun k -> lift nhyp (mkApp(mkRel (k+1),args))) in let inds' = @@ -53,7 +55,7 @@ let abstract_inductive hyps nparams inds = (* To be sure to be the same as before, should probably be moved to process_inductive *) let params' = let (_,arity,_,_,_) = List.hd inds' in let (params,_) = decompose_prod_n_assum nparams' arity in - List.map detype_param params + List.map detype_param params in let ind'' = List.map @@ -100,7 +102,7 @@ let process_inductive (sechyps,abs_ctx) modlist mib = Array.to_list mip.mind_consnames, Array.to_list lc)) mib.mind_packets in - let sechyps' = map_named_context (expmod_constr modlist) sechyps in + let sechyps' = Context.Named.map (expmod_constr modlist) sechyps in let (params',inds') = abstract_inductive sechyps' nparams inds in let abs_ctx = Univ.instantiate_univ_context abs_ctx in let univs = Univ.UContext.union abs_ctx univs in diff --git a/toplevel/discharge.mli b/toplevel/discharge.mli index 386e4e3ef..18d1b6776 100644 --- a/toplevel/discharge.mli +++ b/toplevel/discharge.mli @@ -1,15 +1,14 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Context open Declarations open Entries open Opaqueproof val process_inductive : - named_context Univ.in_universe_context -> work_list -> mutual_inductive_body -> mutual_inductive_entry + Context.Named.t Univ.in_universe_context -> work_list -> mutual_inductive_body -> mutual_inductive_entry diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml index 8f380830d..ad848ccfc 100644 --- a/toplevel/himsg.ml +++ b/toplevel/himsg.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -23,22 +23,26 @@ open Cases open Logic open Printer open Evd +open Context.Rel.Declaration (* This simplifies the typing context of Cases clauses *) (* hope it does not disturb other typing contexts *) let contract env lc = let l = ref [] in - let contract_context (na,c,t) env = - match c with - | Some c' when isRel c' -> + let contract_context decl env = + match decl with + | LocalDef (_,c',_) when isRel c' -> l := (Vars.substl !l c') :: !l; env | _ -> - let t' = Vars.substl !l t in - let c' = Option.map (Vars.substl !l) c in - let na' = named_hd env t' na in + let t' = Vars.substl !l (get_type decl) in + let c' = Option.map (Vars.substl !l) (get_value decl) in + let na' = named_hd env t' (get_name decl) in l := (mkRel 1) :: List.map (Vars.lift 1) !l; - push_rel (na',c',t') env in + match c' with + | None -> push_rel (LocalAssum (na',t')) env + | Some c' -> push_rel (LocalDef (na',c',t')) env + in let env = process_rel_context contract_context env in (env, List.map (Vars.substl !l) lc) @@ -72,6 +76,15 @@ let rec contract3' env a b c = function let y,x = contract3' env a b c x in y,CannotSolveConstraint ((pb,env,t,u),x) +(** Ad-hoc reductions *) + +let j_nf_betaiotaevar sigma j = + { uj_val = Evarutil.nf_evar sigma j.uj_val; + uj_type = Reductionops.nf_betaiota sigma j.uj_type } + +let jv_nf_betaiotaevar sigma jl = + Array.map (j_nf_betaiotaevar sigma) jl + (** Printers *) let pr_lconstr c = quote (pr_lconstr c) @@ -136,9 +149,9 @@ let pr_explicit env sigma t1 t2 = pr_explicit_aux env sigma t1 t2 explicit_flags let pr_db env i = try - match lookup_rel i env with - Name id, _, _ -> pr_id id - | Anonymous, _, _ -> str "<>" + match lookup_rel i env |> get_name with + | Name id -> pr_id id + | Anonymous -> str "<>" with Not_found -> str "UNBOUND_REL_" ++ int i let explain_unbound_rel env sigma n = @@ -260,7 +273,7 @@ let explain_generalization env sigma (name,var) j = str "it has type" ++ spc () ++ pt ++ spc () ++ str "which should be Set, Prop or Type." -let rec explain_unification_error env sigma p1 p2 = function +let explain_unification_error env sigma p1 p2 = function | None -> mt() | Some e -> let rec aux p1 p2 = function @@ -318,7 +331,7 @@ let rec explain_unification_error env sigma p1 p2 = function let explain_actual_type env sigma j t reason = let env = make_all_name_different env in - let j = Evarutil.j_nf_betaiotaevar sigma j in + let j = j_nf_betaiotaevar sigma j in let t = Reductionops.nf_betaiota sigma t in (** Actually print *) let pe = pr_ne_context_of (str "In environment") env sigma in @@ -333,7 +346,7 @@ let explain_actual_type env sigma j t reason = ppreason ++ str ".") let explain_cant_apply_bad_type env sigma (n,exptyp,actualtyp) rator randl = - let randl = Evarutil.jv_nf_betaiotaevar sigma randl in + let randl = jv_nf_betaiotaevar sigma randl in let exptyp = Evarutil.nf_evar sigma exptyp in let actualtyp = Reductionops.nf_betaiota sigma actualtyp in let rator = Evarutil.j_nf_evar sigma rator in @@ -775,7 +788,7 @@ let explain_unsatisfiable_constraints env sigma constr comp = explain_typeclass_resolution env sigma info k ++ fnl () ++ cstr let explain_pretype_error env sigma err = - let env = Evarutil.env_nf_betaiotaevar sigma env in + let env = Evardefine.env_nf_betaiotaevar sigma env in let env = make_all_name_different env in match err with | CantFindCaseType c -> explain_cant_find_case_type env sigma c @@ -822,7 +835,7 @@ let explain_not_match_error = function | ModuleTypeFieldExpected -> strbrk "a module type is expected" | NotConvertibleInductiveField id | NotConvertibleConstructorField id -> - str "types given to " ++ str (Id.to_string id) ++ str " differ" + str "types given to " ++ pr_id id ++ str " differ" | NotConvertibleBodyField -> str "the body of definitions differs" | NotConvertibleTypeField (env, typ1, typ2) -> @@ -847,7 +860,7 @@ let explain_not_match_error = function | RecordProjectionsExpected nal -> (if List.length nal >= 2 then str "expected projection names are " else str "expected projection name is ") ++ - pr_enum (function Name id -> str (Id.to_string id) | _ -> str "_") nal + pr_enum (function Name id -> pr_id id | _ -> str "_") nal | NotEqualInductiveAliases -> str "Aliases to inductive types do not match" | NoTypeConstraintExpected -> @@ -890,17 +903,27 @@ let explain_is_a_functor () = str "Illegal use of a functor." let explain_incompatible_module_types mexpr1 mexpr2 = - str "Incompatible module types." + let open Declarations in + let rec get_arg = function + | NoFunctor _ -> 0 + | MoreFunctor (_, _, ty) -> succ (get_arg ty) + in + let len1 = get_arg mexpr1.mod_type in + let len2 = get_arg mexpr2.mod_type in + if len1 <> len2 then + str "Incompatible module types: module expects " ++ int len2 ++ + str " arguments, found " ++ int len1 ++ str "." + else str "Incompatible module types." let explain_not_equal_module_paths mp1 mp2 = str "Non equal modules." let explain_no_such_label l = - str "No such label " ++ str (Label.to_string l) ++ str "." + str "No such label " ++ pr_label l ++ str "." let explain_incompatible_labels l l' = str "Opening and closing labels are not the same: " ++ - str (Label.to_string l) ++ str " <> " ++ str (Label.to_string l') ++ str "!" + pr_label l ++ str " <> " ++ pr_label l' ++ str "!" let explain_not_a_module s = quote (str s) ++ str " is not a module." @@ -909,21 +932,27 @@ let explain_not_a_module_type s = quote (str s) ++ str " is not a module type." let explain_not_a_constant l = - quote (Label.print l) ++ str " is not a constant." + quote (pr_label l) ++ str " is not a constant." let explain_incorrect_label_constraint l = str "Incorrect constraint for label " ++ - quote (Label.print l) ++ str "." + quote (pr_label l) ++ str "." let explain_generative_module_expected l = - str "The module " ++ str (Label.to_string l) ++ str " is not generative." ++ + str "The module " ++ pr_label l ++ str " is not generative." ++ strbrk " Only components of generative modules can be changed" ++ strbrk " using the \"with\" construct." let explain_label_missing l s = - str "The field " ++ str (Label.to_string l) ++ str " is missing in " + str "The field " ++ pr_label l ++ str " is missing in " ++ str s ++ str "." +let explain_include_restricted_functor mp = + let q = Nametab.shortest_qualid_of_module mp in + str "Cannot include the functor " ++ Libnames.pr_qualid q ++ + strbrk " since it has a restricted signature. " ++ + strbrk "You may name first an instance of this functor, and include it." + let explain_module_error = function | SignatureMismatch (l,spec,err) -> explain_signature_mismatch l spec err | LabelAlreadyDeclared l -> explain_label_already_declared l @@ -940,6 +969,7 @@ 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 + | IncludeRestrictedFunctor mp -> explain_include_restricted_functor mp (* Module internalization errors *) @@ -1190,7 +1220,7 @@ let explain_unused_clause env pats = let explain_non_exhaustive env pats = str "Non exhaustive pattern-matching: no clause found for " ++ str (String.plural (List.length pats) "pattern") ++ - spc () ++ hov 0 (pr_sequence pr_cases_pattern pats) + spc () ++ hov 0 (prlist_with_sep pr_comma pr_cases_pattern pats) let explain_cannot_infer_predicate env sigma typs = let env = make_all_name_different env in @@ -1223,77 +1253,3 @@ let explain_reduction_tactic_error = function quote (pr_goal_concl_style_env env sigma c) ++ spc () ++ str "is not well typed." ++ fnl () ++ explain_type_error env' Evd.empty e - -let is_defined_ltac trace = - let rec aux = function - | (_, Proof_type.LtacNameCall f) :: tail -> - not (Tacenv.is_ltac_for_ml_tactic f) - | (_, Proof_type.LtacAtomCall _) :: tail -> - false - | _ :: tail -> aux tail - | [] -> false in - aux (List.rev trace) - -let explain_ltac_call_trace last trace loc = - let calls = last :: List.rev_map snd trace in - let pr_call ck = match ck with - | Proof_type.LtacNotationCall kn -> quote (KerName.print kn) - | Proof_type.LtacNameCall cst -> quote (Pptactic.pr_ltac_constant cst) - | Proof_type.LtacMLCall t -> - quote (Pptactic.pr_glob_tactic (Global.env()) t) - | Proof_type.LtacVarCall (id,t) -> - quote (Nameops.pr_id id) ++ strbrk " (bound to " ++ - Pptactic.pr_glob_tactic (Global.env()) t ++ str ")" - | Proof_type.LtacAtomCall te -> - quote (Pptactic.pr_glob_tactic (Global.env()) - (Tacexpr.TacAtom (Loc.ghost,te))) - | Proof_type.LtacConstrInterp (c, { Pretyping.ltac_constrs = vars }) -> - quote (pr_glob_constr_env (Global.env()) c) ++ - (if not (Id.Map.is_empty vars) then - strbrk " (with " ++ - prlist_with_sep pr_comma - (fun (id,c) -> - pr_id id ++ str ":=" ++ Printer.pr_lconstr_under_binders c) - (List.rev (Id.Map.bindings vars)) ++ str ")" - else mt()) - in - match calls with - | [] -> mt () - | _ -> - let kind_of_last_call = match List.last calls with - | Proof_type.LtacConstrInterp _ -> ", last term evaluation failed." - | _ -> ", last call failed." - in - hov 0 (str "In nested Ltac calls to " ++ - pr_enum pr_call calls ++ strbrk kind_of_last_call) - -let skip_extensions trace = - let rec aux = function - | (_,Proof_type.LtacNameCall f as tac) :: _ - when Tacenv.is_ltac_for_ml_tactic f -> [tac] - | (_,(Proof_type.LtacNotationCall _ | Proof_type.LtacMLCall _) as tac) - :: _ -> [tac] - | t :: tail -> t :: aux tail - | [] -> [] in - List.rev (aux (List.rev trace)) - -let extract_ltac_trace trace eloc = - let trace = skip_extensions trace in - let (loc,c),tail = List.sep_last trace in - if is_defined_ltac trace then - (* We entered a user-defined tactic, - we display the trace with location of the call *) - let msg = hov 0 (explain_ltac_call_trace c tail eloc ++ fnl()) in - Some msg, loc - else - (* We entered a primitive tactic, we don't display trace but - report on the finest location *) - let best_loc = - if not (Loc.is_ghost eloc) then eloc else - (* trace is with innermost call coming first *) - let rec aux = function - | (loc,_)::tail when not (Loc.is_ghost loc) -> loc - | _::tail -> aux tail - | [] -> Loc.ghost in - aux trace in - None, best_loc diff --git a/toplevel/himsg.mli b/toplevel/himsg.mli index 3d5442bb1..ced54fd27 100644 --- a/toplevel/himsg.mli +++ b/toplevel/himsg.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -36,9 +36,6 @@ val explain_pattern_matching_error : val explain_reduction_tactic_error : Tacred.reduction_tactic_error -> std_ppcmds -val extract_ltac_trace : - Proof_type.ltac_trace -> Loc.t -> std_ppcmds option * Loc.t - val explain_module_error : Modops.module_typing_error -> std_ppcmds val explain_module_internalization_error : diff --git a/toplevel/ind_tables.ml b/toplevel/ind_tables.ml index 218c47b28..35717ed61 100644 --- a/toplevel/ind_tables.ml +++ b/toplevel/ind_tables.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -29,9 +29,9 @@ open Pp (* Registering schemes in the environment *) type mutual_scheme_object_function = - internal_flag -> 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 = - internal_flag -> 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 @@ -124,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; @@ -148,8 +150,8 @@ let define_individual_scheme_base kind suff f mode idopt (mind,i as ind) = | None -> add_suffix mib.mind_packets.(i).mind_typename suff 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 mode names (mind,i as ind) = match Hashtbl.find scheme_object_table kind with @@ -168,8 +170,8 @@ let define_mutual_scheme_base kind suff f mode names mind = 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 @@ -181,10 +183,10 @@ let define_mutual_scheme kind 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 ?(mode=InternalTacticRequest) kind (mind,i as ind) = try find_scheme_on_env_too kind ind diff --git a/toplevel/ind_tables.mli b/toplevel/ind_tables.mli index d0844dd94..20f30d6d1 100644 --- a/toplevel/ind_tables.mli +++ b/toplevel/ind_tables.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -20,9 +20,9 @@ type individual type 'a scheme_kind type mutual_scheme_object_function = - internal_flag -> 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 = - internal_flag -> 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 *) @@ -37,13 +37,13 @@ val declare_individual_scheme_object : string -> ?aux:string -> val define_individual_scheme : individual scheme_kind -> internal_flag (** internal *) -> - Id.t option -> inductive -> constant * Declareops.side_effects + Id.t option -> inductive -> constant * Safe_typing.private_constants val define_mutual_scheme : mutual scheme_kind -> internal_flag (** internal *) -> - (int * Id.t) list -> mutual_inductive -> constant array * Declareops.side_effects + (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 : ?mode:internal_flag -> '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 ae8ee7670..367425546 100644 --- a/toplevel/indschemes.ml +++ b/toplevel/indschemes.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -38,6 +38,7 @@ open Ind_tables open Auto_ind_decl open Eqschemes open Elimschemes +open Context.Rel.Declaration (* Flags governing automatic synthesis of schemes *) @@ -128,8 +129,8 @@ let define id internal ctx c t = { const_entry_body = c; const_entry_secctx = None; const_entry_type = t; - const_entry_polymorphic = true; - const_entry_universes = Evd.universe_context ctx; + const_entry_polymorphic = Flags.is_universe_polymorphism (); + const_entry_universes = snd (Evd.universe_context ctx); const_entry_opaque = false; const_entry_inline_code = false; const_entry_feedback = None; @@ -150,12 +151,14 @@ let alarm what internal msg = | InternalTacticRequest -> (if debug then msg_warning - (hov 0 msg ++ fnl () ++ what ++ str " not defined.")) - | _ -> errorlabstrm "" msg + (hov 0 msg ++ fnl () ++ what ++ str " not defined.")); None + | _ -> Some msg let try_declare_scheme what f internal names kn = try f internal names kn - with + with e -> + let e = Errors.push e in + let msg = match fst e with | ParameterWithoutEquality cst -> alarm what internal (str "Boolean equality not found for parameter " ++ pr_con cst ++ @@ -186,6 +189,11 @@ let try_declare_scheme what f internal names kn = | e when Errors.noncritical e -> alarm what internal (str "Unexpected error during scheme creation: " ++ Errors.print e) + | _ -> iraise e + in + match msg with + | None -> () + | Some msg -> iraise (UserError ("", msg), snd e) let beq_scheme_msg mind = let mib = Global.lookup_mind mind in @@ -360,18 +368,27 @@ requested let do_mutual_induction_scheme lnamedepindsort = let lrecnames = List.map (fun ((_,f),_,_,_) -> f) lnamedepindsort and env0 = Global.env() in - let sigma, lrecspec = + let sigma, lrecspec, _ = List.fold_right - (fun (_,dep,ind,sort) (evd, l) -> - let evd, indu = Evd.fresh_inductive_instance env0 evd ind in - (evd, (indu,dep,interp_elimination_sort sort) :: l)) - lnamedepindsort (Evd.from_env env0,[]) + (fun (_,dep,ind,sort) (evd, l, inst) -> + let evd, indu, inst = + match inst with + | None -> + let _, ctx = Global.type_of_global_in_context env0 (IndRef ind) in + let ctxs = Univ.ContextSet.of_context ctx in + let evd = Evd.from_ctx (Evd.evar_universe_context_of ctxs) in + let u = Univ.UContext.instance ctx in + evd, (ind,u), Some u + | Some ui -> evd, (ind, ui), inst + in + (evd, (indu,dep,interp_elimination_sort sort) :: l, inst)) + lnamedepindsort (Evd.from_env env0,[],None) in let sigma, listdecl = Indrec.build_mutual_induction_scheme env0 sigma lrecspec in 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 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 @@ -454,7 +471,7 @@ let build_combined_scheme env schemes = in let ctx, _ = list_split_rev_at prods - (List.rev_map (fun (x, y) -> x, None, y) ctx) in + (List.rev_map (fun (x, y) -> LocalAssum (x, y)) ctx) in let typ = it_mkProd_wo_LetIn concl_typ ctx in let body = it_mkLambda_or_LetIn concl_bod ctx in (body, typ) @@ -469,7 +486,7 @@ 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 + 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/indschemes.mli b/toplevel/indschemes.mli index 987461078..e5d79fd51 100644 --- a/toplevel/indschemes.mli +++ b/toplevel/indschemes.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/toplevel/locality.ml b/toplevel/locality.ml index 1145a20bb..ef789aa5c 100644 --- a/toplevel/locality.ml +++ b/toplevel/locality.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/toplevel/locality.mli b/toplevel/locality.mli index c395fe921..2ec392eef 100644 --- a/toplevel/locality.mli +++ b/toplevel/locality.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml index 7714cc810..7c1f05cd3 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -43,163 +43,6 @@ let inToken : string -> obj = let add_token_obj s = Lib.add_anonymous_leaf (inToken s) (**********************************************************************) -(* Tactic Notation *) - -let interp_prod_item lev = function - | TacTerm s -> GramTerminal s - | TacNonTerm (loc, nt, po) -> - let sep = match po with Some (_,sep) -> sep | _ -> "" in - let EntryName (etyp, e) = interp_entry_name true (TgTactic lev) nt sep in - GramNonTerminal (loc, etyp, e, Option.map fst po) - -let make_terminal_status = function - | GramTerminal s -> Some s - | GramNonTerminal _ -> None - -let rec make_tags = function - | GramTerminal s :: l -> make_tags l - | GramNonTerminal (loc, etyp, _, po) :: l -> Genarg.unquote etyp :: make_tags l - | [] -> [] - -let make_fresh_key = - let id = Summary.ref ~name:"TACTIC-NOTATION-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) - -type tactic_grammar_obj = { - tacobj_key : KerName.t; - tacobj_local : locality_flag; - tacobj_tacgram : tactic_grammar; - tacobj_tacpp : Pptactic.pp_tactic; - 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 - -let open_tactic_notation i (_, tobj) = - let key = tobj.tacobj_key in - if Int.equal i 1 && not tobj.tacobj_local then - Egramcoq.extend_tactic_grammar key tobj.tacobj_tacgram - -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; - if Int.equal i 1 && not tobj.tacobj_local then - Egramcoq.extend_tactic_grammar key tobj.tacobj_tacgram - -let subst_tactic_notation (subst, tobj) = - { tobj with - tacobj_key = Mod_subst.subst_kn subst tobj.tacobj_key; - tacobj_body = Tacsubst.subst_tactic subst tobj.tacobj_body; - } - -let classify_tactic_notation tacobj = Substitute tacobj - -let inTacticGrammar : tactic_grammar_obj -> obj = - declare_object {(default_object "TacticGrammar") with - open_function = open_tactic_notation; - load_function = load_tactic_notation; - cache_function = cache_tactic_notation; - subst_function = subst_tactic_notation; - classify_function = classify_tactic_notation} - -let cons_production_parameter l = function - | GramTerminal _ -> l - | GramNonTerminal (_,_,_,ido) -> Option.List.cons ido l - -let add_tactic_notation (local,n,prods,e) = - let prods = List.map (interp_prod_item n) prods in - let tags = make_tags prods in - let pprule = { - Pptactic.pptac_args = tags; - pptac_prods = (n, List.map make_terminal_status prods); - } in - let ids = List.fold_left cons_production_parameter [] prods in - let tac = Tacintern.glob_tactic_env ids (Global.env()) e in - let parule = { - tacgram_level = n; - tacgram_prods = prods; - } in - let tacobj = { - tacobj_key = make_fresh_key (); - tacobj_local = local; - tacobj_tacgram = parule; - tacobj_tacpp = pprule; - tacobj_body = tac; - } in - Lib.add_anonymous_leaf (inTacticGrammar tacobj) - -(**********************************************************************) -(* ML Tactic entries *) - -type atomic_entry = string * Genarg.glob_generic_argument list option - -type ml_tactic_grammar_obj = { - mltacobj_name : Tacexpr.ml_tactic_name; - (** ML-side unique name *) - mltacobj_prod : Tacexpr.raw_tactic_expr grammar_prod_item list list; - (** Grammar rules generating the ML tactic. *) -} - -(** ML tactic notations whose use can be restricted to an identifier are added - as true Ltac entries. *) -let extend_atomic_tactic name entries = - let add_atomic i (id, args) = match args with - | None -> () - | Some args -> - let open Tacexpr in - let entry = { mltac_name = name; mltac_index = i } in - let body = TacML (Loc.ghost, entry, args) in - Tacenv.register_ltac false false (Names.Id.of_string id) body - in - List.iteri add_atomic entries - -let cache_ml_tactic_notation (_, obj) = - extend_ml_tactic_grammar obj.mltacobj_name obj.mltacobj_prod - -let open_ml_tactic_notation i obj = - if Int.equal i 1 then cache_ml_tactic_notation obj - -let inMLTacticGrammar : ml_tactic_grammar_obj -> obj = - declare_object { (default_object "MLTacticGrammar") with - open_function = open_ml_tactic_notation; - cache_function = cache_ml_tactic_notation; - classify_function = (fun o -> Substitute o); - subst_function = (fun (_, o) -> o); - } - -let add_ml_tactic_notation name prods atomic = - let obj = { - mltacobj_name = name; - mltacobj_prod = prods; - } in - Lib.add_anonymous_leaf (inMLTacticGrammar obj); - extend_atomic_tactic name atomic - -(**********************************************************************) (* Printing grammar entries *) let entry_buf = Buffer.create 64 @@ -542,10 +385,15 @@ let add_break_if_none n = function | l -> UnpCut (PpBrk(n,0)) :: l let check_open_binder isopen sl m = + let pr_token = function + | Terminal s -> str s + | Break n -> str "␣" + | _ -> assert false + in if isopen && not (List.is_empty sl) then errorlabstrm "" (str "as " ++ pr_id m ++ str " is a non-closed binder, no such \"" ++ - prlist_with_sep spc (function Terminal s -> str s | _ -> assert false) sl + prlist_with_sep spc pr_token sl ++ strbrk "\" is allowed to occur.") (* Heuristics for building default printing rules *) @@ -975,9 +823,10 @@ let make_internalization_vars recvars mainvars typs = let extratyps = List.map (fun (x,y) -> (y,List.assoc x maintyps)) recvars in maintyps @ extratyps -let make_interpretation_type isrec = function +let make_interpretation_type isrec isonlybinding = function | NtnInternTypeConstr when isrec -> NtnTypeConstrList - | NtnInternTypeConstr | NtnInternTypeIdent -> NtnTypeConstr + | NtnInternTypeConstr | NtnInternTypeIdent -> + if isonlybinding then NtnTypeOnlyBinder else NtnTypeConstr | NtnInternTypeBinder when isrec -> NtnTypeBinderList | NtnInternTypeBinder -> error "Type not allowed in recursive notation." @@ -987,16 +836,16 @@ let make_interpretation_vars recvars allvars = List.equal String.equal l1 l2 in let check (x, y) = - let (scope1, _) = Id.Map.find x allvars in - let (scope2, _) = Id.Map.find y allvars in + let (_,scope1, _) = Id.Map.find x allvars in + let (_,scope2, _) = Id.Map.find y allvars in if not (eq_subscope scope1 scope2) then error_not_same_scope x y in let () = List.iter check recvars in let useless_recvars = List.map snd recvars in let mainvars = Id.Map.filter (fun x _ -> not (Id.List.mem x useless_recvars)) allvars in - Id.Map.mapi (fun x (sc, typ) -> - (sc, make_interpretation_type (Id.List.mem_assoc x recvars) typ)) mainvars + Id.Map.mapi (fun x (isonlybinding, sc, typ) -> + (sc, make_interpretation_type (Id.List.mem_assoc x recvars) isonlybinding typ)) mainvars let check_rule_productivity l = if List.for_all (function NonTerminal _ -> true | _ -> false) l then @@ -1450,7 +1299,7 @@ let add_syntactic_definition ident (vars,c) local onlyparse = } in let nvars, pat = interp_notation_constr nenv c in let () = nonprintable := nenv.ninterp_only_parse in - let map id = let (sc, _) = Id.Map.find id nvars in (id, sc) in + let map id = let (_,sc,_) = Id.Map.find id nvars in (id, sc) in List.map map vars, pat in let onlyparse = match onlyparse with diff --git a/toplevel/metasyntax.mli b/toplevel/metasyntax.mli index f7049999e..085cc87c8 100644 --- a/toplevel/metasyntax.mli +++ b/toplevel/metasyntax.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -15,17 +15,6 @@ open Notation_term val add_token_obj : string -> unit -(** Adding a tactic notation in the environment *) - -val add_tactic_notation : - locality_flag * int * grammar_tactic_prod_item_expr list * raw_tactic_expr -> - unit - -type atomic_entry = string * Genarg.glob_generic_argument list option - -val add_ml_tactic_notation : ml_tactic_name -> - Tacexpr.raw_tactic_expr Egramml.grammar_prod_item list list -> atomic_entry list -> unit - (** Adding a (constr) notation in the environment*) val add_infix : locality_flag -> (lstring * syntax_modifier list) -> diff --git a/toplevel/mltop.ml b/toplevel/mltop.ml index fa5ed7bbd..d0fa7a80c 100644 --- a/toplevel/mltop.ml +++ b/toplevel/mltop.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/toplevel/mltop.mli b/toplevel/mltop.mli index 4f3f4ddde..5d0546824 100644 --- a/toplevel/mltop.mli +++ b/toplevel/mltop.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/toplevel/obligations.ml b/toplevel/obligations.ml index 406aacebe..b2fc456d0 100644 --- a/toplevel/obligations.ml +++ b/toplevel/obligations.ml @@ -13,7 +13,6 @@ open Declare *) open Term -open Context open Vars open Names open Evd @@ -44,7 +43,7 @@ let check_evars env evm = type oblinfo = { ev_name: int * Id.t; - ev_hyps: named_context; + ev_hyps: Context.Named.t; ev_status: Evar_kinds.obligation_definition_status; ev_chop: int option; ev_src: Evar_kinds.t Loc.located; @@ -52,13 +51,11 @@ type oblinfo = ev_tac: unit Proofview.tactic option; ev_deps: Int.Set.t } -(* spiwack: Store field for internalizing ev_tac in evar_infos' evar_extra. *) -let evar_tactic = Store.field () - (** Substitute evar references in t using De Bruijn indices, where n binders were passed through. *) -let subst_evar_constr evs n idf t = +let subst_evar_constr evs n idf t = + let open Context.Named.Declaration in let seen = ref Int.Set.empty in let transparent = ref Id.Set.empty in let evar_info id = List.assoc_f Evar.equal id evs in @@ -82,9 +79,9 @@ let subst_evar_constr evs n idf t = let args = let rec aux hyps args acc = match hyps, args with - ((_, None, _) :: tlh), (c :: tla) -> + (LocalAssum _ :: tlh), (c :: tla) -> aux tlh tla ((substrec (depth, fixrels) c) :: acc) - | ((_, Some _, _) :: tlh), (_ :: tla) -> + | (LocalDef _ :: tlh), (_ :: tla) -> aux tlh tla acc | [], [] -> acc | _, _ -> acc (*failwith "subst_evars: invalid argument"*) @@ -120,22 +117,23 @@ let subst_vars acc n t = Changes evars and hypothesis references to variable references. *) let etype_of_evar evs hyps concl = + let open Context.Named.Declaration in let rec aux acc n = function - (id, copt, t) :: tl -> - let t', s, trans = subst_evar_constr evs n mkVar t in + decl :: tl -> + let t', s, trans = subst_evar_constr evs n mkVar (get_type decl) in let t'' = subst_vars acc 0 t' in - let rest, s', trans' = aux (id :: acc) (succ n) tl in + let rest, s', trans' = aux (get_id decl :: acc) (succ n) tl in let s' = Int.Set.union s s' in let trans' = Id.Set.union trans trans' in - (match copt with - Some c -> + (match decl with + | LocalDef (id,c,_) -> let c', s'', trans'' = subst_evar_constr evs n mkVar c in let c' = subst_vars acc 0 c' in - mkNamedProd_or_LetIn (id, Some c', t'') rest, + mkNamedProd_or_LetIn (LocalDef (id, c', t'')) rest, Int.Set.union s'' s', Id.Set.union trans'' trans' - | None -> - mkNamedProd_or_LetIn (id, None, t'') rest, s', trans') + | LocalAssum (id,_) -> + mkNamedProd_or_LetIn (LocalAssum (id, t'')) rest, s', trans') | [] -> let t', s, trans = subst_evar_constr evs n mkVar concl in subst_vars acc 0 t', s, trans @@ -194,7 +192,7 @@ open Environ let eterm_obligations env name evm fs ?status t ty = (* 'Serialize' the evars *) let nc = Environ.named_context env in - let nc_len = Context.named_context_length nc in + let nc_len = Context.Named.length nc in let evm = Evarutil.nf_evar_map_undefined evm in let evl = Evarutil.non_instantiated evm in let evl = Evar.Map.bindings evl in @@ -229,17 +227,9 @@ let eterm_obligations env name evm fs ?status t ty = | Some s -> s, None | None -> Evar_kinds.Define true, None in - let tac = match Store.get ev.evar_extra evar_tactic with - | Some t -> - if Dyn.has_tag t "tactic" then - Some (Tacinterp.interp - (Tacinterp.globTacticIn (Tacinterp.tactic_out t))) - else None - | None -> None - in let info = { ev_name = (n, nstr); ev_hyps = hyps; ev_status = status; ev_chop = chop; - ev_src = loc, k; ev_typ = evtyp ; ev_deps = deps; ev_tac = tac } + ev_src = loc, k; ev_typ = evtyp ; ev_deps = deps; ev_tac = None } in (id, info) :: l) evn [] in @@ -277,7 +267,7 @@ let reduce c = exception NoObligations of Id.t option let explain_no_obligations = function - Some ident -> str "No obligations for program " ++ str (Id.to_string ident) + Some ident -> str "No obligations for program " ++ Id.print ident | None -> str "No obligations remaining" type obligation_info = @@ -311,6 +301,7 @@ type program_info_aux = { prg_body: constr; prg_type: constr; prg_ctx: Evd.evar_universe_context; + prg_pl: Id.t Loc.located list option; prg_obligations: obligations; prg_deps : Id.t list; prg_fixkind : fixpoint_kind option ; @@ -318,21 +309,21 @@ type program_info_aux = { prg_notations : notations ; prg_kind : definition_kind; prg_reduce : constr -> constr; - prg_hook : unit Lemmas.declaration_hook; + prg_hook : (Evd.evar_universe_context -> unit) Lemmas.declaration_hook; prg_opaque : bool; + prg_sign: named_context_val; } -type program_info = program_info_aux Ephemeron.key +type program_info = program_info_aux CEphemeron.key let get_info x = - try Ephemeron.get x - with Ephemeron.InvalidKey -> + try CEphemeron.get x + with CEphemeron.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) = - Tactic_option.declare_tactic_option "Program tactic" +let default_tactic = ref (Proofview.tclUNIT ()) (* true = All transparent, false = Opaque if possible *) let proofs_transparency = ref true @@ -459,7 +450,7 @@ let subst_deps_obl obls obl = module ProgMap = Map.Make(Id) -let map_replace k v m = ProgMap.add k (Ephemeron.create v) (ProgMap.remove k m) +let map_replace k v m = ProgMap.add k (CEphemeron.create v) (ProgMap.remove k m) let map_keys m = ProgMap.fold (fun k _ l -> k :: l) m [] @@ -508,16 +499,23 @@ 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 pl, ctx = + Evd.universe_context ?names:prg.prg_pl (Evd.from_ctx prg.prg_ctx) 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; + let () = progmap_remove prg in + let cst = !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)) - + prg.prg_kind ce prg.prg_implicits + (Lemmas.mk_hook (fun l r -> Lemmas.call_hook fix_exn prg.prg_hook l r prg.prg_ctx; r)) + in + Universes.register_universe_binders cst pl; + cst + open Pp let rec lam_index n t acc = @@ -537,11 +535,11 @@ let compute_possible_guardness_evidences (n,_) fixbody fixtype = but doing it properly involves delta-reduction, and it finally doesn't seem to worth the effort (except for huge mutual fixpoints ?) *) - let m = nb_prod fixtype in + let m = Termops.nb_prod fixtype in 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 @@ -581,6 +579,7 @@ let declare_mutual_definition l = in (* Declare the recursive definitions *) let ctx = Evd.evar_context_universe_context first.prg_ctx in + let fix_exn = Stm.get_fix_exn () in let kns = List.map4 (!declare_fix_ref ~opaque (local, poly, kind) ctx) fixnames fixdecls fixtypes fiximps in (* Declare notations *) @@ -588,18 +587,19 @@ let declare_mutual_definition l = Declare.recursive_message (fixkind != IsCoFixpoint) indexes fixnames; let gr = List.hd kns in let kn = match gr with ConstRef kn -> kn | _ -> assert false in - Lemmas.call_hook (fun exn -> exn) first.prg_hook local gr; - List.iter progmap_remove l; kn + Lemmas.call_hook fix_exn first.prg_hook local gr first.prg_ctx; + List.iter progmap_remove l; kn -let shrink_body c = +let shrink_body c = + let open Context.Rel.Declaration in let ctx, b = decompose_lam_assum c in let b', n, args = - List.fold_left (fun (b, i, args) (n, u, t) -> + List.fold_left (fun (b, i, args) decl -> if noccurn 1 b then subst1 mkProp b, succ i, args else - let args = if Option.is_empty u then mkRel i :: args else args in - mkLambda_or_LetIn (n, u, t) b, succ i, args) + let args = if is_local_assum decl then mkRel i :: args else args in + mkLambda_or_LetIn decl b, succ i, args) (b, 1, []) ctx in ctx, b', Array.of_list args @@ -620,8 +620,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; @@ -642,7 +643,8 @@ let declare_obligation prg obl body ty uctx = else Some (TermObl (it_mkLambda_or_LetIn (mkApp (mkConst constant, args)) ctx)) } -let init_prog_info ?(opaque = false) n b t ctx deps fixkind notations obls impls kind reduce hook = +let init_prog_info ?(opaque = false) sign n pl b t ctx deps fixkind + notations obls impls kind reduce hook = let obls', b = match b with | None -> @@ -662,17 +664,17 @@ let init_prog_info ?(opaque = false) n b t ctx deps fixkind notations obls impls obls, b in { prg_name = n ; prg_body = b; prg_type = reduce t; - prg_ctx = ctx; + prg_ctx = ctx; prg_pl = pl; prg_obligations = (obls', Array.length obls'); prg_deps = deps; prg_fixkind = fixkind ; prg_notations = notations ; prg_implicits = impls; prg_kind = kind; prg_reduce = reduce; - prg_hook = hook; - prg_opaque = opaque; } + prg_hook = hook; prg_opaque = opaque; + prg_sign = sign } 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; + if snd (CEphemeron.get v).prg_obligations > 0 then incr i) m; !i exception Found of program_info @@ -680,7 +682,7 @@ exception Found of program_info let map_first m = try ProgMap.iter (fun _ v -> - if snd (Ephemeron.get v).prg_obligations > 0 then + if snd (CEphemeron.get v).prg_obligations > 0 then raise (Found v)) m; assert(false) with Found x -> x @@ -798,12 +800,12 @@ 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); + 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, Evd.evar_universe_context ctx' + (fst body), entry.const_entry_type, Evd.evar_universe_context ctx' let obligation_terminator name num guard hook pf = let open Proof_global in @@ -815,18 +817,18 @@ let obligation_terminator name num guard hook pf = else let (_, (entry, uctx, _)) = Pfedit.cook_this_proof proof in let env = Global.env () in - let entry = Term_typing.handle_entry_side_effects env entry in + let entry = Safe_typing.inline_private_constants_in_definition_entry env entry in let ty = entry.Entries.const_entry_type in let (body, cstr), eff = Future.force entry.Entries.const_entry_body in - assert(Declareops.side_effects_is_empty eff); + assert(Safe_typing.empty_private_constants = eff); assert(Univ.ContextSet.is_empty cstr); Inductiveops.control_only_guard (Global.env ()) body; (** Declare the obligation ourselves and drop the hook *) let prg = get_info (ProgMap.find name !from_prg) in - let prg = { prg with prg_ctx = uctx } in + let prg = { prg with prg_ctx = fst uctx } in let obls, rem = prg.prg_obligations in let obl = obls.(num) in - let ctx = Evd.evar_context_universe_context uctx in + let ctx = Evd.evar_context_universe_context (fst uctx) in let (_, obl) = declare_obligation prg obl body ty ctx in let obls = Array.copy obls in let _ = obls.(num) <- obl in @@ -852,7 +854,9 @@ let obligation_hook prg obl num auto ctx' _ gr = 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 ())) + let evd = Evd.from_env (Global.env ()) in + let ctx' = Evd.merge_universe_subst evd (Evd.universe_subst (Evd.from_ctx ctx')) in + Evd.evar_universe_context ctx' else ctx' in let prg = { prg with prg_ctx = ctx' } in @@ -883,13 +887,14 @@ let rec solve_obligation prg num tac = 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 evd = Evd.update_sigma_env evd (Global.env ()) in let auto n tac oblset = auto_solve_obligations n ~oblset tac in let terminator guard hook = Proof_global.make_terminator (obligation_terminator prg.prg_name num guard hook) 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 ~terminator hook in + let () = Lemmas.start_proof_univs ~sign:prg.prg_sign obl.obl_name kind evd obl.obl_type ~terminator 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 + let _ = Pfedit.by !default_tactic in Option.iter (fun tac -> Pfedit.set_end_tac tac) tac and obligation (user_num, name, typ) tac = @@ -918,19 +923,23 @@ and solve_obligation_by_tac prg obls i tac = | None -> match obl.obl_tac with | Some t -> t - | None -> snd (get_default_tactic ()) + | None -> !default_tactic in + let evd = Evd.from_ctx !prg.prg_ctx in + let evd = Evd.update_sigma_env evd (Global.env ()) in let t, ty, ctx = solve_by_tac obl.obl_name (evar_of_obligation obl) tac - (pi2 !prg.prg_kind) !prg.prg_ctx + (pi2 !prg.prg_kind) (Evd.evar_universe_context evd) in let uctx = Evd.evar_context_universe_context ctx in 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 + (* Declare the term constraints with the first obligation only *) + let evd = Evd.from_env (Global.env ()) in + let evd = Evd.merge_universe_subst evd (Evd.universe_subst (Evd.from_ctx ctx)) in + let ctx' = Evd.evar_universe_context evd in prg := {!prg with prg_ctx = ctx'}); true else false @@ -996,7 +1005,7 @@ let show_obligations_of_prg ?(msg=true) prg = if !showed > 0 then ( decr showed; msg_info (str "Obligation" ++ spc() ++ int (succ i) ++ spc () ++ - str "of" ++ spc() ++ str (Id.to_string n) ++ str ":" ++ spc () ++ + str "of" ++ spc() ++ Id.print n ++ str ":" ++ spc () ++ hov 1 (Printer.pr_constr_env (Global.env ()) Evd.empty x.obl_type ++ str "." ++ fnl ()))) | Some _ -> ()) @@ -1013,14 +1022,15 @@ let show_obligations ?(msg=true) n = let show_term n = let prg = get_prog_err n in let n = prg.prg_name in - (str (Id.to_string n) ++ spc () ++ str":" ++ spc () ++ + (Id.print n ++ spc () ++ str":" ++ spc () ++ Printer.pr_constr_env (Global.env ()) Evd.empty prg.prg_type ++ spc () ++ str ":=" ++ fnl () ++ Printer.pr_constr_env (Global.env ()) Evd.empty prg.prg_body) -let add_definition n ?term t ctx ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic - ?(reduce=reduce) ?(hook=Lemmas.mk_hook (fun _ _ -> ())) ?(opaque = false) obls = - let info = str (Id.to_string n) ++ str " has type-checked" in - let prg = init_prog_info ~opaque n term t ctx [] None [] obls implicits kind reduce hook in +let add_definition n ?term t ctx ?pl ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic + ?(reduce=reduce) ?(hook=Lemmas.mk_hook (fun _ _ _ -> ())) ?(opaque = false) obls = + let sign = Decls.initialize_named_context_for_proof () in + let info = Id.print n ++ str " has type-checked" in + let prg = init_prog_info sign ~opaque n pl term t ctx [] None [] obls implicits kind reduce hook in let obls,_ = prg.prg_obligations in if Int.equal (Array.length obls) 0 then ( Flags.if_verbose msg_info (info ++ str "."); @@ -1029,20 +1039,21 @@ 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 (Ephemeron.create prg); + progmap_add n (CEphemeron.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 | _ -> res) -let add_mutual_definitions l ctx ?tactic ?(kind=Global,false,Definition) ?(reduce=reduce) - ?(hook=Lemmas.mk_hook (fun _ _ -> ())) ?(opaque = false) notations fixkind = +let add_mutual_definitions l ctx ?pl ?tactic ?(kind=Global,false,Definition) ?(reduce=reduce) + ?(hook=Lemmas.mk_hook (fun _ _ _ -> ())) ?(opaque = false) notations fixkind = + let sign = Decls.initialize_named_context_for_proof () in let deps = List.map (fun (n, b, t, imps, obls) -> n) l in List.iter (fun (n, b, t, imps, obls) -> - let prg = init_prog_info ~opaque n (Some b) t ctx deps (Some fixkind) + let prg = init_prog_info sign ~opaque n pl (Some b) t ctx deps (Some fixkind) notations obls imps kind reduce hook - in progmap_add n (Ephemeron.create prg)) l; + in progmap_add n (CEphemeron.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 40f124ca3..3e99f5760 100644 --- a/toplevel/obligations.mli +++ b/toplevel/obligations.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -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 @@ -54,21 +54,20 @@ type progress = (* Resolution status of a program *) | Remain of int (* n obligations remaining *) | Dependent (* Dependent on other definitions *) | Defined of global_reference (* Defined as id *) - -val set_default_tactic : bool -> Tacexpr.glob_tactic_expr -> unit -val get_default_tactic : unit -> locality_flag * unit Proofview.tactic -val print_default_tactic : unit -> Pp.std_ppcmds + +val default_tactic : unit Proofview.tactic ref val set_proofs_transparency : bool -> unit (* true = All transparent, false = Opaque if possible *) val get_proofs_transparency : unit -> bool val add_definition : Names.Id.t -> ?term:Term.constr -> Term.types -> Evd.evar_universe_context -> + ?pl:(Id.t Loc.located list) -> (* Universe binders *) ?implicits:(Constrexpr.explicitation * (bool * bool * bool)) list -> ?kind:Decl_kinds.definition_kind -> ?tactic:unit Proofview.tactic -> ?reduce:(Term.constr -> Term.constr) -> - ?hook:unit Lemmas.declaration_hook -> ?opaque:bool -> obligation_info -> progress + ?hook:(Evd.evar_universe_context -> unit) Lemmas.declaration_hook -> ?opaque:bool -> obligation_info -> progress type notations = (Vernacexpr.lstring * Constrexpr.constr_expr * Notation_term.scope_name option) list @@ -81,10 +80,11 @@ val add_mutual_definitions : (Names.Id.t * Term.constr * Term.types * (Constrexpr.explicitation * (bool * bool * bool)) list * obligation_info) list -> Evd.evar_universe_context -> + ?pl:(Id.t Loc.located list) -> (* Universe binders *) ?tactic:unit Proofview.tactic -> ?kind:Decl_kinds.definition_kind -> ?reduce:(Term.constr -> Term.constr) -> - ?hook:unit Lemmas.declaration_hook -> ?opaque:bool -> + ?hook:(Evd.evar_universe_context -> unit) Lemmas.declaration_hook -> ?opaque:bool -> notations -> fixpoint_kind -> unit diff --git a/toplevel/record.ml b/toplevel/record.ml index 60fe76bb8..93429da5a 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -13,7 +13,6 @@ open Names open Globnames open Nameops open Term -open Context open Vars open Environ open Declarations @@ -25,6 +24,9 @@ open Type_errors open Constrexpr open Constrexpr_ops open Goptions +open Sigma.Notations +open Context.Rel.Declaration +open Entries (********** definition d'un record (structure) **************) @@ -69,16 +71,19 @@ let interp_fields_evars env evars impls_env nots l = | Anonymous -> impls | Name id -> Id.Map.add id (compute_internalization_data env Constrintern.Method t' impl) impls in - let d = (i,b',t') in + let d = match b' with + | None -> LocalAssum (i,t') + | Some b' -> LocalDef (i,b',t') + in List.iter (Metasyntax.set_notation_for_interpretation impls) no; (push_rel d env, impl :: uimpls, d::params, impls)) (env, [], [], impls_env) nots l let compute_constructor_level evars env l = - List.fold_right (fun (n,b,t as d) (env, univ) -> + List.fold_right (fun d (env, univ) -> let univ = - if b = None then - let s = Retyping.get_sort_of env evars t in + if is_local_assum d then + let s = Retyping.get_sort_of env evars (get_type d) in Univ.sup (univ_of_sort s) univ else univ in (push_rel d env, univ)) @@ -114,16 +119,16 @@ let typecheck_params_and_fields def id pl t ps nots fs = (match kind_of_term sred with | Sort s' -> (match Evd.is_sort_variable !evars s' with - | Some l -> evars := Evd.make_flexible_variable !evars true (* (not def) *) l; + | Some l -> evars := Evd.make_flexible_variable !evars true l; sred, true | None -> s, false) | _ -> user_err_loc (constr_loc t,"", str"Sort expected.")) | None -> - let uvarkind = if (* not def *) true then Evd.univ_flexible_alg else Evd.univ_flexible in - mkSort (Evarutil.evd_comb0 (Evd.new_sort_variable uvarkind) evars), false + let uvarkind = Evd.univ_flexible_alg in + mkSort (Evarutil.evd_comb0 (Evd.new_sort_variable uvarkind) evars), true in let fullarity = it_mkProd_or_LetIn t' newps in - let env_ar = push_rel_context newps (push_rel (Name id,None,fullarity) env0) in + let env_ar = push_rel_context newps (push_rel (LocalAssum (Name id,fullarity)) env0) in let env2,impls,newfs,data = interp_fields_evars env_ar evars impls_env nots (binders_of_decls fs) in @@ -135,33 +140,34 @@ let typecheck_params_and_fields def id pl t ps nots fs = 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 && is_impredicative_set env0) then + if not def && (Sorts.is_prop 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 + if Univ.is_small_univ univ && + Option.cata (Evd.is_flexible_level evars) false (Evd.is_sort_variable evars aritysort) then + (* We can assume that the level in aritysort is not constrained + and clear it, if it is flexible *) + 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 - let newfs = map_rel_context nf newfs in - 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 + let newps = Context.Rel.map nf newps in + let newfs = Context.Rel.map nf newfs in + let ce t = Pretyping.check_evars env0 Evd.empty evars t in + List.iter (iter_constr ce) (List.rev newps); + List.iter (iter_constr ce) (List.rev 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 +let degenerate_decl decl = + let id = match get_name decl 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) + match decl with + | LocalAssum (_,t) -> (id, LocalAssumEntry t) + | LocalDef (_,b,_) -> (id, LocalDefEntry b) type record_error = | MissingProj of Id.t * Id.t list @@ -171,7 +177,7 @@ let warning_or_error coe indsp err = let st = match err with | MissingProj (fi,projs) -> let s,have = if List.length projs > 1 then "s","were" else "","was" in - (str(Id.to_string fi) ++ + (pr_id fi ++ strbrk" cannot be defined because the projection" ++ str s ++ spc () ++ prlist_with_sep pr_comma pr_id projs ++ spc () ++ str have ++ strbrk " not defined.") @@ -244,8 +250,8 @@ let declare_projections indsp ?(kind=StructureComponent) binder_name coers field 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 - let paramargs = Termops.extended_rel_list 1 paramdecls in (*def in [[params;x:rp]]*) + let rp = applist (r, Context.Rel.to_extended_list 0 paramdecls) in + let paramargs = Context.Rel.to_extended_list 1 paramdecls in (*def in [[params;x:rp]]*) let x = Name binder_name in let fields = instantiate_possibly_recursive_type indu paramdecls fields in let lifted_fields = Termops.lift_rel_context 1 fields in @@ -265,23 +271,25 @@ let declare_projections indsp ?(kind=StructureComponent) binder_name coers field in let (_,_,kinds,sp_projs,_) = List.fold_left3 - (fun (nfi,i,kinds,sp_projs,subst) coe (fi,optci,ti) impls -> + (fun (nfi,i,kinds,sp_projs,subst) coe decl impls -> + let fi = get_name decl in + let ti = get_type decl in let (sp_projs,i,subst) = match fi with | Anonymous -> (None::sp_projs,i,NoProjection fi::subst) | Name fid -> try let kn, term = - if optci = None && primitive then + if is_local_assum decl && primitive then (** Already defined in the kernel silently *) let kn = destConstRef (Nametab.locate (Libnames.qualid_of_ident fid)) in Declare.definition_message fid; kn, mkProj (Projection.make kn false,mkRel 1) else let ccl = subst_projection fid subst ti in - let body = match optci with - | Some ci -> subst_projection fid subst ci - | None -> + let body = match decl with + | LocalDef (_,ci,_) -> subst_projection fid subst ci + | LocalAssum _ -> (* [ccl] is defined in context [params;x:rp] *) (* [ccl'] is defined in context [params;x:rp;x:rp] *) let ccl' = liftn 1 2 ccl in @@ -297,7 +305,7 @@ 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; @@ -323,28 +331,32 @@ let declare_projections indsp ?(kind=StructureComponent) binder_name coers field let cl = Class.class_of_global (IndRef indsp) in Class.try_add_new_coercion_with_source refi ~local:false poly ~source:cl end; - let i = if Option.is_empty optci then i+1 else i in + let i = if is_local_assum decl then i+1 else i in (Some kn::sp_projs, i, Projection term::subst) with NotDefinable why -> warning_or_error coe indsp why; (None::sp_projs,i,NoProjection fi::subst) in - (nfi-1,i,(fi, Option.is_empty optci)::kinds,sp_projs,subst)) + (nfi-1,i,(fi, is_local_assum decl)::kinds,sp_projs,subst)) (List.length fields,0,[],[],[]) coers (List.rev fields) (List.rev fieldimpls) in (kinds,sp_projs) let structure_signature ctx = let rec deps_to_evar evm l = match l with [] -> Evd.empty - | [(_,_,typ)] -> + | [decl] -> let env = Environ.empty_named_context_val in - let (evm, _) = Evarutil.new_pure_evar env evm typ in + let evm = Sigma.Unsafe.of_evar_map evm in + let Sigma (_, evm, _) = Evarutil.new_pure_evar env evm (get_type decl) in + let evm = Sigma.to_evar_map evm in evm - | (_,_,typ)::tl -> + | decl::tl -> let env = Environ.empty_named_context_val in - let (evm, ev) = Evarutil.new_pure_evar env evm typ in + let evm = Sigma.Unsafe.of_evar_map evm in + let Sigma (ev, evm, _) = Evarutil.new_pure_evar env evm (get_type decl) in + let evm = Sigma.to_evar_map evm in let new_tl = Util.List.map_i - (fun pos (n,c,t) -> n,c, - Termops.replace_term (mkRel pos) (mkEvar(ev,[||])) t) 1 tl in + (fun pos decl -> + map_type (fun t -> Termops.replace_term (mkRel pos) (mkEvar(ev,[||])) t) decl) 1 tl in deps_to_evar evm new_tl in deps_to_evar Evd.empty (List.rev ctx) @@ -353,7 +365,7 @@ open Typeclasses let declare_structure finite poly ctx id idbuild paramimpls params arity template fieldimpls fields ?(kind=StructureComponent) ?name is_coe coers sign = let nparams = List.length params and nfields = List.length fields in - let args = Termops.extended_rel_list nfields params in + let args = Context.Rel.to_extended_list nfields params in let ind = applist (mkRel (1+nparams+nfields), args) in let type_constructor = it_mkProd_or_LetIn ind fields in let binder_name = @@ -376,7 +388,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 @@ -392,7 +404,7 @@ let implicits_of_context ctx = | Name n -> Some n | Anonymous -> None in ExplByPos (i, explname), (true, true, true)) - 1 (List.rev (Anonymous :: (List.map pi1 ctx))) + 1 (List.rev (Anonymous :: (List.map get_name ctx))) let declare_class finite def poly ctx id idbuild paramimpls params arity template fieldimpls fields ?(kind=StructureComponent) is_coe coers priorities sign = @@ -405,11 +417,11 @@ let declare_class finite def poly ctx id idbuild paramimpls params arity let binder_name = Namegen.next_ident_away (snd id) (Termops.ids_of_context (Global.env())) in let impl, projs = match fields with - | [(Name proj_name, _, field)] when def -> + | [LocalAssum (Name proj_name, field) | LocalDef (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_type = it_mkProd_or_LetIn arity params in let class_entry = - Declare.definition_entry (* ?types:class_type *) ~poly ~univs:ctx class_body in + 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 @@ -446,13 +458,13 @@ let declare_class finite def poly ctx id idbuild paramimpls params arity if b then Backward, pri else Forward, pri) coe) coers priorities in - let l = List.map3 (fun (id, _, _) b y -> (id, b, y)) + let l = List.map3 (fun decl b y -> get_name decl, b, y) (List.rev fields) coers (Recordops.lookup_projections ind) in IndRef ind, l in let ctx_context = - List.map (fun (na, b, t) -> - match Typeclasses.class_of_constr t with + List.map (fun decl -> + match Typeclasses.class_of_constr (get_type decl) with | Some (_, ((cl,_), _)) -> Some (cl.cl_impl, true) | None -> None) params, params @@ -474,7 +486,7 @@ let add_constant_class cst = let tc = { cl_impl = ConstRef cst; cl_context = (List.map (const None) ctx, ctx); - cl_props = [(Anonymous, None, arity)]; + cl_props = [LocalAssum (Anonymous, arity)]; cl_projs = []; cl_strict = !typeclasses_strict; cl_unique = !typeclasses_unique @@ -488,8 +500,8 @@ let add_inductive_class ind = let ctx = oneind.mind_arity_ctxt in let inst = Univ.UContext.instance mind.mind_universes in let map = function - | (_, Some _, _) -> None - | (_, None, t) -> Some (lazy t) + | LocalDef _ -> None + | LocalAssum (_, t) -> Some (lazy t) in let args = List.map_filter map ctx in let ty = Inductive.type_of_inductive_knowing_parameters @@ -499,7 +511,7 @@ let add_inductive_class ind = in { cl_impl = IndRef ind; cl_context = List.map (const None) ctx, ctx; - cl_props = [Anonymous, None, ty]; + cl_props = [LocalAssum (Anonymous, ty)]; cl_projs = []; cl_strict = !typeclasses_strict; cl_unique = !typeclasses_unique } @@ -532,11 +544,11 @@ let definition_structure (kind,poly,finite,(is_coe,((loc,idstruc),pl)),ps,cfs,id 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 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 @@ -549,3 +561,6 @@ let definition_structure (kind,poly,finite,(is_coe,((loc,idstruc),pl)),ps,cfs,id 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 eccb5d29d..26eb3378b 100644 --- a/toplevel/record.mli +++ b/toplevel/record.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,7 +8,6 @@ open Names open Term -open Context open Vernacexpr open Constrexpr open Impargs @@ -22,15 +21,15 @@ val primitive_flag : bool ref val declare_projections : inductive -> ?kind:Decl_kinds.definition_object_kind -> Id.t -> - coercion_flag list -> manual_explicitation list list -> rel_context -> + coercion_flag list -> manual_explicitation list list -> Context.Rel.t -> (Name.t * bool) list * constant option list val declare_structure : Decl_kinds.recursivity_kind -> bool (** polymorphic?*) -> Univ.universe_context -> Id.t -> Id.t -> - manual_explicitation list -> rel_context -> (** params *) constr -> (** arity *) + manual_explicitation list -> Context.Rel.t -> (** params *) constr -> (** arity *) bool (** template arity ? *) -> - Impargs.manual_explicitation list list -> rel_context -> (** fields *) + Impargs.manual_explicitation list list -> Context.Rel.t -> (** fields *) ?kind:Decl_kinds.definition_object_kind -> ?name:Id.t -> bool -> (** coercion? *) bool list -> (** field coercions *) diff --git a/toplevel/search.ml b/toplevel/search.ml index 9c32bddad..646e2e08a 100644 --- a/toplevel/search.ml +++ b/toplevel/search.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -67,7 +67,9 @@ let iter_constructors indsp u fn env nconstr = fn (ConstructRef (indsp, i)) env typ done -let iter_named_context_name_type f = List.iter (fun (nme,_,typ) -> f nme typ) +let iter_named_context_name_type f = + let open Context.Named.Declaration in + List.iter (fun decl -> f (get_id decl) (get_type decl)) (* General search over hypothesis of a goal *) let iter_hypothesis glnum (fn : global_reference -> env -> constr -> unit) = @@ -79,12 +81,13 @@ let iter_hypothesis glnum (fn : global_reference -> env -> constr -> unit) = (* General search over declarations *) let iter_declarations (fn : global_reference -> env -> constr -> unit) = + let open Context.Named.Declaration in let env = Global.env () in let iter_obj (sp, kn) lobj = match object_tag lobj with | "VARIABLE" -> begin try - let (id, _, typ) = Global.lookup_named (basename sp) in - fn (VarRef id) env typ + let decl = Global.lookup_named (basename sp) in + fn (VarRef (get_id decl)) env (get_type decl) with Not_found -> (* we are in a section *) () end | "CONSTANT" -> let cst = Global.constant_of_delta_kn kn in diff --git a/toplevel/search.mli b/toplevel/search.mli index f69489c3d..78b0c45c0 100644 --- a/toplevel/search.mli +++ b/toplevel/search.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/toplevel/usage.ml b/toplevel/usage.ml index 292136406..f855c096e 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -73,6 +73,9 @@ let print_usage_channel co command = \n -impredicative-set set sort Set impredicative\ \n -indices-matter levels of indices (and nonuniform parameters) contribute to the level of inductives\ \n -type-in-type disable universe consistency checking\ +\n -xml export XML files either to the hierarchy rooted in\ +\n the directory $COQ_XML_LIBRARY_ROOT (if set) or to\ +\n stdout (if unset)\ \n -time display the time taken by each command\ \n -m, --memory display total heap size at program exit\ \n (use environment variable\ diff --git a/toplevel/usage.mli b/toplevel/usage.mli index ed0cd477c..3ce9e93ee 100644 --- a/toplevel/usage.mli +++ b/toplevel/usage.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index a0cd618e9..89bc31d0a 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -27,9 +27,9 @@ let rec is_navigation_vernac = function | VernacBacktrack _ | VernacBackTo _ | VernacBack _ -> true - | VernacRedirect (_, l) | VernacTime l -> - List.exists - (fun (_,c) -> is_navigation_vernac c) l (* Time Back* is harmless *) + | VernacRedirect (_, (_,c)) + | VernacTime (_,c) -> + is_navigation_vernac c (* Time Back* is harmless *) | c -> is_deep_navigation_vernac c and is_deep_navigation_vernac = function @@ -150,7 +150,6 @@ let pr_new_syntax loc ocom = if !beautify_file then set_formatter_translator(); let fs = States.freeze ~marshallable:`No in let com = match ocom with - | Some VernacNop -> mt() | Some com -> Ppvernac.pr_vernac com | None -> mt() in if !beautify_file then @@ -229,7 +228,7 @@ let rec vernac_com verbose checknav (loc,com) = checknav loc com; if do_beautify () then pr_new_syntax loc (Some com); if !Flags.time then display_cmd_header loc com; - let com = if !Flags.time then VernacTime [loc,com] else com in + let com = if !Flags.time then VernacTime (loc,com) else com in interp com with reraise -> let (reraise, info) = Errors.push reraise in @@ -277,6 +276,10 @@ let checknav loc ast = let eval_expr loc_ast = vernac_com (Flags.is_verbose()) checknav loc_ast +(* XML output hooks *) +let (f_xml_start_library, xml_start_library) = Hook.make ~default:ignore () +let (f_xml_end_library, xml_end_library) = Hook.make ~default:ignore () + (* Load a vernac file. Errors are annotated with file and location *) let load_vernac verb file = chan_beautify := @@ -311,6 +314,7 @@ let compile verbosely f = Aux_file.start_aux_file_for long_f_dot_v; Dumpglob.start_dump_glob long_f_dot_v; Dumpglob.dump_string ("F" ^ Names.DirPath.to_string ldir ^ "\n"); + if !Flags.xml_export then Hook.get f_xml_start_library (); let wall_clock1 = Unix.gettimeofday () in let _ = load_vernac verbosely long_f_dot_v in Stm.join (); @@ -320,6 +324,7 @@ let compile verbosely f = Aux_file.record_in_aux_at Loc.ghost "vo_compile_time" (Printf.sprintf "%.3f" (wall_clock2 -. wall_clock1)); Aux_file.stop_aux_file (); + if !Flags.xml_export then Hook.get f_xml_end_library (); Dumpglob.end_dump_glob () | BuildVio -> let long_f_dot_v = ensure_v f in diff --git a/toplevel/vernac.mli b/toplevel/vernac.mli index affc21713..008d7a31a 100644 --- a/toplevel/vernac.mli +++ b/toplevel/vernac.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -23,6 +23,10 @@ val just_parsing : bool ref val eval_expr : Loc.t * Vernacexpr.vernac_expr -> unit +(** Set XML hooks *) +val xml_start_library : (unit -> unit) Hook.t +val xml_end_library : (unit -> unit) Hook.t + (** Load a vernac file, verbosely or not. Errors are annotated with file and location *) diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 85d342bc4..bdd52d5be 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -20,7 +20,6 @@ open Tacmach open Constrintern open Prettyp open Printer -open Tacinterp open Command open Goptions open Libnames @@ -32,6 +31,10 @@ open Redexpr open Lemmas open Misctypes open Locality +open Sigma.Notations + +(** TODO: make this function independent of Ltac *) +let (f_interp_redexp, interp_redexp_hook) = Hook.make () let debug = false let prerr_endline = @@ -156,7 +159,7 @@ let show_match id = (* "Print" commands *) let print_path_entry p = - let dir = str (DirPath.to_string (Loadpath.logical p)) in + let dir = pr_dirpath (Loadpath.logical p) in let path = str (Loadpath.physical p) in (dir ++ str " " ++ tbrk (0, 0) ++ path) @@ -333,7 +336,7 @@ let dump_universes_gen g s = | Univ.Eq -> Printf.fprintf output " \"%s\" -> \"%s\" [style=dashed];\n" left right end, begin fun () -> - if Lazy.lazy_is_val init then Printf.fprintf output "}\n"; + if Lazy.is_val init then Printf.fprintf output "}\n"; close_out output end end else begin @@ -355,11 +358,6 @@ let dump_universes_gen g s = close (); iraise reraise -let dump_universes sorted s = - let g = Global.universes () in - let g = if sorted then UGraph.sort_universes g else g in - dump_universes_gen g s - (*********************) (* "Locate" commands *) @@ -475,7 +473,7 @@ let vernac_definition locality p (local,k) ((loc,id as lid),pl) def = | None -> None | Some r -> let (evc,env)= get_current_context () in - Some (snd (interp_redexp env evc r)) in + Some (snd (Hook.get f_interp_redexp env evc r)) in do_definition id (local,p,k) pl bl red_option c typ_opt hook) let vernac_start_proof locality p kind l lettop = @@ -552,12 +550,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" @@ -602,8 +600,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 *) @@ -819,35 +828,6 @@ let vernac_declare_class id = let command_focus = Proof.new_focus_kind () let focus_command_cond = Proof.no_cond command_focus - -let print_info_trace = ref None - -let _ = let open Goptions in declare_int_option { - optsync = true; - optdepr = false; - optname = "print info trace"; - optkey = ["Info" ; "Level"]; - optread = (fun () -> !print_info_trace); - optwrite = fun n -> print_info_trace := n; -} - -let vernac_solve n info tcom b = - if not (refining ()) then - error "Unknown command of the non proof-editing mode."; - let status = Proof_global.with_current_proof (fun etac p -> - let with_end_tac = if b then Some etac else None in - let global = match n with SelectAll -> true | _ -> false in - let info = Option.append info !print_info_trace in - let (p,status) = - solve n info (Tacinterp.hide_interp global tcom None) ?with_end_tac p - in - (* in case a strict subtree was completed, - go back to the top of the prooftree *) - let p = Proof.maximal_unfocus command_focus p in - p,status) in - if not status then Pp.feedback Feedback.AddedAxiom - - (* A command which should be a tactic. It has been added by Christine to patch an error in the design of the proof machine, and enables to instantiate existential variables when @@ -865,20 +845,25 @@ let vernac_set_end_tac tac = (* TO DO verifier s'il faut pas mettre exist s | TacId s ici*) let vernac_set_used_variables e = + let open Context.Named.Declaration in let env = Global.env () in let tys = List.map snd (Proof.initial_goals (Proof_global.give_me_the_proof ())) in let l = Proof_using.process_expr env e tys in let vars = Environ.named_context env in List.iter (fun id -> - if not (List.exists (fun (id',_,_) -> Id.equal id id') vars) then + if not (List.exists (Id.equal id % get_id) vars) then errorlabstrm "vernac_set_used_variables" (str "Unknown variable: " ++ pr_id id)) l; let _, to_clear = set_used_variables l in - vernac_solve - SelectAll None Tacexpr.(TacAtom (Loc.ghost,TacClear(false,to_clear))) false - + let to_clear = List.map snd to_clear in + Proof_global.with_current_proof begin fun _ p -> + if List.is_empty to_clear then (p, ()) + else + let tac = Proofview.V82.tactic (Tactics.clear to_clear) in + fst (solve SelectAll None tac p), () + end (*****************************) (* Auxiliary file management *) @@ -929,85 +914,6 @@ let vernac_restore_state file = (************) (* Commands *) -type tacdef_kind = - | NewTac of Id.t - | UpdateTac of Nametab.ltac_constant - -let is_defined_tac kn = - try ignore (Tacenv.interp_ltac kn); true with Not_found -> false - -let make_absolute_name ident repl = - let loc = loc_of_reference ident in - if repl then - let kn = - try Nametab.locate_tactic (snd (qualid_of_reference ident)) - with Not_found -> - Errors.user_err_loc (loc, "", - str "There is no Ltac named " ++ pr_reference ident ++ str ".") - in - UpdateTac kn - else - let id = Constrexpr_ops.coerce_reference_to_id ident in - let kn = Lib.make_kn id in - let () = if is_defined_tac kn then - Errors.user_err_loc (loc, "", - str "There is already an Ltac named " ++ pr_reference ident ++ str".") - in - let is_primitive = - try - match Pcoq.parse_string Pcoq.Tactic.tactic (Id.to_string id) with - | Tacexpr.TacArg _ -> false - | _ -> true (* most probably TacAtom, i.e. a primitive tactic ident *) - with e when Errors.noncritical e -> true (* prim tactics with args, e.g. "apply" *) - in - let () = if is_primitive then - msg_warning (str "The Ltac name " ++ pr_reference ident ++ - str " may be unusable because of a conflict with a notation.") - in - NewTac id - -let register_ltac local isrec tacl = - let map (ident, repl, body) = - let name = make_absolute_name ident repl in - (name, body) - in - let rfun = List.map map tacl in - let recvars = - let fold accu (op, _) = match op with - | UpdateTac _ -> accu - | NewTac id -> (Lib.make_path id, Lib.make_kn id) :: accu - in - if isrec then List.fold_left fold [] rfun - else [] - in - let ist = Tacintern.make_empty_glob_sign () in - let map (name, body) = - let body = Flags.with_option Tacintern.strict_check (Tacintern.intern_tactic_or_tacarg ist) body in - (name, body) - in - let defs () = - (** Register locally the tactic to handle recursivity. This function affects - the whole environment, so that we transactify it afterwards. *) - let iter_rec (sp, kn) = Nametab.push_tactic (Nametab.Until 1) sp kn in - let () = List.iter iter_rec recvars in - List.map map rfun - in - let defs = Future.transactify defs () in - let iter (def, tac) = match def with - | NewTac id -> - Tacenv.register_ltac false local id tac; - Flags.if_verbose msg_info (Nameops.pr_id id ++ str " is defined") - | UpdateTac kn -> - Tacenv.redefine_ltac local kn tac; - let name = Nametab.shortest_qualid_of_tactic kn in - Flags.if_verbose msg_info (Libnames.pr_qualid name ++ str " is redefined") - in - List.iter iter defs - -let vernac_declare_tactic_definition locality (x,def) = - let local = make_module_locality locality in - register_ltac local x def - let vernac_create_hintdb locality id b = let local = make_module_locality locality in Hints.create_hint_db local id full_transparent_state b @@ -1424,18 +1330,6 @@ let _ = 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) - -let _ = - declare_bool_option - { optsync = false; - optdepr = false; - optname = "Ltac debug"; - optkey = ["Ltac";"Debug"]; - optread = (fun () -> get_debug () != Tactic_debug.DebugOff); - optwrite = vernac_debug } - let _ = declare_bool_option { optsync = true; @@ -1516,7 +1410,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 = @@ -1531,16 +1425,20 @@ 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 - let redfun env evm c = snd (fst (reduction_of_red_expr env r_interp) env evm c) in + let (sigma',r_interp) = Hook.get f_interp_redexp env sigma' r in + let redfun env evm c = + let (redfun, _) = reduction_of_red_expr env r_interp in + let evm = Sigma.Unsafe.of_evar_map evm in + let Sigma (c, _, _) = redfun.Reductionops.e_redfun env evm c in + c + in msg_notice (print_eval redfun env sigma' rc j) let vernac_declare_reduction locality s r = let local = make_locality locality in - declare_red_expr local s (snd (interp_redexp (Global.env()) Evd.empty r)) + declare_red_expr local s (snd (Hook.get f_interp_redexp (Global.env()) Evd.empty r)) (* The same but avoiding the current goal context if any *) let vernac_global_check c = @@ -1566,6 +1464,7 @@ exception NoHyp We only print the type and a small statement to this comes from the goal. Precondition: there must be at least one current goal. *) let print_about_hyp_globs ref_or_by_not glnumopt = + let open Context.Named.Declaration in try let gl,id = match glnumopt,ref_or_by_not with @@ -1578,11 +1477,11 @@ let print_about_hyp_globs ref_or_by_not glnumopt = (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 - let natureofid = match bdyopt with - | None -> "Hypothesis" - | Some bdy ->"Constant (let in)" in - v 0 (str (Id.to_string id) ++ str":" ++ pr_constr typ ++ fnl() ++ fnl() + let decl = Context.Named.lookup id hyps in + let natureofid = match decl with + | LocalAssum _ -> "Hypothesis" + | LocalDef (_,bdy,_) ->"Constant (let in)" in + v 0 (pr_id id ++ str":" ++ pr_constr (get_type decl) ++ fnl() ++ fnl() ++ str natureofid ++ str " of the goal context.") with (* fallback to globals *) | NoHyp | Not_found -> print_about ref_or_by_not @@ -1607,24 +1506,24 @@ let vernac_print = function | PrintClasses -> msg_notice (Prettyp.print_classes()) | PrintTypeClasses -> msg_notice (Prettyp.print_typeclasses()) | PrintInstances c -> msg_notice (Prettyp.print_instances (smart_global c)) - | PrintLtac qid -> msg_notice (Tacintern.print_ltac (snd (qualid_of_reference qid))) | PrintCoercions -> msg_notice (Prettyp.print_coercions()) | PrintCoercionPaths (cls,clt) -> msg_notice (Prettyp.print_path_between (cl_of_qualid cls) (cl_of_qualid clt)) | PrintCanonicalConversions -> msg_notice (Prettyp.print_canonical_projections ()) - | PrintUniverses (b, None) -> + | PrintUniverses (b, dst) -> let univ = Global.universes () in let univ = if b then UGraph.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 (UGraph.pr_universes Universes.pr_with_global_universes univ ++ pr_remaining) - | PrintUniverses (b, Some s) -> dump_universes b s + begin match dst with + | None -> msg_notice (UGraph.pr_universes Universes.pr_with_global_universes univ ++ pr_remaining) + | Some s -> dump_universes_gen univ s + end | PrintHint r -> msg_notice (Hints.pr_hint_ref (smart_global r)) | PrintHintGoal -> msg_notice (Hints.pr_applicable_hint ()) | PrintHintDbName s -> msg_notice (Hints.pr_hint_db_by_name s) - | PrintRewriteHintDbName s -> msg_notice (Autorewrite.print_rewrite_hintdb s) | PrintHintDb -> msg_notice (Hints.pr_searchtable ()) | PrintScopes -> msg_notice (Notation.pr_scopes (Constrextern.without_symbols pr_lglob_constr)) @@ -1775,6 +1674,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 -> @@ -1845,8 +1745,6 @@ let interp ?proof ~loc locality poly c = | VernacError e -> raise e (* Syntax *) - | VernacTacticNotation (n,r,e) -> - Metasyntax.add_tactic_notation (make_module_locality locality,n,r,e) | VernacSyntaxExtension (local,sl) -> vernac_syntax_extension locality local sl | VernacDelimiters (sc,lr) -> vernac_delimiters sc lr @@ -1870,8 +1768,8 @@ let interp ?proof ~loc 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) -> @@ -1904,7 +1802,6 @@ let interp ?proof ~loc locality poly c = | VernacDeclareClass id -> vernac_declare_class id (* Solving *) - | VernacSolve (n,info,tac,b) -> vernac_solve n info tac b | VernacSolveExistential (n,c) -> vernac_solve_existential n c (* Auxiliary file and library management *) @@ -1925,8 +1822,6 @@ let interp ?proof ~loc locality poly c = | VernacBackTo _ -> anomaly (str "VernacBackTo not handled by Stm") (* Commands *) - | VernacDeclareTacticDefinition def -> - vernac_declare_tactic_definition locality def | VernacCreateHintDb (dbname,b) -> vernac_create_hintdb locality dbname b | VernacRemoveHints (dbnames,ids) -> vernac_remove_hints locality dbnames ids | VernacHints (local,dbnames,hints) -> @@ -1955,7 +1850,6 @@ let interp ?proof ~loc locality poly c = | VernacLocate l -> vernac_locate l | VernacRegister (id, r) -> vernac_register id r | VernacComments l -> if_verbose msg_info (str "Comments ok\n") - | VernacNop -> () (* The STM should handle that, but LOAD bypasses the STM... *) | VernacAbort id -> msg_warning (str "VernacAbort not handled by Stm") @@ -2003,15 +1897,13 @@ let check_vernac_supports_locality c l = match l, c with | None, _ -> () | Some _, ( - VernacTacticNotation _ - | VernacOpenCloseScope _ + VernacOpenCloseScope _ | VernacSyntaxExtension _ | VernacInfix _ | VernacNotation _ | VernacDefinition _ | VernacFixpoint _ | VernacCoFixpoint _ | VernacAssumption _ | VernacStartTheoremProof _ | VernacCoercion _ | VernacIdentityCoercion _ | VernacInstance _ | VernacDeclareInstances _ | VernacDeclareMLModule _ - | VernacDeclareTacticDefinition _ | VernacCreateHintDb _ | VernacRemoveHints _ | VernacHints _ | VernacSyntacticDefinition _ | VernacArgumentsScope _ | VernacDeclareImplicits _ | VernacArguments _ @@ -2034,12 +1926,12 @@ 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 | None -> Flags.is_universe_polymorphism () - | Some b -> b + | Some b -> Flags.make_polymorphic_flag b; b (** A global default timeout, controled by option "Set Default Timeout n". Use "Unset Default Timeout" to deactivate it (or set it to 0). *) @@ -2123,11 +2015,11 @@ 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 -> + | VernacRedirect (s, (_,v)) -> + Pp.with_output_to_file s (aux false) v + | VernacTime (_,v) -> System.with_time !Flags.time - (aux_list ?locality ?polymorphism isprogcmd) v; + (aux ?locality ?polymorphism isprogcmd) v; | VernacLoad (_,fname) -> vernac_load (aux false) fname | c -> check_vernac_supports_locality c locality; @@ -2140,7 +2032,8 @@ let interp ?(verbosely=true) ?proof (loc,c) = 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 + Flags.program_mode := orig_program_mode; + ignore (Flags.use_polymorphic_flag ()) end with | reraise when @@ -2152,9 +2045,8 @@ let interp ?(verbosely=true) ?proof (loc,c) = let e = locate_if_not_already loc e in let () = restore_timeout () in Flags.program_mode := orig_program_mode; + ignore (Flags.use_polymorphic_flag ()); iraise e - and aux_list ?locality ?polymorphism isprogcmd l = - List.iter (aux false) (List.map snd l) in if verbosely then Flags.verbosely (aux false) c else aux false c diff --git a/toplevel/vernacentries.mli b/toplevel/vernacentries.mli index c6d87596d..4e7fa4a08 100644 --- a/toplevel/vernacentries.mli +++ b/toplevel/vernacentries.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -59,3 +59,8 @@ val vernac_end_proof : ?proof:Proof_global.closed_proof -> Vernacexpr.proof_end -> unit val with_fail : bool -> (unit -> unit) -> unit + +val command_focus : unit Proof.focus_kind + +val interp_redexp_hook : (Environ.env -> Evd.evar_map -> Tacexpr.raw_red_expr -> + Evd.evar_map * Redexpr.red_expr) Hook.t diff --git a/toplevel/vernacinterp.ml b/toplevel/vernacinterp.ml index d3e48f756..7fbd2b119 100644 --- a/toplevel/vernacinterp.ml +++ b/toplevel/vernacinterp.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/toplevel/vernacinterp.mli b/toplevel/vernacinterp.mli index 028206546..5149b5416 100644 --- a/toplevel/vernacinterp.mli +++ b/toplevel/vernacinterp.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) |