Commit upstream/8.4_gamma0+really8.4beta2+dfsg - coq

+3

-0

.gitignore less more

78	78	doc/stdlib/Library.pdf
79	79	doc/stdlib/Library.ps
80	80	doc/stdlib/Library.coqdoc.tex
	81	doc/stdlib/FullLibrary.pdf
	82	doc/stdlib/FullLibrary.ps
	83	doc/stdlib/FullLibrary.coqdoc.tex
81	84	doc/stdlib/html/
82	85	doc/stdlib/index-body.html
83	86	doc/stdlib/index-list.html

+54

-2

CHANGES less more

0		Changes from V8.3 to V8.4
1		=========================
	0	Changes from V8.4beta to V8.4
	1	=============================
	2
	3	Vernacular commands
	4
	5	- Undo and UndoTo are now handling the proof states. They may
	6	perform some extra steps of backtrack to avoid states where
	7	the proof state is unavailable (typically a closed proof).
	8	- The commands Suspend and Resume have been removed.
	9	- A basic Show Script has been reintroduced (no indentation).
	10	- New command "Set Parsing Explicit" for deactivating parsing (and printing)
	11	of implicit arguments (useful for teaching).
	12	- New command "Grab Existential Variables" to transform the unresolved evars at
	13	the end of a proof into goals.
	14
	15	Tactics
	16
	17	- Still no general "info" tactical, but new specific tactics
	18	info_auto, info_eauto, info_trivial which provides information
	19	on the proofs found by auto/eauto/trivial. Display of these
	20	details could also be activated by Set Info Auto/Eauto/Trivial.
	21	- Details on everything tried by auto/eauto/trivial during
	22	a proof search could be obtained by "debug auto", "debug eauto",
	23	"debug trivial" or by a global "Set Debug Auto/Eauto/Trivial".
	24	- New command "r string" that interprets "idtac string" as a breakpoint
	25	and jumps to its next use in Ltac debugger.
	26	- Tactics from the Dp plugin (simplify, ergo, yices, cvc3, z3, cvcl,
	27	harvey, zenon, gwhy) have been removed, since Why2 has not been
	28	maintained for the last few years. The Why3 plugin should be a suitable
	29	replacement in most cases.
	30
	31	Libraries
	32
	33	- MSetRBT : a new implementation of MSets via Red-Black trees (initial
	34	contribution by Andrew Appel).
	35	- MSetAVL : for maximal sharing with the new MSetRBT, the argument order
	36	of Node has changed (this should be transparent to regular MSets users).
	37
	38	Module System
	39
	40	- The names of modules (and module types) are now in a fully separated
	41	namespace from ordinary definitions : "Definition E:=0. Module E. End E."
	42	is now accepted.
	43
	44	CoqIDE
	45
	46	- Coqide now supports the Restart command, and Undo (with a warning).
	47	Better support for Abort.
	48
	49	Changes from V8.3 to V8.4beta
	50	=============================
2	51
3	52	Logic
4	53

68	117	- When applying destruct or inversion on a fixpoint hiding an inductive
69	118	type, recursive calls to the fixpoint now remain folded by default (rare
70	119	source of incompatibility generally solvable by adding a call to simpl).
	120	- The behavior of the simpl tactic can be tuned using the new "Arguments"
	121	vernacular.
71	122
72	123	Vernacular commands
73	124

89	140	to avoid conversion at Qed time to go into a very long computation.
90	141	- New command "Show Goal ident" to display the statement of a goal, even
91	142	a closed one (available from Proof General).
	143	- New command "Arguments" subsuming "Implicit Arguments" and "Arguments Scope".
92	144
93	145	Module System
94	146

+1

-1

COPYRIGHT less more

0	0	The Coq proof assistant
1	1
2		Copyright 1999-2010 The Coq development team, INRIA, CNRS, University
	2	Copyright 1999-2012 The Coq development team, INRIA, CNRS, University
3	3	Paris Sud, University Paris 7, Ecole Polytechnique.
4	4
5	5	This product includes also software developed by

+8

-2

CREDITS less more

105	105	of the Coq Proof assistant during the indicated time:
106	106
107	107	Bruno Barras (INRIA, 1995-now)
	108	Pierre Boutillier (INRIA-PPS, 2010-now)
108	109	Jacek Chrzaszcz (LRI, 1998-2003)
109	110	Thierry Coquand (INRIA, 1985-1989)
110	111	Pierre Corbineau (LRI, 2003-2005, Nijmegen, 2005-2008, Grenoble 1, 2008-now)

117	118	Amy Felty (INRIA, 1993)
118	119	Jean-Christophe Filliâtre (ENS Lyon, 1994-1997, LRI, 1997-now)
119	120	Eduardo Giménez (ENS Lyon, 1993-1996, INRIA, 1997-1998)
	121	Stéphane Glondu (INRIA-PPS, 2007-now)
120	122	Benjamin Grégoire (INRIA, 2003-now)
121	123	Hugo Herbelin (INRIA, 1996-now)
122	124	Gérard Huet (INRIA, 1985-1997)
123		Pierre Letouzey (LRI, 2000-2004 & PPS, 2005-now)
	125	Pierre Letouzey (LRI, 2000-2004, PPS, 2005-2008, INRIA-PPS, 2009-now)
	126	Patrick Loiseleur (Paris Sud, 1997-1999)
124	127	Evgeny Makarov (INRIA, 2007)
125	128	Pascal Manoury (INRIA, 1993)
126	129	Micaela Mayero (INRIA, 1997-2002)

131	134	Julien Narboux (INRIA, 2005-2006, Strasbourg, 2007-now)
132	135	Jean-Marc Notin (CNRS, 2006-now)
133	136	Catherine Parent-Vigouroux (ENS Lyon, 1992-1995)
134		Patrick Loiseleur (Paris Sud, 1997-1999)
135	137	Christine Paulin-Mohring (INRIA, 1985-1989, ENS Lyon, 1989-1997,
136	138	LRI, 1997-now)
	139	Pierre-Marie Pédrot (INRIA-PPS, 2011-now)
	140	Matthias Puech (INRIA-Bologna, 2008-now)
	141	Yann Régis-Gianas (INRIA-PPS, 2009-now)
137	142	Clément Renard (INRIA, 2001-2004)
138	143	Claudio Sacerdoti Coen (INRIA, 2004-2005)
139	144	Amokrane Saïbi (INRIA, 1993-1998)

141	146	Élie Soubiran (INRIA, 2007-now)
142	147	Matthieu Sozeau (INRIA, 2005-now)
143	148	Arnaud Spiwack (INRIA, 2006-now)
	149	Enrico Tassi (INRIA, 2011-now)
144	150	Benjamin Werner (INRIA, 1989-1994)
145	151
146	152	***************************************************************************

+4

-4

INSTALL less more

38	38
39	39	urpmi coq
40	40
41		Should you need or prefer to compile Coq V8.2 yourself, you need:
42
43		- Objective Caml version 3.10.0 or later
	41	Should you need or prefer to compile Coq V8.4 yourself, you need:
	42
	43	- Objective Caml version 3.11.2 or later
44	44	(available at http://caml.inria.fr/)
45	45
46	46	- Camlp5 (version <= 4.08, or 5.* transitional)

86	86	INSTALLATION PROCEDURE IN DETAILS (NORMAL USERS).
87	87	=================================================
88	88
89		1- Check that you have the Objective Caml compiler version 3.10.0 (or later)
	89	1- Check that you have the Objective Caml compiler version 3.11.2 (or later)
90	90	installed on your computer and that "ocamlmktop" and "ocamlc" (or
91	91	its native code version "ocamlc.opt") lie in a directory which is present
92	92	in your $PATH environment variable.

+1

-1

Makefile less more

190	190	rm -f doc/common/version.tex
191	191	rm -f doc/refman/styles.hva doc/refman/cover.html doc/refman/Reference-Manual.html
192	192	rm -f doc/coq.tex
	193	rm -f doc/refman/styles.hva doc/refman/cover.html
193	194
194	195	archclean: clean-ide optclean voclean
195	196	rm -rf _build myocamlbuild_config.ml

220	221	rm -f config/Makefile config/coq_config.ml dev/ocamldebug-v7 ide/undo.mli
221	222
222	223	distclean: clean cleanconfig
223		$(MAKE) -C test-suite distclean
224	224
225	225	voclean:
226	226	rm -f states/*.coq

+8

-6

Makefile.build less more

317	317	$(STRIP) $@
318	318
319	319	$(COQIDEBYTE): $(LINKIDE) \| $(COQTOPBYTE)
320		$(SHOW)'OCAMLOPT -o $@'
	320	$(SHOW)'OCAMLC -o $@'
321	321	$(HIDE)$(OCAMLC) $(COQIDEFLAGS) $(BYTEFLAGS) -o $@ unix.cma threads.cma lablgtk.cma gtkThread.cmo\
322	322	str.cma $(COQRUNBYTEFLAGS) $(LINKIDE)
323	323

445	445	# 3) plugins
446	446	###########################################################################
447	447
448		.PHONY: plugins omega micromega ring setoid_ring nsatz dp xml extraction
	448	.PHONY: plugins omega micromega ring setoid_ring nsatz xml extraction
449	449	.PHONY: field fourier funind cc subtac rtauto pluginsopt
450	450
451	451	plugins: $(PLUGINSVO)

454	454	ring: $(RINGVO) $(RINGCMA)
455	455	setoid_ring: $(NEWRINGVO) $(NEWRINGCMA)
456	456	nsatz: $(NSATZVO) $(NSATZCMA)
457		dp: $(DPCMA)
458	457	xml: $(XMLVO) $(XMLCMA)
459	458	extraction: $(EXTRACTIONCMA)
460	459	field: $(FIELDVO) $(FIELDCMA)

622	621
623	622	install-library:
624	623	$(MKDIR) $(FULLCOQLIB)
625		$(INSTALLSH) $(FULLCOQLIB) $(LIBFILES) $(PLUGINS) $(PLUGINSOPT)
	624	$(INSTALLSH) $(FULLCOQLIB) $(LIBFILES) $(PLUGINS)
626	625	$(MKDIR) $(FULLCOQLIB)/states
627	626	$(INSTALLLIB) states/*.coq $(FULLCOQLIB)/states
628	627	$(MKDIR) $(FULLCOQLIB)/user-contrib

631	630	$(INSTALLSH) $(FULLCOQLIB) $(INSTALLCMI)
632	631	ifeq ($(BEST),opt)
633	632	$(INSTALLLIB) $(LIBCOQRUN) $(FULLCOQLIB)
634		$(INSTALLSH) $(FULLCOQLIB) $(CONFIG:.cmo=.cmx) $(CONFIG:.cmo=.o) $(LINKCMO:.cma=.cmxa) $(LINKCMO:.cma=.a)
	633	$(INSTALLSH) $(FULLCOQLIB) $(CONFIG:.cmo=.cmx) $(CONFIG:.cmo=.o) $(LINKCMO:.cma=.cmxa) $(LINKCMO:.cma=.a) $(PLUGINSOPT)
635	634	endif
636	635	# csdpcert is not meant to be directly called by the user; we install
637	636	# it with libraries

642	641
643	642	install-library-light:
644	643	$(MKDIR) $(FULLCOQLIB)
645		$(INSTALLSH) $(FULLCOQLIB) $(LIBFILESLIGHT) $(INITPLUGINS) $(INITPLUGINSOPT)
	644	$(INSTALLSH) $(FULLCOQLIB) $(LIBFILESLIGHT) $(INITPLUGINS)
646	645	$(MKDIR) $(FULLCOQLIB)/states
647	646	$(INSTALLLIB) states/*.coq $(FULLCOQLIB)/states
648	647	rm -f $(FULLCOQLIB)/revision
649	648	-$(INSTALLLIB) revision $(FULLCOQLIB)
	649	ifeq ($(BEST),opt)
	650	$(INSTALLSH) $(FULLCOQLIB) $(INITPLUGINSOPT)
	651	endif
650	652
651	653	install-coq-info: install-coq-manpages install-emacs install-latex
652	654

+7

-10

Makefile.common less more

78	78	pretyping interp toplevel/utils toplevel parsing \
79	79	ide/utils ide \
80	80	$(addprefix plugins/, \
81		omega romega micromega quote ring dp \
	81	omega romega micromega quote ring \
82	82	setoid_ring xml extraction fourier \
83	83	cc funind firstorder field subtac \
84	84	rtauto nsatz syntax decl_mode)

124	124	RefMan-cic.v.tex RefMan-lib.v.tex \
125	125	RefMan-tacex.v.tex RefMan-syn.v.tex \
126	126	RefMan-oth.v.tex RefMan-ltac.v.tex \
127		RefMan-decl.v.tex \
	127	RefMan-decl.v.tex RefMan-sch.v.tex \
	128	RefMan-pro.v.tex \
128	129	Cases.v.tex Coercion.v.tex Extraction.v.tex \
129	130	Program.v.tex Omega.v.tex Micromega.v.tex Polynom.v.tex Nsatz.v.tex \
130	131	Setoid.v.tex Helm.tex Classes.v.tex )
131	132
132	133	REFMANTEXFILES:=$(addprefix doc/refman/, \
133	134	headers.sty Reference-Manual.tex \
134		RefMan-pre.tex RefMan-int.tex RefMan-pro.tex RefMan-com.tex \
	135	RefMan-pre.tex RefMan-int.tex RefMan-com.tex \
135	136	RefMan-uti.tex RefMan-ide.tex RefMan-add.tex RefMan-modr.tex ) \
136	137	$(REFMANCOQTEXFILES) \
137	138

175	176	RINGCMA:=plugins/ring/ring_plugin.cma
176	177	NEWRINGCMA:=plugins/setoid_ring/newring_plugin.cma
177	178	NSATZCMA:=plugins/nsatz/nsatz_plugin.cma
178		DPCMA:=plugins/dp/dp_plugin.cma
179	179	FIELDCMA:=plugins/field/field_plugin.cma
180	180	XMLCMA:=plugins/xml/xml_plugin.cma
181	181	FOURIERCMA:=plugins/fourier/fourier_plugin.cma

195	195	DECLMODECMA:=plugins/decl_mode/decl_mode_plugin.cma
196	196
197	197	PLUGINSCMA:=$(OMEGACMA) $(ROMEGACMA) $(MICROMEGACMA) $(DECLMODECMA) \
198		$(QUOTECMA) $(RINGCMA) $(NEWRINGCMA) $(DPCMA) $(FIELDCMA) \
	198	$(QUOTECMA) $(RINGCMA) $(NEWRINGCMA) $(FIELDCMA) \
199	199	$(FOURIERCMA) $(EXTRACTIONCMA) $(XMLCMA) \
200	200	$(CCCMA) $(FOCMA) $(SUBTACCMA) $(RTAUTOCMA) \
201	201	$(FUNINDCMA) $(NSATZCMA) $(NATSYNTAXCMA) $(OTHERSYNTAXCMA)
202	202
203	203	ifneq ($(HASNATDYNLINK),false)
204	204	STATICPLUGINS:=
205		INITPLUGINS:=$(EXTRACTIONCMA) $(FOCMA) $(CCCMA) $(DPCMA) \
	205	INITPLUGINS:=$(EXTRACTIONCMA) $(FOCMA) $(CCCMA) \
206	206	$(XMLCMA) $(FUNINDCMA) $(SUBTACCMA) $(NATSYNTAXCMA)
207	207	INITPLUGINSOPT:=$(INITPLUGINS:.cma=.cmxs)
208	208	PLUGINS:=$(PLUGINSCMA)

313	313	NSATZVO:=$(call cat_vo_itarget, plugins/nsatz)
314	314	FOURIERVO:=$(call cat_vo_itarget, plugins/fourier)
315	315	FUNINDVO:=$(call cat_vo_itarget, plugins/funind)
316		DPVO:=$(call cat_vo_itarget, plugins/dp)
317	316	RTAUTOVO:=$(call cat_vo_itarget, plugins/rtauto)
318	317	EXTRACTIONVO:=$(call cat_vo_itarget, plugins/extraction)
319	318	XMLVO:=

321	320
322	321	PLUGINSVO:= $(OMEGAVO) $(ROMEGAVO) $(MICROMEGAVO) $(RINGVO) $(FIELDVO) \
323	322	$(XMLVO) $(FOURIERVO) $(CCVO) $(FUNINDVO) \
324		$(RTAUTOVO) $(NEWRINGVO) $(DPVO) $(QUOTEVO) \
	323	$(RTAUTOVO) $(NEWRINGVO) $(QUOTEVO) \
325	324	$(NSATZVO) $(EXTRACTIONVO)
326	325
327	326	ALLVO:= $(THEORIESVO) $(PLUGINSVO)

346	345	man/coqwc.1 man/coqdoc.1 man/coqide.1 \
347	346	man/coq_makefile.1 man/coqmktop.1 man/coqchk.1
348	347
349		DATE=$(shell LANG=C date +"%B %Y")
350
351	348	###########################################################################
352	349	# Source documentation
353	350	###########################################################################

+21

-27

Makefile.doc less more

11	11	######################################################################
12	12
13	13	.PHONY: doc doc-html doc-pdf doc-ps refman refman-quick tutorial
14		.PHONY: stdlib full-stdlib faq rectutorial
	14	.PHONY: stdlib full-stdlib faq rectutorial refman-html-dir
15	15
16	16	INDEXURLS:=doc/refman/html/index_urls.txt
17	17

125	125	INDEXES:= doc/refman/html/command-index.html doc/refman/html/tactic-index.html
126	126	ALLINDEXES:= doc/refman/html/index.html $(INDEXES)
127	127
128		$(ALLINDEXES): doc/refman/Reference-Manual.html $(REFMANPNGFILES) \
	128	$(ALLINDEXES): refman-html-dir
	129
	130	refman-html-dir: doc/refman/Reference-Manual.html $(REFMANPNGFILES) \
129	131	doc/refman/cover.html doc/refman/styles.hva doc/refman/index.html
130	132	- rm -rf doc/refman/html
131	133	$(MKDIR) doc/refman/html
132	134	$(INSTALLLIB) $(REFMANPNGFILES) doc/refman/html
133	135	(cd doc/refman/html; hacha -nolinks -tocbis -o toc.html ../styles.hva ../Reference-Manual.html)
134	136	$(INSTALLLIB) doc/refman/cover.html doc/refman/html/index.html
135		$(INSTALLLIB) doc/common/styles/html/$(HTMLSTYLE)/*.css doc/refman/html
	137	-$(INSTALLLIB) doc/common/styles/html/$(HTMLSTYLE)/*.css doc/refman/html
136	138
137	139	refman-quick:
138	140	(cd doc/refman;\

199	201	### Standard library (browsable html format)
200	202
201	203	ifdef QUICK
202		doc/stdlib/index-body.html:
	204	doc/stdlib/html/genindex.html:
	205	else
	206	doc/stdlib/html/genindex.html: \| $(COQDOC) $(THEORIESVO)
	207	endif
203	208	- rm -rf doc/stdlib/html
204	209	$(MKDIR) doc/stdlib/html
205		$(COQDOC) -q -boot -d doc/stdlib/html --multi-index --html -g --utf8 \
	210	$(COQDOC) -q -d doc/stdlib/html --with-header doc/common/styles/html/$(HTMLSTYLE)/header.html --with-footer doc/common/styles/html/$(HTMLSTYLE)/footer.html --multi-index --html -g \
206	211	-R theories Coq $(THEORIESVO:.vo=.v)
207		mv doc/stdlib/html/index.html doc/stdlib/index-body.html
208		else
209		doc/stdlib/index-body.html: $(COQDOC) $(THEORIESVO)
210		- rm -rf doc/stdlib/html
211		$(MKDIR) doc/stdlib/html
212		$(COQDOC) -q -boot -d doc/stdlib/html --multi-index --html -g --utf8 \
213		-R theories Coq $(THEORIESVO:.vo=.v)
214		mv doc/stdlib/html/index.html doc/stdlib/index-body.html
215		endif
	212	mv doc/stdlib/html/index.html doc/stdlib/html/genindex.html
216	213
217	214	doc/stdlib/index-list.html: doc/stdlib/index-list.html.template doc/stdlib/make-library-index
218		./doc/stdlib/make-library-index doc/stdlib/index-list.html
219
220		doc/stdlib/html/index.html: doc/stdlib/index-list.html doc/stdlib/index-body.html doc/stdlib/index-trailer.html
221		cat doc/stdlib/index-list.html > $@
222		sed -n -e '/<table>/,/<\/table>/p' doc/stdlib/index-body.html >> $@
223		cat doc/stdlib/index-trailer.html >> $@
	215	./doc/stdlib/make-library-index doc/stdlib/index-list.html doc/stdlib/hidden-files
	216
	217	doc/stdlib/html/index.html: doc/stdlib/html/genindex.html doc/stdlib/index-list.html
	218	cat doc/common/styles/html/$(HTMLSTYLE)/header.html doc/stdlib/index-list.html > $@
	219	cat doc/common/styles/html/$(HTMLSTYLE)/footer.html >> $@
224	220
225	221	### Standard library (light version, full version is definitely too big)
226	222
227	223	ifdef QUICK
228	224	doc/stdlib/Library.coqdoc.tex:
229		$(COQDOC) -q -boot --gallina --body-only --latex --stdout --utf8 \
230		-R theories Coq $(THEORIESLIGHTVO:.vo=.v) > $@
231	225	else
232		doc/stdlib/Library.coqdoc.tex: $(COQDOC) $(THEORIESLIGHTVO)
233		$(COQDOC) -q -boot --gallina --body-only --latex --stdout --utf8 \
234		-R theories Coq $(THEORIESLIGHTVO:.vo=.v) > $@
	226	doc/stdlib/Library.coqdoc.tex: \| $(COQDOC) $(THEORIESLIGHTVO)
235	227	endif
	228	$(COQDOC) -q -boot --gallina --body-only --latex --stdout \
	229	-R theories Coq $(THEORIESLIGHTVO:.vo=.v) >> $@
236	230
237	231	doc/stdlib/Library.dvi: $(DOCCOMMON) doc/stdlib/Library.coqdoc.tex doc/stdlib/Library.tex
238	232	(cd doc/stdlib;\

254	248	doc/stdlib/FullLibrary.coqdoc.tex:
255	249	$(COQDOC) -q -boot --gallina --body-only --latex --stdout --utf8 \
256	250	-R theories Coq $(THEORIESVO:.vo=.v) > $@
257		sed -i "" -e 's///g' $@
	251	sed -i.tmp -e 's///g' $@ && rm $@.tmp
258	252	else
259	253	doc/stdlib/FullLibrary.coqdoc.tex: $(COQDOC) $(THEORIESVO)
260	254	$(COQDOC) -q -boot --gallina --body-only --latex --stdout --utf8 \
261	255	-R theories Coq $(THEORIESVO:.vo=.v) > $@
262		sed -i "" -e 's///g' $@
	256	sed -i.tmp -e 's///g' $@ && rm $@.tmp
263	257	endif
264	258
265	259	doc/stdlib/FullLibrary.dvi: $(DOCCOMMON) doc/stdlib/FullLibrary.coqdoc.tex doc/stdlib/FullLibrary.tex

+3

-3

README less more

37	37	discuss questions about the Coq system and related topics. The submission
38	38	address is:
39	39
40		coq-club@coq.inria.fr
	40	coq-club@inria.fr
41	41
42	42	The topics to be discussed in the club should include:
43	43

54	54
55	55	To be added to, or removed from, the mailing list, please write to:
56	56
57		coq-club-request@coq.inria.fr
	57	coq-club-request@inria.fr
58	58
59	59	Please use also this address for any questions/suggestions about the
60	60	Coq Club. It might sometimes take a few days before your messages get

66	66
67	67	Send your bug reports by filling a form at
68	68
69		http://logical.saclay.inria.fr/coq-bugs
	69	http://coq.inria.fr/bugs
70	70
71	71	To be effective, bug reports should mention the Caml version used
72	72	to compile and run Coq, the Coq version (coqtop -v), the configuration

+0

-53

~~TODO~~ less more

0		Langage:
1
2		Distribution:
3
4		Environnement:
5
6		- Porter SearchIsos
7
8		Noyau:
9
10		Tactic:
11
12		- Que contradiction raisonne a isomorphisme pres de False
13
14		Vernac:
15
16		- Print / Print Proof en fait identiques ; Print ne devrait pas afficher
17		les constantes opaques (devrait afficher qqchose comme <opaque>)
18
19		Theories:
20
21		- Rendre transparent tous les theoremes prouvant {A}+{B}
22		- Faire demarrer PolyList.nth a` l'indice 0
23		Renommer l'actuel nth en nth1 ??
24
25		Doc:
26
27		- Mettre à jour les messages d'erreurs de Discriminate/Simplify_eq/Injection
28		- Documenter le filtrage sur les types inductifs avec let-ins (dont la
29		compatibilite V6)
30
31		- Ajouter let dans les règles du CIC
32		-> FAIT, mais reste a documenter le let dans les inductifs
33		et les champs manifestes dans les Record
34		- revoir le chapitre sur les tactiques utilisateur
35		- faut-il mieux spécifier la sémantique de Simpl (??)
36
37		- Préciser la clarification syntaxique de IntroPattern
38		- preciser que Goal vient en dernier dans une clause pattern list et
39		qu'il doit apparaitre si il y a un "in"
40
41		- Omega Time debranche mais Omega System et Omega Action remarchent ?
42		- Ajout "Replace in" (mais TODO)
43		- Syntaxe Conditional tac Rewrite marche, à documenter
44		- Documenter Dependent Rewrite et CutRewrite ?
45		- Ajouter les motifs sous-termes de ltac
46
47		- ajouter doc de GenFixpoint (mais avant: changer syntaxe) (J. Forest ou Pierre C.)
48		- mettre à jour la doc de induction (arguments multiples) (Pierre C.)
49		- mettre à jour la doc de functional induction/scheme (J. Forest ou Pierre C.)
50		--> mettre à jour le CHANGES (vers la ligne 72)
51
52

+28

-46

checker/mod_checking.ml less more

52	52	\| SEBident mp -> mp
53	53	\| _ -> raise Not_path
54	54
55		let rec list_split_assoc k rev_before = function
	55	let is_modular = function
	56	\| SFBmodule _ \| SFBmodtype _ -> true
	57	\| SFBconst _ \| SFBmind _ -> false
	58
	59	let rec list_split_assoc ((k,m) as km) rev_before = function
56	60	\| [] -> raise Not_found
57		\| (k',b)::after when k=k' -> rev_before,b,after
58		\| h::tail -> list_split_assoc k (h::rev_before) tail
	61	\| (k',b)::after when k=k' && is_modular b = m -> rev_before,b,after
	62	\| h::tail -> list_split_assoc km (h::rev_before) tail
59	63
60	64	let check_definition_sub env cb1 cb2 =
61	65	let check_type env t1 t2 =

130	134
131	135	let rec check_with env mtb with_decl mp=
132	136	match with_decl with
133		\| With_definition_body _ ->
134		check_with_aux_def env mtb with_decl mp;
	137	\| With_definition_body (idl,c) ->
	138	check_with_def env mtb (idl,c) mp;
135	139	mtb
136		\| With_module_body _ ->
137		check_with_aux_mod env mtb with_decl mp;
	140	\| With_module_body (idl,mp1) ->
	141	check_with_mod env mtb (idl,mp1) mp;
138	142	mtb
139	143
140		and check_with_aux_def env mtb with_decl mp =
	144	and check_with_def env mtb (idl,c) mp =
141	145	let sig_b = match mtb with
142	146	\| SEBstruct(sig_b) ->
143	147	sig_b
144	148	\| _ -> error_signature_expected mtb
145	149	in
146		let id,idl = match with_decl with
147		\| With_definition_body (id::idl,_) \| With_module_body (id::idl,_) ->
148		id,idl
149		\| With_definition_body ([],_) \| With_module_body ([],_) -> assert false
	150	let id,idl = match idl with
	151	\| [] -> assert false
	152	\| id::idl -> id,idl
150	153	in
151	154	let l = label_of_id id in
152	155	try
153		let rev_before,spec,after = list_split_assoc l [] sig_b in
	156	let rev_before,spec,after = list_split_assoc (l,(idl<>[])) [] sig_b in
154	157	let before = List.rev rev_before in
155	158	let env' = Modops.add_signature mp before empty_delta_resolver env in
156		match with_decl with
157		\| With_definition_body ([],_) -> assert false
158		\| With_definition_body ([id],c) ->
	159	if idl = [] then
159	160	let cb = match spec with
160	161	SFBconst cb -> cb
161	162	\| _ -> error_not_a_constant l
162	163	in
163	164	check_definition_sub env' c cb
164		\| With_definition_body (_::_,_) ->
	165	else
165	166	let old = match spec with
166	167	SFBmodule msb -> msb
167	168	\| _ -> error_not_a_module l

169	170	begin
170	171	match old.mod_expr with
171	172	\| None ->
172		let new_with_decl = match with_decl with
173		With_definition_body (_,c) ->
174		With_definition_body (idl,c)
175		\| With_module_body (_,c) ->
176		With_module_body (idl,c) in
177		check_with_aux_def env' old.mod_type new_with_decl (MPdot(mp,l))
	173	check_with_def env' old.mod_type (idl,c) (MPdot(mp,l))
178	174	\| Some msb ->
179	175	error_a_generative_module_expected l
180	176	end
181		\| _ -> anomaly "Modtyping:incorrect use of with"
182	177	with
183	178	Not_found -> error_no_such_label l
184	179	\| Reduction.NotConvertible -> error_with_incorrect l
185	180
186		and check_with_aux_mod env mtb with_decl mp =
	181	and check_with_mod env mtb (idl,mp1) mp =
187	182	let sig_b =
188	183	match mtb with
189	184	\| SEBstruct(sig_b) ->
190	185	sig_b
191	186	\| _ -> error_signature_expected mtb in
192		let id,idl = match with_decl with
193		\| With_definition_body (id::idl,_) \| With_module_body (id::idl,_) ->
194		id,idl
195		\| With_definition_body ([],_) \| With_module_body ([],_) -> assert false
	187	let id,idl = match idl with
	188	\| [] -> assert false
	189	\| id::idl -> id,idl
196	190	in
197	191	let l = label_of_id id in
198	192	try
199		let rev_before,spec,after = list_split_assoc l [] sig_b in
	193	let rev_before,spec,after = list_split_assoc (l,false) [] sig_b in
200	194	let before = List.rev rev_before in
201		let rec mp_rec = function
202		\| [] -> mp
203		\| i::r -> MPdot(mp_rec r,label_of_id i)
204		in
205	195	let env' = Modops.add_signature mp before empty_delta_resolver env in
206		match with_decl with
207		\| With_module_body ([],_) -> assert false
208		\| With_module_body ([id], mp1) ->
	196	if idl = [] then
209	197	let _ = match spec with
210	198	SFBmodule msb -> msb
211	199	\| _ -> error_not_a_module l
212	200	in
213	201	let (_:module_body) = (lookup_module mp1 env) in ()
214		\| With_module_body (_::_,mp) ->
	202	else
215	203	let old = match spec with
216	204	SFBmodule msb -> msb
217	205	\| _ -> error_not_a_module l

219	207	begin
220	208	match old.mod_expr with
221	209	None ->
222		let new_with_decl = match with_decl with
223		With_definition_body (_,c) ->
224		With_definition_body (idl,c)
225		\| With_module_body (_,c) ->
226		With_module_body (idl,c) in
227		check_with_aux_mod env'
228		old.mod_type new_with_decl (MPdot(mp,l))
	210	check_with_mod env'
	211	old.mod_type (idl,mp1) (MPdot(mp,l))
229	212	\| Some msb ->
230	213	error_a_generative_module_expected l
231	214	end
232		\| _ -> anomaly "Modtyping:incorrect use of with"
233	215	with
234	216	Not_found -> error_no_such_label l
235	217	\| Reduction.NotConvertible -> error_with_incorrect l

+37

-29

checker/subtyping.ml less more

27	27	\| Constant of constant_body
28	28	\| IndType of inductive * mutual_inductive_body
29	29	\| IndConstr of constructor * mutual_inductive_body
	30
	31	type namedmodule =
30	32	\| Module of module_body
31	33	\| Modtype of module_type_body
32	34
33	35	(* adds above information about one mutual inductive: all types and
34	36	constructors *)
35	37
36		let add_nameobjects_of_mib ln mib map =
37		let add_nameobjects_of_one j oib map =
38		let ip = (ln,j) in
	38	let add_mib_nameobjects mp l mib map =
	39	let ind = make_mind mp empty_dirpath l in
	40	let add_mip_nameobjects j oib map =
	41	let ip = (ind,j) in
39	42	let map =
40	43	array_fold_right_i
41	44	(fun i id map ->

45	48	in
46	49	Labmap.add (label_of_id oib.mind_typename) (IndType (ip, mib)) map
47	50	in
48		array_fold_right_i add_nameobjects_of_one mib.mind_packets map
49
50
51		(* creates namedobject map for the whole signature *)
52
53		let make_label_map mp list =
	51	array_fold_right_i add_mip_nameobjects mib.mind_packets map
	52
	53
	54	(* creates (namedobject/namedmodule) map for the whole signature *)
	55
	56	type labmap = { objs : namedobject Labmap.t; mods : namedmodule Labmap.t }
	57
	58	let empty_labmap = { objs = Labmap.empty; mods = Labmap.empty }
	59
	60	let get_obj mp map l =
	61	try Labmap.find l map.objs
	62	with Not_found -> error_no_such_label_sub l mp
	63
	64	let get_mod mp map l =
	65	try Labmap.find l map.mods
	66	with Not_found -> error_no_such_label_sub l mp
	67
	68	let make_labmap mp list =
54	69	let add_one (l,e) map =
55		let add_map obj = Labmap.add l obj map in
56	70	match e with
57		\| SFBconst cb -> add_map (Constant cb)
58		\| SFBmind mib ->
59		add_nameobjects_of_mib (make_mind mp empty_dirpath l) mib map
60		\| SFBmodule mb -> add_map (Module mb)
61		\| SFBmodtype mtb -> add_map (Modtype mtb)
62		in
63		List.fold_right add_one list Labmap.empty
	71	\| SFBconst cb -> { map with objs = Labmap.add l (Constant cb) map.objs }
	72	\| SFBmind mib -> { map with objs = add_mib_nameobjects mp l mib map.objs }
	73	\| SFBmodule mb -> { map with mods = Labmap.add l (Module mb) map.mods }
	74	\| SFBmodtype mtb -> { map with mods = Labmap.add l (Modtype mtb) map.mods }
	75	in
	76	List.fold_right add_one list empty_labmap
64	77
65	78
66	79	let check_conv_error error f env a1 a2 =

281	294	let ty1 = type_of_constructor cstr (mind1,mind1.mind_packets.(i)) in
282	295	let ty2 = Typeops.type_of_constant_type env cb2.const_type in
283	296	check_conv conv env ty1 ty2
284		\| _ -> error ()
285	297
286	298	let rec check_modules env msb1 msb2 subst1 subst2 =
287	299	let mty1 = module_type_of_module None msb1 in

290	302
291	303
292	304	and check_signatures env mp1 sig1 sig2 subst1 subst2 =
293		let map1 = make_label_map mp1 sig1 in
	305	let map1 = make_labmap mp1 sig1 in
294	306	let check_one_body (l,spec2) =
295		let info1 =
296		try
297		Labmap.find l map1
298		with
299		Not_found -> error_no_such_label_sub l mp1
300		in
301	307	match spec2 with
302	308	\| SFBconst cb2 ->
303		check_constant env mp1 l info1 cb2 spec2 subst1 subst2
	309	check_constant env mp1 l (get_obj mp1 map1 l)
	310	cb2 spec2 subst1 subst2
304	311	\| SFBmind mib2 ->
305		check_inductive env mp1 l info1 mib2 spec2 subst1 subst2
	312	check_inductive env mp1 l (get_obj mp1 map1 l)
	313	mib2 spec2 subst1 subst2
306	314	\| SFBmodule msb2 ->
307	315	begin
308		match info1 with
	316	match get_mod mp1 map1 l with
309	317	\| Module msb -> check_modules env msb msb2
310	318	subst1 subst2
311	319	\| _ -> error_not_match l spec2
312	320	end
313	321	\| SFBmodtype mtb2 ->
314	322	let mtb1 =
315		match info1 with
	323	match get_mod mp1 map1 l with
316	324	\| Modtype mtb -> mtb
317	325	\| _ -> error_not_match l spec2
318	326	in

+17

-12

configure less more

5	5	#
6	6	##################################
7	7
8		VERSION=8.4beta
	8	VERSION=8.4beta2
9	9	VOMAGIC=08400
10	10	STATEMAGIC=58400
11		DATE="December 2011"
	11	DATE=`LC_ALL=C LANG=C date +"%B %Y"`
12	12
13	13	# Create the bin/ directory if non-existent
14	14	test -d bin \|\| mkdir bin

291	291	"") echo "I can't find the program \"date\" in your path."
292	292	echo "Please give me the current date"
293	293	read COMPILEDATE;;
294		*) COMPILEDATE=`date +"%h %d %Y %H:%M:%S"`;;
	294	*) COMPILEDATE=`LC_ALL=C LANG=C date +"%h %d %Y %H:%M:%S"`;;
295	295	esac
296	296
297	297	# Architecture

387	387
388	388	if [ "$browser_spec" = "no" ]; then
389	389	case $ARCH in
390		win32) BROWSER='C:\PROGRA~1\INTERN~1\IEXPLORE %s' ;;
	390	win32) BROWSER='start %s' ;;
391	391	Darwin) BROWSER='open %s' ;;
392	392	*) BROWSER='firefox -remote "OpenURL(%s,new-tab)" \|\| firefox %s &' ;;
393	393	esac

444	444	CAMLVERSION=`"$bytecamlc" -version`
445	445
446	446	case $CAMLVERSION in
447		1.\|2.\|3.0*)
	447	1.\|2.\|3.0\|3.10\|3.11.[01])
448	448	echo "Your version of Objective-Caml is $CAMLVERSION."
449	449	if [ "$force_caml_version" = "yes" ]; then
450	450	echo "Warning You are compiling Coq with an outdated version of Objective-Caml."
451	451	else
452		echo " You need Objective-Caml 3.10.0 or later."
	452	echo " You need Objective-Caml 3.11.2 or later."
453	453	echo " Configuration script failed!"
454	454	exit 1
455	455	fi;;
456		3.1*)
	456	3.11.2\|3.12*)
457	457	CAMLP4COMPAT="-loc loc"
458	458	echo "You have Objective-Caml $CAMLVERSION. Good!";;
459	459	*)

741	741	bindir_def=${W32PREF}bin
742	742	libdir_def=${W32PREF}lib
743	743	configdir_def=${W32PREF}config
744		datadir_def=${W32PREF}data
	744	datadir_def=${W32PREF}share
745	745	mandir_def=${W32PREF}man
746	746	docdir_def=${W32PREF}doc
747	747	emacslib_def=${W32PREF}emacs

794	794	*) LIBDIR_OPTION="None";;
795	795	esac
796	796
797		case $configdir_spec/$local in
798		yes/*) CONFIGDIR=$configdir;;
799		*/true) CONFIGDIR=$COQTOP/ide
800		configdir_spec=yes;;
	797	case $configdir_spec/$prefix_spec/$local in
	798	yes//) CONFIGDIR=$configdir;;
	799	/yes/) configdir_spec=yes
	800	case $ARCH in
	801	win32) CONFIGDIR=$prefix/config;;
	802	*) CONFIGDIR=$prefix/etc/xdg/coq;;
	803	esac;;
	804	//true) CONFIGDIR=$COQTOP/ide
	805	configdir_spec=yes;;
801	806	*) printf "Where should I install the Coqide configuration files [$configdir_def]? "
802	807	read CONFIGDIR
803	808	case $CONFIGDIR in

+5

-1

dev/base_include less more

122	122	open Auto
123	123	open Autorewrite
124	124	open Contradiction
125		open Dhyp
126	125	open Eauto
127	126	open Elim
128	127	open Equality

198	197	let pf_e gl s =
199	198	Constrintern.interp_constr (project gl) (pf_env gl) (parse_constr s);;
200	199
	200	(* Set usual printing since the global env is available from the tracer *)
	201	let _ = Constrextern.in_debugger := false
	202	let _ = Constrextern.set_debug_global_reference_printer
	203	(fun loc r -> Libnames.Qualid (loc,Nametab.shortest_qualid_of_global Idset.empty r));;
	204
201	205	open Toplevel
202	206	let go = loop
203	207

+1

-1

dev/printers.mllib less more

104	104	Dumpglob
105	105	Reserve
106	106	Impargs
107		Constrextern
108	107	Syntax_def
109	108	Implicit_quantifiers
110	109	Smartlocate
111	110	Constrintern
112	111	Modintern
	112	Constrextern
113	113	Tacexpr
114	114	Proof_type
115	115	Goal

+4

-0

dev/top_printers.ml less more

486	486	[id_of_label (pi3 (repr_mind kn));id_of_string ("_"^string_of_int i)]
487	487	(id_of_string ("_"^string_of_int j))
488	488
	489	(* Anticipate that printers can be used from ocamldebug and that
	490	pretty-printer should not make calls to the global env since ocamldebug
	491	runs in a different process and does not have the proper env at hand *)
	492	let _ = Constrextern.in_debugger := true
489	493	let _ = Constrextern.set_debug_global_reference_printer
490	494	(if !rawdebug then raw_string_of_ref else short_string_of_ref)

+45

-0

doc/common/styles/html/coqremote/footer.html less more

	0	<div id="sidebarWrapper">
	1	<div id="sidebar">
	2
	3	<div class="block">
	4	<h2 class="title">Navigation</h2>
	5	<div class="content">
	6
	7	<ul class="menu">
	8
	9	<li class="leaf">Standard Library
	10	<ul class="menu">
	11	<li><a href="index.html">Table of contents</a></li>
	12	<li><a href="genindex.html">Index</a></li>
	13	</ul>
	14	</li>
	15
	16	</ul>
	17
	18	</div>
	19	</div>
	20
	21	</div>
	22	</div>
	23
	24
	25	</div>
	26
	27	</div>
	28
	29	<div id="footer">
	30	<div id="nav-footer">
	31	<ul class="links-menu-footer">
	32	<li><a href="mailto:webmaster_@_www.lix.polytechnique.fr">webmaster</a></li>
	33	<li><a href="http://validator.w3.org/check?uri=referer">xhtml valid</a></li>
	34	<li><a href="http://jigsaw.w3.org/css-validator/check/referer">CSS valid</a></li>
	35	</ul>
	36
	37	</div>
	38	</div>
	39
	40	</div>
	41
	42	</body>
	43	</html>
	44

+49

-0

doc/common/styles/html/coqremote/header.html less more

	0	<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
	1	<html xmlns="http://www.w3.org/1999/xhtml" lang="en" xml:lang="en">
	2
	3	<head>
	4	<meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1">
	5	<title>Standard Library \| The Coq Proof Assistant</title>
	6
	7	<link rel="shortcut icon" href="favicon.ico" type="image/x-icon" />
	8	<style type="text/css" media="all">@import "http://www.lix.polytechnique.fr/coq/modules/node/node.css";</style>
	9
	10	<style type="text/css" media="all">@import "http://www.lix.polytechnique.fr/coq/modules/system/defaults.css";</style>
	11	<style type="text/css" media="all">@import "http://www.lix.polytechnique.fr/coq/modules/system/system.css";</style>
	12	<style type="text/css" media="all">@import "http://www.lix.polytechnique.fr/coq/modules/user/user.css";</style>
	13
	14	<style type="text/css" media="all">@import "http://www.lix.polytechnique.fr/coq/sites/all/themes/coq/style.css";</style>
	15	<style type="text/css" media="all">@import "http://www.lix.polytechnique.fr/coq/sites/all/themes/coq/coqdoc.css";</style>
	16
	17	</head>
	18
	19	<body>
	20
	21	<div id="container">
	22	<div id="headertop">
	23	<div id="nav">
	24	<ul class="links-menu">
	25	<li><a href="http://www.lix.polytechnique.fr/coq/" class="active">Home</a></li>
	26
	27	<li><a href="http://www.lix.polytechnique.fr/coq/about-coq" title="More about coq">About Coq</a></li>
	28	<li><a href="http://www.lix.polytechnique.fr/coq/download">Get Coq</a></li>
	29	<li><a href="http://www.lix.polytechnique.fr/coq/documentation">Documentation</a></li>
	30	<li><a href="http://www.lix.polytechnique.fr/coq/community">Community</a></li>
	31	</ul>
	32	</div>
	33	</div>
	34
	35	<div id="header">
	36
	37	<div id="logoWrapper">
	38
	39	<div id="logo"><a href="http://www.lix.polytechnique.fr/coq/" title="Home"><img src="http://www.lix.polytechnique.fr/coq/files/barron_logo.png" alt="Home" /></a>
	40	</div>
	41	<div id="siteName"><a href="http://www.lix.polytechnique.fr/coq/" title="Home">The Coq Proof Assistant</a>
	42	</div>
	43
	44	</div>
	45	</div>
	46
	47	<div id="content">
	48

+2

-0

doc/common/styles/html/simple/footer.html less more

	0	</body>
	1	</html>

+13

-0

doc/common/styles/html/simple/header.html less more

	0	<!DOCTYPE html
	1	PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
	2	"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
	3
	4	<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
	5	<head>
	6	<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-15"/>
	7	<link rel="stylesheet" href="coqdoc.css" type="text/css"/>
	8	<title>The Coq Standard Library</title>
	9	</head>
	10
	11	<body>
	12

+418

-0

doc/refman/RefMan-sch.tex less more

	0	\chapter{Proof schemes}
	1
	2	\section{Generation of induction principles with {\tt Scheme}}
	3	\label{Scheme}
	4	\index{Schemes}
	5	\comindex{Scheme}
	6
	7	The {\tt Scheme} command is a high-level tool for generating
	8	automatically (possibly mutual) induction principles for given types
	9	and sorts. Its syntax follows the schema:
	10	\begin{quote}
	11	{\tt Scheme {\ident$_1$} := Induction for \ident'$_1$ Sort {\sort$_1$} \\
	12	with\\
	13	\mbox{}\hspace{0.1cm} \dots\\
	14	with {\ident$_m$} := Induction for {\ident'$_m$} Sort
	15	{\sort$_m$}}
	16	\end{quote}
	17	where \ident'$_1$ \dots\ \ident'$_m$ are different inductive type
	18	identifiers belonging to the same package of mutual inductive
	19	definitions. This command generates {\ident$_1$}\dots{} {\ident$_m$}
	20	to be mutually recursive definitions. Each term {\ident$_i$} proves a
	21	general principle of mutual induction for objects in type {\term$_i$}.
	22
	23	\begin{Variants}
	24	\item {\tt Scheme {\ident$_1$} := Minimality for \ident'$_1$ Sort {\sort$_1$} \\
	25	with\\
	26	\mbox{}\hspace{0.1cm} \dots\ \\
	27	with {\ident$_m$} := Minimality for {\ident'$_m$} Sort
	28	{\sort$_m$}}
	29
	30	Same as before but defines a non-dependent elimination principle more
	31	natural in case of inductively defined relations.
	32
	33	\item {\tt Scheme Equality for \ident$_1$\comindex{Scheme Equality}}
	34
	35	Tries to generate a boolean equality and a proof of the
	36	decidability of the usual equality. If \ident$_i$ involves
	37	some other inductive types, their equality has to be defined first.
	38
	39	\item {\tt Scheme Induction for \ident$_1$ Sort {\sort$_1$} \\
	40	with\\
	41	\mbox{}\hspace{0.1cm} \dots\\
	42	with Induction for {\ident$_m$} Sort
	43	{\sort$_m$}}
	44
	45	If you do not provide the name of the schemes, they will be automatically
	46	computed from the sorts involved (works also with Minimality).
	47
	48	\end{Variants}
	49	\label{Scheme-examples}
	50
	51	\firstexample
	52	\example{Induction scheme for \texttt{tree} and \texttt{forest}}
	53
	54	The definition of principle of mutual induction for {\tt tree} and
	55	{\tt forest} over the sort {\tt Set} is defined by the command:
	56
	57	\begin{coq_eval}
	58	Reset Initial.
	59	Variables A B : Set.
	60	\end{coq_eval}
	61
	62	\begin{coq_example*}
	63	Inductive tree : Set :=
	64	node : A -> forest -> tree
	65	with forest : Set :=
	66	\| leaf : B -> forest
	67	\| cons : tree -> forest -> forest.
	68
	69	Scheme tree_forest_rec := Induction for tree Sort Set
	70	with forest_tree_rec := Induction for forest Sort Set.
	71	\end{coq_example*}
	72
	73	You may now look at the type of {\tt tree\_forest\_rec}:
	74
	75	\begin{coq_example}
	76	Check tree_forest_rec.
	77	\end{coq_example}
	78
	79	This principle involves two different predicates for {\tt trees} and
	80	{\tt forests}; it also has three premises each one corresponding to a
	81	constructor of one of the inductive definitions.
	82
	83	The principle {\tt forest\_tree\_rec} shares exactly the same
	84	premises, only the conclusion now refers to the property of forests.
	85
	86	\begin{coq_example}
	87	Check forest_tree_rec.
	88	\end{coq_example}
	89
	90	\example{Predicates {\tt odd} and {\tt even} on naturals}
	91
	92	Let {\tt odd} and {\tt even} be inductively defined as:
	93
	94	% Reset Initial.
	95	\begin{coq_eval}
	96	Open Scope nat_scope.
	97	\end{coq_eval}
	98
	99	\begin{coq_example*}
	100	Inductive odd : nat -> Prop :=
	101	oddS : forall n:nat, even n -> odd (S n)
	102	with even : nat -> Prop :=
	103	\| evenO : even 0
	104	\| evenS : forall n:nat, odd n -> even (S n).
	105	\end{coq_example*}
	106
	107	The following command generates a powerful elimination
	108	principle:
	109
	110	\begin{coq_example}
	111	Scheme odd_even := Minimality for odd Sort Prop
	112	with even_odd := Minimality for even Sort Prop.
	113	\end{coq_example}
	114
	115	The type of {\tt odd\_even} for instance will be:
	116
	117	\begin{coq_example}
	118	Check odd_even.
	119	\end{coq_example}
	120
	121	The type of {\tt even\_odd} shares the same premises but the
	122	conclusion is {\tt (n:nat)(even n)->(Q n)}.
	123
	124	\subsection{Automatic declaration of schemes}
	125	\comindex{Set Equality Schemes}
	126	\comindex{Set Elimination Schemes}
	127
	128	It is possible to deactivate the automatic declaration of the induction
	129	principles when defining a new inductive type with the
	130	{\tt Unset Elimination Schemes} command. It may be
	131	reactivated at any time with {\tt Set Elimination Schemes}.
	132	\\
	133
	134	You can also activate the automatic declaration of those boolean equalities
	135	(see the second variant of {\tt Scheme}) with the {\tt Set Equality Schemes}
	136	command. However you have to be careful with this option since
	137	\Coq~ may now reject well-defined inductive types because it cannot compute
	138	a boolean equality for them.
	139
	140	\subsection{\tt Combined Scheme}
	141	\label{CombinedScheme}
	142	\comindex{Combined Scheme}
	143
	144	The {\tt Combined Scheme} command is a tool for combining
	145	induction principles generated by the {\tt Scheme} command.
	146	Its syntax follows the schema :
	147	\begin{quote}
	148	{\tt Combined Scheme {\ident$_0$} from {\ident$_1$}, .., {\ident$_n$}}
	149	\end{quote}
	150	where
	151	\ident$_1$ \ldots \ident$_n$ are different inductive principles that must belong to
	152	the same package of mutual inductive principle definitions. This command
	153	generates {\ident$_0$} to be the conjunction of the principles: it is
	154	built from the common premises of the principles and concluded by the
	155	conjunction of their conclusions.
	156
	157	\Example
	158	We can define the induction principles for trees and forests using:
	159	\begin{coq_example}
	160	Scheme tree_forest_ind := Induction for tree Sort Prop
	161	with forest_tree_ind := Induction for forest Sort Prop.
	162	\end{coq_example}
	163
	164	Then we can build the combined induction principle which gives the
	165	conjunction of the conclusions of each individual principle:
	166	\begin{coq_example}
	167	Combined Scheme tree_forest_mutind from tree_forest_ind, forest_tree_ind.
	168	\end{coq_example}
	169
	170	The type of {\tt tree\_forest\_mutrec} will be:
	171	\begin{coq_example}
	172	Check tree_forest_mutind.
	173	\end{coq_example}
	174
	175	\section{Generation of induction principles with {\tt Functional Scheme}}
	176	\label{FunScheme}
	177	\comindex{Functional Scheme}
	178
	179	The {\tt Functional Scheme} command is a high-level experimental
	180	tool for generating automatically induction principles
	181	corresponding to (possibly mutually recursive) functions. Its
	182	syntax follows the schema:
	183	\begin{quote}
	184	{\tt Functional Scheme {\ident$_1$} := Induction for \ident'$_1$ Sort {\sort$_1$} \\
	185	with\\
	186	\mbox{}\hspace{0.1cm} \dots\ \\
	187	with {\ident$_m$} := Induction for {\ident'$_m$} Sort
	188	{\sort$_m$}}
	189	\end{quote}
	190	where \ident'$_1$ \dots\ \ident'$_m$ are different mutually defined function
	191	names (they must be in the same order as when they were defined).
	192	This command generates the induction principles
	193	\ident$_1$\dots\ident$_m$, following the recursive structure and case
	194	analyses of the functions \ident'$_1$ \dots\ \ident'$_m$.
	195
	196	\Rem
	197	There is a difference between obtaining an induction scheme by using
	198	\texttt{Functional Scheme} on a function defined by \texttt{Function}
	199	or not. Indeed \texttt{Function} generally produces smaller
	200	principles, closer to the definition written by the user.
	201
	202	\firstexample
	203	\example{Induction scheme for \texttt{div2}}
	204	\label{FunScheme-examples}
	205
	206	We define the function \texttt{div2} as follows:
	207
	208	\begin{coq_eval}
	209	Reset Initial.
	210	\end{coq_eval}
	211
	212	\begin{coq_example*}
	213	Require Import Arith.
	214	Fixpoint div2 (n:nat) : nat :=
	215	match n with
	216	\| O => 0
	217	\| S O => 0
	218	\| S (S n') => S (div2 n')
	219	end.
	220	\end{coq_example*}
	221
	222	The definition of a principle of induction corresponding to the
	223	recursive structure of \texttt{div2} is defined by the command:
	224
	225	\begin{coq_example}
	226	Functional Scheme div2_ind := Induction for div2 Sort Prop.
	227	\end{coq_example}
	228
	229	You may now look at the type of {\tt div2\_ind}:
	230
	231	\begin{coq_example}
	232	Check div2_ind.
	233	\end{coq_example}
	234
	235	We can now prove the following lemma using this principle:
	236
	237	\begin{coq_example*}
	238	Lemma div2_le' : forall n:nat, div2 n <= n.
	239	intro n.
	240	pattern n , (div2 n).
	241	\end{coq_example*}
	242
	243	\begin{coq_example}
	244	apply div2_ind; intros.
	245	\end{coq_example}
	246
	247	\begin{coq_example*}
	248	auto with arith.
	249	auto with arith.
	250	simpl; auto with arith.
	251	Qed.
	252	\end{coq_example*}
	253
	254	We can use directly the \texttt{functional induction}
	255	(\ref{FunInduction}) tactic instead of the pattern/apply trick:
	256	\tacindex{functional induction}
	257
	258	\begin{coq_example*}
	259	Reset div2_le'.
	260	Lemma div2_le : forall n:nat, div2 n <= n.
	261	intro n.
	262	\end{coq_example*}
	263
	264	\begin{coq_example}
	265	functional induction (div2 n).
	266	\end{coq_example}
	267
	268	\begin{coq_example*}
	269	auto with arith.
	270	auto with arith.
	271	auto with arith.
	272	Qed.
	273	\end{coq_example*}
	274
	275	\Rem There is a difference between obtaining an induction scheme for a
	276	function by using \texttt{Function} (see Section~\ref{Function}) and by
	277	using \texttt{Functional Scheme} after a normal definition using
	278	\texttt{Fixpoint} or \texttt{Definition}. See \ref{Function} for
	279	details.
	280
	281
	282	\example{Induction scheme for \texttt{tree\_size}}
	283
	284	\begin{coq_eval}
	285	Reset Initial.
	286	\end{coq_eval}
	287
	288	We define trees by the following mutual inductive type:
	289
	290	\begin{coq_example*}
	291	Variable A : Set.
	292	Inductive tree : Set :=
	293	node : A -> forest -> tree
	294	with forest : Set :=
	295	\| empty : forest
	296	\| cons : tree -> forest -> forest.
	297	\end{coq_example*}
	298
	299	We define the function \texttt{tree\_size} that computes the size
	300	of a tree or a forest. Note that we use \texttt{Function} which
	301	generally produces better principles.
	302
	303	\begin{coq_example*}
	304	Function tree_size (t:tree) : nat :=
	305	match t with
	306	\| node A f => S (forest_size f)
	307	end
	308	with forest_size (f:forest) : nat :=
	309	match f with
	310	\| empty => 0
	311	\| cons t f' => (tree_size t + forest_size f')
	312	end.
	313	\end{coq_example*}
	314
	315	\Rem \texttt{Function} generates itself non mutual induction
	316	principles {\tt tree\_size\_ind} and {\tt forest\_size\_ind}:
	317
	318	\begin{coq_example}
	319	Check tree_size_ind.
	320	\end{coq_example}
	321
	322	The definition of mutual induction principles following the recursive
	323	structure of \texttt{tree\_size} and \texttt{forest\_size} is defined
	324	by the command:
	325
	326	\begin{coq_example*}
	327	Functional Scheme tree_size_ind2 := Induction for tree_size Sort Prop
	328	with forest_size_ind2 := Induction for forest_size Sort Prop.
	329	\end{coq_example*}
	330
	331	You may now look at the type of {\tt tree\_size\_ind2}:
	332
	333	\begin{coq_example}
	334	Check tree_size_ind2.
	335	\end{coq_example}
	336
	337	\section{Generation of inversion principles with \tt Derive Inversion}
	338	\label{Derive-Inversion}
	339	\comindex{Derive Inversion}
	340
	341	The syntax of {\tt Derive Inversion} follows the schema:
	342	\begin{quote}
	343	{\tt Derive Inversion {\ident} with forall
	344	$(\vec{x} : \vec{T})$, $I~\vec{t}$ Sort \sort}
	345	\end{quote}
	346
	347	This command generates an inversion principle for the
	348	\texttt{inversion \dots\ using} tactic.
	349	\tacindex{inversion \dots\ using}
	350	Let $I$ be an inductive predicate and $\vec{x}$ the variables
	351	occurring in $\vec{t}$. This command generates and stocks the
	352	inversion lemma for the sort \sort~ corresponding to the instance
	353	$\forall (\vec{x}:\vec{T}), I~\vec{t}$ with the name {\ident} in the {\bf
	354	global} environment. When applied, it is equivalent to having inverted
	355	the instance with the tactic {\tt inversion}.
	356
	357	\begin{Variants}
	358	\item \texttt{Derive Inversion\_clear {\ident} with forall
	359	$(\vec{x}:\vec{T})$, $I~\vec{t}$ Sort \sort}\\
	360	\comindex{Derive Inversion\_clear}
	361	When applied, it is equivalent to having
	362	inverted the instance with the tactic \texttt{inversion}
	363	replaced by the tactic \texttt{inversion\_clear}.
	364	\item \texttt{Derive Dependent Inversion {\ident} with forall
	365	$(\vec{x}:\vec{T})$, $I~\vec{t}$ Sort \sort}\\
	366	\comindex{Derive Dependent Inversion}
	367	When applied, it is equivalent to having
	368	inverted the instance with the tactic \texttt{dependent inversion}.
	369	\item \texttt{Derive Dependent Inversion\_clear {\ident} with forall
	370	$(\vec{x}:\vec{T})$, $I~\vec{t}$ Sort \sort}\\
	371	\comindex{Derive Dependent Inversion\_clear}
	372	When applied, it is equivalent to having
	373	inverted the instance with the tactic \texttt{dependent inversion\_clear}.
	374	\end{Variants}
	375
	376	\Example
	377
	378	Let us consider the relation \texttt{Le} over natural numbers and the
	379	following variable:
	380
	381	\begin{coq_eval}
	382	Reset Initial.
	383	\end{coq_eval}
	384
	385	\begin{coq_example*}
	386	Inductive Le : nat -> nat -> Set :=
	387	\| LeO : forall n:nat, Le 0 n
	388	\| LeS : forall n m:nat, Le n m -> Le (S n) (S m).
	389	Variable P : nat -> nat -> Prop.
	390	\end{coq_example*}
	391
	392	To generate the inversion lemma for the instance
	393	\texttt{(Le (S n) m)} and the sort \texttt{Prop}, we do:
	394
	395	\begin{coq_example*}
	396	Derive Inversion_clear leminv with (forall n m:nat, Le (S n) m) Sort Prop.
	397	\end{coq_example*}
	398
	399	\begin{coq_example}
	400	Check leminv.
	401	\end{coq_example}
	402
	403	Then we can use the proven inversion lemma:
	404
	405	\begin{coq_eval}
	406	Lemma ex : forall n m:nat, Le (S n) m -> P n m.
	407	intros.
	408	\end{coq_eval}
	409
	410	\begin{coq_example}
	411	Show.
	412	\end{coq_example}
	413
	414	\begin{coq_example}
	415	inversion H using leminv.
	416	\end{coq_example}
	417

+0

-0

doc/stdlib/hidden-files less more

(New empty file)

+24

-14

doc/stdlib/index-list.html.template less more

0		<!DOCTYPE html
1		PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
2		"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
3
4		<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
5		<head>
6		<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-15"/>
7		<link rel="stylesheet" href="css/context.css" type="text/css"/>
8		<title>The Coq Standard Library</title>
9		</head>
10
11		<body>
12
13		<H1>The Coq Standard Library</H1>
	0
	1	<h1>The Coq Standard Library</h1>
14	2
15	3	<p>Here is a short description of the Coq standard library, which is
16	4	distributed with the system.

67	55	theories/Logic/Epsilon.v
68	56	theories/Logic/IndefiniteDescription.v
69	57	theories/Logic/FunctionalExtensionality.v
	58	theories/Logic/ExtensionalityFacts.v
70	59	</dd>
71	60
72	61	<dt> <b>Structures</b>:

183	172	theories/ZArith/Zpow_def.v
184	173	theories/ZArith/Zpow_alt.v
185	174	theories/ZArith/Zpower.v
	175	theories/ZArith/ZOdiv_def.v
	176	theories/ZArith/ZOdiv.v
186	177	theories/ZArith/Zdiv.v
187	178	theories/ZArith/Zquot.v
188	179	theories/ZArith/Zeuclid.v

413	404	theories/Lists/ListTactics.v
414	405	</dd>
415	406
	407	<dt> <b>Vectors</b>:
	408	Dependent datastructures storing their length
	409	</dt>
	410	<dd>
	411	theories/Vectors/Fin.v
	412	theories/Vectors/VectorDef.v
	413	theories/Vectors/VectorSpec.v
	414	(theories/Vectors/Vector.v)
	415	</dd>
	416
416	417	<dt> <b>Sorting</b>:
417	418	Axiomatizations of sorts
418	419	</dt>

453	454	theories/MSets/MSetEqProperties.v
454	455	theories/MSets/MSetWeakList.v
455	456	theories/MSets/MSetList.v
	457	theories/MSets/MSetGenTree.v
456	458	theories/MSets/MSetAVL.v
	459	theories/MSets/MSetRBT.v
457	460	theories/MSets/MSetPositive.v
458	461	theories/MSets/MSetToFiniteSet.v
459	462	(theories/MSets/MSets.v)

575	578	theories/Program/Combinators.v
576	579	</dd>
577	580
	581	<dt> <b>Unicode</b>:
	582	Unicode-based notations
	583	</dt>
	584	<dd>
	585	theories/Unicode/Utf8_core.v
	586	theories/Unicode/Utf8.v
	587	</dd>
578	588	</dl>

+0

-2

~~doc/stdlib/index-trailer.html~~ less more

0		</body>
1		</html>

+26

-8

doc/stdlib/make-library-index less more

2	2	# Instantiate links to library files in index template
3	3
4	4	FILE=$1
	5	HIDDEN=$2
5	6
6	7	cp -f $FILE.template tmp
7	8	echo -n Building file index-list.prehtml ...
8	9
9		LIBDIRS="Init Logic Structures Bool Arith PArith NArith ZArith QArith Relations Sets Classes Setoids Lists Sorting Wellfounded MSets FSets Reals Program Numbers Numbers/Natural/Abstract Numbers/Natural/Peano Numbers/Natural/Binary Numbers/Natural/BigN Numbers/Natural/SpecViaZ Numbers/Integer/Abstract Numbers/Integer/NatPairs Numbers/Integer/Binary Numbers/Integer/SpecViaZ Numbers/Integer/BigZ Numbers/NatInt Numbers/Cyclic/Abstract Numbers/Cyclic/Int31 Numbers/Cyclic/ZModulo Numbers/Cyclic/DoubleCyclic Numbers/Rational/BigQ Numbers/Rational/SpecViaQ Strings"
	10	#LIBDIRS="Init Logic Structures Bool Arith PArith NArith ZArith QArith Relations Sets Classes Setoids Lists Vectors Sorting Wellfounded MSets FSets Reals Program Numbers Numbers/Natural/Abstract Numbers/Natural/Peano Numbers/Natural/Binary Numbers/Natural/BigN Numbers/Natural/SpecViaZ Numbers/Integer/Abstract Numbers/Integer/NatPairs Numbers/Integer/Binary Numbers/Integer/SpecViaZ Numbers/Integer/BigZ Numbers/NatInt Numbers/Cyclic/Abstract Numbers/Cyclic/Int31 Numbers/Cyclic/ZModulo Numbers/Cyclic/DoubleCyclic Numbers/Rational/BigQ Numbers/Rational/SpecViaQ Strings"
	11	LIBDIRS=`find theories/* -type d \| sed -e "s:^theories/::"`
10	12
11	13	for k in $LIBDIRS; do
12	14	i=theories/$k
13	15	echo $i
14	16
15	17	d=`basename $i`
16		if [ "$d" != "Num" -a "$d" != "CVS" ]; then
	18	if [ "$d" != "CVS" ]; then
	19	ls $i \| grep -q \.v'$'
	20	if [ $? = 0 ]; then
17	21	for j in $i/*.v; do
18	22	b=`basename $j .v`
19	23	rm -f tmp2
20	24	grep -q theories/$k/$b.v tmp
21	25	a=$?
	26	grep -q theories/$k/$b.v $HIDDEN
	27	h=$?
22	28	if [ $a = 0 ]; then
23		p=`echo $k \| sed 's:/:.:g'`
24		sed -e "s:theories/$k/$b.v:<a href=\"Coq.$p.$b.html\">$b</a>:g" tmp > tmp2
25		mv -f tmp2 tmp
	29	if [ $h = 0 ]; then
	30	echo Error: $FILE and $HIDDEN both mention theories/$k/$b.v; exit 1
	31	else
	32	p=`echo $k \| sed 's:/:.:g'`
	33	sed -e "s:theories/$k/$b.v:<a href=\"Coq.$p.$b.html\">$b</a>:g" tmp > tmp2
	34	mv -f tmp2 tmp
	35	fi
26	36	else
27		echo Warning: theories/$k/$b.v is missing in the template file
28		fi
	37	if [ $h = 0 ]; then
	38	echo Error: theories/$k/$b.v is missing in the template file
	39	exit 1
	40	else
	41	echo Error: none of $FILE and $HIDDEN mention theories/$k/$b.v
	42	exit 1
	43	fi
	44
	45	fi
29	46	done
	47	fi
30	48	fi
31	49	rm -f tmp2
32	50	sed -e "s/#$d#//" tmp > tmp2
33	51	mv -f tmp2 tmp
34	52	done
35	53	a=`grep theories tmp`
36		if [ $? = 0 ]; then echo Warning: extra files:; echo $a; fi
	54	if [ $? = 0 ]; then echo Error: extra files:; echo $a; exit 1; fi
37	55	mv tmp $FILE
38	56	echo Done

+21

-3

ide/command_windows.ml less more

12	12	~position:`CENTER
13	13	~title:"CoqIde queries" ~show:false ()
14	14	in *)
	15	let views = ref [] in
15	16	let frame = GBin.frame ~label:"Command Pane" ~shadow_type:`IN () in
16	17	let _ = frame#misc#hide () in
17	18	let _ = GtkData.AccelGroup.create () in

48	49	()
49	50	in
50	51
	52	let remove_cb () =
	53	let index = notebook#current_page in
	54	let () = notebook#remove_page index in
	55	views := Minilib.list_filter_i (fun i x -> i <> index) !views
	56	in
51	57	let _ =
52	58	toolbar#insert_button
53	59	~tooltip:"Delete Page"
54	60	~text:"Delete Page"
55	61	~icon:(Ideutils.stock_to_widget `DELETE)
56		~callback:(fun () -> notebook#remove_page notebook#current_page)
	62	~callback:remove_cb
57	63	()
58	64	in
59	65	object(self)

62	68
63	69	val new_page_menu = new_page_menu
64	70	val notebook = notebook
	71
65	72	method frame = frame
66	73	method new_command ?command ?term () =
67		let appendp x = ignore (notebook#append_page x) in
68	74	let frame = GBin.frame
69	75	~shadow_type:`ETCHED_OUT
70		~packing:appendp
71	76	()
72	77	in
	78	let _ = notebook#append_page frame#coerce in
73	79	notebook#goto_page (notebook#page_num frame#coerce);
74	80	let vbox = GPack.vbox ~homogeneous:false ~packing:frame#add () in
75	81	let hbox = GPack.hbox ~homogeneous:false ~packing:vbox#pack () in

90	96	~packing:(vbox#pack ~fill:true ~expand:true) () in
91	97	let ok_b = GButton.button ~label:"Ok" ~packing:(hbox#pack ~expand:false) () in
92	98	let result = GText.view ~packing:r_bin#add () in
	99	let () = views := !views @ [result] in
93	100	result#misc#modify_font !current.Preferences.text_font;
	101	let clr = Tags.color_of_string !current.Preferences.background_color in
	102	result#misc#modify_base [`NORMAL, `COLOR clr];
94	103	result#misc#set_can_focus true; (* false causes problems for selection *)
95	104	result#set_editable false;
96	105	let callback () =

133	142	ignore (combo#entry#connect#activate ~callback);
134	143	self#frame#misc#show ()
135	144
	145	method refresh_font () =
	146	let iter view = view#misc#modify_font !current.Preferences.text_font in
	147	List.iter iter !views
	148
	149	method refresh_color () =
	150	let clr = Tags.color_of_string !current.Preferences.background_color in
	151	let iter view = view#misc#modify_base [`NORMAL, `COLOR clr] in
	152	List.iter iter !views
	153
136	154	initializer
137	155	ignore (new_page_menu#connect#clicked ~callback:self#new_command);
138	156	(* ignore (window#event#connect#delete (fun _ -> window#misc#hide(); true));*)

+2

-0

ide/command_windows.mli less more

10	10	object
11	11	method new_command : ?command:string -> ?term:string -> unit -> unit
12	12	method frame : GBin.frame
	13	method refresh_font : unit -> unit
	14	method refresh_color : unit -> unit
13	15	end

+96

-26

ide/coq.ml less more

53	53	arg::(read_all_lines in_chan)
54	54	with End_of_file -> []
55	55
56		let filter_coq_opts args =
	56	let fatal_error_popup msg =
	57	let popup = GWindow.message_dialog ~buttons:GWindow.Buttons.ok
	58	~message_type:`ERROR ~message:msg ()
	59	in ignore (popup#run ()); exit 1
	60
	61	let final_info_popup small msg =
	62	if small then
	63	let popup = GWindow.message_dialog ~buttons:GWindow.Buttons.ok
	64	~message_type:`INFO ~message:msg ()
	65	in
	66	let _ = popup#run () in
	67	exit 0
	68	else
	69	let popup = GWindow.dialog () in
	70	let button = GButton.button ~label:"ok" ~packing:popup#action_area#add ()
	71	in
	72	let scroll = GBin.scrolled_window ~hpolicy:`NEVER ~vpolicy:`AUTOMATIC
	73	~packing:popup#vbox#add ~height:500 ()
	74	in
	75	let _ = GMisc.label ~text:msg ~packing:scroll#add_with_viewport () in
	76	let _ = popup#connect#destroy ~callback:(fun _ -> exit 0) in
	77	let _ = button#connect#clicked ~callback:(fun _ -> exit 0) in
	78	let _ = popup#run () in
	79	exit 0
	80
	81	let connection_error cmd lines exn =
	82	fatal_error_popup
	83	("Connection with coqtop failed!\n"^
	84	"Command was: "^cmd^"\n"^
	85	"Answer was: "^(String.concat "\n " lines)^"\n"^
	86	"Exception was: "^Printexc.to_string exn)
	87
	88	let display_coqtop_answer cmd lines =
	89	final_info_popup (List.length lines < 30)
	90	("Coqtop exited\n"^
	91	"Command was: "^cmd^"\n"^
	92	"Answer was: "^(String.concat "\n " lines))
	93
	94	let check_remaining_opt arg =
	95	if arg <> "" && arg.[0] = '-' then fatal_error_popup ("Illegal option: "^arg)
	96
	97	let rec filter_coq_opts args =
57	98	let argstr = String.concat " " (List.map Filename.quote args) in
58		let cmd = Filename.quote !Minilib.coqtop_path ^" -nois -filteropts " ^ argstr in
59		let oc,ic,ec = Unix.open_process_full cmd (Unix.environment ()) in
60		let filtered_args = read_all_lines oc in
61		let message = read_all_lines ec in
62		match Unix.close_process_full (oc,ic,ec) with
63		\| Unix.WEXITED 0 -> true,filtered_args
64		\| Unix.WEXITED 2 -> false,filtered_args
65		\| _ -> false,message
66
67		exception Coqtop_output of string list
	99	let cmd = Filename.quote (coqtop_path ()) ^" -nois -filteropts " ^ argstr in
	100	let cmd = requote cmd in
	101	let filtered_args = ref [] in
	102	let errlines = ref [] in
	103	try
	104	let oc,ic,ec = Unix.open_process_full cmd (Unix.environment ()) in
	105	filtered_args := read_all_lines oc;
	106	errlines := read_all_lines ec;
	107	match Unix.close_process_full (oc,ic,ec) with
	108	\| Unix.WEXITED 0 ->
	109	List.iter check_remaining_opt !filtered_args; !filtered_args
	110	\| Unix.WEXITED 127 -> asks_for_coqtop args
	111	\| _ -> display_coqtop_answer cmd (!filtered_args @ !errlines)
	112	with Sys_error _ -> asks_for_coqtop args
	113	\| e -> connection_error cmd (!filtered_args @ !errlines) e
	114
	115	and asks_for_coqtop args =
	116	let pb_mes = GWindow.message_dialog
	117	~message:"Failed to load coqtop. Reset the preference to default ?"
	118	~message_type:`QUESTION ~buttons:GWindow.Buttons.yes_no () in
	119	match pb_mes#run () with
	120	\| `YES ->
	121	let () = !Preferences.current.Preferences.cmd_coqtop <- None in
	122	let () = custom_coqtop := None in
	123	let () = pb_mes#destroy () in
	124	filter_coq_opts args
	125	\| `DELETE_EVENT \| `NO ->
	126	let () = pb_mes#destroy () in
	127	let cmd_sel = GWindow.file_selection
	128	~title:"Coqtop to execute (edit your preference then)"
	129	~filename:(coqtop_path ()) ~urgency_hint:true () in
	130	match cmd_sel#run () with
	131	\| `OK ->
	132	let () = custom_coqtop := (Some cmd_sel#filename) in
	133	let () = cmd_sel#destroy () in
	134	filter_coq_opts args
	135	\| `CANCEL \| `DELETE_EVENT \| `HELP -> exit 0
	136
	137	exception WrongExitStatus of string
	138
	139	let print_status = function
	140	\| Unix.WEXITED n -> "WEXITED "^string_of_int n
	141	\| Unix.WSIGNALED n -> "WSIGNALED "^string_of_int n
	142	\| Unix.WSTOPPED n -> "WSTOPPED "^string_of_int n
68	143
69	144	let check_connection args =
70		try
71		let argstr = String.concat " " (List.map Filename.quote args) in
72		let cmd = Filename.quote !Minilib.coqtop_path ^ " -batch " ^ argstr in
	145	let lines = ref [] in
	146	let argstr = String.concat " " (List.map Filename.quote args) in
	147	let cmd = Filename.quote (coqtop_path ()) ^ " -batch " ^ argstr in
	148	let cmd = requote cmd in
	149	try
73	150	let ic = Unix.open_process_in cmd in
74		let lines = read_all_lines ic in
	151	lines := read_all_lines ic;
75	152	match Unix.close_process_in ic with
76		\| Unix.WEXITED 0 -> prerr_endline "coqtop seems ok"
77		\| _ -> raise (Coqtop_output lines)
78		with
79		\| End_of_file ->
80		Minilib.safe_prerr_endline "Cannot start connection with coqtop";
81		exit 1
82		\| Coqtop_output lines ->
83		Minilib.safe_prerr_endline "Connection with coqtop failed:";
84		List.iter Minilib.safe_prerr_endline lines;
85		exit 1
	153	\| Unix.WEXITED 0 -> () (* coqtop seems ok *)
	154	\| st -> raise (WrongExitStatus (print_status st))
	155	with e -> connection_error cmd !lines e
86	156
87	157	(** * The structure describing a coqtop sub-process *)
88	158

138	208	let spawn_coqtop sup_args =
139	209	Mutex.lock toplvl_ctr_mtx;
140	210	try
141		let prog = !Minilib.coqtop_path in
	211	let prog = coqtop_path () in
142	212	let args = Array.of_list (prog :: "-ideslave" :: sup_args) in
143	213	let (pid,ic,oc) = open_process_pid prog args in
144	214	incr toplvl_ctr;

+8

-4

ide/coq.mli less more

12	12	val short_version : unit -> string
13	13	val version : unit -> string
14	14
15		(** * Initial checks by launching test coqtop processes *)
	15	(** * Launch a test coqtop processes, ask for a correct coqtop if it fails.
	16	@return the list of arguments that coqtop did not understand
	17	(the files probably ..). This command may terminate coqide in
	18	case of trouble. *)
	19	val filter_coq_opts : string list -> string list
16	20
17		val filter_coq_opts : string list -> bool * string list
18
19		(** A mock coqtop launch, checking in particular that initial.coq is found *)
	21	(** Launch a coqtop with the user args in order to be sure that it works,
	22	checking in particular that initial.coq is found. This command
	23	may terminate coqide in case of trouble *)
20	24	val check_connection : string list -> unit
21	25
22	26	(** * The structure describing a coqtop sub-process *)

+0

-1

ide/coq_commands.ml less more

126	126	"Show Script";
127	127	"Show Tree";*)
128	128	"Structure";
129		(* "Suspend"; *)
130	129	"Syntactic Definition";
131	130	"Syntax";];
132	131	[

+12

-16

ide/coq_lex.mll less more

23	23	let one_word_commands =
24	24	[ "Add" ; "Check"; "Eval"; "Extraction" ;
25	25	"Load" ; "Undo"; "Goal";
26		"Proof" ; "Print";"Save" ;
	26	"Proof" ; "Print";"Save" ; "Restart";
27	27	"End" ; "Section"; "Chapter"; "Transparent"; "Opaque"; "Comments" ]
28	28	in
29	29	let one_word_declarations =

36	36	(* Inductive *)
37	37	"Inductive" ; "CoInductive" ; "Record" ; "Structure" ;
38	38	(* Other *)
39		"Ltac" ; "Typeclasses"; "Instance"; "Include"; "Context"; "Class" ]
	39	"Ltac" ; "Instance"; "Include"; "Context"; "Class" ;
	40	"Arguments" ]
40	41	in
41	42	let proof_declarations =
42	43	[ "Theorem" ; "Lemma" ; " Fact" ; "Remark" ; "Corollary" ;

84	85	\| "Existing" space+ "Instance" "s"?
85	86	\| "Canonical" space+ "Structure"
86	87
87		let locality = ("Local" space+)?
	88	let locality = (space+ "Local")?
88	89
89	90	let multiword_command =
90		"Set" (space+ ident)*
91		\| "Unset" (space+ ident)*
92		\| "Open" space+ locality "Scope"
93		\| "Close" space+ locality "Scope"
94		\| "Bind" space+ "Scope"
95		\| "Arguments" space+ "Scope"
96		\| "Reserved" space+ "Notation" space+ locality
97		\| "Delimit" space+ "Scope"
	91	("Uns" \| "S")" et" (space+ ident)*
	92	\| (("Open" \| "Close") locality \| "Bind" \| " Delimit" )
	93	space+ "Scope"
	94	\| (("Reserved" space+)? "Notation" \| "Infix") locality space+
98	95	\| "Next" space+ "Obligation"
99	96	\| "Solve" space+ "Obligations"
100	97	\| "Require" space+ ("Import"\|"Export")?
101		\| "Infix" space+ locality
102		\| "Notation" space+ locality
103		\| "Hint" space+ locality ident
	98	\| "Hint" locality space+ ident
104	99	\| "Reset" (space+ "Initial")?
105	100	\| "Tactic" space+ "Notation"
106		\| "Implicit" space+ "Arguments"
107		\| "Implicit" space+ ("Type"\|"Types")
	101	\| "Implicit" space+ "Type" "s"?
108	102	\| "Combined" space+ "Scheme"
109	103	\| "Extraction" space+ (("Language" space+ ("Ocaml"\|"Haskell"\|"Scheme"\|"Toplevel"))\|
110	104	("Library"\|"Inline"\|"NoInline"\|"Blacklist"))
111	105	\| "Recursive" space+ "Extraction" (space+ "Library")?
112	106	\| ("Print"\|"Reset") space+ "Extraction" space+ ("Inline"\|"Blacklist")
113	107	\| "Extract" space+ (("Inlined" space+) "Constant"\| "Inductive")
	108	\| "Typeclasses" space+ ("eauto" \| "Transparent" \| "Opaque")
	109	\| ("Generalizable" space+) ("All" \| "No")? "Variable" "s"?
114	110
115	111	(* At least still missing: "Inline" + decl, variants of "Identity
116	112	Coercion", variants of Print, Add, ... *)

+0

-10

ide/coqide-gtk2rc less more

22	22	class "GtkTextView" binding "text"
23	23
24	24
25		style "views" {
26		base[NORMAL] = "CornSilk"
27		# bg_pixmap[NORMAL] = "background.jpg"
28		}
29		class "GtkTextView" style "views"
30
31		widget "....*.ScriptWindow" style "views"
32		widget "....GoalWindow" style "views"
33		widget "....MessageWindow" style "views"
34
35	25	gtk-font-name = "Sans 12"
36	26
37	27	style "location" {

+121

-112

ide/coqide.ml less more

26	26	class type analyzed_views=
27	27	object
28	28	val mutable act_id : GtkSignal.id option
29		val mutable deact_id : GtkSignal.id option
30	29	val input_buffer : GText.buffer
31	30	val input_view : Undo.undoable_view
32	31	val last_array : string array

64	63	method backtrack_to : GText.iter -> unit
65	64	method backtrack_to_no_lock : GText.iter -> unit
66	65	method clear_message : unit
67		method disconnected_keypress_handler : GdkEvent.Key.t -> bool
68	66	method find_phrase_starting_at :
69	67	GText.iter -> (GText.iter * GText.iter) option
70	68	method get_insert : GText.iter

83	81	method reset_initial : unit
84	82	method force_reset_initial : unit
85	83	method set_message : string -> unit
	84	method raw_coq_query : string -> unit
86	85	method show_goals : unit
87	86	method show_goals_full : unit
88	87	method undo_last_step : unit

888	887	raise RestartCoqtop
889	888	\| e -> sync display_error (None, Printexc.to_string e); None
890	889
	890	(* This method is intended to perform stateless commands *)
	891	method raw_coq_query phrase =
	892	let () = prerr_endline "raw_coq_query starting now" in
	893	let display_error s =
	894	if not (Glib.Utf8.validate s) then
	895	flash_info "This error is so nasty that I can't even display it."
	896	else begin
	897	self#insert_message s;
	898	message_view#misc#draw None
	899	end
	900	in
	901	try
	902	match Coq.interp !mycoqtop ~raw:true ~verbose:false phrase with
	903	\| Interface.Fail (_, err) -> sync display_error err
	904	\| Interface.Good msg -> sync self#insert_message msg
	905	with
	906	\| End_of_file -> raise RestartCoqtop
	907	\| e -> sync display_error (Printexc.to_string e)
	908
891	909	method find_phrase_starting_at (start:GText.iter) =
892	910	try
893	911	let start = grab_sentence_start start self#get_start_of_input in
894	912	let stop = grab_sentence_stop start in
895		if is_sentence_end stop#backward_char then Some (start,stop)
	913	(* Is this phrase non-empty and complete ? *)
	914	if stop#compare start > 0 && is_sentence_end stop#backward_char
	915	then Some (start,stop)
896	916	else None
897	917	with Not_found -> None
898	918

1216	1236	let state = GdkEvent.Key.state k in
1217	1237	begin
1218	1238	match state with
1219		\| l when List.mem `MOD1 l ->
1220		let k = GdkEvent.Key.keyval k in
1221		if GdkKeysyms._Return=k
1222		then ignore(
1223		if (input_buffer#insert_interactive "\n") then
1224		begin
1225		let i= self#get_insert#backward_word_start in
1226		prerr_endline "active_kp_hf: Placing cursor";
1227		self#process_until_iter_or_error i
1228		end);
1229		true
1230		\| l when List.mem `CONTROL l ->
1231		let k = GdkEvent.Key.keyval k in
1232		if GdkKeysyms._Break=k
1233		then break ();
1234		false
1235	1239	\| l ->
1236	1240	if GdkEvent.Key.keyval k = GdkKeysyms._Tab then begin
1237	1241	prerr_endline "active_kp_handler for Tab";

1240	1244	end else false
1241	1245	end
1242	1246
1243
1244		method disconnected_keypress_handler k =
1245		match GdkEvent.Key.state k with
1246		\| l when List.mem `CONTROL l ->
1247		let k = GdkEvent.Key.keyval k in
1248		if GdkKeysyms._c=k
1249		then break ();
1250		false
1251		\| l -> false
1252
1253
1254		val mutable deact_id = None
1255	1247	val mutable act_id = None
1256	1248
1257	1249	method activate () = if not is_active then begin

1522	1514	script#buffer#place_cursor ~where:(script#buffer#start_iter);
1523	1515	proof#misc#set_can_focus true;
1524	1516	message#misc#set_can_focus true;
	1517	(* setting fonts *)
1525	1518	script#misc#modify_font !current.text_font;
1526	1519	proof#misc#modify_font !current.text_font;
1527	1520	message#misc#modify_font !current.text_font;
	1521	(* setting colors *)
	1522	script#misc#modify_base [`NORMAL, `NAME !current.background_color];
	1523	proof#misc#modify_base [`NORMAL, `NAME !current.background_color];
	1524	message#misc#modify_base [`NORMAL, `NAME !current.background_color];
	1525
1528	1526	{ tab_label=basename;
1529	1527	filename=begin match file with None -> "" \|Some f -> f end;
1530	1528	script=script;

1797	1795	else false)
1798	1796
1799	1797	let main files =
1800		(* Statup preferences *)
1801		begin
1802		try load_pref ()
1803		with e ->
1804		flash_info ("Could not load preferences ("^Printexc.to_string e^").");
1805		end;
1806	1798
1807	1799	(* Main window *)
1808	1800	let w = GWindow.window

1822	1814	let vbox = GPack.vbox ~homogeneous:false ~packing:w#add () in
1823	1815
1824	1816	let new_f _ =
1825		match select_file_for_save ~title:"Create file" () with
1826		\| None -> ()
1827		\| Some f -> do_load f
	1817	let session = create_session None in
	1818	let index = session_notebook#append_term session in
	1819	session_notebook#goto_page index
1828	1820	in
1829	1821	let load_f _ =
1830	1822	match select_file_for_open ~title:"Load file" () with

2180	2172	true))
2181	2173	in reset_auto_save_timer (); (* to enable statup preferences timer *)
2182	2174	(* end Preferences *)
	2175
2183	2176	let do_or_activate f () =
2184	2177	do_if_not_computing "do_or_activate"
2185	2178	(fun current ->

2326	2319	in
2327	2320
2328	2321	let file_actions = GAction.action_group ~name:"File" () in
	2322	let edit_actions = GAction.action_group ~name:"Edit" () in
	2323	let view_actions = GAction.action_group ~name:"View" () in
2329	2324	let export_actions = GAction.action_group ~name:"Export" () in
2330		let edit_actions = GAction.action_group ~name:"Edit" () in
2331	2325	let navigation_actions = GAction.action_group ~name:"Navigation" () in
2332	2326	let tactics_actions = GAction.action_group ~name:"Tactics" () in
2333	2327	let templates_actions = GAction.action_group ~name:"Templates" () in
2334	2328	let queries_actions = GAction.action_group ~name:"Queries" () in
2335		let display_actions = GAction.action_group ~name:"Display" () in
2336	2329	let compile_actions = GAction.action_group ~name:"Compile" () in
2337	2330	let windows_actions = GAction.action_group ~name:"Windows" () in
2338	2331	let help_actions = GAction.action_group ~name:"Help" () in

2361	2354	~accel:(!current.modifier_for_tactics^sc)
2362	2355	~callback:(do_if_active (fun a -> a#insert_command
2363	2356	("progress "^s^".\n") (s^".\n"))) in
2364		let query_shortcut s accel = GAction.add_action s ~label:("_"^s) ?accel
2365		~callback:(fun _ -> let term = get_current_word () in
2366		session_notebook#current_term.command#new_command ~command:s ~term ())
2367		in let add_complex_template (name, label, text, offset, len, key) =
	2357	let query_callback command _ =
	2358	let word = get_current_word () in
	2359	if not (word = "") then
	2360	let term = session_notebook#current_term in
	2361	let query = command ^ " " ^ word ^ "." in
	2362	term.message_view#buffer#set_text "";
	2363	term.analyzed_view#raw_coq_query query
	2364	in
	2365	let query_shortcut s accel =
	2366	GAction.add_action s ~label:("_"^s) ?accel ~callback:(query_callback s)
	2367	in
	2368	let add_complex_template (name, label, text, offset, len, key) =
2368	2369	(* Templates/Lemma *)
2369	2370	let callback _ =
2370	2371	let {script = view } = session_notebook#current_term in

2449	2450	end;
2450	2451	reset_revert_timer ()) ~stock:`PREFERENCES;
2451	2452	(* GAction.add_action "Save preferences" ~label:"_Save preferences" ~callback:(fun _ -> save_pref ()); *) ];
	2453	GAction.add_actions view_actions [
	2454	GAction.add_action "View" ~label:"_View";
	2455	GAction.add_action "Previous tab" ~label:"_Previous tab" ~accel:("<SHIFT>Left") ~stock:`GO_BACK
	2456	~callback:(fun _ -> session_notebook#previous_page ());
	2457	GAction.add_action "Next tab" ~label:"_Next tab" ~accel:("<SHIFT>Right") ~stock:`GO_FORWARD
	2458	~callback:(fun _ -> session_notebook#next_page ());
	2459	GAction.add_toggle_action "Show Toolbar" ~label:"Show _Toolbar"
	2460	~active:(!current.show_toolbar) ~callback:
	2461	(fun _ -> !current.show_toolbar <- not !current.show_toolbar;
	2462	!refresh_toolbar_hook ());
	2463	GAction.add_toggle_action "Show Query Pane" ~label:"Show _Query Pane"
	2464	~callback:(fun _ -> let ccw = session_notebook#current_term.command in
	2465	if ccw#frame#misc#visible
	2466	then ccw#frame#misc#hide ()
	2467	else ccw#frame#misc#show ())
	2468	~accel:"Escape";
	2469	];
	2470	List.iter
	2471	(fun (opts,name,label,key,dflt) ->
	2472	GAction.add_toggle_action name ~active:dflt ~label
	2473	~accel:(!current.modifier_for_display^key)
	2474	~callback:(fun v -> do_or_activate (fun a ->
	2475	let () = setopts !(session_notebook#current_term.toplvl) opts v#get_active in
	2476	a#show_goals) ()) view_actions)
	2477	print_items;
2452	2478	GAction.add_actions navigation_actions [
2453	2479	GAction.add_action "Navigation" ~label:"_Navigation";
2454	2480	GAction.add_action "Forward" ~label:"_Forward" ~stock:`GO_DOWN

2531	2557	query_shortcut "Locate" None;
2532	2558	query_shortcut "Whelp Locate" None;
2533	2559	];
2534		GAction.add_action "Display" ~label:"_Display" display_actions;
2535		List.iter
2536		(fun (opts,name,label,key,dflt) ->
2537		GAction.add_toggle_action name ~active:dflt ~label
2538		~accel:(!current.modifier_for_display^key)
2539		~callback:(fun v -> do_or_activate (fun a ->
2540		let () = setopts !(session_notebook#current_term.toplvl) opts v#get_active in
2541		a#show_goals) ()) display_actions)
2542		print_items;
2543	2560	GAction.add_actions compile_actions [
2544	2561	GAction.add_action "Compile" ~label:"_Compile";
2545	2562	GAction.add_action "Compile buffer" ~label:"_Compile buffer" ~callback:compile_f;

2550	2567	];
2551	2568	GAction.add_actions windows_actions [
2552	2569	GAction.add_action "Windows" ~label:"_Windows";
2553		GAction.add_toggle_action "Show/Hide Query Pane" ~label:"Show/Hide _Query Pane"
2554		~callback:(fun _ -> let ccw = session_notebook#current_term.command in
2555		if ccw#frame#misc#visible
2556		then ccw#frame#misc#hide ()
2557		else ccw#frame#misc#show ())
2558		~accel:"Escape";
2559		GAction.add_toggle_action "Show/Hide Toolbar" ~label:"Show/Hide _Toolbar"
2560		~active:(!current.show_toolbar) ~callback:
2561		(fun _ -> !current.show_toolbar <- not !current.show_toolbar;
2562		!show_toolbar !current.show_toolbar);
2563	2570	GAction.add_action "Detach View" ~label:"Detach _View"
2564	2571	~callback:(fun _ -> do_if_not_computing "detach view"
2565	2572	(function {script=v;analyzed_view=av} ->

2607	2614	Coqide_ui.ui_m#insert_action_group file_actions 0;
2608	2615	Coqide_ui.ui_m#insert_action_group export_actions 0;
2609	2616	Coqide_ui.ui_m#insert_action_group edit_actions 0;
	2617	Coqide_ui.ui_m#insert_action_group view_actions 0;
2610	2618	Coqide_ui.ui_m#insert_action_group navigation_actions 0;
2611	2619	Coqide_ui.ui_m#insert_action_group tactics_actions 0;
2612	2620	Coqide_ui.ui_m#insert_action_group templates_actions 0;
2613	2621	Coqide_ui.ui_m#insert_action_group queries_actions 0;
2614		Coqide_ui.ui_m#insert_action_group display_actions 0;
2615	2622	Coqide_ui.ui_m#insert_action_group compile_actions 0;
2616	2623	Coqide_ui.ui_m#insert_action_group windows_actions 0;
2617	2624	Coqide_ui.ui_m#insert_action_group help_actions 0;

2623	2630	~tooltips:true tbar in
2624	2631	let toolbar = new GObj.widget tbar in
2625	2632	vbox#pack toolbar;
2626
2627		show_toolbar :=
2628		(fun b -> if b then toolbar#misc#show () else toolbar#misc#hide ());
2629	2633
2630	2634	ignore (w#event#connect#delete ~callback:(fun _ -> quit_f (); true));
2631	2635

2789	2793	(* Progress Bar *)
2790	2794	lower_hbox#pack pbar#coerce;
2791	2795	pbar#set_text "CoqIde started";
2792		(* XXX *)
2793		change_font :=
2794		(fun fd ->
2795		List.iter
2796		(fun {script=view; proof_view=prf_v; message_view=msg_v} ->
2797		view#misc#modify_font fd;
2798		prf_v#misc#modify_font fd;
2799		msg_v#misc#modify_font fd
2800		)
2801		session_notebook#pages;
	2796
	2797	(* Initializing hooks *)
	2798
	2799	refresh_toolbar_hook :=
	2800	(fun () -> if !current.show_toolbar then toolbar#misc#show () else toolbar#misc#hide ());
	2801	refresh_font_hook :=
	2802	(fun () ->
	2803	let fd = !current.text_font in
	2804	let iter_page p =
	2805	p.script#misc#modify_font fd;
	2806	p.proof_view#misc#modify_font fd;
	2807	p.message_view#misc#modify_font fd;
	2808	p.command#refresh_font ()
	2809	in
	2810	List.iter iter_page session_notebook#pages;
2802	2811	);
	2812	refresh_background_color_hook :=
	2813	(fun () ->
	2814	let clr = Tags.color_of_string !current.background_color in
	2815	let iter_page p =
	2816	p.script#misc#modify_base [`NORMAL, `COLOR clr];
	2817	p.proof_view#misc#modify_base [`NORMAL, `COLOR clr];
	2818	p.message_view#misc#modify_base [`NORMAL, `COLOR clr];
	2819	p.command#refresh_color ()
	2820	in
	2821	List.iter iter_page session_notebook#pages;
	2822	);
	2823	resize_window_hook := (fun () ->
	2824	w#resize
	2825	~width:!current.window_width
	2826	~height:!current.window_height);
	2827	refresh_tabs_hook := update_notebook_pos;
	2828
2803	2829	let about_full_string =
2804	2830	"\nCoq is developed by the Coq Development Team\
2805	2831	\n(INRIA - CNRS - LIX - LRI - PPS)\

2864	2890	(*
2865	2891
2866	2892	*)
2867		resize_window := (fun () ->
2868		w#resize
2869		~width:!current.window_width
2870		~height:!current.window_height);
	2893	(* Begin Color configuration *)
	2894
	2895	Tags.set_processing_color (Tags.color_of_string !current.processing_color);
	2896	Tags.set_processed_color (Tags.color_of_string !current.processed_color);
	2897
	2898	(* End of color configuration *)
2871	2899	ignore(nb#connect#switch_page
2872	2900	~callback:
2873	2901	(fun i ->

2891	2919	session_notebook#goto_page index;
2892	2920	end;
2893	2921	initial_about session_notebook#current_term.proof_view#buffer;
2894		!show_toolbar !current.show_toolbar;
	2922	!refresh_toolbar_hook ();
2895	2923	session_notebook#current_term.script#misc#grab_focus ();;
2896	2924
2897	2925	(* This function check every half of second if GeoProof has send

2920	2948	in the path. Note that the -coqtop option to coqide allows to override
2921	2949	this default coqtop path *)
2922	2950
2923		let default_coqtop_path () =
2924		let prog = Sys.executable_name in
2925		try
2926		let pos = String.length prog - 6 in
2927		let i = Str.search_backward (Str.regexp_string "coqide") prog pos in
2928		String.blit "coqtop" 0 prog i 6;
2929		prog
2930		with _ -> "coqtop"
2931
2932	2951	let read_coqide_args argv =
2933	2952	let rec filter_coqtop coqtop project_files out = function
2934	2953	\| "-coqtop" :: prog :: args ->
2935		if coqtop = "" then filter_coqtop prog project_files out args
	2954	if coqtop = None then filter_coqtop (Some prog) project_files out args
2936	2955	else
2937		(output_string stderr "Error: multiple -coqtop options"; exit 1)
	2956	(output_string stderr "Error: multiple -coqtop options"; exit 1)
2938	2957	\| "-f" :: file :: args ->
2939	2958	filter_coqtop coqtop
2940	2959	((Minilib.canonical_path_name (Filename.dirname file),
2941	2960	Project_file.read_project_file file) :: project_files) out args
2942	2961	\| "-f" :: [] -> output_string stderr "Error: missing project file name"; exit 1
	2962	\| "-coqtop" :: [] -> output_string stderr "Error: missing argument after -coqtop"; exit 1
	2963	\| "-debug"::args -> Ideutils.debug := true;
	2964	filter_coqtop coqtop project_files ("-debug"::out) args
2943	2965	\| arg::args -> filter_coqtop coqtop project_files (arg::out) args
2944		\| [] -> ((if coqtop = "" then default_coqtop_path () else coqtop),
2945		List.rev project_files,List.rev out)
2946		in
2947		let coqtop,project_files,argv = filter_coqtop "" [] [] argv in
2948		Minilib.coqtop_path := coqtop;
	2966	\| [] -> (coqtop,List.rev project_files,List.rev out)
	2967	in
	2968	let coqtop,project_files,argv = filter_coqtop None [] [] argv in
	2969	Ideutils.custom_coqtop := coqtop;
2949	2970	custom_project_files := project_files;
2950	2971	argv
2951
2952		let process_argv argv =
2953		try
2954		let continue,filtered = Coq.filter_coq_opts (List.tl argv) in
2955		if not continue then
2956		(List.iter Minilib.safe_prerr_endline filtered; exit 0);
2957		let opts = List.filter (fun arg -> String.get arg 0 == '-') filtered in
2958		if opts <> [] then
2959		(Minilib.safe_prerr_endline ("Illegal option: "^List.hd opts); exit 1);
2960		filtered
2961		with _ ->
2962		(Minilib.safe_prerr_endline "coqtop choked on one of your option"; exit 1)

+0

-3

ide/coqide.mli less more

14	14	(** Filter the argv from coqide specific options, and set
15	15	Minilib.coqtop_path accordingly *)
16	16	val read_coqide_args : string list -> string list
17
18		(** Ask coqtop the remaining options it doesn't recognize *)
19		val process_argv : string list -> string list
20	17
21	18	(** Prepare the widgets, load the given files in tabs *)
22	19	val main : string list -> unit

+15

-9

ide/coqide_main.ml4 less more

64	64	END
65	65
66	66	let () =
67		let argl = Array.to_list Sys.argv in
68		let argl = Coqide.read_coqide_args argl in
69		let files = Coqide.process_argv argl in
70		let args = List.filter (fun x -> not (List.mem x files)) (List.tl argl) in
71		Coq.check_connection args;
72		Coqide.sup_args := args;
73	67	Coqide.ignore_break ();
	68	ignore (GtkMain.Main.init ());
	69	initmac () ;
74	70	(try
75	71	let gtkrcdir = List.find
76	72	(fun x -> Sys.file_exists (Filename.concat x "coqide-gtk2rc"))
77	73	Minilib.xdg_config_dirs in
78	74	GtkMain.Rc.add_default_file (Filename.concat gtkrcdir "coqide-gtk2rc");
79	75	with Not_found -> ());
80		ignore (GtkMain.Main.init ());
81		initmac () ;
	76	(* Statup preferences *)
	77	begin
	78	try Preferences.load_pref ()
	79	with e ->
	80	Ideutils.flash_info ("Could not load preferences ("^Printexc.to_string e^").");
	81	end;
82	82	(* GtkData.AccelGroup.set_default_mod_mask
83	83	(Some [`CONTROL;`SHIFT;`MOD1;`MOD3;`MOD4]);*)
84	84	ignore (

88	88	if level land Glib.Message.log_level `WARNING <> 0
89	89	then Printf.eprintf "Warning: %s\n" msg
90	90	else failwith ("Coqide internal error: " ^ msg)));
91		Coqide.main files;
	91	let argl = Array.to_list Sys.argv in
	92	let argl = Coqide.read_coqide_args argl in
	93	let files = Coq.filter_coq_opts (List.tl argl) in
	94	let args = List.filter (fun x -> not (List.mem x files)) (List.tl argl) in
	95	Coq.check_connection args;
	96	Coqide.sup_args := args;
	97	Coqide.main files;
92	98	if !Coq_config.with_geoproof then ignore (Thread.create Coqide.check_for_geoproof_input ());
93	99	macready (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar") (Coqide_ui.ui_m#get_widget "/CoqIde MenuBar/Edit/Prefs")
94	100	(Coqide_ui.ui_m#get_widget "/CoqIde MenuBar/Help/Abt");

+16

-12

ide/coqide_ui.ml less more

55	55	<separator />
56	56	<menuitem name='Prefs' action='Preferences' />
57	57	</menu>
	58	<menu name='View' action='View'>
	59	<menuitem action='Previous tab' />
	60	<menuitem action='Next tab' />
	61	<separator/>
	62	<menuitem action='Show Toolbar' />
	63	<menuitem action='Show Query Pane' />
	64	<separator/>
	65	<menuitem action='Display implicit arguments' />
	66	<menuitem action='Display coercions' />
	67	<menuitem action='Display raw matching expressions' />
	68	<menuitem action='Display notations' />
	69	<menuitem action='Display all basic low-level contents' />
	70	<menuitem action='Display existential variable instances' />
	71	<menuitem action='Display universe levels' />
	72	<menuitem action='Display all low-level contents' />
	73	</menu>
58	74	<menu action='Navigation'>
59	75	<menuitem action='Forward' />
60	76	<menuitem action='Backward' />

99	115	<menuitem action='Locate' />
100	116	<menuitem action='Whelp Locate' />
101	117	</menu>
102		<menu action='Display'>
103		<menuitem action='Display implicit arguments' />
104		<menuitem action='Display coercions' />
105		<menuitem action='Display raw matching expressions' />
106		<menuitem action='Display notations' />
107		<menuitem action='Display all basic low-level contents' />
108		<menuitem action='Display existential variable instances' />
109		<menuitem action='Display universe levels' />
110		<menuitem action='Display all low-level contents' />
111		</menu>
112	118	<menu action='Compile'>
113	119	<menuitem action='Compile buffer' />
114	120	<menuitem action='Make' />

116	122	<menuitem action='Make makefile' />
117	123	</menu>
118	124	<menu action='Windows'>
119		<menuitem action='Show/Hide Query Pane' />
120		<menuitem action='Show/Hide Toolbar' />
121	125	<menuitem action='Detach View' />
122	126	</menu>
123	127	<menu name='Help' action='Help'>

+9

-7

ide/ideproof.ml less more

52	52	"%d subgoal%s\n" goals_cnt (if 1 < goals_cnt then "" else "s")
53	53	in
54	54	let goal_str index total = Printf.sprintf
55		"\n______________________________________(%d/%d)\n" index total
	55	"______________________________________(%d/%d)\n" index total
56	56	in
57	57	(* Insert current goal and its hypotheses *)
58	58	let hyps_hints, goal_hints = match hints with

75	75	let () = proof#buffer#insert head_str in
76	76	let () = insert_hyp hyps_hints hyps in
77	77	let () =
78		let tags = if goal_hints <> [] then
	78	let tags = Tags.Proof.goal :: if goal_hints <> [] then
79	79	let tag = proof#buffer#create_tag [] in
80	80	let () = hook_tag_cb tag goal_hints sel_cb on_hover in
81	81	[tag]
82	82	else []
83	83	in
84	84	proof#buffer#insert (goal_str 1 goals_cnt);
85		proof#buffer#insert ~tags (cur_goal ^ "\n")
	85	proof#buffer#insert ~tags cur_goal;
	86	proof#buffer#insert "\n"
86	87	in
87	88	(* Insert remaining goals (no hypotheses) *)
88	89	let fold_goal i _ { Interface.goal_ccl = g } =

90	91	proof#buffer#insert (g ^ "\n")
91	92	in
92	93	let () = Minilib.list_fold_left_i fold_goal 2 () rem_goals in
93		ignore(proof#buffer#place_cursor
94		~where:((proof#buffer#get_iter_at_mark `INSERT)#backward_lines (3*goals_cnt - 2)));
95		ignore(proof#scroll_to_mark `INSERT)
96	94
	95	ignore(proof#buffer#place_cursor
	96	~where:(proof#buffer#end_iter#backward_to_tag_toggle
	97	(Some Tags.Proof.goal)));
	98	ignore(proof#scroll_to_mark ~use_align:true ~yalign:0.95 `INSERT)
97	99
98	100	let mode_cesar (proof:GText.view) = function
99	101	\| [] -> assert false

122	124	in
123	125	List.iter iter evs
124	126	\| _ ->
125		view#buffer#insert "Proof Completed."
	127	view#buffer#insert "No more subgoals."
126	128	end
127	129	\| Some { Interface.fg_goals = []; Interface.bg_goals = bg } ->
128	130	(* No foreground proofs, but still unfocused ones *)

+63

-36

ide/ideutils.ml less more

62	62	let do_convert s =
63	63	Utf8_convert.f
64	64	(if Glib.Utf8.validate s then begin
65		prerr_endline "Input is UTF-8";s
66		end else
67		let from_loc () =
68		let _,char_set = Glib.Convert.get_charset () in
69		flash_info
70		("Converting from locale ("^char_set^")");
71		Glib.Convert.convert_with_fallback ~to_codeset:"UTF-8" ~from_codeset:char_set s
72		in
73		let from_manual () =
74		flash_info
75		("Converting from "^ !current.encoding_manual);
76		Glib.Convert.convert s ~to_codeset:"UTF-8" ~from_codeset:!current.encoding_manual
77		in
78		if !current.encoding_use_utf8 \|\| !current.encoding_use_locale then begin
79		try
80		from_loc ()
81		with _ -> from_manual ()
82		end else begin
83		try
84		from_manual ()
85		with _ -> from_loc ()
86		end)
	65	prerr_endline "Input is UTF-8";s
	66	end else
	67	let from_loc () =
	68	let _,char_set = Glib.Convert.get_charset () in
	69	flash_info
	70	("Converting from locale ("^char_set^")");
	71	Glib.Convert.convert_with_fallback ~to_codeset:"UTF-8" ~from_codeset:char_set s
	72	in
	73	let from_manual enc =
	74	flash_info
	75	("Converting from "^ enc);
	76	Glib.Convert.convert s ~to_codeset:"UTF-8" ~from_codeset:enc
	77	in
	78	match !current.encoding with
	79	\|Preferences.Eutf8 \| Preferences.Elocale -> from_loc ()
	80	\|Emanual enc ->
	81	try
	82	from_manual enc
	83	with _ -> from_loc ())
87	84
88	85	let try_convert s =
89	86	try

95	92
96	93	let try_export file_name s =
97	94	try let s =
98		try if !current.encoding_use_utf8 then begin
99		(prerr_endline "UTF-8 is enforced" ;s)
100		end else if !current.encoding_use_locale then begin
101		let is_unicode,char_set = Glib.Convert.get_charset () in
102		if is_unicode then
103		(prerr_endline "Locale is UTF-8" ;s)
104		else
105		(prerr_endline ("Locale is "^char_set);
106		Glib.Convert.convert_with_fallback ~from_codeset:"UTF-8" ~to_codeset:char_set s)
107		end else
108		(prerr_endline ("Manual charset is "^ !current.encoding_manual);
109		Glib.Convert.convert_with_fallback ~from_codeset:"UTF-8" ~to_codeset:!current.encoding_manual s)
	95	try match !current.encoding with
	96	\|Eutf8 -> begin
	97	(prerr_endline "UTF-8 is enforced" ;s)
	98	end
	99	\|Elocale -> begin
	100	let is_unicode,char_set = Glib.Convert.get_charset () in
	101	if is_unicode then
	102	(prerr_endline "Locale is UTF-8" ;s)
	103	else
	104	(prerr_endline ("Locale is "^char_set);
	105	Glib.Convert.convert_with_fallback ~from_codeset:"UTF-8" ~to_codeset:char_set s)
	106	end
	107	\|Emanual enc ->
	108	(prerr_endline ("Manual charset is "^ enc);
	109	Glib.Convert.convert_with_fallback ~from_codeset:"UTF-8" ~to_codeset:enc s)
110	110	with e -> (prerr_endline ("Error ("^(Printexc.to_string e)^") in transcoding: falling back to UTF-8") ;s)
111	111	in
112	112	let oc = open_out file_name in

251	251	in img#set_stock s;
252	252	img#coerce
253	253
	254	let custom_coqtop = ref None
	255
	256	let coqtop_path () =
	257	let file = match !custom_coqtop with
	258	\| Some s -> s
	259	\| None ->
	260	match !current.cmd_coqtop with
	261	\| Some s -> s
	262	\| None ->
	263	let prog = String.copy Sys.executable_name in
	264	try
	265	let pos = String.length prog - 6 in
	266	let i = Str.search_backward (Str.regexp_string "coqide") prog pos in
	267	String.blit "coqtop" 0 prog i 6;
	268	prog
	269	with Not_found -> "coqtop"
	270	in file
	271
254	272	let rec print_list print fmt = function
255	273	\| [] -> ()
256	274	\| [x] -> print fmt x
257	275	\| x :: r -> print fmt x; print_list print fmt r
258	276
	277	(* In win32, when a command-line is to be executed via cmd.exe
	278	(i.e. Sys.command, Unix.open_process, ...), it cannot contain several
	279	quoted "..." zones otherwise some quotes are lost. Solution: we re-quote
	280	everything. Reference: http://ss64.com/nt/cmd.html *)
	281
	282	let requote cmd = if Sys.os_type = "Win32" then "\""^cmd^"\"" else cmd
	283
259	284	(* TODO: allow to report output as soon as it comes (user-fiendlier
260	285	for long commands like make...) *)
261	286	let run_command f c =
	287	let c = requote c in
262	288	let result = Buffer.create 127 in
263	289	let cin,cout,cerr = Unix.open_process_full c (Unix.environment ()) in
264	290	let buff = String.make 127 ' ' in

278	304
279	305	let browse f url =
280	306	let com = Minilib.subst_command_placeholder !current.cmd_browse url in
281		let s = Sys.command com in
	307	let _ = Unix.open_process_out com in ()
	308	(* This beautiful message will wait for twt ...
282	309	if s = 127 then
283	310	f ("Could not execute\n\""^com^
284	311	"\"\ncheck your preferences for setting a valid browser command\n")
285
	312	*)
286	313	let doc_url () =
287	314	if !current.doc_url = use_default_doc_url \|\| !current.doc_url = "" then
288	315	let addr = List.fold_left Filename.concat (Coq_config.docdir) ["html";"refman";"index.html"] in

+13

-0

ide/ideutils.mli less more

51	51
52	52	val run_command : (string -> unit) -> string -> Unix.process_status*string
53	53
	54	val custom_coqtop : string option ref
	55	(* @return command to call coqtop
	56	- custom_coqtop if set
	57	- from the prefs is set
	58	- try to infer it else *)
	59	val coqtop_path : unit -> string
54	60
55	61
56	62	val status : GMisc.statusbar

66	72	returns an absolute filename equivalent to given filename
67	73	*)
68	74	val absolute_filename : string -> string
	75
	76	(* In win32, when a command-line is to be executed via cmd.exe
	77	(i.e. Sys.command, Unix.open_process, ...), it cannot contain several
	78	quoted "..." zones otherwise some quotes are lost. Solution: we re-quote
	79	everything. Reference: http://ss64.com/nt/cmd.html *)
	80
	81	val requote : string -> string

+35

-12

ide/minilib.ml less more

63	63	let subst_command_placeholder s t =
64	64	Str.global_replace (Str.regexp_string "%s") t s
65	65
66		let path_to_list p =
67		let sep = Str.regexp (if Sys.os_type = "Win32" then ";" else ":") in
68		Str.split sep p
	66	(* Split the content of a variable such as $PATH in a list of directories.
	67	The separators are either ":" in unix or ";" in win32 *)
	68
	69	let path_to_list = Str.split (Str.regexp "[:;]")
69	70
70	71	(* On win32, the home directory is probably not in $HOME, but in
71	72	some other environment variable *)

75	76	try (Sys.getenv "HOMEDRIVE")^(Sys.getenv "HOMEPATH") with Not_found ->
76	77	try Sys.getenv "USERPROFILE" with Not_found -> Filename.current_dir_name
77	78
	79	let opt2list = function None -> [] \| Some x -> [x]
	80
	81	let rec lconcat = function
	82	\| [] -> assert false
	83	\| [x] -> x
	84	\| x::l -> Filename.concat x (lconcat l)
	85
78	86	let xdg_config_home =
79	87	try
80	88	Filename.concat (Sys.getenv "XDG_CONFIG_HOME") "coq"
81	89	with Not_found ->
82		Filename.concat home "/.config/coq"
	90	lconcat [home;".config";"coq"]
	91
	92	let static_xdg_config_dirs =
	93	if Sys.os_type = "Win32" then
	94	let base = Filename.dirname (Filename.dirname Sys.executable_name) in
	95	[Filename.concat base "config"]
	96	else ["/etc/xdg/coq"]
83	97
84	98	let xdg_config_dirs =
85		xdg_config_home :: (try
86		List.map (fun dir -> Filename.concat dir "coq") (path_to_list (Sys.getenv "XDG_CONFIG_DIRS"))
87		with Not_found -> "/etc/xdg/coq"::(match Coq_config.configdir with \|None -> [] \|Some d -> [d]))
	99	xdg_config_home ::
	100	try
	101	List.map (fun dir -> Filename.concat dir "coq")
	102	(path_to_list (Sys.getenv "XDG_CONFIG_DIRS"))
	103	with Not_found -> static_xdg_config_dirs @ opt2list Coq_config.configdir
88	104
89	105	let xdg_data_home =
90	106	try
91	107	Filename.concat (Sys.getenv "XDG_DATA_HOME") "coq"
92	108	with Not_found ->
93		Filename.concat home "/.local/share/coq"
	109	lconcat [home;".local";"share";"coq"]
	110
	111	let static_xdg_data_dirs =
	112	if Sys.os_type = "Win32" then
	113	let base = Filename.dirname (Filename.dirname Sys.executable_name) in
	114	[Filename.concat base "share"]
	115	else ["/usr/local/share/coq";"/usr/share/coq"]
94	116
95	117	let xdg_data_dirs =
96		xdg_data_home :: (try
97		List.map (fun dir -> Filename.concat dir "coq") (path_to_list (Sys.getenv "XDG_DATA_DIRS"))
98		with Not_found ->
99		"/usr/local/share/coq"::"/usr/share/coq"::(match Coq_config.datadir with \|None -> [] \|Some d -> [d]))
	118	xdg_data_home ::
	119	try
	120	List.map (fun dir -> Filename.concat dir "coq")
	121	(path_to_list (Sys.getenv "XDG_DATA_DIRS"))
	122	with Not_found -> static_xdg_data_dirs @ opt2list Coq_config.datadir
100	123
101	124	let coqtop_path = ref ""
102	125

+144

-68

ide/preferences.ml less more

9	9	open Printf
10	10
11	11	let pref_file = Filename.concat Minilib.xdg_config_home "coqiderc"
12
13	12	let accel_file = Filename.concat Minilib.xdg_config_home "coqide.keys"
	13
	14	let get_config_file name =
	15	let find_config dir = Sys.file_exists (Filename.concat dir name) in
	16	let config_dir = List.find find_config Minilib.xdg_config_dirs in
	17	Filename.concat config_dir name
	18
	19	(* Small hack to handle v8.3 to v8.4 change in configuration file *)
	20	let loaded_pref_file =
	21	try get_config_file "coqiderc"
	22	with Not_found -> Filename.concat Minilib.home ".coqiderc"
	23
	24	let loaded_accel_file =
	25	try get_config_file "coqide.keys"
	26	with Not_found -> Filename.concat Minilib.home ".coqide.keys"
14	27
15	28	let mod_to_str (m:Gdk.Tags.modifier) =
16	29	match m with

39	52	else if s = "appended to arguments" then Append_args
40	53	else Ignore_args
41	54
	55	type inputenc = Elocale \| Eutf8 \| Emanual of string
	56
	57	let string_of_inputenc = function
	58	\|Elocale -> "LOCALE"
	59	\|Eutf8 -> "UTF-8"
	60	\|Emanual s -> s
	61
	62	let inputenc_of_string s =
	63	(if s = "UTF-8" then Eutf8
	64	else if s = "LOCALE" then Elocale
	65	else Emanual s)
	66
	67
	68	(** Hooks *)
	69
	70	let refresh_font_hook = ref (fun () -> ())
	71	let refresh_background_color_hook = ref (fun () -> ())
	72	let refresh_toolbar_hook = ref (fun () -> ())
	73	let auto_complete_hook = ref (fun x -> ())
	74	let contextual_menus_on_goal_hook = ref (fun x -> ())
	75	let resize_window_hook = ref (fun () -> ())
	76	let refresh_tabs_hook = ref (fun () -> ())
	77
42	78	type pref =
43	79	{
	80	mutable cmd_coqtop : string option;
44	81	mutable cmd_coqc : string;
45	82	mutable cmd_make : string;
46	83	mutable cmd_coqmakefile : string;

56	93	mutable read_project : project_behavior;
57	94	mutable project_file_name : string;
58	95
59		mutable encoding_use_locale : bool;
60		mutable encoding_use_utf8 : bool;
61		mutable encoding_manual : string;
	96	mutable encoding : inputenc;
62	97
63	98	mutable automatic_tactics : string list;
64	99	mutable cmd_print : string;

88	123	*)
89	124	mutable auto_complete : bool;
90	125	mutable stop_before : bool;
91		mutable lax_syntax : bool;
92	126	mutable vertical_tabs : bool;
93	127	mutable opposite_tabs : bool;
	128
	129	mutable background_color : string;
	130	mutable processing_color : string;
	131	mutable processed_color : string;
	132
94	133	}
95	134
96	135	let use_default_doc_url = "(automatic)"
97	136
98	137	let (current:pref ref) =
99	138	ref {
	139	cmd_coqtop = None;
100	140	cmd_coqc = "coqc";
101	141	cmd_make = "make";
102	142	cmd_coqmakefile = "coq_makefile -o makefile *.v";

113	153	read_project = Ignore_args;
114	154	project_file_name = "_CoqProject";
115	155
116		encoding_use_locale = true;
117		encoding_use_utf8 = false;
118		encoding_manual = "ISO_8859-1";
	156	encoding = if Sys.os_type = "Win32" then Eutf8 else Elocale;
119	157
120	158	automatic_tactics = ["trivial"; "tauto"; "auto"; "omega";
121	159	"auto with *"; "intuition" ];

149	187	*)
150	188	auto_complete = false;
151	189	stop_before = true;
152		lax_syntax = true;
153	190	vertical_tabs = false;
154	191	opposite_tabs = false;
	192
	193	background_color = "cornsilk";
	194	processed_color = "light green";
	195	processing_color = "light blue";
	196
155	197	}
156
157
158		let change_font = ref (fun f -> ())
159
160		let show_toolbar = ref (fun x -> ())
161
162		let auto_complete = ref (fun x -> ())
163
164		let contextual_menus_on_goal = ref (fun x -> ())
165
166		let resize_window = ref (fun () -> ())
167	198
168	199	let save_pref () =
169	200	if not (Sys.file_exists Minilib.xdg_config_home)
170	201	then Unix.mkdir Minilib.xdg_config_home 0o700;
171		(try GtkData.AccelMap.save accel_file
172		with _ -> ());
	202	let () = try GtkData.AccelMap.save accel_file with _ -> () in
173	203	let p = !current in
174	204
175	205	let add = Minilib.Stringmap.add in
176	206	let (++) x f = f x in
177	207	Minilib.Stringmap.empty ++
	208	add "cmd_coqtop" (match p.cmd_coqtop with \| None -> [] \| Some v-> [v]) ++
178	209	add "cmd_coqc" [p.cmd_coqc] ++
179	210	add "cmd_make" [p.cmd_make] ++
180	211	add "cmd_coqmakefile" [p.cmd_coqmakefile] ++

189	220	add "project_options" [string_of_project_behavior p.read_project] ++
190	221	add "project_file_name" [p.project_file_name] ++
191	222
192		add "encoding_use_locale" [string_of_bool p.encoding_use_locale] ++
193		add "encoding_use_utf8" [string_of_bool p.encoding_use_utf8] ++
194		add "encoding_manual" [p.encoding_manual] ++
	223	add "encoding" [string_of_inputenc p.encoding] ++
195	224
196	225	add "automatic_tactics" p.automatic_tactics ++
197	226	add "cmd_print" [p.cmd_print] ++

216	245	add "query_window_width" [string_of_int p.query_window_width] ++
217	246	add "auto_complete" [string_of_bool p.auto_complete] ++
218	247	add "stop_before" [string_of_bool p.stop_before] ++
219		add "lax_syntax" [string_of_bool p.lax_syntax] ++
220	248	add "vertical_tabs" [string_of_bool p.vertical_tabs] ++
221	249	add "opposite_tabs" [string_of_bool p.opposite_tabs] ++
	250	add "background_color" [p.background_color] ++
	251	add "processing_color" [p.processing_color] ++
	252	add "processed_color" [p.processed_color] ++
222	253	Config_lexer.print_file pref_file
223	254
224	255	let load_pref () =
225		let accel_dir = List.find
226		(fun x -> Sys.file_exists (Filename.concat x "coqide.keys"))
227		Minilib.xdg_config_dirs in
228		GtkData.AccelMap.load (Filename.concat accel_dir "coqide.keys");
	256	let () = try GtkData.AccelMap.load loaded_accel_file with _ -> () in
229	257	let p = !current in
230	258
231		let m = Config_lexer.load_file pref_file in
	259	let m = Config_lexer.load_file loaded_pref_file in
232	260	let np = { p with cmd_coqc = p.cmd_coqc } in
233	261	let set k f = try let v = Minilib.Stringmap.find k m in f v with _ -> () in
234	262	let set_hd k f = set k (fun v -> f (List.hd v)) in

238	266	let set_command_with_pair_compat k f =
239	267	set k (function [v1;v2] -> f (v1^"%s"^v2) \| [v] -> f v \| _ -> raise Exit)
240	268	in
	269	let set_option k f = set k (fun v -> f (match v with \|[] -> None \|h::_ -> Some h)) in
	270	set_option "cmd_coqtop" (fun v -> np.cmd_coqtop <- v);
241	271	set_hd "cmd_coqc" (fun v -> np.cmd_coqc <- v);
242	272	set_hd "cmd_make" (fun v -> np.cmd_make <- v);
243	273	set_hd "cmd_coqmakefile" (fun v -> np.cmd_coqmakefile <- v);

248	278	set_bool "auto_save" (fun v -> np.auto_save <- v);
249	279	set_int "auto_save_delay" (fun v -> np.auto_save_delay <- v);
250	280	set_pair "auto_save_name" (fun v1 v2 -> np.auto_save_name <- (v1,v2));
251		set_bool "encoding_use_locale" (fun v -> np.encoding_use_locale <- v);
252		set_bool "encoding_use_utf8" (fun v -> np.encoding_use_utf8 <- v);
253		set_hd "encoding_manual" (fun v -> np.encoding_manual <- v);
	281	set_hd "encoding_manual" (fun v -> np.encoding <- (inputenc_of_string v));
254	282	set_hd "project_options"
255	283	(fun v -> np.read_project <- (project_behavior_of_string v));
256	284	set_hd "project_file_name" (fun v -> np.project_file_name <- v);

289	317	set_int "query_window_height" (fun v -> np.query_window_height <- v);
290	318	set_bool "auto_complete" (fun v -> np.auto_complete <- v);
291	319	set_bool "stop_before" (fun v -> np.stop_before <- v);
292		set_bool "lax_syntax" (fun v -> np.lax_syntax <- v);
293	320	set_bool "vertical_tabs" (fun v -> np.vertical_tabs <- v);
294	321	set_bool "opposite_tabs" (fun v -> np.opposite_tabs <- v);
	322	set_hd "background_color" (fun v -> np.background_color <- v);
	323	set_hd "processing_color" (fun v -> np.processing_color <- v);
	324	set_hd "processed_color" (fun v -> np.processed_color <- v);
295	325	current := np
296	326	(*
297	327	Format.printf "in load_pref: current.text_font = %s@." (Pango.Font.to_string !current.text_font);
298	328	*)
299	329
300	330	let configure ?(apply=(fun () -> ())) () =
	331	let cmd_coqtop =
	332	string
	333	~f:(fun s -> !current.cmd_coqtop <- if s = "AUTO" then None else Some s)
	334	" coqtop" (match !current.cmd_coqtop with \|None -> "AUTO" \| Some x -> x) in
301	335	let cmd_coqc =
302	336	string
303	337	~f:(fun s -> !current.cmd_coqc <- s)

324	358	let w = GMisc.font_selection () in
325	359	w#set_preview_text
326	360	"Goal (∃n : nat, n ≤ 0)∧(∀x,y,z, x∈y⋃z↔x∈y∨x∈z).";
327		box#pack w#coerce;
	361	box#pack ~expand:true w#coerce;
328	362	ignore (w#misc#connect#realize
329	363	~callback:(fun () -> w#set_font_name
330	364	(Pango.Font.to_string !current.text_font)));

337	371	(*
338	372	Format.printf "in config_font: current.text_font = %s@." (Pango.Font.to_string !current.text_font);
339	373	*)
340		!change_font !current.text_font)
	374	!refresh_font_hook ())
341	375	true
342	376	in
	377
	378	let config_color =
	379	let box = GPack.vbox () in
	380	let table = GPack.table
	381	~row_spacings:5
	382	~col_spacings:5
	383	~border_width:2
	384	~packing:(box#pack ~expand:true) ()
	385	in
	386	let background_label = GMisc.label
	387	~text:"Background color"
	388	~packing:(table#attach ~expand:`X ~left:0 ~top:0) ()
	389	in
	390	let processed_label = GMisc.label
	391	~text:"Background color of processed text"
	392	~packing:(table#attach ~expand:`X ~left:0 ~top:1) ()
	393	in
	394	let processing_label = GMisc.label
	395	~text:"Background color of text being processed"
	396	~packing:(table#attach ~expand:`X ~left:0 ~top:2) ()
	397	in
	398	let () = background_label#set_xalign 0. in
	399	let () = processed_label#set_xalign 0. in
	400	let () = processing_label#set_xalign 0. in
	401	let background_button = GButton.color_button
	402	~color:(Tags.color_of_string (!current.background_color))
	403	~packing:(table#attach ~left:1 ~top:0) ()
	404	in
	405	let processed_button = GButton.color_button
	406	~color:(Tags.get_processed_color ())
	407	~packing:(table#attach ~left:1 ~top:1) ()
	408	in
	409	let processing_button = GButton.color_button
	410	~color:(Tags.get_processing_color ())
	411	~packing:(table#attach ~left:1 ~top:2) ()
	412	in
	413	let reset_button = GButton.button
	414	~label:"Reset"
	415	~packing:box#pack ()
	416	in
	417	let reset_cb () =
	418	background_button#set_color (Tags.color_of_string "cornsilk");
	419	processing_button#set_color (Tags.color_of_string "light blue");
	420	processed_button#set_color (Tags.color_of_string "light green");
	421	in
	422	let _ = reset_button#connect#clicked ~callback:reset_cb in
	423	let label = "Color configuration" in
	424	let callback () =
	425	!current.background_color <- Tags.string_of_color background_button#color;
	426	!current.processing_color <- Tags.string_of_color processing_button#color;
	427	!current.processed_color <- Tags.string_of_color processed_button#color;
	428	!refresh_background_color_hook ();
	429	Tags.set_processing_color processing_button#color;
	430	Tags.set_processed_color processed_button#color
	431	in
	432	custom ~label box callback true
	433	in
	434
343	435	(*
344	436	let show_toolbar =
345	437	bool

368	460	bool
369	461	~f:(fun s ->
370	462	!current.auto_complete <- s;
371		!auto_complete s)
	463	!auto_complete_hook s)
372	464	"Auto Complete" !current.auto_complete
373	465	in
374	466

415	507	"Stop interpreting before the current point" !current.stop_before
416	508	in
417	509
418		let lax_syntax =
419		bool
420		~f:(fun s -> !current.lax_syntax <- s)
421		"Relax read-only constraint at end of command" !current.lax_syntax
422		in
423
424	510	let vertical_tabs =
425	511	bool
426		~f:(fun s -> !current.vertical_tabs <- s)
	512	~f:(fun s -> !current.vertical_tabs <- s; !refresh_tabs_hook ())
427	513	"Vertical tabs" !current.vertical_tabs
428	514	in
429	515
430	516	let opposite_tabs =
431	517	bool
432		~f:(fun s -> !current.opposite_tabs <- s)
	518	~f:(fun s -> !current.opposite_tabs <- s; !refresh_tabs_hook ())
433	519	"Tabs on opposite side" !current.opposite_tabs
434	520	in
435	521
436	522	let encodings =
437	523	combo
438	524	"File charset encoding "
439		~f:(fun s ->
440		match s with
441		\| "UTF-8" ->
442		!current.encoding_use_utf8 <- true;
443		!current.encoding_use_locale <- false
444		\| "LOCALE" ->
445		!current.encoding_use_utf8 <- false;
446		!current.encoding_use_locale <- true
447		\| _ ->
448		!current.encoding_use_utf8 <- false;
449		!current.encoding_use_locale <- false;
450		!current.encoding_manual <- s;
451		)
	525	~f:(fun s -> !current.encoding <- (inputenc_of_string s))
452	526	~new_allowed: true
453		["UTF-8";"LOCALE";!current.encoding_manual]
454		(if !current.encoding_use_utf8 then "UTF-8"
455		else if !current.encoding_use_locale then "LOCALE" else !current.encoding_manual)
	527	("UTF-8"::"LOCALE":: match !current.encoding with
	528	\|Emanual s -> [s]
	529	\|_ -> []
	530	)
	531	(string_of_inputenc !current.encoding)
456	532	in
457	533	let read_project =
458	534	combo

578	654	bool
579	655	~f:(fun s ->
580	656	!current.contextual_menus_on_goal <- s;
581		!contextual_menus_on_goal s)
	657	!contextual_menus_on_goal_hook s)
582	658	"Contextual menus on goal" !current.contextual_menus_on_goal
583	659	in
584	660
585		let misc = [contextual_menus_on_goal;auto_complete;stop_before;lax_syntax;
	661	let misc = [contextual_menus_on_goal;auto_complete;stop_before;
586	662	vertical_tabs;opposite_tabs] in
587	663
588	664	(* ATTENTION !!!!! L'onglet Fonts doit etre en premier pour eviter un bug !!!!

590	666	let cmds =
591	667	[Section("Fonts", Some `SELECT_FONT,
592	668	[config_font]);
	669	Section("Colors", Some `SELECT_COLOR, [config_color]);
593	670	Section("Files", Some `DIRECTORY,
594	671	[global_auto_revert;global_auto_revert_delay;
595	672	auto_save; auto_save_delay; (* auto_save_name*)

603	680	config_appearance);
604	681	*)
605	682	Section("Externals", None,
606		[cmd_coqc;cmd_make;cmd_coqmakefile; cmd_coqdoc; cmd_print;
607		cmd_editor;
608		cmd_browse;doc_url;library_url]);
	683	[cmd_coqtop;cmd_coqc;cmd_make;cmd_coqmakefile; cmd_coqdoc;
	684	cmd_print;cmd_editor;cmd_browse;doc_url;library_url]);
609	685	Section("Tactics Wizard", None,
610	686	[automatic_tactics]);
611	687	Section("Shortcuts", Some `PREFERENCES,

617	693	(*
618	694	Format.printf "before edit: current.text_font = %s@." (Pango.Font.to_string !current.text_font);
619	695	*)
620		let x = edit ~apply ~width:500 "Customizations" cmds in
	696	let x = edit ~apply "Customizations" cmds in
621	697	(*
622	698	Format.printf "after edit: current.text_font = %s@." (Pango.Font.to_string !current.text_font);
623	699	*)

+13

-8

ide/preferences.mli less more

6	6	(************************************************************************)
7	7
8	8	type project_behavior = Ignore_args \| Append_args \| Subst_args
	9	type inputenc = Elocale \| Eutf8 \| Emanual of string
9	10
10	11	type pref =
11	12	{
	13	mutable cmd_coqtop : string option;
12	14	mutable cmd_coqc : string;
13	15	mutable cmd_make : string;
14	16	mutable cmd_coqmakefile : string;

24	26	mutable read_project : project_behavior;
25	27	mutable project_file_name : string;
26	28
27		mutable encoding_use_locale : bool;
28		mutable encoding_use_utf8 : bool;
29		mutable encoding_manual : string;
	29	mutable encoding : inputenc;
30	30
31	31	mutable automatic_tactics : string list;
32	32	mutable cmd_print : string;

56	56	*)
57	57	mutable auto_complete : bool;
58	58	mutable stop_before : bool;
59		mutable lax_syntax : bool;
60	59	mutable vertical_tabs : bool;
61	60	mutable opposite_tabs : bool;
	61
	62	mutable background_color : string;
	63	mutable processing_color : string;
	64	mutable processed_color : string;
62	65	}
63	66
64	67	val save_pref : unit -> unit

68	71
69	72	val configure : ?apply:(unit -> unit) -> unit -> unit
70	73
71		val change_font : ( Pango.font_description -> unit) ref
72		val show_toolbar : (bool -> unit) ref
73		val auto_complete : (bool -> unit) ref
74		val resize_window : (unit -> unit) ref
	74	(* Hooks *)
	75	val refresh_font_hook : (unit -> unit) ref
	76	val refresh_background_color_hook : (unit -> unit) ref
	77	val refresh_toolbar_hook : (unit -> unit) ref
	78	val resize_window_hook : (unit -> unit) ref
	79	val refresh_tabs_hook : (unit -> unit) ref
75	80
76	81	val use_default_doc_url : string

+30

-3

ide/tags.ml less more

12	12	tt#add new_tag#as_tag;
13	13	new_tag
14	14
	15	let processed_color = ref "light green"
	16	let processing_color = ref "light blue"
	17
15	18	module Script =
16	19	struct
17	20	let table = GText.tag_table ()

22	25	let comment = make_tag table ~name:"comment" [`FOREGROUND "brown"]
23	26	let reserved = make_tag table ~name:"reserved" [`FOREGROUND "dark red"]
24	27	let error = make_tag table ~name:"error" [`UNDERLINE `DOUBLE ; `FOREGROUND "red"]
25		let to_process = make_tag table ~name:"to_process" [`BACKGROUND "light blue" ;`EDITABLE false]
26		let processed = make_tag table ~name:"processed" [`BACKGROUND "light green" ;`EDITABLE false]
	28	let to_process = make_tag table ~name:"to_process" [`BACKGROUND !processing_color ;`EDITABLE false]
	29	let processed = make_tag table ~name:"processed" [`BACKGROUND !processed_color;`EDITABLE false]
27	30	let unjustified = make_tag table ~name:"unjustified" [`UNDERLINE `SINGLE; `FOREGROUND "red"; `BACKGROUND "gold";`EDITABLE false]
28	31	let found = make_tag table ~name:"found" [`BACKGROUND "blue"; `FOREGROUND "white"]
29	32	let hidden = make_tag table ~name:"hidden" [`INVISIBLE true; `EDITABLE false]

34	37	module Proof =
35	38	struct
36	39	let table = GText.tag_table ()
37		let highlight = make_tag table ~name:"highlight" [`BACKGROUND "light green"]
	40	let highlight = make_tag table ~name:"highlight" [`BACKGROUND !processed_color]
38	41	let hypothesis = make_tag table ~name:"hypothesis" []
39	42	let goal = make_tag table ~name:"goal" []
40	43	end

44	47	let error = make_tag table ~name:"error" [`FOREGROUND "red"]
45	48	end
46	49
	50	let string_of_color clr =
	51	let r = Gdk.Color.red clr in
	52	let g = Gdk.Color.green clr in
	53	let b = Gdk.Color.blue clr in
	54	Printf.sprintf "#%04X%04X%04X" r g b
	55
	56	let color_of_string s =
	57	let colormap = Gdk.Color.get_system_colormap () in
	58	Gdk.Color.alloc ~colormap (`NAME s)
	59
	60	let get_processed_color () = color_of_string !processed_color
	61
	62	let set_processed_color clr =
	63	let s = string_of_color clr in
	64	processed_color := s;
	65	Script.processed#set_property (`BACKGROUND s);
	66	Proof.highlight#set_property (`BACKGROUND s)
	67
	68	let get_processing_color () = color_of_string !processing_color
	69
	70	let set_processing_color clr =
	71	let s = string_of_color clr in
	72	processing_color := s;
	73	Script.to_process#set_property (`BACKGROUND s)

+50

-0

ide/tags.mli less more

	0	(************************************************************************)
	1	(* v * The Coq Proof Assistant / The Coq Development Team *)
	2	(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
	3	(* \VV/ **************************************************************)
	4	(* // * This file is distributed under the terms of the *)
	5	(* * GNU Lesser General Public License Version 2.1 *)
	6	(************************************************************************)
	7
	8	module Script :
	9	sig
	10	val table : GText.tag_table
	11	val kwd : GText.tag
	12	val qed : GText.tag
	13	val decl : GText.tag
	14	val proof_decl : GText.tag
	15	val comment : GText.tag
	16	val reserved : GText.tag
	17	val error : GText.tag
	18	val to_process : GText.tag
	19	val processed : GText.tag
	20	val unjustified : GText.tag
	21	val found : GText.tag
	22	val hidden : GText.tag
	23	val folded : GText.tag
	24	val paren : GText.tag
	25	val sentence : GText.tag
	26	end
	27
	28	module Proof :
	29	sig
	30	val table : GText.tag_table
	31	val highlight : GText.tag
	32	val hypothesis : GText.tag
	33	val goal : GText.tag
	34	end
	35
	36	module Message :
	37	sig
	38	val table : GText.tag_table
	39	val error : GText.tag
	40	end
	41
	42	val string_of_color : Gdk.color -> string
	43	val color_of_string : string -> Gdk.color
	44
	45	val get_processed_color : unit -> Gdk.color
	46	val set_processed_color : Gdk.color -> unit
	47
	48	val get_processing_color : unit -> Gdk.color
	49	val set_processing_color : Gdk.color -> unit

+2

-2

ide/utils/configwin.ml less more

59	59
60	60	let edit
61	61	?(apply=(fun () -> ()))
62		title ?(width=400) ?(height=400)
	62	title ?width ?height
63	63	conf_struct_list =
64		Configwin_ihm.edit ~with_apply: true ~apply title ~width ~height conf_struct_list
	64	Configwin_ihm.edit ~with_apply: true ~apply title ?width ?height conf_struct_list
65	65
66	66	let get = Configwin_ihm.edit ~with_apply: false ~apply: (fun () -> ())
67	67

+3

-3

ide/utils/configwin_ihm.ml less more

1021	1021
1022	1022	let rec make_tree iter conf_struct =
1023	1023	(* box is not shown at first *)
1024		let box = GPack.vbox ~packing:menu_box#add ~show:false () in
	1024	let box = GPack.vbox ~packing:(menu_box#pack ~expand:true) ~show:false () in
1025	1025	let new_iter = match iter with
1026	1026	\| None -> tree#append ()
1027	1027	\| Some parent -> tree#append ~parent ()

1135	1135	to configure the various parameters. *)
1136	1136	let edit ?(with_apply=true)
1137	1137	?(apply=(fun () -> ()))
1138		title ?(width=400) ?(height=400)
	1138	title ?width ?height
1139	1139	conf_struct =
1140	1140	let dialog = GWindow.dialog
1141	1141	~position:`CENTER
1142	1142	~modal: true ~title: title
1143		~height ~width
	1143	?height ?width
1144	1144	()
1145	1145	in
1146	1146	let tooltips = GData.tooltips () in

+35

-19

interp/constrextern.ml less more

139	139	let debug_global_reference_printer =
140	140	ref (fun _ -> failwith "Cannot print a global reference")
141	141
	142	let in_debugger = ref false
	143
142	144	let set_debug_global_reference_printer f =
143	145	debug_global_reference_printer := f
144	146
145	147	let extern_reference loc vars r =
146		try Qualid (loc,shortest_qualid_of_global vars r)
147		with Not_found ->
148		(* happens in debugger *)
	148	if !in_debugger then
	149	(* Debugger does not have the tables of global reference at hand *)
149	150	!debug_global_reference_printer loc r
	151	else
	152	Qualid (loc,shortest_qualid_of_global vars r)
	153
150	154
151	155	(************************************************************************)
152	156	(* Equality up to location (useful for translator v8) *)

343	347	let args = List.map (extern_cases_pattern_in_scope scopes vars) args in
344	348	let p =
345	349	try
346		if !Flags.raw_print then raise Exit;
	350	if !in_debugger \|\| !Flags.raw_print then raise Exit;
347	351	let projs = Recordops.lookup_projections (fst cstrsp) in
348	352	let rec ip projs args acc =
349	353	match projs with

446	450	(* Implicit args indexes are in ascending order *)
447	451	(* inctx is useful only if there is a last argument to be deduced from ctxt *)
448	452	let explicitize loc inctx impl (cf,f) args =
	453	let impl = if !Constrintern.parsing_explicit then [] else impl in
449	454	let n = List.length args in
450	455	let rec exprec q = function
451	456	\| a::args, imp::impl when is_status_implicit imp ->

481	486	if args = [] then f else CApp (loc, (None, f), args)
482	487
483	488	let extern_global loc impl f =
484		if impl <> [] & List.for_all is_status_implicit impl then
	489	if not !Constrintern.parsing_explicit &&
	490	impl <> [] && List.for_all is_status_implicit impl
	491	then
485	492	CAppExpl (loc, (None, f), [])
486	493	else
487	494	CRef f

490	497	if args = [] (* maybe caused by a hidden coercion *) then
491	498	extern_global loc impl f
492	499	else
493		if
	500	if not !Constrintern.parsing_explicit &&
494	501	((!Flags.raw_print or
495	502	(!print_implicits & not !print_implicits_explicit_args)) &
496	503	List.exists is_status_implicit impl)

760	767	and factorize_lambda inctx scopes vars aty c =
761	768	try
762	769	if !Flags.raw_print or !print_no_symbol then raise No_match;
763		([],extern_symbol scopes vars c (uninterp_notations c))
	770	([],extern_symbol (Some Notation.type_scope,snd scopes) vars c (uninterp_notations c))
764	771	with No_match -> match c with
765	772	\| GLambda (loc,na,bk,ty,c)
766	773	when same aty (extern_typ scopes vars (anonymize_if_reserved na ty))

888	895
889	896	let loc = dummy_loc (* for constr and pattern, locations are lost *)
890	897
891		let extern_constr_gen at_top scopt env t =
892		let avoid = if at_top then ids_of_context env else [] in
893		let r = Detyping.detype at_top avoid (names_of_rel_context env) t in
	898	let extern_constr_gen goal_concl_style scopt env t =
	899	(* "goal_concl_style" means do alpha-conversion using the "goal" convention *)
	900	(* i.e.: avoid using the names of goal/section/rel variables and the short *)
	901	(* names of global definitions of current module when computing names for *)
	902	(* bound variables. *)
	903	(* Not "goal_concl_style" means do alpha-conversion avoiding only *)
	904	(* those goal/section/rel variables that occurs in the subterm under *)
	905	(* consideration; see namegen.ml for further details *)
	906	let avoid = if goal_concl_style then ids_of_context env else [] in
	907	let rel_env_names = names_of_rel_context env in
	908	let r = Detyping.detype goal_concl_style avoid rel_env_names t in
894	909	let vars = vars_of_env env in
895	910	extern false (scopt,[]) vars r
896	911
897		let extern_constr_in_scope at_top scope env t =
898		extern_constr_gen at_top (Some scope) env t
899
900		let extern_constr at_top env t =
901		extern_constr_gen at_top None env t
902
903		let extern_type at_top env t =
904		let avoid = if at_top then ids_of_context env else [] in
905		let r = Detyping.detype at_top avoid (names_of_rel_context env) t in
	912	let extern_constr_in_scope goal_concl_style scope env t =
	913	extern_constr_gen goal_concl_style (Some scope) env t
	914
	915	let extern_constr goal_concl_style env t =
	916	extern_constr_gen goal_concl_style None env t
	917
	918	let extern_type goal_concl_style env t =
	919	let avoid = if goal_concl_style then ids_of_context env else [] in
	920	let rel_env_names = names_of_rel_context env in
	921	let r = Detyping.detype goal_concl_style avoid rel_env_names t in
906	922	extern_glob_type (vars_of_env env) r
907	923
908	924	let extern_sort s = extern_glob_sort (detype_sort s)

+1

-0

interp/constrextern.mli less more

52	52	(** Debug printing options *)
53	53	val set_debug_global_reference_printer :
54	54	(loc -> global_reference -> reference) -> unit
	55	val in_debugger : bool ref
55	56
56	57	(** This governs printing of implicit arguments. If [with_implicits] is
57	58	on and not [with_arguments] then implicit args are printed prefixed

+41

-29

interp/constrintern.ml less more

164	164	(**********************************************************************)
165	165	(* Pre-computing the implicit arguments and arguments scopes needed *)
166	166	(* for interpretation *)
	167
	168	let parsing_explicit = ref false
167	169
168	170	let empty_internalization_env = Idmap.empty
169	171

407	409	\| LocalRawAssum(nal,bk,ty) ->
408	410	(match bk with
409	411	\| Default k ->
410		let (loc,na) = List.hd nal in
411		(* TODO: fail if several names with different implicit types *)
412		let ty = locate_if_isevar loc na (intern_type env ty) in
	412	let ty = intern_type env ty in
	413	let impls = impls_type_list ty in
413	414	List.fold_left
414		(fun (env,bl) na ->
415		(push_name_env lvar (impls_type_list ty) env na,(snd na,k,None,ty)::bl))
	415	(fun (env,bl) (loc,na as locna) ->
	416	(push_name_env lvar impls env locna,
	417	(na,k,None,locate_if_isevar loc na ty)::bl))
416	418	(env,bl) nal
417	419	\| Generalized (b,b',t) ->
418	420	let env, b = intern_generalized_binder ~global_level intern_type lvar env bl (List.hd nal) b b' t ty in

451	453	let intern_type env = intern (set_type_scope env) in
452	454	(match bk with
453	455	\| Default k ->
454		let (loc,na) = List.hd nal in
455		(* TODO: fail if several names with different implicit types *)
456	456	let ty = intern_type env ty in
457		let ty = locate_if_isevar loc na ty in
	457	let impls = impls_type_list ty in
458	458	List.fold_left
459		(fun (env,bl) na -> (push_name_env lvar (impls_type_list ty) env na,(snd na,k,None,ty)::bl))
	459	(fun (env,bl) (loc,na as locna) ->
	460	(push_name_env lvar impls env locna,
	461	(na,k,None,locate_if_isevar loc na ty)::bl))
460	462	(env,bl) nal
461	463	\| Generalized (b,b',t) ->
462	464	let env, b = intern_generalized_binder intern_type lvar env bl (List.hd nal) b b' t ty in

730	732	\| [] -> {env with tmp_scope = None}, []
731	733	\| sc::scl -> {env with tmp_scope = sc}, scl
732	734
733		let rec simple_adjust_scopes n = function
734		\| [] -> if n=0 then [] else None :: simple_adjust_scopes (n-1) []
	735	let rec simple_adjust_scopes n scopes =
	736	if n=0 then [] else match scopes with
	737	\| [] -> None :: simple_adjust_scopes (n-1) []
735	738	\| sc::scopes -> sc :: simple_adjust_scopes (n-1) scopes
736	739
737	740	let find_remaining_constructor_scopes pl1 pl2 (ind,j as cstr) =

807	810	(str "Alias variable " ++ pr_id id1 ++ str " is merged with " ++ pr_id id2)
808	811
809	812	(* Expanding notations *)
810
811		let error_invalid_pattern_notation loc =
812		user_err_loc (loc,"",str "Invalid notation for pattern.")
813	813
814	814	let chop_aconstr_constructor loc (ind,k) args =
815	815	if List.length args = 0 then (* Tolerance for a @id notation *) args else

1292	1292	find_appl_head_data c, args
1293	1293	\| x -> (intern env f,[],[],[]), args in
1294	1294	let args =
1295		intern_impargs c env impargs args_scopes (merge_impargs l args) in
	1295	intern_impargs c env impargs args_scopes (merge_impargs l args) in
1296	1296	check_projection isproj (List.length args) c;
1297	1297	(match c with
1298	1298	(* Now compact "(f args') args" *)

1416	1416	(tm',(snd na,typ)), na::ids
1417	1417
1418	1418	and iterate_prod loc2 env bk ty body nal =
1419		let rec default env bk = function
1420		\| (loc1,na as locna)::nal ->
1421		if nal <> [] then check_capture loc1 ty na;
1422		let ty = locate_if_isevar loc1 na (intern_type env ty) in
1423		let body = default (push_name_env lvar (impls_type_list ty) env locna) bk nal in
1424		GProd (join_loc loc1 loc2, na, bk, ty, body)
1425		\| [] -> intern_type env body
	1419	let default env bk = function
	1420	\| (loc1,na)::nal' as nal ->
	1421	if nal' <> [] then check_capture loc1 ty na;
	1422	let ty = intern_type env ty in
	1423	let impls = impls_type_list ty in
	1424	let env = List.fold_left (push_name_env lvar impls) env nal in
	1425	List.fold_right (fun (loc,na) c ->
	1426	GProd (join_loc loc loc2, na, bk, locate_if_isevar loc na ty, c))
	1427	nal (intern_type env body)
	1428	\| [] -> assert false
1426	1429	in
1427	1430	match bk with
1428	1431	\| Default b -> default env b nal

1432	1435	it_mkGProd ibind body
1433	1436
1434	1437	and iterate_lam loc2 env bk ty body nal =
1435		let rec default env bk = function
1436		\| (loc1,na as locna)::nal ->
1437		if nal <> [] then check_capture loc1 ty na;
1438		let ty = locate_if_isevar loc1 na (intern_type env ty) in
1439		let body = default (push_name_env lvar (impls_type_list ty) env locna) bk nal in
1440		GLambda (join_loc loc1 loc2, na, bk, ty, body)
1441		\| [] -> intern env body
	1438	let default env bk = function
	1439	\| (loc1,na)::nal' as nal ->
	1440	if nal' <> [] then check_capture loc1 ty na;
	1441	let ty = intern_type env ty in
	1442	let impls = impls_type_list ty in
	1443	let env = List.fold_left (push_name_env lvar impls) env nal in
	1444	List.fold_right (fun (loc,na) c ->
	1445	GLambda (join_loc loc loc2, na, bk, locate_if_isevar loc na ty, c))
	1446	nal (intern env body)
	1447	\| [] -> assert false
1442	1448	in match bk with
1443	1449	\| Default b -> default env b nal
1444	1450	\| Generalized (b, b', t) ->

1449	1455	and intern_impargs c env l subscopes args =
1450	1456	let l = select_impargs_size (List.length args) l in
1451	1457	let eargs, rargs = extract_explicit_arg l args in
	1458	if !parsing_explicit then
	1459	if eargs <> [] then
	1460	error "Arguments given by name or position not supported in explicit mode."
	1461	else
	1462	intern_args env subscopes rargs
	1463	else
1452	1464	let rec aux n impl subscopes eargs rargs =
1453	1465	let (enva,subscopes') = apply_scope_env env subscopes in
1454	1466	match (impl,rargs) with

+3

-0

interp/constrintern.mli less more

177	177	(identifier * identifier) list -> constr_expr ->
178	178	(identifier * (subscopes * notation_var_internalization_type)) list * aconstr
179	179
	180	(** Globalization options *)
	181	val parsing_explicit : bool ref
	182
180	183	(** Globalization leak for Grammar *)
181	184	val for_grammar : ('a -> 'b) -> 'a -> 'b

+29

-13

interp/genarg.ml less more

62	62
63	63	type 'a generic_argument = argument_type * Obj.t
64	64
65		let dyntab = ref ([] : string list)
66
67	65	type rlevel
68	66	type glevel
69	67	type tlevel
70
71		type ('a,'b) abstract_argument_type = argument_type
72
73		let create_arg s =
74		if List.mem s !dyntab then
75		anomaly ("Genarg.create: already declared generic argument " ^ s);
76		dyntab := s :: !dyntab;
77		let t = ExtraArgType s in
78		(t,t,t)
79
80		let exists_argtype s = List.mem s !dyntab
81	68
82	69	type intro_pattern_expr =
83	70	\| IntroOrAndPattern of or_and_intro_pattern_expr

258	245	type an_arg_of_this_type = Obj.t
259	246
260	247	let in_generic t x = (t, Obj.repr x)
	248
	249	let dyntab = ref ([] : (string * glevel generic_argument option) list)
	250
	251	type ('a,'b) abstract_argument_type = argument_type
	252
	253	let create_arg v s =
	254	if List.mem_assoc s !dyntab then
	255	anomaly ("Genarg.create: already declared generic argument " ^ s);
	256	let t = ExtraArgType s in
	257	dyntab := (s,Option.map (in_gen t) v) :: !dyntab;
	258	(t,t,t)
	259
	260	let exists_argtype s = List.mem_assoc s !dyntab
	261
	262	let default_empty_argtype_value s = List.assoc s !dyntab
	263
	264	let default_empty_value t =
	265	let rec aux = function
	266	\| List0ArgType _ -> Some (in_gen t [])
	267	\| OptArgType _ -> Some (in_gen t None)
	268	\| PairArgType(t1,t2) ->
	269	(match aux t1, aux t2 with
	270	\| Some (_,v1), Some (_,v2) -> Some (in_gen t (v1,v2))
	271	\| _ -> None)
	272	\| ExtraArgType s -> default_empty_argtype_value s
	273	\| _ -> None in
	274	match aux t with
	275	\| Some v -> Some (out_gen t v)
	276	\| None -> None

+4

-2

interp/genarg.mli less more

255	255
256	256	(** create a new generic type of argument: force to associate
257	257	unique ML types at each of the three levels *)
258		val create_arg : string ->
	258	val create_arg : 'rawa option ->
	259	string ->
259	260	('a,tlevel) abstract_argument_type
260	261	* ('globa,glevel) abstract_argument_type
261	262	* ('rawa,rlevel) abstract_argument_type

297	298	val out_gen :
298	299	('a,'co) abstract_argument_type -> 'co generic_argument -> 'a
299	300
300
301	301	(** [in_generic] is used in combination with camlp4 [Gramext.action] magic
302	302
303	303	[in_generic: !l:type, !a:argument_type -> \|a\|_l -> 'l generic_argument]

311	311
312	312	val in_generic :
313	313	argument_type -> an_arg_of_this_type -> 'co generic_argument
	314
	315	val default_empty_value : ('a,rlevel) abstract_argument_type -> 'a option

+5

-0

interp/notation.ml less more

816	816	{ freeze_function = freeze;
817	817	unfreeze_function = unfreeze;
818	818	init_function = init }
	819
	820	let with_notation_protection f x =
	821	let fs = freeze () in
	822	try let a = f x in unfreeze fs; a
	823	with e -> unfreeze fs; raise e

+2

-0

interp/notation.mli less more

176	176	val find_notation_printing_rule : notation -> unparsing_rule
177	177
178	178	(** Rem: printing rules for primitive token are canonical *)
	179
	180	val with_notation_protection : ('a -> 'b) -> 'a -> 'b

+12

-3

interp/topconstr.ml less more

238	238	\| GLambda (_,Name x,_,t_x,c), GLambda (_,Name y,_,t_y,term)
239	239	\| GProd (_,Name x,_,t_x,c), GProd (_,Name y,_,t_y,term) ->
240	240	(* We found a binding position where it differs *)
241		check_is_hole y t_x;
	241	check_is_hole x t_x;
242	242	check_is_hole y t_y;
243	243	!diff = None && (diff := Some (x,y,None); aux c term)
244	244	\| _ ->

563	563	\| _ -> raise No_match
564	564
565	565	let match_names metas (alp,sigma) na1 na2 = match (na1,na2) with
566		\| (Name id1,Name id2) when List.mem id2 (fst metas) ->
567		alp, bind_env alp sigma id2 (GVar (dummy_loc,id1))
	566	\| (_,Name id2) when List.mem id2 (fst metas) ->
	567	let rhs = match na1 with
	568	\| Name id1 -> GVar (dummy_loc,id1)
	569	\| Anonymous -> GHole (dummy_loc,Evd.InternalHole) in
	570	alp, bind_env alp sigma id2 rhs
568	571	\| (Name id1,Name id2) -> (id1,id2)::alp,sigma
569	572	\| (Anonymous,Anonymous) -> alp,sigma
570	573	\| _ -> raise No_match

921	924	List.flatten (List.map (function LocalRawAssum(l,_,_)->l\|LocalRawDef(l,_)->[l]) bl)
922	925
923	926	(**********************************************************************)
	927	(* Miscellaneous *)
	928
	929	let error_invalid_pattern_notation loc =
	930	user_err_loc (loc,"",str "Invalid notation for pattern.")
	931
	932	(**********************************************************************)
924	933	(* Functions on constr_expr *)
925	934
926	935	let constr_loc = function

+4

-0

interp/topconstr.mli less more

267	267	Util.loc -> constr_notation_substitution -> string -> (int * int) list
268	268	val patntn_loc :
269	269	Util.loc -> cases_pattern_notation_substitution -> string -> (int * int) list
	270
	271	(** For cases pattern parsing errors *)
	272
	273	val error_invalid_pattern_notation : Util.loc -> 'a

+4

-0

kernel/declarations.mli less more

190	190	\| SFBmind of mutual_inductive_body
191	191	\| SFBmodule of module_body
192	192	\| SFBmodtype of module_type_body
	193
	194	(** NB: we may encounter now (at most) twice the same label in
	195	a [structure_body], once for a module ([SFBmodule] or [SFBmodtype])
	196	and once for an object ([SFBconst] or [SFBmind]) *)
193	197
194	198	and structure_body = (label * structure_field_body) list
195	199

+39

-43

kernel/mod_typing.ml less more

34	34	\| MSEfunctor (_,_,expr) -> mp_from_mexpr expr
35	35	\| MSEwith (expr,_) -> mp_from_mexpr expr
36	36
37		let rec list_split_assoc k rev_before = function
	37	let is_modular = function
	38	\| SFBmodule _ \| SFBmodtype _ -> true
	39	\| SFBconst _ \| SFBmind _ -> false
	40
	41	let rec list_split_assoc ((k,m) as km) rev_before = function
38	42	\| [] -> raise Not_found
39		\| (k',b)::after when k=k' -> rev_before,b,after
40		\| h::tail -> list_split_assoc k (h::rev_before) tail
	43	\| (k',b)::after when k=k' && is_modular b = m -> rev_before,b,after
	44	\| h::tail -> list_split_assoc km (h::rev_before) tail
41	45
42	46	let discr_resolver env mtb =
43	47	match mtb.typ_expr with

53	57
54	58	let rec check_with env sign with_decl alg_sign mp equiv =
55	59	let sign,wd,equiv,cst= match with_decl with
56		\| With_Definition (id,_) ->
57		let sign,cb,cst = check_with_aux_def env sign with_decl mp equiv in
58		sign,With_definition_body(id,cb),equiv,cst
59		\| With_Module (id,mp1) ->
60		let sign,equiv,cst =
61		check_with_aux_mod env sign with_decl mp equiv in
62		sign,With_module_body(id,mp1),equiv,cst in
	60	\| With_Definition (idl,c) ->
	61	let sign,cb,cst = check_with_def env sign (idl,c) mp equiv in
	62	sign,With_definition_body(idl,cb),equiv,cst
	63	\| With_Module (idl,mp1) ->
	64	let sign,equiv,cst = check_with_mod env sign (idl,mp1) mp equiv in
	65	sign,With_module_body(idl,mp1),equiv,cst
	66	in
63	67	if alg_sign = None then
64	68	sign,None,equiv,cst
65	69	else
66	70	sign,Some (SEBwith(Option.get(alg_sign),wd)),equiv,cst
67	71
68		and check_with_aux_def env sign with_decl mp equiv =
	72	and check_with_def env sign (idl,c) mp equiv =
69	73	let sig_b = match sign with
70	74	\| SEBstruct(sig_b) -> sig_b
71	75	\| _ -> error_signature_expected sign
72	76	in
73		let id,idl = match with_decl with
74		\| With_Definition (id::idl,_) \| With_Module (id::idl,_) -> id,idl
75		\| With_Definition ([],_) \| With_Module ([],_) -> assert false
	77	let id,idl = match idl with
	78	\| [] -> assert false
	79	\| id::idl -> id,idl
76	80	in
77	81	let l = label_of_id id in
78	82	try
79		let rev_before,spec,after = list_split_assoc l [] sig_b in
	83	let rev_before,spec,after = list_split_assoc (l,(idl<>[])) [] sig_b in
80	84	let before = List.rev rev_before in
81	85	let env' = Modops.add_signature mp before equiv env in
82		match with_decl with
83		\| With_Definition ([],_) -> assert false
84		\| With_Definition ([id],c) ->
	86	if idl = [] then
	87	(* Toplevel definition *)
85	88	let cb = match spec with
86	89	\| SFBconst cb -> cb
87	90	\| _ -> error_not_a_constant l

114	117	Cemitcodes.from_val (compile_constant_body env' def);
115	118	const_constraints = cst }
116	119	in
117		SEBstruct(before@((l,SFBconst(cb'))::after)),cb',cst
118		\| With_Definition (_::_,c) ->
	120	SEBstruct(before@(l,SFBconst(cb'))::after),cb',cst
	121	else
	122	(* Definition inside a sub-module *)
119	123	let old = match spec with
120	124	\| SFBmodule msb -> msb
121	125	\| _ -> error_not_a_module (string_of_label l)

123	127	begin
124	128	match old.mod_expr with
125	129	\| None ->
126		let new_with_decl = With_Definition (idl,c) in
127	130	let sign,cb,cst =
128		check_with_aux_def env' old.mod_type new_with_decl
	131	check_with_def env' old.mod_type (idl,c)
129	132	(MPdot(mp,l)) old.mod_delta in
130	133	let new_spec = SFBmodule({old with
131	134	mod_type = sign;
132	135	mod_type_alg = None}) in
133		SEBstruct(before@((l,new_spec)::after)),cb,cst
	136	SEBstruct(before@(l,new_spec)::after),cb,cst
134	137	\| Some msb ->
135	138	error_generative_module_expected l
136	139	end
137		\| _ -> anomaly "Modtyping:incorrect use of with"
138	140	with
139	141	\| Not_found -> error_no_such_label l
140	142	\| Reduction.NotConvertible -> error_incorrect_with_constraint l
141	143
142		and check_with_aux_mod env sign with_decl mp equiv =
	144	and check_with_mod env sign (idl,mp1) mp equiv =
143	145	let sig_b = match sign with
144	146	\| SEBstruct(sig_b) ->sig_b
145	147	\| _ -> error_signature_expected sign
146	148	in
147		let id,idl = match with_decl with
148		\| With_Definition (id::idl,_) \| With_Module (id::idl,_) -> id,idl
149		\| With_Definition ([],_) \| With_Module ([],_) -> assert false
	149	let id,idl = match idl with
	150	\| [] -> assert false
	151	\| id::idl -> id,idl
150	152	in
151	153	let l = label_of_id id in
152	154	try
153		let rev_before,spec,after = list_split_assoc l [] sig_b in
	155	let rev_before,spec,after = list_split_assoc (l,true) [] sig_b in
154	156	let before = List.rev rev_before in
155		let rec mp_rec = function
156		\| [] -> mp
157		\| i::r -> MPdot(mp_rec r,label_of_id i)
158		in
159	157	let env' = Modops.add_signature mp before equiv env in
160		match with_decl with
161		\| With_Module ([],_) -> assert false
162		\| With_Module ([id], mp1) ->
	158	if idl = [] then
	159	(* Toplevel module definition *)
163	160	let old = match spec with
164	161	SFBmodule msb -> msb
165	162	\| _ -> error_not_a_module (string_of_label l)

193	190	let id_subst = map_mp (MPdot(mp,l)) (MPdot(mp,l)) new_mb.mod_delta in
194	191	SEBstruct(before@(l,new_spec)::subst_signature id_subst after),
195	192	add_delta_resolver equiv new_mb.mod_delta,cst
196		\| With_Module (idc,mp1) ->
	193	else
	194	(* Module definition of a sub-module *)
197	195	let old = match spec with
198	196	SFBmodule msb -> msb
199	197	\| _ -> error_not_a_module (string_of_label l)

201	199	begin
202	200	match old.mod_expr with
203	201	None ->
204		let new_with_decl = With_Module (idl,mp1) in
205	202	let sign,equiv',cst =
206		check_with_aux_mod env'
207		old.mod_type new_with_decl (MPdot(mp,l)) old.mod_delta in
	203	check_with_mod env'
	204	old.mod_type (idl,mp1) (MPdot(mp,l)) old.mod_delta in
208	205	let new_equiv = add_delta_resolver equiv equiv' in
209	206	let new_spec = SFBmodule {old with
210	207	mod_type = sign;

222	219	\| _ ->
223	220	error_generative_module_expected l
224	221	end
225		\| _ -> anomaly "Modtyping:incorrect use of with"
226	222	with
227	223	Not_found -> error_no_such_label l
228	224	\| Reduction.NotConvertible -> error_incorrect_with_constraint l

367	363
368	364	\| SEBstruct (structure_body) ->
369	365	List.fold_left
370		(fun env (l,item) -> add_struct_elem_constraints env item)
	366	(fun env (_,item) -> add_struct_elem_constraints env item)
371	367	env
372	368	structure_body
373	369

412	408
413	409	\| SEBstruct (structure_body) ->
414	410	List.fold_left
415		(fun cst (l,item) -> struct_elem_constraints cst item)
	411	(fun cst (_,item) -> struct_elem_constraints cst item)
416	412	cst
417	413	structure_body
418	414

+39

-23

kernel/safe_typing.ml less more

100	100	{ old : safe_environment;
101	101	env : env;
102	102	modinfo : module_info;
103		labset : Labset.t;
	103	modlabels : Labset.t;
	104	objlabels : Labset.t;
104	105	revstruct : structure_body;
105	106	univ : Univ.constraints;
106	107	engagement : engagement option;

108	109	loads : (module_path * module_body) list;
109	110	local_retroknowledge : Retroknowledge.action list}
110	111
111		let exists_label l senv = Labset.mem l senv.labset
112
113		let check_label l senv =
114		if exists_label l senv then error_existing_label l
115
116		let check_labels ls senv =
117		Labset.iter (fun l -> check_label l senv) ls
	112	let exists_modlabel l senv = Labset.mem l senv.modlabels
	113	let exists_objlabel l senv = Labset.mem l senv.objlabels
	114
	115	let check_modlabel l senv =
	116	if exists_modlabel l senv then error_existing_label l
	117	let check_objlabel l senv =
	118	if exists_objlabel l senv then error_existing_label l
	119
	120	let check_objlabels ls senv =
	121	Labset.iter (fun l -> check_objlabel l senv) ls
118	122
119	123	let labels_of_mib mib =
120	124	let add,get =

139	143	variant = NONE;
140	144	resolver = empty_delta_resolver;
141	145	resolver_of_param = empty_delta_resolver};
142		labset = Labset.empty;
	146	modlabels = Labset.empty;
	147	objlabels = Labset.empty;
143	148	revstruct = [];
144	149	univ = Univ.empty_constraint;
145	150	engagement = None;

171	176	\| M
172	177
173	178	let add_field ((l,sfb) as field) gn senv =
174		let labels = match sfb with
175		\| SFBmind mib -> labels_of_mib mib
176		\| _ -> Labset.singleton l
177		in
178		check_labels labels senv;
	179	let mlabs,olabs = match sfb with
	180	\| SFBmind mib ->
	181	let l = labels_of_mib mib in
	182	check_objlabels l senv; (Labset.empty,l)
	183	\| SFBconst _ ->
	184	check_objlabel l senv; (Labset.empty, Labset.singleton l)
	185	\| SFBmodule _ \| SFBmodtype _ ->
	186	check_modlabel l senv; (Labset.singleton l, Labset.empty)
	187	in
179	188	let senv = add_constraints (constraints_of_sfb sfb) senv in
180	189	let env' = match sfb, gn with
181	190	\| SFBconst cb, C con -> Environ.add_constant con cb senv.env

186	195	in
187	196	{ senv with
188	197	env = env';
189		labset = Labset.union labels senv.labset;
	198	modlabels = Labset.union mlabs senv.modlabels;
	199	objlabels = Labset.union olabs senv.objlabels;
190	200	revstruct = field :: senv.revstruct }
191	201
192	202	(* Applying a certain function to the resolver of a safe environment *)

319	329	(* Interactive modules *)
320	330
321	331	let start_module l senv =
322		check_label l senv;
	332	check_modlabel l senv;
323	333	let mp = MPdot(senv.modinfo.modpath, l) in
324	334	let modinfo = { modpath = mp;
325	335	label = l;

330	340	mp, { old = senv;
331	341	env = senv.env;
332	342	modinfo = modinfo;
333		labset = Labset.empty;
	343	modlabels = Labset.empty;
	344	objlabels = Labset.empty;
334	345	revstruct = [];
335	346	univ = Univ.empty_constraint;
336	347	engagement = None;

414	425	mp,resolver,{ old = oldsenv.old;
415	426	env = newenv;
416	427	modinfo = modinfo;
417		labset = Labset.add l oldsenv.labset;
	428	modlabels = Labset.add l oldsenv.modlabels;
	429	objlabels = oldsenv.objlabels;
418	430	revstruct = (l,SFBmodule mb)::oldsenv.revstruct;
419	431	univ = Univ.union_constraints senv'.univ oldsenv.univ;
420	432	(* engagement is propagated to the upper level *)

509	521	variant = new_variant;
510	522	resolver_of_param = add_delta_resolver
511	523	resolver_of_param senv.modinfo.resolver_of_param};
512		labset = senv.labset;
	524	modlabels = senv.modlabels;
	525	objlabels = senv.objlabels;
513	526	revstruct = [];
514	527	univ = senv.univ;
515	528	engagement = senv.engagement;

521	534	(* Interactive module types *)
522	535
523	536	let start_modtype l senv =
524		check_label l senv;
	537	check_modlabel l senv;
525	538	let mp = MPdot(senv.modinfo.modpath, l) in
526	539	let modinfo = { modpath = mp;
527	540	label = l;

532	545	mp, { old = senv;
533	546	env = senv.env;
534	547	modinfo = modinfo;
535		labset = Labset.empty;
	548	modlabels = Labset.empty;
	549	objlabels = Labset.empty;
536	550	revstruct = [];
537	551	univ = Univ.empty_constraint;
538	552	engagement = None;

583	597	mp, { old = oldsenv.old;
584	598	env = newenv;
585	599	modinfo = oldsenv.modinfo;
586		labset = Labset.add l oldsenv.labset;
	600	modlabels = Labset.add l oldsenv.modlabels;
	601	objlabels = oldsenv.objlabels;
587	602	revstruct = (l,SFBmodtype mtb)::oldsenv.revstruct;
588	603	univ = Univ.union_constraints senv.univ oldsenv.univ;
589	604	engagement = senv.engagement;

642	657	mp, { old = senv;
643	658	env = senv.env;
644	659	modinfo = modinfo;
645		labset = Labset.empty;
	660	modlabels = Labset.empty;
	661	objlabels = Labset.empty;
646	662	revstruct = [];
647	663	univ = Univ.empty_constraint;
648	664	engagement = None;

+1

-1

kernel/safe_typing.mli less more

137	137
138	138	(** {7 Query } *)
139	139
140		val exists_label : label -> safe_environment -> bool
	140	val exists_objlabel : label -> safe_environment -> bool
141	141
142	142	(spiwack: safe retroknowledge functionalities )
143	143

+43

-39

kernel/subtyping.ml less more

31	31	\| Constant of constant_body
32	32	\| IndType of inductive * mutual_inductive_body
33	33	\| IndConstr of constructor * mutual_inductive_body
	34
	35	type namedmodule =
34	36	\| Module of module_body
35	37	\| Modtype of module_type_body
36	38
37	39	(* adds above information about one mutual inductive: all types and
38	40	constructors *)
39	41
40		let add_nameobjects_of_mib ln mib map =
41		let add_nameobjects_of_one j oib map =
42		let ip = (ln,j) in
	42	let add_mib_nameobjects mp l mib map =
	43	let ind = make_mind mp empty_dirpath l in
	44	let add_mip_nameobjects j oib map =
	45	let ip = (ind,j) in
43	46	let map =
44	47	array_fold_right_i
45	48	(fun i id map ->

49	52	in
50	53	Labmap.add (label_of_id oib.mind_typename) (IndType (ip, mib)) map
51	54	in
52		array_fold_right_i add_nameobjects_of_one mib.mind_packets map
53
54
55		(* creates namedobject map for the whole signature *)
56
57		let make_label_map mp list =
	55	array_fold_right_i add_mip_nameobjects mib.mind_packets map
	56
	57
	58	(* creates (namedobject/namedmodule) map for the whole signature *)
	59
	60	type labmap = { objs : namedobject Labmap.t; mods : namedmodule Labmap.t }
	61
	62	let empty_labmap = { objs = Labmap.empty; mods = Labmap.empty }
	63
	64	let get_obj mp map l =
	65	try Labmap.find l map.objs
	66	with Not_found -> error_no_such_label_sub l (string_of_mp mp)
	67
	68	let get_mod mp map l =
	69	try Labmap.find l map.mods
	70	with Not_found -> error_no_such_label_sub l (string_of_mp mp)
	71
	72	let make_labmap mp list =
58	73	let add_one (l,e) map =
59		let add_map obj = Labmap.add l obj map in
60	74	match e with
61		\| SFBconst cb -> add_map (Constant cb)
62		\| SFBmind mib ->
63		add_nameobjects_of_mib (make_mind mp empty_dirpath l) mib map
64		\| SFBmodule mb -> add_map (Module mb)
65		\| SFBmodtype mtb -> add_map (Modtype mtb)
66		in
67		List.fold_right add_one list Labmap.empty
	75	\| SFBconst cb -> { map with objs = Labmap.add l (Constant cb) map.objs }
	76	\| SFBmind mib -> { map with objs = add_mib_nameobjects mp l mib map.objs }
	77	\| SFBmodule mb -> { map with mods = Labmap.add l (Module mb) map.mods }
	78	\| SFBmodtype mtb -> { map with mods = Labmap.add l (Modtype mtb) map.mods }
	79	in
	80	List.fold_right add_one list empty_labmap
	81
68	82
69	83	let check_conv_error error why cst f env a1 a2 =
70	84	try

298	312	let ty1 = type_of_constructor cstr (mind1,mind1.mind_packets.(i)) in
299	313	let ty2 = Typeops.type_of_constant_type env cb2.const_type in
300	314	check_conv NotConvertibleTypeField cst conv env ty1 ty2
301		\| _ -> error DefinitionFieldExpected
302	315
303	316	let rec check_modules cst env msb1 msb2 subst1 subst2 =
304	317	let mty1 = module_type_of_module None msb1 in

307	320	cst
308	321
309	322	and check_signatures cst env mp1 sig1 mp2 sig2 subst1 subst2 reso1 reso2=
310		let map1 = make_label_map mp1 sig1 in
	323	let map1 = make_labmap mp1 sig1 in
311	324	let check_one_body cst (l,spec2) =
312		let info1 =
313		try
314		Labmap.find l map1
315		with
316		Not_found -> error_no_such_label_sub l
317		(string_of_mp mp1)
318		in
319		match spec2 with
	325	match spec2 with
320	326	\| SFBconst cb2 ->
321		check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2
	327	check_constant cst env mp1 l (get_obj mp1 map1 l)
	328	cb2 spec2 subst1 subst2
322	329	\| SFBmind mib2 ->
323		check_inductive cst env
324		mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2
	330	check_inductive cst env mp1 l (get_obj mp1 map1 l)
	331	mp2 mib2 spec2 subst1 subst2 reso1 reso2
325	332	\| SFBmodule msb2 ->
326		begin
327		match info1 with
328		\| Module msb -> check_modules cst env msb msb2
329		subst1 subst2
330		\| _ -> error_signature_mismatch l spec2 ModuleFieldExpected
	333	begin match get_mod mp1 map1 l with
	334	\| Module msb -> check_modules cst env msb msb2 subst1 subst2
	335	\| _ -> error_signature_mismatch l spec2 ModuleFieldExpected
331	336	end
332	337	\| SFBmodtype mtb2 ->
333		let mtb1 =
334		match info1 with
335		\| Modtype mtb -> mtb
336		\| _ -> error_signature_mismatch l spec2 ModuleTypeFieldExpected
	338	let mtb1 = match get_mod mp1 map1 l with
	339	\| Modtype mtb -> mtb
	340	\| _ -> error_signature_mismatch l spec2 ModuleTypeFieldExpected
337	341	in
338	342	let env = add_module (module_body_of_type mtb2.typ_mp mtb2)
339	343	(add_module (module_body_of_type mtb1.typ_mp mtb1) env) in

+1

-0

kernel/term.ml less more

321	321
322	322	(* Tests if a de Bruijn index *)
323	323	let isRel c = match kind_of_term c with Rel _ -> true \| _ -> false
	324	let isRelN n c = match kind_of_term c with Rel n' -> n = n' \| _ -> false
324	325
325	326	(* Tests if a variable *)
326	327	let isVar c = match kind_of_term c with Var _ -> true \| _ -> false

+3

-3

kernel/term.mli less more

228	228	(** {6 Simple term case analysis. } *)
229	229
230	230	val isRel : constr -> bool
	231	val isRelN : int -> constr -> bool
231	232	val isVar : constr -> bool
232		val isVarId : identifier -> constr -> bool
	233	val isVarId : identifier -> constr -> bool
233	234	val isInd : constr -> bool
234	235	val isEvar : constr -> bool
235	236	val isMeta : constr -> bool

434	435	(** {6 Other term destructors. } *)
435	436
436	437	(** Transforms a product term {% $ %}(x_1:T_1)..(x_n:T_n)T{% $ %} into the pair
437		{% $ %}([(x_n,T_n);...;(x_1,T_1)],T){% $ %}, where {% $ %}T{% $ %} is not a product.
438		It includes also local definitions *)
	438	{% $ %}([(x_n,T_n);...;(x_1,T_1)],T){% $ %}, where {% $ %}T{% $ %} is not a product. *)
439	439	val decompose_prod : constr -> (nameconstr) list constr
440	440
441	441	(** Transforms a lambda term {% $ %}[x_1:T_1]..[x_n:T_n]T{% $ %} into the pair

+69

-44

kernel/univ.ml less more

259	259
260	260	(** [compare_neq] : is [arcv] in the transitive upward closure of [arcu] ?
261	261
262		We try to avoid visiting unneeded parts of this transitive closure,
263		by stopping as soon as [arcv] is encountered. During the recursive
264		traversal, [lt_done] and [le_done] are universes we have already
265		visited, they do not contain [arcv]. The 3rd arg is
266		[(lt_todo,le_todo)], two lists of universes not yet considered,
267		known to be above [arcu], strictly or not.
	262	In [strict] mode, we fully distinguish between LE and LT, while in
	263	non-strict mode, we simply answer LE for both situations.
	264
	265	If [arcv] is encountered in a LT part, we could directly answer
	266	without visiting unneeded parts of this transitive closure.
	267	In [strict] mode, if [arcv] is encountered in a LE part, we could only
	268	change the default answer (1st arg [c]) from NLE to LE, since a strict
	269	constraint may appear later. During the recursive traversal,
	270	[lt_done] and [le_done] are universes we have already visited,
	271	they do not contain [arcv]. The 4rd arg is [(lt_todo,le_todo)],
	272	two lists of universes not yet considered, known to be above [arcu],
	273	strictly or not.
268	274
269	275	We use depth-first search, but the presence of [arcv] in [new_lt]
270	276	is checked as soon as possible : this seems to be slightly faster
271	277	on a test.
272	278	*)
273	279
274		let compare_neq g arcu arcv =
275		let rec cmp lt_done le_done = function
276		\| [],[] -> NLE
	280	let compare_neq strict g arcu arcv =
	281	let rec cmp c lt_done le_done = function
	282	\| [],[] -> c
277	283	\| arc::lt_todo, le_todo ->
278	284	if List.memq arc lt_done then
279		cmp lt_done le_done (lt_todo,le_todo)
	285	cmp c lt_done le_done (lt_todo,le_todo)
280	286	else
281	287	let lt_new = can g (arc.lt@arc.le) in
282		if List.memq arcv lt_new then LT
283		else cmp (arc::lt_done) le_done (lt_new@lt_todo,le_todo)
	288	if List.memq arcv lt_new then
	289	if strict then LT else LE
	290	else cmp c (arc::lt_done) le_done (lt_new@lt_todo,le_todo)
284	291	\| [], arc::le_todo ->
285		if arc == arcv then LE
286		(* No need to continue inspecting universes above arc:
287		if arcv is strictly above arc, then we would have a cycle *)
	292	if arc == arcv then
	293	(* No need to continue inspecting universes above arc:
	294	if arcv is strictly above arc, then we would have a cycle.
	295	But we cannot answer LE yet, a stronger constraint may
	296	come later from [le_todo]. *)
	297	if strict then cmp LE lt_done le_done ([],le_todo) else LE
288	298	else
289	299	if (List.memq arc lt_done) \|\| (List.memq arc le_done) then
290		cmp lt_done le_done ([],le_todo)
	300	cmp c lt_done le_done ([],le_todo)
291	301	else
292	302	let lt_new = can g arc.lt in
293		if List.memq arcv lt_new then LT
	303	if List.memq arcv lt_new then
	304	if strict then LT else LE
294	305	else
295	306	let le_new = can g arc.le in
296		cmp lt_done (arc::le_done) (lt_new, le_new@le_todo)
297		in
298		cmp [] [] ([],[arcu])
	307	cmp c lt_done (arc::le_done) (lt_new, le_new@le_todo)
	308	in
	309	cmp NLE [] [] ([],[arcu])
299	310
300	311	let compare g arcu arcv =
301		if arcu == arcv then EQ else compare_neq g arcu arcv
	312	if arcu == arcv then EQ else compare_neq true g arcu arcv
	313
	314	let is_leq g arcu arcv =
	315	arcu == arcv \|\| (compare_neq false g arcu arcv = LE)
	316
	317	let is_lt g arcu arcv = (compare g arcu arcv = LT)
302	318
303	319	(* Invariants : compare(u,v) = EQ <=> compare(v,u) = EQ
304	320	compare(u,v) = LT or LE => compare(v,u) = NLE

336	352	let compare_greater g strict u v =
337	353	let g, arcu = safe_repr g u in
338	354	let g, arcv = safe_repr g v in
339		if not strict && arcv == snd (safe_repr g UniverseLevel.Set) then true else
340		match compare g arcv arcu with
341		\| (EQ\|LE) -> not strict
342		\| LT -> true
343		\| NLE -> false
	355	if strict then
	356	is_lt g arcv arcu
	357	else
	358	arcv == snd (safe_repr g UniverseLevel.Set) \|\| is_leq g arcv arcu
	359
344	360	(*
345	361	let compare_greater g strict u v =
346	362	let b = compare_greater g strict u v in

367	383	(* checks that non-redundant *)
368	384	let setlt_if (g,arcu) v =
369	385	let arcv = repr g v in
370		match compare g arcu arcv with
371		\| LT -> g, arcu
372		\| _ -> setlt g arcu arcv
	386	if is_lt g arcu arcv then g, arcu
	387	else setlt g arcu arcv
373	388
374	389	(* setleq : UniverseLevel.t -> UniverseLevel.t -> unit *)
375	390	(* forces u >= v *)

382	397	(* checks that non-redundant *)
383	398	let setleq_if (g,arcu) v =
384	399	let arcv = repr g v in
385		match compare g arcu arcv with
386		\| NLE -> setleq g arcu arcv
387		\| _ -> g, arcu
	400	if is_leq g arcu arcv then g, arcu
	401	else setleq g arcu arcv
388	402
389	403	(* merge : UniverseLevel.t -> UniverseLevel.t -> unit *)
390	404	(* we assume compare(u,v) = LE *)

428	442	let enforce_univ_leq u v g =
429	443	let g,arcu = safe_repr g u in
430	444	let g,arcv = safe_repr g v in
431		match compare g arcu arcv with
432		\| NLE ->
433		(match compare g arcv arcu with
434		\| LT -> error_inconsistency Le u v
435		\| LE -> merge g arcv arcu
436		\| NLE -> fst (setleq g arcu arcv)
437		\| EQ -> anomaly "Univ.compare")
438		\| _ -> g
	445	if is_leq g arcu arcv then g
	446	else match compare g arcv arcu with
	447	\| LT -> error_inconsistency Le u v
	448	\| LE -> merge g arcv arcu
	449	\| NLE -> fst (setleq g arcu arcv)
	450	\| EQ -> anomaly "Univ.compare"
439	451
440	452	(* enforc_univ_eq : UniverseLevel.t -> UniverseLevel.t -> unit *)
441	453	(* enforc_univ_eq u v will force u=v if possible, will fail otherwise *)

462	474	\| LE -> fst (setlt g arcu arcv)
463	475	\| EQ -> error_inconsistency Lt u v
464	476	\| NLE ->
465		(match compare g arcv arcu with
466		\| NLE -> fst (setlt g arcu arcv)
467		\| _ -> error_inconsistency Lt u v)
	477	if is_leq g arcv arcu then error_inconsistency Lt u v
	478	else fst (setlt g arcu arcv)
468	479
469	480	(* Constraints and sets of consrtaints. *)
470	481

479	490	module Constraint = Set.Make(
480	491	struct
481	492	type t = univ_constraint
482		let compare = Pervasives.compare
	493	let compare (u,c,v) (u',c',v') =
	494	let i = Pervasives.compare c c' in
	495	if i <> 0 then i
	496	else
	497	let i' = UniverseLevel.compare u u' in
	498	if i' <> 0 then i'
	499	else UniverseLevel.compare v v'
483	500	end)
484	501
485	502	type constraints = Constraint.t

783	800	\| Atom u -> Constraint.for_all (fun (u1,_,_) -> u1 <> u) cst
784	801	\| Max _ -> anomaly "no_upper_constraints"
785	802
	803	(* Is u mentionned in v (or equals to v) ? *)
	804
	805	let univ_depends u v =
	806	match u, v with
	807	\| Atom u, Atom v -> u = v
	808	\| Atom u, Max (gel,gtl) -> List.mem u gel \|\| List.mem u gtl
	809	\| _ -> anomaly "univ_depends given a non-atomic 1st arg"
	810
786	811	(* Pretty-printing *)
787	812
788	813	let pr_arc = function

+4

-0

kernel/univ.mli less more

90	90
91	91	val no_upper_constraints : universe -> constraints -> bool
92	92
	93	(** Is u mentionned in v (or equals to v) ? *)
	94
	95	val univ_depends : universe -> universe -> bool
	96
93	97	(** {6 Pretty-printing of universes. } *)
94	98
95	99	val pr_uni_level : universe_level -> Pp.std_ppcmds

+3

-3

lib/envars.ml less more

61	61	"coq"
62	62
63	63	let xdg_data_dirs =
64		try
	64	(try
65	65	List.map (fun dir -> Filename.concat dir "coq") (path_to_list (Sys.getenv "XDG_DATA_DIRS"))
66		with Not_found -> "/usr/local/share/coq" :: "/usr/share/coq"
67		:: (match Coq_config.datadir with \|None -> [] \|Some datadir -> [datadir])
	66	with Not_found -> ["/usr/local/share/coq";"/usr/share/coq"])
	67	@ (match Coq_config.datadir with \|None -> [] \|Some datadir -> [datadir])
68	68
69	69	let xdg_dirs =
70	70	let dirs = xdg_data_home :: xdg_data_dirs

+9

-9

lib/explore.ml less more

5	5	(* * GNU Lesser General Public License Version 2.1 *)
6	6	(************************************************************************)
7	7
8		open Format
	8	open Pp
9	9
10	10	(s Definition of a search problem. )
11	11

13	13	type state
14	14	val branching : state -> state list
15	15	val success : state -> bool
16		val pp : state -> unit
	16	val pp : state -> std_ppcmds
17	17	end
18	18
19	19	module Make = functor(S : SearchProblem) -> struct
20	20
21	21	type position = int list
22	22
23		let pp_position p =
	23	let msg_with_position p pp =
24	24	let rec pp_rec = function
25		\| [] -> ()
26		\| [i] -> printf "%d" i
27		\| i :: l -> pp_rec l; printf ".%d" i
	25	\| [] -> mt ()
	26	\| [i] -> int i
	27	\| i :: l -> pp_rec l ++ str "." ++ int i
28	28	in
29		open_hbox (); pp_rec p; close_box ()
	29	msg_debug (h 0 (pp_rec p) ++ pp)
30	30
31	31	(s Depth first search. )
32	32

39	39
40	40	let debug_depth_first s =
41	41	let rec explore p s =
42		pp_position p; S.pp s;
	42	msg_with_position p (S.pp s);
43	43	if S.success s then s else explore_many 1 p (S.branching s)
44	44	and explore_many i p = function
45	45	\| [] -> raise Not_found

82	82	explore q
83	83	\| s :: l ->
84	84	let ps = i::p in
85		pp_position ps; S.pp s;
	85	msg_with_position ps (S.pp s);
86	86	if S.success s then s else enqueue (succ i) p (push (ps,s) q) l
87	87	in
88	88	enqueue 1 [] empty [s]

+1

-1

lib/explore.mli less more

26	26
27	27	val success : state -> bool
28	28
29		val pp : state -> unit
	29	val pp : state -> Pp.std_ppcmds
30	30
31	31	end
32	32

+12

-11

lib/pp.ml4 less more

273	273	(* pretty print on stdout and stderr *)
274	274
275	275	(* Special chars for emacs, to detect warnings inside goal output *)
276		let emacs_warning_start_string = String.make 1 (Char.chr 254)
277		let emacs_warning_end_string = String.make 1 (Char.chr 255)
278
279		let warnstart() =
280		if not !print_emacs then mt() else str emacs_warning_start_string
281
282		let warnend() =
283		if not !print_emacs then mt() else str emacs_warning_end_string
284
285		let warnbody strm =
286		[< warnstart() ; hov 0 (str "Warning: " ++ strm) ; warnend() >]
	276	let emacs_quote_start = String.make 1 (Char.chr 254)
	277	let emacs_quote_end = String.make 1 (Char.chr 255)
	278
	279	let emacs_quote strm =
	280	if !print_emacs then
	281	[< str emacs_quote_start; hov 0 strm; str emacs_quote_end >]
	282	else hov 0 strm
	283
	284	let warnbody strm = emacs_quote (str "Warning: " ++ strm)
287	285
288	286	(* pretty printing functions WITHOUT FLUSH *)
289	287	let pp_with ft strm =

332	330	let msgerrnl x = msgnl_with !err_ft x
333	331	let msg_warning x = msg_warning_with !err_ft x
334	332
	333	(* Same specific display in emacs as warning, but without the "Warning:" *)
	334	let msg_debug x = msgnl (emacs_quote x)
	335
335	336	let string_of_ppcmds c =
336	337	msg_with Format.str_formatter c;
337	338	Format.flush_str_formatter ()

+3

-0

lib/pp.mli less more

112	112	val msgerrnl : std_ppcmds -> unit
113	113	val msg_warning : std_ppcmds -> unit
114	114
	115	( Same specific display in emacs as warning, but without the "Warning:" )
	116	val msg_debug : std_ppcmds -> unit
	117
115	118	val string_of_ppcmds : std_ppcmds -> string

+24

-1

lib/util.ml less more

498	498	in
499	499	map (l1,l2,l3,l4)
500	500
	501	let list_map_to_array f l =
	502	Array.of_list (List.map f l)
	503
501	504	let rec list_smartfilter f l = match l with
502	505	[] -> l
503	506	\| h::tl ->

707	710	match f i x with None -> l' \| Some y -> y::l'
708	711	in aux 0
709	712
	713	let list_filter_along f filter l =
	714	snd (list_filter2 (fun b c -> f b) (filter,l))
	715
	716	let list_filter_with filter l =
	717	list_filter_along (fun x -> x) filter l
	718
710	719	let list_subset l1 l2 =
711	720	let t2 = Hashtbl.create 151 in
712	721	List.iter (fun x -> Hashtbl.add t2 x ()) l2;

740	749	split_when_loop []
741	750
742	751	(* [list_split_by p l] splits [l] into two lists [(l1,l2)] such that elements of
743		[l1] satisfy [p] and elements of [l2] do not *)
	752	[l1] satisfy [p] and elements of [l2] do not; order is preserved *)
744	753	let list_split_by p =
745	754	let rec split_by_loop = function
746	755	\| [] -> ([],[])

898	907	(* Drop the last element of a list *)
899	908
900	909	let rec list_drop_last = function [] -> assert false \| hd :: [] -> [] \| hd :: tl -> hd :: list_drop_last tl
	910
	911	(* Factorize lists of pairs according to the left argument *)
	912	let rec list_factorize_left = function
	913	\| (a,b)::l ->
	914	let al,l' = list_split_by (fun (a',b) -> a=a') l in
	915	(a,(b::List.map snd al)) :: list_factorize_left l'
	916	\| [] ->
	917	[]
901	918
902	919	(* Arrays *)
903	920

1216	1233	if i >= Array.length a then res else tolist (i+1) (a.(i) :: res) in
1217	1234	tolist 0 []
1218	1235
	1236	let array_filter_along f filter v =
	1237	Array.of_list (list_filter_along f filter (Array.to_list v))
	1238
	1239	let array_filter_with filter v =
	1240	Array.of_list (list_filter_with filter (Array.to_list v))
	1241
1219	1242	(* Stream *)
1220	1243
1221	1244	let stream_nth n st =

+6

-0

lib/util.mli less more

134	134	val list_filter2 : ('a -> 'b -> bool) -> 'a list * 'b list -> 'a list * 'b list
135	135	val list_map_filter : ('a -> 'b option) -> 'a list -> 'b list
136	136	val list_map_filter_i : (int -> 'a -> 'b option) -> 'a list -> 'b list
	137	val list_filter_with : bool list -> 'a list -> 'a list
	138	val list_filter_along : ('a -> bool) -> 'a list -> 'b list -> 'b list
137	139
138	140	(** [list_smartmap f [a1...an] = List.map f [a1...an]] but if for all i
139	141	[ f ai == ai], then [list_smartmap f l==l] *)

146	148	('a -> 'b -> 'c -> 'd) -> 'a list -> 'b list -> 'c list -> 'd list
147	149	val list_map4 :
148	150	('a -> 'b -> 'c -> 'd -> 'e) -> 'a list -> 'b list -> 'c list -> 'd list -> 'e list
	151	val list_map_to_array : ('a -> 'b) -> 'a list -> 'b array
149	152	val list_filter_i :
150	153	(int -> 'a -> bool) -> 'a list -> 'a list
151	154

238	241	('a -> 'b -> 'b option) -> 'b -> 'a list list -> 'b list
239	242
240	243	val list_union_map : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b
	244	val list_factorize_left : ('a * 'b) list -> ('a * 'b list) list
241	245
242	246	(** {6 Arrays. } *)
243	247

290	294	val array_distinct : 'a array -> bool
291	295	val array_union_map : ('a -> 'b -> 'b) -> 'a array -> 'b -> 'b
292	296	val array_rev_to_list : 'a array -> 'a list
	297	val array_filter_along : ('a -> bool) -> 'a list -> 'b array -> 'b array
	298	val array_filter_with : bool list -> 'a array -> 'a array
293	299
294	300	(** {6 Streams. } *)
295	301

+1

-1

lib/xml_parser.mli less more

41	41	and the {!Xml.error_pos} can be used to retreive the document
42	42	location where the error occured at.}
43	43	{li {!Xml.File_not_found} is raised when and error occured while
44		opening a file with the {!Xml.parse_file} function.
	44	opening a file with the {!Xml.parse_file} function.}
45	45	}
46	46	*)
47	47

+12

-6

library/assumptions.ml less more

53	53
54	54	let modcache = ref (MPmap.empty : structure_body MPmap.t)
55	55
	56	let rec search_mod_label lab = function
	57	\| [] -> raise Not_found
	58	\| (l,SFBmodule mb) :: _ when l = lab -> mb
	59	\| _ :: fields -> search_mod_label lab fields
	60
	61	let rec search_cst_label lab = function
	62	\| [] -> raise Not_found
	63	\| (l,SFBconst cb) :: _ when l = lab -> cb
	64	\| _ :: fields -> search_cst_label lab fields
	65
56	66	let rec lookup_module_in_impl mp =
57	67	try Global.lookup_module mp
58	68	with Not_found ->

63	73	raise Not_found (* should have been found by [lookup_module] *)
64	74	\| MPdot (mp',lab') ->
65	75	let fields = memoize_fields_of_mp mp' in
66		match List.assoc lab' fields with
67		\| SFBmodule mb -> mb
68		\| _ -> assert false (* same label for a non-module ?! *)
	76	search_mod_label lab' fields
69	77
70	78	and memoize_fields_of_mp mp =
71	79	try MPmap.find mp !modcache

125	133	let fields = memoize_fields_of_mp mp in
126	134	(* A module found this way is necessarily closed, in particular
127	135	our constant cannot be in an opened section : *)
128		match List.assoc lab fields with
129		\| SFBconst cb -> cb
130		\| _ -> assert false (* label not pointing to a constant ?! *)
	136	search_cst_label lab fields
131	137	with Not_found ->
132	138	(* Either:
133	139	- The module part of the constant isn't registered yet :

+1

-1

library/declare.ml less more

115	115	Nametab.push (Nametab.Exactly i) sp (ConstRef con)
116	116
117	117	let exists_name id =
118		variable_exists id or Global.exists_label (label_of_id id)
	118	variable_exists id or Global.exists_objlabel (label_of_id id)
119	119
120	120	let check_exists sp =
121	121	let id = basename sp in

+1

-1

library/global.ml less more

132	132	Mod_subst.mind_of_delta resolver_param
133	133	(Mod_subst.mind_of_delta_kn resolver kn)
134	134
135		let exists_label id = exists_label id !global_env
	135	let exists_objlabel id = exists_objlabel id !global_env
136	136
137	137	let start_library dir =
138	138	let mp,newenv = start_library dir !global_env in

+1

-1

library/global.mli less more

86	86	val lookup_modtype : module_path -> module_type_body
87	87	val constant_of_delta_kn : kernel_name -> constant
88	88	val mind_of_delta_kn : kernel_name -> mutual_inductive
89		val exists_label : label -> bool
	89	val exists_objlabel : label -> bool
90	90
91	91	(** Compiled modules *)
92	92	val start_library : dir_path -> module_path

+1

-0

library/goptions.ml less more

246	246	declare_object {(default_object ("G "^nickname key)) with
247	247	cache_function = (fun (_,v) -> write v);
248	248	classify_function = (fun v -> Substitute v);
	249	subst_function = (fun (_,v) -> v);
249	250	discharge_function = (fun (_,v) -> Some v);
250	251	load_function = (fun _ (_,v) -> write v)}
251	252	in

+6

-7

library/impargs.ml less more

206	206
207	207	(* calcule la liste des arguments implicites *)
208	208
209		let find_displayed_name_in all avoid na b =
210		if all then
211		compute_and_force_displayed_name_in (RenamingElsewhereFor b) avoid na b
212		else
213		compute_displayed_name_in (RenamingElsewhereFor b) avoid na b
	209	let find_displayed_name_in all avoid na (_,b as envnames_b) =
	210	let flag = RenamingElsewhereFor envnames_b in
	211	if all then compute_and_force_displayed_name_in flag avoid na b
	212	else compute_displayed_name_in flag avoid na b
214	213
215	214	let compute_implicits_gen strict strongly_strict revpat contextual all env t =
216	215	let rigid = ref true in

218	217	let t = whd_betadeltaiota env t in
219	218	match kind_of_term t with
220	219	\| Prod (na,a,b) ->
221		let na',avoid' = find_displayed_name_in all avoid na b in
	220	let na',avoid' = find_displayed_name_in all avoid na (names,b) in
222	221	add_free_rels_until strict strongly_strict revpat n env a (Hyp (n+1))
223	222	(aux (push_rel (na',None,a) env) avoid' (n+1) (na'::names) b)
224	223	\| _ ->

231	230	in
232	231	match kind_of_term (whd_betadeltaiota env t) with
233	232	\| Prod (na,a,b) ->
234		let na',avoid = find_displayed_name_in all [] na b in
	233	let na',avoid = find_displayed_name_in all [] na ([],b) in
235	234	let v = aux (push_rel (na',None,a) env) avoid 1 [na'] b in
236	235	!rigid, Array.to_list v
237	236	\| _ -> true, []

+19

-98

library/lib.ml less more

571	571
572	572	let reset_to sp = reset_to_gen (fun x -> fst x = sp)
573	573
574		(* LEM: TODO
575		* We will need to muck with frozen states in after, too!
576		* Not only FrozenState, but also those embedded in Opened(Section\|Module)
577		*)
578		let delete_gen test =
579		let (after,equal,before) = split_lib_gen test in
580		let rec chop_at_dot = function
581		\| [] as l -> l
582		\| (_, Leaf o)::t when object_tag o = "DOT" -> t
583		\| _::t -> chop_at_dot t
584		and chop_before_dot = function
585		\| [] as l -> l
586		\| (_, Leaf o)::t as l when object_tag o = "DOT" -> l
587		\| _::t -> chop_before_dot t
588		in
589		set_lib_stk (List.rev_append (chop_at_dot after) (chop_before_dot before))
590
591		let delete sp = delete_gen (fun x -> fst x = sp)
592
593		let reset_name (loc,id) =
594		let (sp,_) =
595		try
596		find_entry_p (fun (sp,_) -> let (_,spi) = repr_path (fst sp) in id = spi)
597		with Not_found ->
598		user_err_loc (loc,"reset_name",pr_id id ++ str ": no such entry")
599		in
600		reset_to sp
601
602		let remove_name (loc,id) =
603		let (sp,_) =
604		try
605		find_entry_p (fun (sp,_) -> let (_,spi) = repr_path (fst sp) in id = spi)
606		with Not_found ->
607		user_err_loc (loc,"remove_name",pr_id id ++ str ": no such entry")
608		in
609		delete sp
610
611		let is_mod_node = function
612		\| OpenedModule _ \| OpenedSection _
613		\| ClosedModule _ \| ClosedSection _ -> true
614		\| Leaf o -> let t = object_tag o in t = "MODULE" \|\| t = "MODULE TYPE"
615		\|\| t = "MODULE ALIAS"
616		\| _ -> false
617
618		(* Reset on a module or section name in order to bypass constants with
619		the same name *)
620
621		let reset_mod (loc,id) =
622		let (_,before) =
623		try
624		find_split_p (fun (sp,node) ->
625		let (_,spi) = repr_path (fst sp) in id = spi
626		&& is_mod_node node)
627		with Not_found ->
628		user_err_loc (loc,"reset_mod",pr_id id ++ str ": no such entry")
629		in
630		set_lib_stk before
631
632		let mark_end_of_command, current_command_label, set_command_label =
633		let n = ref 0 in
	574	let first_command_label = 1
	575
	576	let mark_end_of_command, current_command_label, reset_command_label =
	577	let n = ref (first_command_label-1) in
634	578	(fun () ->
635	579	match !lib_stk with
636	580	(_,Leaf o)::_ when object_tag o = "DOT" -> ()
637	581	\| _ -> incr n;add_anonymous_leaf (inLabel !n)),
638	582	(fun () -> !n),
639		(fun x -> n:=x)
	583	(fun x -> n:=x;add_anonymous_leaf (inLabel x))
640	584
641	585	let is_label_n n x =
642	586	match x with

649	593	let reset_label n =
650	594	if n >= current_command_label () then
651	595	error "Cannot backtrack to the current label or a future one";
652		let res = reset_to_gen (is_label_n n) in
	596	reset_to_gen (is_label_n n);
653	597	(* forget state numbers after n only if reset succeeded *)
654		set_command_label (n-1);
655		res
656
657		let rec back_stk n stk =
658		match stk with
659		(sp,Leaf o)::tail when object_tag o = "DOT" ->
660		if n=0 then sp else back_stk (n-1) tail
661		\| _::tail -> back_stk n tail
662		\| [] -> error "Reached begin of command history"
663
664		let back n =
665		reset_to (back_stk n !lib_stk);
666		set_command_label (current_command_label () - n - 1)
	598	reset_command_label n
	599
	600	(** Search the last label registered before defining [id] *)
	601
	602	let label_before_name (loc,id) =
	603	let found = ref false in
	604	let search = function
	605	\| (_,Leaf o) when !found && object_tag o = "DOT" -> true
	606	\| (sp,_) -> (if id = snd (repr_path (fst sp)) then found := true); false
	607	in
	608	match find_entry_p search with
	609	\| (_,Leaf o) -> outLabel o
	610	\| _ -> raise Not_found
667	611
668	612	(* State and initialization. *)
669	613

682	626	comp_name := None;
683	627	path_prefix := initial_prefix;
684	628	init_summaries()
685
686		(* Initial state. *)
687
688		let initial_state = ref None
689
690		let declare_initial_state () =
691		let name = add_anonymous_entry (FrozenState (freeze_summaries())) in
692		initial_state := Some name
693
694		let reset_initial () =
695		match !initial_state with
696		\| None ->
697		error "Resetting to the initial state is possible only interactively"
698		\| Some sp ->
699		begin match split_lib sp with
700		\| (_,[_,FrozenState fs as hd],before) ->
701		lib_stk := hd::before;
702		recalc_path_prefix ();
703		set_command_label 0;
704		unfreeze_summaries fs
705		\| _ -> assert false
706		end
707
708	629
709	630	(* Misc *)
710	631

+22

-25

library/lib.mli less more

61	61
62	62	val add_frozen_state : unit -> unit
63	63
64		(** Adds a "dummy" entry in lib_stk with a unique new label number. *)
65		val mark_end_of_command : unit -> unit
66
67		(** Returns the current label number *)
68		val current_command_label : unit -> int
69
70		(** [reset_label n] resets [lib_stk] to the label n registered by
71		[mark_end_of_command()]. It forgets the label and anything
72		registered after it. The label should be strictly in the past. *)
73		val reset_label : int -> unit
74
75	64	(** {6 ... } *)
76	65	(** The function [contents_after] returns the current library segment,
77	66	starting from a given section path. If not given, the entire segment

150	139	val open_section : Names.identifier -> unit
151	140	val close_section : unit -> unit
152	141
153		(** {6 Backtracking (undo). } *)
154
155		val reset_to : Libnames.object_name -> unit
156		val reset_name : Names.identifier Util.located -> unit
157		val remove_name : Names.identifier Util.located -> unit
158		val reset_mod : Names.identifier Util.located -> unit
159
160		(** [back n] resets to the place corresponding to the {% $ %}n{% $ %}-th call of
161		[mark_end_of_command] (counting backwards) *)
162		val back : int -> unit
	142	(** {6 Backtracking } *)
	143
	144	(** NB: The next commands are low-level ones, do not use them directly
	145	otherwise the command history stack in [Backtrack] will be out-of-sync.
	146	Also note that [reset_initial] is now [reset_label first_command_label] *)
	147
	148	(** Adds a "dummy" entry in lib_stk with a unique new label number. *)
	149	val mark_end_of_command : unit -> unit
	150
	151	(** Returns the current label number *)
	152	val current_command_label : unit -> int
	153
	154	(** The first label number *)
	155	val first_command_label : int
	156
	157	(** [reset_label n] resets [lib_stk] to the label n registered by
	158	[mark_end_of_command()]. It forgets anything registered after
	159	this label. The label should be strictly in the past. *)
	160	val reset_label : int -> unit
	161
	162	(** search the label registered immediately before adding some definition *)
	163	val label_before_name : Names.identifier Util.located -> int
163	164
164	165	(** {6 We can get and set the state of the operations (used in [States]). } *)
165	166

169	170	val unfreeze : frozen -> unit
170	171
171	172	val init : unit -> unit
172
173		val declare_initial_state : unit -> unit
174		val reset_initial : unit -> unit
175
176	173
177	174	(** XML output hooks *)
178	175	val set_xml_open_section : (Names.identifier -> unit) -> unit

+12

-0

man/coqc.1 less more

39	39	it accepts the same options as
40	40	.B coqtop.
41	41
	42	.TP
	43	.BI \-image \ bin
	44	use
	45	.I bin
	46	as underlying
	47	.B coqtop
	48	instead of the default one.
	49
	50	.TP
	51	.BI \-verbose
	52	print the compiled file on the standard output.
	53
42	54	.SH SEE ALSO
43	55
44	56	.BR coqtop (1),

+1

-7

man/coqtop.1 less more

52	52
53	53	.TP
54	54	.B \-nois
55		start with an empty intial state
	55	start with an empty initial state
56	56
57	57	.TP
58	58	.BI \-outputstate filename

134	134	.I filename
135	135
136	136	.TP
137		.BI \-user \ uid
138		use the rcfile of user
139		.I uid
140
141
142		.TP
143	137	.B \-batch
144	138	batch mode (exits just after arguments parsing)
145	139

+9

-0

myocamlbuild.ml less more

401	401	if w32 then flag ["link"; "ocaml"; "program"; "ide"]
402	402	(S [A "-ccopt"; A "-link -Wl,-subsystem,windows"; P w32ico]);
403	403
	404	(** The mingw32-ocaml cross-compiler currently uses Filename.dir_sep="/".
	405	Let's tweak that... *)
	406
	407	if w32 then begin
	408	ocaml_lib "tools/win32hack";
	409	List.iter (fun (_,s,_) -> tag_file (s^".native") ["use_win32hack"])
	410	all_binaries
	411	end;
	412
404	413	(** Coqtop *)
405	414
406	415	let () =

+68

-6

parsing/argextend.ml4 less more

106	106	value wit = $lid:"wit_"^s$;
107	107	end in WIT.wit >>
108	108
	109	let has_extraarg =
	110	List.exists (function GramNonTerminal(_,ExtraArgType _,_,_) -> true \| _ -> false)
	111
	112	let statically_known_possibly_empty s (prods,_) =
	113	List.for_all (function
	114	\| GramNonTerminal(_,ExtraArgType s',_,_) ->
	115	(* For ExtraArg we don't know (we'll have to test dynamically) *)
	116	(* unless it is a recursive call *)
	117	s <> s'
	118	\| GramNonTerminal(_,(OptArgType _\|List0ArgType _),_,_) ->
	119	(* Opt and List0 parses the empty string *)
	120	true
	121	\| _ ->
	122	(* This consumes a token for sure *) false)
	123	prods
	124
	125	let possibly_empty_subentries loc (prods,act) =
	126	let bind_name p v e = match p with
	127	\| None -> e
	128	\| Some id ->
	129	let s = Names.string_of_id id in <:expr< let $lid:s$ = $v$ in $e$ >> in
	130	let rec aux = function
	131	\| [] -> <:expr< let loc = $default_loc$ in let _ = loc = loc in $act$ >>
	132	\| GramNonTerminal(_,OptArgType _,_,p) :: tl ->
	133	bind_name p <:expr< None >> (aux tl)
	134	\| GramNonTerminal(_,List0ArgType _,_,p) :: tl ->
	135	bind_name p <:expr< [] >> (aux tl)
	136	\| GramNonTerminal(_,(ExtraArgType _ as t),_,p) :: tl ->
	137	(* We check at runtime if extraarg s parses "epsilon" *)
	138	let s = match p with None -> "_" \| Some id -> Names.string_of_id id in
	139	<:expr< let $lid:s$ = match Genarg.default_empty_value $make_rawwit loc t$ with
	140	[ None -> raise Exit
	141	\| Some v -> v ] in $aux tl$ >>
	142	\| _ -> assert false (* already filtered out *) in
	143	if has_extraarg prods then
	144	(* Needs a dynamic check; catch all exceptions if ever some rhs raises *)
	145	(* an exception rather than returning a value; *)
	146	(* declares loc because some code can refer to it; *)
	147	(* ensures loc is used to avoid "unused variable" warning *)
	148	(true, <:expr< try Some $aux prods$ with [ _ -> None ] >>)
	149	else
	150	(* Static optimisation *)
	151	(false, aux prods)
	152
	153	let make_possibly_empty_subentries loc s cl =
	154	let cl = List.filter (statically_known_possibly_empty s) cl in
	155	if cl = [] then
	156	<:expr< None >>
	157	else
	158	let rec aux = function
	159	\| (true, e) :: l ->
	160	<:expr< match $e$ with [ Some v -> Some v \| None -> $aux l$ ] >>
	161	\| (false, e) :: _ ->
	162	<:expr< Some $e$ >>
	163	\| [] ->
	164	<:expr< None >> in
	165	aux (List.map (possibly_empty_subentries loc) cl)
	166
109	167	let make_act loc act pil =
110	168	let rec make = function
111	169	\| [] -> <:expr< Pcoq.Gram.action (fun loc -> ($act$ : 'a)) >>

143	201	let interp = match f with
144	202	\| None ->
145	203	<:expr< fun ist gl x ->
146		out_gen $make_wit loc globtyp$
147		(Tacinterp.interp_genarg ist gl
148		(Genarg.in_gen $make_globwit loc globtyp$ x)) >>
	204	let (sigma,a_interp) =
	205	Tacinterp.interp_genarg ist gl
	206	(Genarg.in_gen $make_globwit loc globtyp$ x)
	207	in
	208	(sigma , out_gen $make_wit loc globtyp$ a_interp)>>
149	209	\| Some f -> <:expr< $lid:f$>> in
150	210	let substitute = match h with
151	211	\| None ->

159	219	let rawwit = <:expr< $lid:"rawwit_"^s$ >> in
160	220	let globwit = <:expr< $lid:"globwit_"^s$ >> in
161	221	let rules = mlexpr_of_list (make_rule loc) (List.rev cl) in
	222	let default_value = <:expr< $make_possibly_empty_subentries loc s cl$ >> in
162	223	declare_str_items loc
163	224	[ <:str_item<
164	225	value ($lid:"wit_"^s$, $lid:"globwit_"^s$, $lid:"rawwit_"^s$) =
165		Genarg.create_arg $se$ >>;
	226	Genarg.create_arg $default_value$ $se$>>;
166	227	<:str_item<
167	228	value $lid:s$ = Pcoq.create_generic_entry $se$ $rawwit$ >>;
168	229	<:str_item< do {

170	231	((fun e x ->
171	232	(Genarg.in_gen $globwit$ ($glob$ e (out_gen $rawwit$ x)))),
172	233	(fun ist gl x ->
173		(Genarg.in_gen $wit$ ($interp$ ist gl (out_gen $globwit$ x)))),
	234	let (sigma,a_interp) = $interp$ ist gl (out_gen $globwit$ x) in
	235	(sigma , Genarg.in_gen $wit$ a_interp)),
174	236	(fun subst x ->
175	237	(Genarg.in_gen $globwit$ ($substitute$ subst (out_gen $globwit$ x)))));
176	238	Compat.maybe_uncurry (Pcoq.Gram.extend ($lid:s$ : Pcoq.Gram.entry 'a))

194	256	[ <:str_item<
195	257	value (($lid:"wit_"^s$:Genarg.abstract_argument_type unit Genarg.tlevel),
196	258	($lid:"globwit_"^s$:Genarg.abstract_argument_type unit Genarg.glevel),
197		$lid:"rawwit_"^s$) = Genarg.create_arg $se$ >>;
	259	$lid:"rawwit_"^s$) = Genarg.create_arg None $se$ >>;
198	260	<:str_item<
199	261	value $lid:s$ = Pcoq.create_generic_entry $se$ $rawwit$ >>;
200	262	<:str_item< do {

+29

-12

parsing/egrammar.ml less more

105	105	in
106	106	make ([],[],[]) (List.rev pil)
107	107
	108	let check_cases_pattern_env loc (env,envlist,hasbinders) =
	109	if hasbinders then error_invalid_pattern_notation loc else (env,envlist)
	110
108	111	let make_cases_pattern_action
109	112	(f : loc -> cases_pattern_notation_substitution -> cases_pattern_expr) pil =
110		let rec make (env,envlist as fullenv) = function
	113	let rec make (env,envlist,hasbinders as fullenv) = function
111	114	\| [] ->
112		Gram.action (fun loc -> f loc fullenv)
	115	Gram.action (fun loc -> f loc (check_cases_pattern_env loc fullenv))
113	116	\| (GramConstrTerminal _ \| GramConstrNonTerminal (_,None)) :: tl ->
114	117	(* parse a non-binding item *)
115	118	Gram.action (fun _ -> make fullenv tl)

117	120	(* parse a binding non-terminal *)
118	121	(match typ with
119	122	\| ETConstr _ -> (* pattern non-terminal *)
120		Gram.action (fun (v:cases_pattern_expr) -> make (v::env,envlist) tl)
	123	Gram.action (fun (v:cases_pattern_expr) ->
	124	make (v::env, envlist, hasbinders) tl)
121	125	\| ETReference ->
122	126	Gram.action (fun (v:reference) ->
123		make (CPatAtom (dummy_loc,Some v) :: env, envlist) tl)
	127	make (CPatAtom (dummy_loc,Some v) :: env, envlist, hasbinders) tl)
124	128	\| ETName ->
125	129	Gram.action (fun (na:name located) ->
126		make (cases_pattern_expr_of_name na :: env, envlist) tl)
	130	make (cases_pattern_expr_of_name na :: env, envlist, hasbinders) tl)
127	131	\| ETBigint ->
128	132	Gram.action (fun (v:Bigint.bigint) ->
129		make (CPatPrim (dummy_loc,Numeral v) :: env, envlist) tl)
	133	make (CPatPrim (dummy_loc,Numeral v) :: env, envlist, hasbinders) tl)
130	134	\| ETConstrList (_,_) ->
131	135	Gram.action (fun (vl:cases_pattern_expr list) ->
132		make (env, vl :: envlist) tl)
133		\| (ETPattern \| ETBinderList _ \| ETBinder _ \| ETOther _) ->
134		failwith "Unexpected entry of type cases pattern or other")
	136	make (env, vl :: envlist, hasbinders) tl)
	137	\| ETBinder _ \| ETBinderList (true,_) ->
	138	Gram.action (fun (v:local_binder list) ->
	139	make (env, envlist, hasbinders) tl)
	140	\| ETBinderList (false,_) ->
	141	Gram.action (fun (v:local_binder list list) ->
	142	make (env, envlist, true) tl)
	143	\| (ETPattern \| ETOther _) ->
	144	anomaly "Unexpected entry of type cases pattern or other")
135	145	\| GramConstrListMark (n,b) :: tl ->
136	146	(* Rebuild expansions of ConstrList *)
137	147	let heads,env = list_chop n env in
138		if b then make (env,(heads@List.hd envlist)::List.tl envlist) tl
139		else make (env,heads::envlist) tl
	148	if b then
	149	make (env,(heads@List.hd envlist)::List.tl envlist,hasbinders) tl
	150	else
	151	make (env,heads::envlist,hasbinders) tl
140	152	in
141		make ([],[]) (List.rev pil)
	153	make ([],[],false) (List.rev pil)
142	154
143	155	let rec make_constr_prod_item assoc from forpat = function
144	156	\| GramConstrTerminal tok :: l ->

348	360	{ freeze_function = freeze;
349	361	unfreeze_function = unfreeze;
350	362	init_function = init }
	363
	364	let with_grammar_rule_protection f x =
	365	let fs = freeze () in
	366	try let a = f x in unfreeze fs; a
	367	with e -> unfreeze fs; raise e

+2

-0

parsing/egrammar.mli less more

70	70	val recover_notation_grammar :
71	71	notation -> (precedence * tolerability list) ->
72	72	notation_var_internalization_type list * notation_grammar
	73
	74	val with_grammar_rule_protection : ('a -> 'b) -> 'a -> 'b

+6

-6

parsing/extrawit.ml less more

14	14
15	15	let tactic_main_level = 5
16	16
17		let (wit_tactic0,globwit_tactic0,rawwit_tactic0) = create_arg "tactic0"
18		let (wit_tactic1,globwit_tactic1,rawwit_tactic1) = create_arg "tactic1"
19		let (wit_tactic2,globwit_tactic2,rawwit_tactic2) = create_arg "tactic2"
20		let (wit_tactic3,globwit_tactic3,rawwit_tactic3) = create_arg "tactic3"
21		let (wit_tactic4,globwit_tactic4,rawwit_tactic4) = create_arg "tactic4"
22		let (wit_tactic5,globwit_tactic5,rawwit_tactic5) = create_arg "tactic5"
	17	let (wit_tactic0,globwit_tactic0,rawwit_tactic0) = create_arg None "tactic0"
	18	let (wit_tactic1,globwit_tactic1,rawwit_tactic1) = create_arg None "tactic1"
	19	let (wit_tactic2,globwit_tactic2,rawwit_tactic2) = create_arg None "tactic2"
	20	let (wit_tactic3,globwit_tactic3,rawwit_tactic3) = create_arg None "tactic3"
	21	let (wit_tactic4,globwit_tactic4,rawwit_tactic4) = create_arg None "tactic4"
	22	let (wit_tactic5,globwit_tactic5,rawwit_tactic5) = create_arg None "tactic5"
23	23
24	24	let wit_tactic = function
25	25	\| 0 -> wit_tactic0

+17

-7

parsing/g_constr.ml4 less more

29	29	let mk_cast = function
30	30	(c,(_,None)) -> c
31	31	\| (c,(_,Some ty)) -> CCast(join_loc (constr_loc c) (constr_loc ty), c, CastConv (DEFAULTcast, ty))
	32
	33	let binders_of_names l =
	34	List.map (fun (loc, na) ->
	35	LocalRawAssum ([loc, na], Default Explicit,
	36	CHole (loc, Some (Evd.BinderType na)))) l
32	37
33	38	let binders_of_lidents l =
34	39	List.map (fun (loc, id) ->

94	99	\| _ -> err ())
95	100	\| _ -> err ())
96	101
97		let ident_colon =
98		Gram.Entry.of_parser "ident_colon"
	102	let name_colon =
	103	Gram.Entry.of_parser "name_colon"
99	104	(fun strm ->
100	105	match get_tok (stream_nth 0 strm) with
101	106	\| IDENT s ->
102	107	(match get_tok (stream_nth 1 strm) with
103	108	\| KEYWORD ":" ->
104	109	stream_njunk 2 strm;
105		Names.id_of_string s
	110	Name (Names.id_of_string s)
	111	\| _ -> err ())
	112	\| KEYWORD "_" ->
	113	(match get_tok (stream_nth 1 strm) with
	114	\| KEYWORD ":" ->
	115	stream_njunk 2 strm;
	116	Anonymous
106	117	\| _ -> err ())
107	118	\| _ -> err ())
108	119

377	388	[LocalRawAssum (id::idl,Default Explicit,c)]
378	389	(* binders factorized with open binder *)
379	390	\| id = name; idl = LIST0 name; bl = binders ->
380		let t = CHole (loc, Some (Evd.BinderType (snd id))) in
381		LocalRawAssum (id::idl,Default Explicit,t)::bl
	391	binders_of_names (id::idl) @ bl
382	392	\| id1 = name; ".."; id2 = name ->
383	393	[LocalRawAssum ([id1;(loc,Name ldots_var);id2],
384	394	Default Explicit,CHole (loc,None))]

420	430	[ [ "!" ; c = operconstr LEVEL "200" -> (loc, Anonymous), true, c
421	431	\| "{"; id = name; "}"; ":" ; expl = [ "!" -> true \| -> false ] ; c = operconstr LEVEL "200" ->
422	432	id, expl, c
423		\| iid=ident_colon ; expl = [ "!" -> true \| -> false ] ; c = operconstr LEVEL "200" ->
424		(loc, Name iid), expl, c
	433	\| iid=name_colon ; expl = [ "!" -> true \| -> false ] ; c = operconstr LEVEL "200" ->
	434	(loc, iid), expl, c
425	435	\| c = operconstr LEVEL "200" ->
426	436	(loc, Anonymous), false, c
427	437	] ]

+2

-19

parsing/g_proofs.ml4 less more

22	22	GEXTEND Gram
23	23	GLOBAL: command;
24	24
25		destruct_location :
26		[ [ IDENT "Conclusion" -> Tacexpr.ConclLocation ()
27		\| discard = [ IDENT "Discardable" -> true \| -> false ]; "Hypothesis"
28		-> Tacexpr.HypLocation discard ] ]
29		;
30	25	opt_hintbases:
31	26	[ [ -> []
32	27	\| ":"; l = LIST1 [id = IDENT -> id ] -> l ] ]

57	52	\| IDENT "Defined" -> VernacEndProof (Proved (false,None))
58	53	\| IDENT "Defined"; id=identref ->
59	54	VernacEndProof (Proved (false,Some (id,None)))
60		\| IDENT "Suspend" -> VernacSuspend
61		\| IDENT "Resume" -> VernacResume None
62		\| IDENT "Resume"; id = identref -> VernacResume (Some id)
63	55	\| IDENT "Restart" -> VernacRestart
64	56	\| IDENT "Undo" -> VernacUndo 1
65	57	\| IDENT "Undo"; n = natural -> VernacUndo n

67	59	\| IDENT "Focus" -> VernacFocus None
68	60	\| IDENT "Focus"; n = natural -> VernacFocus (Some n)
69	61	\| IDENT "Unfocus" -> VernacUnfocus
70		\| IDENT "BeginSubproof" -> VernacSubproof None
71		\| IDENT "BeginSubproof"; n = natural -> VernacSubproof (Some n)
72		\| IDENT "EndSubproof" -> VernacEndSubproof
	62	\| IDENT "Unfocused" -> VernacUnfocused
73	63	\| IDENT "Show" -> VernacShow (ShowGoal OpenSubgoals)
74	64	\| IDENT "Show"; n = natural -> VernacShow (ShowGoal (NthGoal n))
75	65	\| IDENT "Show"; IDENT "Goal"; n = string ->

117	107	\| IDENT "Constructors"; lc = LIST1 global -> HintsConstructors lc
118	108	\| IDENT "Extern"; n = natural; c = OPT constr_pattern ; "=>";
119	109	tac = tactic ->
120		HintsExtern (n,c,tac)
121		\| IDENT "Destruct";
122		id = ident; ":=";
123		pri = natural;
124		dloc = destruct_location;
125		hyptyp = constr_pattern;
126		"=>"; tac = tactic ->
127		HintsDestruct(id,pri,dloc,hyptyp,tac) ] ]
	110	HintsExtern (n,c,tac) ] ]
128	111	;
129	112	constr_body:
130	113	[ [ ":="; c = lconstr -> c

+12

-15

parsing/g_tactic.ml4 less more

347	347	\| IDENT "lazy"; s = strategy_flag -> Lazy s
348	348	\| IDENT "compute"; delta = delta_flag -> Cbv (all_with delta)
349	349	\| IDENT "vm_compute" -> CbvVm
350		\| IDENT "unfold"; ul = LIST1 unfold_occ -> Unfold ul
	350	\| IDENT "unfold"; ul = LIST1 unfold_occ SEP "," -> Unfold ul
351	351	\| IDENT "fold"; cl = LIST1 constr -> Fold cl
352	352	\| IDENT "pattern"; pl = LIST1 pattern_occ SEP"," -> Pattern pl
353	353	\| s = IDENT -> ExtraRedExpr s ] ]

596	596
597	597	(* Automation tactic *)
598	598	\| IDENT "trivial"; lems = auto_using; db = hintbases ->
599		TacTrivial (lems,db)
	599	TacTrivial (Off,lems,db)
	600	\| IDENT "info_trivial"; lems = auto_using; db = hintbases ->
	601	TacTrivial (Info,lems,db)
	602	\| IDENT "debug"; IDENT "trivial"; lems = auto_using; db = hintbases ->
	603	TacTrivial (Debug,lems,db)
	604
600	605	\| IDENT "auto"; n = OPT int_or_var; lems = auto_using; db = hintbases ->
601		TacAuto (n,lems,db)
602
603		(* Obsolete since V8.0
604		\| IDENT "autotdb"; n = OPT natural -> TacAutoTDB n
605		\| IDENT "cdhyp"; id = identref -> TacDestructHyp (true,id)
606		\| IDENT "dhyp"; id = identref -> TacDestructHyp (false,id)
607		\| IDENT "dconcl" -> TacDestructConcl
608		\| IDENT "superauto"; l = autoargs -> TacSuperAuto l
609		*)
610		\| IDENT "auto"; IDENT "decomp"; p = OPT natural;
611		lems = auto_using -> TacDAuto (None,p,lems)
612		\| IDENT "auto"; n = OPT int_or_var; IDENT "decomp"; p = OPT natural;
613		lems = auto_using -> TacDAuto (n,p,lems)
	606	TacAuto (Off,n,lems,db)
	607	\| IDENT "info_auto"; n = OPT int_or_var; lems = auto_using;
	608	db = hintbases -> TacAuto (Info,n,lems,db)
	609	\| IDENT "debug"; IDENT "auto"; n = OPT int_or_var; lems = auto_using;
	610	db = hintbases -> TacAuto (Debug,n,lems,db)
614	611
615	612	(* Context management *)
616	613	\| IDENT "clear"; "-"; l = LIST1 id_or_meta -> TacClear (true, l)

+2

-2

parsing/g_vernac.ml4 less more

142	142	(* Gallina declarations *)
143	143	GEXTEND Gram
144	144	GLOBAL: gallina gallina_ext thm_token def_body of_type_with_opt_coercion
145		typeclass_constraint record_field decl_notation rec_definition;
	145	record_field decl_notation rec_definition;
146	146
147	147	gallina:
148	148	(* Definition, Theorem, Variable, Axiom, ... *)

655	655	\| IDENT "clear"; IDENT "implicits" -> [`ClearImplicits]
656	656	\| IDENT "clear"; IDENT "scopes" -> [`ClearScopes]
657	657	\| IDENT "rename" -> [`Rename]
	658	\| IDENT "extra"; IDENT "scopes" -> [`ExtraScopes]
658	659	\| IDENT "clear"; IDENT "scopes"; IDENT "and"; IDENT "implicits" ->
659	660	[`ClearImplicits; `ClearScopes]
660	661	\| IDENT "clear"; IDENT "implicits"; IDENT "and"; IDENT "scopes" ->

926	927
927	928	(* Resetting *)
928	929	\| IDENT "Reset"; id = identref -> VernacResetName id
929		\| IDENT "Delete"; id = identref -> VernacRemoveName id
930	930	\| IDENT "Reset"; IDENT "Initial" -> VernacResetInitial
931	931	\| IDENT "Back" -> VernacBack 1
932	932	\| IDENT "Back"; n = natural -> VernacBack n

+44

-28

parsing/ppconstr.ml less more

218	218	\| Explicit -> str"(" ++ p ++ str")"
219	219	\| Implicit -> str"{" ++ p ++ str"}"
220	220
221		let surround_binder k p =
222		match k with
223		\| Default b -> hov 1 (surround_impl b p)
224		\| Generalized (b, b', t) ->
225		hov 1 (surround_impl b' (surround_impl b p))
226
227	221	let surround_implicit k p =
228	222	match k with
229		\| Default Explicit -> p
230		\| Default Implicit -> (str"{" ++ p ++ str"}")
231		\| Generalized (b, b', t) ->
232		surround_impl b' (surround_impl b p)
	223	\| Explicit -> p
	224	\| Implicit -> (str"{" ++ p ++ str"}")
233	225
234	226	let pr_binder many pr (nal,k,t) =
235		match t with
236		\| CHole _ -> prlist_with_sep spc pr_lname nal
237		\| _ ->
238		let s = prlist_with_sep spc pr_lname nal ++ str" : " ++ pr t in
239		hov 1 (if many then surround_binder k s else surround_implicit k s)
	227	match k with
	228	\| Generalized (b, b', t') ->
	229	assert (b=Implicit);
	230	begin match nal with
	231	\|[loc,Anonymous] ->
	232	hov 1 (str"`" ++ (surround_impl b'
	233	((if t' then str "!" else mt ()) ++ pr t)))
	234	\|[loc,Name id] ->
	235	hov 1 (str "`" ++ (surround_impl b'
	236	(pr_lident (loc,id) ++ str " : " ++
	237	(if t' then str "!" else mt()) ++ pr t)))
	238	\|_ -> anomaly "List of generalized binders have alwais one element."
	239	end
	240	\| Default b ->
	241	match t with
	242	\| CHole _ ->
	243	let s = prlist_with_sep spc pr_lname nal in
	244	hov 1 (surround_implicit b s)
	245	\| _ ->
	246	let s = prlist_with_sep spc pr_lname nal ++ str " : " ++ pr t in
	247	hov 1 (if many then surround_impl b s else surround_implicit b s)
240	248
241	249	let pr_binder_among_many pr_c = function
242	250	\| LocalRawAssum (nal,k,t) ->

322	330	pr_opt_type_spc pr t ++ str " :=" ++
323	331	pr_sep_com (fun () -> brk(1,2)) (pr_body ltop) c
324	332
325		let pr_fixdecl pr prd dangling_with_for ((_,id),(n,ro),bl,t,c) =
326		let annot =
327		match ro with
328		CStructRec ->
329		if List.length bl > 1 && n <> None then
330		spc() ++ str "{struct " ++ pr_id (snd (Option.get n)) ++ str"}"
331		else mt()
332		\| CWfRec c ->
333		spc () ++ str "{wf " ++ pr lsimple c ++ pr_id (snd (Option.get n)) ++ str"}"
334		\| CMeasureRec (m,r) ->
335		spc () ++ str "{measure " ++ pr lsimple m ++ pr_id (snd (Option.get n)) ++
336		(match r with None -> mt() \| Some r -> str" on " ++ pr lsimple r) ++ str"}"
337		in
	333	let pr_guard_annot pr_aux bl (n,ro) =
	334	match n with
	335	\| None -> mt ()
	336	\| Some (loc, id) ->
	337	match (ro : Topconstr.recursion_order_expr) with
	338	\| CStructRec ->
	339	let names_of_binder = function
	340	\| LocalRawAssum (nal,_,_) -> nal
	341	\| LocalRawDef (_,_) -> []
	342	in let ids = List.flatten (List.map names_of_binder bl) in
	343	if List.length ids > 1 then
	344	spc() ++ str "{struct " ++ pr_id id ++ str"}"
	345	else mt()
	346	\| CWfRec c ->
	347	spc() ++ str "{wf " ++ pr_aux c ++ spc() ++ pr_id id ++ str"}"
	348	\| CMeasureRec (m,r) ->
	349	spc() ++ str "{measure " ++ pr_aux m ++ spc() ++ pr_id id++
	350	(match r with None -> mt() \| Some r -> str" on " ++ pr_aux r) ++ str"}"
	351
	352	let pr_fixdecl pr prd dangling_with_for ((_,id),ro,bl,t,c) =
	353	let annot = pr_guard_annot (pr lsimple) bl ro in
338	354	pr_recursive_decl pr prd dangling_with_for id bl annot t c
339	355
340	356	let pr_cofixdecl pr prd dangling_with_for ((_,id),bl,t,c) =

+5

-1

parsing/ppconstr.mli less more

50	50	('a -> std_ppcmds) -> 'a with_occurrences -> std_ppcmds
51	51	val pr_red_expr :
52	52	('a -> std_ppcmds) * ('a -> std_ppcmds) * ('b -> std_ppcmds) * ('c -> std_ppcmds) ->
53		('a,'b,'c) red_expr_gen -> std_ppcmds
	53	('a,'b,'c) red_expr_gen -> std_ppcmds
54	54	val pr_may_eval :
55	55	('a -> std_ppcmds) -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) ->
56	56	('c -> std_ppcmds) -> ('a,'b,'c) may_eval -> std_ppcmds
57	57
58	58	val pr_glob_sort : glob_sort -> std_ppcmds
	59	val pr_guard_annot : (constr_expr -> std_ppcmds) ->
	60	local_binder list ->
	61	('a * Names.identifier) option * recursion_order_expr ->
	62	std_ppcmds
59	63
60	64	val pr_binders : local_binder list -> std_ppcmds
61	65	val pr_constr_pattern_expr : constr_pattern_expr -> std_ppcmds

+14

-16

parsing/pptactic.ml less more

514	514	\| l -> spc () ++
515	515	hov 2 (str "using" ++ spc () ++ prlist_with_sep pr_comma prc l)
516	516
	517	let string_of_debug = function
	518	\| Off -> ""
	519	\| Debug -> "debug "
	520	\| Info -> "info_"
	521
517	522	let pr_then () = str ";"
518	523
519	524	let ltop = (5,E)

622	627	\| TacAssumption -> str "assumption"
623	628	\| TacAnyConstructor (false,None) -> str "constructor"
624	629	\| TacAnyConstructor (true,None) -> str "econstructor"
625		\| TacTrivial ([],Some []) -> str "trivial"
626		\| TacAuto (None,[],Some []) -> str "auto"
	630	\| TacTrivial (d,[],Some []) -> str (string_of_debug d ^ "trivial")
	631	\| TacAuto (d,None,[],Some []) -> str (string_of_debug d ^ "auto")
627	632	\| TacReflexivity -> str "reflexivity"
628	633	\| TacClear (true,[]) -> str "clear"
629	634	\| t -> str "(" ++ pr_atom1 t ++ str ")"
630	635
631	636	(* Main tactic printer *)
632	637	and pr_atom1 = function
633		\| TacAutoTDB _ \| TacDestructHyp _ \| TacDestructConcl
634		\| TacSuperAuto _ \| TacExtend (_,
635		("GTauto"\|"GIntuition"\|"TSimplif"\|
636		"LinearIntuition"),_) ->
637		errorlabstrm "Obsolete V8" (str "Tactic is not ported to V8.0")
638	638	\| TacExtend (loc,s,l) ->
639	639	pr_with_comments loc (pr_extend 1 s l)
640	640	\| TacAlias (loc,s,l,_) ->

741	741	hov 1 (str "lapply" ++ pr_constrarg c)
742	742
743	743	(* Automation tactics *)
744		\| TacTrivial ([],Some []) as x -> pr_atom0 x
745		\| TacTrivial (lems,db) ->
746		hov 0 (str "trivial" ++
	744	\| TacTrivial (_,[],Some []) as x -> pr_atom0 x
	745	\| TacTrivial (d,lems,db) ->
	746	hov 0 (str (string_of_debug d ^ "trivial") ++
747	747	pr_auto_using pr_constr lems ++ pr_hintbases db)
748		\| TacAuto (None,[],Some []) as x -> pr_atom0 x
749		\| TacAuto (n,lems,db) ->
750		hov 0 (str "auto" ++ pr_opt (pr_or_var int) n ++
	748	\| TacAuto (_,None,[],Some []) as x -> pr_atom0 x
	749	\| TacAuto (d,n,lems,db) ->
	750	hov 0 (str (string_of_debug d ^ "auto") ++
	751	pr_opt (pr_or_var int) n ++
751	752	pr_auto_using pr_constr lems ++ pr_hintbases db)
752		\| TacDAuto (n,p,lems) ->
753		hov 1 (str "auto" ++ pr_opt (pr_or_var int) n ++ str "decomp" ++
754		pr_opt int p ++ pr_auto_using pr_constr lems)
755	753
756	754	(* Context management *)
757	755	\| TacClear (true,[]) as t -> pr_atom0 t

+19

-57

parsing/ppvernac.ml less more

202	202	let pat = match c with None -> mt () \| Some pat -> pr_pat pat in
203	203	str "Extern" ++ spc() ++ int n ++ spc() ++ pat ++ str" =>" ++
204	204	spc() ++ pr_raw_tactic tac
205		\| HintsDestruct(name,i,loc,c,tac) ->
206		str "Destruct " ++ pr_id name ++ str" :=" ++ spc() ++
207		hov 0 (int i ++ spc() ++ pr_destruct_location loc ++ spc() ++
208		pr_c c ++ str " =>") ++ spc() ++
209		pr_raw_tactic tac in
	205	in
210	206	hov 2 (str"Hint "++pr_locality local ++ pph ++ opth)
211	207
212	208	let pr_with_declaration pr_c = function

290	286
291	287	let pr_and_type_binders_arg bl =
292	288	pr_binders_arg bl
293
294		let names_of_binder = function
295		\| LocalRawAssum (nal,_,_) -> nal
296		\| LocalRawDef (_,_) -> []
297
298		let pr_guard_annot bl (n,ro) =
299		match n with
300		\| None -> mt ()
301		\| Some (loc, id) ->
302		match (ro : Topconstr.recursion_order_expr) with
303		\| CStructRec ->
304		let ids = List.flatten (List.map names_of_binder bl) in
305		if List.length ids > 1 then
306		spc() ++ str "{struct " ++ pr_id id ++ str"}"
307		else mt()
308		\| CWfRec c ->
309		spc() ++ str "{wf " ++ pr_lconstr_expr c ++ spc() ++
310		pr_id id ++ str"}"
311		\| CMeasureRec (m,r) ->
312		spc() ++ str "{measure " ++ pr_lconstr_expr m ++ spc() ++
313		pr_id id ++ (match r with None -> mt() \| Some r -> str" on " ++
314		pr_lconstr_expr r) ++ str"}"
315	289
316	290	let pr_onescheme (idop,schem) =
317	291	match schem with

418	392	hov 1
419	393	(head ++ spc() ++ pr_lident (Option.get id) ++ spc() ++
420	394	(match bl with [] -> mt() \| _ -> pr_binders bl ++ spc()) ++
421		pr_opt (pr_guard_annot bl) guard ++
	395	pr_opt (pr_guard_annot pr_lconstr_expr bl) guard ++
422	396	str":" ++ pr_spc_lconstr c)
423	397
424	398	(**************************************)

461	435	(* Proof management *)
462	436	\| VernacAbortAll -> str "Abort All"
463	437	\| VernacRestart -> str"Restart"
464		\| VernacSuspend -> str"Suspend"
465	438	\| VernacUnfocus -> str"Unfocus"
	439	\| VernacUnfocused -> str"Unfocused"
466	440	\| VernacGoal c -> str"Goal" ++ pr_lconstrarg c
467	441	\| VernacAbort id -> str"Abort" ++ pr_opt pr_lident id
468		\| VernacResume id -> str"Resume" ++ pr_opt pr_lident id
469	442	\| VernacUndo i -> if i=1 then str"Undo" else str"Undo" ++ pr_intarg i
470	443	\| VernacUndoTo i -> str"Undo" ++ spc() ++ str"To" ++ pr_intarg i
471	444	\| VernacBacktrack (i,j,k) ->

492	465	\| VernacCheckGuard -> str"Guarded"
493	466
494	467	(* Resetting *)
495		\| VernacRemoveName id -> str"Remove" ++ spc() ++ pr_lident id
496	468	\| VernacResetName id -> str"Reset" ++ spc() ++ pr_lident id
497	469	\| VernacResetInitial -> str"Reset Initial"
498	470	\| VernacBack i -> if i=1 then str"Back" else str"Back" ++ pr_intarg i

626	598	let (_,_,_,k,_),_ = List.hd l in
627	599	match k with Record -> "Record" \| Structure -> "Structure"
628	600	\| Inductive_kw -> "Inductive" \| CoInductive -> "CoInductive"
629		\| Class b -> if b then "Definitional Class" else "Class" in
	601	\| Class _ -> "Class" in
630	602	hov 1 (pr_oneind key (List.hd l)) ++
631	603	(prlist (fun ind -> fnl() ++ hov 1 (pr_oneind "with" ind)) (List.tl l))
632	604

634	606	\| VernacFixpoint recs ->
635	607	let pr_onerec = function
636	608	\| ((loc,id),ro,bl,type_,def),ntn ->
637		let annot = pr_guard_annot bl ro in
638		pr_id id ++ pr_binders_arg bl ++ annot ++ spc()
	609	let annot = pr_guard_annot pr_lconstr_expr bl ro in
	610	pr_id id ++ pr_binders_arg bl ++ annot
639	611	++ pr_type_option (fun c -> spc() ++ pr_lconstr_expr c) type_
640		++ pr_opt (fun def -> str" :=" ++ brk(1,2) ++ pr_lconstr def) def ++
	612	++ pr_opt (fun def -> str":=" ++ brk(1,2) ++ pr_lconstr def) def ++
641	613	prlist (pr_decl_notation pr_constr) ntn
642	614	in
643	615	hov 0 (str "Fixpoint" ++ spc() ++

689	661	spc() ++ str":" ++ spc() ++ pr_class_rawexpr c1 ++ spc() ++ str">->" ++
690	662	spc() ++ pr_class_rawexpr c2)
691	663
692
693		(* \| VernacClass (id, par, ar, sup, props) -> *)
694		(* hov 1 ( *)
695		(* str"Class" ++ spc () ++ pr_lident id ++ *)
696		(* (\* prlist_with_sep (spc) (pr_lident_constr (spc() ++ str ":" ++ spc())) par ++ \) )
697		(* pr_and_type_binders_arg par ++ *)
698		(* (match ar with Some ar -> spc () ++ str":" ++ spc() ++ pr_glob_sort (snd ar) \| None -> mt()) ++ *)
699		(* spc () ++ str":=" ++ spc () ++ *)
700		(* prlist_with_sep (fun () -> str";" ++ spc()) *)
701		(* (fun (lid,oc,c) -> pr_lident_constr ((if oc then str" :>" else str" :") ++ spc()) (lid,c)) props ) *)
702
703	664	\| VernacInstance (abst,glob, sup, (instid, bk, cl), props, pri) ->
704	665	hov 1 (
705	666	pr_non_locality (not glob) ++
706	667	(if abst then str"Declare " else mt ()) ++
707		str"Instance" ++ spc () ++
708		pr_and_type_binders_arg sup ++
709		str"=>" ++ spc () ++
710		(match snd instid with Name id -> pr_lident (fst instid, id) ++ spc () ++ str":" ++ spc () \| Anonymous -> mt ()) ++
711		pr_constr_expr cl ++ spc () ++
	668	str"Instance" ++
	669	(match snd instid with Name id -> spc () ++ pr_lident (fst instid, id) ++ spc () \|
	670	Anonymous -> mt ()) ++
	671	pr_and_type_binders_arg sup ++
	672	str":" ++ spc () ++
	673	pr_constr_expr cl ++ spc () ++
712	674	(match props with
713	675	\| Some p -> spc () ++ str":=" ++ spc () ++ pr_constr_expr p
714	676	\| None -> mt()))
715	677
716	678	\| VernacContext l ->
717	679	hov 1 (
718		str"Context" ++ spc () ++ str"[" ++ spc () ++
719		pr_and_type_binders_arg l ++ spc () ++ str "]")
	680	str"Context" ++ spc () ++ pr_and_type_binders_arg l)
720	681
721	682
722	683	\| VernacDeclareInstances (glob, ids) ->

816	777	pr_hints local dbnames h pr_constr pr_constr_pattern_expr
817	778	\| VernacSyntacticDefinition (id,(ids,c),local,onlyparsing) ->
818	779	hov 2
819		(pr_locality local ++ str"Notation " ++ pr_lident id ++
820		prlist_with_sep spc pr_id ids ++ str" :=" ++ pr_constrarg c ++
	780	(pr_locality local ++ str"Notation " ++ pr_lident id ++ spc () ++
	781	prlist (fun x -> spc() ++ pr_id x) ids ++ str":=" ++ pr_constrarg c ++
821	782	pr_syntax_modifiers (if onlyparsing then [SetOnlyParsing] else []))
822	783	\| VernacDeclareImplicits (local,q,[]) ->
823	784	hov 2 (pr_section_locality local ++ str"Implicit Arguments" ++ spc() ++

851	812	\| `SimplNeverUnfold -> str "simpl never"
852	813	\| `DefaultImplicits -> str "default implicits"
853	814	\| `Rename -> str "rename"
	815	\| `ExtraScopes -> str "extra scopes"
854	816	\| `ClearImplicits -> str "clear implicits"
855	817	\| `ClearScopes -> str "clear scopes")
856	818	mods)

977	939	\| Star -> str"*"
978	940	\| Plus -> str"+"
979	941	end ++ spc()
980		\| VernacSubproof None -> str "BeginSubproof"
	942	\| VernacSubproof None -> str "{"
981	943	\| VernacSubproof (Some i) -> str "BeginSubproof " ++ pr_int i
982		\| VernacEndSubproof -> str "EndSubproof"
	944	\| VernacEndSubproof -> str "}"
983	945
984	946	and pr_extend s cl =
985	947	let pr_arg a =

+24

-17

parsing/printer.ml less more

34	34	(**********************************************************************)
35	35	(** Terms *)
36	36
37		(* [at_top] means ids of env must be avoided in bound variables *)
38		let pr_constr_core at_top env t =
39		pr_constr_expr (extern_constr at_top env t)
40		let pr_lconstr_core at_top env t =
41		pr_lconstr_expr (extern_constr at_top env t)
42
43		let pr_lconstr_env_at_top env = pr_lconstr_core true env
	37	(* [goal_concl_style] means that all names of goal/section variables
	38	and all names of rel variables (if any) in the given env and all short
	39	names of global definitions of the current module must be avoided while
	40	printing bound variables.
	41	Otherwise, short names of global definitions are printed qualified
	42	and only names of goal/section variables and rel names that do
	43	_not_ occur in the scope of the binder to be printed are avoided. *)
	44
	45	let pr_constr_core goal_concl_style env t =
	46	pr_constr_expr (extern_constr goal_concl_style env t)
	47	let pr_lconstr_core goal_concl_style env t =
	48	pr_lconstr_expr (extern_constr goal_concl_style env t)
	49
44	50	let pr_lconstr_env env = pr_lconstr_core false env
45	51	let pr_constr_env env = pr_constr_core false env
46	52

67	73	let pr_constr_under_binders c = pr_constr_under_binders_env (Global.env()) c
68	74	let pr_lconstr_under_binders c = pr_lconstr_under_binders_env (Global.env()) c
69	75
70		let pr_type_core at_top env t =
71		pr_constr_expr (extern_type at_top env t)
72		let pr_ltype_core at_top env t =
73		pr_lconstr_expr (extern_type at_top env t)
74
75		let pr_ltype_env_at_top env = pr_ltype_core true env
	76	let pr_type_core goal_concl_style env t =
	77	pr_constr_expr (extern_type goal_concl_style env t)
	78	let pr_ltype_core goal_concl_style env t =
	79	pr_lconstr_expr (extern_type goal_concl_style env t)
	80
	81	let pr_goal_concl_style_env env = pr_ltype_core true env
76	82	let pr_ltype_env env = pr_ltype_core false env
77	83	let pr_type_env env = pr_type_core false env
78	84

261	267	let preamb,thesis,penv,pc =
262	268	mt (), mt (),
263	269	pr_context_of env,
264		pr_ltype_env_at_top env (Goal.V82.concl sigma g)
	270	pr_goal_concl_style_env env (Goal.V82.concl sigma g)
265	271	in
266	272	preamb ++
267	273	str" " ++ hv 0 (penv ++ fnl () ++

278	284	let pr_concl n sigma g =
279	285	let (g,sigma) = Goal.V82.nf_evar sigma g in
280	286	let env = Goal.V82.env sigma g in
281		let pc = pr_ltype_env_at_top env (Goal.V82.concl sigma g) in
	287	let pc = pr_goal_concl_style_env env (Goal.V82.concl sigma g) in
282	288	str (emacs_str "") ++
283	289	str "subgoal " ++ int n ++ pr_goal_tag g ++
284	290	str " is:" ++ cut () ++ str" " ++ pc

362	368	let pei = pr_evars_int 1 exl in
363	369	(str "No more subgoals but non-instantiated existential " ++
364	370	str "variables:" ++ fnl () ++ (hov 0 pei)
365		++ emacs_print_dependent_evars sigma seeds)
	371	++ emacs_print_dependent_evars sigma seeds ++ fnl () ++
	372	str "You can use Grab Existential Variables.")
366	373	end
367	374	\| [g] ->
368	375	let pg = default_pr_goal { it = g ; sigma = sigma } in

423	430	begin match bgoals with
424	431	\| [] -> pr_subgoals None sigma seeds goals
425	432	\| _ -> pr_subgoals None bsigma seeds bgoals ++ fnl () ++ fnl () ++
426		str"This subproof is complete, but there are still unfocused goals:"
	433	str"This subproof is complete, but there are still unfocused goals." ++ fnl ()
427	434	(* spiwack: to stay compatible with the proof general and coqide,
428	435	I use print the message after the goal. It would be better to have
429	436	something like:

+1

-2

parsing/printer.mli less more

25	25	(** Terms *)
26	26
27	27	val pr_lconstr_env : env -> constr -> std_ppcmds
28		val pr_lconstr_env_at_top : env -> constr -> std_ppcmds
29	28	val pr_lconstr : constr -> std_ppcmds
30	29
31	30	val pr_constr_env : env -> constr -> std_ppcmds

43	42	val pr_lconstr_under_binders_env : env -> constr_under_binders -> std_ppcmds
44	43	val pr_lconstr_under_binders : constr_under_binders -> std_ppcmds
45	44
46		val pr_ltype_env_at_top : env -> types -> std_ppcmds
	45	val pr_goal_concl_style_env : env -> types -> std_ppcmds
47	46	val pr_ltype_env : env -> types -> std_ppcmds
48	47	val pr_ltype : types -> std_ppcmds
49	48

+11

-4

parsing/q_coqast.ml4 less more

271	271	\| Tacexpr.MsgString s -> <:expr< Tacexpr.MsgString $str:s$ >>
272	272	\| Tacexpr.MsgInt n -> <:expr< Tacexpr.MsgInt $mlexpr_of_int n$ >>
273	273	\| Tacexpr.MsgIdent id -> <:expr< Tacexpr.MsgIdent $mlexpr_of_hyp id$ >>
	274
	275	let mlexpr_of_debug = function
	276	\| Tacexpr.Off -> <:expr< Tacexpr.Off >>
	277	\| Tacexpr.Debug -> <:expr< Tacexpr.Debug >>
	278	\| Tacexpr.Info -> <:expr< Tacexpr.Info >>
274	279
275	280	let rec mlexpr_of_atomic_tactic = function
276	281	(* Basic tactics *)

398	403	\| Tacexpr.TacTransitivity c -> <:expr< Tacexpr.TacTransitivity $mlexpr_of_option mlexpr_of_constr c$ >>
399	404
400	405	(* Automation tactics *)
401		\| Tacexpr.TacAuto (n,lems,l) ->
	406	\| Tacexpr.TacAuto (debug,n,lems,l) ->
	407	let d = mlexpr_of_debug debug in
402	408	let n = mlexpr_of_option (mlexpr_of_or_var mlexpr_of_int) n in
403	409	let lems = mlexpr_of_list mlexpr_of_constr lems in
404	410	let l = mlexpr_of_option (mlexpr_of_list mlexpr_of_string) l in
405		<:expr< Tacexpr.TacAuto $n$ $lems$ $l$ >>
406		\| Tacexpr.TacTrivial (lems,l) ->
	411	<:expr< Tacexpr.TacAuto $d$ $n$ $lems$ $l$ >>
	412	\| Tacexpr.TacTrivial (debug,lems,l) ->
	413	let d = mlexpr_of_debug debug in
407	414	let l = mlexpr_of_option (mlexpr_of_list mlexpr_of_string) l in
408	415	let lems = mlexpr_of_list mlexpr_of_constr lems in
409		<:expr< Tacexpr.TacTrivial $lems$ $l$ >>
	416	<:expr< Tacexpr.TacTrivial $d$ $lems$ $l$ >>
410	417
411	418	\| _ -> failwith "Quotation of atomic tactic expressions: TODO"
412	419

+43

-18

parsing/tacextend.ml4 less more

118	118
119	119	let make_printing_rule se = mlexpr_of_list (make_one_printing_rule se)
120	120
121		let rec contains_epsilon = function
122		\| List0ArgType _ -> true
123		\| List1ArgType t -> contains_epsilon t
124		\| OptArgType _ -> true
125		\| PairArgType(t1,t2) -> contains_epsilon t1 && contains_epsilon t2
126		\| ExtraArgType("hintbases") -> true
127		\| _ -> false
128		let is_atomic = function
129		\| GramTerminal s :: l when
130		List.for_all (function
131		GramTerminal _ -> false
132		\| GramNonTerminal(_,t,_,_) -> contains_epsilon t) l
133		-> [s]
134		\| _ -> []
	121	let rec possibly_empty_subentries loc = function
	122	\| [] -> []
	123	\| (s,prodsl) :: l ->
	124	let rec aux = function
	125	\| [] -> (false,<:expr< None >>)
	126	\| prods :: rest ->
	127	try
	128	let l = List.map (function
	129	\| GramNonTerminal(_,(List0ArgType _\|
	130	OptArgType _\|
	131	ExtraArgType _ as t),_,_)->
	132	(* This possibly parses epsilon *)
	133	let rawwit = make_rawwit loc t in
	134	<:expr< match Genarg.default_empty_value $rawwit$ with
	135	[ None -> failwith ""
	136	\| Some v ->
	137	Tacinterp.intern_genarg Tacinterp.fully_empty_glob_sign
	138	(Genarg.in_gen $rawwit$ v) ] >>
	139	\| GramTerminal _ \| GramNonTerminal(_,_,_,_) ->
	140	(* This does not parse epsilon (this Exit is static time) *)
	141	raise Exit) prods in
	142	if has_extraarg prods then
	143	(true,<:expr< try Some $mlexpr_of_list (fun x -> x) l$
	144	with [ Failure "" -> $snd (aux rest)$ ] >>)
	145	else
	146	(true, <:expr< Some $mlexpr_of_list (fun x -> x) l$ >>)
	147	with Exit -> aux rest in
	148	let (nonempty,v) = aux prodsl in
	149	if nonempty then (s,v) :: possibly_empty_subentries loc l
	150	else possibly_empty_subentries loc l
	151
	152	let possibly_atomic loc prods =
	153	let l = list_map_filter (function
	154	\| GramTerminal s :: l, _ -> Some (s,l)
	155	\| _ -> None) prods in
	156	possibly_empty_subentries loc (list_factorize_left l)
135	157
136	158	let declare_tactic loc s cl =
137	159	let se = mlexpr_of_string s in

150	172	in
151	173	let hidden = if List.length cl = 1 then List.map hide_tac cl else [] in
152	174	let atomic_tactics =
153		mlexpr_of_list mlexpr_of_string
154		(List.flatten (List.map (fun (al,_) -> is_atomic al) cl)) in
	175	mlexpr_of_list (mlexpr_of_pair mlexpr_of_string (fun x -> x))
	176	(possibly_atomic loc cl) in
155	177	declare_str_items loc
156	178	(hidden @
157	179	[ <:str_item< do {
158	180	try
159	181	let _=Tacinterp.add_tactic $se$ $make_fun_clauses loc s cl$ in
160	182	List.iter
161		(fun s -> Tacinterp.add_primitive_tactic s
	183	(fun (s,l) -> match l with
	184	[ Some l ->
	185	Tacinterp.add_primitive_tactic s
162	186	(Tacexpr.TacAtom($default_loc$,
163		Tacexpr.TacExtend($default_loc$,s,[]))))
	187	Tacexpr.TacExtend($default_loc$,$se$,l)))
	188	\| None -> () ])
164	189	$atomic_tactics$
165	190	with e -> Pp.pp (Errors.print e);
166	191	Egrammar.extend_tactic_grammar $se$ $gl$;

+3

-2

plugins/decl_mode/g_decl_mode.ml4 less more

28	28	(str " * Declarative Mode *" ++ fnl ()++fnl ()),
29	29	(str "thesis := " ++ fnl ()),
30	30	Printer.pr_context_of env,
31		Printer.pr_ltype_env_at_top env (Goal.V82.concl sigma g)
	31	Printer.pr_goal_concl_style_env env (Goal.V82.concl sigma g)
32	32	in
33	33	preamb ++
34	34	str" " ++ hv 0 (penv ++ fnl () ++

102	102
103	103	(* [Genarg.create_arg] creates a new embedding into Genarg. *)
104	104	let (wit_proof_instr,globwit_proof_instr,rawwit_proof_instr) =
105		Genarg.create_arg "proof_instr"
	105	Genarg.create_arg None "proof_instr"
106	106	let _ = Tacinterp.add_interp_genarg "proof_instr"
107	107	begin
108	108	begin fun e x -> (* declares the globalisation function *)

110	110	(Decl_interp.intern_proof_instr e (Genarg.out_gen rawwit_proof_instr x))
111	111	end,
112	112	begin fun ist gl x -> (* declares the interpretation function *)
	113	Tacmach.project gl ,
113	114	Genarg.in_gen wit_proof_instr
114	115	(interp_proof_instr ist gl (Genarg.out_gen globwit_proof_instr x))
115	116	end,

+0

-118

~~plugins/dp/Dp.v~~ less more

0		(* Calls to external decision procedures *)
1
2		Require Export ZArith.
3		Require Export Classical.
4
5		(* Zenon *)
6
7		(* Copyright 2004 INRIA *)
8		Lemma zenon_nottrue :
9		(~True -> False).
10		Proof. tauto. Qed.
11
12		Lemma zenon_noteq : forall (T : Type) (t : T),
13		((t <> t) -> False).
14		Proof. tauto. Qed.
15
16		Lemma zenon_and : forall P Q : Prop,
17		(P -> Q -> False) -> (P /\ Q -> False).
18		Proof. tauto. Qed.
19
20		Lemma zenon_or : forall P Q : Prop,
21		(P -> False) -> (Q -> False) -> (P \/ Q -> False).
22		Proof. tauto. Qed.
23
24		Lemma zenon_imply : forall P Q : Prop,
25		(~P -> False) -> (Q -> False) -> ((P -> Q) -> False).
26		Proof. tauto. Qed.
27
28		Lemma zenon_equiv : forall P Q : Prop,
29		(~P -> ~Q -> False) -> (P -> Q -> False) -> ((P <-> Q) -> False).
30		Proof. tauto. Qed.
31
32		Lemma zenon_notand : forall P Q : Prop,
33		(~P -> False) -> (~Q -> False) -> (~(P /\ Q) -> False).
34		Proof. tauto. Qed.
35
36		Lemma zenon_notor : forall P Q : Prop,
37		(~P -> ~Q -> False) -> (~(P \/ Q) -> False).
38		Proof. tauto. Qed.
39
40		Lemma zenon_notimply : forall P Q : Prop,
41		(P -> ~Q -> False) -> (~(P -> Q) -> False).
42		Proof. tauto. Qed.
43
44		Lemma zenon_notequiv : forall P Q : Prop,
45		(~P -> Q -> False) -> (P -> ~Q -> False) -> (~(P <-> Q) -> False).
46		Proof. tauto. Qed.
47
48		Lemma zenon_ex : forall (T : Type) (P : T -> Prop),
49		(forall z : T, ((P z) -> False)) -> ((exists x : T, (P x)) -> False).
50		Proof. firstorder. Qed.
51
52		Lemma zenon_all : forall (T : Type) (P : T -> Prop) (t : T),
53		((P t) -> False) -> ((forall x : T, (P x)) -> False).
54		Proof. firstorder. Qed.
55
56		Lemma zenon_notex : forall (T : Type) (P : T -> Prop) (t : T),
57		(~(P t) -> False) -> (~(exists x : T, (P x)) -> False).
58		Proof. firstorder. Qed.
59
60		Lemma zenon_notall : forall (T : Type) (P : T -> Prop),
61		(forall z : T, (~(P z) -> False)) -> (~(forall x : T, (P x)) -> False).
62		Proof. intros T P Ha Hb. apply Hb. intro. apply NNPP. exact (Ha x). Qed.
63
64		Lemma zenon_equal_base : forall (T : Type) (f : T), f = f.
65		Proof. auto. Qed.
66
67		Lemma zenon_equal_step :
68		forall (S T : Type) (fa fb : S -> T) (a b : S),
69		(fa = fb) -> (a <> b -> False) -> ((fa a) = (fb b)).
70		Proof. intros. rewrite (NNPP (a = b)). congruence. auto. Qed.
71
72		Lemma zenon_pnotp : forall P Q : Prop,
73		(P = Q) -> (P -> ~Q -> False).
74		Proof. intros P Q Ha. rewrite Ha. auto. Qed.
75
76		Lemma zenon_notequal : forall (T : Type) (a b : T),
77		(a = b) -> (a <> b -> False).
78		Proof. auto. Qed.
79
80		Ltac zenon_intro id :=
81		intro id \|\| let nid := fresh in (intro nid; clear nid)
82		.
83
84		Definition zenon_and_s := fun P Q a b => zenon_and P Q b a.
85		Definition zenon_or_s := fun P Q a b c => zenon_or P Q b c a.
86		Definition zenon_imply_s := fun P Q a b c => zenon_imply P Q b c a.
87		Definition zenon_equiv_s := fun P Q a b c => zenon_equiv P Q b c a.
88		Definition zenon_notand_s := fun P Q a b c => zenon_notand P Q b c a.
89		Definition zenon_notor_s := fun P Q a b => zenon_notor P Q b a.
90		Definition zenon_notimply_s := fun P Q a b => zenon_notimply P Q b a.
91		Definition zenon_notequiv_s := fun P Q a b c => zenon_notequiv P Q b c a.
92		Definition zenon_ex_s := fun T P a b => zenon_ex T P b a.
93		Definition zenon_notall_s := fun T P a b => zenon_notall T P b a.
94
95		Definition zenon_pnotp_s := fun P Q a b c => zenon_pnotp P Q c a b.
96		Definition zenon_notequal_s := fun T a b x y => zenon_notequal T a b y x.
97
98		(* Ergo *)
99
100		Set Implicit Arguments.
101		Section congr.
102		Variable t:Type.
103		Lemma ergo_eq_concat_1 :
104		forall (P:t -> Prop) (x y:t),
105		P x -> x = y -> P y.
106		Proof.
107		intros; subst; auto.
108		Qed.
109
110		Lemma ergo_eq_concat_2 :
111		forall (P:t -> t -> Prop) (x1 x2 y1 y2:t),
112		P x1 x2 -> x1 = y1 -> x2 = y2 -> P y1 y2.
113		Proof.
114		intros; subst; auto.
115		Qed.
116
117		End congr.

+0

-24

~~plugins/dp/TODO~~ less more

0
1		TODO
2		----
3
4		- axiomes pour les prédicats récursifs comme
5
6		Fixpoint even (n:nat) : Prop :=
7		match n with
8		O => True
9		\| S O => False
10		\| S (S p) => even p
11		end.
12
13		ou encore In sur les listes du module Coq List.
14
15		- discriminate
16
17		- inversion (Set et Prop)
18
19
20		BUGS
21		----
22
23

+0

-1133

~~plugins/dp/dp.ml~~ less more

0		(* Authors: Nicolas Ayache and Jean-Christophe Filliâtre *)
1		(* Tactics to call decision procedures *)
2
3		(* Works in two steps:
4
5		- first the Coq context and the current goal are translated in
6		Polymorphic First-Order Logic (see fol.mli in this directory)
7
8		- then the resulting query is passed to the Why tool that translates
9		it to the syntax of the selected prover (Simplify, CVC Lite, haRVey,
10		Zenon)
11		*)
12
13		open Util
14		open Pp
15		open Libobject
16		open Summary
17		open Term
18		open Tacmach
19		open Tactics
20		open Tacticals
21		open Fol
22		open Names
23		open Nameops
24		open Namegen
25		open Coqlib
26		open Hipattern
27		open Libnames
28		open Declarations
29		open Dp_why
30
31		let debug = ref false
32		let set_debug b = debug := b
33		let trace = ref false
34		let set_trace b = trace := b
35		let timeout = ref 10
36		let set_timeout n = timeout := n
37
38		let dp_timeout_obj : int -> obj =
39		declare_object
40		{(default_object "Dp_timeout") with
41		cache_function = (fun (_,x) -> set_timeout x);
42		load_function = (fun _ (_,x) -> set_timeout x)}
43
44		let dp_timeout x = Lib.add_anonymous_leaf (dp_timeout_obj x)
45
46		let dp_debug_obj : bool -> obj =
47		declare_object
48		{(default_object "Dp_debug") with
49		cache_function = (fun (_,x) -> set_debug x);
50		load_function = (fun _ (_,x) -> set_debug x)}
51
52		let dp_debug x = Lib.add_anonymous_leaf (dp_debug_obj x)
53
54		let dp_trace_obj : bool -> obj =
55		declare_object
56		{(default_object "Dp_trace") with
57		cache_function = (fun (_,x) -> set_trace x);
58		load_function = (fun _ (_,x) -> set_trace x)}
59
60		let dp_trace x = Lib.add_anonymous_leaf (dp_trace_obj x)
61
62		let logic_dir = ["Coq";"Logic";"Decidable"]
63		let coq_modules =
64		init_modules @ [logic_dir] @ arith_modules @ zarith_base_modules
65		@ [["Coq"; "ZArith"; "BinInt"];
66		["Coq"; "Reals"; "Rdefinitions"];
67		["Coq"; "Reals"; "Raxioms";];
68		["Coq"; "Reals"; "Rbasic_fun";];
69		["Coq"; "Reals"; "R_sqrt";];
70		["Coq"; "Reals"; "Rfunctions";]]
71		@ [["Coq"; "omega"; "OmegaLemmas"]]
72
73		let constant = gen_constant_in_modules "dp" coq_modules
74
75		(* integers constants and operations *)
76		let coq_Z = lazy (constant "Z")
77		let coq_Zplus = lazy (constant "Zplus")
78		let coq_Zmult = lazy (constant "Zmult")
79		let coq_Zopp = lazy (constant "Zopp")
80		let coq_Zminus = lazy (constant "Zminus")
81		let coq_Zdiv = lazy (constant "Zdiv")
82		let coq_Zs = lazy (constant "Zs")
83		let coq_Zgt = lazy (constant "Zgt")
84		let coq_Zle = lazy (constant "Zle")
85		let coq_Zge = lazy (constant "Zge")
86		let coq_Zlt = lazy (constant "Zlt")
87		let coq_Z0 = lazy (constant "Z0")
88		let coq_Zpos = lazy (constant "Zpos")
89		let coq_Zneg = lazy (constant "Zneg")
90		let coq_xH = lazy (constant "xH")
91		let coq_xI = lazy (constant "xI")
92		let coq_xO = lazy (constant "xO")
93		let coq_iff = lazy (constant "iff")
94
95		(* real constants and operations *)
96		let coq_R = lazy (constant "R")
97		let coq_R0 = lazy (constant "R0")
98		let coq_R1 = lazy (constant "R1")
99		let coq_Rgt = lazy (constant "Rgt")
100		let coq_Rle = lazy (constant "Rle")
101		let coq_Rge = lazy (constant "Rge")
102		let coq_Rlt = lazy (constant "Rlt")
103		let coq_Rplus = lazy (constant "Rplus")
104		let coq_Rmult = lazy (constant "Rmult")
105		let coq_Ropp = lazy (constant "Ropp")
106		let coq_Rminus = lazy (constant "Rminus")
107		let coq_Rdiv = lazy (constant "Rdiv")
108		let coq_powerRZ = lazy (constant "powerRZ")
109
110		(* not Prop typed expressions *)
111		exception NotProp
112
113		(* not first-order expressions *)
114		exception NotFO
115
116		(* Renaming of Coq globals *)
117
118		let global_names = Hashtbl.create 97
119		let used_names = Hashtbl.create 97
120
121		let rename_global r =
122		try
123		Hashtbl.find global_names r
124		with Not_found ->
125		let rec loop id =
126		if Hashtbl.mem used_names id then
127		loop (lift_subscript id)
128		else begin
129		Hashtbl.add used_names id ();
130		let s = string_of_id id in
131		Hashtbl.add global_names r s;
132		s
133		end
134		in
135		loop (Nametab.basename_of_global r)
136
137		let foralls =
138		List.fold_right
139		(fun (x,t) p -> Forall (x, t, p))
140
141		let fresh_var = function
142		\| Anonymous -> rename_global (VarRef (id_of_string "x"))
143		\| Name x -> rename_global (VarRef x)
144
145		(* coq_rename_vars env [(x1,t1);...;(xn,tn)] renames the xi outside of
146		env names, and returns the new variables together with the new
147		environment *)
148		let coq_rename_vars env vars =
149		let avoid = ref (Termops.ids_of_named_context (Environ.named_context env)) in
150		List.fold_right
151		(fun (na,t) (newvars, newenv) ->
152		let id = next_name_away na !avoid in
153		avoid := id :: !avoid;
154		id :: newvars, Environ.push_named (id, None, t) newenv)
155		vars ([],env)
156
157		(* extract the prenex type quantifications i.e.
158		type_quantifiers env (A1:Set)...(Ak:Set)t = A1...An, (env+Ai), t *)
159		let decomp_type_quantifiers env t =
160		let rec loop vars t = match kind_of_term t with
161		\| Prod (n, a, t) when is_Set a \|\| is_Type a ->
162		loop ((n,a) :: vars) t
163		\| _ ->
164		let vars, env = coq_rename_vars env vars in
165		let t = substl (List.map mkVar vars) t in
166		List.rev vars, env, t
167		in
168		loop [] t
169
170		(* same thing with lambda binders (for axiomatize body) *)
171		let decomp_type_lambdas env t =
172		let rec loop vars t = match kind_of_term t with
173		\| Lambda (n, a, t) when is_Set a \|\| is_Type a ->
174		loop ((n,a) :: vars) t
175		\| _ ->
176		let vars, env = coq_rename_vars env vars in
177		let t = substl (List.map mkVar vars) t in
178		List.rev vars, env, t
179		in
180		loop [] t
181
182		let decompose_arrows =
183		let rec arrows_rec l c = match kind_of_term c with
184		\| Prod (_,t,c) when not (Termops.dependent (mkRel 1) c) -> arrows_rec (t :: l) c
185		\| Cast (c,_,_) -> arrows_rec l c
186		\| _ -> List.rev l, c
187		in
188		arrows_rec []
189
190		let rec eta_expanse t vars env i =
191		assert (i >= 0);
192		if i = 0 then
193		t, vars, env
194		else
195		match kind_of_term (Typing.type_of env Evd.empty t) with
196		\| Prod (n, a, b) when not (Termops.dependent (mkRel 1) b) ->
197		let avoid = Termops.ids_of_named_context (Environ.named_context env) in
198		let id = next_name_away n avoid in
199		let env' = Environ.push_named (id, None, a) env in
200		let t' = mkApp (t, [\| mkVar id \|]) in
201		eta_expanse t' (id :: vars) env' (pred i)
202		\| _ ->
203		assert false
204
205		let rec skip_k_args k cl = match k, cl with
206		\| 0, _ -> cl
207		\| _, _ :: cl -> skip_k_args (k-1) cl
208		\| _, [] -> raise NotFO
209
210		(* Coq global references *)
211
212		type global = Gnot_fo \| Gfo of Fol.decl
213
214		let globals = ref Refmap.empty
215		let globals_stack = ref []
216
217		(* synchronization *)
218		let () =
219		Summary.declare_summary "Dp globals"
220		{ Summary.freeze_function = (fun () -> !globals, !globals_stack);
221		Summary.unfreeze_function =
222		(fun (g,s) -> globals := g; globals_stack := s);
223		Summary.init_function = (fun () -> ()) }
224
225		let add_global r d = globals := Refmap.add r d !globals
226		let mem_global r = Refmap.mem r !globals
227		let lookup_global r = match Refmap.find r !globals with
228		\| Gnot_fo -> raise NotFO
229		\| Gfo d -> d
230
231		let locals = Hashtbl.create 97
232
233		let lookup_local r = match Hashtbl.find locals r with
234		\| Gnot_fo -> raise NotFO
235		\| Gfo d -> d
236
237		let iter_all_constructors i f =
238		let _, oib = Global.lookup_inductive i in
239		Array.iteri
240		(fun j tj -> f j (mkConstruct (i, j+1)))
241		oib.mind_nf_lc
242
243
244		(* injection c [t1,...,tn] adds the injection axiom
245		forall x1:t1,...,xn:tn,y1:t1,...,yn:tn.
246		c(x1,...,xn)=c(y1,...,yn) -> x1=y1 /\ ... /\ xn=yn *)
247
248		let injection c l =
249		let i = ref 0 in
250		let var s = incr i; id_of_string (s ^ string_of_int !i) in
251		let xl = List.map (fun t -> rename_global (VarRef (var "x")), t) l in
252		i := 0;
253		let yl = List.map (fun t -> rename_global (VarRef (var "y")), t) l in
254		let f =
255		List.fold_right2
256		(fun (x,_) (y,_) p -> And (Fatom (Eq (App (x,[]),App (y,[]))), p))
257		xl yl True
258		in
259		let vars = List.map (fun (x,_) -> App(x,[])) in
260		let f = Imp (Fatom (Eq (App (c, vars xl), App (c, vars yl))), f) in
261		let foralls = List.fold_right (fun (x,t) p -> Forall (x, t, p)) in
262		let f = foralls xl (foralls yl f) in
263		let ax = Axiom ("injection_" ^ c, f) in
264		globals_stack := ax :: !globals_stack
265
266		(* rec_names_for c [\|n1;...;nk\|] builds the list of constant names for
267		identifiers n1...nk with the same path as c, if they exist; otherwise
268		raises Not_found *)
269		let rec_names_for c =
270		let mp,dp,_ = Names.repr_con c in
271		array_map_to_list
272		(function
273		\| Name id ->
274		let c' = Names.make_con mp dp (label_of_id id) in
275		ignore (Global.lookup_constant c');
276		msgnl (Printer.pr_constr (mkConst c'));
277		c'
278		\| Anonymous ->
279		raise Not_found)
280
281		(* abstraction tables *)
282
283		let term_abstractions = Hashtbl.create 97
284
285		let new_abstraction =
286		let r = ref 0 in fun () -> incr r; "abstraction_" ^ string_of_int !r
287
288		(* Arithmetic constants *)
289
290		exception NotArithConstant
291
292		(* translates a closed Coq term p:positive into a FOL term of type int *)
293
294		let big_two = Big_int.succ_big_int Big_int.unit_big_int
295
296		let rec tr_positive p = match kind_of_term p with
297		\| Term.Construct _ when p = Lazy.force coq_xH ->
298		Big_int.unit_big_int
299		\| Term.App (f, [\|a\|]) when f = Lazy.force coq_xI ->
300		(*
301		Plus (Mult (Cst 2, tr_positive a), Cst 1)
302		*)
303		Big_int.succ_big_int (Big_int.mult_big_int big_two (tr_positive a))
304		\| Term.App (f, [\|a\|]) when f = Lazy.force coq_xO ->
305		(*
306		Mult (Cst 2, tr_positive a)
307		*)
308		Big_int.mult_big_int big_two (tr_positive a)
309		\| Term.Cast (p, _, _) ->
310		tr_positive p
311		\| _ ->
312		raise NotArithConstant
313
314		(* translates a closed Coq term t:Z or R into a FOL term of type int or real *)
315		let rec tr_arith_constant t = match kind_of_term t with
316		\| Term.Construct _ when t = Lazy.force coq_Z0 ->
317		Cst Big_int.zero_big_int
318		\| Term.App (f, [\|a\|]) when f = Lazy.force coq_Zpos ->
319		Cst (tr_positive a)
320		\| Term.App (f, [\|a\|]) when f = Lazy.force coq_Zneg ->
321		Cst (Big_int.minus_big_int (tr_positive a))
322		\| Term.Const _ when t = Lazy.force coq_R0 ->
323		RCst Big_int.zero_big_int
324		\| Term.Const _ when t = Lazy.force coq_R1 ->
325		RCst Big_int.unit_big_int
326		\| Term.App (f, [\|a;b\|]) when f = Lazy.force coq_Rplus ->
327		let ta = tr_arith_constant a in
328		let tb = tr_arith_constant b in
329		begin match ta,tb with
330		\| RCst na, RCst nb -> RCst (Big_int.add_big_int na nb)
331		\| _ -> raise NotArithConstant
332		end
333		\| Term.App (f, [\|a;b\|]) when f = Lazy.force coq_Rmult ->
334		let ta = tr_arith_constant a in
335		let tb = tr_arith_constant b in
336		begin match ta,tb with
337		\| RCst na, RCst nb -> RCst (Big_int.mult_big_int na nb)
338		\| _ -> raise NotArithConstant
339		end
340		\| Term.App (f, [\|a;b\|]) when f = Lazy.force coq_powerRZ ->
341		tr_powerRZ a b
342		\| Term.Cast (t, _, _) ->
343		tr_arith_constant t
344		\| _ ->
345		raise NotArithConstant
346
347		(* translates a constant of the form (powerRZ 2 int_constant) *)
348		and tr_powerRZ a b =
349		(* checking first that a is (R1 + R1) *)
350		match kind_of_term a with
351		\| Term.App (f, [\|c;d\|]) when f = Lazy.force coq_Rplus ->
352		begin
353		match kind_of_term c,kind_of_term d with
354		\| Term.Const _, Term.Const _
355		when c = Lazy.force coq_R1 && d = Lazy.force coq_R1 ->
356		begin
357		match tr_arith_constant b with
358		\| Cst n -> Power2 n
359		\| _ -> raise NotArithConstant
360		end
361		\| _ -> raise NotArithConstant
362		end
363		\| _ -> raise NotArithConstant
364
365
366		(* translate a Coq term t:Set into a FOL type expression;
367		tv = list of type variables *)
368		and tr_type tv env t =
369		let t = Reductionops.nf_betadeltaiota env Evd.empty t in
370		if t = Lazy.force coq_Z then
371		Tid ("int", [])
372		else if t = Lazy.force coq_R then
373		Tid ("real", [])
374		else match kind_of_term t with
375		\| Var x when List.mem x tv ->
376		Tvar (string_of_id x)
377		\| _ ->
378		let f, cl = decompose_app t in
379		begin try
380		let r = global_of_constr f in
381		match tr_global env r with
382		\| DeclType (id, k) ->
383		assert (k = List.length cl); (* since t:Set *)
384		Tid (id, List.map (tr_type tv env) cl)
385		\| _ ->
386		raise NotFO
387		with
388		\| Not_found ->
389		raise NotFO
390		\| NotFO ->
391		(* we need to abstract some part of (f cl) *)
392		(TODO)
393		raise NotFO
394		end
395
396		and make_term_abstraction tv env c =
397		let ty = Typing.type_of env Evd.empty c in
398		let id = new_abstraction () in
399		match tr_decl env id ty with
400		\| DeclFun (id,_,_,_) as _d ->
401		raise NotFO
402		(* [CM 07/09/2009] deactivated because it generates
403		unbound identifiers 'abstraction_<number>'
404		begin try
405		Hashtbl.find term_abstractions c
406		with Not_found ->
407		Hashtbl.add term_abstractions c id;
408		globals_stack := d :: !globals_stack;
409		id
410		end
411		*)
412		\| _ ->
413		raise NotFO
414
415		(* translate a Coq declaration id:ty in a FOL declaration, that is either
416		- a type declaration : DeclType (id, n) where n:int is the type arity
417		- a function declaration : DeclFun (id, tl, t) ; that includes constants
418		- a predicate declaration : DeclPred (id, tl)
419		- an axiom : Axiom (id, p)
420		*)
421		and tr_decl env id ty =
422		let tv, env, t = decomp_type_quantifiers env ty in
423		if is_Set t \|\| is_Type t then
424		DeclType (id, List.length tv)
425		else if is_Prop t then
426		DeclPred (id, List.length tv, [])
427		else
428		let s = Typing.type_of env Evd.empty t in
429		if is_Prop s then
430		Axiom (id, tr_formula tv [] env t)
431		else
432		let l, t = decompose_arrows t in
433		let l = List.map (tr_type tv env) l in
434		if is_Prop t then
435		DeclPred(id, List.length tv, l)
436		else
437		let s = Typing.type_of env Evd.empty t in
438		if is_Set s \|\| is_Type s then
439		DeclFun (id, List.length tv, l, tr_type tv env t)
440		else
441		raise NotFO
442
443		(* tr_global(r) = tr_decl(id(r),typeof(r)) + a cache mechanism *)
444		and tr_global env r = match r with
445		\| VarRef id ->
446		lookup_local id
447		\| r ->
448		try
449		lookup_global r
450		with Not_found ->
451		try
452		let ty = Global.type_of_global r in
453		let id = rename_global r in
454		let d = tr_decl env id ty in
455		(* r can be already declared if it is a constructor *)
456		if not (mem_global r) then begin
457		add_global r (Gfo d);
458		globals_stack := d :: !globals_stack
459		end;
460		begin try axiomatize_body env r id d with NotFO -> () end;
461		d
462		with NotFO ->
463		add_global r Gnot_fo;
464		raise NotFO
465
466		and axiomatize_body env r id d = match r with
467		\| VarRef _ ->
468		assert false
469		\| ConstRef c ->
470		begin match body_of_constant (Global.lookup_constant c) with
471		\| Some b ->
472		let b = force b in
473		let axioms =
474		(match d with
475		\| DeclPred (id, _, []) ->
476		let tv, env, b = decomp_type_lambdas env b in
477		let value = tr_formula tv [] env b in
478		[id, Iff (Fatom (Pred (id, [])), value)]
479		\| DeclFun (id, _, [], _) ->
480		let tv, env, b = decomp_type_lambdas env b in
481		let value = tr_term tv [] env b in
482		[id, Fatom (Eq (Fol.App (id, []), value))]
483		\| DeclFun (id, _, l, _) \| DeclPred (id, _, l) ->
484		(Format.eprintf "axiomatize_body %S@." id;)
485		let b = match kind_of_term b with
486		(* a single recursive function *)
487		\| Fix (_, (_,_,[\|b\|])) ->
488		subst1 (mkConst c) b
489		(* mutually recursive functions *)
490		\| Fix ((_,i), (names,_,bodies)) ->
491		(* we only deal with named functions *)
492		begin try
493		let l = rec_names_for c names in
494		substl (List.rev_map mkConst l) bodies.(i)
495		with Not_found ->
496		b
497		end
498		\| _ ->
499		b
500		in
501		let tv, env, b = decomp_type_lambdas env b in
502		let vars, t = decompose_lam b in
503		let n = List.length l in
504		let k = List.length vars in
505		assert (k <= n);
506		let vars, env = coq_rename_vars env vars in
507		let t = substl (List.map mkVar vars) t in
508		let t, vars, env = eta_expanse t vars env (n-k) in
509		let vars = List.rev vars in
510		let bv = vars in
511		let vars = List.map (fun x -> string_of_id x) vars in
512		let fol_var x = Fol.App (x, []) in
513		let fol_vars = List.map fol_var vars in
514		let vars = List.combine vars l in
515		begin match d with
516		\| DeclFun (_, _, _, ty) ->
517		begin match kind_of_term t with
518		\| Case (ci, _, e, br) ->
519		equations_for_case env id vars tv bv ci e br
520		\| _ ->
521		let t = tr_term tv bv env t in
522		let ax =
523		add_proof (Fun_def (id, vars, ty, t))
524		in
525		let p = Fatom (Eq (App (id, fol_vars), t)) in
526		[ax, foralls vars p]
527		end
528		\| DeclPred _ ->
529		let value = tr_formula tv bv env t in
530		let p = Iff (Fatom (Pred (id, fol_vars)), value) in
531		[id, foralls vars p]
532		\| _ ->
533		assert false
534		end
535		\| DeclType _ ->
536		raise NotFO
537		\| Axiom _ -> assert false)
538		in
539		let axioms = List.map (fun (id,ax) -> Axiom (id, ax)) axioms in
540		globals_stack := axioms @ !globals_stack
541		\| None ->
542		() (* Coq axiom *)
543		end
544		\| IndRef i ->
545		iter_all_constructors i
546		(fun _ c ->
547		let rc = global_of_constr c in
548		try
549		begin match tr_global env rc with
550		\| DeclFun (_, _, [], _) -> ()
551		\| DeclFun (idc, _, al, _) -> injection idc al
552		\| _ -> ()
553		end
554		with NotFO ->
555		())
556		\| _ -> ()
557
558		and equations_for_case env id vars tv bv ci e br = match kind_of_term e with
559		\| Var x when List.exists (fun (y, _) -> string_of_id x = y) vars ->
560		let eqs = ref [] in
561		iter_all_constructors ci.ci_ind
562		(fun j cj ->
563		try
564		let cjr = global_of_constr cj in
565		begin match tr_global env cjr with
566		\| DeclFun (idc, _, l, _) ->
567		let b = br.(j) in
568		let rec_vars, b = decompose_lam b in
569		let rec_vars, env = coq_rename_vars env rec_vars in
570		let coq_rec_vars = List.map mkVar rec_vars in
571		let b = substl coq_rec_vars b in
572		let rec_vars = List.rev rec_vars in
573		let coq_rec_term = applist (cj, List.rev coq_rec_vars) in
574		let b = replace_vars [x, coq_rec_term] b in
575		let bv = bv @ rec_vars in
576		let rec_vars = List.map string_of_id rec_vars in
577		let fol_var x = Fol.App (x, []) in
578		let fol_rec_vars = List.map fol_var rec_vars in
579		let fol_rec_term = App (idc, fol_rec_vars) in
580		let rec_vars = List.combine rec_vars l in
581		let fol_vars = List.map fst vars in
582		let fol_vars = List.map fol_var fol_vars in
583		let fol_vars = List.map (fun y -> match y with
584		\| App (id, _) ->
585		if id = string_of_id x
586		then fol_rec_term
587		else y
588		\| _ -> y)
589		fol_vars in
590		let vars = vars @ rec_vars in
591		let rec remove l e = match l with
592		\| [] -> []
593		\| (y, t)::l' -> if y = string_of_id e then l'
594		else (y, t)::(remove l' e) in
595		let vars = remove vars x in
596		let p =
597		Fatom (Eq (App (id, fol_vars),
598		tr_term tv bv env b))
599		in
600		eqs := (id ^ "_" ^ idc, foralls vars p) :: !eqs
601		\| _ ->
602		assert false end
603		with NotFO ->
604		());
605		!eqs
606		\| _ ->
607		raise NotFO
608
609		(* assumption: t:T:Set *)
610		and tr_term tv bv env t =
611		try
612		tr_arith_constant t
613		with NotArithConstant ->
614		match kind_of_term t with
615		(* binary operations on integers *)
616		\| Term.App (f, [\|a;b\|]) when f = Lazy.force coq_Zplus ->
617		Plus (tr_term tv bv env a, tr_term tv bv env b)
618		\| Term.App (f, [\|a;b\|]) when f = Lazy.force coq_Zminus ->
619		Moins (tr_term tv bv env a, tr_term tv bv env b)
620		\| Term.App (f, [\|a;b\|]) when f = Lazy.force coq_Zmult ->
621		Mult (tr_term tv bv env a, tr_term tv bv env b)
622		\| Term.App (f, [\|a;b\|]) when f = Lazy.force coq_Zdiv ->
623		Div (tr_term tv bv env a, tr_term tv bv env b)
624		\| Term.App (f, [\|a\|]) when f = Lazy.force coq_Zopp ->
625		Opp (tr_term tv bv env a)
626		(* binary operations on reals *)
627		\| Term.App (f, [\|a;b\|]) when f = Lazy.force coq_Rplus ->
628		Plus (tr_term tv bv env a, tr_term tv bv env b)
629		\| Term.App (f, [\|a;b\|]) when f = Lazy.force coq_Rminus ->
630		Moins (tr_term tv bv env a, tr_term tv bv env b)
631		\| Term.App (f, [\|a;b\|]) when f = Lazy.force coq_Rmult ->
632		Mult (tr_term tv bv env a, tr_term tv bv env b)
633		\| Term.App (f, [\|a;b\|]) when f = Lazy.force coq_Rdiv ->
634		Div (tr_term tv bv env a, tr_term tv bv env b)
635		\| Term.Var id when List.mem id bv ->
636		App (string_of_id id, [])
637		\| _ ->
638		let f, cl = decompose_app t in
639		begin try
640		let r = global_of_constr f in
641		match tr_global env r with
642		\| DeclFun (s, k, _, _) ->
643		let cl = skip_k_args k cl in
644		Fol.App (s, List.map (tr_term tv bv env) cl)
645		\| _ ->
646		raise NotFO
647		with
648		\| Not_found ->
649		raise NotFO
650		\| NotFO -> (* we need to abstract some part of (f cl) *)
651		let rec abstract app = function
652		\| [] ->
653		Fol.App (make_term_abstraction tv env app, [])
654		\| x :: l as args ->
655		begin try
656		let s = make_term_abstraction tv env app in
657		Fol.App (s, List.map (tr_term tv bv env) args)
658		with NotFO ->
659		abstract (applist (app, [x])) l
660		end
661		in
662		let app,l = match cl with
663		\| x :: l -> applist (f, [x]), l \| [] -> raise NotFO
664		in
665		abstract app l
666		end
667
668		and quantifiers n a b tv bv env =
669		let vars, env = coq_rename_vars env [n,a] in
670		let id = match vars with [x] -> x \| _ -> assert false in
671		let b = subst1 (mkVar id) b in
672		let t = tr_type tv env a in
673		let bv = id :: bv in
674		id, t, bv, env, b
675
676		(* assumption: f is of type Prop *)
677		and tr_formula tv bv env f =
678		let c, args = decompose_app f in
679		match kind_of_term c, args with
680		\| Var id, [] ->
681		Fatom (Pred (rename_global (VarRef id), []))
682		\| _, [t;a;b] when c = build_coq_eq () ->
683		let ty = Typing.type_of env Evd.empty t in
684		if is_Set ty \|\| is_Type ty then
685		let _ = tr_type tv env t in
686		Fatom (Eq (tr_term tv bv env a, tr_term tv bv env b))
687		else
688		raise NotFO
689		(* comparisons on integers *)
690		\| _, [a;b] when c = Lazy.force coq_Zle ->
691		Fatom (Le (tr_term tv bv env a, tr_term tv bv env b))
692		\| _, [a;b] when c = Lazy.force coq_Zlt ->
693		Fatom (Lt (tr_term tv bv env a, tr_term tv bv env b))
694		\| _, [a;b] when c = Lazy.force coq_Zge ->
695		Fatom (Ge (tr_term tv bv env a, tr_term tv bv env b))
696		\| _, [a;b] when c = Lazy.force coq_Zgt ->
697		Fatom (Gt (tr_term tv bv env a, tr_term tv bv env b))
698		(* comparisons on reals *)
699		\| _, [a;b] when c = Lazy.force coq_Rle ->
700		Fatom (Le (tr_term tv bv env a, tr_term tv bv env b))
701		\| _, [a;b] when c = Lazy.force coq_Rlt ->
702		Fatom (Lt (tr_term tv bv env a, tr_term tv bv env b))
703		\| _, [a;b] when c = Lazy.force coq_Rge ->
704		Fatom (Ge (tr_term tv bv env a, tr_term tv bv env b))
705		\| _, [a;b] when c = Lazy.force coq_Rgt ->
706		Fatom (Gt (tr_term tv bv env a, tr_term tv bv env b))
707		\| _, [] when c = build_coq_False () ->
708		False
709		\| _, [] when c = build_coq_True () ->
710		True
711		\| _, [a] when c = build_coq_not () ->
712		Not (tr_formula tv bv env a)
713		\| _, [a;b] when c = build_coq_and () ->
714		And (tr_formula tv bv env a, tr_formula tv bv env b)
715		\| _, [a;b] when c = build_coq_or () ->
716		Or (tr_formula tv bv env a, tr_formula tv bv env b)
717		\| _, [a;b] when c = Lazy.force coq_iff ->
718		Iff (tr_formula tv bv env a, tr_formula tv bv env b)
719		\| Prod (n, a, b), _ ->
720		if is_Prop (Typing.type_of env Evd.empty a) then
721		Imp (tr_formula tv bv env a, tr_formula tv bv env b)
722		else
723		let id, t, bv, env, b = quantifiers n a b tv bv env in
724		Forall (string_of_id id, t, tr_formula tv bv env b)
725		\| _, [_; a] when c = build_coq_ex () ->
726		begin match kind_of_term a with
727		\| Lambda(n, a, b) ->
728		let id, t, bv, env, b = quantifiers n a b tv bv env in
729		Exists (string_of_id id, t, tr_formula tv bv env b)
730		\| _ ->
731		(* unusual case of the shape (ex p) *)
732		raise NotFO (* TODO: we could eta-expanse *)
733		end
734		\| _ ->
735		begin try
736		let r = global_of_constr c in
737		match tr_global env r with
738		\| DeclPred (s, k, _) ->
739		let args = skip_k_args k args in
740		Fatom (Pred (s, List.map (tr_term tv bv env) args))
741		\| _ ->
742		raise NotFO
743		with Not_found ->
744		raise NotFO
745		end
746
747
748		let tr_goal gl =
749		Hashtbl.clear locals;
750		let tr_one_hyp (id, ty) =
751		try
752		let s = rename_global (VarRef id) in
753		let d = tr_decl (pf_env gl) s ty in
754		Hashtbl.add locals id (Gfo d);
755		d
756		with NotFO ->
757		Hashtbl.add locals id Gnot_fo;
758		raise NotFO
759		in
760		let hyps =
761		List.fold_right
762		(fun h acc -> try tr_one_hyp h :: acc with NotFO -> acc)
763		(pf_hyps_types gl) []
764		in
765		let c = tr_formula [] [] (pf_env gl) (pf_concl gl) in
766		let hyps = List.rev_append !globals_stack (List.rev hyps) in
767		hyps, c
768
769
770		type prover = Simplify \| Ergo \| Yices \| CVCLite \| Harvey \| Zenon \| Gwhy \| CVC3 \| Z3
771
772		let remove_files = List.iter (fun f -> try Sys.remove f with _ -> ())
773
774		let sprintf = Format.sprintf
775
776		let file_contents f =
777		let buf = Buffer.create 1024 in
778		try
779		let c = open_in f in
780		begin try
781		while true do
782		let s = input_line c in Buffer.add_string buf s;
783		Buffer.add_char buf '\n'
784		done;
785		assert false
786		with End_of_file ->
787		close_in c;
788		Buffer.contents buf
789		end
790		with _ ->
791		sprintf "(cannot open %s)" f
792
793		let timeout_sys_command cmd =
794		if !debug then Format.eprintf "command line: %s@." cmd;
795		let out = Filename.temp_file "out" "" in
796		let cmd = sprintf "why-cpulimit %d %s > %s 2>&1" !timeout cmd out in
797		let ret = Sys.command cmd in
798		if !debug then
799		Format.eprintf "Output file %s:@.%s@." out (file_contents out);
800		ret, out
801
802		let timeout_or_failure c cmd out =
803		if c = 152 then
804		Timeout
805		else
806		Failure
807		(sprintf "command %s failed with output:\n%s " cmd (file_contents out))
808
809		let call_prover ?(opt="") file =
810		if !debug then Format.eprintf "calling prover on %s@." file;
811		let out = Filename.temp_file "out" "" in
812		let cmd =
813		sprintf "why-dp -timeout %d -batch %s > %s 2>&1" !timeout file out in
814		match Sys.command cmd with
815		0 -> Valid None
816		\| 1 -> Failure (sprintf "could not run why-dp\n%s" (file_contents out))
817		\| 2 -> Invalid
818		\| 3 -> DontKnow
819		\| 4 -> Timeout
820		\| 5 -> Failure (sprintf "prover failed:\n%s" (file_contents out))
821		\| n -> Failure (sprintf "Unknown exit status of why-dp: %d" n)
822
823		let prelude_files = ref ([] : string list)
824
825		let set_prelude l = prelude_files := l
826
827		let dp_prelude_obj : string list -> obj =
828		declare_object
829		{(default_object "Dp_prelude") with
830		cache_function = (fun (_,x) -> set_prelude x);
831		load_function = (fun _ (_,x) -> set_prelude x)}
832
833		let dp_prelude x = Lib.add_anonymous_leaf (dp_prelude_obj x)
834
835		let why_files f = String.concat " " (!prelude_files @ [f])
836
837		let call_simplify fwhy =
838		let cmd =
839		sprintf "why --simplify %s" (why_files fwhy)
840		in
841		if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed");
842		let fsx = Filename.chop_suffix fwhy ".why" ^ "_why.sx" in
843		(*
844		let cmd =
845		sprintf "why-cpulimit %d Simplify %s > out 2>&1 && grep -q -w Valid out"
846		!timeout fsx
847		in
848		let out = Sys.command cmd in
849		let r =
850		if out = 0 then Valid None else if out = 1 then Invalid else Timeout
851		in
852		*)
853		let r = call_prover fsx in
854		if not !debug then remove_files [fwhy; fsx];
855		r
856
857		let call_ergo fwhy =
858		let cmd = sprintf "why --alt-ergo %s" (why_files fwhy) in
859		if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed");
860		let fwhy = Filename.chop_suffix fwhy ".why" ^ "_why.why" in
861		(let ftrace = Filename.temp_file "ergo_trace" "" in)
862		(*NB: why-dp can't handle -cctrace
863		let cmd =
864		if !trace then
865		sprintf "alt-ergo -cctrace %s %s" ftrace fwhy
866
867		else
868		sprintf "alt-ergo %s" fwhy
869		in*)
870		let r = call_prover fwhy in
871		if not !debug then remove_files [fwhy; (out)];
872		r
873
874
875		let call_zenon fwhy =
876		let cmd =
877		sprintf "why --no-zenon-prelude --zenon %s" (why_files fwhy)
878		in
879		if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed");
880		let fznn = Filename.chop_suffix fwhy ".why" ^ "_why.znn" in
881		(* why-dp won't let us having coqterm...
882		let out = Filename.temp_file "dp_out" "" in
883		let cmd =
884		sprintf "timeout %d zenon -ocoqterm %s > %s 2>&1" !timeout fznn out
885		in
886		let c = Sys.command cmd in
887		if not !debug then remove_files [fwhy; fznn];
888		if c = 137 then
889		Timeout
890		else begin
891		if c <> 0 then anomaly ("command failed: " ^ cmd);
892		if Sys.command (sprintf "grep -q -w Error %s" out) = 0 then
893		error "Zenon failed";
894		let c = Sys.command (sprintf "grep -q PROOF-FOUND %s" out) in
895		if c = 0 then Valid (Some out) else Invalid
896		end
897		*)
898		let r = call_prover fznn in
899		if not !debug then remove_files [fwhy; fznn];
900		r
901
902		let call_smt ~smt fwhy =
903		let cmd =
904		sprintf "why -smtlib --encoding sstrat %s" (why_files fwhy)
905		in
906		if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed");
907		let fsmt = Filename.chop_suffix fwhy ".why" ^ "_why.smt" in
908		let opt = "-smt-solver " ^ smt in
909		let r = call_prover ~opt fsmt in
910		if not !debug then remove_files [fwhy; fsmt];
911		r
912
913		(*
914		let call_yices fwhy =
915		let cmd =
916		sprintf "why -smtlib --encoding sstrat %s" (why_files fwhy)
917		in
918		if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed");
919		let fsmt = Filename.chop_suffix fwhy ".why" ^ "_why.smt" in
920		let cmd =
921		sprintf "why-cpulimit %d yices -pc 0 -smt %s > out 2>&1 && grep -q -w unsat out"
922		!timeout fsmt
923		in
924		let out = Sys.command cmd in
925		let r =
926		if out = 0 then Valid None else if out = 1 then Invalid else Timeout
927		in
928		if not !debug then remove_files [fwhy; fsmt];
929		r
930
931		let call_cvc3 fwhy =
932		let cmd =
933		sprintf "why -smtlib --encoding sstrat %s" (why_files fwhy)
934		in
935		if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed");
936		let fsmt = Filename.chop_suffix fwhy ".why" ^ "_why.smt" in
937		let cmd =
938		sprintf "why-cpulimit %d cvc3 -lang smt %s > out 2>&1 && grep -q -w unsat out"
939		!timeout fsmt
940		in
941		let out = Sys.command cmd in
942		let r =
943		if out = 0 then Valid None else if out = 1 then Invalid else Timeout
944		in
945		if not !debug then remove_files [fwhy; fsmt];
946		r
947		*)
948
949		let call_cvcl fwhy =
950		let cmd =
951		sprintf "why --cvcl --encoding sstrat %s" (why_files fwhy)
952		in
953		if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed");
954		let fcvc = Filename.chop_suffix fwhy ".why" ^ "_why.cvc" in
955		(*
956		let cmd =
957		sprintf "timeout %d cvcl < %s > out 2>&1 && grep -q -w Valid out"
958		!timeout fcvc
959		in
960		let out = Sys.command cmd in
961		let r =
962		if out = 0 then Valid None else if out = 1 then Invalid else Timeout
963		in
964		*)
965		let r = call_prover fcvc in
966		if not !debug then remove_files [fwhy; fcvc];
967		r
968
969		let call_harvey fwhy =
970		let cmd =
971		sprintf "why --harvey --encoding strat %s" (why_files fwhy)
972		in
973		if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed");
974		let frv = Filename.chop_suffix fwhy ".why" ^ "_why.rv" in
975		(*
976		let out = Sys.command (sprintf "rvc -e -t %s > /dev/null 2>&1" frv) in
977		if out <> 0 then anomaly ("call to rvc -e -t " ^ frv ^ " failed");
978		let f = Filename.chop_suffix frv ".rv" ^ "-0.baf" in
979		let outf = Filename.temp_file "rv" ".out" in
980		let out =
981		Sys.command (sprintf "timeout %d rv -e\"-T 2000\" %s > %s 2>&1"
982		!timeout f outf)
983		in
984		let r =
985		if out <> 0 then
986		Timeout
987		else
988		let cmd =
989		sprintf "grep \"Proof obligation in\" %s \| grep -q \"is valid\"" outf
990		in
991		if Sys.command cmd = 0 then Valid None else Invalid
992		in
993		if not !debug then remove_files [fwhy; frv; outf];
994		*)
995		let r = call_prover frv in
996		if not !debug then remove_files [fwhy; frv];
997		r
998
999		let call_gwhy fwhy =
1000		let cmd = sprintf "gwhy %s" (why_files fwhy) in
1001		if Sys.command cmd <> 0 then ignore (Sys.command (sprintf "emacs %s" fwhy));
1002		NoAnswer
1003
1004		let ergo_proof_from_file f gl =
1005		let s =
1006		let buf = Buffer.create 1024 in
1007		let c = open_in f in
1008		try
1009		while true do Buffer.add_string buf (input_line c) done; assert false
1010		with End_of_file ->
1011		close_in c;
1012		Buffer.contents buf
1013		in
1014		let parsed_constr = Pcoq.parse_string Pcoq.Constr.constr s in
1015		let t = Constrintern.interp_constr (project gl) (pf_env gl) parsed_constr in
1016		exact_check t gl
1017
1018		let call_prover prover q =
1019		let fwhy = Filename.temp_file "coq_dp" ".why" in
1020		Dp_why.output_file fwhy q;
1021		match prover with
1022		\| Simplify -> call_simplify fwhy
1023		\| Ergo -> call_ergo fwhy
1024		\| CVC3 -> call_smt ~smt:"cvc3" fwhy
1025		\| Yices -> call_smt ~smt:"yices" fwhy
1026		\| Z3 -> call_smt ~smt:"z3" fwhy
1027		\| Zenon -> call_zenon fwhy
1028		\| CVCLite -> call_cvcl fwhy
1029		\| Harvey -> call_harvey fwhy
1030		\| Gwhy -> call_gwhy fwhy
1031
1032		let dp prover gl =
1033		Coqlib.check_required_library ["Coq";"ZArith";"ZArith"];
1034		let concl_type = pf_type_of gl (pf_concl gl) in
1035		if not (is_Prop concl_type) then error "Conclusion is not a Prop";
1036		try
1037		let q = tr_goal gl in
1038		begin match call_prover prover q with
1039		\| Valid (Some f) when prover = Zenon -> Dp_zenon.proof_from_file f gl
1040		\| Valid (Some f) when prover = Ergo -> ergo_proof_from_file f gl
1041		\| Valid _ -> Tactics.admit_as_an_axiom gl
1042		\| Invalid -> error "Invalid"
1043		\| DontKnow -> error "Don't know"
1044		\| Timeout -> error "Timeout"
1045		\| Failure s -> error s
1046		\| NoAnswer -> Tacticals.tclIDTAC gl
1047		end
1048		with NotFO ->
1049		error "Not a first order goal"
1050
1051
1052		let simplify = tclTHEN intros (dp Simplify)
1053		let ergo = tclTHEN intros (dp Ergo)
1054		let cvc3 = tclTHEN intros (dp CVC3)
1055		let yices = tclTHEN intros (dp Yices)
1056		let z3 = tclTHEN intros (dp Z3)
1057		let cvc_lite = tclTHEN intros (dp CVCLite)
1058		let harvey = dp Harvey
1059		let zenon = tclTHEN intros (dp Zenon)
1060		let gwhy = tclTHEN intros (dp Gwhy)
1061
1062		let dp_hint l =
1063		let env = Global.env () in
1064		let one_hint (qid,r) =
1065		if not (mem_global r) then begin
1066		let ty = Global.type_of_global r in
1067		let s = Typing.type_of env Evd.empty ty in
1068		if is_Prop s then
1069		try
1070		let id = rename_global r in
1071		let tv, env, ty = decomp_type_quantifiers env ty in
1072		let d = Axiom (id, tr_formula tv [] env ty) in
1073		add_global r (Gfo d);
1074		globals_stack := d :: !globals_stack
1075		with NotFO ->
1076		add_global r Gnot_fo;
1077		msg_warning
1078		(pr_reference qid ++
1079		str " ignored (not a first order proposition)")
1080		else begin
1081		add_global r Gnot_fo;
1082		msg_warning
1083		(pr_reference qid ++ str " ignored (not a proposition)")
1084		end
1085		end
1086		in
1087		List.iter one_hint (List.map (fun qid -> qid, Nametab.global qid) l)
1088
1089		let dp_hint_obj : reference list -> obj =
1090		declare_object
1091		{(default_object "Dp_hint") with
1092		cache_function = (fun (_,l) -> dp_hint l);
1093		load_function = (fun _ (_,l) -> dp_hint l)}
1094
1095		let dp_hint l = Lib.add_anonymous_leaf (dp_hint_obj l)
1096
1097		let dp_predefined qid s =
1098		let r = Nametab.global qid in
1099		let ty = Global.type_of_global r in
1100		let env = Global.env () in
1101		let id = rename_global r in
1102		try
1103		let d = match tr_decl env id ty with
1104		\| DeclType (_, n) -> DeclType (s, n)
1105		\| DeclFun (_, n, tyl, ty) -> DeclFun (s, n, tyl, ty)
1106		\| DeclPred (_, n, tyl) -> DeclPred (s, n, tyl)
1107		\| Axiom _ as d -> d
1108		in
1109		match d with
1110		\| Axiom _ -> msg_warning (str " ignored (axiom)")
1111		\| d -> add_global r (Gfo d)
1112		with NotFO ->
1113		msg_warning (str " ignored (not a first order declaration)")
1114
1115		let dp_predefined_obj : reference * string -> obj =
1116		declare_object
1117		{(default_object "Dp_predefined") with
1118		cache_function = (fun (_,(id,s)) -> dp_predefined id s);
1119		load_function = (fun _ (_,(id,s)) -> dp_predefined id s)}
1120
1121		let dp_predefined id s = Lib.add_anonymous_leaf (dp_predefined_obj (id,s))
1122
1123		let _ = declare_summary "Dp options"
1124		{ freeze_function =
1125		(fun () -> !debug, !trace, !timeout, !prelude_files);
1126		unfreeze_function =
1127		(fun (d,tr,tm,pr) ->
1128		debug := d; trace := tr; timeout := tm; prelude_files := pr);
1129		init_function =
1130		(fun () ->
1131		debug := false; trace := false; timeout := 10;
1132		prelude_files := []) }

+0

-20

~~plugins/dp/dp.mli~~ less more

0
1		open Libnames
2		open Proof_type
3
4		val simplify : tactic
5		val ergo : tactic
6		val cvc3 : tactic
7		val yices : tactic
8		val cvc_lite : tactic
9		val harvey : tactic
10		val zenon : tactic
11		val gwhy : tactic
12		val z3: tactic
13
14		val dp_hint : reference list -> unit
15		val dp_timeout : int -> unit
16		val dp_debug : bool -> unit
17		val dp_trace : bool -> unit
18		val dp_prelude : string list -> unit
19		val dp_predefined : reference -> string -> unit

+0

-5

~~plugins/dp/dp_plugin.mllib~~ less more

0		Dp_why
1		Dp_zenon
2		Dp
3		G_dp
4		Dp_plugin_mod

+0

-185

~~plugins/dp/dp_why.ml~~ less more

0
1		(* Pretty-print PFOL (see fol.mli) in Why syntax *)
2
3		open Format
4		open Fol
5
6		type proof =
7		\| Immediate of Term.constr
8		\| Fun_def of string * (string * typ) list * typ * term
9
10		let proofs = Hashtbl.create 97
11		let proof_name =
12		let r = ref 0 in fun () -> incr r; "dp_axiom__" ^ string_of_int !r
13
14		let add_proof pr = let n = proof_name () in Hashtbl.add proofs n pr; n
15
16		let find_proof = Hashtbl.find proofs
17
18		let rec print_list sep print fmt = function
19		\| [] -> ()
20		\| [x] -> print fmt x
21		\| x :: r -> print fmt x; sep fmt (); print_list sep print fmt r
22
23		let space fmt () = fprintf fmt "@ "
24		let comma fmt () = fprintf fmt ",@ "
25
26		let is_why_keyword =
27		let h = Hashtbl.create 17 in
28		List.iter
29		(fun s -> Hashtbl.add h s ())
30		["absurd"; "and"; "array"; "as"; "assert"; "axiom"; "begin";
31		"bool"; "do"; "done"; "else"; "end"; "exception"; "exists";
32		"external"; "false"; "for"; "forall"; "fun"; "function"; "goal";
33		"if"; "in"; "int"; "invariant"; "label"; "let"; "logic"; "not";
34		"of"; "or"; "parameter"; "predicate"; "prop"; "raise"; "raises";
35		"reads"; "real"; "rec"; "ref"; "returns"; "then"; "true"; "try";
36		"type"; "unit"; "variant"; "void"; "while"; "with"; "writes" ];
37		Hashtbl.mem h
38
39		let ident fmt s =
40		if is_why_keyword s then fprintf fmt "coq__%s" s else fprintf fmt "%s" s
41
42		let rec print_typ fmt = function
43		\| Tvar x -> fprintf fmt "'%a" ident x
44		\| Tid ("int", []) -> fprintf fmt "int"
45		\| Tid ("real", []) -> fprintf fmt "real"
46		\| Tid (x, []) -> fprintf fmt "%a" ident x
47		\| Tid (x, [t]) -> fprintf fmt "%a %a" print_typ t ident x
48		\| Tid (x,tl) -> fprintf fmt "(%a) %a" (print_list comma print_typ) tl ident x
49
50		let print_arg fmt (id,typ) = fprintf fmt "%a: %a" ident id print_typ typ
51
52		let rec print_term fmt = function
53		\| Cst n ->
54		fprintf fmt "%s" (Big_int.string_of_big_int n)
55		\| RCst s ->
56		fprintf fmt "%s.0" (Big_int.string_of_big_int s)
57		\| Power2 n ->
58		fprintf fmt "0x1p%s" (Big_int.string_of_big_int n)
59		\| Plus (a, b) ->
60		fprintf fmt "@[(%a +@ %a)@]" print_term a print_term b
61		\| Moins (a, b) ->
62		fprintf fmt "@[(%a -@ %a)@]" print_term a print_term b
63		\| Mult (a, b) ->
64		fprintf fmt "@[(%a *@ %a)@]" print_term a print_term b
65		\| Div (a, b) ->
66		fprintf fmt "@[(%a /@ %a)@]" print_term a print_term b
67		\| Opp (a) ->
68		fprintf fmt "@[(-@ %a)@]" print_term a
69		\| App (id, []) ->
70		fprintf fmt "%a" ident id
71		\| App (id, tl) ->
72		fprintf fmt "@[%a(%a)@]" ident id print_terms tl
73
74		and print_terms fmt tl =
75		print_list comma print_term fmt tl
76
77		let rec print_predicate fmt p =
78		let pp = print_predicate in
79		match p with
80		\| True ->
81		fprintf fmt "true"
82		\| False ->
83		fprintf fmt "false"
84		\| Fatom (Eq (a, b)) ->
85		fprintf fmt "@[(%a =@ %a)@]" print_term a print_term b
86		\| Fatom (Le (a, b)) ->
87		fprintf fmt "@[(%a <=@ %a)@]" print_term a print_term b
88		\| Fatom (Lt (a, b))->
89		fprintf fmt "@[(%a <@ %a)@]" print_term a print_term b
90		\| Fatom (Ge (a, b)) ->
91		fprintf fmt "@[(%a >=@ %a)@]" print_term a print_term b
92		\| Fatom (Gt (a, b)) ->
93		fprintf fmt "@[(%a >@ %a)@]" print_term a print_term b
94		\| Fatom (Pred (id, [])) ->
95		fprintf fmt "%a" ident id
96		\| Fatom (Pred (id, tl)) ->
97		fprintf fmt "@[%a(%a)@]" ident id print_terms tl
98		\| Imp (a, b) ->
99		fprintf fmt "@[(%a ->@ %a)@]" pp a pp b
100		\| Iff (a, b) ->
101		fprintf fmt "@[(%a <->@ %a)@]" pp a pp b
102		\| And (a, b) ->
103		fprintf fmt "@[(%a and@ %a)@]" pp a pp b
104		\| Or (a, b) ->
105		fprintf fmt "@[(%a or@ %a)@]" pp a pp b
106		\| Not a ->
107		fprintf fmt "@[(not@ %a)@]" pp a
108		\| Forall (id, t, p) ->
109		fprintf fmt "@[(forall %a:%a.@ %a)@]" ident id print_typ t pp p
110		\| Exists (id, t, p) ->
111		fprintf fmt "@[(exists %a:%a.@ %a)@]" ident id print_typ t pp p
112
113		let rec remove_iff args = function
114		Forall (id,t,p) -> remove_iff ((id,t)::args) p
115		\| Iff(_,b) -> List.rev args, b
116		\| _ -> raise Not_found
117
118		let print_query fmt (decls,concl) =
119		let find_declared_preds l =
120		function
121		DeclPred (id,_,args) -> (id,args) :: l
122		\| _ -> l
123		in
124		let find_defined_preds declared l = function
125		Axiom(id,f) ->
126		(try
127		let _decl = List.assoc id declared in
128		(id,remove_iff [] f)::l
129		with Not_found -> l)
130		\| _ -> l
131		in
132		let declared_preds =
133		List.fold_left find_declared_preds [] decls in
134		let defined_preds =
135		List.fold_left (find_defined_preds declared_preds) [] decls
136		in
137		let print_dtype = function
138		\| DeclType (id, 0) ->
139		fprintf fmt "@[type %a@]@\n@\n" ident id
140		\| DeclType (id, 1) ->
141		fprintf fmt "@[type 'a %a@]@\n@\n" ident id
142		\| DeclType (id, n) ->
143		fprintf fmt "@[type (";
144		for i = 1 to n do
145		fprintf fmt "'a%d" i; if i < n then fprintf fmt ", "
146		done;
147		fprintf fmt ") %a@]@\n@\n" ident id
148		\| DeclFun _ \| DeclPred _ \| Axiom _ ->
149		()
150		in
151		let print_dvar_dpred = function
152		\| DeclFun (id, _, [], t) ->
153		fprintf fmt "@[logic %a : -> %a@]@\n@\n" ident id print_typ t
154		\| DeclFun (id, _, l, t) ->
155		fprintf fmt "@[logic %a : %a -> %a@]@\n@\n"
156		ident id (print_list comma print_typ) l print_typ t
157		\| DeclPred (id, _, []) when not (List.mem_assoc id defined_preds) ->
158		fprintf fmt "@[logic %a : -> prop @]@\n@\n" ident id
159		\| DeclPred (id, _, l) when not (List.mem_assoc id defined_preds) ->
160		fprintf fmt "@[logic %a : %a -> prop@]@\n@\n"
161		ident id (print_list comma print_typ) l
162		\| DeclType _ \| Axiom _ \| DeclPred _ ->
163		()
164		in
165		let print_assert = function
166		\| Axiom(id,_) when List.mem_assoc id defined_preds ->
167		let args, def = List.assoc id defined_preds in
168		fprintf fmt "@[predicate %a(%a) =@\n%a@]@\n" ident id
169		(print_list comma print_arg) args print_predicate def
170		\| Axiom (id, f) ->
171		fprintf fmt "@[<hov 2>axiom %a:@ %a@]@\n@\n" ident id print_predicate f
172		\| DeclType _ \| DeclFun _ \| DeclPred _ ->
173		()
174		in
175		List.iter print_dtype decls;
176		List.iter print_dvar_dpred decls;
177		List.iter print_assert decls;
178		fprintf fmt "@[<hov 2>goal coq___goal: %a@]" print_predicate concl
179
180		let output_file f q =
181		let c = open_out f in
182		let fmt = formatter_of_out_channel c in
183		fprintf fmt "@[%a@]@." print_query q;
184		close_out c

+0

-17

~~plugins/dp/dp_why.mli~~ less more

0
1		open Fol
2
3		(* generation of the Why file *)
4
5		val output_file : string -> query -> unit
6
7		(* table to translate the proofs back to Coq (used in dp_zenon) *)
8
9		type proof =
10		\| Immediate of Term.constr
11		\| Fun_def of string * (string * typ) list * typ * term
12
13		val add_proof : proof -> string
14		val find_proof : string -> proof
15
16

+0

-7

~~plugins/dp/dp_zenon.mli~~ less more

0
1		open Fol
2
3		val set_debug : bool -> unit
4
5		val proof_from_file : string -> Proof_type.tactic
6

+0

-189

~~plugins/dp/dp_zenon.mll~~ less more

0
1		{
2
3		open Lexing
4		open Pp
5		open Util
6		open Names
7		open Tacmach
8		open Dp_why
9		open Tactics
10		open Tacticals
11
12		let debug = ref false
13		let set_debug b = debug := b
14
15		let buf = Buffer.create 1024
16
17		let string_of_global env ref =
18		Libnames.string_of_qualid (Nametab.shortest_qualid_of_global env ref)
19
20		let axioms = ref []
21
22		(* we cannot interpret the terms as we read them (since some lemmas
23		may need other lemmas to be already interpreted) *)
24		type lemma = { l_id : string; l_type : string; l_proof : string }
25		type zenon_proof = lemma list * string
26
27		}
28
29		let ident = ['a'-'z' 'A'-'Z' '_' '0'-'9' '\'']+
30		let space = [' ' '\t' '\r']
31
32		rule start = parse
33		\| "(* BEGIN-PROOF *)" "\n" { scan lexbuf }
34		\| _ { start lexbuf }
35		\| eof { anomaly "malformed Zenon proof term" }
36
37		(* here we read the lemmas and the main proof term;
38		meanwhile we maintain the set of axioms that were used *)
39
40		and scan = parse
41		\| "Let" space (ident as id) space* ":"
42		{ let t = read_coq_term lexbuf in
43		let p = read_lemma_proof lexbuf in
44		let l,pr = scan lexbuf in
45		{ l_id = id; l_type = t; l_proof = p } :: l, pr }
46		\| "Definition theorem:"
47		{ let t = read_main_proof lexbuf in [], t }
48		\| _ \| eof
49		{ anomaly "malformed Zenon proof term" }
50
51		and read_coq_term = parse
52		\| "." "\n"
53		{ let s = Buffer.contents buf in Buffer.clear buf; s }
54		\| "coq__" (ident as id) (* a Why keyword renamed *)
55		{ Buffer.add_string buf id; read_coq_term lexbuf }
56		\| ("dp_axiom__" ['0'-'9']+) as id
57		{ axioms := id :: !axioms; Buffer.add_string buf id; read_coq_term lexbuf }
58		\| _ as c
59		{ Buffer.add_char buf c; read_coq_term lexbuf }
60		\| eof
61		{ anomaly "malformed Zenon proof term" }
62
63		and read_lemma_proof = parse
64		\| "Proof" space
65		{ read_coq_term lexbuf }
66		\| _ \| eof
67		{ anomaly "malformed Zenon proof term" }
68
69		(* skip the main proof statement and then read its term *)
70		and read_main_proof = parse
71		\| ":=" "\n"
72		{ read_coq_term lexbuf }
73		\| _
74		{ read_main_proof lexbuf }
75		\| eof
76		{ anomaly "malformed Zenon proof term" }
77
78
79		{
80
81		let read_zenon_proof f =
82		Buffer.clear buf;
83		let c = open_in f in
84		let lb = from_channel c in
85		let p = start lb in
86		close_in c;
87		if not !debug then begin try Sys.remove f with _ -> () end;
88		p
89
90		let constr_of_string gl s =
91		let parse_constr = Pcoq.parse_string Pcoq.Constr.constr in
92		Constrintern.interp_constr (project gl) (pf_env gl) (parse_constr s)
93
94		(* we are lazy here: we build strings containing Coq terms using a *)
95		(* pretty-printer Fol -> Coq *)
96		module Coq = struct
97		open Format
98		open Fol
99
100		let rec print_list sep print fmt = function
101		\| [] -> ()
102		\| [x] -> print fmt x
103		\| x :: r -> print fmt x; sep fmt (); print_list sep print fmt r
104
105		let space fmt () = fprintf fmt "@ "
106		let comma fmt () = fprintf fmt ",@ "
107
108		let rec print_typ fmt = function
109		\| Tvar x -> fprintf fmt "%s" x
110		\| Tid ("int", []) -> fprintf fmt "Z"
111		\| Tid (x, []) -> fprintf fmt "%s" x
112		\| Tid (x, [t]) -> fprintf fmt "(%s %a)" x print_typ t
113		\| Tid (x,tl) ->
114		fprintf fmt "(%s %a)" x (print_list comma print_typ) tl
115
116		let rec print_term fmt = function
117		\| Cst n ->
118		fprintf fmt "%s" (Big_int.string_of_big_int n)
119		\| RCst s ->
120		fprintf fmt "%s" (Big_int.string_of_big_int s)
121		\| Power2 n ->
122		fprintf fmt "@[(powerRZ 2 %s)@]" (Big_int.string_of_big_int n)
123
124		(* TODO: bug, it might be operations on reals *)
125		\| Plus (a, b) ->
126		fprintf fmt "@[(Zplus %a %a)@]" print_term a print_term b
127		\| Moins (a, b) ->
128		fprintf fmt "@[(Zminus %a %a)@]" print_term a print_term b
129		\| Mult (a, b) ->
130		fprintf fmt "@[(Zmult %a %a)@]" print_term a print_term b
131		\| Div (a, b) ->
132		fprintf fmt "@[(Zdiv %a %a)@]" print_term a print_term b
133		\| Opp (a) ->
134		fprintf fmt "@[(Zopp %a)@]" print_term a
135		\| App (id, []) ->
136		fprintf fmt "%s" id
137		\| App (id, tl) ->
138		fprintf fmt "@[(%s %a)@]" id print_terms tl
139
140		and print_terms fmt tl =
141		print_list space print_term fmt tl
142
143		(* builds the text for "forall vars, f vars = t" *)
144		let fun_def_axiom f vars t =
145		let binder fmt (x,t) = fprintf fmt "(%s: %a)" x print_typ t in
146		fprintf str_formatter
147		"@[(forall %a, %s %a = %a)@]@."
148		(print_list space binder) vars f
149		(print_list space (fun fmt (x,_) -> pp_print_string fmt x)) vars
150		print_term t;
151		flush_str_formatter ()
152
153		end
154
155		let prove_axiom id = match Dp_why.find_proof id with
156		\| Immediate t ->
157		exact_check t
158		\| Fun_def (f, vars, ty, t) ->
159		tclTHENS
160		(fun gl ->
161		let s = Coq.fun_def_axiom f vars t in
162		if !debug then Format.eprintf "axiom fun def = %s@." s;
163		let c = constr_of_string gl s in
164		assert_tac (Name (id_of_string id)) c gl)
165		[tclTHEN intros reflexivity; tclIDTAC]
166
167		let exact_string s gl =
168		let c = constr_of_string gl s in
169		exact_check c gl
170
171		let interp_zenon_proof (ll,p) =
172		let interp_lemma l gl =
173		let ty = constr_of_string gl l.l_type in
174		tclTHENS
175		(assert_tac (Name (id_of_string l.l_id)) ty)
176		[exact_string l.l_proof; tclIDTAC]
177		gl
178		in
179		tclTHEN (tclMAP interp_lemma ll) (exact_string p)
180
181		let proof_from_file f =
182		axioms := [];
183		msgnl (str "proof_from_file " ++ str f);
184		let zp = read_zenon_proof f in
185		msgnl (str "proof term is " ++ str (snd zp));
186		tclTHEN (tclMAP prove_axiom !axioms) (interp_zenon_proof zp)
187
188		}

+0

-58

~~plugins/dp/fol.mli~~ less more

0
1		(* Polymorphic First-Order Logic (that is Why's input logic) *)
2
3		type typ =
4		\| Tvar of string
5		\| Tid of string * typ list
6
7		type term =
8		\| Cst of Big_int.big_int
9		\| RCst of Big_int.big_int
10		\| Power2 of Big_int.big_int
11		\| Plus of term * term
12		\| Moins of term * term
13		\| Mult of term * term
14		\| Div of term * term
15		\| Opp of term
16		\| App of string * term list
17
18		and atom =
19		\| Eq of term * term
20		\| Le of term * term
21		\| Lt of term * term
22		\| Ge of term * term
23		\| Gt of term * term
24		\| Pred of string * term list
25
26		and form =
27		\| Fatom of atom
28		\| Imp of form * form
29		\| Iff of form * form
30		\| And of form * form
31		\| Or of form * form
32		\| Not of form
33		\| Forall of string * typ * form
34		\| Exists of string * typ * form
35		\| True
36		\| False
37
38		(* the integer indicates the number of type variables *)
39		type decl =
40		\| DeclType of string * int
41		\| DeclFun of string * int * typ list * typ
42		\| DeclPred of string * int * typ list
43		\| Axiom of string * form
44
45		type query = decl list * form
46
47
48		(* prover result *)
49
50		type prover_answer =
51		\| Valid of string option
52		\| Invalid
53		\| DontKnow
54		\| Timeout
55		\| NoAnswer
56		\| Failure of string
57

+0

-77

~~plugins/dp/g_dp.ml4~~ less more

0		(************************************************************************)
1		(* v * The Coq Proof Assistant / The Coq Development Team *)
2		(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
3		(* \VV/ **************************************************************)
4		(* // * This file is distributed under the terms of the *)
5		(* * GNU Lesser General Public License Version 2.1 *)
6		(************************************************************************)
7
8		(i camlp4deps: "parsing/grammar.cma" i)
9
10		open Dp
11
12		TACTIC EXTEND Simplify
13		[ "simplify" ] -> [ simplify ]
14		END
15
16		TACTIC EXTEND Ergo
17		[ "ergo" ] -> [ ergo ]
18		END
19
20		TACTIC EXTEND Yices
21		[ "yices" ] -> [ yices ]
22		END
23
24		TACTIC EXTEND CVC3
25		[ "cvc3" ] -> [ cvc3 ]
26		END
27
28		TACTIC EXTEND Z3
29		[ "z3" ] -> [ z3 ]
30		END
31
32		TACTIC EXTEND CVCLite
33		[ "cvcl" ] -> [ cvc_lite ]
34		END
35
36		TACTIC EXTEND Harvey
37		[ "harvey" ] -> [ harvey ]
38		END
39
40		TACTIC EXTEND Zenon
41		[ "zenon" ] -> [ zenon ]
42		END
43
44		TACTIC EXTEND Gwhy
45		[ "gwhy" ] -> [ gwhy ]
46		END
47
48		(* should be part of basic tactics syntax *)
49		TACTIC EXTEND admit
50		[ "admit" ] -> [ Tactics.admit_as_an_axiom ]
51		END
52
53		VERNAC COMMAND EXTEND Dp_hint
54		[ "Dp_hint" ne_global_list(l) ] -> [ dp_hint l ]
55		END
56
57		VERNAC COMMAND EXTEND Dp_timeout
58		\| [ "Dp_timeout" natural(n) ] -> [ dp_timeout n ]
59		END
60
61		VERNAC COMMAND EXTEND Dp_prelude
62		\| [ "Dp_prelude" string_list(l) ] -> [ dp_prelude l ]
63		END
64
65		VERNAC COMMAND EXTEND Dp_predefined
66		\| [ "Dp_predefined" global(g) "=>" string(s) ] -> [ dp_predefined g s ]
67		END
68
69		VERNAC COMMAND EXTEND Dp_debug
70		\| [ "Dp_debug" ] -> [ dp_debug true; Dp_zenon.set_debug true ]
71		END
72
73		VERNAC COMMAND EXTEND Dp_trace
74		\| [ "Dp_trace" ] -> [ dp_trace true ]
75		END
76

+0

-80

~~plugins/dp/test2.v~~ less more

0		Require Import ZArith.
1		Require Import Classical.
2		Require Import List.
3
4		Open Scope list_scope.
5		Open Scope Z_scope.
6
7		Dp_debug.
8		Dp_timeout 3.
9		Require Export zenon.
10
11		Definition neg (z:Z) : Z := match z with
12		\| Z0 => Z0
13		\| Zpos p => Zneg p
14		\| Zneg p => Zpos p
15		end.
16
17		Goal forall z, neg (neg z) = z.
18		Admitted.
19
20		Open Scope nat_scope.
21		Print plus.
22
23		Goal forall x, x+0=x.
24		induction x; ergo.
25		(* simplify resoud le premier, pas le second *)
26		Admitted.
27
28		Goal 1::2::3::nil = 1::2::(1+2)::nil.
29		zenon.
30		Admitted.
31
32		Definition T := nat.
33		Parameter fct : T -> nat.
34		Goal fct O = O.
35		Admitted.
36
37		Fixpoint even (n:nat) : Prop :=
38		match n with
39		O => True
40		\| S O => False
41		\| S (S p) => even p
42		end.
43
44		Goal even 4%nat.
45		try zenon.
46		Admitted.
47
48		Definition p (A B:Set) (a:A) (b:B) : list (A*B) := cons (a,b) nil.
49
50		Definition head :=
51		fun (A : Set) (l : list A) =>
52		match l with
53		\| nil => None (A:=A)
54		\| x :: _ => Some x
55		end.
56
57		Goal forall x, head _ (p _ _ 1 2) = Some x -> fst x = 1.
58
59		Admitted.
60
61		(*
62		BUG avec head prédéfini : manque eta-expansion sur A:Set
63
64		Goal forall x, head _ (p _ _ 1 2) = Some x -> fst x = 1.
65
66		Print value.
67		Print Some.
68
69		zenon.
70		*)
71
72		Inductive IN (A:Set) : A -> list A -> Prop :=
73		\| IN1 : forall x l, IN A x (x::l)
74		\| IN2: forall x l, IN A x l -> forall y, IN A x (y::l).
75		Arguments IN [A] _ _.
76
77		Goal forall x, forall (l:list nat), IN x l -> IN x (1%nat::l).
78		zenon.
79		Print In.

+0

-300

~~plugins/dp/tests.v~~ less more

0
1		Require Import ZArith.
2		Require Import Classical.
3		Require Export Reals.
4
5
6		(* real numbers *)
7
8		Lemma real_expr: (0 <= 9 * 4)%R.
9		ergo.
10		Qed.
11
12		Lemma powerRZ_translation: (powerRZ 2 15 < powerRZ 2 17)%R.
13		ergo.
14		Qed.
15
16		Dp_debug.
17		Dp_timeout 3.
18
19		(* module renamings *)
20
21		Module M.
22		Parameter t : Set.
23		End M.
24
25		Lemma test_module_0 : forall x:M.t, x=x.
26		ergo.
27		Qed.
28
29		Module N := M.
30
31		Lemma test_module_renaming_0 : forall x:N.t, x=x.
32		ergo.
33		Qed.
34
35		Dp_predefined M.t => "int".
36
37		Lemma test_module_renaming_1 : forall x:N.t, x=x.
38		ergo.
39		Qed.
40
41		(* Coq lists *)
42
43		Require Export List.
44
45		Lemma test_pol_0 : forall l:list nat, l=l.
46		ergo.
47		Qed.
48
49		Parameter nlist: list nat -> Prop.
50
51		Lemma poly_1 : forall l, nlist l -> True.
52		intros.
53		simplify.
54		Qed.
55
56		(* user lists *)
57
58		Inductive list (A:Set) : Set :=
59		\| nil : list A
60		\| cons: forall a:A, list A -> list A.
61
62		Fixpoint app (A:Set) (l m:list A) {struct l} : list A :=
63		match l with
64		\| nil => m
65		\| cons a l1 => cons A a (app A l1 m)
66		end.
67
68		Lemma entail: (nil Z) = app Z (nil Z) (nil Z) -> True.
69		intros; ergo.
70		Qed.
71
72		(* polymorphism *)
73		Require Import List.
74
75		Inductive mylist (A:Set) : Set :=
76		mynil : mylist A
77		\| mycons : forall a:A, mylist A -> mylist A.
78
79		Parameter my_nlist: mylist nat -> Prop.
80
81		Goal forall l, my_nlist l -> True.
82		intros.
83		simplify.
84		Qed.
85
86		(* First example with the 0 and the equality translated *)
87
88		Goal 0 = 0.
89		simplify.
90		Qed.
91
92		(* Examples in the Propositional Calculus
93		and theory of equality *)
94
95		Parameter A C : Prop.
96
97		Goal A -> A.
98		simplify.
99		Qed.
100
101
102		Goal A -> (A \/ C).
103
104		simplify.
105		Qed.
106
107
108		Parameter x y z : Z.
109
110		Goal x = y -> y = z -> x = z.
111		ergo.
112		Qed.
113
114
115		Goal ((((A -> C) -> A) -> A) -> C) -> C.
116
117		ergo.
118		Qed.
119
120		(* Arithmetic *)
121		Open Scope Z_scope.
122
123		Goal 1 + 1 = 2.
124		yices.
125		Qed.
126
127
128		Goal 2*x + 10 = 18 -> x = 4.
129
130		simplify.
131		Qed.
132
133
134		(* Universal quantifier *)
135
136		Goal (forall (x y : Z), x = y) -> 0=1.
137		try zenon.
138		ergo.
139		Qed.
140
141		Goal forall (x: nat), (x + 0 = x)%nat.
142
143		induction x0; ergo.
144		Qed.
145
146
147		(* No decision procedure can solve this problem
148		Goal forall (x a b : Z), a * x + b = 0 -> x = - b/a.
149		*)
150
151
152		(* Functions definitions *)
153
154		Definition fst (x y : Z) : Z := x.
155
156		Goal forall (g : Z -> Z) (x y : Z), g (fst x y) = g x.
157
158		simplify.
159		Qed.
160
161
162		(* Eta-expansion example *)
163
164		Definition snd_of_3 (x y z : Z) : Z := y.
165
166		Definition f : Z -> Z -> Z := snd_of_3 0.
167
168		Goal forall (x y z z1 : Z), snd_of_3 x y z = f y z1.
169
170		simplify.
171		Qed.
172
173
174		(* Inductive types definitions - call to dp/injection function *)
175
176		Inductive even : Z -> Prop :=
177		\| even_0 : even 0
178		\| even_plus2 : forall z : Z, even z -> even (z + 2).
179
180
181		(* Simplify and Zenon can't prove this goal before the timeout
182		unlike CVC Lite *)
183
184		Goal even 4.
185		ergo.
186		Qed.
187
188
189		Definition skip_z (z : Z) (n : nat) := n.
190
191		Definition skip_z1 := skip_z.
192
193		Goal forall (z : Z) (n : nat), skip_z z n = skip_z1 z n.
194		yices.
195		Qed.
196
197
198		(* Axioms definitions and dp_hint *)
199
200		Parameter add : nat -> nat -> nat.
201		Axiom add_0 : forall (n : nat), add 0%nat n = n.
202		Axiom add_S : forall (n1 n2 : nat), add (S n1) n2 = S (add n1 n2).
203
204		Dp_hint add_0.
205		Dp_hint add_S.
206
207		(* Simplify can't prove this goal before the timeout
208		unlike zenon *)
209
210		Goal forall n : nat, add n 0 = n.
211		induction n ; yices.
212		Qed.
213
214
215		Definition pred (n : nat) : nat := match n with
216		\| 0%nat => 0%nat
217		\| S n' => n'
218		end.
219
220		Goal forall n : nat, n <> 0%nat -> pred (S n) <> 0%nat.
221		yices.
222		(zenon.)
223		Qed.
224
225
226		Fixpoint plus (n m : nat) {struct n} : nat :=
227		match n with
228		\| 0%nat => m
229		\| S n' => S (plus n' m)
230		end.
231
232		Goal forall n : nat, plus n 0%nat = n.
233
234		induction n; ergo.
235		Qed.
236
237
238		(* Mutually recursive functions *)
239
240		Fixpoint even_b (n : nat) : bool := match n with
241		\| O => true
242		\| S m => odd_b m
243		end
244		with odd_b (n : nat) : bool := match n with
245		\| O => false
246		\| S m => even_b m
247		end.
248
249		Goal even_b (S (S O)) = true.
250		ergo.
251		(*
252		simplify.
253		zenon.
254		*)
255		Qed.
256
257
258		(* sorts issues *)
259
260		Parameter foo : Set.
261		Parameter ff : nat -> foo -> foo -> nat.
262		Parameter g : foo -> foo.
263		Goal (forall x:foo, ff 0 x x = O) -> forall y, ff 0 (g y) (g y) = O.
264		yices.
265		(zenon.)
266		Qed.
267
268
269
270		(* abstractions *)
271
272		Parameter poly_f : forall A:Set, A->A.
273
274		Goal forall x:nat, poly_f nat x = poly_f nat x.
275		ergo.
276		(zenon.)
277		Qed.
278
279
280
281		(* Anonymous mutually recursive functions : no equations are produced
282
283		Definition mrf :=
284		fix even2 (n : nat) : bool := match n with
285		\| O => true
286		\| S m => odd2 m
287		end
288		with odd2 (n : nat) : bool := match n with
289		\| O => false
290		\| S m => even2 m
291		end for even.
292
293		Thus this goal is unsolvable
294
295		Goal mrf (S (S O)) = true.
296
297		zenon.
298
299		*)

+0

-1

~~plugins/dp/vo.itarget~~ less more

0

Dp.vo

+0

-92

~~plugins/dp/zenon.v~~ less more

0		(* Copyright 2004 INRIA *)
1		Require Export Classical.
2
3		Lemma zenon_nottrue :
4		(~True -> False).
5		Proof. tauto. Qed.
6
7		Lemma zenon_noteq : forall (T : Type) (t : T),
8		((t <> t) -> False).
9		Proof. tauto. Qed.
10
11		Lemma zenon_and : forall P Q : Prop,
12		(P -> Q -> False) -> (P /\ Q -> False).
13		Proof. tauto. Qed.
14
15		Lemma zenon_or : forall P Q : Prop,
16		(P -> False) -> (Q -> False) -> (P \/ Q -> False).
17		Proof. tauto. Qed.
18
19		Lemma zenon_imply : forall P Q : Prop,
20		(~P -> False) -> (Q -> False) -> ((P -> Q) -> False).
21		Proof. tauto. Qed.
22
23		Lemma zenon_equiv : forall P Q : Prop,
24		(~P -> ~Q -> False) -> (P -> Q -> False) -> ((P <-> Q) -> False).
25		Proof. tauto. Qed.
26
27		Lemma zenon_notand : forall P Q : Prop,
28		(~P -> False) -> (~Q -> False) -> (~(P /\ Q) -> False).
29		Proof. tauto. Qed.
30
31		Lemma zenon_notor : forall P Q : Prop,
32		(~P -> ~Q -> False) -> (~(P \/ Q) -> False).
33		Proof. tauto. Qed.
34
35		Lemma zenon_notimply : forall P Q : Prop,
36		(P -> ~Q -> False) -> (~(P -> Q) -> False).
37		Proof. tauto. Qed.
38
39		Lemma zenon_notequiv : forall P Q : Prop,
40		(~P -> Q -> False) -> (P -> ~Q -> False) -> (~(P <-> Q) -> False).
41		Proof. tauto. Qed.
42
43		Lemma zenon_ex : forall (T : Type) (P : T -> Prop),
44		(forall z : T, ((P z) -> False)) -> ((exists x : T, (P x)) -> False).
45		Proof. firstorder. Qed.
46
47		Lemma zenon_all : forall (T : Type) (P : T -> Prop) (t : T),
48		((P t) -> False) -> ((forall x : T, (P x)) -> False).
49		Proof. firstorder. Qed.
50
51		Lemma zenon_notex : forall (T : Type) (P : T -> Prop) (t : T),
52		(~(P t) -> False) -> (~(exists x : T, (P x)) -> False).
53		Proof. firstorder. Qed.
54
55		Lemma zenon_notall : forall (T : Type) (P : T -> Prop),
56		(forall z : T, (~(P z) -> False)) -> (~(forall x : T, (P x)) -> False).
57		Proof. intros T P Ha Hb. apply Hb. intro. apply NNPP. exact (Ha x). Qed.
58
59		Lemma zenon_equal_base : forall (T : Type) (f : T), f = f.
60		Proof. auto. Qed.
61
62		Lemma zenon_equal_step :
63		forall (S T : Type) (fa fb : S -> T) (a b : S),
64		(fa = fb) -> (a <> b -> False) -> ((fa a) = (fb b)).
65		Proof. intros. rewrite (NNPP (a = b)). congruence. auto. Qed.
66
67		Lemma zenon_pnotp : forall P Q : Prop,
68		(P = Q) -> (P -> ~Q -> False).
69		Proof. intros P Q Ha. rewrite Ha. auto. Qed.
70
71		Lemma zenon_notequal : forall (T : Type) (a b : T),
72		(a = b) -> (a <> b -> False).
73		Proof. auto. Qed.
74
75		Ltac zenon_intro id :=
76		intro id \|\| let nid := fresh in (intro nid; clear nid)
77		.
78
79		Definition zenon_and_s := fun P Q a b => zenon_and P Q b a.
80		Definition zenon_or_s := fun P Q a b c => zenon_or P Q b c a.
81		Definition zenon_imply_s := fun P Q a b c => zenon_imply P Q b c a.
82		Definition zenon_equiv_s := fun P Q a b c => zenon_equiv P Q b c a.
83		Definition zenon_notand_s := fun P Q a b c => zenon_notand P Q b c a.
84		Definition zenon_notor_s := fun P Q a b => zenon_notor P Q b a.
85		Definition zenon_notimply_s := fun P Q a b => zenon_notimply P Q b a.
86		Definition zenon_notequiv_s := fun P Q a b c => zenon_notequiv P Q b c a.
87		Definition zenon_ex_s := fun T P a b => zenon_ex T P b a.
88		Definition zenon_notall_s := fun T P a b => zenon_notall T P b a.
89
90		Definition zenon_pnotp_s := fun P Q a b c => zenon_pnotp P Q c a b.
91		Definition zenon_notequal_s := fun T a b x y => zenon_notequal T a b y x.

+7

-4

plugins/extraction/extract_env.ml less more

154	154	function
155	155	\| (l,SFBconst cb') ->
156	156	let check' = check_fix env cb' (j+1) in
157		if not (fst check = fst check' && prec_declaration_equal (snd check) (snd check')) then raise Impossible;
	157	if not (fst check = fst check' &&
	158	prec_declaration_equal (snd check) (snd check'))
	159	then raise Impossible;
158	160	labels.(j+1) <- l;
159	161	\| _ -> raise Impossible) msb';
160	162	labels, recd, msb''

195	197	\| SEBwith (seb,_) -> msid_of_seb seb
196	198	\| _ -> assert false
197	199
198		let env_for_mtb_with env mp seb idl =
	200	let env_for_mtb_with_def env mp seb idl =
199	201	let sig_b = match seb with
200	202	\| SEBstruct(sig_b) -> sig_b
201	203	\| _ -> assert false
202	204	in
203	205	let l = label_of_id (List.hd idl) in
204		let before = fst (list_split_when (fun (l',_) -> l=l') sig_b) in
	206	let spot = function (l',SFBconst _) -> l = l' \| _ -> false in
	207	let before = fst (list_split_when spot sig_b) in
205	208	Modops.add_signature mp before empty_delta_resolver env
206	209
207	210	(* From a [structure_body] (i.e. a list of [structure_field_body])

240	243	and extract_seb_spec env mp1 (seb,seb_alg) = match seb_alg with
241	244	\| SEBident mp -> Visit.add_mp_all mp; MTident mp
242	245	\| SEBwith(seb',With_definition_body(idl,cb))->
243		let env' = env_for_mtb_with env (msid_of_seb seb') seb idl in
	246	let env' = env_for_mtb_with_def env (msid_of_seb seb') seb idl in
244	247	let mt = extract_seb_spec env mp1 (seb,seb') in
245	248	(match extract_with_type env' cb with (* cb peut contenir des kn *)
246	249	\| None -> mt

+10

-1

plugins/extraction/modutil.ml less more

193	193
194	194	(s Searching one [ml_decl] in a [ml_structure] by its [global_reference] )
195	195
	196	let is_modular = function
	197	\| SEdecl _ -> false
	198	\| SEmodule _ \| SEmodtype _ -> true
	199
	200	let rec search_structure l m = function
	201	\| [] -> raise Not_found
	202	\| (lab,d)::_ when lab=l && is_modular d = m -> d
	203	\| _::fields -> search_structure l m fields
	204
196	205	let get_decl_in_structure r struc =
197	206	try
198	207	let base_mp,ll = labels_of_ref r in

201	210	let rec go ll sel = match ll with
202	211	\| [] -> assert false
203	212	\| l :: ll ->
204		match List.assoc l sel with
	213	match search_structure l (ll<>[]) sel with
205	214	\| SEdecl d -> d
206	215	\| SEmodtype m -> assert false
207	216	\| SEmodule m ->

+0

-2

plugins/firstorder/g_ground.ml4 less more

133	133	\| [ "firstorder" tactic_opt(t) firstorder_using(l)
134	134	"with" ne_preident_list(l') ] ->
135	135	[ gen_ground_tac true (Option.map eval_tactic t) l l' ]
136		\| [ "firstorder" tactic_opt(t) ] ->
137		[ gen_ground_tac true (Option.map eval_tactic t) [] [] ]
138	136	END
139	137
140	138	TACTIC EXTEND gintuition

+1

-2

plugins/funind/functional_principles_proofs.ml less more

1370	1370	(* let ids = List.filter (fun id -> not (List.mem id ids)) ids' in *)
1371	1371	(* rewrite *)
1372	1372	(* ) *)
1373		Eauto.gen_eauto false (false,5) [] (Some [])
	1373	Eauto.gen_eauto (false,5) [] (Some [])
1374	1374	]
1375	1375	gls
1376	1376

1448	1448	(
1449	1449	tclCOMPLETE(
1450	1450	Eauto.eauto_with_bases
1451		false
1452	1451	(true,5)
1453	1452	[Evd.empty,Lazy.force refl_equal]
1454	1453	[Auto.Hint_db.empty empty_transparent_state false]

+1

-1

plugins/funind/g_indfun.ml4 less more

153	153	let (wit_function_rec_definition_loc : Genarg.tlevel function_rec_definition_loc_argtype),
154	154	(globwit_function_rec_definition_loc : Genarg.glevel function_rec_definition_loc_argtype),
155	155	(rawwit_function_rec_definition_loc : Genarg.rlevel function_rec_definition_loc_argtype) =
156		Genarg.create_arg "function_rec_definition_loc"
	156	Genarg.create_arg None "function_rec_definition_loc"
157	157	VERNAC COMMAND EXTEND Function
158	158	["Function" ne_function_rec_definition_loc_list_sep(recsl,"with")] ->
159	159	[

+24

-31

plugins/funind/invfun.ml less more

587	587	)
588	588	in
589	589	(tclFIRST
590		[ reflexivity;
591		tclTHEN (tclPROGRESS discr_inject) (destruct_case ());
	590	[ observe_tac "reflexivity_with_destruct_cases : reflexivity" reflexivity;
	591	observe_tac "reflexivity_with_destruct_cases : destruct_case" ((destruct_case ()));
592	592	(* We reach this point ONLY if
593	593	the same value is matched (at least) two times
594	594	along binding path.
595	595	In this case, either we have a discriminable hypothesis and we are done,
596	596	either at least an injectable one and we do the injection before continuing
597	597	*)
598		tclTHEN (tclPROGRESS discr_inject ) reflexivity_with_destruct_cases
	598	observe_tac "reflexivity_with_destruct_cases : others" (tclTHEN (tclPROGRESS discr_inject ) reflexivity_with_destruct_cases)
599	599	])
600	600	g
601	601

751	751	*)
752	752
753	753	let derive_correctness make_scheme functional_induction (funs: constant list) (graphs:inductive list) =
	754	let previous_state = States.freeze () in
754	755	let funs = Array.of_list funs and graphs = Array.of_list graphs in
755	756	let funs_constr = Array.map mkConst funs in
756	757	try

792	793	Array.iteri
793	794	(fun i f_as_constant ->
794	795	let f_id = id_of_label (con_label f_as_constant) in
795		Lemmas.start_proof
796		(*i The next call to mk_correct_id is valid since we are constructing the lemma
	796	(*i The next call to mk_correct_id is valid since we are constructing the lemma
797	797	Ensures by: obvious
798		i*)
799		(mk_correct_id f_id)
	798	i*)
	799	let lem_id = mk_correct_id f_id in
	800	Lemmas.start_proof lem_id
800	801	(Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem))
801	802	(fst lemmas_types_infos.(i))
802	803	(fun _ _ -> ());
803		Pfedit.by (observe_tac ("prove correctness ("^(string_of_id f_id)^")") (proving_tac i));
	804	Pfedit.by
	805	(observe_tac ("prove correctness ("^(string_of_id f_id)^")")
	806	(proving_tac i));
804	807	do_save ();
805	808	let finfo = find_Function_infos f_as_constant in
806		update_Function
807		{finfo with
808		correctness_lemma = Some (destConst (Constrintern.global_reference (mk_correct_id f_id)))
809		}
810
	809	let lem_cst = destConst (Constrintern.global_reference lem_id) in
	810	update_Function {finfo with correctness_lemma = Some lem_cst}
811	811	)
812	812	funs;
813	813	let lemmas_types_infos =

844	844	Array.iteri
845	845	(fun i f_as_constant ->
846	846	let f_id = id_of_label (con_label f_as_constant) in
847		Lemmas.start_proof
848		(*i The next call to mk_complete_id is valid since we are constructing the lemma
	847	(*i The next call to mk_complete_id is valid since we are constructing the lemma
849	848	Ensures by: obvious
850		i*)
851		(mk_complete_id f_id)
	849	i*)
	850	let lem_id = mk_complete_id f_id in
	851	Lemmas.start_proof lem_id
852	852	(Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem))
853	853	(fst lemmas_types_infos.(i))
854	854	(fun _ _ -> ());
855		Pfedit.by (observe_tac ("prove completeness ("^(string_of_id f_id)^")") (proving_tac i));
	855	Pfedit.by
	856	(observe_tac ("prove completeness ("^(string_of_id f_id)^")")
	857	(proving_tac i));
856	858	do_save ();
857	859	let finfo = find_Function_infos f_as_constant in
858		update_Function
859		{finfo with
860		completeness_lemma = Some (destConst (Constrintern.global_reference (mk_complete_id f_id)))
861		}
	860	let lem_cst = destConst (Constrintern.global_reference lem_id) in
	861	update_Function {finfo with completeness_lemma = Some lem_cst}
862	862	)
863	863	funs;
864	864	with e ->
865	865	(* In case of problem, we reset all the lemmas *)
866		(*i The next call to mk_correct_id is valid since we are erasing the lemmas
867		Ensures by: obvious
868		i*)
869		let first_lemma_id =
870		let f_id = id_of_label (con_label funs.(0)) in
871
872		mk_correct_id f_id
873		in
874		ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,first_lemma_id) with _ -> ());
	866	Pfedit.delete_all_proofs ();
	867	States.unfreeze previous_state;
875	868	raise e
876	869
877	870

+27

-15

plugins/funind/recdef.ml less more

47	47
48	48
49	49	let compute_renamed_type gls c =
50		rename_bound_vars_as_displayed [] (pf_type_of gls c)
	50	rename_bound_vars_as_displayed (no avoid) [] (no rels) []
	51	(pf_type_of gls c)
51	52
52	53	let qed () = Lemmas.save_named true
53	54	let defined () = Lemmas.save_named false

231	232	\| Rel(v) -> if v > nb_lam then error "find_call_occs : Rel" else ((fun l -> expr),[])
232	233	\| Var(_) when eq_constr expr f -> errorlabstrm "recdef" (str "Partial application of function " ++ Printer.pr_lconstr expr ++ str " in its body is not allowed while using Function")
233	234	\| Var(id) -> (fun l -> expr), []
234		\| Meta(_) -> error "find_call_occs : Meta"
235		\| Evar(_) -> error "find_call_occs : Evar"
	235	\| Meta(_) -> error "Found a metavariable. Can not treat such a term"
	236	\| Evar(_) -> error "Found an evar. Can not treat such a term"
236	237	\| Sort(_) -> (fun l -> expr), []
237	238	\| Cast(b,_,_) -> find_call_occs nb_arg nb_lam f b
238		\| Prod(_,_,_) -> error "find_call_occs : Prod"
	239	\| Prod(na,t,b) ->
	240	error "Found a product. Can not treat such a term"
239	241	\| Lambda(na,t,b) ->
240	242	begin
241	243	match find_call_occs nb_arg (succ nb_lam) f b with
242	244	\| _, [] -> (* Lambda are authorized as long as they do not contain
243	245	recursives calls *)
244	246	(fun l -> expr),[]
245		\| _ -> error "find_call_occs : Lambda"
	247	\| _ -> error "Found a lambda which body contains a recursive call. Such terms are not allowed"
246	248	end
247	249	\| LetIn(na,v,t,b) ->
248	250	begin

253	255	((fun l -> mkLetIn(na,v,t,cf l)),l)
254	256	\| (cf,(_::_ as l)),(_,[]) ->
255	257	((fun l -> mkLetIn(na,cf l,t,b)), l)
256		\| _ -> error "find_call_occs : LetIn"
	258	\| _ -> error "Found a letin with recursive calls in both variable value and body. Such terms are not allowed."
257	259	end
258	260	\| Const(_) -> (fun l -> expr), []
259	261	\| Ind(_) -> (fun l -> expr), []

262	264	(match find_call_occs nb_arg nb_lam f a with
263	265	cf, (arg1::args) -> (fun l -> mkCase(i, t, (cf l), r)),(arg1::args)
264	266	\| _ -> (fun l -> expr),[])
265		\| Fix(_) -> error "find_call_occs : Fix"
266		\| CoFix(_) -> error "find_call_occs : CoFix";;
	267	\| Fix(_) -> error "Found a local fixpoint. Can not treat such a term"
	268	\| CoFix(_) -> error "Found a local cofixpoint : CoFix";;
267	269
268	270	let coq_constant s =
269	271	Coqlib.gen_constant_in_modules "RecursiveDefinition"

895	897	let conj_constr = coq_conj () in
896	898	let mk_and p1 p2 =
897	899	Term.mkApp(and_constr,[\|p1;p2\|]) in
	900	let rec is_well_founded t =
	901	match kind_of_term t with
	902	\| Prod(_,_,t') -> is_well_founded t'
	903	\| App(_,_) ->
	904	let (f,_) = decompose_app t in
	905	eq_constr f (well_founded ())
	906	\| _ -> assert false
	907	in
	908	let compare t1 t2 =
	909	let b1,b2= is_well_founded t1,is_well_founded t2 in
	910	if (b1&&b2) \|\| not (b1 \|\| b2) then 0
	911	else if b1 && not b2 then 1 else -1
	912	in
	913	let l = List.sort compare l in
898	914	let rec f = function
899	915	\| [] -> failwith "empty list of subgoals!"
900	916	\| [p] -> p,tclIDTAC,1

1005	1021	(eapply_with_bindings (mkVar (List.nth !lid !h_num), NoBindings))
1006	1022	e_assumption;
1007	1023	Eauto.eauto_with_bases
1008		false
1009	1024	(true,5)
1010	1025	[Evd.empty,delayed_force refl_equal]
1011	1026	[Auto.Hint_db.empty empty_transparent_state false]

1377	1392
1378	1393	let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num eq
1379	1394	generate_induction_principle using_lemmas : unit =
	1395	let previous_label = Lib.current_command_label () in
1380	1396	let function_type = interp_constr Evd.empty (Global.env()) type_of_f in
1381	1397	let env = push_named (function_name,None,function_type) (Global.env()) in
1382	1398	(* Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type); *)

1428	1444	then pperrnl (str "Cannot create equation Lemma " ++ Errors.print e)
1429	1445	else anomaly "Cannot create equation Lemma"
1430	1446	;
1431		(* ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,functional_id) with _ -> ()); *)
1432	1447	stop := true;
1433	1448	end
1434	1449	end;

1460	1475	hook
1461	1476	with e ->
1462	1477	begin
1463		ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,functional_id) with _ -> ());
1464		(* anomaly "Cannot create termination Lemma" *)
	1478	(try ignore (Backtrack.backto previous_label) with _ -> ());
	1479	(* anomaly "Cannot create termination Lemma" *)
1465	1480	raise e
1466	1481	end
1467
1468
1469

+14

-5

plugins/micromega/coq_micromega.ml less more

894	894	let parse_expr parse_constant parse_exp ops_spec env term =
895	895	if debug
896	896	then (Pp.pp (Pp.str "parse_expr: ");
897		Pp.pp_flush ();Pp.pp (Printer.prterm term); Pp.pp_flush ());
	897	Pp.pp (Printer.prterm term);
	898	Pp.pp (Pp.str "\n");
	899	Pp.pp_flush ());
898	900
899	901	(*
900	902	let constant_or_variable env term =

990	992	else raise ParseError
991	993	\| App(op,args) ->
992	994	begin
993		try
994		(assoc_const op rconst_assoc) (rconstant args.(0)) (rconstant args.(1))
	995	try
	996	(* the evaluation order is important in the following *)
	997	let f = assoc_const op rconst_assoc in
	998	let a = rconstant args.(0) in
	999	let b = rconstant args.(1) in
	1000	f a b
995	1001	with
996	1002	ParseError ->
997	1003	match op with

1008	1014	if debug
1009	1015	then (Pp.pp_flush ();
1010	1016	Pp.pp (Pp.str "rconstant: ");
1011		Pp.pp (Printer.prterm term); Pp.pp_flush ());
	1017	Pp.pp (Printer.prterm term);
	1018	Pp.pp (Pp.str "\n");
	1019	Pp.pp_flush ());
1012	1020	let res = rconstant term in
1013	1021	if debug then
1014		(Printf.printf "rconstant -> %a" pp_Rcst res ; flush stdout) ;
	1022	(Printf.printf "rconstant -> %a\n" pp_Rcst res ; flush stdout) ;
1015	1023	res
1016	1024
1017	1025

1051	1059	then (Pp.pp_flush ();
1052	1060	Pp.pp (Pp.str "parse_arith: ");
1053	1061	Pp.pp (Printer.prterm cstr);
	1062	Pp.pp (Pp.str "\n");
1054	1063	Pp.pp_flush ());
1055	1064	match kind_of_term cstr with
1056	1065	\| App(op,args) ->

+1

-1

plugins/nsatz/nsatz.ml4 less more

473	473	done;
474	474	!lcr)
475	475	lr in
476		info ("unuseful spolynomials: "
	476	info ("useless spolynomials: "
477	477	^string_of_int (m-List.length lr)^"\n");
478	478	info ("useful spolynomials: "
479	479	^string_of_int (List.length lr)^"\n");

+0

-1

plugins/pluginsbyte.itarget less more

7	7	romega/romega_plugin.cma
8	8	omega/omega_plugin.cma
9	9	micromega/micromega_plugin.cma
10		dp/dp_plugin.cma
11	10	xml/xml_plugin.cma
12	11	subtac/subtac_plugin.cma
13	12	ring/ring_plugin.cma

+0

-1

plugins/pluginsdyn.itarget less more

7	7	romega/romega_plugin.cmxs
8	8	omega/omega_plugin.cmxs
9	9	micromega/micromega_plugin.cmxs
10		dp/dp_plugin.cmxs
11	10	xml/xml_plugin.cmxs
12	11	subtac/subtac_plugin.cmxs
13	12	ring/ring_plugin.cmxs

+0

-1

plugins/pluginsopt.itarget less more

7	7	romega/romega_plugin.cmxa
8	8	omega/omega_plugin.cmxa
9	9	micromega/micromega_plugin.cmxa
10		dp/dp_plugin.cmxa
11	10	xml/xml_plugin.cmxa
12	11	subtac/subtac_plugin.cmxa
13	12	ring/ring_plugin.cmxa

+1

-2

plugins/pluginsvo.itarget less more

0		dp/vo.otarget
1	0	field/vo.otarget
2	1	fourier/vo.otarget
3	2	funind/vo.otarget

9	8	romega/vo.otarget
10	9	rtauto/vo.otarget
11	10	setoid_ring/vo.otarget
12		extraction/vo.otarget⏎
	11	extraction/vo.otarget

+2

-2

plugins/rtauto/proof_search.ml less more

508	508
509	509	let pp =
510	510	function
511		Incomplete(gl,ctx) -> msgnl (pp_gl gl)
512		\| _ -> msg (str "<complete>")
	511	Incomplete(gl,ctx) -> pp_gl gl ++ fnl ()
	512	\| _ -> str "<complete>"
513	513
514	514	let pp_info () =
515	515	let count_info =

+1

-1

plugins/rtauto/proof_search.mli less more

37	37
38	38	val success: state -> bool
39	39
40		val pp: state -> unit
	40	val pp: state -> Pp.std_ppcmds
41	41
42	42	val pr_form : form -> unit
43	43

+14

-3

plugins/subtac/eterm.ml less more

131	131	\| Prod (_, _, b) -> if noccurn 1 b then chop_product (pred n) (Termops.pop b) else None
132	132	\| _ -> None
133	133
134		let evar_dependencies evm ev =
	134	let evars_of_evar_info evi =
	135	Intset.union (Evarutil.evars_of_term evi.evar_concl)
	136	(Intset.union
	137	(match evi.evar_body with
	138	\| Evar_empty -> Intset.empty
	139	\| Evar_defined b -> Evarutil.evars_of_term b)
	140	(Evarutil.evars_of_named_context (evar_filtered_context evi)))
	141
	142	let evar_dependencies evm oev =
135	143	let one_step deps =
136	144	Intset.fold (fun ev s ->
137	145	let evi = Evd.find evm ev in
138		Intset.union (Evarutil.evars_of_evar_info evi) s)
	146	let deps' = evars_of_evar_info evi in
	147	if Intset.mem oev deps' then
	148	raise (Invalid_argument ("Ill-formed evar map: cycle detected for evar " ^ string_of_int oev))
	149	else Intset.union deps' s)
139	150	deps deps
140	151	in
141	152	let rec aux deps =
142	153	let deps' = one_step deps in
143	154	if Intset.equal deps deps' then deps
144	155	else aux deps'
145		in aux (Intset.singleton ev)
	156	in aux (Intset.singleton oev)
146	157
147	158	let move_after (id, ev, deps as obl) l =
148	159	let rec aux restdeps = function

+2

-2

plugins/subtac/g_subtac.ml4 less more

74	74	let (wit_subtac_gallina_loc : Genarg.tlevel gallina_loc_argtype),
75	75	(globwit_subtac_gallina_loc : Genarg.glevel gallina_loc_argtype),
76	76	(rawwit_subtac_gallina_loc : Genarg.rlevel gallina_loc_argtype) =
77		Genarg.create_arg "subtac_gallina_loc"
	77	Genarg.create_arg None "subtac_gallina_loc"
78	78
79	79	type 'a withtac_argtype = (Tacexpr.raw_tactic_expr option, 'a) Genarg.abstract_argument_type
80	80
81	81	let (wit_subtac_withtac : Genarg.tlevel withtac_argtype),
82	82	(globwit_subtac_withtac : Genarg.glevel withtac_argtype),
83	83	(rawwit_subtac_withtac : Genarg.rlevel withtac_argtype) =
84		Genarg.create_arg "subtac_withtac"
	84	Genarg.create_arg None "subtac_withtac"
85	85
86	86	VERNAC COMMAND EXTEND Subtac
87	87	[ "Program" subtac_gallina_loc(g) ] -> [ Subtac.subtac g ]

+1

-3

plugins/subtac/subtac.ml less more

81	81	Impargs.declare_manual_implicits (loc = Local) gr ~enriching:true [imps];
82	82	hook loc gr)
83	83
84		let print_subgoals () = Flags.if_verbose (fun () -> msg (Printer.pr_open_subgoals ())) ()
85
86	84	let start_proof_and_print env isevars idopt k t hook =
87	85	start_proof_com env isevars idopt k t hook;
88		print_subgoals ()
	86	Vernacentries.print_subgoals ()
89	87
90	88	let _ = Detyping.set_detype_anonymous (fun loc n -> GVar (loc, id_of_string ("Anonymous_REL_" ^ string_of_int n)))
91	89

+1

-1

plugins/subtac/subtac_cases.ml less more

1844	1844	refl_arg :: refl_args,
1845	1845	pred slift,
1846	1846	(Name id, b, t) :: argsign'))
1847		(env, 0, [], [], slift, []) args argsign
	1847	(env, neqs, [], [], slift, []) args argsign
1848	1848	in
1849	1849	let eq = mk_JMeq
1850	1850	(lift (nargeqs + slift) appt)

+6

-3

plugins/subtac/subtac_classes.ml less more

51	51	\| None -> interp_casted_constr_evars evars env (List.hd l) t', List.tl l
52	52	\| Some b -> substl subst b, l
53	53	in
54		evars := resolve_typeclasses ~onlyargs:true ~fail:true env !evars;
	54	evars := resolve_typeclasses ~filter:Subtac_utils.no_goals_or_obligations ~fail:true env !evars;
55	55	let d = na, Some c', t' in
56	56	aux (c' :: subst, d :: instctx) l ctx
57	57	\| [] -> subst

106	106	let i = Nameops.add_suffix (Classes.id_of_class k) "_instance_0" in
107	107	Namegen.next_global_ident_away i (Termops.ids_of_context env)
108	108	in
	109	evars := resolve_typeclasses ~filter:Subtac_utils.no_goals_or_obligations ~fail:true env !evars;
	110	let ctx = Evarutil.nf_rel_context_evar !evars ctx
	111	and ctx' = Evarutil.nf_rel_context_evar !evars ctx' in
109	112	let env' = push_rel_context ctx env in
110		evars := Evarutil.nf_evar_map !evars;
111		evars := resolve_typeclasses ~onlyargs:false ~fail:true env !evars;
112	113	let sigma = !evars in
113	114	let subst = List.map (Evarutil.nf_evar sigma) subst in
114	115	let props =

156	157	Inl (type_ctx_instance evars (push_rel_context ctx' env') k.cl_props props subst)
157	158	in
158	159	evars := Evarutil.nf_evar_map !evars;
	160	evars := resolve_typeclasses ~filter:Subtac_utils.no_goals_or_obligations ~fail:true env !evars;
	161	evars := resolve_typeclasses ~filter:Typeclasses.no_goals ~fail:false env !evars;
159	162	let term, termtype =
160	163	match subst with
161	164	\| Inl subst ->

+59

-48

plugins/subtac/subtac_coercion.ml less more

26	26	open Eterm
27	27	open Pp
28	28
	29	let app_opt env evars f t =
	30	whd_betaiota !evars (app_opt f t)
	31
29	32	let pair_of_array a = (a.(0), a.(1))
30	33	let make_name s = Name (id_of_string s)
31	34

79	82	\| Type _, Prop Null -> Prop Null
80	83	\| _, Type _ -> s2
81	84
82		let hnf env isevars c = whd_betadeltaiota env ( !isevars) c
	85	let hnf env isevars c = whd_betadeltaiota env isevars c
	86	let hnf_nodelta env evars c = whd_betaiota evars c
83	87
84	88	let lift_args n sign =
85	89	let rec liftrec k = function

89	93	liftrec (List.length sign) sign
90	94
91	95	let rec mu env isevars t =
92		let isevars = ref isevars in
93	96	let rec aux v =
94		let v = hnf env isevars v in
	97	let v = hnf env !isevars v in
95	98	match disc_subset v with
96	99	Some (u, p) ->
97	100	let f, ct = aux u in
	101	let p = hnf env !isevars p in
98	102	(Some (fun x ->
99		app_opt f (mkApp ((delayed_force sig_).proj1,
100		[\| u; p; x \|]))),
	103	app_opt env isevars
	104	f (mkApp ((delayed_force sig_).proj1,
	105	[\| u; p; x \|]))),
101	106	ct)
102	107	\| None -> (None, v)
103	108	in aux t

105	110	and coerce loc env isevars (x : Term.constr) (y : Term.constr)
106	111	: (Term.constr -> Term.constr) option
107	112	=
108		let x = nf_evar ( !isevars) x and y = nf_evar ( !isevars) y in
109	113	let rec coerce_unify env x y =
110		let x = hnf env isevars x and y = hnf env isevars y in
	114	let x = hnf env !isevars x and y = hnf env !isevars y in
111	115	try
112	116	isevars := the_conv_x_leq env x y !isevars;
113	117	None

166	170	let env' = push_rel (name', None, a') env in
167	171	let c1 = coerce_unify env' (lift 1 a') (lift 1 a) in
168	172	(* env, x : a' \|- c1 : lift 1 a' > lift 1 a *)
169		let coec1 = app_opt c1 (mkRel 1) in
	173	let coec1 = app_opt env' isevars c1 (mkRel 1) in
170	174	(* env, x : a' \|- c1[x] : lift 1 a *)
171	175	let c2 = coerce_unify env' (subst1 coec1 (liftn 1 2 b)) b' in
172	176	(* env, x : a' \|- c2 : b[c1[x]/x]] > b' *)

176	180	Some
177	181	(fun f ->
178	182	mkLambda (name', a',
179		app_opt c2
	183	app_opt env' isevars c2
180	184	(mkApp (Term.lift 1 f, [\| coec1 \|])))))
181	185
182	186	\| App (c, l), App (c', l') ->

219	223	Some
220	224	(fun x ->
221	225	let x, y =
222		app_opt c1 (mkApp (existS.proj1,
	226	app_opt env' isevars c1 (mkApp (existS.proj1,
223	227	[\| a; pb; x \|])),
224		app_opt c2 (mkApp (existS.proj2,
	228	app_opt env' isevars c2 (mkApp (existS.proj2,
225	229	[\| a; pb; x \|]))
226	230	in
227	231	mkApp (existS.intro, [\| a'; pb'; x ; y \|]))

239	243	Some
240	244	(fun x ->
241	245	let x, y =
242		app_opt c1 (mkApp (prod.proj1,
	246	app_opt env isevars c1 (mkApp (prod.proj1,
243	247	[\| a; b; x \|])),
244		app_opt c2 (mkApp (prod.proj2,
	248	app_opt env isevars c2 (mkApp (prod.proj2,
245	249	[\| a; b; x \|]))
246	250	in
247	251	mkApp (prod.intro, [\| a'; b'; x ; y \|]))

275	279	Some (u, p) ->
276	280	let c = coerce_unify env u y in
277	281	let f x =
278		app_opt c (mkApp ((delayed_force sig_).proj1,
	282	app_opt env isevars c (mkApp ((delayed_force sig_).proj1,
279	283	[\| u; p; x \|]))
280	284	in Some f
281	285	\| None ->

284	288	let c = coerce_unify env x u in
285	289	Some
286	290	(fun x ->
287		let cx = app_opt c x in
	291	let cx = app_opt env isevars c x in
288	292	let evar = make_existential loc env isevars (mkApp (p, [\| cx \|]))
289	293	in
290	294	(mkApp

299	303	let coerce_itf loc env isevars v t c1 =
300	304	let evars = ref isevars in
301	305	let coercion = coerce loc env evars t c1 in
302		!evars, Option.map (app_opt coercion) v
	306	let t = Option.map (app_opt env evars coercion) v in
	307	!evars, t
303	308
304	309	(* Taken from pretyping/coercion.ml *)
305	310

353	358	with _ -> anomaly "apply_coercion"
354	359
355	360	let inh_app_fun env isevars j =
356		let t = whd_betadeltaiota env ( isevars) j.uj_type in
	361	let isevars = ref isevars in
	362	let t = hnf env !isevars j.uj_type in
357	363	match kind_of_term t with
358		\| Prod (_,_,_) -> (isevars,j)
359		\| Evar ev when not (is_defined_evar isevars ev) ->
360		let (isevars',t) = define_evar_as_product isevars ev in
	364	\| Prod (_,_,_) -> (!isevars,j)
	365	\| Evar ev when not (is_defined_evar !isevars ev) ->
	366	let (isevars',t) = define_evar_as_product !isevars ev in
361	367	(isevars',{ uj_val = j.uj_val; uj_type = t })
362	368	\| _ ->
363	369	(try
364	370	let t,p =
365		lookup_path_to_fun_from env ( isevars) j.uj_type in
366		(isevars,apply_coercion env ( isevars) p j t)
	371	lookup_path_to_fun_from env !isevars j.uj_type in
	372	(!isevars,apply_coercion env !isevars p j t)
367	373	with Not_found ->
368	374	try
369	375	let coercef, t = mu env isevars t in
370		(isevars, { uj_val = app_opt coercef j.uj_val; uj_type = t })
	376	let res = { uj_val = app_opt env isevars coercef j.uj_val; uj_type = t } in
	377	(!isevars, res)
371	378	with NoSubtacCoercion \| NoCoercion ->
372		(isevars,j))
	379	(!isevars,j))
373	380
374	381	let inh_tosort_force loc env isevars j =
375	382	try
376	383	let t,p = lookup_path_to_sort_from env ( isevars) j.uj_type in
377	384	let j1 = apply_coercion env ( isevars) p j t in
378		(isevars,type_judgment env (j_nf_evar ( isevars) j1))
	385	(isevars, type_judgment env (j_nf_evar ( isevars) j1))
379	386	with Not_found ->
380	387	error_not_a_type_loc loc env ( isevars) j
381	388
382	389	let inh_coerce_to_sort loc env isevars j =
383		let typ = whd_betadeltaiota env ( isevars) j.uj_type in
	390	let typ = hnf env isevars j.uj_type in
384	391	match kind_of_term typ with
385	392	\| Sort s -> (isevars,{ utj_val = j.uj_val; utj_type = s })
386	393	\| Evar ev when not (is_defined_evar isevars ev) ->

390	397	inh_tosort_force loc env isevars j
391	398
392	399	let inh_coerce_to_base loc env isevars j =
393		let typ = whd_betadeltaiota env ( isevars) j.uj_type in
	400	let isevars = ref isevars in
	401	let typ = hnf env !isevars j.uj_type in
394	402	let ct, typ' = mu env isevars typ in
395		isevars, { uj_val = app_opt ct j.uj_val;
396		uj_type = typ' }
	403	let res =
	404	{ uj_val = app_opt env isevars ct j.uj_val;
	405	uj_type = typ' }
	406	in !isevars, res
397	407
398	408	let inh_coerce_to_prod loc env isevars t =
399		let typ = whd_betadeltaiota env ( isevars) (snd t) in
	409	let isevars = ref isevars in
	410	let typ = hnf env !isevars (snd t) in
400	411	let _, typ' = mu env isevars typ in
401		isevars, (fst t, typ')
	412	!isevars, (fst t, typ')
402	413
403	414	let inh_coerce_to_fail env evd rigidonly v t c1 =
404	415	if rigidonly & not (Heads.is_rigid env c1 && Heads.is_rigid env t)

451	462	(* Look for cj' obtained from cj by inserting coercions, s.t. cj'.typ = t *)
452	463	let inh_conv_coerce_to_gen rigidonly loc env evd cj ((n, t) as _tycon) =
453	464	match n with
454		None ->
455		let (evd', val') =
456		try
457		inh_conv_coerce_to_fail loc env evd rigidonly
458		(Some (nf_evar evd cj.uj_val))
459		(nf_evar evd cj.uj_type) (nf_evar evd t)
460		with NoCoercion ->
461		let sigma = evd in
462		try
463		coerce_itf loc env evd (Some cj.uj_val) cj.uj_type t
464		with NoSubtacCoercion ->
465		error_actual_type_loc loc env sigma cj t
466		in
467		let val' = match val' with Some v -> v \| None -> assert(false) in
468		(evd',{ uj_val = val'; uj_type = t })
469		\| Some (init, cur) ->
470		(evd, cj)
	465	\| None ->
	466	let cj = { cj with uj_type = hnf_nodelta env evd cj.uj_type }
	467	and t = hnf_nodelta env evd t in
	468	let (evd', val') =
	469	try
	470	inh_conv_coerce_to_fail loc env evd rigidonly
	471	(Some cj.uj_val) cj.uj_type t
	472	with NoCoercion ->
	473	(try
	474	coerce_itf loc env evd (Some cj.uj_val) cj.uj_type t
	475	with NoSubtacCoercion ->
	476	error_actual_type_loc loc env evd cj t)
	477	in
	478	let val' = match val' with Some v -> v \| None -> assert(false) in
	479	(evd',{ uj_val = val'; uj_type = t })
	480	\| Some (init, cur) ->
	481	(evd, cj)
471	482
472	483	let inh_conv_coerce_to = inh_conv_coerce_to_gen false
473	484	let inh_conv_coerce_rigid_to = inh_conv_coerce_to_gen true

+1

-1

plugins/subtac/subtac_command.ml less more

457	457	(* Instantiate evars and check all are resolved *)
458	458	let evd = Evarconv.consider_remaining_unif_problems env_rec !evdref in
459	459	let evd = Typeclasses.resolve_typeclasses
460		~onlyargs:true ~split:true ~fail:false env_rec evd
	460	~filter:Typeclasses.no_goals ~split:true ~fail:false env_rec evd
461	461	in
462	462	let evd = Evarutil.nf_evar_map evd in
463	463	let fixdefs = List.map (nf_evar evd) fixdefs in

+15

-10

plugins/subtac/subtac_obligations.ml less more

444	444	else x :: acc)
445	445	deps []
446	446
447		let has_dependencies obls n =
448		let res = ref false in
	447	let dependencies obls n =
	448	let res = ref Intset.empty in
449	449	Array.iteri
450	450	(fun i obl ->
451	451	if i <> n && Intset.mem n obl.obl_deps then
452		res := true)
	452	res := Intset.add i !res)
453	453	obls;
454	454	!res
455	455

501	501	in
502	502	match res with
503	503	\| Remain n when n > 0 ->
504		if has_dependencies obls num then
505		ignore(auto_solve_obligations (Some prg.prg_name) None)
	504	let deps = dependencies obls num in
	505	if deps <> Intset.empty then
	506	ignore(auto_solve_obligations (Some prg.prg_name) None ~oblset:deps)
506	507	\| _ -> ());
507	508	trace (str "Started obligation " ++ int user_num ++ str " proof: " ++
508	509	Subtac_utils.my_print_constr (Global.env ()) obl.obl_type);

552	553	\| Util.Anomaly _ as e -> raise e
553	554	\| e -> false
554	555
555		and solve_prg_obligations prg tac =
	556	and solve_prg_obligations prg ?oblset tac =
556	557	let obls, rem = prg.prg_obligations in
557	558	let rem = ref rem in
558	559	let obls' = Array.copy obls in
	560	let p = match oblset with
	561	\| None -> (fun _ -> true)
	562	\| Some s -> (fun i -> Intset.mem i s)
	563	in
559	564	let _ =
560	565	Array.iteri (fun i x ->
561		if solve_obligation_by_tac prg obls' i tac then
562		decr rem)
	566	if p i && solve_obligation_by_tac prg obls' i tac then
	567	decr rem)
563	568	obls'
564	569	in
565	570	update_obls prg obls' !rem

581	586	and try_solve_obligations n tac =
582	587	try ignore (solve_obligations n tac) with NoObligations _ -> ()
583	588
584		and auto_solve_obligations n tac : progress =
	589	and auto_solve_obligations n ?oblset tac : progress =
585	590	Flags.if_verbose msgnl (str "Solving obligations automatically...");
586		try solve_prg_obligations (get_prog_err n) tac with NoObligations _ -> Dependent
	591	try solve_prg_obligations (get_prog_err n) ?oblset tac with NoObligations _ -> Dependent
587	592
588	593	open Pp
589	594	let show_obligations_of_prg ?(msg=true) prg =

+2

-2

plugins/subtac/subtac_pretyping.ml less more

66	66	let _ = isevars := Evarutil.nf_evar_map !isevars in
67	67	let evd = consider_remaining_unif_problems env !isevars in
68	68	(* let unevd = undefined_evars evd in *)
69		let unevd' = Typeclasses.resolve_typeclasses ~onlyargs:true ~split:true ~fail:true env evd in
70		let unevd' = Typeclasses.resolve_typeclasses ~onlyargs:false ~split:true ~fail:false env unevd' in
	69	let unevd' = Typeclasses.resolve_typeclasses ~filter:Subtac_utils.no_goals_or_obligations ~split:true ~fail:true env evd in
	70	let unevd' = Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars ~split:true ~fail:false env unevd' in
71	71	let evm = unevd' in
72	72	isevars := unevd';
73	73	nf_evar evm j.uj_val, nf_evar evm j.uj_type

+15

-18

plugins/subtac/subtac_pretyping_F.ml less more

87	87
88	88	(* coerce to tycon if any *)
89	89	let inh_conv_coerce_to_tycon loc env evdref j = function
90		\| None -> j_nf_evar !evdref j
	90	\| None -> j
91	91	\| Some t -> evd_comb2 (Coercion.inh_conv_coerce_to loc env) evdref j t
92	92
93	93	let push_rels vars env = List.fold_right push_rel vars env

322	322	else tycon
323	323	in
324	324	match ty with
325		\| Some (_, t) when Subtac_coercion.disc_subset t = None -> ty
	325	\| Some (_, t) ->
	326	if Subtac_coercion.disc_subset (whd_betadeltaiota env !evdref t) = None then ty
	327	else None
326	328	\| _ -> None
327	329	in
328	330	let fj = pretype ftycon env evdref lvar f in

339	341	Coercion.inh_conv_coerces_to loc env !evdref resty ty) tycon;
340	342	let evd, (_, _, tycon) = split_tycon loc env !evdref tycon in
341	343	evdref := evd;
342		let hj = pretype (mk_tycon (nf_evar !evdref c1)) env evdref lvar c in
	344	let hj = pretype (mk_tycon c1) env evdref lvar c in
343	345	let value, typ = applist (j_val resj, [j_val hj]), subst1 hj.uj_val c2 in
344		let typ' = nf_evar !evdref typ in
345	346	apply_rec env (n+1)
346		{ uj_val = nf_evar !evdref value;
347		uj_type = nf_evar !evdref typ' }
348		(Option.map (fun (abs, c) -> abs, nf_evar !evdref c) tycon) rest
	347	{ uj_val = value;
	348	uj_type = typ }
	349	(Option.map (fun (abs, c) -> abs, c) tycon) rest
349	350
350	351	\| _ ->
351	352	let hj = pretype empty_tycon env evdref lvar c in

353	354	(join_loc floc argloc) env !evdref
354	355	resj [hj]
355	356	in
356		let resj = j_nf_evar !evdref (apply_rec env 1 fj ftycon args) in
	357	let resj = apply_rec env 1 fj ftycon args in
357	358	let resj =
358		match kind_of_term resj.uj_val with
	359	match kind_of_term (whd_evar !evdref resj.uj_val) with
359	360	\| App (f,args) when isInd f or isConst f ->
360	361	let sigma = !evdref in
361	362	let c = mkApp (f,Array.map (whd_evar sigma) args) in

507	508	it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in
508	509	let pred = nf_evar !evdref pred in
509	510	let p = nf_evar !evdref p in
510		(* msgnl (str "Pred is: " ++ Termops.print_constr_env env pred);*)
511	511	let f cs b =
512	512	let n = rel_context_length cs.cs_args in
513		let pi = lift n pred in (* liftn n 2 pred ? *)
	513	let pi = lift n pred in
514	514	let pi = beta_applist (pi, [build_dependent_constructor cs]) in
515	515	let csgn =
516	516	if not !allow_anonymous_refs then

524	524	cs.cs_args
525	525	in
526	526	let env_c = push_rels csgn env in
527		(* msgnl (str "Pi is: " ++ Termops.print_constr_env env_c pi); *)
528	527	let bj = pretype (mk_tycon pi) env_c evdref lvar b in
529	528	it_mkLambda_or_LetIn bj.uj_val cs.cs_args in
530	529	let b1 = f cstrs.(0) b1 in

550	549	\| CastConv (k,t) ->
551	550	let tj = pretype_type empty_valcon env evdref lvar t in
552	551	let cj = pretype (mk_tycon tj.utj_val) env evdref lvar c in
553		(* User Casts are for helping pretyping, experimentally not to be kept*)
554		(* ... except for Correctness *)
555	552	let v = mkCast (cj.uj_val, k, tj.utj_val) in
556	553	{ uj_val = v; uj_type = tj.utj_val }
557	554	in

599	596	in
600	597	if resolve_classes then
601	598	(try
602		evdref := Typeclasses.resolve_typeclasses ~onlyargs:true
	599	evdref := Typeclasses.resolve_typeclasses ~filter:Subtac_utils.no_goals_or_obligations
603	600	~split:true ~fail:true env !evdref;
604		evdref := Typeclasses.resolve_typeclasses ~onlyargs:false
	601	evdref := Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars
605	602	~split:true ~fail:false env !evdref
606	603	with e -> if fail_evar then raise e else ());
607	604	evdref := consider_remaining_unif_problems env !evdref;

646	643	let understand_type sigma env c =
647	644	snd (ise_pretype_gen true false true sigma env ([],[]) IsType c)
648	645
649		let understand_ltac expand_evar sigma env lvar kind c =
650		ise_pretype_gen expand_evar false true sigma env lvar kind c
	646	let understand_ltac ?(resolve_classes=false) expand_evar sigma env lvar kind c =
	647	ise_pretype_gen expand_evar false resolve_classes sigma env lvar kind c
651	648
652	649	let understand_tcc ?(resolve_classes=true) sigma env ?expected_type:exptyp c =
653	650	ise_pretype_gen true false resolve_classes sigma env ([],[]) (OfType exptyp) c

+5

-6

plugins/subtac/subtac_utils.ml less more

160	160	Array.fold_right (fun a acc -> my_print_constr env a ++ spc () ++ acc) args (str "")
161	161
162	162	let make_existential loc ?(opaque = Define true) env isevars c =
163		let evar = Evarutil.e_new_evar isevars env ~src:(loc, QuestionMark opaque) c in
164		let (key, args) = destEvar evar in
165		(try trace (str "Constructed evar " ++ int key ++ str " applied to args: " ++
166		print_args env args ++ str " for type: "++
167		my_print_constr env c) with _ -> ());
168		evar
	163	Evarutil.e_new_evar isevars env ~src:(loc, QuestionMark opaque) c
	164
	165	let no_goals_or_obligations = function
	166	\| GoalEvar \| QuestionMark _ -> false
	167	\| _ -> true
169	168
170	169	let make_existential_expr loc env c =
171	170	let key = Evarutil.new_untyped_evar () in

+1

-0

plugins/subtac/subtac_utils.mli less more

81	81	val print_args : env -> constr array -> std_ppcmds
82	82	val make_existential : loc -> ?opaque:obligation_definition_status ->
83	83	env -> evar_map ref -> types -> constr
	84	val no_goals_or_obligations : Typeclasses.evar_filter
84	85	val make_existential_expr : loc -> 'a -> 'b -> constr_expr
85	86	val string_of_hole_kind : hole_kind -> string
86	87	val evars_of_term : evar_map -> evar_map -> constr -> evar_map

+2

-2

plugins/xml/dumptree.ml4 less more

106	106
107	107	let pr_subgoal_metas_xml metas env=
108	108	let pr_one (meta, typ) =
109		fnl () ++ str "<meta index=\"" ++ int meta ++ str " type=\"" ++ xmlstream (pr_ltype_env_at_top env typ) ++
	109	fnl () ++ str "<meta index=\"" ++ int meta ++ str " type=\"" ++ xmlstream (pr_goal_concl_style_env env typ) ++
110	110	str "\"/>"
111	111	in
112	112	List.fold_left (++) (mt ()) (List.map pr_one metas)

116	116	let env = try Goal.V82.unfiltered_env sigma g with _ -> empty_env in
117	117	if Decl_mode.try_get_info sigma g = None then
118	118	(hov 2 (str "<goal>" ++ fnl () ++ str "<concl type=\"" ++
119		xmlstream (pr_ltype_env_at_top env (Goal.V82.concl sigma g)) ++
	119	xmlstream (pr_goal_concl_style_env env (Goal.V82.concl sigma g)) ++
120	120	str "\"/>" ++
121	121	(pr_context_xml env)) ++
122	122	fnl () ++ str "</goal>")

+3

-2

pretyping/cases.ml less more

76	76	\| [] -> anomaly "try_find_f"
77	77	\| h::t ->
78	78	try f h
79		with UserError _ \| TypeError _ \| PretypeError _
80		\| Loc.Exc_located (_,(UserError _ \| TypeError _ \| PretypeError _)) ->
	79	with UserError _ \| TypeError _ \| PretypeError _ \| PatternMatchingError _
	80	\| Loc.Exc_located
	81	(_, (UserError _ \| TypeError _ \| PretypeError _ \| PatternMatchingError _)) ->
81	82	list_try_compile f t
82	83
83	84	let force_name =

+1

-1

pretyping/coercion.ml less more

109	109
110	110	let saturate_evd env evd =
111	111	Typeclasses.resolve_typeclasses
112		~onlyargs:true ~split:true ~fail:false env evd
	112	~filter:Typeclasses.no_goals ~split:true ~fail:false env evd
113	113
114	114	(* appliquer le chemin de coercions p à hj *)
115	115	let apply_coercion env sigma p hj typ_cl =

+5

-3

pretyping/detyping.ml less more

531	531	buildrec [] [] avoid env construct_nargs branch
532	532
533	533	and detype_binder isgoal bk avoid env na ty c =
534		let flag = if isgoal then RenamingForGoal else (RenamingElsewhereFor c) in
	534	let flag = if isgoal then RenamingForGoal else RenamingElsewhereFor (env,c) in
535	535	let na',avoid' =
536	536	if bk = BLetIn then compute_displayed_let_name_in flag avoid na c
537	537	else compute_displayed_name_in flag avoid na c in

551	551	\| None -> na,avoid
552	552	\| Some c ->
553	553	if b<>None then
554		compute_displayed_let_name_in (RenamingElsewhereFor c) avoid na c
	554	compute_displayed_let_name_in
	555	(RenamingElsewhereFor (env,c)) avoid na c
555	556	else
556		compute_displayed_name_in (RenamingElsewhereFor c) avoid na c in
	557	compute_displayed_name_in
	558	(RenamingElsewhereFor (env,c)) avoid na c in
557	559	let b = Option.map (detype false avoid env) b in
558	560	let t = detype false avoid env t in
559	561	(na',Explicit,b,t) :: aux avoid' (add_name na' env) rest

+89

-30

pretyping/evarconv.ml less more

194	194	evar_eqappr_x ts env evd pbty
195	195	(decompose_app term1) (decompose_app term2)
196	196
197		and evar_eqappr_x ?(rhs_is_stuck_proj = false)
	197	and evar_eqappr_x ?(rhs_is_already_stuck = false)
198	198	ts env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) =
199	199	(* Evar must be undefined since we have flushed evars *)
200	200	match (flex_kind_of_term term1 l1, flex_kind_of_term term2 l2) with

323	323	(* heuristic: unfold second argument first, exception made
324	324	if the first argument is a beta-redex (expand a constant
325	325	only if necessary) or the second argument is potentially
326		usable as a canonical projection *)
327		let rhs_is_stuck_proj =
328		rhs_is_stuck_proj \|\| is_open_canonical_projection env i appr2 in
329		if isLambda flex1 \|\| rhs_is_stuck_proj then
	326	usable as a canonical projection or canonical value *)
	327	let rec is_unnamed (hd, args) = match kind_of_term hd with
	328	\| (Var _\|Construct _\|Ind _\|Const _\|Prod _\|Sort _) -> false
	329	\| (Case _\|Fix _\|CoFix _\|Meta _\|Rel _)-> true
	330	\| Evar _ -> false (* immediate solution without Canon Struct *)
	331	\| Lambda _ -> assert(args = []); true
	332	\| LetIn (_,b,_,c) ->
	333	is_unnamed (evar_apprec ts env i args (subst1 b c))
	334	\| App _\| Cast _ -> assert false in
	335	let rhs_is_stuck_and_unnamed () =
	336	match eval_flexible_term ts env flex2 with
	337	\| None -> false
	338	\| Some v2 -> is_unnamed (evar_apprec ts env i l2 v2) in
	339	let rhs_is_already_stuck =
	340	rhs_is_already_stuck \|\| rhs_is_stuck_and_unnamed () in
	341	if isLambda flex1 \|\| rhs_is_already_stuck then
330	342	match eval_flexible_term ts env flex1 with
331	343	\| Some v1 ->
332		evar_eqappr_x ~rhs_is_stuck_proj
	344	evar_eqappr_x ~rhs_is_already_stuck
333	345	ts env i pbty (evar_apprec ts env i l1 v1) appr2
334	346	\| None ->
335	347	match eval_flexible_term ts env flex2 with

543	555	(fun i -> evar_conv_x trs env i CONV c1 (applist (c,(List.rev ks))));
544	556	(fun i -> ise_list2 i (fun i -> evar_conv_x trs env i CONV) ts ts1)]
545	557
546		(* getting rid of the optional argument rhs_is_stuck_proj *)
	558	(* getting rid of the optional argument rhs_is_already_stuck *)
547	559	let evar_eqappr_x ts env evd pbty appr1 appr2 =
548	560	evar_eqappr_x ts env evd pbty appr1 appr2
549	561

581	593	in
582	594	applyrec (0,c) t
583	595
584		let filter_possible_projections c args =
	596	let filter_possible_projections c ty ctxt args =
585	597	let fv1 = free_rels c in
586	598	let fv2 = collect_vars c in
587		List.map (fun a ->
	599	let tyvars = collect_vars ty in
	600	List.map2 (fun (id,_,_) a ->
588	601	a == c \|\|
589	602	(* Here we make an approximation, for instance, we could also be *)
590	603	(* interested in finding a term u convertible to c such that a occurs *)
591	604	(* in u *)
592	605	isRel a && Intset.mem (destRel a) fv1 \|\|
593		isVar a && Idset.mem (destVar a) fv2)
594		args
	606	isVar a && Idset.mem (destVar a) fv2 \|\|
	607	Idset.mem id tyvars)
	608	ctxt args
595	609
596	610	let initial_evar_data evi =
597	611	let ids = List.map pi1 (evar_context evi) in

628	642	let instance = List.map mkVar (List.map pi1 ctxt) in
629	643
630	644	let rec make_subst = function
631		\| (id,_,t)::ctxt, c::l, occs::occsl when isVarId id c ->
	645	\| (id,_,t)::ctxt', c::l, occs::occsl when isVarId id c ->
632	646	if occs<>None then
633	647	error "Cannot force abstraction on identity instance."
634	648	else
635		make_subst (ctxt,l,occsl)
636		\| (id,_,t)::ctxt, c::l, occs::occsl ->
	649	make_subst (ctxt',l,occsl)
	650	\| (id,_,t)::ctxt', c::l, occs::occsl ->
637	651	let evs = ref [] in
638		let filter = List.map2 (&&) filter (filter_possible_projections c args) in
639	652	let ty = Retyping.get_type_of env_rhs evd c in
640		(id,t,c,ty,evs,filter,occs) :: make_subst (ctxt,l,occsl)
	653	let filter' = filter_possible_projections c ty ctxt args in
	654	let filter = List.map2 (&&) filter filter' in
	655	(id,t,c,ty,evs,filter,occs) :: make_subst (ctxt',l,occsl)
641	656	\| [], [], [] -> []
642	657	\| _ -> anomaly "Signature, instance and occurrences list do not match" in
643	658

723	738	(* The typical kind of constraint coming from pattern-matching return
724	739	type inference *)
725	740	choose_less_dependent_instance evk2 evd term1 args2, true
	741	\| Evar (evk1,args1), Evar (evk2,args2) when evk1 = evk2 ->
	742	let f env evd pbty x y = (evd,is_trans_fconv pbty ts env evd x y) in
	743	solve_refl ~can_drop:true f env evd evk1 args1 args2, true
	744	\| Evar ev1, Evar ev2 ->
	745	solve_evar_evar ~force:true
	746	(evar_define (evar_conv_x ts)) (evar_conv_x ts) env evd ev1 ev2, true
726	747	\| Evar ev1,_ when List.length l1 <= List.length l2 ->
727	748	(* On "?n t1 .. tn = u u1 .. u(n+p)", try first-order unification *)
728	749	(* and otherwise second-order matching *)

752	773	\| (pbty,env,t1,t2)::_ -> Pretype_errors.error_cannot_unify env evd (t1, t2)
753	774	\| _ -> ()
754	775
	776	let max_undefined_with_candidates evd =
	777	(* If evar were ordered with highest index first, fold_undefined
	778	would be going decreasingly and we could use fold_undefined to
	779	find the undefined evar of maximum index (alternatively,
	780	max_bindings from ocaml 3.12 could be used); instead we traverse
	781	the whole map *)
	782	let l = Evd.fold_undefined
	783	(fun evk ev_info evars ->
	784	match ev_info.evar_candidates with
	785	\| None -> evars
	786	\| Some l -> (evk,ev_info,l)::evars) evd [] in
	787	match l with
	788	\| [] -> None
	789	\| a::l -> Some (list_last (a::l))
	790
	791	let rec solve_unconstrained_evars_with_canditates evd =
	792	(* max_undefined is supposed to return the most recent, hence
	793	possibly most dependent evar *)
	794	match max_undefined_with_candidates evd with
	795	\| None -> evd
	796	\| Some (evk,ev_info,l) ->
	797	let rec aux = function
	798	\| [] -> error "Unsolvable existential variables."
	799	\| a::l ->
	800	try
	801	let conv_algo = evar_conv_x full_transparent_state in
	802	let evd = check_evar_instance evd evk a conv_algo in
	803	let evd = Evd.define evk a evd in
	804	let evd,b = reconsider_conv_pbs conv_algo evd in
	805	if b then solve_unconstrained_evars_with_canditates evd
	806	else aux l
	807	with e when Pretype_errors.precatchable_exception e ->
	808	aux l in
	809	(* List.rev is there to favor most dependent solutions *)
	810	(* and favor progress when used with the refine tactics *)
	811	let evd = aux (List.rev l) in
	812	solve_unconstrained_evars_with_canditates evd
	813
	814	let solve_unconstrained_impossible_cases evd =
	815	Evd.fold_undefined (fun evk ev_info evd' ->
	816	match ev_info.evar_source with
	817	\| _,ImpossibleCase -> Evd.define evk (j_type (coq_unit_judge ())) evd'
	818	\| _ -> evd') evd evd
	819
755	820	let consider_remaining_unif_problems ?(ts=full_transparent_state) env evd =
	821	let evd = solve_unconstrained_evars_with_canditates evd in
756	822	let (evd,pbs) = extract_all_conv_pbs evd in
757	823	let heuristic_solved_evd = List.fold_left
758	824	(fun evd (pbty,env,t1,t2) ->

760	826	if b then evd' else Pretype_errors.error_cannot_unify env evd (t1, t2))
761	827	evd pbs in
762	828	check_problems_are_solved env heuristic_solved_evd;
763		Evd.fold_undefined (fun ev ev_info evd' -> match ev_info.evar_source with
764		\|_,ImpossibleCase ->
765		Evd.define ev (j_type (coq_unit_judge ())) evd'
766		\|_ ->
767		match ev_info.evar_candidates with
768		\| Some (a::l) -> Evd.define ev a evd'
769		\| Some [] -> error "Unsolvable existential variables"
770		\| None -> evd') heuristic_solved_evd heuristic_solved_evd
	829	solve_unconstrained_impossible_cases heuristic_solved_evd
771	830
772	831	(* Main entry points *)
773	832

781	840	(evd', true) -> evd'
782	841	\| _ -> raise Reduction.NotConvertible
783	842
784		let e_conv ?(ts=full_transparent_state) env evd t1 t2 =
785		match evar_conv_x ts env !evd CONV t1 t2 with
786		(evd',true) -> evd := evd'; true
	843	let e_conv ?(ts=full_transparent_state) env evdref t1 t2 =
	844	match evar_conv_x ts env !evdref CONV t1 t2 with
	845	(evd',true) -> evdref := evd'; true
787	846	\| _ -> false
788	847
789		let e_cumul ?(ts=full_transparent_state) env evd t1 t2 =
790		match evar_conv_x ts env !evd CUMUL t1 t2 with
791		(evd',true) -> evd := evd'; true
	848	let e_cumul ?(ts=full_transparent_state) env evdref t1 t2 =
	849	match evar_conv_x ts env !evdref CUMUL t1 t2 with
	850	(evd',true) -> evdref := evd'; true
792	851	\| _ -> false

+880

-623

pretyping/evarutil.ml less more

20	20	open Pretype_errors
21	21	open Retyping
22	22
23		(* Expanding existential variables *)
24		(* 1- flush_and_check_evars fails if an existential is undefined *)
	23	(****************************************************)
	24	(* Expanding/testing/exposing existential variables *)
	25	(****************************************************)
	26
	27	(* flush_and_check_evars fails if an existential is undefined *)
25	28
26	29	exception Uninstantiated_evar of existential_key
27	30

69	72
70	73	let nf_evar_map evd = Evd.evars_reset_evd (nf_evars evd) evd
71	74	let nf_evar_map_undefined evd = Evd.evars_reset_evd (nf_evars_undefined evd) evd
	75
	76	(-------------------)
	77	(* Auxiliary functions for the conversion algorithms modulo evars
	78	*)
	79
	80	let has_undefined_evars_or_sorts evd t =
	81	let rec has_ev t =
	82	match kind_of_term t with
	83	\| Evar (ev,args) ->
	84	(match evar_body (Evd.find evd ev) with
	85	\| Evar_defined c ->
	86	has_ev c; Array.iter has_ev args
	87	\| Evar_empty ->
	88	raise NotInstantiatedEvar)
	89	\| Sort s when is_sort_variable evd s -> raise Not_found
	90	\| _ -> iter_constr has_ev t in
	91	try let _ = has_ev t in false
	92	with (Not_found \| NotInstantiatedEvar) -> true
	93
	94	let is_ground_term evd t =
	95	not (has_undefined_evars_or_sorts evd t)
	96
	97	let is_ground_env evd env =
	98	let is_ground_decl = function
	99	(_,Some b,_) -> is_ground_term evd b
	100	\| _ -> true in
	101	List.for_all is_ground_decl (rel_context env) &&
	102	List.for_all is_ground_decl (named_context env)
	103	(* Memoization is safe since evar_map and environ are applicative
	104	structures *)
	105	let is_ground_env = memo1_2 is_ground_env
	106
	107	(* Return the head evar if any *)
	108
	109	exception NoHeadEvar
	110
	111	let head_evar =
	112	let rec hrec c = match kind_of_term c with
	113	\| Evar (evk,_) -> evk
	114	\| Case (_,_,c,_) -> hrec c
	115	\| App (c,_) -> hrec c
	116	\| Cast (c,_,_) -> hrec c
	117	\| _ -> raise NoHeadEvar
	118	in
	119	hrec
	120
	121	(* Expand head evar if any (currently consider only applications but I
	122	guess it should consider Case too) *)
	123
	124	let whd_head_evar_stack sigma c =
	125	let rec whrec (c, l as s) =
	126	match kind_of_term c with
	127	\| Evar (evk,args as ev) when Evd.is_defined sigma evk
	128	-> whrec (existential_value sigma ev, l)
	129	\| Cast (c,_,_) -> whrec (c, l)
	130	\| App (f,args) -> whrec (f, Array.fold_right (fun a l -> a::l) args l)
	131	\| _ -> s
	132	in
	133	whrec (c, [])
	134
	135	let whd_head_evar sigma c = applist (whd_head_evar_stack sigma c)
	136
	137	let noccur_evar evd evk c =
	138	let rec occur_rec c = match kind_of_term c with
	139	\| Evar (evk',_ as ev') ->
	140	(match safe_evar_value evd ev' with
	141	\| Some c -> occur_rec c
	142	\| None -> if evk = evk' then raise Occur)
	143	\| _ -> iter_constr occur_rec c
	144	in
	145	try occur_rec c; true with Occur -> false
72	146
73	147	(**********************)
74	148	(* Creating new metas *)

124	198	let emap = nf_evar_map_undefined emap in
125	199	let sigma',emap' = push_dependent_evars sigma emap in
126	200	let sigma',emap' = push_duplicated_evars sigma' emap' c in
	201	(* if an evar has been instantiated in [emap] (as part of typing [c])
	202	then it is instantiated in [sigma]. *)
	203	let repair_evars sigma emap =
	204	fold_undefined begin fun ev _ sigma' ->
	205	try
	206	let info = find emap ev in
	207	match evar_body info with
	208	\| Evar_empty -> sigma'
	209	\| Evar_defined body -> define ev body sigma'
	210	with Not_found -> sigma'
	211	end sigma sigma
	212	in
	213	let sigma' = repair_evars sigma' emap in
127	214	let change_exist evar =
128	215	let ty = nf_betaiota emap (existential_type emap evar) in
129	216	let n = new_meta() in

140	227	let listev = Evd.undefined_list sigma in
141	228	List.map (fun (ev,evi) -> (ev,nf_evar_info sigma evi)) listev
142	229
	230	(************************)
	231	(* Manipulating filters *)
	232	(************************)
	233
	234	let apply_subfilter filter subfilter =
	235	fst (List.fold_right (fun oldb (l,filter) ->
	236	if oldb then List.hd filter::l,List.tl filter else (false::l,filter))
	237	filter ([], List.rev subfilter))
	238
	239	let extract_subfilter initial_filter refined_filter =
	240	snd (list_filter2 (fun b1 b2 -> b1) (initial_filter,refined_filter))
	241
143	242	(**********************)
144	243	(* Creating new evars *)
145	244	(**********************)

157	256	* functional operations on evar sets *
158	257	------------------------------------)
159	258
160		let new_evar_instance sign evd typ ?(src=(dummy_loc,InternalHole)) ?filter ?candidates instance =
161		assert
162		(let ctxt = named_context_of_val sign in
163		list_distinct (ids_of_named_context ctxt));
	259	(* [push_rel_context_to_named_context] builds the defining context and the
	260	* initial instance of an evar. If the evar is to be used in context
	261	*
	262	* Gamma = a1 ... an xp ... x1
	263	* \- named part -/ \- de Bruijn part -/
	264	*
	265	* then the x1...xp are turned into variables so that the evar is declared in
	266	* context
	267	*
	268	* a1 ... an xp ... x1
	269	* \----------- named part ------------/
	270	*
	271	* but used applied to the initial instance "a1 ... an Rel(p) ... Rel(1)"
	272	* so that ev[a1:=a1 ... an:=an xp:=Rel(p) ... x1:=Rel(1)] is correctly typed
	273	* in context Gamma.
	274	*
	275	* Remark 1: The instance is reverted in practice (i.e. Rel(1) comes first)
	276	* Remark 2: If some of the ai or xj are definitions, we keep them in the
	277	* instance. This is necessary so that no unfolding of local definitions
	278	* happens when inferring implicit arguments (consider e.g. the problem
	279	* "x:nat; x':=x; f:forall y, y=y -> Prop \|- f _ (refl_equal x')" which
	280	* produces the equation "?y[x,x']=?y[x,x']" =? "x'=x'": we want
	281	* the hole to be instantiated by x', not by x (which would have been
	282	* the case in [invert_definition] if x' had disappeared from the instance).
	283	* Note that at any time, if, in some context env, the instance of
	284	* declaration x:A is t and the instance of definition x':=phi(x) is u, then
	285	* we have the property that u and phi(t) are convertible in env.
	286	*)
	287
	288	let push_rel_context_to_named_context env typ =
	289	(* compute the instances relative to the named context and rel_context *)
	290	let ids = List.map pi1 (named_context env) in
	291	let inst_vars = List.map mkVar ids in
	292	let inst_rels = List.rev (rel_list 0 (nb_rel env)) in
	293	(* move the rel context to a named context and extend the named instance *)
	294	(* with vars of the rel context *)
	295	(* We do keep the instances corresponding to local definition (see above) *)
	296	let (subst, _, env) =
	297	Sign.fold_rel_context
	298	(fun (na,c,t) (subst, avoid, env) ->
	299	let id = next_name_away na avoid in
	300	let d = (id,Option.map (substl subst) c,substl subst t) in
	301	(mkVar id :: subst, id::avoid, push_named d env))
	302	(rel_context env) ~init:([], ids, env) in
	303	(named_context_val env, substl subst typ, inst_rels@inst_vars, subst)
	304
	305	(------------------------------------
	306	* Entry points to define new evars *
	307	------------------------------------)
	308
	309	let default_source = (dummy_loc,InternalHole)
	310
	311	let new_pure_evar evd sign ?(src=default_source) ?filter ?candidates typ =
164	312	let newevk = new_untyped_evar() in
165		let evd = evar_declare sign newevk typ ~src:src ?filter ?candidates evd in
	313	let evd = evar_declare sign newevk typ ~src ?filter ?candidates evd in
	314	(evd,newevk)
	315
	316	let new_evar_instance sign evd typ ?src ?filter ?candidates instance =
	317	assert (not !Flags.debug \|\|
	318	list_distinct (ids_of_named_context (named_context_of_val sign)));
	319	let evd,newevk = new_pure_evar evd sign ?src ?filter ?candidates typ in
166	320	(evd,mkEvar (newevk,Array.of_list instance))
	321
	322	(* [new_evar] declares a new existential in an env env with type typ *)
	323	(* Converting the env into the sign of the evar to define *)
	324
	325	let new_evar evd env ?src ?filter ?candidates typ =
	326	let sign,typ',instance,subst = push_rel_context_to_named_context env typ in
	327	let candidates = Option.map (List.map (substl subst)) candidates in
	328	let instance =
	329	match filter with
	330	\| None -> instance
	331	\| Some filter -> list_filter_with filter instance in
	332	new_evar_instance sign evd typ' ?src ?filter ?candidates instance
	333
	334	let new_type_evar ?src ?filter evd env =
	335	let evd', s = new_sort_variable evd in
	336	new_evar evd' env ?src ?filter (mkSort s)
	337
	338	(* The same using side-effect *)
	339	let e_new_evar evdref env ?(src=(dummy_loc,InternalHole)) ?filter ?candidates ty =
	340	let (evd',ev) = new_evar !evdref env ~src:src ?filter ?candidates ty in
	341	evdref := evd';
	342	ev
	343
	344	(------------------------------------
	345	* Restricting existing evars *
	346	------------------------------------)
	347
	348	let restrict_evar_key evd evk filter candidates =
	349	if filter = None && candidates = None then
	350	evd,evk
	351	else
	352	let evi = Evd.find_undefined evd evk in
	353	let oldfilter = evar_filter evi in
	354	if filter = Some oldfilter && candidates = None then
	355	evd,evk
	356	else
	357	let filter =
	358	match filter with
	359	\| None -> evar_filter evi
	360	\| Some filter -> filter in
	361	let candidates =
	362	match candidates with None -> evi.evar_candidates \| _ -> candidates in
	363	let ccl = evi.evar_concl in
	364	let sign = evar_hyps evi in
	365	let src = evi.evar_source in
	366	let evd,newevk = new_pure_evar evd sign ccl ~src ~filter ?candidates in
	367	let ctxt = snd (list_filter2 (fun b c -> b) (filter,evar_context evi)) in
	368	let id_inst = Array.of_list (List.map (fun (id,_,_) -> mkVar id) ctxt) in
	369	Evd.define evk (mkEvar(newevk,id_inst)) evd,newevk
	370
	371	(* Restrict an applied evar and returns its restriction in the same context *)
	372	let restrict_applied_evar evd (evk,argsv) filter candidates =
	373	let evd,newevk = restrict_evar_key evd evk filter candidates in
	374	let newargsv = match filter with
	375	\| None -> (* optim *) argsv
	376	\| Some filter ->
	377	let evi = Evd.find evd evk in
	378	let subfilter = extract_subfilter (evar_filter evi) filter in
	379	array_filter_with subfilter argsv in
	380	evd,(newevk,newargsv)
	381
	382	(* Restrict an evar in the current evar_map *)
	383	let restrict_evar evd evk filter candidates =
	384	fst (restrict_evar_key evd evk filter candidates)
	385
	386	(* Restrict an evar in the current evar_map *)
	387	let restrict_instance evd evk filter argsv =
	388	match filter with None -> argsv \| Some filter ->
	389	let evi = Evd.find evd evk in
	390	array_filter_with (extract_subfilter (evar_filter evi) filter) argsv
	391
	392	(* This assumes an evar with identity instance and generalizes it over only
	393	the De Bruijn part of the context *)
	394	let generalize_evar_over_rels sigma (ev,args) =
	395	let evi = Evd.find sigma ev in
	396	let sign = named_context_of_val evi.evar_hyps in
	397	List.fold_left2
	398	(fun (c,inst as x) a d ->
	399	if isRel a then (mkNamedProd_or_LetIn d c,a::inst) else x)
	400	(evi.evar_concl,[]) (Array.to_list args) sign
	401
	402	(***************************************)
	403	(* Managing chains of local definitons *)
	404	(***************************************)
167	405
168	406	(* Expand rels and vars that are bound to other rels or vars so that
169	407	dependencies in variables are canonically associated to the most ancient

207	445	let var_aliases = compute_var_aliases (named_context env) in
208	446	let rel_aliases = compute_rel_aliases var_aliases (rel_context env) in
209	447	(var_aliases,rel_aliases)
	448
	449	let lift_aliases n (var_aliases,rel_aliases as aliases) =
	450	if n = 0 then aliases else
	451	(var_aliases,
	452	Intmap.fold (fun p l -> Intmap.add (p+n) (List.map (lift n) l))
	453	rel_aliases Intmap.empty)
210	454
211	455	let get_alias_chain_of aliases x = match kind_of_term x with
212	456	\| Rel n -> (try Intmap.find n (snd aliases) with Not_found -> [])

249	493	\| None -> rel_aliases in
250	494	(var_aliases, rel_aliases)
251	495
	496	let expand_alias_once aliases x =
	497	match get_alias_chain_of aliases x with
	498	\| [] -> None
	499	\| l -> Some (list_last l)
	500
252	501	let rec expansions_of_var aliases x =
253	502	match get_alias_chain_of aliases x with
254	503	\| [] -> [x]

271	520
272	521	let free_vars_and_rels_up_alias_expansion aliases c =
273	522	let acc1 = ref Intset.empty and acc2 = ref Idset.empty in
274		let rec frec (aliases,depth) c = match kind_of_term c with
275		\| Rel _ \| Var _ ->
	523	let cache_rel = ref Intset.empty and cache_var = ref Idset.empty in
	524	let is_in_cache depth = function
	525	\| Rel n -> Intset.mem (n-depth) !cache_rel
	526	\| Var s -> Idset.mem s !cache_var
	527	\| _ -> false in
	528	let put_in_cache depth = function
	529	\| Rel n -> cache_rel := Intset.add (n-depth) !cache_rel
	530	\| Var s -> cache_var := Idset.add s !cache_var
	531	\| _ -> () in
	532	let rec frec (aliases,depth) c =
	533	match kind_of_term c with
	534	\| Rel _ \| Var _ as ck ->
	535	if is_in_cache depth ck then () else begin
	536	put_in_cache depth ck;
276	537	let c = expansion_of_var aliases c in
277		(match kind_of_term c with
	538	match kind_of_term c with
278	539	\| Var id -> acc2 := Idset.add id !acc2
279	540	\| Rel n -> if n >= depth+1 then acc1 := Intset.add (n-depth) !acc1
280		\| _ ->
281		(* not optimal: would need sharing if alias occurs more than once *)
282		frec (aliases,depth) c)
	541	\| _ -> frec (aliases,depth) c end
283	542	\| Const _ \| Ind _ \| Construct _ ->
284	543	acc2 := List.fold_right Idset.add (vars_of_global (Global.env()) c) !acc2
285	544	\| _ ->

289	548	in
290	549	frec (aliases,0) c;
291	550	(!acc1,!acc2)
	551
	552	(************************************)
	553	(* Removing a dependency in an evar *)
	554	(************************************)
	555
	556	type clear_dependency_error =
	557	\| OccurHypInSimpleClause of identifier option
	558	\| EvarTypingBreak of existential
	559
	560	exception ClearDependencyError of identifier * clear_dependency_error
	561
	562	open Store.Field
	563
	564	let cleared = Store.field ()
	565
	566	let rec check_and_clear_in_constr evdref err ids c =
	567	(* returns a new constr where all the evars have been 'cleaned'
	568	(ie the hypotheses ids have been removed from the contexts of
	569	evars) *)
	570	let check id' =
	571	if List.mem id' ids then
	572	raise (ClearDependencyError (id',err))
	573	in
	574	match kind_of_term c with
	575	\| Var id' ->
	576	check id'; c
	577
	578	\| ( Const _ \| Ind _ \| Construct _ ) ->
	579	let vars = Environ.vars_of_global (Global.env()) c in
	580	List.iter check vars; c
	581
	582	\| Evar (evk,l as ev) ->
	583	if Evd.is_defined !evdref evk then
	584	(* If evk is already defined we replace it by its definition *)
	585	let nc = whd_evar !evdref c in
	586	(check_and_clear_in_constr evdref err ids nc)
	587	else
	588	(* We check for dependencies to elements of ids in the
	589	evar_info corresponding to e and in the instance of
	590	arguments. Concurrently, we build a new evar
	591	corresponding to e where hypotheses of ids have been
	592	removed *)
	593	let evi = Evd.find_undefined !evdref evk in
	594	let ctxt = Evd.evar_filtered_context evi in
	595	let (nhyps,nargs,rids) =
	596	List.fold_right2
	597	(fun (rid,ob,c as h) a (hy,ar,ri) ->
	598	(* Check if some id to clear occurs in the instance
	599	a of rid in ev and remember the dependency *)
	600	match
	601	List.filter (fun id -> List.mem id ids) (Idset.elements (collect_vars a))
	602	with
	603	\| id :: _ -> (hy,ar,(rid,id)::ri)
	604	\| _ ->
	605	(* Check if some rid to clear in the context of ev
	606	has dependencies in another hyp of the context of ev
	607	and transitively remember the dependency *)
	608	match List.filter (fun (id,_) -> occur_var_in_decl (Global.env()) id h) ri with
	609	\| (_,id') :: _ -> (hy,ar,(rid,id')::ri)
	610	\| _ ->
	611	(* No dependency at all, we can keep this ev's context hyp *)
	612	(h::hy,a::ar,ri))
	613	ctxt (Array.to_list l) ([],[],[]) in
	614	(* Check if some rid to clear in the context of ev has dependencies
	615	in the type of ev and adjust the source of the dependency *)
	616	let nconcl =
	617	try check_and_clear_in_constr evdref (EvarTypingBreak ev)
	618	(List.map fst rids) (evar_concl evi)
	619	with ClearDependencyError (rid,err) ->
	620	raise (ClearDependencyError (List.assoc rid rids,err)) in
	621
	622	if rids = [] then c else begin
	623	let env = Sign.fold_named_context push_named nhyps ~init:(empty_env) in
	624	let ev'= e_new_evar evdref env ~src:(evar_source evk !evdref) nconcl in
	625	evdref := Evd.define evk ev' !evdref;
	626	let (evk',_) = destEvar ev' in
	627	(* spiwack: hacking session to mark the old [evk] as having been "cleared" *)
	628	let evi = Evd.find !evdref evk in
	629	let extra = evi.evar_extra in
	630	let extra' = cleared.set true extra in
	631	let evi' = { evi with evar_extra = extra' } in
	632	evdref := Evd.add !evdref evk evi' ;
	633	(* spiwack: /hacking session *)
	634	mkEvar(evk', Array.of_list nargs)
	635	end
	636
	637	\| _ -> map_constr (check_and_clear_in_constr evdref err ids) c
	638
	639	let clear_hyps_in_evi evdref hyps concl ids =
	640	(* clear_hyps_in_evi erases hypotheses ids in hyps, checking if some
	641	hypothesis does not depend on a element of ids, and erases ids in
	642	the contexts of the evars occuring in evi *)
	643	let nconcl =
	644	check_and_clear_in_constr evdref (OccurHypInSimpleClause None) ids concl in
	645	let nhyps =
	646	let check_context (id,ob,c) =
	647	let err = OccurHypInSimpleClause (Some id) in
	648	(id, Option.map (check_and_clear_in_constr evdref err ids) ob,
	649	check_and_clear_in_constr evdref err ids c)
	650	in
	651	let check_value vk =
	652	match !vk with
	653	\| VKnone -> vk
	654	\| VKvalue (v,d) ->
	655	if (List.for_all (fun e -> not (Idset.mem e d)) ids) then
	656	(* v does depend on any of ids, it's ok *)
	657	vk
	658	else
	659	(* v depends on one of the cleared hyps: we forget the computed value *)
	660	ref VKnone
	661	in
	662	remove_hyps ids check_context check_value hyps
	663	in
	664	(nhyps,nconcl)
	665
	666	(********************************)
	667	(* Managing pattern-unification *)
	668	(********************************)
	669
	670	let rec expand_and_check_vars aliases = function
	671	\| [] -> []
	672	\| a::l when isRel a or isVar a ->
	673	let a = expansion_of_var aliases a in
	674	if isRel a or isVar a then a :: expand_and_check_vars aliases l
	675	else raise Exit
	676	\| _ ->
	677	raise Exit
	678
	679	module Constrhash = Hashtbl.Make
	680	(struct type t = constr
	681	let equal = eq_constr
	682	let hash = hash_constr
	683	end)
	684
	685	let rec constr_list_distinct l =
	686	let visited = Constrhash.create 23 in
	687	let rec loop = function
	688	\| h::t ->
	689	if Constrhash.mem visited h then false
	690	else (Constrhash.add visited h h; loop t)
	691	\| [] -> true
	692	in loop l
	693
	694	let get_actual_deps aliases l t =
	695	if occur_meta_or_existential t then
	696	(* Probably no restrictions on allowed vars in presence of evars *)
	697	l
	698	else
	699	(* Probably strong restrictions coming from t being evar-closed *)
	700	let (fv_rels,fv_ids) = free_vars_and_rels_up_alias_expansion aliases t in
	701	List.filter (fun c ->
	702	match kind_of_term c with
	703	\| Var id -> Idset.mem id fv_ids
	704	\| Rel n -> Intset.mem n fv_rels
	705	\| _ -> assert false) l
	706
	707	let remove_instance_local_defs evd evk args =
	708	let evi = Evd.find evd evk in
	709	let rec aux = function
	710	\| (_,Some _,_)::sign, a::args -> aux (sign,args)
	711	\| (_,None,_)::sign, a::args -> a::aux (sign,args)
	712	\| [], [] -> []
	713	\| _ -> assert false in
	714	aux (evar_filtered_context evi, args)
	715
	716	(* Check if an applied evar "?X[args] l" is a Miller's pattern *)
	717
	718	let find_unification_pattern_args env l t =
	719	if List.for_all (fun x -> isRel x \|\| isVar x) l (* common failure case *) then
	720	let aliases = make_alias_map env in
	721	match (try Some (expand_and_check_vars aliases l) with Exit -> None) with
	722	\| Some l as x when constr_list_distinct (get_actual_deps aliases l t) -> x
	723	\| _ -> None
	724	else
	725	None
	726
	727	let is_unification_pattern_meta env nb m l t =
	728	(* Variables from context and rels > nb are implicitly all there *)
	729	(* so we need to be a rel <= nb *)
	730	if List.for_all (fun x -> isRel x && destRel x <= nb) l then
	731	match find_unification_pattern_args env l t with
	732	\| Some _ as x when not (dependent (mkMeta m) t) -> x
	733	\| _ -> None
	734	else
	735	None
	736
	737	let is_unification_pattern_evar env evd (evk,args) l t =
	738	if List.for_all (fun x -> isRel x \|\| isVar x) l & noccur_evar evd evk t then
	739	let args = remove_instance_local_defs evd evk (Array.to_list args) in
	740	let n = List.length args in
	741	match find_unification_pattern_args env (args @ l) t with
	742	\| Some l -> Some (list_skipn n l)
	743	\| _ -> None
	744	else
	745	None
	746
	747	let is_unification_pattern_pure_evar env evd (evk,args) t =
	748	is_unification_pattern_evar env evd (evk,args) [] t <> None
	749
	750	let is_unification_pattern (env,nb) evd f l t =
	751	match kind_of_term f with
	752	\| Meta m -> is_unification_pattern_meta env nb m l t
	753	\| Evar ev -> is_unification_pattern_evar env evd ev l t
	754	\| _ -> None
	755
	756	(* From a unification problem "?X l = c", build "\x1...xn.(term1 l2)"
	757	(pattern unification). It is assumed that l is made of rel's that
	758	are distinct and not bound to aliases. *)
	759	(* It is also assumed that c does not contain metas because metas
	760	implicitly depend on Vars but lambda abstraction will not reflect this
	761	dependency: ?X x = ?1 (?1 is a meta) will return \_.?1 while it should
	762	return \y. ?1{x\y} (non constant function if ?1 depends on x) (BB) *)
	763	let solve_pattern_eqn env l c =
	764	let c' = List.fold_right (fun a c ->
	765	let c' = subst_term (lift 1 a) (lift 1 c) in
	766	match kind_of_term a with
	767	(* Rem: if [a] links to a let-in, do as if it were an assumption *)
	768	\| Rel n ->
	769	let d = map_rel_declaration (lift n) (lookup_rel n env) in
	770	mkLambda_or_LetIn d c'
	771	\| Var id ->
	772	let d = lookup_named id env in mkNamedLambda_or_LetIn d c'
	773	\| _ -> assert false)
	774	l c in
	775	(* Warning: we may miss some opportunity to eta-reduce more since c'
	776	is not in normal form *)
	777	whd_eta c'
	778
	779	(*****************************************)
	780	(* Refining/solving unification problems *)
	781	(*****************************************)
292	782
293	783	(* Knowing that [Gamma \|- ev : T] and that [ev] is applied to [args],
294	784	* [make_projectable_subst ev args] builds the substitution [Gamma:=args].

343	833	\| _ -> anomaly "Instance does not match its signature")
344	834	(evar_filtered_context evi) (array_rev_to_list args,[]))
345	835
346		(* [push_rel_context_to_named_context] builds the defining context and the
347		* initial instance of an evar. If the evar is to be used in context
348		*
349		* Gamma = a1 ... an xp ... x1
350		* \- named part -/ \- de Bruijn part -/
351		*
352		* then the x1...xp are turned into variables so that the evar is declared in
353		* context
354		*
355		* a1 ... an xp ... x1
356		* \----------- named part ------------/
357		*
358		* but used applied to the initial instance "a1 ... an Rel(p) ... Rel(1)"
359		* so that ev[a1:=a1 ... an:=an xp:=Rel(p) ... x1:=Rel(1)] is correctly typed
360		* in context Gamma.
361		*
362		* Remark 1: The instance is reverted in practice (i.e. Rel(1) comes first)
363		* Remark 2: If some of the ai or xj are definitions, we keep them in the
364		* instance. This is necessary so that no unfolding of local definitions
365		* happens when inferring implicit arguments (consider e.g. the problem
366		* "x:nat; x':=x; f:forall y, y=y -> Prop \|- f _ (refl_equal x')" which
367		* produces the equation "?y[x,x']=?y[x,x']" =? "x'=x'": we want
368		* the hole to be instantiated by x', not by x (which would have been
369		* the case in [invert_definition] if x' had disappeared from the instance).
370		* Note that at any time, if, in some context env, the instance of
371		* declaration x:A is t and the instance of definition x':=phi(x) is u, then
372		* we have the property that u and phi(t) are convertible in env.
373		*)
374
375		let push_rel_context_to_named_context env typ =
376		(* compute the instances relative to the named context and rel_context *)
377		let ids = List.map pi1 (named_context env) in
378		let inst_vars = List.map mkVar ids in
379		let inst_rels = List.rev (rel_list 0 (nb_rel env)) in
380		(* move the rel context to a named context and extend the named instance *)
381		(* with vars of the rel context *)
382		(* We do keep the instances corresponding to local definition (see above) *)
383		let (subst, _, env) =
384		Sign.fold_rel_context
385		(fun (na,c,t) (subst, avoid, env) ->
386		let id = next_name_away na avoid in
387		let d = (id,Option.map (substl subst) c,substl subst t) in
388		(mkVar id :: subst, id::avoid, push_named d env))
389		(rel_context env) ~init:([], ids, env) in
390		(named_context_val env, substl subst typ, inst_rels@inst_vars, subst)
391
392		(* [new_evar] declares a new existential in an env env with type typ *)
393		(* Converting the env into the sign of the evar to define *)
394
395		let new_evar evd env ?(src=(dummy_loc,InternalHole)) ?filter ?candidates typ =
396		let sign,typ',instance,subst = push_rel_context_to_named_context env typ in
397		let candidates = Option.map (List.map (substl subst)) candidates in
398		let instance =
399		match filter with
400		\| None -> instance
401		\| Some filter -> snd (list_filter2 (fun b c -> b) (filter,instance)) in
402		new_evar_instance sign evd typ' ~src:src ?filter ?candidates instance
403
404		(* The same using side-effect *)
405		let e_new_evar evdref env ?(src=(dummy_loc,InternalHole)) ?filter ?candidates ty =
406		let (evd',ev) = new_evar !evdref env ~src:src ?filter ?candidates ty in
407		evdref := evd';
408		ev
409
410		(* This assumes an evar with identity instance and generalizes it over only
411		the de Bruijn part of the context *)
412		let generalize_evar_over_rels sigma (ev,args) =
413		let evi = Evd.find sigma ev in
414		let sign = named_context_of_val evi.evar_hyps in
415		List.fold_left2
416		(fun (c,inst as x) a d ->
417		if isRel a then (mkNamedProd_or_LetIn d c,a::inst) else x)
418		(evi.evar_concl,[]) (Array.to_list args) sign
419
420	836	(------------------------------------
421	837	* operations on the evar constraints *
422	838	------------------------------------)
423
424		exception IllTypedFilter
425
426		let check_restricted_occur evd refine env filter constr =
427		let filter = Array.of_list filter in
428		let rec aux k c =
429		let c = whd_evar evd c in
430		match kind_of_term c with
431		\| Var id ->
432		let idx = list_try_find_i (fun i (id', _, _) -> if id' = id then i else raise (Failure "")) 0 env in
433		if not filter.(idx)
434		then if refine then
435		(filter.(idx) <- true; c)
436		else raise IllTypedFilter
437		else c
438		\| _ -> map_constr_with_binders succ aux k c
439		in
440		let res = aux 0 constr in
441		Array.to_list filter, res
442	839
443	840	(* We have a unification problem Σ; Γ \|- ?e[u1..uq] = t : s where ?e is not yet
444	841	* declared in Σ but yet known to be declarable in some context x1:T1..xq:Tq.

446	843	* declares x1:T1..xq:Tq \|- ?e : s such that ?e[u1..uq] = t holds.
447	844	*)
448	845
449		let define_evar_from_virtual_equation define_fun env evd t_in_env sign filter inst_in_env
450		inst_in_sign =
	846	let define_evar_from_virtual_equation define_fun env evd t_in_env sign filter inst_in_env =
451	847	let ty_t_in_env = Retyping.get_type_of env evd t_in_env in
452	848	let evd,evar_in_env = new_evar_instance sign evd ty_t_in_env ~filter inst_in_env in
453	849	let t_in_env = whd_evar evd t_in_env in
454	850	let evd = define_fun env evd (destEvar evar_in_env) t_in_env in
	851	let ids = List.map pi1 (named_context_of_val sign) in
	852	let inst_in_sign = List.map mkVar (list_filter_with filter ids) in
455	853	let evar_in_sign = mkEvar (fst (destEvar evar_in_env), Array.of_list inst_in_sign) in
456	854	(evd,whd_evar evd evar_in_sign)
457	855

478	876	let sign1 = evar_hyps evi1 in
479	877	let filter1 = evar_filter evi1 in
480	878	let ids1 = List.map pi1 (named_context_of_val sign1) in
481		let inst_in_sign =
482		List.map mkVar (snd (list_filter2 (fun b id -> b) (filter1,ids1))) in
	879	let inst_in_sign = List.map mkVar (list_filter_with filter1 ids1) in
483	880	let (sign2,filter2,inst2_in_env,inst2_in_sign,_,evd,_) =
484	881	List.fold_right (fun (na,b,t_in_env as d) (sign,filter,inst_in_env,inst_in_sign,env,evd,avoid) ->
485		match b with
486		\| None ->
487		let id = next_name_away na avoid in
488		let evd,t_in_sign =
489		define_evar_from_virtual_equation define_fun env evd t_in_env
490		sign filter inst_in_env inst_in_sign in
491		(push_named_context_val (id,None,t_in_sign) sign,true::filter,
492		(mkRel 1)::(List.map (lift 1) inst_in_env),(mkVar id)::inst_in_sign,
493		push_rel d env,evd,id::avoid)
	882	let id = next_name_away na avoid in
	883	let evd,t_in_sign =
	884	define_evar_from_virtual_equation define_fun env evd t_in_env
	885	sign filter inst_in_env in
	886	let evd,b_in_sign = match b with
	887	\| None -> evd,None
494	888	\| Some b ->
495		(sign,filter,inst_in_env,inst_in_sign,
496		push_rel d env,evd,avoid))
	889	let evd,b = define_evar_from_virtual_equation define_fun env evd b
	890	sign filter inst_in_env in
	891	evd,Some b in
	892	(push_named_context_val (id,b_in_sign,t_in_sign) sign,true::filter,
	893	(mkRel 1)::(List.map (lift 1) inst_in_env),
	894	(mkRel 1)::(List.map (lift 1) inst_in_sign),
	895	push_rel d env,evd,id::avoid))
497	896	rel_sign
498	897	(sign1,filter1,Array.to_list args1,inst_in_sign,env1,evd,ids1)
499	898	in
500	899	let evd,ev2ty_in_sign =
501	900	define_evar_from_virtual_equation define_fun env evd ty_in_env
502		sign2 filter2 inst2_in_env inst2_in_sign in
	901	sign2 filter2 inst2_in_env in
503	902	let evd,ev2_in_sign =
504	903	new_evar_instance sign2 evd ev2ty_in_sign ~filter:filter2 inst2_in_sign in
505	904	let ev2_in_env = (fst (destEvar ev2_in_sign), Array.of_list inst2_in_env) in
506	905	(evd, ev2_in_sign, ev2_in_env)
507	906
508		let subfilter env ccl filter newfilter args =
509		let vars = collect_vars ccl in
510		let (filter, _, _, newargs) =
511		List.fold_left2
512		(fun (filter, newl, args, newargs) oldf (n, _, _) ->
513		if oldf then
514		let a, oldargs = match args with hd :: tl -> hd, tl \| _ -> assert false in
515		if Idset.mem n vars then
516		(oldf :: filter, List.tl newl, oldargs, a :: newargs)
517		else if List.hd newl then (true :: filter, List.tl newl, oldargs, a :: newargs)
518		else (false :: filter, List.tl newl, oldargs, newargs)
519		else (oldf :: filter, newl, args, newargs))
520		([], newfilter, args, []) filter env
521		in List.rev filter, List.rev newargs
522
523		let restrict_upon_filter ?(refine=false) evd evi evk p args =
524		let filter = evar_filter evi in
	907	let restrict_upon_filter evd evk p args =
525	908	let newfilter = List.map p args in
526		let env = evar_unfiltered_env evi in
527		let ccl = nf_evar evd evi.evar_concl in
528		let newfilter, newargs =
529		subfilter (named_context env) ccl filter newfilter args
530		in
531		if newfilter <> filter then
532		let (evd,newev) = new_evar evd env ~src:(evar_source evk evd)
533		~filter:newfilter ccl in
534		let evd = Evd.define evk newev evd in
535		evd,fst (destEvar newev), newargs
	909	if List.for_all (fun id -> id) newfilter then
	910	None
536	911	else
537		evd,evk,args
538
539		let collect_vars c =
540		let rec collrec acc c =
541		match kind_of_term c with
542		\| Var id -> list_add_set id acc
543		\| _ -> fold_constr collrec acc c
544		in
545		collrec [] c
546
547		type clear_dependency_error =
548		\| OccurHypInSimpleClause of identifier option
549		\| EvarTypingBreak of existential
550
551		exception ClearDependencyError of identifier * clear_dependency_error
552
553		open Store.Field
554
555		let cleared = Store.field ()
556
557		let rec check_and_clear_in_constr evdref err ids c =
558		(* returns a new constr where all the evars have been 'cleaned'
559		(ie the hypotheses ids have been removed from the contexts of
560		evars) *)
561		let check id' =
562		if List.mem id' ids then
563		raise (ClearDependencyError (id',err))
564		in
565		match kind_of_term c with
566		\| Var id' ->
567		check id'; c
568
569		\| ( Const _ \| Ind _ \| Construct _ ) ->
570		let vars = Environ.vars_of_global (Global.env()) c in
571		List.iter check vars; c
572
573		\| Evar (evk,l as ev) ->
574		if Evd.is_defined !evdref evk then
575		(* If evk is already defined we replace it by its definition *)
576		let nc = whd_evar !evdref c in
577		(check_and_clear_in_constr evdref err ids nc)
578		else
579		(* We check for dependencies to elements of ids in the
580		evar_info corresponding to e and in the instance of
581		arguments. Concurrently, we build a new evar
582		corresponding to e where hypotheses of ids have been
583		removed *)
584		let evi = Evd.find_undefined !evdref evk in
585		let ctxt = Evd.evar_filtered_context evi in
586		let (nhyps,nargs,rids) =
587		List.fold_right2
588		(fun (rid,ob,c as h) a (hy,ar,ri) ->
589		(* Check if some id to clear occurs in the instance
590		a of rid in ev and remember the dependency *)
591		match
592		List.filter (fun id -> List.mem id ids) (collect_vars a)
593		with
594		\| id :: _ -> (hy,ar,(rid,id)::ri)
595		\| _ ->
596		(* Check if some rid to clear in the context of ev
597		has dependencies in another hyp of the context of ev
598		and transitively remember the dependency *)
599		match List.filter (fun (id,_) -> occur_var_in_decl (Global.env()) id h) ri with
600		\| (_,id') :: _ -> (hy,ar,(rid,id')::ri)
601		\| _ ->
602		(* No dependency at all, we can keep this ev's context hyp *)
603		(h::hy,a::ar,ri))
604		ctxt (Array.to_list l) ([],[],[]) in
605		(* Check if some rid to clear in the context of ev has dependencies
606		in the type of ev and adjust the source of the dependency *)
607		let nconcl =
608		try check_and_clear_in_constr evdref (EvarTypingBreak ev)
609		(List.map fst rids) (evar_concl evi)
610		with ClearDependencyError (rid,err) ->
611		raise (ClearDependencyError (List.assoc rid rids,err)) in
612
613		if rids = [] then c else begin
614		let env = Sign.fold_named_context push_named nhyps ~init:(empty_env) in
615		let ev'= e_new_evar evdref env ~src:(evar_source evk !evdref) nconcl in
616		evdref := Evd.define evk ev' !evdref;
617		let (evk',_) = destEvar ev' in
618		(* spiwack: hacking session to mark the old [evk] as having been "cleared" *)
619		let evi = Evd.find !evdref evk in
620		let extra = evi.evar_extra in
621		let extra' = cleared.set true extra in
622		let evi' = { evi with evar_extra = extra' } in
623		evdref := Evd.add !evdref evk evi' ;
624		(* spiwack: /hacking session *)
625		mkEvar(evk', Array.of_list nargs)
626		end
627
628		\| _ -> map_constr (check_and_clear_in_constr evdref err ids) c
629
630		let clear_hyps_in_evi evdref hyps concl ids =
631		(* clear_hyps_in_evi erases hypotheses ids in hyps, checking if some
632		hypothesis does not depend on a element of ids, and erases ids in
633		the contexts of the evars occuring in evi *)
634		let nconcl =
635		check_and_clear_in_constr evdref (OccurHypInSimpleClause None) ids concl in
636		let nhyps =
637		let check_context (id,ob,c) =
638		let err = OccurHypInSimpleClause (Some id) in
639		(id, Option.map (check_and_clear_in_constr evdref err ids) ob,
640		check_and_clear_in_constr evdref err ids c)
641		in
642		let check_value vk =
643		match !vk with
644		\| VKnone -> vk
645		\| VKvalue (v,d) ->
646		if (List.for_all (fun e -> not (Idset.mem e d)) ids) then
647		(* v does depend on any of ids, it's ok *)
648		vk
649		else
650		(* v depends on one of the cleared hyps: we forget the computed value *)
651		ref VKnone
652		in
653		remove_hyps ids check_context check_value hyps
654		in
655		(nhyps,nconcl)
	912	let oldfullfilter = evar_filter (Evd.find_undefined evd evk) in
	913	Some (apply_subfilter oldfullfilter newfilter)
656	914
657	915	(* Inverting constructors in instances (common when inferring type of match) *)
658	916

701	959	* [make_projectable_subst])
702	960	*)
703	961
704		exception NotUnique
705		exception NotUniqueInType of types
706
707	962	type evar_projection =
708	963	\| ProjectVar
709	964	\| ProjectEvar of existential * evar_info * identifier * evar_projection
	965
	966	exception NotUnique
	967	exception NotUniqueInType of (identifier * evar_projection) list
710	968
711	969	let rec assoc_up_to_alias sigma aliases y yc = function
712	970	\| [] -> raise Not_found

827	1085	\| CannotInvert
828	1086	\| Invertible of projectibility_kind
829	1087
830		let invert_arg_from_subst aliases k sigma subst_in_env c_in_env_extended_with_k_binders =
	1088	let invert_arg_from_subst evd aliases k0 subst_in_env_extended_with_k_binders c_in_env_extended_with_k_binders =
831	1089	let effects = ref [] in
832	1090	let rec aux k t =
833		let t = whd_evar sigma t in
	1091	let t = whd_evar evd t in
834	1092	match kind_of_term t with
835		\| Rel i when i>k ->
836		project_with_effects aliases sigma effects (mkRel (i-k)) subst_in_env
837		\| Var id ->
838		project_with_effects aliases sigma effects t subst_in_env
839		\| _ ->
840		map_constr_with_binders succ aux k t in
	1093	\| Rel i when i>k0+k -> aux' k (mkRel (i-k))
	1094	\| Var id -> aux' k t
	1095	\| _ -> map_constr_with_binders succ aux k t
	1096	and aux' k t =
	1097	try project_with_effects aliases evd effects t subst_in_env_extended_with_k_binders
	1098	with Not_found ->
	1099	match expand_alias_once aliases t with
	1100	\| None -> raise Not_found
	1101	\| Some c -> aux k c in
841	1102	try
842		let c = aux k c_in_env_extended_with_k_binders in
	1103	let c = aux 0 c_in_env_extended_with_k_binders in
843	1104	Invertible (UniqueProjection (c,!effects))
844	1105	with
845	1106	\| Not_found -> CannotInvert
846	1107	\| NotUnique -> Invertible NoUniqueProjection
847	1108
848		let invert_arg aliases k sigma evk subst_in_env c_in_env_extended_with_k_binders =
849		let res = invert_arg_from_subst aliases k sigma subst_in_env c_in_env_extended_with_k_binders in
	1109	let invert_arg evd aliases k evk subst_in_env_extended_with_k_binders c_in_env_extended_with_k_binders =
	1110	let res = invert_arg_from_subst evd aliases k subst_in_env_extended_with_k_binders c_in_env_extended_with_k_binders in
850	1111	match res with
851		\| Invertible (UniqueProjection (c,_)) when occur_evar evk c -> CannotInvert
852		\| _ -> res
853
	1112	\| Invertible (UniqueProjection (c,_)) when not (noccur_evar evd evk c) ->
	1113	CannotInvert
	1114	\| _ ->
	1115	res
854	1116
855	1117	let effective_projections =
856	1118	map_succeed (function Invertible c -> c \| _ -> failwith"")

862	1124	\| UniqueProjection (c,effects) ->
863	1125	(List.fold_left (do_projection_effects f env ty) evd effects, c)
864	1126
865		let filter_of_projection = function CannotInvert -> false \| _ -> true
866
867		let filter_along f projs v =
868		let l = Array.to_list v in
869		let _,l = list_filter2 (fun b c -> f b) (projs,l) in
870		Array.of_list l
	1127	exception NotEnoughInformationToInvert
	1128
	1129	let extract_unique_projections projs =
	1130	List.map (function
	1131	\| Invertible (UniqueProjection (c,_)) -> c
	1132	\| _ ->
	1133	(* For instance, there are evars with non-invertible arguments and *)
	1134	(* we cannot arbitrarily restrict these evars before knowing if there *)
	1135	(* will really be used; it can also be due to some argument *)
	1136	(* (typically a rel) that is not inversible and that cannot be *)
	1137	(* inverted either because it is needed for typing the conclusion *)
	1138	(* of the evar to project *)
	1139	raise NotEnoughInformationToInvert) projs
	1140
	1141	let extract_candidates sols =
	1142	try
	1143	Some
	1144	(List.map (function (id,ProjectVar) -> mkVar id \| _ -> raise Exit) sols)
	1145	with Exit ->
	1146	None
	1147
	1148	let filter_of_projection = function Invertible _ -> true \| _ -> false
	1149
	1150	let invert_invertible_arg evd aliases k (evk,argsv) args' =
	1151	let evi = Evd.find_undefined evd evk in
	1152	let subst,_ = make_projectable_subst aliases evd evi argsv in
	1153	let projs = array_map_to_list (invert_arg evd aliases k evk subst) args' in
	1154	Array.of_list (extract_unique_projections projs)
871	1155
872	1156	(* Redefines an evar with a smaller context (i.e. it may depend on less
873	1157	* variables) such that c becomes closed.

882	1166	* such that "hyps' \|- ?e : T"
883	1167	*)
884	1168
885		let restrict_hyps ?(refine=false) evd evk filter =
	1169	let filter_candidates evd evk filter candidates =
	1170	let evi = Evd.find_undefined evd evk in
	1171	let candidates = match candidates with
	1172	\| None -> evi.evar_candidates
	1173	\| Some _ -> candidates in
	1174	match candidates,filter with
	1175	\| None,_ \| _, None -> candidates
	1176	\| Some l, Some filter ->
	1177	let ids = List.map pi1 (list_filter_with filter (evar_context evi)) in
	1178	Some (List.filter (fun a ->
	1179	list_subset (Idset.elements (collect_vars a)) ids) l)
	1180
	1181	let closure_of_filter evd evk filter =
	1182	let evi = Evd.find_undefined evd evk in
	1183	let vars = collect_vars (evar_concl evi) in
	1184	let ids = List.map pi1 (evar_context evi) in
	1185	let test id b = b \|\| Idset.mem id vars in
	1186	let newfilter = List.map2 test ids filter in
	1187	if newfilter = evar_filter evi then None else Some newfilter
	1188
	1189	let restrict_hyps evd evk filter candidates =
886	1190	(* What to do with dependencies?
887	1191	Assume we have x:A, y:B(x), z:C(x,y) \|- ?e:T(x,y,z) and restrict on y.
888	1192	- If y is in a non-erasable position in C(x,y) (i.e. it is not below an

893	1197	interest for this early detection in practice is not obvious. We let
894	1198	it for future work. In any case, thanks to the use of filters, the whole
895	1199	(unrestricted) context remains consistent. *)
896		let evi = Evd.find evd evk in
897		let env = evar_unfiltered_env evi in
898		let oldfilter = evar_filter evi in
899		let filter,_ = List.fold_right (fun oldb (l,filter) ->
900		if oldb then List.hd filter::l,List.tl filter else (false::l,filter))
901		oldfilter ([], List.rev filter) in
902		let filter, ccl = check_restricted_occur evd refine (named_context env) filter evi.evar_concl in
903		(env,evar_source evk evd,filter,ccl)
904
905		let do_restrict_hyps evd evk projs =
906		let filter = List.map filter_of_projection projs in
907		if List.for_all (fun x -> x) filter then
908		evd,evk
909		else
910		let env,src,filter,ccl = restrict_hyps evd evk filter in
911		if List.for_all (fun x -> x) filter then
912		evd,evk
913		else
914		let evd,nc = new_evar evd env ~src ~filter ccl in
915		let evd = Evd.define evk nc evd in
916		let evk',_ = destEvar nc in
917		evd,evk'
918
919		(* [postpone_evar_term] postpones an equation of the form ?e[σ] = c *)
920
921		let postpone_evar_term env evd (evk,argsv) rhs =
922		assert (isVar rhs or isRel rhs);
	1200	let candidates = filter_candidates evd evk (Some filter) candidates in
	1201	let typablefilter = closure_of_filter evd evk filter in
	1202	(typablefilter,candidates)
	1203
	1204	exception EvarSolvedWhileRestricting of evar_map * constr
	1205
	1206	let do_restrict_hyps evd (evk,args as ev) filter candidates =
	1207	let filter,candidates = match filter with
	1208	\| None -> None,candidates
	1209	\| Some filter -> restrict_hyps evd evk filter candidates in
	1210	match candidates,filter with
	1211	\| Some [], _ -> error "Not solvable."
	1212	\| Some [nc],_ ->
	1213	let evd = Evd.define evk nc evd in
	1214	raise (EvarSolvedWhileRestricting (evd,whd_evar evd (mkEvar ev)))
	1215	\| None, None -> evd,ev
	1216	\| _ -> restrict_applied_evar evd ev filter candidates
	1217
	1218	(* [postpone_non_unique_projection] postpones equation of the form ?e[?] = c *)
	1219	(* ?e is assumed to have no candidates *)
	1220
	1221	let postpone_non_unique_projection env evd (evk,argsv as ev) sols rhs =
923	1222	let rhs = expand_vars_in_term env rhs in
924		let evi = Evd.find evd evk in
925		let evd,evk,args =
926		restrict_upon_filter evd evi evk
927		(* Keep only variables that depends in rhs *)
	1223	let filter =
	1224	restrict_upon_filter evd evk
	1225	(* Keep only variables that occur in rhs *)
928	1226	(* This is not safe: is the variable is a local def, its body *)
929	1227	(* may contain references to variables that are removed, leading to *)
930	1228	(* a ill-formed context. We would actually need a notion of filter *)
931	1229	(* that says that the body is hidden. Note that expand_vars_in_term *)
932	1230	(* expands only rels and vars aliases, not rels or vars bound to an *)
933	1231	(* arbitrary complex term *)
934		(fun a -> not (isRel a \|\| isVar a) \|\| dependent a rhs)
	1232	(fun a -> not (isRel a \|\| isVar a)
	1233	\|\| dependent a rhs \|\| List.exists (fun (id,_) -> isVarId id a) sols)
935	1234	(Array.to_list argsv) in
936		let args = Array.of_list args in
937		let pb = (Reduction.CONV,env,mkEvar(evk,args),rhs) in
938		Evd.add_conv_pb pb evd
939
940		(* [postpone_evar_evar] postpones an equation of the form ?e1[σ1] = ?e2[σ2] *)
941
942		let postpone_evar_evar env evd projs1 (evk1,args1) projs2 (evk2,args2) =
	1235	let filter = match filter with
	1236	\| None -> None
	1237	\| Some filter -> closure_of_filter evd evk filter in
	1238	let candidates = extract_candidates sols in
	1239	if candidates <> None then
	1240	restrict_evar evd evk filter candidates
	1241	else
	1242	(* We made an approximation by not expanding a local definition *)
	1243	let evd,ev = restrict_applied_evar evd ev filter None in
	1244	let pb = (Reduction.CONV,env,mkEvar ev,rhs) in
	1245	Evd.add_conv_pb pb evd
	1246
	1247	(* [postpone_evar_evar] postpones an equation of the form ?e1[?1] = ?e2[?2] *)
	1248
	1249	let postpone_evar_evar f env evd filter1 ev1 filter2 ev2 =
943	1250	(* Leave an equation between (restrictions of) ev1 andv ev2 *)
944		let args1' = filter_along filter_of_projection projs1 args1 in
945		let evd,evk1' = do_restrict_hyps evd evk1 projs1 in
946		let args2' = filter_along filter_of_projection projs2 args2 in
947		let evd,evk2' = do_restrict_hyps evd evk2 projs2 in
948		let pb = (Reduction.CONV,env,mkEvar(evk1',args1'),mkEvar (evk2',args2')) in
949		add_conv_pb pb evd
	1251	try
	1252	let evd,ev1' = do_restrict_hyps evd ev1 filter1 None in
	1253	try
	1254	let evd,ev2' = do_restrict_hyps evd ev2 filter2 None in
	1255	add_conv_pb (Reduction.CONV,env,mkEvar ev1',mkEvar ev2') evd
	1256	with EvarSolvedWhileRestricting (evd,ev2) ->
	1257	(* ev2 solved on the fly *)
	1258	f env evd ev1' ev2
	1259	with EvarSolvedWhileRestricting (evd,ev1) ->
	1260	(* ev1 solved on the fly *)
	1261	f env evd ev2 ev1
950	1262
951	1263	(* [solve_evar_evar f Γ Σ ?e1[u1..un] ?e2[v1..vp]] applies an heuristic
952	1264	* to solve the equation Σ; Γ ⊢ ?e1[u1..un] = ?e2[v1..vp]:
953	1265	* - if there are at most one φj for each vj s.t. vj = φj(u1..un),
954		* we first restrict ?2 to the subset v_k1..v_kq of the vj that are
955		* inversible and we set ?1[x1..xn] := ?2[φk1(x1..xn)..φkp(x1..xn)]
	1266	* we first restrict ?e2 to the subset v_k1..v_kq of the vj that are
	1267	* inversible and we set ?e1[x1..xn] := ?e2[φk1(x1..xn)..φkp(x1..xn)]
	1268	* (this is a case of pattern-unification)
956	1269	* - symmetrically if there are at most one ψj for each uj s.t.
957	1270	* uj = ψj(v1..vp),
958	1271	* - otherwise, each position i s.t. ui does not occur in v1..vp has to

970	1283	let n2 = Array.length args2 in
971	1284	let rec aux n = function
972	1285	\| (id,_,c)::sign
973		when n < n1 && isVar args1.(n) && destVar args1.(n) = id && eq_constr args1.(n) args2.(n) ->
	1286	when n < n1 && isVarId id args1.(n) && isVarId id args2.(n) ->
974	1287	aux (n+1) sign
975	1288	\| [] ->
976	1289	let rec aux2 n =
977	1290	n = n1 \|\|
978		(isRel args1.(n) && destRel args1.(n) = n1-n &&
979		isRel args2.(n) && destRel args2.(n) = n1-n && aux2 (n+1))
	1291	(isRelN (n1-n) args1.(n) && isRelN (n1-n) args2.(n) && aux2 (n+1))
980	1292	in aux2 n
981	1293	\| _ -> false in
982	1294	n1 = n2 & aux 0 (named_context env)
983	1295
984		exception CannotProject of projectibility_status list
985
986		let is_variable_subst args =
987		array_for_all (fun c -> isRel c \|\| isVar c) args
988
989		let solve_evar_evar_l2r f env evd (evk1,args1) (evk2,args2 as ev2) =
990		let aliases = make_alias_map env in
991		let subst,_ = make_projectable_subst aliases evd (Evd.find evd evk2) args2 in
	1296	let filter_compatible_candidates conv_algo env evd evi args rhs c =
	1297	let c' = instantiate_evar (evar_filtered_context evi) c args in
	1298	let evd, b = conv_algo env evd Reduction.CONV rhs c' in
	1299	if b then Some (c,evd) else None
	1300
	1301	exception DoesNotPreserveCandidateRestriction
	1302
	1303	let restrict_candidates conv_algo env evd filter1 (evk1,argsv1) (evk2,argsv2) =
	1304	let evi1 = Evd.find evd evk1 in
	1305	let evi2 = Evd.find evd evk2 in
	1306	let cand1 = filter_candidates evd evk1 filter1 None in
	1307	let cand2 = evi2.evar_candidates in
	1308	match cand1, cand2 with
	1309	\| _, None -> cand1
	1310	\| None, Some _ -> raise DoesNotPreserveCandidateRestriction
	1311	\| Some l1, Some l2 ->
	1312	let args1 = Array.to_list argsv1 in
	1313	let args2 = Array.to_list argsv2 in
	1314	let l1' = List.filter (fun c1 ->
	1315	let c1' = instantiate_evar (evar_filtered_context evi1) c1 args1 in
	1316	List.filter (fun c2 ->
	1317	(filter_compatible_candidates conv_algo env evd evi2 args2 c1' c2
	1318	<> None)) l2 <> []) l1 in
	1319	if List.length l1 = List.length l1' then None else Some l1'
	1320
	1321	exception CannotProject of bool list option
	1322
	1323	(* Assume that FV(?n[x1:=t1..xn:=tn]) belongs to some set U.
	1324	Can ?n be instantiated by a term u depending essentially on xi such that the
	1325	FV(u[x1:=t1..xn:=tn]) are in the set U?
	1326	- If ti is a variable, it has to be in U.
	1327	- If ti is a constructor, its parameters cannot be erased even if u
	1328	matches on it, so we have to discard ti if the parameters
	1329	contain variables not in U.
	1330	- If ti is rigid, we have to discard it if it contains variables in U.
	1331
	1332	Note: when restricting as part of an equation ?n[x1:=t1..xn:=tn] = ?m[...]
	1333	then, occurrences of ?m in the ti can be seen, like variables, as occurrences
	1334	of subterms to eventually discard so as to be allowed to keep ti.
	1335	*)
	1336
	1337	let rec is_constrainable_in k (ev,(fv_rels,fv_ids) as g) t =
	1338	let f,args = decompose_app_vect t in
	1339	match kind_of_term f with
	1340	\| Construct (ind,_) ->
	1341	let nparams = (fst (Global.lookup_inductive ind)).Declarations.mind_nparams in
	1342	let params,_ = array_chop nparams args in
	1343	array_for_all (is_constrainable_in k g) params
	1344	\| Ind _ -> array_for_all (is_constrainable_in k g) args
	1345	\| Prod (_,t1,t2) -> is_constrainable_in k g t1 && is_constrainable_in k g t2
	1346	\| Evar (ev',_) -> ev' <> ev (If ev' needed, one may also try to restrict it)
	1347	\| Var id -> Idset.mem id fv_ids
	1348	\| Rel n -> n <= k \|\| Intset.mem n fv_rels
	1349	\| Sort _ -> true
	1350	\| _ -> (* We don't try to be more clever *) true
	1351
	1352	let has_constrainable_free_vars evd aliases k ev (fv_rels,fv_ids as fvs) t =
	1353	let t = expansion_of_var aliases t in
	1354	match kind_of_term t with
	1355	\| Var id -> Idset.mem id fv_ids
	1356	\| Rel n -> n <= k \|\| Intset.mem n fv_rels
	1357	\| _ -> is_constrainable_in k (ev,fvs) t
	1358
	1359	let ensure_evar_independent g env evd (evk1,argsv1 as ev1) (evk2,argsv2 as ev2)=
	1360	let filter1 =
	1361	restrict_upon_filter evd evk1 (noccur_evar evd evk2) (Array.to_list argsv1)
	1362	in
	1363	let candidates1 = restrict_candidates g env evd filter1 ev1 ev2 in
	1364	let evd,(evk1,_ as ev1) = do_restrict_hyps evd ev1 filter1 candidates1 in
	1365	let filter2 =
	1366	restrict_upon_filter evd evk2 (noccur_evar evd evk1) (Array.to_list argsv2)
	1367	in
	1368	let candidates2 = restrict_candidates g env evd filter2 ev2 ev1 in
	1369	let evd,ev2 = do_restrict_hyps evd ev2 filter2 candidates2 in
	1370	evd,ev1,ev2
	1371
	1372	exception EvarSolvedOnTheFly of evar_map * constr
	1373
	1374	let project_evar_on_evar g env evd aliases k2 (evk1,argsv1 as ev1) (evk2,argsv2 as ev2) =
	1375	(* Apply filtering on ev1 so that fvs(ev1) are in fvs(ev2). *)
	1376	let fvs2 = free_vars_and_rels_up_alias_expansion aliases (mkEvar ev2) in
	1377	let filter1 = restrict_upon_filter evd evk1
	1378	(has_constrainable_free_vars evd aliases k2 evk2 fvs2)
	1379	(Array.to_list argsv1) in
	1380	(* Only try pruning on variable substitutions, postpone otherwise. *)
	1381	(* Rules out non-linear instances. *)
	1382	if is_unification_pattern_pure_evar env evd ev2 (mkEvar ev1) then
	1383	try
	1384	let candidates1 = restrict_candidates g env evd filter1 ev1 ev2 in
	1385	let evd,(evk1',args1) = do_restrict_hyps evd ev1 filter1 candidates1 in
	1386	evd,mkEvar (evk1',invert_invertible_arg evd aliases k2 ev2 args1)
	1387	with
	1388	\| EvarSolvedWhileRestricting (evd,ev1) ->
	1389	raise (EvarSolvedOnTheFly (evd,ev1))
	1390	\| DoesNotPreserveCandidateRestriction \| NotEnoughInformationToInvert ->
	1391	raise (CannotProject filter1)
	1392	else
	1393	raise (CannotProject filter1)
	1394
	1395	let solve_evar_evar_l2r f g env evd aliases ev1 (evk2,_ as ev2) =
	1396	try
	1397	let evd,body = project_evar_on_evar g env evd aliases 0 ev1 ev2 in
	1398	Evd.define evk2 body evd
	1399	with EvarSolvedOnTheFly (evd,c) ->
	1400	f env evd ev2 c
	1401
	1402	let solve_evar_evar ?(force=false) f g env evd (evk1,args1 as ev1) (evk2,args2 as ev2) =
992	1403	if are_canonical_instances args1 args2 env then
993	1404	(* If instances are canonical, we solve the problem in linear time *)
994	1405	let sign = evar_filtered_context (Evd.find evd evk2) in
995		let subst = List.map (fun (id,_,_) -> mkVar id) sign in
996		Evd.define evk2 (mkEvar(evk1,Array.of_list subst)) evd
	1406	let id_inst = list_map_to_array (fun (id,_,_) -> mkVar id) sign in
	1407	Evd.define evk2 (mkEvar(evk1,id_inst)) evd
997	1408	else
998		(* Only try pruning on variable substitutions, postpone otherwise. *)
999		if is_variable_subst args1 && is_variable_subst args2 then
1000		let proj1 = array_map_to_list (invert_arg aliases 0 evd evk2 subst) args1 in
1001		try
1002		(* Instantiate ev2 with (a restriction of) ev1 if uniquely projectable.
1003		Rules out non-linear instances. *)
1004		let proj1' = effective_projections proj1 in
1005		let evd,args1' =
1006		list_fold_map (instance_of_projection f env (mkEvar ev2)) evd proj1' in
1007		let evd,evk1' = do_restrict_hyps evd evk1 proj1 in
1008		Evd.define evk2 (mkEvar(evk1',Array.of_list args1')) evd
1009		with NotUnique -> raise (CannotProject proj1)
1010		else raise IllTypedFilter
1011
1012		let solve_evar_evar f env evd ev1 ev2 =
1013		try
1014		try solve_evar_evar_l2r f env evd ev1 ev2
1015		with CannotProject projs1 ->
1016		try solve_evar_evar_l2r f env evd ev2 ev1
1017		with CannotProject projs2 ->
1018		postpone_evar_evar env evd projs1 ev1 projs2 ev2
1019		with IllTypedFilter ->
1020		let pb = (Reduction.CONV,env,mkEvar(ev1),mkEvar (ev2)) in
1021		add_conv_pb pb evd
	1409	let evd,ev1,ev2 =
	1410	(* If an evar occurs in the instance of the other evar and the
	1411	use of an heuristic is forced, we restrict *)
	1412	if force then ensure_evar_independent g env evd ev1 ev2 else (evd,ev1,ev2) in
	1413	let aliases = make_alias_map env in
	1414	try solve_evar_evar_l2r f g env evd aliases ev1 ev2
	1415	with CannotProject filter1 ->
	1416	try solve_evar_evar_l2r f g env evd aliases ev2 ev1
	1417	with CannotProject filter2 ->
	1418	postpone_evar_evar f env evd filter1 ev1 filter2 ev2
1022	1419
1023	1420	type conv_fun =
1024	1421	env -> evar_map -> conv_pb -> constr -> constr -> evar_map * bool

1036	1433	user_err_loc (fst (evar_source evk1 evd),"",
1037	1434	str "Unable to find a well-typed instantiation")
1038	1435
1039		(* Solve pbs (?i x1..xn) = (?i y1..yn) which arises often in fixpoint
1040		* definitions. We try to unify the xi with the yi pairwise. The pairs
1041		* that don't unify are discarded (i.e. ?i is redefined so that it does not
	1436	(* Solve pbs ?e[t1..tn] = ?e[u1..un] which arise often in fixpoint
	1437	* definitions. We try to unify the ti with the ui pairwise. The pairs
	1438	* that don't unify are discarded (i.e. ?e is redefined so that it does not
1042	1439	* depend on these args). *)
1043	1440
1044		let solve_refl conv_algo env evd evk argsv1 argsv2 =
	1441	let solve_refl ?(can_drop=false) conv_algo env evd evk argsv1 argsv2 =
1045	1442	if array_equal eq_constr argsv1 argsv2 then evd else
1046		let evi = Evd.find_undefined evd evk in
1047	1443	(* Filter and restrict if needed *)
1048		let evd,evk,args =
1049		restrict_upon_filter evd evi evk
	1444	let untypedfilter =
	1445	restrict_upon_filter evd evk
1050	1446	(fun (a1,a2) -> snd (conv_algo env evd Reduction.CONV a1 a2))
1051	1447	(List.combine (Array.to_list argsv1) (Array.to_list argsv2)) in
	1448	let candidates = filter_candidates evd evk untypedfilter None in
	1449	let filter = match untypedfilter with
	1450	\| None -> None
	1451	\| Some filter -> closure_of_filter evd evk filter in
	1452	let evd,ev1 = restrict_applied_evar evd (evk,argsv1) filter candidates in
	1453	if fst ev1 = evk & can_drop then (* No refinement *) evd else
	1454	(* either progress, or not allowed to drop, e.g. to preserve possibly *)
	1455	(* informative equations such as ?e[x:=?y]=?e[x:=?y'] where we don't know *)
	1456	(* if e can depend on x until ?y is not resolved, or, conversely, we *)
	1457	(* don't know if ?y has to be unified with ?y, until e is resolved *)
	1458	let argsv2 = restrict_instance evd evk filter argsv2 in
	1459	let ev2 = (fst ev1,argsv2) in
1052	1460	(* Leave a unification problem *)
1053		let args1,args2 = List.split args in
1054		let argsv1 = Array.of_list args1 and argsv2 = Array.of_list args2 in
1055		let pb = (Reduction.CONV,env,mkEvar(evk,argsv1),mkEvar(evk,argsv2)) in
1056		Evd.add_conv_pb pb evd
	1461	Evd.add_conv_pb (Reduction.CONV,env,mkEvar ev1,mkEvar ev2) evd
1057	1462
1058	1463	(* If the evar can be instantiated by a finite set of candidates known
1059	1464	in advance, we check which of them apply *)

1066	1471	match evi.evar_candidates with
1067	1472	\| None -> raise NoCandidates
1068	1473	\| Some l ->
1069		let l' = list_map_filter (fun c ->
1070		let c' = instantiate_evar (evar_filtered_context evi) c args in
1071		let evd, b = conv_algo env evd Reduction.CONV c' rhs in
1072		if b then Some (c,evd) else None) l in
	1474	let l' =
	1475	list_map_filter
	1476	(filter_compatible_candidates conv_algo env evd evi args rhs) l in
1073	1477	match l' with
1074	1478	\| [] -> error_cannot_unify env evd (mkEvar ev, rhs)
1075	1479	\| [c,evd] -> Evd.define evk c evd
1076	1480	\| l when List.length l < List.length l' ->
1077	1481	let candidates = List.map fst l in
1078		let filter = evar_filter evi in
1079		let sign = evar_hyps evi in
1080		let ids = List.map pi1 (named_context_of_val sign) in
1081		let inst_in_sign =
1082		List.map mkVar (snd (list_filter2 (fun b id -> b) (filter,ids))) in
1083		let evd,evar = new_evar_instance (evar_hyps evi) evd (evar_concl evi)
1084		~filter ~candidates inst_in_sign in
1085		Evd.define evk evar evd
	1482	restrict_evar evd evk None (Some candidates)
1086	1483	\| l -> evd
1087	1484
1088	1485	(* We try to instantiate the evar assuming the body won't depend

1109	1506	*)
1110	1507
1111	1508	exception NotInvertibleUsingOurAlgorithm of constr
1112		exception NotEnoughInformationToProgress
	1509	exception NotEnoughInformationToProgress of (identifier * evar_projection) list
1113	1510	exception OccurCheckIn of evar_map * constr
1114	1511
1115	1512	let rec invert_definition conv_algo choose env evd (evk,argsv as ev) rhs =

1128	1525	\| [] -> raise Not_found
1129	1526	\| [id,p] -> (mkVar id, p)
1130	1527	\| (id,p)::_::_ ->
1131		if choose then (mkVar id, p)
1132		else raise (NotUniqueInType(find_solution_type (evar_env evi) sols))
	1528	if choose then (mkVar id, p) else raise (NotUniqueInType sols)
1133	1529	in
1134	1530	let ty = lazy (Retyping.get_type_of env !evdref t) in
1135	1531	let evd = do_projection_effects (evar_define conv_algo) env ty !evdref p in

1137	1533	c
1138	1534	with
1139	1535	\| Not_found -> raise (NotInvertibleUsingOurAlgorithm t)
1140		\| NotUniqueInType ty ->
1141		if not !progress then raise NotEnoughInformationToProgress;
	1536	\| NotUniqueInType sols ->
	1537	if not !progress then
	1538	raise (NotEnoughInformationToProgress sols);
1142	1539	(* No unique projection but still restrict to where it is possible *)
1143	1540	(* materializing is necessary, but is restricting useful? *)
	1541	let ty = find_solution_type (evar_env evi) sols in
1144	1542	let sign = evar_filtered_context evi in
1145	1543	let ty' = instantiate_evar sign ty (Array.to_list argsv) in
1146		let (evd,_,ev') =
	1544	let (evd,evar,(evk',argsv' as ev')) =
1147	1545	materialize_evar (evar_define conv_algo) env !evdref 0 ev ty' in
1148	1546	let ts = expansions_of_var aliases t in
1149	1547	let test c = isEvar c or List.mem c ts in
1150		let filter = array_map_to_list test argsv in
1151		let evarenv,src,filter,_ = restrict_hyps ~refine:true evd (fst ev') filter in
1152		let args' = filter_along (fun x -> x) filter argsv in
1153		let evd,evar = new_evar !evdref evarenv ~src ~filter ty in
1154		let evk',_ = destEvar evar in
1155		let pb = (Reduction.CONV,env,mkEvar(evk',args'),t) in
1156		evdref := Evd.add_conv_pb pb evd;
	1548	let filter = array_map_to_list test argsv' in
	1549	let filter = apply_subfilter (evar_filter (Evd.find_undefined evd evk)) filter in
	1550
	1551	let filter = closure_of_filter evd evk' filter in
	1552	let candidates = extract_candidates sols in
	1553	let evd =
	1554	if candidates <> None then restrict_evar evd evk' filter candidates
	1555	else
	1556	let evd,ev'' = restrict_applied_evar evd ev' filter None in
	1557	Evd.add_conv_pb (Reduction.CONV,env,mkEvar ev'',t) evd in
	1558	evdref := evd;
1157	1559	evar in
1158	1560
1159	1561	let rec imitate (env',k as envk) t =
1160	1562	let t = whd_evar !evdref t in
1161	1563	match kind_of_term t with
1162		\| Rel i when i>k -> project_variable (mkRel (i-k))
1163		\| Var id -> project_variable t
	1564	\| Rel i when i>k ->
	1565	(match pi2 (Environ.lookup_rel (i-k) env') with
	1566	\| None -> project_variable (mkRel (i-k))
	1567	\| Some b ->
	1568	try project_variable (mkRel (i-k))
	1569	with NotInvertibleUsingOurAlgorithm _ -> imitate envk (lift i b))
	1570	\| Var id ->
	1571	(match pi2 (Environ.lookup_named id env') with
	1572	\| None -> project_variable t
	1573	\| Some b ->
	1574	try project_variable t
	1575	with NotInvertibleUsingOurAlgorithm _ -> imitate envk b)
1164	1576	\| Evar (evk',args' as ev') ->
1165	1577	if evk = evk' then raise (OccurCheckIn (evd,rhs));
1166	1578	(* Evar/Evar problem (but left evar is virtual) *)
1167		let projs' =
1168		array_map_to_list
1169		(invert_arg_from_subst aliases k !evdref subst) args'
1170		in
1171		(try
1172		(* Try to project (a restriction of) the right evar *)
1173		let eprojs' = effective_projections projs' in
1174		let evd,args' =
1175		list_fold_map (instance_of_projection (evar_define conv_algo) env' t)
1176		!evdref eprojs' in
1177		let evd,evk' = do_restrict_hyps evd evk' projs' in
1178		evdref := evd;
1179		mkEvar (evk',Array.of_list args')
1180		with NotUnique \| IllTypedFilter ->
1181		assert !progress;
1182		(* Make the virtual left evar real *)
1183		let ty = get_type_of env' !evdref t in
1184		let (evd,evar'',ev'') =
	1579	let aliases = lift_aliases k aliases in
	1580	(try
	1581	let ev = (evk,Array.map (lift k) argsv) in
	1582	let evd,body = project_evar_on_evar conv_algo env !evdref aliases k ev' ev in
	1583	evdref := evd;
	1584	body
	1585	with
	1586	\| EvarSolvedOnTheFly (evd,t) -> evdref:=evd; imitate envk t
	1587	\| CannotProject filter' ->
	1588	assert !progress;
	1589	(* Make the virtual left evar real *)
	1590	let ty = get_type_of env' !evdref t in
	1591	let (evd,evar'',ev'') =
1185	1592	materialize_evar (evar_define conv_algo) env' !evdref k ev ty in
1186		(try
1187		let evd =
1188		(* Try to project (a restriction of) the left evar ... *)
1189		try solve_evar_evar_l2r (evar_define conv_algo) env' evd ev'' ev'
1190		with CannotProject projs'' ->
1191		(* ... or postpone the problem *)
1192		postpone_evar_evar env' evd projs'' ev'' projs' ev'
1193		in
1194		evdref := evd;
1195		evar''
1196		with IllTypedFilter -> raise (NotInvertibleUsingOurAlgorithm t)))
	1593	let evd =
	1594	(* Try to project (a restriction of) the left evar ... *)
	1595	try
	1596	let evd,body = project_evar_on_evar conv_algo env' evd aliases 0 ev'' ev' in
	1597	Evd.define evk' body evd
	1598	with
	1599	\| EvarSolvedOnTheFly _ -> assert false (* ev has no candidates *)
	1600	\| CannotProject filter'' ->
	1601	(* ... or postpone the problem *)
	1602	postpone_evar_evar (evar_define conv_algo) env' evd filter'' ev'' filter' ev' in
	1603	evdref := evd;
	1604	evar'')
1197	1605	\| _ ->
	1606	progress := true;
1198	1607	match
1199	1608	let c,args = decompose_app_vect t in
1200	1609	match kind_of_term c with

1204	1613	(* possible inversions; we do not treat overlap with a possible *)
1205	1614	(* alternative inversion of the subterms of the constructor, etc)*)
1206	1615	(match find_projectable_constructor env evd cstr k args cstr_subst with
1207		\| [id] -> Some (mkVar id)
	1616	\| _::_ as l -> Some (List.map mkVar l)
1208	1617	\| _ -> None)
1209	1618	\| _ -> None
1210	1619	with
1211		\| Some c -> c
	1620	\| Some l ->
	1621	let ty = get_type_of env' !evdref t in
	1622	let candidates =
	1623	try
	1624	let t =
	1625	map_constr_with_full_binders (fun d (env,k) -> push_rel d env, k+1)
	1626	imitate envk t in
	1627	t::l
	1628	with _ -> l in
	1629	(match candidates with
	1630	\| [x] -> x
	1631	\| _ ->
	1632	let (evd,evar'',ev'') =
	1633	materialize_evar (evar_define conv_algo) env' !evdref k ev ty in
	1634	evdref := restrict_evar evd (fst ev'') None (Some candidates);
	1635	evar'')
1212	1636	\| None ->
1213		progress := true;
1214	1637	(* Evar/Rigid problem (or assimilated if not normal): we "imitate" *)
1215		map_constr_with_full_binders (fun d (env,k) -> push_rel d env, k+1)
1216		imitate envk t in
	1638	map_constr_with_full_binders (fun d (env,k) -> push_rel d env, k+1)
	1639	imitate envk t in
1217	1640
1218	1641	let rhs = whd_beta evd rhs (* heuristic *) in
1219	1642	let body = imitate (env,0) rhs in

1229	1652	and evar_define conv_algo ?(choose=false) env evd (evk,argsv as ev) rhs =
1230	1653	match kind_of_term rhs with
1231	1654	\| Evar (evk2,argsv2 as ev2) ->
1232		if evk = evk2 then solve_refl conv_algo env evd evk argsv argsv2
1233		else solve_evar_evar (evar_define conv_algo) env evd ev ev2
	1655	if evk = evk2 then
	1656	solve_refl ~can_drop:choose conv_algo env evd evk argsv argsv2
	1657	else
	1658	solve_evar_evar ~force:choose
	1659	(evar_define conv_algo) conv_algo env evd ev ev2
1234	1660	\| _ ->
1235	1661	try solve_candidates conv_algo env evd ev rhs
1236	1662	with NoCandidates ->

1261	1687	let evd' = Evd.define evk body evd' in
1262	1688	check_evar_instance evd' evk body conv_algo
1263	1689	with
1264		\| NotEnoughInformationToProgress ->
1265		postpone_evar_term env evd ev rhs
	1690	\| NotEnoughInformationToProgress sols ->
	1691	postpone_non_unique_projection env evd ev sols rhs
1266	1692	\| NotInvertibleUsingOurAlgorithm t ->
1267	1693	error_not_clean env evd evk t (evar_source evk evd)
1268	1694	\| OccurCheckIn (evd,rhs) ->

1275	1701	env evd evk argsv argsv2
1276	1702	\| _ ->
1277	1703	error_occur_check env evd evk rhs
1278
1279		(-------------------)
1280		(* Auxiliary functions for the conversion algorithms modulo evars
1281		*)
1282
1283		let has_undefined_evars_or_sorts evd t =
1284		let rec has_ev t =
1285		match kind_of_term t with
1286		\| Evar (ev,args) ->
1287		(match evar_body (Evd.find evd ev) with
1288		\| Evar_defined c ->
1289		has_ev c; Array.iter has_ev args
1290		\| Evar_empty ->
1291		raise NotInstantiatedEvar)
1292		\| Sort s when is_sort_variable evd s -> raise Not_found
1293		\| _ -> iter_constr has_ev t in
1294		try let _ = has_ev t in false
1295		with (Not_found \| NotInstantiatedEvar) -> true
1296
1297		let is_ground_term evd t =
1298		not (has_undefined_evars_or_sorts evd t)
1299
1300		let is_ground_env evd env =
1301		let is_ground_decl = function
1302		(_,Some b,_) -> is_ground_term evd b
1303		\| _ -> true in
1304		List.for_all is_ground_decl (rel_context env) &&
1305		List.for_all is_ground_decl (named_context env)
1306		(* Memoization is safe since evar_map and environ are applicative
1307		structures *)
1308		let is_ground_env = memo1_2 is_ground_env
1309
1310		(* Return the head evar if any *)
1311
1312		exception NoHeadEvar
1313
1314		let head_evar =
1315		let rec hrec c = match kind_of_term c with
1316		\| Evar (evk,_) -> evk
1317		\| Case (_,_,c,_) -> hrec c
1318		\| App (c,_) -> hrec c
1319		\| Cast (c,_,_) -> hrec c
1320		\| _ -> raise NoHeadEvar
1321		in
1322		hrec
1323
1324		(* Expand head evar if any (currently consider only applications but I
1325		guess it should consider Case too) *)
1326
1327		let whd_head_evar_stack sigma c =
1328		let rec whrec (c, l as s) =
1329		match kind_of_term c with
1330		\| Evar (evk,args as ev) when Evd.is_defined sigma evk
1331		-> whrec (existential_value sigma ev, l)
1332		\| Cast (c,_,_) -> whrec (c, l)
1333		\| App (f,args) -> whrec (f, Array.fold_right (fun a l -> a::l) args l)
1334		\| _ -> s
1335		in
1336		whrec (c, [])
1337
1338		let whd_head_evar sigma c = applist (whd_head_evar_stack sigma c)
1339
1340		let rec expand_and_check_vars aliases = function
1341		\| [] -> []
1342		\| a::l when isRel a or isVar a ->
1343		let a = expansion_of_var aliases a in
1344		if isRel a or isVar a then a :: expand_and_check_vars aliases l
1345		else raise Exit
1346		\| _ ->
1347		raise Exit
1348
1349		module Constrhash = Hashtbl.Make
1350		(struct type t = constr
1351		let equal = eq_constr
1352		let hash = hash_constr
1353		end)
1354
1355		let rec constr_list_distinct l =
1356		let visited = Constrhash.create 23 in
1357		let rec loop = function
1358		\| h::t ->
1359		if Constrhash.mem visited h then false
1360		else (Constrhash.add visited h h; loop t)
1361		\| [] -> true
1362		in loop l
1363
1364		let get_actual_deps aliases l t =
1365		if occur_meta_or_existential t then
1366		(* Probably no restrictions on allowed vars in presence of evars *)
1367		l
1368		else
1369		(* Probably strong restrictions coming from t being evar-closed *)
1370		let (fv_rels,fv_ids) = free_vars_and_rels_up_alias_expansion aliases t in
1371		List.filter (fun c ->
1372		match kind_of_term c with
1373		\| Var id -> Idset.mem id fv_ids
1374		\| Rel n -> Intset.mem n fv_rels
1375		\| _ -> assert false) l
1376
1377		let remove_instance_local_defs evd evk args =
1378		let evi = Evd.find evd evk in
1379		let rec aux = function
1380		\| (_,Some _,_)::sign, a::args -> aux (sign,args)
1381		\| (_,None,_)::sign, a::args -> a::aux (sign,args)
1382		\| [], [] -> []
1383		\| _ -> assert false in
1384		aux (evar_filtered_context evi, args)
1385
1386		(* Check if an applied evar "?X[args] l" is a Miller's pattern *)
1387
1388		let find_unification_pattern_args env l t =
1389		if List.for_all (fun x -> isRel x \|\| isVar x) l (* common failure case *) then
1390		let aliases = make_alias_map env in
1391		match (try Some (expand_and_check_vars aliases l) with Exit -> None) with
1392		\| Some l as x when constr_list_distinct (get_actual_deps aliases l t) -> x
1393		\| _ -> None
1394		else
1395		None
1396
1397		let is_unification_pattern_meta env nb m l t =
1398		(* Variables from context and rels > nb are implicitly all there *)
1399		(* so we need to be a rel <= nb *)
1400		if List.for_all (fun x -> isRel x && destRel x <= nb) l then
1401		match find_unification_pattern_args env l t with
1402		\| Some _ as x when not (dependent (mkMeta m) t) -> x
1403		\| _ -> None
1404		else
1405		None
1406
1407		let is_unification_pattern_evar env evd (evk,args) l t =
1408		if List.for_all (fun x -> isRel x \|\| isVar x) l (* common failure case *) then
1409		let args = remove_instance_local_defs evd evk (Array.to_list args) in
1410		let n = List.length args in
1411		match find_unification_pattern_args env (args @ l) t with
1412		\| Some l when not (occur_evar evk t) -> Some (list_skipn n l)
1413		\| _ -> None
1414		else
1415		None
1416
1417		let is_unification_pattern (env,nb) evd f l t =
1418		match kind_of_term f with
1419		\| Meta m -> is_unification_pattern_meta env nb m l t
1420		\| Evar ev -> is_unification_pattern_evar env evd ev l t
1421		\| _ -> None
1422
1423		(* From a unification problem "?X l = c", build "\x1...xn.(term1 l2)"
1424		(pattern unification). It is assumed that l is made of rel's that
1425		are distinct and not bound to aliases. *)
1426		(* It is also assumed that c does not contain metas because metas
1427		implicitly depend on Vars but lambda abstraction will not reflect this
1428		dependency: ?X x = ?1 (?1 is a meta) will return \_.?1 while it should
1429		return \y. ?1{x\y} (non constant function if ?1 depends on x) (BB) *)
1430		let solve_pattern_eqn env l c =
1431		let c' = List.fold_right (fun a c ->
1432		let c' = subst_term (lift 1 a) (lift 1 c) in
1433		match kind_of_term a with
1434		(* Rem: if [a] links to a let-in, do as if it were an assumption *)
1435		\| Rel n ->
1436		let d = map_rel_declaration (lift n) (lookup_rel n env) in
1437		mkLambda_or_LetIn d c'
1438		\| Var id ->
1439		let d = lookup_named id env in mkNamedLambda_or_LetIn d c'
1440		\| _ -> assert false)
1441		l c in
1442		(* Warning: we may miss some opportunity to eta-reduce more since c'
1443		is not in normal form *)
1444		whd_eta c'
1445	1704
1446	1705	(* This code (i.e. solve_pb, etc.) takes a unification
1447	1706	* problem, and tries to solve it. If it solves it, then it removes

1623	1882
1624	1883	open Glob_term
1625	1884
	1885	(****************************************)
1626	1886	(* Operations on value/type constraints *)
	1887	(****************************************)
1627	1888
1628	1889	type type_constraint_type = (int * int) option * constr
1629	1890	type type_constraint = type_constraint_type option

1662	1923	(* Builds a value constraint *)
1663	1924	let mk_valcon c = Some c
1664	1925
1665
1666		let new_type_evar ?src ?filter evd env =
1667		let evd', s = new_sort_variable evd in
1668		new_evar evd' env ?src ?filter (mkSort s)
1669	1926
1670	1927	let idx = id_of_string "x"
1671	1928

+5

-1

pretyping/evarutil.mli less more

83	83
84	84	val is_ground_term : evar_map -> constr -> bool
85	85	val is_ground_env : evar_map -> env -> bool
86		val solve_refl : conv_fun -> env -> evar_map ->
	86	val solve_refl : ?can_drop:bool -> conv_fun -> env -> evar_map ->
87	87	existential_key -> constr array -> constr array -> evar_map
	88	val solve_evar_evar : ?force:bool ->
	89	(env -> evar_map -> existential -> constr -> evar_map) -> conv_fun ->
	90	env -> evar_map -> existential -> existential -> evar_map
	91
88	92	val solve_simple_eqn : conv_fun -> ?choose:bool -> env -> evar_map ->
89	93	bool option * existential * constr -> evar_map * bool
90	94	val reconsider_conv_pbs : conv_fun -> evar_map -> evar_map * bool

+9

-1

pretyping/evd.ml less more

777	777	\| Evar_empty -> mt ()
778	778	\| Evar_defined c -> spc() ++ str"=> " ++ print_constr c
779	779	in
	780	let candidates =
	781	match evi.evar_body, evi.evar_candidates with
	782	\| Evar_empty, Some l ->
	783	spc () ++ str "{" ++
	784	prlist_with_sep (fun () -> str "\|") print_constr l ++ str "}"
	785	\| _ ->
	786	mt ()
	787	in
780	788	let src = str "(" ++ pr_evar_source (snd evi.evar_source) ++ str ")" in
781	789	hov 2
782	790	(str"[" ++ phyps ++ spc () ++ str"\|- " ++ pty ++ pb ++ str"]" ++
783		spc() ++ src)
	791	candidates ++ spc() ++ src)
784	792
785	793	let compute_evar_dependency_graph (sigma:evar_map) =
786	794	(* Compute the map binding ev to the evars whose body depends on ev *)

+2

-0

pretyping/evd.mli less more

146	146	there are uninstantiated evars in [sigma]. *)
147	147	val has_undefined : evar_map -> bool
148	148
	149	(** [add sigma ev info] adds [ev] with evar info [info] in sigma.
	150	Precondition: ev must not preexist in [sigma]. *)
149	151	val add : evar_map -> evar -> evar_info -> evar_map
150	152
151	153	val find : evar_map -> evar -> evar_info

+3

-16

pretyping/inductiveops.ml less more

391	391	(* Inferring the sort of parameters of a polymorphic inductive type
392	392	knowing the sort of the conclusion *)
393	393
394		(* Check if u (sort of a parameter) appears in the sort of the
395		inductive (is). This is done by trying to enforce u > u' >= is
396		in the empty univ graph. If an inconsistency appears, then
397		is depends on u. *)
398		let is_constrained is u =
399		try
400		let u' = fresh_local_univ() in
401		let _ =
402		merge_constraints
403		(enforce_geq u (super u')
404		(enforce_geq u' is empty_constraint))
405		initial_universes in
406		false
407		with UniverseInconsistency _ -> true
408
409	394	(* Compute the inductive argument types: replace the sorts
410	395	that appear in the type of the inductive by the sort of the
411	396	conclusion, and the other ones by fresh universes. *)

417	402	\| (na,None,ty)::sign, Some u::exp ->
418	403	let ctx,_ = Reduction.dest_arity env ty in
419	404	let s =
420		if is_constrained is u then
	405	(* Does the sort of parameter [u] appear in (or equal)
	406	the sort of inductive [is] ? *)
	407	if univ_depends u is then
421	408	scl (* constrained sort: replace by scl *)
422	409	else
423	410	(* unconstriained sort: replace by fresh universe *)

+28

-19

pretyping/namegen.ml less more

52	52	let is_constructor id =
53	53	try
54	54	match locate (qualid_of_ident id) with
55		\| ConstructRef _ as ref -> not (is_imported_ref ref)
	55	\| ConstructRef _ -> true
56	56	\| _ -> false
57	57	with Not_found ->
58	58	false

231	231	looks for name of same base with lower available subscript beyond current
232	232	subscript *)
233	233
234		let visibly_occur_id id c =
235		let rec occur c = match kind_of_term c with
	234	let occur_rel p env id =
	235	try lookup_name_of_rel p env = Name id
	236	with Not_found -> false (* Unbound indice : may happen in debug *)
	237
	238	let visibly_occur_id id (nenv,c) =
	239	let rec occur n c = match kind_of_term c with
236	240	\| Const _ \| Ind _ \| Construct _ \| Var _
237	241	when shortest_qualid_of_global Idset.empty (global_of_constr c)
238	242	= qualid_of_ident id -> raise Occur
239		\| _ -> iter_constr occur c
	243	\| Rel p when p>n & occur_rel (p-n) nenv id -> raise Occur
	244	\| _ -> iter_constr_with_binders succ occur n c
240	245	in
241		try occur c; false
	246	try occur 1 c; false
242	247	with Occur -> true
243	248	\| Not_found -> false (* Happens when a global is not in the env *)
244	249
245		let next_ident_away_for_default_printing t id avoid =
246		let bad id = List.mem id avoid or visibly_occur_id id t in
	250	let next_ident_away_for_default_printing env_t id avoid =
	251	let bad id = List.mem id avoid or visibly_occur_id id env_t in
247	252	next_ident_away_from id bad
248	253
249		let next_name_away_for_default_printing t na avoid =
	254	let next_name_away_for_default_printing env_t na avoid =
250	255	let id = match na with
251	256	\| Name id -> id
252	257	\| Anonymous ->

254	259	(* taken into account by the function compute_displayed_name_in; *)
255	260	(* just in case, invent a valid name *)
256	261	id_of_string "H" in
257		next_ident_away_for_default_printing t id avoid
	262	next_ident_away_for_default_printing env_t id avoid
258	263
259	264	(**********************************************************************)
260	265	(* Displaying terms avoiding bound variables clashes *)

277	282	type renaming_flags =
278	283	\| RenamingForCasesPattern
279	284	\| RenamingForGoal
280		\| RenamingElsewhereFor of constr
	285	\| RenamingElsewhereFor of (name list * constr)
281	286
282	287	let next_name_for_display flags =
283	288	match flags with
284	289	\| RenamingForCasesPattern -> next_name_away_in_cases_pattern
285	290	\| RenamingForGoal -> next_name_away_in_goal
286		\| RenamingElsewhereFor t -> next_name_away_for_default_printing t
	291	\| RenamingElsewhereFor env_t -> next_name_away_for_default_printing env_t
287	292
288	293	(* Remark: Anonymous var may be dependent in Evar's contexts *)
289	294	let compute_displayed_name_in flags avoid na c =

305	310	let fresh_id = next_name_for_display flags na avoid in
306	311	(Name fresh_id, fresh_id::avoid)
307	312
308		let rec rename_bound_vars_as_displayed avoid c =
309		let rec rename avoid c =
	313	let rec rename_bound_vars_as_displayed avoid env c =
	314	let rec rename avoid env c =
310	315	match kind_of_term c with
311	316	\| Prod (na,c1,c2) ->
312		let na',avoid' = compute_displayed_name_in (RenamingElsewhereFor c2) avoid na c2 in
313		mkProd (na', c1, rename avoid' c2)
	317	let na',avoid' =
	318	compute_displayed_name_in
	319	(RenamingElsewhereFor (env,c2)) avoid na c2 in
	320	mkProd (na', c1, rename avoid' (add_name na' env) c2)
314	321	\| LetIn (na,c1,t,c2) ->
315		let na',avoid' = compute_displayed_let_name_in (RenamingElsewhereFor c2) avoid na c2 in
316		mkLetIn (na',c1,t, rename avoid' c2)
317		\| Cast (c,k,t) -> mkCast (rename avoid c, k,t)
	322	let na',avoid' =
	323	compute_displayed_let_name_in
	324	(RenamingElsewhereFor (env,c2)) avoid na c2 in
	325	mkLetIn (na',c1,t, rename avoid' (add_name na' env) c2)
	326	\| Cast (c,k,t) -> mkCast (rename avoid env c, k,t)
318	327	\| _ -> c
319	328	in
320		rename avoid c
	329	rename avoid env c

+3

-2

pretyping/namegen.mli less more

69	69	type renaming_flags =
70	70	\| RenamingForCasesPattern (** avoid only global constructors *)
71	71	\| RenamingForGoal (** avoid all globals (as in intro) *)
72		\| RenamingElsewhereFor of constr
	72	\| RenamingElsewhereFor of (name list * constr)
73	73
74	74	val make_all_name_different : env -> env
75	75

79	79	renaming_flags -> identifier list -> name -> constr -> name * identifier list
80	80	val compute_displayed_let_name_in :
81	81	renaming_flags -> identifier list -> name -> constr -> name * identifier list
82		val rename_bound_vars_as_displayed : identifier list -> types -> types
	82	val rename_bound_vars_as_displayed :
	83	identifier list -> name list -> types -> types

+5

-4

pretyping/pretyping.ml less more

103	103
104	104	let resolve_evars env evdref fail_evar resolve_classes =
105	105	if resolve_classes then
106		evdref := (Typeclasses.resolve_typeclasses ~onlyargs:false
	106	evdref := (Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals
107	107	~split:true ~fail:fail_evar env !evdref);
108	108	(* Resolve eagerly, potentially making wrong choices *)
109	109	evdref := (try consider_remaining_unif_problems

159	159
160	160	In [understand_ltac expand_evars sigma env ltac_env constraint c],
161	161
	162	resolve_classes : launch typeclass resolution after typechecking.
162	163	expand_evars : expand inferred evars by their value if any
163	164	sigma : initial set of existential variables (typically dependent subgoals)
164	165	ltac_env : partial substitution of variables (used for the tactic language)
165	166	constraint : tell if interpreted as a possibly constrained term or a type
166	167	*)
167	168
168		val understand_ltac :
	169	val understand_ltac : ?resolve_classes:bool ->
169	170	bool -> evar_map -> env -> ltac_var_map ->
170	171	typing_constraint -> glob_constr -> pure_open_constr
171	172

761	762	let understand_type sigma env c =
762	763	snd (ise_pretype_gen true true true sigma env ([],[]) IsType c)
763	764
764		let understand_ltac expand_evar sigma env lvar kind c =
765		ise_pretype_gen expand_evar false false sigma env lvar kind c
	765	let understand_ltac ?(resolve_classes=false) expand_evar sigma env lvar kind c =
	766	ise_pretype_gen expand_evar false resolve_classes sigma env lvar kind c
766	767
767	768	let understand_tcc ?(resolve_classes=true) sigma env ?expected_type:exptyp c =
768	769	ise_pretype_gen true false resolve_classes sigma env ([],[]) (OfType exptyp) c

+2

-1

pretyping/pretyping.mli less more

57	57
58	58	In [understand_ltac expand_evars sigma env ltac_env constraint c],
59	59
	60	resolve_classes : launch typeclass resolution after typechecking.
60	61	expand_evars : expand inferred evars by their value if any
61	62	sigma : initial set of existential variables (typically dependent subgoals)
62	63	ltac_env : partial substitution of variables (used for the tactic language)
63	64	constraint : tell if interpreted as a possibly constrained term or a type
64	65	*)
65	66
66		val understand_ltac :
	67	val understand_ltac : ?resolve_classes:bool ->
67	68	bool -> evar_map -> env -> ltac_var_map ->
68	69	typing_constraint -> glob_constr -> pure_open_constr
69	70

+8

-4

pretyping/tacred.ml less more

575	575
576	576	let set_simpl_behaviour local r (recargs, nargs, flags as req) =
577	577	let nargs = if List.mem `SimplNeverUnfold flags then max_int else nargs in
578		let nargs = List.fold_left max nargs recargs in
579	578	let behaviour = {
580	579	b_nargs = nargs; b_recargs = recargs;
581	580	b_dont_expose_case = List.mem `SimplDontExposeCase flags } in

609	608
610	609	let rec red_elim_const env sigma ref largs =
611	610	let nargs = stack_args_size largs in
612		let largs, unfold_anyway =
	611	let largs, unfold_anyway, unfold_nonelim =
613	612	match recargs ref with
614		\| None -> largs, false
	613	\| None -> largs, false, false
615	614	\| Some (_,n) when nargs < n -> raise Redelimination
	615	\| Some (x::l,_) when nargs <= List.fold_left max x l -> raise Redelimination
616	616	\| Some (l,n) ->
617	617	List.fold_left (fun stack i ->
618	618	let arg = stack_nth stack i in

620	620	match kind_of_term (fst rarg) with
621	621	\| Construct _ -> stack_assign stack i (app_stack rarg)
622	622	\| _ -> raise Redelimination)
623		largs l, n >= 0 && l = [] && nargs >= n in
	623	largs l, n >= 0 && l = [] && nargs >= n,
	624	n >= 0 && l <> [] && nargs >= n in
624	625	try match reference_eval sigma env ref with
625	626	\| EliminationCases n when nargs >= n ->
626	627	let c = reference_value sigma env ref in

650	651	(match reduce_fix_use_function env sigma f whfun (destFix d) lrest with
651	652	\| NotReducible -> raise Redelimination
652	653	\| Reduced (c,rest) -> (nf_beta sigma c, rest))
	654	\| NotAnElimination when unfold_nonelim ->
	655	let c = reference_value sigma env ref in
	656	whd_betaiotazeta sigma (app_stack (c, largs)), empty_stack
653	657	\| _ -> raise Redelimination
654	658	with Redelimination when unfold_anyway ->
655	659	let c = reference_value sigma env ref in

+20

-16

pretyping/typeclasses.ml less more

449	449	is_class (IndRef ind)
450	450	\| _ -> false
451	451
452		let is_implicit_arg k =
453		match k with
454		ImplicitArg (ref, (n, id), b) -> true
455		\| InternalHole -> true
456		\| _ -> false
457
458	452
459	453	(* To embed a boolean for resolvability status.
460	454	This is essentially a hack to mark which evars correspond to

472	466	assert (evi.evar_body = Evar_empty);
473	467	Option.default true (resolvable.get evi.evar_extra)
474	468
475		let mark_unresolvable_undef evi =
476		let t = resolvable.set false evi.evar_extra in
	469	let mark_resolvability_undef b evi =
	470	let t = resolvable.set b evi.evar_extra in
477	471	{ evi with evar_extra = t }
478	472
479		let mark_unresolvable evi =
	473	let mark_resolvability b evi =
480	474	assert (evi.evar_body = Evar_empty);
481		mark_unresolvable_undef evi
482
483		let mark_unresolvables sigma =
	475	mark_resolvability_undef b evi
	476
	477	let mark_unresolvable evi = mark_resolvability false evi
	478	let mark_resolvable evi = mark_resolvability true evi
	479
	480	let mark_resolvability b sigma =
484	481	Evd.fold_undefined (fun ev evi evs ->
485		Evd.add evs ev (mark_unresolvable_undef evi))
	482	Evd.add evs ev (mark_resolvability_undef b evi))
486	483	sigma (Evd.defined_evars sigma)
	484
	485	let mark_unresolvables sigma = mark_resolvability false sigma
487	486
488	487	let has_typeclasses evd =
489	488	Evd.fold_undefined (fun ev evi has -> has \|\|
490		(is_class_evar evd evi && is_resolvable evi))
	489	(is_resolvable evi && is_class_evar evd evi))
491	490	evd false
492	491
493	492	let solve_instanciations_problem = ref (fun _ _ _ _ _ -> assert false)
494	493
495		let resolve_typeclasses ?(onlyargs=false) ?(split=true) ?(fail=true) env evd =
	494	type evar_filter = hole_kind -> bool
	495
	496	let no_goals = function GoalEvar -> false \| _ -> true
	497	let all_evars _ = true
	498
	499	let resolve_typeclasses ?(filter=no_goals) ?(split=true) ?(fail=true) env evd =
496	500	if not (has_typeclasses evd) then evd
497		else !solve_instanciations_problem env evd onlyargs split fail
	501	else !solve_instanciations_problem env evd filter split fail

+8

-4

pretyping/typeclasses.mli less more

70	70	val is_class : global_reference -> bool
71	71	val is_instance : global_reference -> bool
72	72
73		val is_implicit_arg : hole_kind -> bool
74
75	73	(** Returns the term and type for the given instance of the parameters and fields
76	74	of the type class. *)
77	75

82	80
83	81	val is_resolvable : evar_info -> bool
84	82	val mark_unresolvable : evar_info -> evar_info
	83	val mark_resolvable : evar_info -> evar_info
85	84	val mark_unresolvables : evar_map -> evar_map
86	85	val is_class_evar : evar_map -> evar_info -> bool
87	86
88		val resolve_typeclasses : ?onlyargs:bool -> ?split:bool -> ?fail:bool ->
	87	(** Filter which evars to consider for resolution. *)
	88	type evar_filter = hole_kind -> bool
	89	val no_goals : evar_filter
	90	val all_evars : evar_filter
	91
	92	val resolve_typeclasses : ?filter:evar_filter -> ?split:bool -> ?fail:bool ->
89	93	env -> evar_map -> evar_map
90	94	val resolve_one_typeclass : env -> evar_map -> types -> open_constr
91	95

100	104	val add_instance_hint : constr -> bool -> int option -> unit
101	105	val remove_instance_hint : global_reference -> unit
102	106
103		val solve_instanciations_problem : (env -> evar_map -> bool -> bool -> bool -> evar_map) ref
	107	val solve_instanciations_problem : (env -> evar_map -> evar_filter -> bool -> bool -> evar_map) ref
104	108	val solve_instanciation_problem : (env -> evar_map -> types -> open_constr) ref
105	109
106	110	val declare_instance : int option -> bool -> global_reference -> unit

+1

-1

pretyping/unification.ml less more

965	965
966	966	let try_resolve_typeclasses env evd flags m n =
967	967	if flags.resolve_evars then
968		try Typeclasses.resolve_typeclasses ~onlyargs:false ~split:false
	968	try Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals ~split:false
969	969	~fail:true env evd
970	970	with e when Typeclasses_errors.unsatisfiable_exception e ->
971	971	error_cannot_unify env evd (m, n)

+3

-6

pretyping/vnorm.ml less more

108	108	a 0) et les lambda correspondant aux realargs *)
109	109	let build_one_branch i cty =
110	110	let typi = type_constructor mind mib cty params in
111		let decl,indapp = Term.decompose_prod typi in
	111	let decl,indapp = decompose_prod_assum typi in
112	112	let ind,cargs = find_rectype_a env indapp in
113	113	let nparams = Array.length params in
114	114	let carity = snd (rtbl.(i)) in

192	192	let bsw = branch_of_switch (nb_rel env) sw in
193	193	let mkbranch i (n,v) =
194	194	let decl,codom = btypes.(i) in
195		let env =
196		List.fold_right
197		(fun (name,t) env -> push_rel (name,None,t) env) decl env in
198		let b = nf_val env v codom in
199		compose_lam decl b
	195	let b = nf_val (push_rel_context decl env) v codom in
	196	it_mkLambda_or_LetIn b decl
200	197	in
201	198	let branchs = Array.mapi mkbranch bsw in
202	199	let tcase = build_case_type dep p realargs c in

+2

-2

proofs/clenv.ml less more

499	499	let clause = mk_clenv_from_env env sigma n (c,t) in
500	500	clenv_constrain_dep_args hyps_only largs clause
501	501	\| ExplicitBindings lbind ->
502		let clause = mk_clenv_from_env env sigma n
503		(c,rename_bound_vars_as_displayed [] t)
	502	let clause = mk_clenv_from_env env sigma n
	503	(c,rename_bound_vars_as_displayed [] [] t)
504	504	in clenv_match_args lbind clause
505	505	\| NoBindings ->
506	506	mk_clenv_from_env env sigma n (c,t)

+1

-1

proofs/evar_refiner.ml less more

39	39	error "Instantiate called on already-defined evar";
40	40	let env = Evd.evar_env evi in
41	41	let sigma',typed_c =
42		try Pretyping.Default.understand_ltac true sigma env ltac_var
	42	try Pretyping.Default.understand_ltac ~resolve_classes:true true sigma env ltac_var
43	43	(Pretyping.OfType (Some evi.evar_concl)) rawc
44	44	with _ ->
45	45	let loc = Glob_term.loc_of_glob_constr rawc in

+3

-3

proofs/goal.ml less more

162	162	(* spiwack: it is not very fine grain since it solves all typeclasses holes,
163	163	not only those containing the current goal, or a given term. But it
164	164	seems to fit our needs so far. *)
165		let resolve_typeclasses ?onlyargs ?split ?(fail=false) () env rdefs _ _ =
166		rdefs:=Typeclasses.resolve_typeclasses ?onlyargs ?split ~fail env !rdefs;
	165	let resolve_typeclasses ?filter ?split ?(fail=false) () env rdefs _ _ =
	166	rdefs:=Typeclasses.resolve_typeclasses ?filter ?split ~fail env !rdefs;
167	167	()
168	168
169	169

562	562	let new_sigma = Evd.add Evd.empty evk new_evi in
563	563	{ Evd.it = build evk ; sigma = new_sigma }
564	564
565		(* Used by the typeclasses *)
	565	(* Used by the compatibility layer and typeclasses *)
566	566	let nf_evar sigma gl =
567	567	let evi = content sigma gl in
568	568	let evi = Evarutil.nf_evar_info sigma evi in

+2

-2

proofs/goal.mli less more

71	71	(* [with_type c typ] constrains term [c] to have type [typ]. *)
72	72	val with_type : Term.constr -> Term.types -> Term.constr sensitive
73	73
74		val resolve_typeclasses : ?onlyargs:bool -> ?split:bool -> ?fail:bool -> unit -> unit sensitive
	74	val resolve_typeclasses : ?filter:(Evd.hole_kind -> bool) -> ?split:bool -> ?fail:bool -> unit -> unit sensitive
75	75
76	76
77	77	(* [constr_of_raw h check_type resolve_classes] is a pretyping function.

233	233	(* Used for congruence closure *)
234	234	val new_goal_with : Evd.evar_map -> goal -> Environ.named_context_val -> goal Evd.sigma
235	235
236		(* Used by the typeclasses *)
	236	(* Used by the compatibility layer and typeclasses *)
237	237	val nf_evar : Evd.evar_map -> goal -> goal * Evd.evar_map
238	238
239	239	(* Goal represented as a type, doesn't take into account section variables *)

+2

-6

proofs/logic.ml less more

684	684	([gl], sigma)
685	685
686	686	\| Change_evars ->
687		(* spiwack: a priori [Change_evars] is now devoid of operational content.
688		The new proof engine keeping the evar_map up to date at all time.
689		As a compatibility mesure I leave the rule.
690		It is possible that my assumption is wrong and some uses of
691		[Change_evars] are not subsumed by the new engine. In which
692		case something has to be done here. (Feb. 2010) *)
	687	(* Normalises evars in goals. Used by instantiate. *)
	688	let (goal,sigma) = Goal.V82.nf_evar sigma goal in
693	689	([goal],sigma)
694	690
695	691	(************************************************************************)

+4

-10

proofs/pfedit.ml less more

34	34	let delete_current_proof = Proof_global.discard_current
35	35	let delete_all_proofs = Proof_global.discard_all
36	36
37		let undo n =
	37	let undo n =
38	38	let p = Proof_global.give_me_the_proof () in
	39	let d = Proof.V82.depth p in
	40	if n >= d then raise Proof.EmptyUndoStack;
39	41	for i = 1 to n do
40	42	Proof.undo p
41	43	done

63	65	Proof_global.start_proof id str goals ?compute_guard hook;
64	66	Option.iter Proof_global.run_tactic init_tac
65	67
66		let restart_proof () =
67		let p = Proof_global.give_me_the_proof () in
68		try while true do
69		Proof.undo p
70		done with Proof.EmptyUndoStack -> ()
71
72		let resume_last_proof () = Proof_global.resume_last ()
73		let resume_proof (_,id) = Proof_global.resume id
74		let suspend_proof () = Proof_global.suspend ()
	68	let restart_proof () = undo_todepth 1
75	69
76	70	let cook_proof hook =
77	71	let prf = Proof_global.give_me_the_proof () in

+3

-19

proofs/pfedit.mli less more

84	84	val restart_proof : unit -> unit
85	85
86	86	(** {6 ... } *)
87		(** [resume_last_proof ()] focus on the last unfocused proof or fails
88		if there is no suspended proofs *)
89
90		val resume_last_proof : unit -> unit
91
92		(** [resume_proof name] focuses on the proof of name [name] or
93		raises [NoSuchProof] if no proof has name [name].
94
95		It doesn't [suspend_proof ()] before. *)
96
97		val resume_proof : identifier located -> unit
98
99		(** [suspend_proof ()] unfocuses the current focused proof or
100		failed with [UserError] if no proof is currently focused *)
101
102		val suspend_proof : unit -> unit
103
104		(** {6 ... } *)
105	87	(** [cook_proof opacity] turns the current proof (assumed completed) into
106	88	a constant with its name, kind and possible hook (see [start_proof]);
107	89	it fails if there is no current proof of if it is not completed;

142	124
143	125	val get_current_proof_name : unit -> identifier
144	126
145		(** [get_all_proof_names ()] returns the list of all pending proof names *)
	127	(** [get_all_proof_names ()] returns the list of all pending proof names.
	128	The first name is the current proof, the other names may come in
	129	any order. *)
146	130
147	131	val get_all_proof_names : unit -> identifier list
148	132

+73

-63

proofs/proof.ml less more

34	34	type 'a focus_kind = _focus_kind
35	35	type focus_info = Obj.t
36	36	type unfocusable =
37		\| Cannot
	37	\| Cannot of exn
38	38	\| Loose
39	39	\| Strict
40	40	type _focus_condition =
41	41	(_focus_kind -> Proofview.proofview -> unfocusable) *
42		(_focus_kind -> focus_info -> focus_info)
	42	(_focus_kind -> bool)
43	43	type 'a focus_condition = _focus_condition
44	44
45	45	let next_kind = ref 0

48	48	incr next_kind;
49	49	r
50	50
51		(* Auxiliary function to define conditions:
52		[check kind1 kind2 inf] returns [inf] if [kind1] and [kind2] match.
53		Otherwise it raises [CheckNext] *)
54		exception CheckNext
55		(* no handler: confined to this module. *)
56		let check kind1 kind2 inf =
57		if kind1=kind2 then inf else raise CheckNext
	51	(* Auxiliary function to define conditions. *)
	52	let check kind1 kind2 = kind1=kind2
58	53
59	54	(* To be authorized to unfocus one must meet the condition prescribed by
60	55	the action which focused.*)

67	62	(* first attempt at an algebra of condition *)
68	63	(* semantics:
69	64	- [Cannot] means that the condition is not met
70		- [Strict] that the condition is meant
71		- [Loose] that the condition is not quite meant
	65	- [Strict] that the condition is met
	66	- [Loose] that the condition is not quite met
72	67	but authorises to unfocus provided a condition
73	68	of a previous focus on the stack is (strictly)
74		met.
	69	met. [Loose] focuses are those, like bullets,
	70	which do not have a closing command and
	71	are hence closed by unfocusing actions unrelated
	72	to their focus_kind.
75	73	*)
76		let bool b =
	74	let bool e b =
77	75	if b then fun _ _ -> Strict
78		else fun _ _ -> Cannot
	76	else fun _ _ -> Cannot e
79	77	let loose c k p = match c k p with
80		\| Cannot -> Loose
	78	\| Cannot _ -> Loose
81	79	\| c -> c
82	80	let cloose l c =
83	81	if l then loose c
84	82	else c
85	83	let (&&&) c1 c2 k p=
86	84	match c1 k p , c2 k p with
87		\| Cannot , _
88		\| _ , Cannot -> Cannot
	85	\| Cannot e , _
	86	\| _ , Cannot e -> Cannot e
89	87	\| Strict, Strict -> Strict
90	88	\| _ , _ -> Loose
91		let kind k0 k p = bool (k0=k) k p
92		let pdone k p = bool (Proofview.finished p) k p
	89	let kind e k0 k p = bool e (k0=k) k p
	90	let pdone e k p = bool e (Proofview.finished p) k p
	91	end
	92
	93
	94	(* Unfocus command.
	95	Fails if the proof is not focused. *)
	96	exception CannotUnfocusThisWay
	97	let _ = Errors.register_handler begin function
	98	\| CannotUnfocusThisWay ->
	99	Util.error "This proof is focused, but cannot be unfocused this way"
	100	\| _ -> raise Errors.Unhandled
93	101	end
94	102
95	103	open Cond
96		let no_cond ~loose_end k0 =
97		cloose loose_end (kind k0)
98		let no_cond ?(loose_end=false) k = no_cond ~loose_end k , check k
	104	let no_cond_gen e ~loose_end k0 =
	105	cloose loose_end (kind e k0)
	106	let no_cond_gen e ?(loose_end=false) k = no_cond_gen e ~loose_end k , check k
	107	let no_cond ?loose_end = no_cond_gen CannotUnfocusThisWay ?loose_end
99	108	(* [done_cond] checks that the unfocusing command uses the right [focus_kind]
100	109	and that the focused proofview is complete. *)
101		let done_cond ~loose_end k0 =
102		(cloose loose_end (kind k0)) &&& pdone
103		let done_cond ?(loose_end=false) k = done_cond ~loose_end k , check k
	110	let done_cond_gen e ~loose_end k0 =
	111	(cloose loose_end (kind e k0)) &&& pdone e
	112	let done_cond_gen e ?(loose_end=false) k = done_cond_gen e ~loose_end k , check k
	113	let done_cond ?loose_end = done_cond_gen CannotUnfocusThisWay ?loose_end
104	114
105	115
106	116	(* Subpart of the type of proofs. It contains the parts of the proof which

248	258	push_undo (save_state pr) pr
249	259
250	260	(* This function restores a state, presumably from the top of the undo stack. *)
251		let restore_state save pr =
	261	let restore_state save pr =
252	262	match save with
253	263	\| State save -> pr.state <- save
254	264	\| Effect undo -> undo ()
255	265
256	266	(* Interpretes the Undo command. *)
257		let undo pr =
	267	let undo pr =
258	268	(* On a single line, since the effects commute *)
259	269	restore_state (pop_undo pr) pr
260	270

308	318	save pr;
309	319	_focus cond (Obj.repr inf) i i pr
310	320
311		(* Unfocus command.
312		Fails if the proof is not focused. *)
313		exception CannotUnfocusThisWay
314		let _ = Errors.register_handler begin function
315		\| CannotUnfocusThisWay ->
316		Util.error "This proof is focused, but cannot be unfocused this way"
317		\| _ -> raise Errors.Unhandled
318		end
319
320	321	let rec unfocus kind pr () =
321	322	let starting_point = save_state pr in
322	323	let cond = cond_of_focus pr in
323	324	match fst cond kind pr.state.proofview with
324		\| Cannot -> raise CannotUnfocusThisWay
	325	\| Cannot e -> raise e
325	326	\| Strict ->
326	327	(_unfocus pr;
327	328	push_undo starting_point pr)

335	336
336	337	let unfocus kind pr =
337	338	transaction pr (unfocus kind pr)
338
339		let get_at_point kind ((_,get),inf,_) = get kind inf
	339
340	340	exception NoSuchFocus
341	341	(* no handler: should not be allowed to reach toplevel. *)
342		exception GetDone of Obj.t
343		(* no handler: confined to this module. *)
344		let get_in_focus_stack kind stack =
345		try
346		List.iter begin fun pt ->
347		try
348		raise (GetDone (get_at_point kind pt))
349		with CheckNext -> ()
350		end stack;
351		raise NoSuchFocus
352		with GetDone x -> x
	342	let rec get_in_focus_stack kind stack =
	343	match stack with
	344	\| ((_,check),inf,_)::stack ->
	345	if check kind then inf
	346	else get_in_focus_stack kind stack
	347	\| [] -> raise NoSuchFocus
353	348	let get_at_focus kind pr =
354	349	Obj.magic (get_in_focus_stack kind pr.state.focus_stack)
355	350
	351	let is_last_focus kind pr =
	352	let ((_,check),_,_) = List.hd pr.state.focus_stack in
	353	check kind
	354
356	355	let no_focused_goal p =
357	356	Proofview.finished p.state.proofview
358	357
359	358	(* Proof Creation/Termination *)
360	359
	360	(* [end_of_stack] is unfocused by return to close every loose focus. *)
361	361	let end_of_stack_kind = new_focus_kind ()
362		let end_of_stack = done_cond end_of_stack_kind
	362	let end_of_stack = done_cond_gen FullyUnfocused end_of_stack_kind
	363
	364	let unfocused = is_last_focus end_of_stack_kind
363	365
364	366	let start goals =
365		let pr =
	367	let pr =
366	368	{ state = { proofview = Proofview.init goals ;
367	369	focus_stack = [] ;
368	370	intel = Store.empty} ;

444	446	let top_evars p =
445	447	Proofview.V82.top_evars p.state.proofview
446	448
447		let instantiate_evar n com pr =
448		let starting_point = save_state pr in
449		let sp = pr.state.proofview in
450		try
451		let new_proofview = Proofview.V82.instantiate_evar n com sp in
452		pr.state <- { pr.state with proofview = new_proofview };
453		push_undo starting_point pr
454		with e ->
455		restore_state starting_point pr;
456		raise e
457		end
	449	let grab_evars p =
	450	if not (is_done p) then
	451	raise UnfinishedProof
	452	else
	453	save p;
	454	p.state <- { p.state with proofview = Proofview.V82.grab p.state.proofview }
	455
	456
	457	let instantiate_evar n com pr =
	458	let starting_point = save_state pr in
	459	let sp = pr.state.proofview in
	460	try
	461	let new_proofview = Proofview.V82.instantiate_evar n com sp in
	462	pr.state <- { pr.state with proofview = new_proofview };
	463	push_undo starting_point pr
	464	with e ->
	465	restore_state starting_point pr;
	466	raise e
	467	end

+11

-3

proofs/proof.mli less more

113	113	is not met. *)
114	114	val unfocus : 'a focus_kind -> proof -> unit
115	115
	116	(* [unfocused p] returns [true] when [p] is fully unfocused. *)
	117	val unfocused : proof -> bool
	118
116	119	(* [get_at_focus k] gets the information stored at the closest focus point
117	120	of kind [k].
118	121	Raises [NoSuchFocus] if there is no focus point of kind [k]. *)
119	122	exception NoSuchFocus
120	123	val get_at_focus : 'a focus_kind -> proof -> 'a
	124
	125	(* [is_last_focus k] check if the most recent focus is of kind [k] *)
	126	val is_last_focus : 'a focus_kind -> proof -> bool
121	127
122	128	(* returns [true] if there is no goal under focus. *)
123	129	val no_focused_goal : proof -> bool

125	131	(* Function manipulation proof extra informations *)
126	132
127	133	val get_proof_info : proof -> Store.t
128
129		val set_proof_info : Store.t -> proof -> unit
130	134
131	135	(* Sets the section variables assumed by the proof *)
132	136	val set_used_variables : Sign.section_context -> proof -> unit

150	154	a focusing command and a tactic. Transactions are such that if
151	155	any of the atomic action fails, the whole transaction fails.
152	156
153		During a transaction, the undo visible undo stack is constituted only
	157	During a transaction, the visible undo stack is constituted only
154	158	of the actions performed done during the transaction.
155	159
156	160	[transaction p f] can be called on an [f] using, itself, [transaction p].*)

177	181	(* returns the existential variable used to start the proof *)
178	182	val top_evars : proof -> Evd.evar list
179	183
	184	(* Turns the unresolved evars into goals.
	185	Raises [UnfinishedProof] if there are still unsolved goals. *)
	186	val grab_evars : proof -> unit
	187
180	188	(* Implements the Existential command *)
181	189	val instantiate_evar : int -> Topconstr.constr_expr -> proof -> unit
182	190	end

+31

-41

proofs/proof_global.ml less more

69	69	mode : proof_mode
70	70	}
71	71
72		(* Invariant: a proof is at most in one of current_proof and suspended. And the
73		domain of proof_info is the union of that of current_proof and suspended.*)
74		(* The head of [!current_proof] is the actual current proof, the other ones are to
75		be resumed when the current proof is closed, aborted or suspended. *)
	72	(* Invariant: the domain of proof_info is current_proof.*)
	73	(* The head of [!current_proof] is the actual current proof, the other ones are
	74	to be resumed when the current proof is closed or aborted. *)
76	75	let current_proof = ref ([]:nproof list)
77		let suspended = ref ([] : nproof list)
78	76	let proof_info = ref (Idmap.empty : proof_info Idmap.t)
79	77
80	78	(* Current proof_mode, for bookkeeping *)

92	90	!current_proof_mode.reset ();
93	91	current_proof_mode := standard
94	92
95		(* combinators for the current_proof and suspended lists *)
	93	(* combinators for the current_proof lists *)
96	94	let push a l = l := a::!l;
97	95	update_proof_mode ()
98	96

144	142	(* Proof Global manipulation *)
145	143
146	144	let get_all_proof_names () =
147		List.map fst !current_proof @
148		List.map fst !suspended
	145	List.map fst !current_proof
149	146
150	147	let give_me_the_proof () =
151	148	snd (find_top current_proof)

159	156	accessed directly through vernacular commands. Error message should be
160	157	pushed to external layers, and so we should be able to have a finer
161	158	control on error message on complex actions. *)
162		let msg_proofs use_resume =
	159	let msg_proofs () =
163	160	match get_all_proof_names () with
164	161	\| [] -> (spc () ++ str"(No proof-editing in progress).")
165	162	\| l -> (str"." ++ fnl () ++ str"Proofs currently edited:" ++ spc () ++
166		(Util.prlist_with_sep Util.pr_spc Nameops.pr_id l) ++
167		str"." ++
168		(if use_resume then (fnl () ++ str"Use \"Resume\" first.")
169		else (mt ()))
170		)
171
	163	(Util.prlist_with_sep Util.pr_spc Nameops.pr_id l)++ str ".")
172	164
173	165	let there_is_a_proof () = !current_proof <> []
174		let there_are_suspended_proofs () = !suspended <> []
175		let there_are_pending_proofs () =
176		there_is_a_proof () \|\|
177		there_are_suspended_proofs ()
178		let check_no_pending_proof () =
	166	let there_are_pending_proofs () = there_is_a_proof ()
	167	let check_no_pending_proof () =
179	168	if not (there_are_pending_proofs ()) then
180	169	()
181	170	else begin
182	171	Util.error (Pp.string_of_ppcmds
183		(str"Proof editing in progress" ++ (msg_proofs false) ++ fnl() ++
	172	(str"Proof editing in progress" ++ msg_proofs () ++ fnl() ++
184	173	str"Use \"Abort All\" first or complete proof(s)."))
185	174	end
186	175
187
188		let suspend () =
189		rotate_top current_proof suspended
190
191		let resume_last () =
192		rotate_top suspended current_proof
193
194		let resume id =
195		rotate_find id suspended current_proof
196
197	176	let discard_gen id =
198		try
199		ignore (extract id current_proof);
200		remove id proof_info
201		with NoSuchProof -> ignore (extract id suspended)
	177	ignore (extract id current_proof);
	178	remove id proof_info
202	179
203	180	let discard (loc,id) =
204	181	try
205	182	discard_gen id
206	183	with NoSuchProof ->
207	184	Util.user_err_loc
208		(loc,"Pfedit.delete_proof",str"No such proof" ++ msg_proofs false)
	185	(loc,"Pfedit.delete_proof",str"No such proof" ++ msg_proofs ())
209	186
210	187	let discard_current () =
211	188	let (id,_) = extract_top current_proof in
212	189	remove id proof_info
213	190
214	191	let discard_all () =
215		current_proof := [];
216		suspended := [];
	192	current_proof := [];
217	193	proof_info := Idmap.empty
218	194
219	195	(* [set_proof_mode] sets the proof mode to be used after it's called. It is

238	214	end pr ;
239	215	set_proof_mode m id
240	216
	217	exception AlreadyExists
	218	let _ = Errors.register_handler begin function
	219	\| AlreadyExists -> Util.error "Already editing something of that name."
	220	\| _ -> raise Errors.Unhandled
	221	end
241	222	(* [start_proof s str env t hook tac] starts a proof of name [s] and
242	223	conclusion [t]; [hook] is optionally a function to be applied at
243	224	proof end (e.g. to declare the built constructions as a coercion

247	228	It raises exception [ProofInProgress] if there is a proof being
248	229	currently edited. *)
249	230	let start_proof id str goals ?(compute_guard=[]) hook =
250		(* arnaud: ajouter une vérification pour la présence de id dans le proof_global *)
	231	begin
	232	List.iter begin fun (id_ex,_) ->
	233	if Names.id_ord id id_ex = 0 then raise AlreadyExists
	234	end !current_proof
	235	end;
251	236	let p = Proof.start goals in
252	237	add id { strength=str ;
253	238	compute_guard=compute_guard ;

353	338	let bullet_kind = (Proof.new_focus_kind () : t list Proof.focus_kind)
354	339	let bullet_cond = Proof.done_cond ~loose_end:true bullet_kind
355	340
	341	(* spiwack: as it is bullets are reset (locally) by any non-bullet focusing command
	342	experience will tell if this is the right discipline of if we want to be finer and
	343	reset them only for a choice of bullets. *)
356	344	let get_bullets pr =
357		try Proof.get_at_focus bullet_kind pr
358		with Proof.NoSuchFocus -> []
	345	if Proof.is_last_focus bullet_kind pr then
	346	Proof.get_at_focus bullet_kind pr
	347	else
	348	[]
359	349
360	350	let has_bullet bul pr =
361	351	let rec has_bullet = function

+0

-6

proofs/proof_global.mli less more

68	68
69	69	exception NoSuchProof
70	70
71		val suspend : unit -> unit
72		val resume_last : unit -> unit
73
74		val resume : Names.identifier -> unit
75		(** @raise NoSuchProof if it doesn't find one. *)
76
77	71	(** Runs a tactic on the current proof. Raises [NoCurrentProof] is there is
78	72	no current proof. *)
79	73	val run_tactic : unit Proofview.tactic -> unit

+11

-0

proofs/proofview.ml less more

474	474	let has_unresolved_evar pv =
475	475	Evd.has_undefined pv.solution
476	476
	477	(* Main function in the implementation of Grab Existential Variables.*)
	478	let grab pv =
	479	let goals =
	480	List.map begin fun (e,_) ->
	481	Goal.build e
	482	end (Evd.undefined_list pv.solution)
	483	in
	484	{ pv with comb = goals }
	485
	486
	487
477	488	(* Returns the open goals of the proofview together with the evar_map to
478	489	interprete them. *)
479	490	let goals { comb = comb ; solution = solution } =

+5

-0

proofs/proofview.mli less more

194	194
195	195	val has_unresolved_evar : proofview -> bool
196	196
	197	(* Main function in the implementation of Grab Existential Variables.
	198	Resets the proofview's goals so that it contains all unresolved evars
	199	(in chronological order of insertion). *)
	200	val grab : proofview -> proofview
	201
197	202	(* Returns the open goals of the proofview together with the evar_map to
198	203	interprete them. *)
199	204	val goals : proofview -> Goal.goal list Evd.sigma

+0

-4

proofs/refiner.ml less more

414	414	let pp_info = ref (fun _ _ _ -> assert false)
415	415	let set_info_printer f = pp_info := f
416	416
417		let tclINFO (tac : tactic) gls =
418		msgnl (hov 0 (str "Warning: info is currently not working"));
419		tac gls
420
421	417	(* Check that holes in arguments have been resolved *)
422	418
423	419	let check_evars env sigma extsigma gl =

+0

-1

proofs/refiner.mli less more

136	136	val tclWEAK_PROGRESS : tactic -> tactic
137	137	val tclPROGRESS : tactic -> tactic
138	138	val tclNOTSAMEGOAL : tactic -> tactic
139		val tclINFO : tactic -> tactic
140	139
141	140	(** [tclIFTHENELSE tac1 tac2 tac3 gls] first applies [tac1] to [gls] then,
142	141	if it succeeds, applies [tac2] to the resulting subgoals,

+4

-7

proofs/tacexpr.ml less more

25	25	type split_flag = bool (* true = exists false = split *)
26	26	type hidden_flag = bool (* true = internal use false = user-level *)
27	27	type letin_flag = bool (* true = use local def false = use Leibniz *)
	28
	29	type debug = Debug \| Info \| Off (* for trivial / auto / eauto ... *)
28	30
29	31	type glob_red_flag =
30	32	\| FBeta

170	172	\| TacLApply of 'constr
171	173
172	174	(* Automation tactics *)
173		\| TacTrivial of 'constr list * string list option
174		\| TacAuto of int or_var option * 'constr list * string list option
175		\| TacAutoTDB of int option
176		\| TacDestructHyp of (bool * identifier located)
177		\| TacDestructConcl
178		\| TacSuperAuto of (int option * reference list * bool * bool)
179		\| TacDAuto of int or_var option * int option * 'constr list
	175	\| TacTrivial of debug * 'constr list * string list option
	176	\| TacAuto of debug * int or_var option * 'constr list * string list option
180	177
181	178	(* Context management *)
182	179	\| TacClear of bool * 'id list

+0

-8

proofs/tacmach.ml less more

71	71	(fun id acc -> (next_ident_away id (acc@avoid))::acc)
72	72	ids []
73	73
74		let pf_interp_constr gls c =
75		let evc = project gls in
76		Constrintern.interp_constr evc (pf_env gls) c
77
78		let pf_interp_type gls c =
79		let evc = project gls in
80		Constrintern.interp_type evc (pf_env gls) c
81
82	74	let pf_global gls id = Constrintern.construct_reference (pf_hyps gls) id
83	75
84	76	let pf_parse_const gls = compose (pf_global gls) id_of_string

+0

-3

proofs/tacmach.mli less more

46	46	val pf_type_of : goal sigma -> constr -> types
47	47	val pf_check_type : goal sigma -> constr -> types -> unit
48	48	val pf_hnf_type_of : goal sigma -> constr -> types
49
50		val pf_interp_constr : goal sigma -> Topconstr.constr_expr -> constr
51		val pf_interp_type : goal sigma -> Topconstr.constr_expr -> types
52	49
53	50	val pf_get_hyp : goal sigma -> identifier -> named_declaration
54	51	val pf_get_hyp_typ : goal sigma -> identifier -> types

+71

-32

proofs/tactic_debug.ml less more

48	48
49	49	(* Prints the commands *)
50	50	let help () =
51		msgnl (str "Commands: <Enter>=Continue" ++ fnl() ++
52		str " h/?=Help" ++ fnl() ++
53		str " r<num>=Run <num> times" ++ fnl() ++
54		str " s=Skip" ++ fnl() ++
55		str " x=Exit")
	51	msgnl (str "Commands: <Enter> = Continue" ++ fnl() ++
	52	str " h/? = Help" ++ fnl() ++
	53	str " r <num> = Run <num> times" ++ fnl() ++
	54	str " r <string> = Run up to next idtac <string>" ++ fnl() ++
	55	str " s = Skip" ++ fnl() ++
	56	str " x = Exit")
56	57
57	58	(* Prints the goal and the command to be executed *)
58	59	let goal_com g tac =

61	62	msg (str "Going to execute:" ++ fnl () ++ !prtac tac ++ fnl ())
62	63	end
63	64
64		(* Gives the number of a run command *)
	65	let skipped = ref 0
	66	let skip = ref 0
	67	let breakpoint = ref None
	68
	69	let rec drop_spaces inst i =
	70	if String.length inst > i && inst.[i] = ' ' then drop_spaces inst (i+1)
	71	else i
	72
	73	let possibly_unquote s =
	74	if String.length s >= 2 & s.[0] = '"' & s.[String.length s - 1] = '"' then
	75	String.sub s 1 (String.length s - 2)
	76	else
	77	s
	78
	79	(* (Re-)initialize debugger *)
	80	let db_initialize () =
	81	skip:=0;skipped:=0;breakpoint:=None
	82
	83	(* Gives the number of steps or next breakpoint of a run command *)
65	84	let run_com inst =
66	85	if (String.get inst 0)='r' then
67		let num = int_of_string (String.sub inst 1 ((String.length inst)-1)) in
68		if num>0 then num
69		else raise (Invalid_argument "run_com")
	86	let i = drop_spaces inst 1 in
	87	if String.length inst > i then
	88	let s = String.sub inst i (String.length inst - i) in
	89	if inst.[0] >= '0' && inst.[0] <= '9' then
	90	let num = int_of_string s in
	91	if num<0 then raise (Invalid_argument "run_com");
	92	skip:=num;skipped:=0
	93	else
	94	breakpoint:=Some (possibly_unquote s)
	95	else
	96	raise (Invalid_argument "run_com")
70	97	else
71	98	raise (Invalid_argument "run_com")
72
73		let allskip = ref 0
74		let skip = ref 0
75	99
76	100	(* Prints the run counter *)
77	101	let run ini =
78	102	if not ini then
	103	begin
79	104	for i=1 to 2 do
80	105	print_char (Char.chr 8);print_char (Char.chr 13)
81	106	done;
82		msg (str "Executed expressions: " ++ int (!allskip - !skip) ++
83		fnl() ++ fnl())
	107	msg (str "Executed expressions: " ++ int !skipped ++ fnl() ++ fnl())
	108	end;
	109	incr skipped
84	110
85	111	(* Prints the prompt *)
86	112	let rec prompt level =
87	113	begin
88	114	msg (fnl () ++ str "TcDebug (" ++ int level ++ str ") > ");
89	115	flush stdout;
90		let exit () = skip:=0;allskip:=0;raise Sys.Break in
	116	let exit () = skip:=0;skipped:=0;raise Sys.Break in
91	117	let inst = try read_line () with End_of_file -> exit () in
92	118	match inst with
93		\| "" -> true
94		\| "s" -> false
	119	\| "" -> DebugOn (level+1)
	120	\| "s" -> DebugOff
95	121	\| "x" -> print_char (Char.chr 8); exit ()
96	122	\| "h"\| "?" ->
97	123	begin

99	125	prompt level
100	126	end
101	127	\| _ ->
102		(try let ctr=run_com inst in skip:=ctr;allskip:=ctr;run true;true
	128	(try run_com inst;run true;DebugOn (level+1)
103	129	with Failure _ \| Invalid_argument _ -> prompt level)
104	130	end
105	131
106	132	(* Prints the state and waits for an instruction *)
107	133	let debug_prompt lev g tac f =
108	134	(* What to print and to do next *)
109		let continue =
110		if !skip = 0 then (goal_com g tac; prompt lev)
111		else (decr skip; run false; if !skip=0 then allskip:=0; true) in
	135	let newlevel =
	136	if !skip = 0 then
	137	if !breakpoint = None then (goal_com g tac; prompt lev)
	138	else (run false; DebugOn (lev+1))
	139	else (decr skip; run false; if !skip=0 then skipped:=0; DebugOn (lev+1)) in
112	140	(* What to execute *)
113		try f (if continue then DebugOn (lev+1) else DebugOff)
	141	try f newlevel
114	142	with e ->
115		skip:=0; allskip:=0;
	143	skip:=0; skipped:=0;
116	144	if Logic.catchable_exception e then
117	145	ppnl (str "Level " ++ int lev ++ str ": " ++ !explain_logic_error e);
118	146	raise e
119	147
120	148	(* Prints a constr *)
121	149	let db_constr debug env c =
122		if debug <> DebugOff & !skip = 0 then
	150	if debug <> DebugOff & !skip = 0 & !breakpoint = None then
123	151	msgnl (str "Evaluated term: " ++ print_constr_env env c)
124	152
125	153	(* Prints the pattern rule *)
126	154	let db_pattern_rule debug num r =
127		if debug <> DebugOff & !skip = 0 then
	155	if debug <> DebugOff & !skip = 0 & !breakpoint = None then
128	156	begin
129	157	msgnl (str "Pattern rule " ++ int num ++ str ":");
130	158	msgnl (str "\|" ++ spc () ++ !prmatchrl r)

137	165
138	166	(* Prints a matched hypothesis *)
139	167	let db_matched_hyp debug env (id,_,c) ido =
140		if debug <> DebugOff & !skip = 0 then
	168	if debug <> DebugOff & !skip = 0 & !breakpoint = None then
141	169	msgnl (str "Hypothesis " ++
142	170	str ((Names.string_of_id id)^(hyp_bound ido)^
143	171	" has been matched: ") ++ print_constr_env env c)
144	172
145	173	(* Prints the matched conclusion *)
146	174	let db_matched_concl debug env c =
147		if debug <> DebugOff & !skip = 0 then
	175	if debug <> DebugOff & !skip = 0 & !breakpoint = None then
148	176	msgnl (str "Conclusion has been matched: " ++ print_constr_env env c)
149	177
150	178	(* Prints a success message when the goal has been matched *)
151	179	let db_mc_pattern_success debug =
152		if debug <> DebugOff & !skip = 0 then
	180	if debug <> DebugOff & !skip = 0 & !breakpoint = None then
153	181	msgnl (str "The goal has been successfully matched!" ++ fnl() ++
154	182	str "Let us execute the right-hand side part..." ++ fnl())
155	183
156	184	(* Prints a failure message for an hypothesis pattern *)
157	185	let db_hyp_pattern_failure debug env (na,hyp) =
158		if debug <> DebugOff & !skip = 0 then
	186	if debug <> DebugOff & !skip = 0 & !breakpoint = None then
159	187	msgnl (str ("The pattern hypothesis"^(hyp_bound na)^
160	188	" cannot match: ") ++
161	189	!prmatchpatt env hyp)
162	190
163	191	(* Prints a matching failure message for a rule *)
164	192	let db_matching_failure debug =
165		if debug <> DebugOff & !skip = 0 then
	193	if debug <> DebugOff & !skip = 0 & !breakpoint = None then
166	194	msgnl (str "This rule has failed due to matching errors!" ++ fnl() ++
167	195	str "Let us try the next one...")
168	196
169	197	(* Prints an evaluation failure message for a rule *)
170	198	let db_eval_failure debug s =
171		if debug <> DebugOff & !skip = 0 then
	199	if debug <> DebugOff & !skip = 0 & !breakpoint = None then
172	200	let s = str "message \"" ++ s ++ str "\"" in
173	201	msgnl
174	202	(str "This rule has failed due to \"Fail\" tactic (" ++

176	204
177	205	(* Prints a logic failure message for a rule *)
178	206	let db_logic_failure debug err =
179		if debug <> DebugOff & !skip = 0 then
	207	if debug <> DebugOff & !skip = 0 & !breakpoint = None then
180	208	begin
181	209	msgnl (!explain_logic_error err);
182	210	msgnl (str "This rule has failed due to a logic error!" ++ fnl() ++
183	211	str "Let us try the next one...")
184	212	end
	213
	214	let is_breakpoint brkname s = match brkname, s with
	215	\| Some s, MsgString s'::_ -> s = s'
	216	\| _ -> false
	217
	218	let db_breakpoint debug s =
	219	match debug with
	220	\| DebugOn lev when s <> [] & is_breakpoint !breakpoint s ->
	221	breakpoint:=None
	222	\| _ ->
	223	()

+7

-0

proofs/tactic_debug.mli less more

32	32	(** Prints the state and waits *)
33	33	val debug_prompt :
34	34	int -> goal sigma -> glob_tactic_expr -> (debug_info -> 'a) -> 'a
	35
	36	(** Initializes debugger *)
	37	val db_initialize : unit -> unit
35	38
36	39	(** Prints a constr *)
37	40	val db_constr : debug_info -> env -> constr -> unit

71	74
72	75	(** Prints a logic failure message for a rule *)
73	76	val db_logic_failure : debug_info -> exn -> unit
	77
	78	(** Prints a logic failure message for a rule *)
	79	val db_breakpoint : debug_info ->
	80	identifier Util.located message_token list -> unit

+7

-16

scripts/coqc.ml less more

27	27
28	28	(* coqc options *)
29	29
30		let specification = ref false
31		let keep = ref false
32	30	let verbose = ref false
33	31
34	32	(* Verifies that a string starts by a letter and do not contain

103	101	let rec parse (cfiles,args) = function
104	102	\| [] ->
105	103	List.rev cfiles, List.rev args
106		\| "-i" :: rem ->
107		specification := true ; parse (cfiles,args) rem
108		\| "-t" :: rem ->
109		keep := true ; parse (cfiles,args) rem
110	104	\| ("-verbose" \| "--verbose") :: rem ->
111	105	verbose := true ; parse (cfiles,args) rem
112		\| "-boot" :: rem ->
113		Flags.boot := true;
114		parse (cfiles, "-boot"::args) rem
115		\| "-byte" :: rem ->
116		binary := "coqtop.byte"; parse (cfiles,args) rem
117		\| "-opt" :: rem ->
118		binary := "coqtop.opt"; parse (cfiles,args) rem
119	106	\| "-image" :: f :: rem ->
120	107	image := f; parse (cfiles,args) rem
121	108	\| "-image" :: [] ->
122	109	usage ()
	110	\| "-byte" :: rem ->
	111	binary := "coqtop.byte"; parse (cfiles,args) rem
	112	\| "-opt" :: rem ->
	113	binary := "coqtop.opt"; parse (cfiles,args) rem
123	114	\| "-libdir" :: _ :: rem ->
124		print_string "Warning: option -libdir deprecated\n"; flush stdout;
	115	print_string "Warning: option -libdir deprecated and ignored\n"; flush stdout;
125	116	parse (cfiles,args) rem
126	117	\| ("-db"\|"-debugger") :: rem ->
127		print_string "Warning: option -db/-debugger deprecated\n";flush stdout;
	118	print_string "Warning: option -db/-debugger deprecated and ignored\n";flush stdout;
128	119	parse (cfiles,args) rem
129	120
130	121	\| ("-?"\|"-h"\|"-H"\|"-help"\|"--help") :: _ -> usage ()

149	140	\| "-R" :: s :: "-as" :: [] -> usage ()
150	141	\| "-R" :: s :: t :: rem -> parse (cfiles,t::s::"-R"::args) rem
151	142
152		\| ("-notactics"\|"-debug"\|"-nolib"
	143	\| ("-notactics"\|"-debug"\|"-nolib"\|"-boot"
153	144	\|"-batch"\|"-nois"\|"-noglob"\|"-no-glob"
154	145	\|"-q"\|"-full"\|"-profile"\|"-just-parsing"\|"-echo" \|"-unsafe"\|"-quiet"
155	146	\|"-silent"\|"-m"\|"-xml"\|"-v7"\|"-v8"\|"-beautify"\|"-strict-implicit"

+214

-221

tactics/auto.ml less more

785	785	\| HintsTransparencyEntry of evaluable_global_reference list * bool
786	786	\| HintsExternEntry of
787	787	int * (patvar list * constr_pattern) option * glob_tactic_expr
788		\| HintsDestructEntry of identifier * int * (bool,unit) location *
789		(patvar list * constr_pattern) * glob_tactic_expr
790	788
791	789	let h = id_of_string "H"
792	790

857	855	let pat = Option.map fp patcom in
858	856	let tacexp = !forward_intern_tac (match pat with None -> [] \| Some (l, _) -> l) tacexp in
859	857	HintsExternEntry (pri, pat, tacexp)
860		\| HintsDestruct(na,pri,loc,pat,code) ->
861		let (l,_ as pat) = fp pat in
862		HintsDestructEntry (na,pri,loc,pat,!forward_intern_tac l code)
863	858
864	859	let add_hints local dbnames0 h =
865	860	if List.mem "nocore" dbnames0 then

875	870	add_transparency lhints b local dbnames
876	871	\| HintsExternEntry (pri, pat, tacexp) ->
877	872	add_externs pri pat tacexp local dbnames
878		\| HintsDestructEntry (na,pri,loc,pat,code) ->
879		if dbnames0<>[] then
880		warn (str"Database selection not implemented for destruct hints");
881		Dhyp.add_destructor_hint local na loc pat pri code
882	873
883	874	(**************************************************************************)
884	875	(* Functions for printing the hints *)

886	877
887	878	let pr_autotactic =
888	879	function
889		\| Res_pf (c,clenv) -> (str"apply " ++ pr_lconstr c)
890		\| ERes_pf (c,clenv) -> (str"eapply " ++ pr_lconstr c)
891		\| Give_exact c -> (str"exact " ++ pr_lconstr c)
	880	\| Res_pf (c,clenv) -> (str"apply " ++ pr_constr c)
	881	\| ERes_pf (c,clenv) -> (str"eapply " ++ pr_constr c)
	882	\| Give_exact c -> (str"exact " ++ pr_constr c)
892	883	\| Res_pf_THEN_trivial_fail (c,clenv) ->
893		(str"apply " ++ pr_lconstr c ++ str" ; trivial")
	884	(str"apply " ++ pr_constr c ++ str" ; trivial")
894	885	\| Unfold_nth c -> (str"unfold " ++ pr_evaluable_reference c)
895	886	\| Extern tac ->
896		(str "(external) " ++ Pptactic.pr_glob_tactic (Global.env()) tac)
	887	(str "(external) " ++ Pptactic.pr_glob_tactic (Global.env()) tac)
897	888
898	889	let pr_hint (id, v) =
899	890	(pr_autotactic v.code ++ str"(level " ++ int v.pri ++ str", id " ++ int id ++ str ")" ++ spc ())

1106	1097	with PatternMatchingFailure -> error "conclPattern" in
1107	1098	!forward_interp_tactic constr_bindings tac gl
1108	1099
	1100	(***********************************************************)
	1101	(** A debugging / verbosity framework for trivial and auto *)
	1102	(***********************************************************)
	1103
	1104	(** The following options allow to trigger debugging/verbosity
	1105	without having to adapt the scripts.
	1106	Note: if Debug and Info are both activated, Debug take precedence. *)
	1107
	1108	let global_debug_trivial = ref false
	1109	let global_debug_auto = ref false
	1110	let global_info_trivial = ref false
	1111	let global_info_auto = ref false
	1112
	1113	let add_option ls refe =
	1114	let _ = Goptions.declare_bool_option
	1115	{ Goptions.optsync = true;
	1116	Goptions.optdepr = false;
	1117	Goptions.optname = String.concat " " ls;
	1118	Goptions.optkey = ls;
	1119	Goptions.optread = (fun () -> !refe);
	1120	Goptions.optwrite = (:=) refe }
	1121	in ()
	1122
	1123	let _ =
	1124	add_option ["Debug";"Trivial"] global_debug_trivial;
	1125	add_option ["Debug";"Auto"] global_debug_auto;
	1126	add_option ["Info";"Trivial"] global_info_trivial;
	1127	add_option ["Info";"Auto"] global_info_auto
	1128
	1129	let no_dbg () = (Off,0,ref [])
	1130
	1131	let mk_trivial_dbg debug =
	1132	let d =
	1133	if debug = Debug \|\| !global_debug_trivial then Debug
	1134	else if debug = Info \|\| !global_info_trivial then Info
	1135	else Off
	1136	in (d,0,ref [])
	1137
	1138	(** Note : we start the debug depth of auto at 1 to distinguish it
	1139	for trivial (whose depth is 0). *)
	1140
	1141	let mk_auto_dbg debug =
	1142	let d =
	1143	if debug = Debug \|\| !global_debug_auto then Debug
	1144	else if debug = Info \|\| !global_info_auto then Info
	1145	else Off
	1146	in (d,1,ref [])
	1147
	1148	let incr_dbg = function (dbg,depth,trace) -> (dbg,depth+1,trace)
	1149
	1150	(** A tracing tactic for debug/info trivial/auto *)
	1151
	1152	let tclLOG (dbg,depth,trace) pp tac =
	1153	match dbg with
	1154	\| Off -> tac
	1155	\| Debug ->
	1156	(* For "debug (trivial/auto)", we directly output messages *)
	1157	let s = String.make depth '*' in
	1158	begin fun gl ->
	1159	try
	1160	let out = tac gl in
	1161	msg_debug (str s ++ spc () ++ pp () ++ str ". (success)");
	1162	out
	1163	with e ->
	1164	msg_debug (str s ++ spc () ++ pp () ++ str ". (fail)");
	1165	raise e
	1166	end
	1167	\| Info ->
	1168	(* For "info (trivial/auto)", we store a log trace *)
	1169	begin fun gl ->
	1170	try
	1171	let out = tac gl in
	1172	trace := (depth, Some pp) :: !trace;
	1173	out
	1174	with e ->
	1175	trace := (depth, None) :: !trace;
	1176	raise e
	1177	end
	1178
	1179	(** For info, from the linear trace information, we reconstitute the part
	1180	of the proof tree we're interested in. The last executed tactic
	1181	comes first in the trace (and it should be a successful one).
	1182	[depth] is the root depth of the tree fragment we're visiting.
	1183	[keep] means we're in a successful tree fragment (the very last
	1184	tactic has been successful). *)
	1185
	1186	let rec cleanup_info_trace depth acc = function
	1187	\| [] -> acc
	1188	\| (d,Some pp) :: l -> cleanup_info_trace d ((d,pp)::acc) l
	1189	\| l -> cleanup_info_trace depth acc (erase_subtree depth l)
	1190
	1191	and erase_subtree depth = function
	1192	\| [] -> []
	1193	\| (d,_) :: l -> if d = depth then l else erase_subtree depth l
	1194
	1195	let pr_info_atom (d,pp) =
	1196	msg_debug (str (String.make d ' ') ++ pp () ++ str ".")
	1197
	1198	let pr_info_trace = function
	1199	\| (Info,_,{contents=(d,Some pp)::l}) ->
	1200	List.iter pr_info_atom (cleanup_info_trace d [(d,pp)] l)
	1201	\| _ -> ()
	1202
	1203	let pr_info_nop = function
	1204	\| (Info,_,_) -> msg_debug (str "idtac.")
	1205	\| _ -> ()
	1206
	1207	let pr_dbg_header = function
	1208	\| (Off,_,_) -> ()
	1209	\| (Debug,0,_) -> msg_debug (str "(* debug trivial : *)")
	1210	\| (Debug,_,_) -> msg_debug (str "(* debug auto : *)")
	1211	\| (Info,0,_) -> msg_debug (str "(* info trivial : *)")
	1212	\| (Info,_,_) -> msg_debug (str "(* info auto : *)")
	1213
	1214	let tclTRY_dbg d tac =
	1215	tclORELSE0
	1216	(fun gl ->
	1217	pr_dbg_header d;
	1218	let out = tac gl in
	1219	pr_info_trace d;
	1220	out)
	1221	(fun gl ->
	1222	pr_info_nop d;
	1223	tclIDTAC gl)
	1224
1109	1225	(**************************************************************************)
1110	1226	(* The Trivial tactic *)
1111	1227	(**************************************************************************)

1129	1245	\| EvalConstRef _ -> true
1130	1246	\| EvalVarRef v -> try ignore(lookup_named v env); true with Not_found -> false
1131	1247
1132		let rec trivial_fail_db mod_delta db_list local_db gl =
	1248	let dbg_intro dbg = tclLOG dbg (fun () -> str "intro") intro
	1249	let dbg_assumption dbg = tclLOG dbg (fun () -> str "assumption") assumption
	1250
	1251	let rec trivial_fail_db dbg mod_delta db_list local_db gl =
1133	1252	let intro_tac =
1134		tclTHEN intro
	1253	tclTHEN (dbg_intro dbg)
1135	1254	(fun g'->
1136	1255	let hintl = make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g')
1137		in trivial_fail_db mod_delta db_list (Hint_db.add_list hintl local_db) g')
	1256	in trivial_fail_db dbg mod_delta db_list (Hint_db.add_list hintl local_db) g')
1138	1257	in
1139	1258	tclFIRST
1140		(assumption::intro_tac::
1141		(List.map (fun tac -> tclCOMPLETE tac)
1142		(trivial_resolve mod_delta db_list local_db (pf_concl gl)))) gl
	1259	((dbg_assumption dbg)::intro_tac::
	1260	(List.map tclCOMPLETE
	1261	(trivial_resolve dbg mod_delta db_list local_db (pf_concl gl)))) gl
1143	1262
1144	1263	and my_find_search_nodelta db_list local_db hdc concl =
1145	1264	List.map (fun hint -> (None,hint))

1180	1299	in List.map (fun x -> (Some flags,x)) l)
1181	1300	(local_db::db_list)
1182	1301
1183		and tac_of_hint db_list local_db concl (flags, ({pat=p; code=t})) =
	1302	and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t})) =
1184	1303	let tactic =
1185	1304	match t with
1186	1305	\| Res_pf (c,cl) -> unify_resolve_gen flags (c,cl)

1189	1308	\| Res_pf_THEN_trivial_fail (c,cl) ->
1190	1309	tclTHEN
1191	1310	(unify_resolve_gen flags (c,cl))
1192		(trivial_fail_db (flags <> None) db_list local_db)
1193		\| Unfold_nth c ->
	1311	(* With "(debug) trivial", we shouldn't end here, and
	1312	with "debug auto" we don't display the details of inner trivial *)
	1313	(trivial_fail_db (no_dbg ()) (flags <> None) db_list local_db)
	1314	\| Unfold_nth c ->
1194	1315	(fun gl ->
1195	1316	if exists_evaluable_reference (pf_env gl) c then
1196	1317	tclPROGRESS (h_reduce (Unfold [all_occurrences_expr,c]) onConcl) gl
1197	1318	else tclFAIL 0 (str"Unbound reference") gl)
1198	1319	\| Extern tacast -> conclPattern concl p tacast
1199		in tactic
1200
1201		and trivial_resolve mod_delta db_list local_db cl =
	1320	in
	1321	tclLOG dbg (fun () -> pr_autotactic t) tactic
	1322
	1323	and trivial_resolve dbg mod_delta db_list local_db cl =
1202	1324	try
1203	1325	let head =
1204	1326	try let hdconstr,_ = head_constr_bound cl in
1205	1327	Some (head_of_constr_reference hdconstr)
1206	1328	with Bound -> None
1207	1329	in
1208		List.map (tac_of_hint db_list local_db cl)
	1330	List.map (tac_of_hint dbg db_list local_db cl)
1209	1331	(priority
1210	1332	(my_find_search mod_delta db_list local_db head cl))
1211	1333	with Not_found -> []

1222	1344	in
1223	1345	List.map lookup dbnames
1224	1346
1225		let trivial lems dbnames gl =
	1347	let trivial ?(debug=Off) lems dbnames gl =
1226	1348	let db_list = make_db_list dbnames in
1227		tclTRY (trivial_fail_db false db_list (make_local_hint_db false lems gl)) gl
1228
1229		let full_trivial lems gl =
	1349	let d = mk_trivial_dbg debug in
	1350	tclTRY_dbg d
	1351	(trivial_fail_db d false db_list (make_local_hint_db false lems gl)) gl
	1352
	1353	let full_trivial ?(debug=Off) lems gl =
1230	1354	let dbnames = Hintdbmap.dom !searchtable in
1231	1355	let dbnames = list_remove "v62" dbnames in
1232	1356	let db_list = List.map (fun x -> searchtable_map x) dbnames in
1233		tclTRY (trivial_fail_db false db_list (make_local_hint_db false lems gl)) gl
1234
1235		let gen_trivial lems = function
1236		\| None -> full_trivial lems
1237		\| Some l -> trivial lems l
1238
1239		let h_trivial lems l =
1240		Refiner.abstract_tactic (TacTrivial (List.map snd lems,l))
1241		(gen_trivial lems l)
	1357	let d = mk_trivial_dbg debug in
	1358	tclTRY_dbg d
	1359	(trivial_fail_db d false db_list (make_local_hint_db false lems gl)) gl
	1360
	1361	let gen_trivial ?(debug=Off) lems = function
	1362	\| None -> full_trivial ~debug lems
	1363	\| Some l -> trivial ~debug lems l
	1364
	1365	let h_trivial ?(debug=Off) lems l =
	1366	Refiner.abstract_tactic (TacTrivial (debug,List.map snd lems,l))
	1367	(gen_trivial ~debug lems l)
1242	1368
1243	1369	(**************************************************************************)
1244	1370	(* The classical Auto tactic *)
1245	1371	(**************************************************************************)
1246	1372
1247		let possible_resolve mod_delta db_list local_db cl =
	1373	let possible_resolve dbg mod_delta db_list local_db cl =
1248	1374	try
1249	1375	let head =
1250	1376	try let hdconstr,_ = head_constr_bound cl in
1251	1377	Some (head_of_constr_reference hdconstr)
1252	1378	with Bound -> None
1253	1379	in
1254		List.map (tac_of_hint db_list local_db cl)
	1380	List.map (tac_of_hint dbg db_list local_db cl)
1255	1381	(my_find_search mod_delta db_list local_db head cl)
1256	1382	with Not_found -> []
1257	1383
1258		let decomp_unary_term_then (id,_,typc) kont1 kont2 gl =
	1384	let dbg_case dbg id =
	1385	tclLOG dbg (fun () -> str "case " ++ pr_id id) (simplest_case (mkVar id))
	1386
	1387	let decomp_unary_term_then dbg (id,_,typc) kont1 kont2 gl =
1259	1388	try
1260	1389	let ccl = applist (head_constr typc) in
1261	1390	match Hipattern.match_with_conjunction ccl with
1262	1391	\| Some (_,args) ->
1263		tclTHEN (simplest_case (mkVar id)) (kont1 (List.length args)) gl
	1392	tclTHEN (dbg_case dbg id) (kont1 (List.length args)) gl
1264	1393	\| None ->
1265	1394	kont2 gl
1266	1395	with UserError _ -> kont2 gl
1267	1396
1268		let decomp_empty_term (id,_,typc) gl =
	1397	let decomp_empty_term dbg (id,_,typc) gl =
1269	1398	if Hipattern.is_empty_type typc then
1270		simplest_case (mkVar id) gl
	1399	dbg_case dbg id gl
1271	1400	else
1272	1401	errorlabstrm "Auto.decomp_empty_term" (str "Not an empty type.")
1273	1402
1274	1403	let extend_local_db gl decl db =
1275	1404	Hint_db.add_list (make_resolve_hyp (pf_env gl) (project gl) decl) db
1276	1405
1277		(* Try to decompose hypothesis [decl] into atomic components of a
1278		conjunction with maximum depth [p] (or solve the goal from an
1279		empty type) then call the continuation tactic with hint db extended
1280		with the obtained not-further-decomposable hypotheses *)
1281
1282		let rec decomp_and_register_decl p kont (id,_,_ as decl) db gl =
1283		if p = 0 then
1284		kont (extend_local_db gl decl db) gl
1285		else
1286		tclORELSE0
1287		(decomp_empty_term decl)
1288		(decomp_unary_term_then decl (intros_decomp (p-1) kont [] db)
1289		(kont (extend_local_db gl decl db))) gl
1290
1291		(* Introduce [n] hypotheses, then decompose then with maximum depth [p] and
1292		call the continuation tactic [kont] with the hint db extended
1293		with the so-obtained not-further-decomposable hypotheses *)
1294
1295		and intros_decomp p kont decls db n =
1296		if n = 0 then
1297		decomp_and_register_decls p kont decls db
1298		else
1299		tclTHEN intro (onLastDecl (fun d ->
1300		(intros_decomp p kont (d::decls) db (n-1))))
1301
1302		(* Decompose hypotheses [hyps] with maximum depth [p] and
1303		call the continuation tactic [kont] with the hint db extended
1304		with the so-obtained not-further-decomposable hypotheses *)
1305
1306		and decomp_and_register_decls p kont decls =
1307		List.fold_left (decomp_and_register_decl p) kont decls
1308
1309
1310		(* decomp is an natural number giving an indication on decomposition
1311		of conjunction in hypotheses, 0 corresponds to no decomposition *)
	1406	(* Introduce an hypothesis, then call the continuation tactic [kont]
	1407	with the hint db extended with the so-obtained hypothesis *)
	1408
	1409	let intro_register dbg kont db =
	1410	tclTHEN (dbg_intro dbg)
	1411	(onLastDecl (fun decl gl -> kont (extend_local_db gl decl db) gl))
	1412
1312	1413	(* n is the max depth of search *)
1313	1414	(* local_db contains the local Hypotheses *)
1314	1415
1315	1416	exception Uplift of tactic list
1316	1417
1317		let search_gen p n mod_delta db_list local_db =
1318		let rec search n local_db =
	1418	let search d n mod_delta db_list local_db =
	1419	let rec search d n local_db =
1319	1420	if n=0 then (fun gl -> error "BOUND 2") else
1320		tclORELSE0 assumption
1321		(tclORELSE0 (intros_decomp p (search n) [] local_db 1)
1322		(fun gl -> tclFIRST
1323		(List.map (fun ntac -> tclTHEN ntac (search (n-1) local_db))
1324		(possible_resolve mod_delta db_list local_db (pf_concl gl))) gl))
	1421	tclORELSE0 (dbg_assumption d)
	1422	(tclORELSE0 (intro_register d (search d n) local_db)
	1423	(fun gl ->
	1424	let d' = incr_dbg d in
	1425	tclFIRST
	1426	(List.map
	1427	(fun ntac -> tclTHEN ntac (search d' (n-1) local_db))
	1428	(possible_resolve d mod_delta db_list local_db (pf_concl gl))) gl))
1325	1429	in
1326		search n local_db
1327
1328		let search = search_gen 0
	1430	search d n local_db
1329	1431
1330	1432	let default_search_depth = ref 5
1331	1433
1332		let delta_auto mod_delta n lems dbnames gl =
	1434	let delta_auto ?(debug=Off) mod_delta n lems dbnames gl =
1333	1435	let db_list = make_db_list dbnames in
1334		tclTRY (search n mod_delta db_list (make_local_hint_db false lems gl)) gl
1335
1336		let auto = delta_auto false
1337
1338		let new_auto = delta_auto true
	1436	let d = mk_auto_dbg debug in
	1437	tclTRY_dbg d
	1438	(search d n mod_delta db_list (make_local_hint_db false lems gl)) gl
	1439
	1440	let auto ?(debug=Off) n = delta_auto ~debug false n
	1441
	1442	let new_auto ?(debug=Off) n = delta_auto ~debug true n
1339	1443
1340	1444	let default_auto = auto !default_search_depth [] []
1341	1445
1342		let delta_full_auto mod_delta n lems gl =
	1446	let delta_full_auto ?(debug=Off) mod_delta n lems gl =
1343	1447	let dbnames = Hintdbmap.dom !searchtable in
1344	1448	let dbnames = list_remove "v62" dbnames in
1345	1449	let db_list = List.map (fun x -> searchtable_map x) dbnames in
1346		tclTRY (search n mod_delta db_list (make_local_hint_db false lems gl)) gl
1347
1348		let full_auto = delta_full_auto false
1349		let new_full_auto = delta_full_auto true
	1450	let d = mk_auto_dbg debug in
	1451	tclTRY_dbg d
	1452	(search d n mod_delta db_list (make_local_hint_db false lems gl)) gl
	1453
	1454	let full_auto ?(debug=Off) n = delta_full_auto ~debug false n
	1455	let new_full_auto ?(debug=Off) n = delta_full_auto ~debug true n
1350	1456
1351	1457	let default_full_auto gl = full_auto !default_search_depth [] gl
1352	1458
1353		let gen_auto n lems dbnames =
	1459	let gen_auto ?(debug=Off) n lems dbnames =
1354	1460	let n = match n with None -> !default_search_depth \| Some n -> n in
1355	1461	match dbnames with
1356		\| None -> full_auto n lems
1357		\| Some l -> auto n lems l
	1462	\| None -> full_auto ~debug n lems
	1463	\| Some l -> auto ~debug n lems l
1358	1464
1359	1465	let inj_or_var = Option.map (fun n -> ArgArg n)
1360	1466
1361		let h_auto n lems l =
1362		Refiner.abstract_tactic (TacAuto (inj_or_var n,List.map snd lems,l))
1363		(gen_auto n lems l)
1364
1365		(**************************************************************************)
1366		(* The "destructing Auto" from Eduardo *)
1367		(**************************************************************************)
1368
1369		(* Depth of search after decomposition of hypothesis, by default
1370		one look for an immediate solution *)
1371		let default_search_decomp = ref 20
1372
1373		let destruct_auto p lems n gl =
1374		decomp_and_register_decls p (fun local_db gl ->
1375		search_gen p n false (List.map searchtable_map ["core";"extcore"])
1376		(add_hint_lemmas false lems local_db gl) gl)
1377		(pf_hyps gl)
1378		(Hint_db.empty empty_transparent_state false)
1379		gl
1380
1381		let dautomatic des_opt lems n = tclTRY (destruct_auto des_opt lems n)
1382
1383		let dauto (n,p) lems =
1384		let p = match p with Some p -> p \| None -> !default_search_decomp in
1385		let n = match n with Some n -> n \| None -> !default_search_depth in
1386		dautomatic p lems n
1387
1388		let default_dauto = dauto (None,None) []
1389
1390		let h_dauto (n,p) lems =
1391		Refiner.abstract_tactic (TacDAuto (inj_or_var n,p,List.map snd lems))
1392		(dauto (n,p) lems)
1393
1394		(***************************************)
1395		(* A new formulation of Auto *******)
1396		(***************************************)
1397
1398		let make_resolve_any_hyp env sigma (id,_,ty) =
1399		let ents =
1400		map_succeed
1401		(fun f -> f (mkVar id,ty))
1402		[make_exact_entry sigma None; make_apply_entry env sigma (true,true,false) None]
1403		in
1404		ents
1405
1406		type autoArguments =
1407		\| UsingTDB
1408		\| Destructing
1409
1410		let compileAutoArg contac = function
1411		\| Destructing ->
1412		(function g ->
1413		let ctx = pf_hyps g in
1414		tclFIRST
1415		(List.map
1416		(fun (id,_,typ) ->
1417		let cl = (strip_prod_assum typ) in
1418		if Hipattern.is_conjunction cl
1419		then
1420		tclTHENSEQ [simplest_elim (mkVar id); clear [id]; contac]
1421		else
1422		tclFAIL 0 (pr_id id ++ str" is not a conjunction"))
1423		ctx) g)
1424		\| UsingTDB ->
1425		(tclTHEN
1426		(Tacticals.tryAllHypsAndConcl
1427		(function
1428		\| Some id -> Dhyp.h_destructHyp false id
1429		\| None -> Dhyp.h_destructConcl))
1430		contac)
1431
1432		let compileAutoArgList contac = List.map (compileAutoArg contac)
1433
1434		let rec super_search n db_list local_db argl gl =
1435		if n = 0 then error "BOUND 2";
1436		tclFIRST
1437		(assumption
1438		::
1439		tclTHEN intro
1440		(fun g ->
1441		let hintl = pf_apply make_resolve_any_hyp g (pf_last_hyp g) in
1442		super_search n db_list (Hint_db.add_list hintl local_db)
1443		argl g)
1444		::
1445		List.map (fun ntac ->
1446		tclTHEN ntac
1447		(super_search (n-1) db_list local_db argl))
1448		(possible_resolve false db_list local_db (pf_concl gl))
1449		@
1450		compileAutoArgList (super_search (n-1) db_list local_db argl) argl) gl
1451
1452		let search_superauto n to_add argl g =
1453		let sigma =
1454		List.fold_right
1455		(fun (id,c) -> add_named_decl (id, None, pf_type_of g c))
1456		to_add empty_named_context in
1457		let db0 = list_map_append (make_resolve_hyp (pf_env g) (project g)) sigma in
1458		let db = Hint_db.add_list db0 (make_local_hint_db false [] g) in
1459		super_search n [Hintdbmap.find "core" !searchtable] db argl g
1460
1461		let superauto n to_add argl =
1462		tclTRY (tclCOMPLETE (search_superauto n to_add argl))
1463
1464		let interp_to_add gl r =
1465		let r = locate_global_with_alias (qualid_of_reference r) in
1466		let id = basename_of_global r in
1467		(next_ident_away id (pf_ids_of_hyps gl), constr_of_global r)
1468
1469		let gen_superauto nopt l a b gl =
1470		let n = match nopt with Some n -> n \| None -> !default_search_depth in
1471		let al = (if a then [Destructing] else [])@(if b then [UsingTDB] else []) in
1472		superauto n (List.map (interp_to_add gl) l) al gl
1473
1474		let h_superauto no l a b =
1475		Refiner.abstract_tactic (TacSuperAuto (no,l,a,b)) (gen_superauto no l a b)
1476
	1467	let h_auto ?(debug=Off) n lems l =
	1468	Refiner.abstract_tactic (TacAuto (debug,inj_or_var n,List.map snd lems,l))
	1469	(gen_auto ~debug n lems l)

+22

-32

tactics/auto.mli less more

101	101	\| HintsTransparencyEntry of evaluable_global_reference list * bool
102	102	\| HintsExternEntry of
103	103	int * (patvar list * constr_pattern) option * Tacexpr.glob_tactic_expr
104		\| HintsDestructEntry of identifier * int * (bool,unit) Tacexpr.location *
105		(patvar list * constr_pattern) * Tacexpr.glob_tactic_expr
106	104
107	105	val searchtable_map : hint_db_name -> hint_db
108	106

219	217
220	218	val make_db_list : hint_db_name list -> hint_db list
221	219
222		val auto : int -> open_constr list -> hint_db_name list -> tactic
	220	val auto : ?debug:Tacexpr.debug ->
	221	int -> open_constr list -> hint_db_name list -> tactic
223	222
224	223	(** Auto with more delta. *)
225	224
226		val new_auto : int -> open_constr list -> hint_db_name list -> tactic
	225	val new_auto : ?debug:Tacexpr.debug ->
	226	int -> open_constr list -> hint_db_name list -> tactic
227	227
228	228	(** auto with default search depth and with the hint database "core" *)
229	229	val default_auto : tactic
230	230
231	231	(** auto with all hint databases except the "v62" compatibility database *)
232		val full_auto : int -> open_constr list -> tactic
	232	val full_auto : ?debug:Tacexpr.debug ->
	233	int -> open_constr list -> tactic
233	234
234	235	(** auto with all hint databases except the "v62" compatibility database
235	236	and doing delta *)
236		val new_full_auto : int -> open_constr list -> tactic
	237	val new_full_auto : ?debug:Tacexpr.debug ->
	238	int -> open_constr list -> tactic
237	239
238	240	(** auto with default search depth and with all hint databases
239	241	except the "v62" compatibility database *)
240	242	val default_full_auto : tactic
241	243
242	244	(** The generic form of auto (second arg [None] means all bases) *)
243		val gen_auto : int option -> open_constr list -> hint_db_name list option -> tactic
	245	val gen_auto : ?debug:Tacexpr.debug ->
	246	int option -> open_constr list -> hint_db_name list option -> tactic
244	247
245	248	(** The hidden version of auto *)
246		val h_auto : int option -> open_constr list -> hint_db_name list option -> tactic
	249	val h_auto : ?debug:Tacexpr.debug ->
	250	int option -> open_constr list -> hint_db_name list option -> tactic
247	251
248	252	(** Trivial *)
249		val trivial : open_constr list -> hint_db_name list -> tactic
250		val gen_trivial : open_constr list -> hint_db_name list option -> tactic
251		val full_trivial : open_constr list -> tactic
252		val h_trivial : open_constr list -> hint_db_name list option -> tactic
	253
	254	val trivial : ?debug:Tacexpr.debug ->
	255	open_constr list -> hint_db_name list -> tactic
	256	val gen_trivial : ?debug:Tacexpr.debug ->
	257	open_constr list -> hint_db_name list option -> tactic
	258	val full_trivial : ?debug:Tacexpr.debug ->
	259	open_constr list -> tactic
	260	val h_trivial : ?debug:Tacexpr.debug ->
	261	open_constr list -> hint_db_name list option -> tactic
253	262
254	263	val pr_autotactic : 'a auto_tactic -> Pp.std_ppcmds
255	264
256		(** {6 The following is not yet up to date -- Papageno. } *)
257
258		(** DAuto *)
259		val dauto : int option * int option -> open_constr list -> tactic
260		val default_search_decomp : int ref
261		val default_dauto : tactic
262
263		val h_dauto : int option * int option -> open_constr list -> tactic
264
265		(** SuperAuto *)
266
267		type autoArguments =
268		\| UsingTDB
269		\| Destructing
270
271		(*
272		val superauto : int -> (identifier * constr) list -> autoArguments list -> tactic
273		*)
274
275		val h_superauto : int option -> reference list -> bool -> bool -> tactic
	265	(** Hook for changing the initialization of auto *)
276	266
277	267	val add_auto_init : (unit -> unit) -> unit

+27

-14

tactics/class_tactics.ml4 less more

633	633	snd (p oevd ev evi))
634	634	evd false
635	635
	636	(** Revert the resolvability status of evars after resolution,
	637	potentially unprotecting some evars that were set unresolvable
	638	just for this call to resolution. *)
	639
	640	let revert_resolvability oevd evd =
	641	Evd.fold_undefined
	642	(fun ev evi evm ->
	643	try
	644	if not (Typeclasses.is_resolvable evi) then
	645	let evi' = Evd.find_undefined oevd ev in
	646	if Typeclasses.is_resolvable evi' then
	647	Evd.add evm ev (Typeclasses.mark_resolvable evi)
	648	else evm
	649	else evm
	650	with Not_found -> evm)
	651	evd evd
	652
636	653	(** If [do_split] is [true], we try to separate the problem in
637	654	several components and then solve them separately *)
638	655

643	660	let in_comp comp ev = if do_split then Intset.mem ev comp else true
644	661	in
645	662	let rec docomp evd = function
646		\| [] -> evd
	663	\| [] -> revert_resolvability oevd evd
647	664	\| comp :: comps ->
648	665	let p = select_and_update_evars p oevd (in_comp comp) in
649	666	try

658	675	docomp evd comps
659	676	in docomp oevd split
660	677
661		let initial_select_evars onlyargs =
662		if onlyargs then
663		(fun evd ev evi ->
664		Typeclasses.is_implicit_arg (snd (Evd.evar_source ev evd))
665		&& Typeclasses.is_class_evar evd evi)
666		else
667		(fun evd ev evi -> Typeclasses.is_class_evar evd evi)
668
669		let resolve_typeclass_evars debug m env evd onlyargs split fail =
	678	let initial_select_evars filter evd ev evi =
	679	filter (snd evi.Evd.evar_source) &&
	680	Typeclasses.is_class_evar evd evi
	681
	682	let resolve_typeclass_evars debug m env evd filter split fail =
670	683	let evd =
671	684	try Evarconv.consider_remaining_unif_problems
672	685	~ts:(Typeclasses.classes_transparent_state ()) env evd
673	686	with _ -> evd
674	687	in
675		resolve_all_evars debug m env (initial_select_evars onlyargs) evd split fail
676
677		let solve_inst debug depth env evd onlyargs split fail =
678		resolve_typeclass_evars debug depth env evd onlyargs split fail
	688	resolve_all_evars debug m env (initial_select_evars filter) evd split fail
	689
	690	let solve_inst debug depth env evd filter split fail =
	691	resolve_typeclass_evars debug depth env evd filter split fail
679	692
680	693	let _ =
681	694	Typeclasses.solve_instanciations_problem :=

+0

-359

~~tactics/dhyp.ml~~ less more

0		(************************************************************************)
1		(* v * The Coq Proof Assistant / The Coq Development Team *)
2		(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
3		(* \VV/ **************************************************************)
4		(* // * This file is distributed under the terms of the *)
5		(* * GNU Lesser General Public License Version 2.1 *)
6		(************************************************************************)
7
8		(* Chet's comments about this tactic :
9
10		Programmable destruction of hypotheses and conclusions.
11
12		The idea here is that we are going to store patterns. These
13		patterns look like:
14
15		TYP=<pattern>
16		SORT=<pattern>
17
18		and from these patterns, we will be able to decide which tactic to
19		execute.
20
21		For hypotheses, we have a vector of 4 patterns:
22
23		HYP[TYP] HYP[SORT] CONCL[TYP] CONCL[SORT]
24
25		and for conclusions, we have 2:
26
27		CONCL[TYP] CONCL[SORT]
28
29		If the user doesn't supply some of these, they are just replaced
30		with empties.
31
32		The process of matching goes like this:
33
34		We use a discrimination net to look for matches between the pattern
35		for HYP[TOP] (CONCL[TOP]) and the type of the chosen hypothesis.
36		Then, we use this to look for the right tactic to apply, by
37		matching the rest of the slots. Each match is tried, and if there
38		is more than one, this fact is reported, and the one with the
39		lowest priority is taken. The priority is a parameter of the
40		tactic input.
41
42		The tactic input is an expression to hand to the
43		tactic-interpreter, and its priority.
44
45		For most tactics, the priority should be the number of subgoals
46		generated.
47
48		Matching is compatible with second-order matching of sopattern.
49
50		SYNTAX:
51
52		Hint DHyp <hyp-pattern> pri <tac-pattern>.
53
54		and
55
56		Hint DConcl <concl-pattern> pri <tac-pattern>.
57
58		The bindings at the end allow us to transfer information from the
59		patterns on terms into the patterns on tactics in a safe way - we
60		will perform second-order normalization and conversion to an AST
61		before substitution into the tactic-expression.
62
63		WARNING: The binding mechanism is NOT intended to facilitate the
64		transfer of large amounts of information from the terms to the
65		tactic. This should be done in a special-purpose tactic.
66
67		*)
68
69		(*
70
71		Example : The tactic "if there is a hypothesis saying that the
72		successor of some number is smaller than zero, then invert such
73		hypothesis" is defined in this way:
74
75		Require DHyp.
76		Hint Destruct Hypothesis less_than_zero (le (S ?) O) 1
77		(:tactic:<Inversion $0>).
78
79		Then, the tactic is used like this:
80
81		Goal (le (S O) O) -> False.
82		Intro H.
83		DHyp H.
84		Qed.
85
86		The name "$0" refers to the matching hypothesis --in this case the
87		hypothesis H.
88
89		Similarly for the conclusion :
90
91		Hint Destruct Conclusion equal_zero (? = ?) 1 (:tactic:<Reflexivity>).
92
93		Goal (plus O O)=O.
94		DConcl.
95		Qed.
96
97		The "Discardable" option clears the hypothesis after using it.
98
99		Require DHyp.
100		Hint Destruct Discardable Hypothesis less_than_zero (le (S ?) O) 1
101		(:tactic:<Inversion $0>).
102
103		Goal (n:nat)(le (S n) O) -> False.
104		Intros n H.
105		DHyp H.
106		Qed.
107		-- Eduardo (9/3/97 )
108
109		*)
110
111		open Pp
112		open Util
113		open Names
114		open Term
115		open Environ
116		open Reduction
117		open Proof_type
118		open Glob_term
119		open Tacmach
120		open Refiner
121		open Tactics
122		open Clenv
123		open Tactics
124		open Tacticals
125		open Libobject
126		open Library
127		open Pattern
128		open Matching
129		open Pcoq
130		open Tacexpr
131		open Termops
132		open Libnames
133
134		(* two patterns - one for the type, and one for the type of the type *)
135		type destructor_pattern = {
136		d_typ: constr_pattern;
137		d_sort: constr_pattern }
138
139		let subst_destructor_pattern subst { d_typ = t; d_sort = s } =
140		{ d_typ = subst_pattern subst t; d_sort = subst_pattern subst s }
141
142		(* hypothesis patterns might need to do matching on the conclusion, too.
143		* conclusion-patterns only need to do matching on the hypothesis *)
144		type located_destructor_pattern =
145		(* discardable, pattern for hyp, pattern for concl *)
146		(bool * destructor_pattern * destructor_pattern,
147		(* pattern for concl *)
148		destructor_pattern) location
149
150		let subst_located_destructor_pattern subst = function
151		\| HypLocation (b,d,d') ->
152		HypLocation
153		(b,subst_destructor_pattern subst d, subst_destructor_pattern subst d')
154		\| ConclLocation d ->
155		ConclLocation (subst_destructor_pattern subst d)
156
157
158		type destructor_data = {
159		d_pat : located_destructor_pattern;
160		d_pri : int;
161		d_code : identifier option * glob_tactic_expr (* should be of phylum tactic *)
162		}
163
164		module Dest_data = struct
165		type t = destructor_data
166		let compare = Pervasives.compare
167		end
168
169		module Nbterm_net = Nbtermdn.Make(Dest_data)
170
171		type t = identifier Nbterm_net.t
172		type frozen_t = identifier Nbterm_net.frozen_t
173
174		let tactab = (Nbterm_net.create () : t)
175
176		let lookup pat = Nbterm_net.lookup tactab pat
177
178
179		let init () = Nbterm_net.empty tactab
180
181		let freeze () = Nbterm_net.freeze tactab
182		let unfreeze fs = Nbterm_net.unfreeze fs tactab
183
184		let add (na,dd) =
185		let pat = match dd.d_pat with
186		\| HypLocation(_,p,_) -> p.d_typ
187		\| ConclLocation p -> p.d_typ
188		in
189		if Nbterm_net.in_dn tactab na then begin
190		msgnl (str "Warning [Overriding Destructor Entry " ++
191		str (string_of_id na) ++ str"]");
192		Nbterm_net.remap tactab na (pat,dd)
193		end else
194		Nbterm_net.add tactab (na,(pat,dd))
195
196		let _ =
197		Summary.declare_summary "destruct-hyp-concl"
198		{ Summary.freeze_function = freeze;
199		Summary.unfreeze_function = unfreeze;
200		Summary.init_function = init }
201
202		let forward_subst_tactic =
203		ref (fun _ -> failwith "subst_tactic is not installed for DHyp")
204
205		let cache_dd (_,(_,na,dd)) =
206		try
207		add (na,dd)
208		with _ ->
209		anomalylabstrm "Dhyp.add"
210		(str"The code which adds destructor hints broke;" ++ spc () ++
211		str"this is not supposed to happen")
212
213		let classify_dd (local,_,_ as o) =
214		if local then Dispose else Substitute o
215
216		let subst_dd (subst,(local,na,dd)) =
217		(local,na,
218		{ d_pat = subst_located_destructor_pattern subst dd.d_pat;
219		d_pri = dd.d_pri;
220		d_code = !forward_subst_tactic subst dd.d_code })
221
222		let inDD : bool * identifier * destructor_data -> obj =
223		declare_object {(default_object "DESTRUCT-HYP-CONCL-DATA") with
224		cache_function = cache_dd;
225		open_function = (fun i o -> if i=1 then cache_dd o);
226		subst_function = subst_dd;
227		classify_function = classify_dd }
228
229		let catch_all_sort_pattern = PMeta(Some (id_of_string "SORT"))
230		let catch_all_type_pattern = PMeta(Some (id_of_string "TYPE"))
231
232		let add_destructor_hint local na loc (_,pat) pri code =
233		let code =
234		begin match loc, code with
235		\| HypLocation _, TacFun ([id],body) -> (id,body)
236		\| ConclLocation _, _ -> (None, code)
237		\| _ ->
238		errorlabstrm "add_destructor_hint"
239		(str "The tactic should be a function of the hypothesis name.") end
240		in
241		let pat = match loc with
242		\| HypLocation b ->
243		HypLocation
244		(b,{d_typ=pat;d_sort=catch_all_sort_pattern},
245		{d_typ=catch_all_type_pattern;d_sort=catch_all_sort_pattern})
246		\| ConclLocation () ->
247		ConclLocation({d_typ=pat;d_sort=catch_all_sort_pattern}) in
248		Lib.add_anonymous_leaf
249		(inDD (local,na,{ d_pat = pat; d_pri=pri; d_code=code }))
250
251		let match_dpat dp cls gls =
252		let onconcl = cls.concl_occs <> no_occurrences_expr in
253		match (cls,dp) with
254		\| ({onhyps=lo},HypLocation(_,hypd,concld)) when not onconcl ->
255		let hl = match lo with
256		Some l -> l
257		\| None -> List.map (fun id -> ((all_occurrences_expr,id),InHyp))
258		(pf_ids_of_hyps gls) in
259		if not
260		(List.for_all
261		(fun ((_,id),hl) ->
262		let cltyp = pf_get_hyp_typ gls id in
263		let cl = pf_concl gls in
264		(hl=InHyp) &
265		(is_matching hypd.d_typ cltyp) &
266		(is_matching hypd.d_sort (pf_type_of gls cltyp)) &
267		(is_matching concld.d_typ cl) &
268		(is_matching concld.d_sort (pf_type_of gls cl)))
269		hl)
270		then error "No match."
271		\| ({onhyps=Some[]},ConclLocation concld) when onconcl ->
272		let cl = pf_concl gls in
273		if not
274		((is_matching concld.d_typ cl) &
275		(is_matching concld.d_sort (pf_type_of gls cl)))
276		then error "No match."
277		\| _ -> error "ApplyDestructor"
278
279		let forward_interp_tactic =
280		ref (fun _ -> failwith "interp_tactic is not installed for DHyp")
281
282		let set_extern_interp f = forward_interp_tactic := f
283
284		let applyDestructor cls discard dd gls =
285		match_dpat dd.d_pat cls gls;
286		let cll = simple_clause_of cls gls in
287		let tacl =
288		List.map (fun cl ->
289		match cl, dd.d_code with
290		\| Some id, (Some x, tac) ->
291		let arg =
292		ConstrMayEval(ConstrTerm (GRef(dummy_loc,VarRef id),None)) in
293		TacLetIn (false, [(dummy_loc, x), arg], tac)
294		\| None, (None, tac) -> tac
295		\| _, (Some _,_) -> error "Destructor expects an hypothesis."
296		\| _, (None,_) -> error "Destructor is for conclusion.")
297		cll in
298		let discard_0 =
299		List.map (fun cl ->
300		match (cl,dd.d_pat) with
301		\| (Some id,HypLocation(discardable,_,_)) ->
302		if discard & discardable then thin [id] else tclIDTAC
303		\| (None,ConclLocation _) -> tclIDTAC
304		\| _ -> error "ApplyDestructor" ) cll in
305		tclTHEN (tclMAP !forward_interp_tactic tacl) (tclTHENLIST discard_0) gls
306
307
308		(* [DHyp id gls]
309
310		will take an identifier, get its type, look it up in the
311		discrimination net, get the destructors stored there, and then try
312		them in order of priority. *)
313
314		let destructHyp discard id gls =
315		let hyptyp = pf_get_hyp_typ gls id in
316		let ddl = List.map snd (lookup hyptyp) in
317		let sorted_ddl = Sort.list (fun dd1 dd2 -> dd1.d_pri > dd2.d_pri) ddl in
318		tclFIRST (List.map (applyDestructor (onHyp id) discard) sorted_ddl) gls
319
320		let dHyp id gls = destructHyp false id gls
321
322		let h_destructHyp b id =
323		abstract_tactic (TacDestructHyp (b,(dummy_loc,id))) (destructHyp b id)
324
325		(* [DConcl gls]
326
327		will take a goal, get its concl, look it up in the
328		discrimination net, get the destructors stored there, and then try
329		them in order of priority. *)
330
331		let dConcl gls =
332		let ddl = List.map snd (lookup (pf_concl gls)) in
333		let sorted_ddl = Sort.list (fun dd1 dd2 -> dd1.d_pri > dd2.d_pri) ddl in
334		tclFIRST (List.map (applyDestructor onConcl false) sorted_ddl) gls
335
336		let h_destructConcl = abstract_tactic TacDestructConcl dConcl
337
338		let rec search n =
339		if n=0 then error "Search has reached zero.";
340		tclFIRST
341		[intros;
342		assumption;
343		(tclTHEN
344		(Tacticals.tryAllHypsAndConcl
345		(function
346		\| Some id -> (dHyp id)
347		\| None -> dConcl ))
348		(search (n-1)))]
349
350		let auto_tdb n = tclTRY (tclCOMPLETE (search n))
351
352		let search_depth_tdb = ref(5)
353
354		let depth_tdb = function
355		\| None -> !search_depth_tdb
356		\| Some n -> n
357
358		let h_auto_tdb n = abstract_tactic (TacAutoTDB n) (auto_tdb (depth_tdb n))

+0

-28

~~tactics/dhyp.mli~~ less more

0		(************************************************************************)
1		(* v * The Coq Proof Assistant / The Coq Development Team *)
2		(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
3		(* \VV/ **************************************************************)
4		(* // * This file is distributed under the terms of the *)
5		(* * GNU Lesser General Public License Version 2.1 *)
6		(************************************************************************)
7
8		open Names
9		open Tacmach
10		open Tacexpr
11
12		(** Programmable destruction of hypotheses and conclusions. *)
13
14		val set_extern_interp : (glob_tactic_expr -> tactic) -> unit
15
16		(*
17		val dHyp : identifier -> tactic
18		val dConcl : tactic
19		*)
20		val h_destructHyp : bool -> identifier -> tactic
21		val h_destructConcl : tactic
22		val h_auto_tdb : int option -> tactic
23
24		val add_destructor_hint :
25		Vernacexpr.locality_flag -> identifier -> (bool,unit) Tacexpr.location ->
26		Glob_term.patvar list * Pattern.constr_pattern -> int ->
27		glob_tactic_expr -> unit

+105

-41

tactics/eauto.ml4 less more

26	26	open Auto
27	27	open Glob_term
28	28	open Hiddentac
	29	open Tacexpr
29	30
30	31	let eauto_unif_flags = { auto_unif_flags with Unification.modulo_delta = full_transparent_state }
31	32

170	171	tacres : goal list sigma;
171	172	last_tactic : std_ppcmds Lazy.t;
172	173	dblist : Auto.hint_db list;
173		localdb : Auto.hint_db list }
	174	localdb : Auto.hint_db list;
	175	prev : prev_search_state
	176	}
	177
	178	and prev_search_state = (* for info eauto *)
	179	\| Unknown
	180	\| Init
	181	\| State of search_state
174	182
175	183	module SearchProblem = struct
176	184

210	218	if s.depth = 0 then
211	219	[]
212	220	else
	221	let ps = if s.prev = Unknown then Unknown else State s in
213	222	let lg = s.tacres in
214	223	let nbgl = List.length (sig_it lg) in
215	224	assert (nbgl > 0);

224	233	in
225	234	List.map (fun (res,pp) -> { depth = s.depth; tacres = res;
226	235	last_tactic = pp; dblist = s.dblist;
227		localdb = List.tl s.localdb }) l
	236	localdb = List.tl s.localdb;
	237	prev = ps}) l
228	238	in
229	239	let intro_tac =
230	240	List.map

236	246	let ldb = Hint_db.add_list hintl (List.hd s.localdb) in
237	247	{ depth = s.depth; tacres = res;
238	248	last_tactic = pp; dblist = s.dblist;
239		localdb = ldb :: List.tl s.localdb })
	249	localdb = ldb :: List.tl s.localdb; prev = ps })
240	250	(filter_tactics s.tacres [Tactics.intro,lazy (str "intro")])
241	251	in
242	252	let rec_tacs =

247	257	(fun (lgls as res, pp) ->
248	258	let nbgl' = List.length (sig_it lgls) in
249	259	if nbgl' < nbgl then
250		{ depth = s.depth; tacres = res; last_tactic = pp;
	260	{ depth = s.depth; tacres = res; last_tactic = pp; prev = ps;
251	261	dblist = s.dblist; localdb = List.tl s.localdb }
252	262	else
253	263	{ depth = pred s.depth; tacres = res;
254		dblist = s.dblist; last_tactic = pp;
	264	dblist = s.dblist; last_tactic = pp; prev = ps;
255	265	localdb =
256	266	list_addn (nbgl'-nbgl) (List.hd s.localdb) s.localdb })
257	267	l
258	268	in
259	269	List.sort compare (assumption_tacs @ intro_tac @ rec_tacs)
260	270
261		let pp s =
262		msg (hov 0 (str " depth=" ++ int s.depth ++ spc () ++
263		(Lazy.force s.last_tactic) ++ str "\n"))
	271	let pp s = hov 0 (str " depth=" ++ int s.depth ++ spc () ++
	272	(Lazy.force s.last_tactic))
264	273
265	274	end
266	275
267	276	module Search = Explore.Make(SearchProblem)
268	277
269		let make_initial_state n gl dblist localdb =
	278	(** Utilities for debug eauto / info eauto *)
	279
	280	let global_debug_eauto = ref false
	281	let global_info_eauto = ref false
	282
	283	let _ =
	284	Goptions.declare_bool_option
	285	{ Goptions.optsync = true;
	286	Goptions.optdepr = false;
	287	Goptions.optname = "Debug Eauto";
	288	Goptions.optkey = ["Debug";"Eauto"];
	289	Goptions.optread = (fun () -> !global_debug_eauto);
	290	Goptions.optwrite = (:=) global_debug_eauto }
	291
	292	let _ =
	293	Goptions.declare_bool_option
	294	{ Goptions.optsync = true;
	295	Goptions.optdepr = false;
	296	Goptions.optname = "Info Eauto";
	297	Goptions.optkey = ["Info";"Eauto"];
	298	Goptions.optread = (fun () -> !global_info_eauto);
	299	Goptions.optwrite = (:=) global_info_eauto }
	300
	301	let mk_eauto_dbg d =
	302	if d = Debug \|\| !global_debug_eauto then Debug
	303	else if d = Info \|\| !global_info_eauto then Info
	304	else Off
	305
	306	let pr_info_nop = function
	307	\| Info -> msg_debug (str "idtac.")
	308	\| _ -> ()
	309
	310	let pr_dbg_header = function
	311	\| Off -> ()
	312	\| Debug -> msg_debug (str "(* debug eauto : *)")
	313	\| Info -> msg_debug (str "(* info eauto : *)")
	314
	315	let pr_info dbg s =
	316	if dbg <> Info then ()
	317	else
	318	let rec loop s =
	319	match s.prev with
	320	\| Unknown \| Init -> s.depth
	321	\| State sp ->
	322	let mindepth = loop sp in
	323	let indent = String.make (mindepth - sp.depth) ' ' in
	324	msg_debug (str indent ++ Lazy.force s.last_tactic ++ str ".");
	325	mindepth
	326	in
	327	ignore (loop s)
	328
	329	(** Eauto main code *)
	330
	331	let make_initial_state dbg n gl dblist localdb =
270	332	{ depth = n;
271	333	tacres = tclIDTAC gl;
272	334	last_tactic = lazy (mt());
273	335	dblist = dblist;
274		localdb = [localdb] }
275
276		let e_depth_search debug p db_list local_db gl =
277		try
278		let tac = if debug then Search.debug_depth_first else Search.depth_first in
279		let s = tac (make_initial_state p gl db_list local_db) in
280		s.tacres
281		with Not_found -> error "eauto: depth first search failed."
282
283		let e_breadth_search debug n db_list local_db gl =
284		try
285		let tac =
286		if debug then Search.debug_breadth_first else Search.breadth_first
287		in
288		let s = tac (make_initial_state n gl db_list local_db) in
289		s.tacres
290		with Not_found -> error "eauto: breadth first search failed."
	336	localdb = [localdb];
	337	prev = if dbg=Info then Init else Unknown;
	338	}
291	339
292	340	let e_search_auto debug (in_depth,p) lems db_list gl =
293	341	let local_db = make_local_hint_db ~ts:full_transparent_state true lems gl in
294		if in_depth then
295		e_depth_search debug p db_list local_db gl
296		else
297		e_breadth_search debug p db_list local_db gl
	342	let d = mk_eauto_dbg debug in
	343	let tac = match in_depth,d with
	344	\| (true,Debug) -> Search.debug_depth_first
	345	\| (true,_) -> Search.depth_first
	346	\| (false,Debug) -> Search.debug_breadth_first
	347	\| (false,_) -> Search.breadth_first
	348	in
	349	try
	350	pr_dbg_header d;
	351	let s = tac (make_initial_state d p gl db_list local_db) in
	352	pr_info d s;
	353	s.tacres
	354	with Not_found ->
	355	pr_info_nop d;
	356	error "eauto: search failed"
298	357
299	358	open Evd
300	359
301		let eauto_with_bases debug np lems db_list =
	360	let eauto_with_bases ?(debug=Off) np lems db_list =
302	361	tclTRY (e_search_auto debug np lems db_list)
303	362
304		let eauto debug np lems dbnames =
	363	let eauto ?(debug=Off) np lems dbnames =
305	364	let db_list = make_db_list dbnames in
306	365	tclTRY (e_search_auto debug np lems db_list)
307	366
308		let full_eauto debug n lems gl =
	367	let full_eauto ?(debug=Off) n lems gl =
309	368	let dbnames = current_db_names () in
310	369	let dbnames = list_remove "v62" dbnames in
311	370	let db_list = List.map searchtable_map dbnames in
312	371	tclTRY (e_search_auto debug n lems db_list) gl
313	372
314		let gen_eauto d np lems = function
315		\| None -> full_eauto d np lems
316		\| Some l -> eauto d np lems l
	373	let gen_eauto ?(debug=Off) np lems = function
	374	\| None -> full_eauto ~debug np lems
	375	\| Some l -> eauto ~debug np lems l
317	376
318	377	let make_depth = function
319	378	\| None -> !default_search_depth

361	420	TACTIC EXTEND eauto
362	421	\| [ "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems)
363	422	hintbases(db) ] ->
364		[ gen_eauto false (make_dimension n p) lems db ]
	423	[ gen_eauto (make_dimension n p) lems db ]
365	424	END
366	425
367	426	TACTIC EXTEND new_eauto

369	428	hintbases(db) ] ->
370	429	[ match db with
371	430	\| None -> new_full_auto (make_depth n) lems
372		\| Some l ->
373		new_auto (make_depth n) lems l ]
	431	\| Some l -> new_auto (make_depth n) lems l ]
374	432	END
375	433
376	434	TACTIC EXTEND debug_eauto
377	435	\| [ "debug" "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems)
378	436	hintbases(db) ] ->
379		[ gen_eauto true (make_dimension n p) lems db ]
	437	[ gen_eauto ~debug:Debug (make_dimension n p) lems db ]
	438	END
	439
	440	TACTIC EXTEND info_eauto
	441	\| [ "info_eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems)
	442	hintbases(db) ] ->
	443	[ gen_eauto ~debug:Info (make_dimension n p) lems db ]
380	444	END
381	445
382	446	TACTIC EXTEND dfs_eauto
383	447	\| [ "dfs" "eauto" int_or_var_opt(p) auto_using(lems)
384	448	hintbases(db) ] ->
385		[ gen_eauto false (true, make_depth p) lems db ]
	449	[ gen_eauto (true, make_depth p) lems db ]
386	450	END
387	451
388	452	let cons a l = a :: l

+2

-2

tactics/eauto.mli less more

26	26
27	27	val e_give_exact : ?flags:Unification.unify_flags -> constr -> tactic
28	28
29		val gen_eauto : bool -> bool * int -> open_constr list ->
	29	val gen_eauto : ?debug:Tacexpr.debug -> bool * int -> open_constr list ->
30	30	hint_db_name list option -> tactic
31	31
32	32	val eauto_with_bases :
33		bool ->
	33	?debug:Tacexpr.debug ->
34	34	bool * int ->
35	35	open_constr list -> Auto.hint_db list -> Proof_type.tactic
36	36

+14

-23

tactics/extraargs.ml4 less more

32	32
33	33	let pr_orient = pr_orient () () ()
34	34
35		let pr_int_list_full _prc _prlc _prt l =
36		let rec aux = function
37		\| i :: l -> Pp.int i ++ Pp.spc () ++ aux l
38		\| [] -> Pp.mt()
39		in aux l
40
41		ARGUMENT EXTEND int_nelist
42		PRINTED BY pr_int_list_full
43		RAW_TYPED AS int list
44		RAW_PRINTED BY pr_int_list_full
45		GLOB_TYPED AS int list
46		GLOB_PRINTED BY pr_int_list_full
47		\| [ integer(x) int_nelist(l) ] -> [x::l]
48		\| [ integer(x) ] -> [ [x] ]
49		END
50
51		let pr_int_list = pr_int_list_full () () ()
	35
	36	let pr_int_list = Util.pr_sequence Pp.int
	37	let pr_int_list_full _prc _prlc _prt l = pr_int_list l
52	38
53	39	open Glob_term
54	40

71	57	\| ArgVar (_,id as locid) ->
72	58	(try int_list_of_VList (List.assoc id ist.lfun)
73	59	with Not_found \| CannotCoerceTo _ -> [interp_int ist locid])
	60	let interp_occs ist gl l =
	61	Tacmach.project gl , interp_occs ist gl l
74	62
75	63	let glob_occs ist l = l
76	64

92	80	GLOB_TYPED AS occurrences_or_var
93	81	GLOB_PRINTED BY pr_occurrences
94	82
95		\| [ int_nelist(l) ] -> [ ArgArg l ]
	83	\| [ ne_integer_list(l) ] -> [ ArgArg l ]
96	84	\| [ var(id) ] -> [ ArgVar id ]
97	85	END
98	86

102	90
103	91	let pr_globc _prc _prlc _prtac (_,glob) = Printer.pr_glob_constr glob
104	92
105		let interp_glob ist gl (t,_) = (ist,t)
	93	let interp_glob ist gl (t,_) = Tacmach.project gl , (ist,t)
106	94
107	95	let glob_glob = Tacinterp.intern_constr
108	96

148	136	let interp_place ist gl = function
149	137	ConclLocation () -> ConclLocation ()
150	138	\| HypLocation (id,hl) -> HypLocation (interp_hyp ist gl id,hl)
	139
	140	let interp_place ist gl p =
	141	Tacmach.project gl , interp_place ist gl p
151	142
152	143	let subst_place subst pl = pl
153	144

286	277	(* spiwack argument for the commands of the retroknowledge *)
287	278
288	279	let (wit_r_nat_field, globwit_r_nat_field, rawwit_r_nat_field) =
289		Genarg.create_arg "r_nat_field"
	280	Genarg.create_arg None "r_nat_field"
290	281	let (wit_r_n_field, globwit_r_n_field, rawwit_r_n_field) =
291		Genarg.create_arg "r_n_field"
	282	Genarg.create_arg None "r_n_field"
292	283	let (wit_r_int31_field, globwit_r_int31_field, rawwit_r_int31_field) =
293		Genarg.create_arg "r_int31_field"
	284	Genarg.create_arg None "r_int31_field"
294	285	let (wit_r_field, globwit_r_field, rawwit_r_field) =
295		Genarg.create_arg "r_field"
	286	Genarg.create_arg None "r_field"
296	287
297	288	(* spiwack: the print functions are incomplete, but I don't know what they are
298	289	used for *)

+2

-0

tactics/extraargs.mli less more

14	14	open Glob_term
15	15
16	16	val rawwit_orient : bool raw_abstract_argument_type
	17	val globwit_orient : bool glob_abstract_argument_type
17	18	val wit_orient : bool typed_abstract_argument_type
18	19	val orient : bool Pcoq.Gram.entry
19	20	val pr_orient : bool -> Pp.std_ppcmds

38	39	val pr_hloc : loc_place -> Pp.std_ppcmds
39	40
40	41	val in_arg_hyp: (Names.identifier Util.located list option * bool) Pcoq.Gram.entry
	42	val globwit_in_arg_hyp : (Names.identifier Util.located list option * bool) glob_abstract_argument_type
41	43	val rawwit_in_arg_hyp : (Names.identifier Util.located list option * bool) raw_abstract_argument_type
42	44	val wit_in_arg_hyp : (Names.identifier list option * bool) typed_abstract_argument_type
43	45	val raw_in_arg_hyp_to_clause : (Names.identifier Util.located list option * bool) -> Tacticals.clause

+17

-1

tactics/extratactics.ml4 less more

22	22	open Compat
23	23
24	24	(**********************************************************************)
25		(* replace, discriminate, injection, simplify_eq *)
	25	(* admit, replace, discriminate, injection, simplify_eq *)
26	26	(* cutrewrite, dependent rewrite *)
	27
	28	TACTIC EXTEND admit
	29	[ "admit" ] -> [ admit_as_an_axiom ]
	30	END
27	31
28	32	let replace_in_clause_maybe_by (sigma1,c1) c2 in_hyp tac =
29	33	Refiner.tclWITHHOLES false

760	764	\| Var _ -> tclIDTAC
761	765	\| _ -> tclFAIL 0 (str "Not a variable or hypothesis") ]
762	766	END
	767
	768
	769	(* Command to grab the evars left unresolved at the end of a proof. *)
	770	(* spiwack: I put it in extratactics because it is somewhat tied with
	771	the semantics of the LCF-style tactics, hence with the classic tactic
	772	mode. *)
	773	VERNAC COMMAND EXTEND GrabEvars
	774	[ "Grab" "Existential" "Variables" ] ->
	775	[ let p = Proof_global.give_me_the_proof () in
	776	Proof.V82.grab_evars p;
	777	Flags.if_verbose (fun () -> Pp.msg (Printer.pr_open_subgoals ())) () ]
	778	END

+1

-1

tactics/refine.ml less more

387	387
388	388	let refine (evd,c) gl =
389	389	let sigma = project gl in
390		let evd = Typeclasses.resolve_typeclasses ~onlyargs:true (pf_env gl) evd in
	390	let evd = Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals (pf_env gl) evd in
391	391	let c = Evarutil.nf_evar evd c in
392	392	let (evd,c) = Evarutil.evars_to_metas sigma (evd,c) in
393	393	(* Relies on Cast's put on Meta's by evars_to_metas, because it is otherwise

+13

-9

tactics/rewrite.ml4 less more

256	256	let ctype = Typing.type_of env sigma c' in
257	257	let find_rel ty =
258	258	let eqclause = Clenv.make_clenv_binding_env_apply env sigma None (c',ty) l in
259		let (equiv, args) = decompose_app_rel env sigma (Clenv.clenv_type eqclause) in
	259	let (equiv, args) = decompose_app_rel env eqclause.evd (Clenv.clenv_type eqclause) in
260	260	let c1 = args.(0) and c2 = args.(1) in
261	261	let ty1, ty2 =
262	262	Typing.type_of env eqclause.evd c1, Typing.type_of env eqclause.evd c2

1342	1342	let pr_glob_constr_with_bindings_sign _ _ _ (ge : glob_constr_with_bindings_sign) = Printer.pr_glob_constr (fst (fst (snd ge)))
1343	1343	let pr_glob_constr_with_bindings _ _ _ (ge : glob_constr_with_bindings) = Printer.pr_glob_constr (fst (fst ge))
1344	1344	let pr_constr_expr_with_bindings prc _ _ (ge : constr_expr_with_bindings) = prc (fst ge)
1345		let interp_glob_constr_with_bindings ist gl c = (ist, c)
	1345	let interp_glob_constr_with_bindings ist gl c = Tacmach.project gl , (ist, c)
1346	1346	let glob_glob_constr_with_bindings ist l = Tacinterp.intern_constr_with_bindings ist l
1347	1347	let subst_glob_constr_with_bindings s c = subst_glob_with_bindings s c
1348	1348

1364	1364	END
1365	1365
1366	1366	let _ =
1367		(Genarg.create_arg "strategy" :
	1367	(Genarg.create_arg None "strategy" :
1368	1368	((strategy, Genarg.tlevel) Genarg.abstract_argument_type *
1369	1369	(strategy, Genarg.glevel) Genarg.abstract_argument_type *
1370	1370	(strategy, Genarg.rlevel) Genarg.abstract_argument_type))

1373	1373
1374	1374	let pr_strategy _ _ _ (s : strategy) = Pp.str "<strategy>"
1375	1375
1376		let interp_strategy ist gl c = c
	1376	let interp_strategy ist gl c = project gl , c
1377	1377	let glob_strategy ist l = l
1378	1378	let subst_strategy evm l = l
1379	1379

1404	1404	\| [ "choice" rewstrategy(h) rewstrategy(h') ] -> [ Strategies.choice h h' ]
1405	1405	\| [ "old_hints" preident(h) ] -> [ Strategies.old_hints h ]
1406	1406	\| [ "hints" preident(h) ] -> [ Strategies.hints h ]
1407		\| [ "terms" constr_list(h) ] -> [ fun env avoid t ty cstr evars ->
	1407	\| [ "terms" constr_list(h) ] -> [ fun env avoid t ty cstr evars ->
1408	1408	Strategies.lemmas rewrite_unif_flags (interp_constr_list env (goalevars evars) h) env avoid t ty cstr evars ]
1409		\| [ "eval" red_expr(r) ] -> [ fun env avoid t ty cstr evars ->
1410		Strategies.reduce (Tacinterp.interp_redexp env (goalevars evars) r) env avoid t ty cstr evars ]
	1409	\| [ "eval" red_expr(r) ] -> [ fun env avoid t ty cstr evars ->
	1410	let (sigma,r_interp) = Tacinterp.interp_redexp env (goalevars evars) r in
	1411	Strategies.reduce r_interp env avoid t ty cstr (sigma,cstrevars evars) ]
1411	1412	\| [ "fold" constr(c) ] -> [ Strategies.fold c ]
1412	1413	END
1413	1414

1423	1424	match cl with
1424	1425	\| Some id when is_tac id -> tclIDTAC
1425	1426	\| _ -> cl_rewrite_clause c o all_occurrences cl)
	1427
	1428	open Extraargs
1426	1429
1427	1430	TACTIC EXTEND substitute
1428	1431	\| [ "substitute" orient(o) glob_constr_with_bindings(c) ] -> [ clsubstitute o c ]

1535	1538	type 'a binders_argtype = (local_binder list, 'a) Genarg.abstract_argument_type
1536	1539
1537	1540	let _, _, rawwit_binders =
1538		(Genarg.create_arg "binders" :
	1541	(Genarg.create_arg None "binders" :
1539	1542	Genarg.tlevel binders_argtype *
1540	1543	Genarg.glevel binders_argtype *
1541	1544	Genarg.rlevel binders_argtype)

1866	1869	let env = pf_env gl in
1867	1870	try
1868	1871	let rel, args = decompose_app_rel env (project gl) (pf_concl gl) in
1869		let evm, car = project gl, pf_type_of gl args.(0) in
	1872	let evm = project gl in
	1873	let car = pi3 (List.hd (fst (Reduction.dest_prod env (Typing.type_of env evm rel)))) in
1870	1874	fn env evm car rel gl
1871	1875	with e ->
1872	1876	try fallback gl

+400

-205

tactics/tacinterp.ml less more

174	174	"intros", TacIntroPattern [];
175	175	"assumption", TacAssumption;
176	176	"cofix", TacCofix None;
177		"trivial", TacTrivial ([],None);
178		"auto", TacAuto(None,[],None);
	177	"trivial", TacTrivial (Off,[],None);
	178	"auto", TacAuto(Off,None,[],None);
179	179	"left", TacLeft(false,NoBindings);
180	180	"eleft", TacLeft(true,NoBindings);
181	181	"right", TacRight(false,NoBindings);

253	253	type interp_genarg_type =
254	254	(glob_sign -> raw_generic_argument -> glob_generic_argument) *
255	255	(interp_sign -> goal sigma -> glob_generic_argument ->
256		typed_generic_argument) *
	256	Evd.evar_map * typed_generic_argument) *
257	257	(substitution -> glob_generic_argument -> glob_generic_argument)
258	258
259	259	let extragenargtab =

712	712	(clause_app (intern_hyp_location ist) cls),b)
713	713
714	714	(* Automation tactics *)
715		\| TacTrivial (lems,l) -> TacTrivial (List.map (intern_constr ist) lems,l)
716		\| TacAuto (n,lems,l) ->
717		TacAuto (Option.map (intern_or_var ist) n,
	715	\| TacTrivial (d,lems,l) -> TacTrivial (d,List.map (intern_constr ist) lems,l)
	716	\| TacAuto (d,n,lems,l) ->
	717	TacAuto (d,Option.map (intern_or_var ist) n,
718	718	List.map (intern_constr ist) lems,l)
719		\| TacAutoTDB n -> TacAutoTDB n
720		\| TacDestructHyp (b,id) -> TacDestructHyp(b,intern_hyp ist id)
721		\| TacDestructConcl -> TacDestructConcl
722		\| TacSuperAuto (n,l,b1,b2) -> TacSuperAuto (n,l,b1,b2)
723		\| TacDAuto (n,p,lems) ->
724		TacDAuto (Option.map (intern_or_var ist) n,p,
725		List.map (intern_constr ist) lems)
726	719
727	720	(* Derived basic tactics *)
728	721	\| TacSimpleInductionDestruct (isrec,h) ->

1255	1248	in
1256	1249	let trace = push_trace (dloc,LtacConstrInterp (c,vars)) ist.trace in
1257	1250	let evdc =
1258		catch_error trace (understand_ltac expand_evar sigma env vars kind) c in
	1251	catch_error trace
	1252	(understand_ltac ~resolve_classes:use_classes expand_evar sigma env vars kind) c in
1259	1253	let (evd,c) =
1260	1254	if expand_evar then
1261	1255	solve_remaining_evars fail_evar use_classes

1267	1261
1268	1262	(* Interprets a constr; expects evars to be solved *)
1269	1263	let interp_constr_gen kind ist env sigma c =
1270		snd (interp_gen kind ist false true true true env sigma c)
	1264	interp_gen kind ist false true true true env sigma c
1271	1265
1272	1266	let interp_constr = interp_constr_gen (OfType None)
1273	1267

1277	1271	let interp_open_constr_gen kind ist =
1278	1272	interp_gen kind ist false true false false
1279	1273
1280		let interp_open_constr ccl =
1281		interp_open_constr_gen (OfType ccl)
	1274	let interp_open_constr ccl ist =
	1275	interp_gen (OfType ccl) ist false true false (ccl<>None)
1282	1276
1283	1277	let interp_pure_open_constr ist =
1284	1278	interp_gen (OfType None) ist false false false false

1316	1310	sigma, List.flatten l
1317	1311
1318	1312	let interp_constr_list ist env sigma c =
1319		snd (interp_constr_in_compound_list (fun x -> x) (fun x -> x) (fun ist env sigma c -> (Evd.empty, interp_constr ist env sigma c)) ist env sigma c)
	1313	interp_constr_in_compound_list (fun x -> x) (fun x -> x) interp_constr ist env sigma c
1320	1314
1321	1315	let interp_open_constr_list =
1322	1316	interp_constr_in_compound_list (fun x -> x) (fun x -> x)

1338	1332	{ red with rConst = List.map (interp_evaluable ist env) red.rConst }
1339	1333
1340	1334	let interp_constr_with_occurrences ist sigma env (occs,c) =
1341		(interp_occurrences ist occs, interp_constr ist sigma env c)
	1335	let (sigma,c_interp) = interp_constr ist sigma env c in
	1336	sigma , (interp_occurrences ist occs, c_interp)
1342	1337
1343	1338	let interp_typed_pattern_with_occurrences ist env sigma (occs,c) =
1344	1339	let sign,p = interp_typed_pattern ist env sigma c in

1353	1348	(function ((occs,c),Anonymous) when occs = all_occurrences_expr -> c
1354	1349	\| _ -> raise Not_found)
1355	1350	(fun ist env sigma (occ_c,na) ->
1356		sigma, (interp_constr_with_occurrences ist env sigma occ_c,
	1351	let (sigma,c_interp) = interp_constr_with_occurrences ist env sigma occ_c in
	1352	sigma, (c_interp,
1357	1353	interp_fresh_name ist env na))
1358	1354
1359	1355	let interp_red_expr ist sigma env = function
1360		\| Unfold l -> Unfold (List.map (interp_unfold ist env) l)
1361		\| Fold l -> Fold (List.map (interp_constr ist env sigma) l)
1362		\| Cbv f -> Cbv (interp_flag ist env f)
1363		\| Lazy f -> Lazy (interp_flag ist env f)
	1356	\| Unfold l -> sigma , Unfold (List.map (interp_unfold ist env) l)
	1357	\| Fold l ->
	1358	let (sigma,l_interp) = interp_constr_list ist env sigma l in
	1359	sigma , Fold l_interp
	1360	\| Cbv f -> sigma , Cbv (interp_flag ist env f)
	1361	\| Lazy f -> sigma , Lazy (interp_flag ist env f)
1364	1362	\| Pattern l ->
1365		Pattern (List.map (interp_constr_with_occurrences ist env sigma) l)
	1363	let (sigma,l_interp) =
	1364	List.fold_right begin fun c (sigma,acc) ->
	1365	let (sigma,c_interp) = interp_constr_with_occurrences ist env sigma c in
	1366	sigma , c_interp :: acc
	1367	end l (sigma,[])
	1368	in
	1369	sigma , Pattern l_interp
1366	1370	\| Simpl o ->
1367		Simpl(Option.map (interp_closed_typed_pattern_with_occurrences ist env sigma) o)
1368		\| (Red _ \| Hnf \| ExtraRedExpr _ \| CbvVm as r) -> r
	1371	sigma , Simpl(Option.map (interp_closed_typed_pattern_with_occurrences ist env sigma) o)
	1372	\| (Red _ \| Hnf \| ExtraRedExpr _ \| CbvVm as r) -> sigma , r
1369	1373
1370	1374	let pf_interp_red_expr ist gl = interp_red_expr ist (project gl) (pf_env gl)
1371	1375
1372	1376	let interp_may_eval f ist gl = function
1373	1377	\| ConstrEval (r,c) ->
1374		let redexp = pf_interp_red_expr ist gl r in
1375		pf_reduction_of_red_expr gl redexp (f ist gl c)
	1378	let (sigma,redexp) = pf_interp_red_expr ist gl r in
	1379	let (sigma,c_interp) = f ist { gl with sigma=sigma } c in
	1380	sigma , pf_reduction_of_red_expr gl redexp c_interp
1376	1381	\| ConstrContext ((loc,s),c) ->
1377	1382	(try
1378		let ic = f ist gl c
	1383	let (sigma,ic) = f ist gl c
1379	1384	and ctxt = constr_of_VConstr_context (List.assoc s ist.lfun) in
1380		subst_meta [special_meta,ic] ctxt
	1385	sigma , subst_meta [special_meta,ic] ctxt
1381	1386	with
1382	1387	\| Not_found ->
1383	1388	user_err_loc (loc, "interp_may_eval",
1384	1389	str "Unbound context identifier" ++ pr_id s ++ str"."))
1385		\| ConstrTypeOf c -> pf_type_of gl (f ist gl c)
	1390	\| ConstrTypeOf c ->
	1391	let (sigma,c_interp) = f ist gl c in
	1392	sigma , pf_type_of gl c_interp
1386	1393	\| ConstrTerm c ->
1387	1394	try
1388	1395	f ist gl c

1393	1400
1394	1401	(* Interprets a constr expression possibly to first evaluate *)
1395	1402	let interp_constr_may_eval ist gl c =
1396		let csr =
	1403	let (sigma,csr) =
1397	1404	try
1398	1405	interp_may_eval pf_interp_constr ist gl c
1399	1406	with e ->

1402	1409	in
1403	1410	begin
1404	1411	db_constr ist.debug (pf_env gl) csr;
1405		csr
	1412	sigma , csr
1406	1413	end
1407	1414
1408	1415	let rec message_of_value gl = function

1564	1571	ElimOnIdent (loc,id)
1565	1572	else
1566	1573	let c = (GVar (loc,id),Some (CRef (Ident (loc,id)))) in
1567		let c = interp_constr ist env sigma c in
	1574	let (sigma,c) = interp_constr ist env sigma c in
1568	1575	ElimOnConstr (sigma,(c,NoBindings))
1569	1576
1570	1577	(* Associates variables with values and gives the remaining variables and

1724	1731
1725	1732	(* misc *)
1726	1733
1727		let mk_constr_value ist gl c = VConstr ([],pf_interp_constr ist gl c)
	1734	let mk_constr_value ist gl c =
	1735	let (sigma,c_interp) = pf_interp_constr ist gl c in
	1736	sigma,VConstr ([],c_interp)
	1737	let mk_open_constr_value ist gl c =
	1738	let (sigma,c_interp) = pf_apply (interp_open_constr None ist) gl c in
	1739	sigma,VConstr ([],c_interp)
1728	1740	let mk_hyp_value ist gl c = VConstr ([],mkVar (interp_hyp ist gl c))
1729	1741	let mk_int_or_var_value ist c = VInteger (interp_int_or_var ist c)
1730	1742

1738	1750
1739	1751	(* Interprets an l-tac expression into a value *)
1740	1752	let rec val_interp ist gl (tac:glob_tactic_expr) =
1741
1742	1753	let value_interp ist = match tac with
1743	1754	(* Immediate evaluation *)
1744		\| TacFun (it,body) -> VFun (ist.trace,ist.lfun,it,body)
	1755	\| TacFun (it,body) -> project gl , VFun (ist.trace,ist.lfun,it,body)
1745	1756	\| TacLetIn (true,l,u) -> interp_letrec ist gl l u
1746	1757	\| TacLetIn (false,l,u) -> interp_letin ist gl l u
1747	1758	\| TacMatchGoal (lz,lr,lmr) -> interp_match_goal ist gl lz lr lmr
1748	1759	\| TacMatch (lz,c,lmr) -> interp_match ist gl lz c lmr
1749	1760	\| TacArg (loc,a) -> interp_tacarg ist gl a
1750	1761	(* Delayed evaluation *)
1751		\| t -> VFun (ist.trace,ist.lfun,[],t)
	1762	\| t -> project gl , VFun (ist.trace,ist.lfun,[],t)
1752	1763
1753	1764	in check_for_interrupt ();
1754	1765	match ist.debug with

1768	1779	catch_error (push_trace(loc,call)ist.trace) tac gl
1769	1780	\| TacFun _ \| TacLetIn _ -> assert false
1770	1781	\| TacMatchGoal _ \| TacMatch _ -> assert false
1771		\| TacId s -> fun gl -> tclIDTAC_MESSAGE (interp_message_nl ist gl s) gl
	1782	\| TacId s -> fun gl ->
	1783	let res = tclIDTAC_MESSAGE (interp_message_nl ist gl s) gl in
	1784	db_breakpoint ist.debug s; res
1772	1785	\| TacFail (n,s) -> fun gl -> tclFAIL (interp_int_or_var ist n) (interp_message ist gl s) gl
1773	1786	\| TacProgress tac -> tclPROGRESS (interp_tactic ist tac)
1774	1787	\| TacAbstract (tac,ido) ->

1781	1794	\| TacDo (n,tac) -> tclDO (interp_int_or_var ist n) (interp_tactic ist tac)
1782	1795	\| TacTimeout (n,tac) -> tclTIMEOUT (interp_int_or_var ist n) (interp_tactic ist tac)
1783	1796	\| TacTry tac -> tclTRY (interp_tactic ist tac)
1784		\| TacInfo tac ->
1785		let t = (interp_tactic ist tac) in
1786		tclINFO
1787		begin
1788		match tac with
1789		TacAtom (_,_) -> t
1790		\| _ -> abstract_tactic_expr (TacArg (dloc,Tacexp tac)) t
1791		end
1792	1797	\| TacRepeat tac -> tclREPEAT (interp_tactic ist tac)
1793	1798	\| TacOrelse (tac1,tac2) ->
1794	1799	tclORELSE (interp_tactic ist tac1) (interp_tactic ist tac2)

1796	1801	\| TacSolve l -> tclSOLVE (List.map (interp_tactic ist) l)
1797	1802	\| TacComplete tac -> tclCOMPLETE (interp_tactic ist tac)
1798	1803	\| TacArg a -> interp_tactic ist (TacArg a)
	1804	\| TacInfo tac ->
	1805	msg_warning
	1806	(str "The general \"info\" tactic is currently not working.\n" ++
	1807	str "Some specific verbose tactics may exist instead, such as\n" ++
	1808	str "info_trivial, info_auto, info_eauto.");
	1809	eval_tactic ist tac
1799	1810
1800	1811	and force_vrec ist gl = function
1801	1812	\| VRec (lfun,body) -> val_interp {ist with lfun = !lfun} gl body
1802		\| v -> v
	1813	\| v -> project gl , v
1803	1814
1804	1815	and interp_ltac_reference loc' mustbetac ist gl = function
1805	1816	\| ArgVar (loc,id) ->
1806	1817	let v = List.assoc id ist.lfun in
1807		let v = force_vrec ist gl v in
	1818	let (sigma,v) = force_vrec ist gl v in
1808	1819	let v = propagate_trace ist loc id v in
1809		if mustbetac then coerce_to_tactic loc id v else v
	1820	sigma , if mustbetac then coerce_to_tactic loc id v else v
1810	1821	\| ArgArg (loc,r) ->
1811	1822	let ids = extract_ids [] ist.lfun in
1812	1823	let loc_info = ((if loc' = dloc then loc else loc'),LtacNameCall r) in

1815	1826	trace = push_trace loc_info ist.trace } in
1816	1827	val_interp ist gl (lookup r)
1817	1828
1818		and interp_tacarg ist gl = function
1819		\| TacVoid -> VVoid
1820		\| Reference r -> interp_ltac_reference dloc false ist gl r
1821		\| Integer n -> VInteger n
1822		\| IntroPattern ipat -> VIntroPattern (snd (interp_intro_pattern ist gl ipat))
1823		\| ConstrMayEval c -> VConstr ([],interp_constr_may_eval ist gl c)
1824		\| MetaIdArg (loc,_,id) -> assert false
1825		\| TacCall (loc,r,[]) -> interp_ltac_reference loc true ist gl r
1826		\| TacCall (loc,f,l) ->
1827		let fv = interp_ltac_reference loc true ist gl f
1828		and largs = List.map (interp_tacarg ist gl) l in
1829		List.iter check_is_value largs;
1830		interp_app loc ist gl fv largs
1831		\| TacExternal (loc,com,req,la) ->
1832		interp_external loc ist gl com req (List.map (interp_tacarg ist gl) la)
1833		\| TacFreshId l ->
1834		let id = pf_interp_fresh_id ist gl l in
1835		VIntroPattern (IntroIdentifier id)
1836		\| Tacexp t -> val_interp ist gl t
1837		\| TacDynamic(_,t) ->
1838		let tg = (Dyn.tag t) in
1839		if tg = "tactic" then
1840		val_interp ist gl (tactic_out t ist)
1841		else if tg = "value" then
1842		value_out t
1843		else if tg = "constr" then
	1829	and interp_tacarg ist gl arg =
	1830	let evdref = ref (project gl) in
	1831	let v = match arg with
	1832	\| TacVoid -> VVoid
	1833	\| Reference r ->
	1834	let (sigma,v) = interp_ltac_reference dloc false ist gl r in
	1835	evdref := sigma;
	1836	v
	1837	\| Integer n -> VInteger n
	1838	\| IntroPattern ipat -> VIntroPattern (snd (interp_intro_pattern ist gl ipat))
	1839	\| ConstrMayEval c ->
	1840	let (sigma,c_interp) = interp_constr_may_eval ist gl c in
	1841	evdref := sigma;
	1842	VConstr ([],c_interp)
	1843	\| MetaIdArg (loc,_,id) -> assert false
	1844	\| TacCall (loc,r,[]) ->
	1845	let (sigma,v) = interp_ltac_reference loc true ist gl r in
	1846	evdref := sigma;
	1847	v
	1848	\| TacCall (loc,f,l) ->
	1849	let (sigma,fv) = interp_ltac_reference loc true ist gl f in
	1850	let (sigma,largs) =
	1851	List.fold_right begin fun a (sigma',acc) ->
	1852	let (sigma', a_interp) = interp_tacarg ist gl a in
	1853	sigma' , a_interp::acc
	1854	end l (sigma,[])
	1855	in
	1856	List.iter check_is_value largs;
	1857	let (sigma,v) = interp_app loc ist { gl with sigma=sigma } fv largs in
	1858	evdref:= sigma;
	1859	v
	1860	\| TacExternal (loc,com,req,la) ->
	1861	let (sigma,la_interp) =
	1862	List.fold_right begin fun a (sigma,acc) ->
	1863	let (sigma,a_interp) = interp_tacarg ist {gl with sigma=sigma} a in
	1864	sigma , a_interp::acc
	1865	end la (project gl,[])
	1866	in
	1867	let (sigma,v) = interp_external loc ist { gl with sigma=sigma } com req la_interp in
	1868	evdref := sigma;
	1869	v
	1870	\| TacFreshId l ->
	1871	let id = pf_interp_fresh_id ist gl l in
	1872	VIntroPattern (IntroIdentifier id)
	1873	\| Tacexp t ->
	1874	let (sigma,v) = val_interp ist gl t in
	1875	evdref := sigma;
	1876	v
	1877	\| TacDynamic(_,t) ->
	1878	let tg = (Dyn.tag t) in
	1879	if tg = "tactic" then
	1880	let (sigma,v) = val_interp ist gl (tactic_out t ist) in
	1881	evdref := sigma;
	1882	v
	1883	else if tg = "value" then
	1884	value_out t
	1885	else if tg = "constr" then
1844	1886	VConstr ([],constr_out t)
1845		else
1846		anomaly_loc (dloc, "Tacinterp.val_interp",
1847		(str "Unknown dynamic: <" ++ str (Dyn.tag t) ++ str ">"))
	1887	else
	1888	anomaly_loc (dloc, "Tacinterp.val_interp",
	1889	(str "Unknown dynamic: <" ++ str (Dyn.tag t) ++ str ">"))
	1890	in
	1891	!evdref , v
1848	1892
1849	1893	(* Interprets an application node *)
1850	1894	and interp_app loc ist gl fv largs =

1858	1902	(TacFun _\|TacLetIn _\|TacMatchGoal _\|TacMatch _\| TacArg _ as body))) ->
1859	1903	let (newlfun,lvar,lval)=head_with_value (var,largs) in
1860	1904	if lvar=[] then
1861		let v =
	1905	let (sigma,v) =
1862	1906	try
1863	1907	catch_error trace
1864	1908	(val_interp {ist with lfun=newlfun@olfun; trace=trace} gl) body
1865	1909	with e ->
1866	1910	debugging_exception_step ist false e (fun () -> str "evaluation");
1867	1911	raise e in
	1912	let gl = { gl with sigma=sigma } in
1868	1913	debugging_step ist
1869	1914	(fun () ->
1870	1915	str"evaluation returns"++fnl()++pr_value (Some (pf_env gl)) v);
1871		if lval=[] then v else interp_app loc ist gl v lval
	1916	if lval=[] then sigma,v else interp_app loc ist gl v lval
1872	1917	else
1873		VFun(trace,newlfun@olfun,lvar,body)
	1918	project gl , VFun(trace,newlfun@olfun,lvar,body)
1874	1919	\| _ ->
1875	1920	user_err_loc (loc, "Tacinterp.interp_app",
1876	1921	(str"Illegal tactic application."))

1893	1938	(* Evaluation with FailError catching *)
1894	1939	and eval_with_fail ist is_lazy goal tac =
1895	1940	try
1896		(match val_interp ist goal tac with
	1941	let (sigma,v) = val_interp ist goal tac in
	1942	sigma ,
	1943	(match v with
1897	1944	\| VFun (trace,lfun,[],t) when not is_lazy ->
1898	1945	let tac = eval_tactic {ist with lfun=lfun; trace=trace} t in
1899		VRTactic (catch_error trace tac goal)
	1946	VRTactic (catch_error trace tac { goal with sigma=sigma })
1900	1947	\| a -> a)
1901	1948	with
1902	1949	\| FailError (0,s) \| Loc.Exc_located(_, FailError (0,s))

1918	1965
1919	1966	(* Interprets the clauses of a LetIn *)
1920	1967	and interp_letin ist gl llc u =
1921		let lve = list_map_left (fun ((_,id),body) ->
1922		let v = interp_tacarg ist gl body in check_is_value v; (id,v)) llc in
	1968	let (sigma,lve) =
	1969	List.fold_right begin fun ((_,id),body) (sigma,acc) ->
	1970	let (sigma,v) = interp_tacarg ist { gl with sigma=sigma } body in
	1971	check_is_value v;
	1972	sigma, (id,v)::acc
	1973	end llc (project gl,[])
	1974	in
1923	1975	let ist = { ist with lfun = lve@ist.lfun } in
1924		val_interp ist gl u
	1976	val_interp ist { gl with sigma=sigma } u
1925	1977
1926	1978	(* Interprets the Match Context expressions *)
1927	1979	and interp_match_goal ist goal lz lr lmr =

2014	2066
2015	2067	(* Interprets extended tactic generic arguments *)
2016	2068	and interp_genarg ist gl x =
2017		match genarg_tag x with
2018		\| BoolArgType -> in_gen wit_bool (out_gen globwit_bool x)
2019		\| IntArgType -> in_gen wit_int (out_gen globwit_int x)
2020		\| IntOrVarArgType ->
	2069	let evdref = ref (project gl) in
	2070	let rec interp_genarg ist gl x =
	2071	let gl = { gl with sigma = !evdref } in
	2072	match genarg_tag x with
	2073	\| BoolArgType -> in_gen wit_bool (out_gen globwit_bool x)
	2074	\| IntArgType -> in_gen wit_int (out_gen globwit_int x)
	2075	\| IntOrVarArgType ->
2021	2076	in_gen wit_int_or_var
2022	2077	(ArgArg (interp_int_or_var ist (out_gen globwit_int_or_var x)))
2023		\| StringArgType ->
	2078	\| StringArgType ->
2024	2079	in_gen wit_string (out_gen globwit_string x)
2025		\| PreIdentArgType ->
	2080	\| PreIdentArgType ->
2026	2081	in_gen wit_pre_ident (out_gen globwit_pre_ident x)
2027		\| IntroPatternArgType ->
	2082	\| IntroPatternArgType ->
2028	2083	in_gen wit_intro_pattern
2029	2084	(interp_intro_pattern ist gl (out_gen globwit_intro_pattern x))
2030		\| IdentArgType b ->
	2085	\| IdentArgType b ->
2031	2086	in_gen (wit_ident_gen b)
2032	2087	(pf_interp_fresh_ident ist gl (out_gen (globwit_ident_gen b) x))
2033		\| VarArgType ->
	2088	\| VarArgType ->
2034	2089	in_gen wit_var (interp_hyp ist gl (out_gen globwit_var x))
2035		\| RefArgType ->
	2090	\| RefArgType ->
2036	2091	in_gen wit_ref (pf_interp_reference ist gl (out_gen globwit_ref x))
2037		\| SortArgType ->
	2092	\| SortArgType ->
	2093	let (sigma,c_interp) =
	2094	pf_interp_constr ist gl
	2095	(GSort (dloc,out_gen globwit_sort x), None)
	2096	in
	2097	evdref := sigma;
2038	2098	in_gen wit_sort
2039		(destSort
2040		(pf_interp_constr ist gl
2041		(GSort (dloc,out_gen globwit_sort x), None)))
2042		\| ConstrArgType ->
2043		in_gen wit_constr (pf_interp_constr ist gl (out_gen globwit_constr x))
2044		\| ConstrMayEvalArgType ->
2045		in_gen wit_constr_may_eval (interp_constr_may_eval ist gl (out_gen globwit_constr_may_eval x))
2046		\| QuantHypArgType ->
	2099	(destSort c_interp)
	2100	\| ConstrArgType ->
	2101	let (sigma,c_interp) = pf_interp_constr ist gl (out_gen globwit_constr x) in
	2102	evdref := sigma;
	2103	in_gen wit_constr c_interp
	2104	\| ConstrMayEvalArgType ->
	2105	let (sigma,c_interp) = interp_constr_may_eval ist gl (out_gen globwit_constr_may_eval x) in
	2106	evdref := sigma;
	2107	in_gen wit_constr_may_eval c_interp
	2108	\| QuantHypArgType ->
2047	2109	in_gen wit_quant_hyp
2048	2110	(interp_declared_or_quantified_hypothesis ist gl
2049		(out_gen globwit_quant_hyp x))
2050		\| RedExprArgType ->
2051		in_gen wit_red_expr (pf_interp_red_expr ist gl (out_gen globwit_red_expr x))
2052		\| OpenConstrArgType casted ->
	2111	(out_gen globwit_quant_hyp x))
	2112	\| RedExprArgType ->
	2113	let (sigma,r_interp) = pf_interp_red_expr ist gl (out_gen globwit_red_expr x) in
	2114	evdref := sigma;
	2115	in_gen wit_red_expr r_interp
	2116	\| OpenConstrArgType casted ->
2053	2117	in_gen (wit_open_constr_gen casted)
2054	2118	(interp_open_constr (if casted then Some (pf_concl gl) else None)
2055		ist (pf_env gl) (project gl)
2056		(snd (out_gen (globwit_open_constr_gen casted) x)))
2057		\| ConstrWithBindingsArgType ->
	2119	ist (pf_env gl) (project gl)
	2120	(snd (out_gen (globwit_open_constr_gen casted) x)))
	2121	\| ConstrWithBindingsArgType ->
2058	2122	in_gen wit_constr_with_bindings
2059	2123	(pack_sigma (interp_constr_with_bindings ist (pf_env gl) (project gl)
2060		(out_gen globwit_constr_with_bindings x)))
2061		\| BindingsArgType ->
	2124	(out_gen globwit_constr_with_bindings x)))
	2125	\| BindingsArgType ->
2062	2126	in_gen wit_bindings
2063	2127	(pack_sigma (interp_bindings ist (pf_env gl) (project gl) (out_gen globwit_bindings x)))
2064		\| List0ArgType ConstrArgType -> interp_genarg_constr_list0 ist gl x
2065		\| List1ArgType ConstrArgType -> interp_genarg_constr_list1 ist gl x
2066		\| List0ArgType VarArgType -> interp_genarg_var_list0 ist gl x
2067		\| List1ArgType VarArgType -> interp_genarg_var_list1 ist gl x
2068		\| List0ArgType _ -> app_list0 (interp_genarg ist gl) x
2069		\| List1ArgType _ -> app_list1 (interp_genarg ist gl) x
2070		\| OptArgType _ -> app_opt (interp_genarg ist gl) x
2071		\| PairArgType _ -> app_pair (interp_genarg ist gl) (interp_genarg ist gl) x
2072		\| ExtraArgType s ->
	2128	\| List0ArgType ConstrArgType ->
	2129	let (sigma,v) = interp_genarg_constr_list0 ist gl x in
	2130	evdref := sigma;
	2131	v
	2132	\| List1ArgType ConstrArgType ->
	2133	let (sigma,v) = interp_genarg_constr_list1 ist gl x in
	2134	evdref := sigma;
	2135	v
	2136	\| List0ArgType VarArgType -> interp_genarg_var_list0 ist gl x
	2137	\| List1ArgType VarArgType -> interp_genarg_var_list1 ist gl x
	2138	\| List0ArgType _ -> app_list0 (interp_genarg ist gl) x
	2139	\| List1ArgType _ -> app_list1 (interp_genarg ist gl) x
	2140	\| OptArgType _ -> app_opt (interp_genarg ist gl) x
	2141	\| PairArgType _ -> app_pair (interp_genarg ist gl) (interp_genarg ist gl) x
	2142	\| ExtraArgType s ->
2073	2143	match tactic_genarg_level s with
2074	2144	\| Some n ->
2075	2145	(* Special treatment of tactic arguments *)
2076		in_gen (wit_tactic n)
2077		(TacArg(dloc,valueIn(VFun(ist.trace,ist.lfun,[],
2078		out_gen (globwit_tactic n) x))))
	2146	in_gen (wit_tactic n)
	2147	(TacArg(dloc,valueIn(VFun(ist.trace,ist.lfun,[],
	2148	out_gen (globwit_tactic n) x))))
2079	2149	\| None ->
2080		lookup_interp_genarg s ist gl x
	2150	let (sigma,v) = lookup_interp_genarg s ist gl x in
	2151	evdref:=sigma;
	2152	v
	2153	in
	2154	let v = interp_genarg ist gl x in
	2155	!evdref , v
2081	2156
2082	2157	and interp_genarg_constr_list0 ist gl x =
2083	2158	let lc = out_gen (wit_list0 globwit_constr) x in
2084		let lc = pf_apply (interp_constr_list ist) gl lc in
2085		in_gen (wit_list0 wit_constr) lc
	2159	let (sigma,lc) = pf_apply (interp_constr_list ist) gl lc in
	2160	sigma , in_gen (wit_list0 wit_constr) lc
2086	2161
2087	2162	and interp_genarg_constr_list1 ist gl x =
2088	2163	let lc = out_gen (wit_list1 globwit_constr) x in
2089		let lc = pf_apply (interp_constr_list ist) gl lc in
2090		in_gen (wit_list1 wit_constr) lc
	2164	let (sigma,lc) = pf_apply (interp_constr_list ist) gl lc in
	2165	sigma , in_gen (wit_list1 wit_constr) lc
2091	2166
2092	2167	and interp_genarg_var_list0 ist gl x =
2093	2168	let lc = out_gen (wit_list0 globwit_var) x in

2110	2185	with e when is_match_catchable e ->
2111	2186	match_next_pattern find_next' () in
2112	2187	match_next_pattern (fun () -> match_subterm_gen app c csr) () in
2113		let rec apply_match ist csr = function
	2188	let rec apply_match ist sigma csr = let g = { g with sigma=sigma } in function
2114	2189	\| (All t)::tl ->
2115	2190	(try eval_with_fail ist lz g t
2116		with e when is_match_catchable e -> apply_match ist csr tl)
	2191	with e when is_match_catchable e -> apply_match ist sigma csr tl)
2117	2192	\| (Pat ([],Term c,mt))::tl ->
2118	2193	(try
2119	2194	let lmatch =

2133	2208	raise e
2134	2209	with e when is_match_catchable e ->
2135	2210	debugging_step ist (fun () -> str "switching to the next rule");
2136		apply_match ist csr tl)
	2211	apply_match ist sigma csr tl)
2137	2212
2138	2213	\| (Pat ([],Subterm (b,id,c),mt))::tl ->
2139	2214	(try apply_match_subterm b ist (id,c) csr mt
2140		with PatternMatchingFailure -> apply_match ist csr tl)
	2215	with PatternMatchingFailure -> apply_match ist sigma csr tl)
2141	2216	\| _ ->
2142	2217	errorlabstrm "Tacinterp.apply_match" (str
2143	2218	"No matching clauses for match.") in
2144		let csr =
	2219	let (sigma,csr) =
2145	2220	try interp_ltac_constr ist g constr with e ->
2146	2221	debugging_exception_step ist true e
2147	2222	(fun () -> str "evaluation of the matched expression");
2148	2223	raise e in
2149		let ilr = read_match_rule (fst (extract_ltac_constr_values ist (pf_env g))) ist (pf_env g) (project g) lmr in
	2224	let ilr = read_match_rule (fst (extract_ltac_constr_values ist (pf_env g))) ist (pf_env g) sigma lmr in
2150	2225	let res =
2151		try apply_match ist csr ilr with e ->
	2226	try apply_match ist sigma csr ilr with e ->
2152	2227	debugging_exception_step ist true e (fun () -> str "match expression");
2153	2228	raise e in
2154	2229	debugging_step ist (fun () ->
2155		str "match expression returns " ++ pr_value (Some (pf_env g)) res);
	2230	str "match expression returns " ++ pr_value (Some (pf_env g)) (snd res));
2156	2231	res
2157	2232
2158	2233	(* Interprets tactic expressions : returns a "constr" *)
2159	2234	and interp_ltac_constr ist gl e =
2160		let result =
	2235	let (sigma, result) =
2161	2236	try val_interp ist gl e with Not_found ->
2162	2237	debugging_step ist (fun () ->
2163	2238	str "evaluation failed for" ++ fnl() ++

2170	2245	str " has value " ++ fnl() ++
2171	2246	pr_constr_under_binders_env (pf_env gl) cresult);
2172	2247	if fst cresult <> [] then raise Not_found;
2173		snd cresult
	2248	sigma , snd cresult
2174	2249	with Not_found ->
2175	2250	errorlabstrm ""
2176	2251	(str "Must evaluate to a closed term" ++ fnl() ++

2203	2278
2204	2279	(* Interprets tactic expressions : returns a "tactic" *)
2205	2280	and interp_tactic ist tac gl =
2206		tactic_of_value ist (val_interp ist gl tac) gl
	2281	let (sigma,v) = val_interp ist gl tac in
	2282	tactic_of_value ist v { gl with sigma=sigma }
2207	2283
2208	2284	(* Interprets a primitive tactic *)
2209	2285	and interp_atomic ist gl tac =

2218	2294	h_intro_move (Option.map (interp_fresh_ident ist env) ido)
2219	2295	(interp_move_location ist gl hto)
2220	2296	\| TacAssumption -> h_assumption
2221		\| TacExact c -> h_exact (pf_interp_casted_constr ist gl c)
2222		\| TacExactNoCheck c -> h_exact_no_check (pf_interp_constr ist gl c)
2223		\| TacVmCastNoCheck c -> h_vm_cast_no_check (pf_interp_constr ist gl c)
	2297	\| TacExact c ->
	2298	let (sigma,c_interp) = pf_interp_casted_constr ist gl c in
	2299	tclTHEN
	2300	(tclEVARS sigma)
	2301	(h_exact c_interp)
	2302	\| TacExactNoCheck c ->
	2303	let (sigma,c_interp) = pf_interp_constr ist gl c in
	2304	tclTHEN
	2305	(tclEVARS sigma)
	2306	(h_exact_no_check c_interp)
	2307	\| TacVmCastNoCheck c ->
	2308	let (sigma,c_interp) = pf_interp_constr ist gl c in
	2309	tclTHEN
	2310	(tclEVARS sigma)
	2311	(h_vm_cast_no_check c_interp)
2224	2312	\| TacApply (a,ev,cb,cl) ->
2225	2313	let sigma, l =
2226	2314	list_fold_map (interp_open_constr_with_bindings_loc ist env) sigma cb

2234	2322	let sigma, cb = interp_constr_with_bindings ist env sigma cb in
2235	2323	let sigma, cbo = Option.fold_map (interp_constr_with_bindings ist env) sigma cbo in
2236	2324	tclWITHHOLES ev (h_elim ev cb) sigma cbo
2237		\| TacElimType c -> h_elim_type (pf_interp_type ist gl c)
	2325	\| TacElimType c ->
	2326	let (sigma,c_interp) = pf_interp_type ist gl c in
	2327	tclTHEN
	2328	(tclEVARS sigma)
	2329	(h_elim_type c_interp)
2238	2330	\| TacCase (ev,cb) ->
2239	2331	let sigma, cb = interp_constr_with_bindings ist env sigma cb in
2240	2332	tclWITHHOLES ev (h_case ev) sigma cb
2241		\| TacCaseType c -> h_case_type (pf_interp_type ist gl c)
	2333	\| TacCaseType c ->
	2334	let (sigma,c_interp) = pf_interp_type ist gl c in
	2335	tclTHEN
	2336	(tclEVARS sigma)
	2337	(h_case_type c_interp)
2242	2338	\| TacFix (idopt,n) -> h_fix (Option.map (interp_fresh_ident ist env) idopt) n
2243	2339	\| TacMutualFix (b,id,n,l) ->
2244		let f (id,n,c) = (interp_fresh_ident ist env id,n,pf_interp_type ist gl c)
2245		in h_mutual_fix b (interp_fresh_ident ist env id) n (List.map f l)
	2340	let f sigma (id,n,c) =
	2341	let (sigma,c_interp) = pf_interp_type ist { gl with sigma=sigma } c in
	2342	sigma , (interp_fresh_ident ist env id,n,c_interp) in
	2343	let (sigma,l_interp) =
	2344	List.fold_right begin fun c (sigma,acc) ->
	2345	let (sigma,c_interp) = f sigma c in
	2346	sigma , c_interp::acc
	2347	end l (project gl,[])
	2348	in
	2349	tclTHEN
	2350	(tclEVARS sigma)
	2351	(h_mutual_fix b (interp_fresh_ident ist env id) n l_interp)
2246	2352	\| TacCofix idopt -> h_cofix (Option.map (interp_fresh_ident ist env) idopt)
2247	2353	\| TacMutualCofix (b,id,l) ->
2248		let f (id,c) = (interp_fresh_ident ist env id,pf_interp_type ist gl c) in
2249		h_mutual_cofix b (interp_fresh_ident ist env id) (List.map f l)
2250		\| TacCut c -> h_cut (pf_interp_type ist gl c)
	2354	let f sigma (id,c) =
	2355	let (sigma,c_interp) = pf_interp_type ist { gl with sigma=sigma } c in
	2356	sigma , (interp_fresh_ident ist env id,c_interp) in
	2357	let (sigma,l_interp) =
	2358	List.fold_right begin fun c (sigma,acc) ->
	2359	let (sigma,c_interp) = f sigma c in
	2360	sigma , c_interp::acc
	2361	end l (project gl,[])
	2362	in
	2363	tclTHEN
	2364	(tclEVARS sigma)
	2365	(h_mutual_cofix b (interp_fresh_ident ist env id) l_interp)
	2366	\| TacCut c ->
	2367	let (sigma,c_interp) = pf_interp_type ist gl c in
	2368	tclTHEN
	2369	(tclEVARS sigma)
	2370	(h_cut c_interp)
2251	2371	\| TacAssert (t,ipat,c) ->
2252		let c = (if t=None then interp_constr else interp_type) ist env sigma c in
2253		abstract_tactic (TacAssert (t,ipat,c))
2254		(Tactics.forward (Option.map (interp_tactic ist) t)
2255		(Option.map (interp_intro_pattern ist gl) ipat) c)
	2372	let (sigma,c) = (if t=None then interp_constr else interp_type) ist env sigma c in
	2373	tclTHEN
	2374	(tclEVARS sigma)
	2375	(abstract_tactic (TacAssert (t,ipat,c))
	2376	(Tactics.forward (Option.map (interp_tactic ist) t)
	2377	(Option.map (interp_intro_pattern ist gl) ipat) c))
2256	2378	\| TacGeneralize cl ->
2257	2379	let sigma, cl = interp_constr_with_occurrences_and_name_as_list ist env sigma cl in
2258	2380	tclWITHHOLES false (h_generalize_gen) sigma cl
2259		\| TacGeneralizeDep c -> h_generalize_dep (pf_interp_constr ist gl c)
	2381	\| TacGeneralizeDep c ->
	2382	let (sigma,c_interp) = pf_interp_constr ist gl c in
	2383	tclTHEN
	2384	(tclEVARS sigma)
	2385	(h_generalize_dep c_interp)
2260	2386	\| TacLetTac (na,c,clp,b) ->
2261	2387	let clp = interp_clause ist gl clp in
2262	2388	if clp = nowhere then
2263	2389	(* We try to fully-typechect the term *)
2264		h_let_tac b (interp_fresh_name ist env na)
2265		(pf_interp_constr ist gl c) clp
	2390	let (sigma,c_interp) = pf_interp_constr ist gl c in
	2391	tclTHEN
	2392	(tclEVARS sigma)
	2393	(h_let_tac b (interp_fresh_name ist env na) c_interp clp)
2266	2394	else
2267	2395	(* We try to keep the pattern structure as much as possible *)
2268	2396	h_let_pat_tac b (interp_fresh_name ist env na)
2269	2397	(interp_pure_open_constr ist env sigma c) clp
2270	2398
2271	2399	(* Automation tactics *)
2272		\| TacTrivial (lems,l) ->
2273		Auto.h_trivial
	2400	\| TacTrivial (debug,lems,l) ->
	2401	Auto.h_trivial ~debug
2274	2402	(interp_auto_lemmas ist env sigma lems)
2275	2403	(Option.map (List.map (interp_hint_base ist)) l)
2276		\| TacAuto (n,lems,l) ->
2277		Auto.h_auto (Option.map (interp_int_or_var ist) n)
	2404	\| TacAuto (debug,n,lems,l) ->
	2405	Auto.h_auto ~debug (Option.map (interp_int_or_var ist) n)
2278	2406	(interp_auto_lemmas ist env sigma lems)
2279	2407	(Option.map (List.map (interp_hint_base ist)) l)
2280		\| TacAutoTDB n -> Dhyp.h_auto_tdb n
2281		\| TacDestructHyp (b,id) -> Dhyp.h_destructHyp b (interp_hyp ist gl id)
2282		\| TacDestructConcl -> Dhyp.h_destructConcl
2283		\| TacSuperAuto (n,l,b1,b2) -> Auto.h_superauto n l b1 b2
2284		\| TacDAuto (n,p,lems) ->
2285		Auto.h_dauto (Option.map (interp_int_or_var ist) n,p)
2286		(interp_auto_lemmas ist env sigma lems)
2287	2408
2288	2409	(* Derived basic tactics *)
2289	2410	\| TacSimpleInductionDestruct (isrec,h) ->

2303	2424	let h1 = interp_quantified_hypothesis ist h1 in
2304	2425	let h2 = interp_quantified_hypothesis ist h2 in
2305	2426	Elim.h_double_induction h1 h2
2306		\| TacDecomposeAnd c -> Elim.h_decompose_and (pf_interp_constr ist gl c)
2307		\| TacDecomposeOr c -> Elim.h_decompose_or (pf_interp_constr ist gl c)
	2427	\| TacDecomposeAnd c ->
	2428	let (sigma,c_interp) = pf_interp_constr ist gl c in
	2429	tclTHEN
	2430	(tclEVARS sigma)
	2431	(Elim.h_decompose_and c_interp)
	2432	\| TacDecomposeOr c ->
	2433	let (sigma,c_interp) = pf_interp_constr ist gl c in
	2434	tclTHEN
	2435	(tclEVARS sigma)
	2436	(Elim.h_decompose_or c_interp)
2308	2437	\| TacDecompose (l,c) ->
2309	2438	let l = List.map (interp_inductive ist) l in
2310		Elim.h_decompose l (pf_interp_constr ist gl c)
	2439	let (sigma,c_interp) = pf_interp_constr ist gl c in
	2440	tclTHEN
	2441	(tclEVARS sigma)
	2442	(Elim.h_decompose l c_interp)
2311	2443	\| TacSpecialize (n,cb) ->
2312	2444	let sigma, cb = interp_constr_with_bindings ist env sigma cb in
2313	2445	tclWITHHOLES false (h_specialize n) sigma cb
2314		\| TacLApply c -> h_lapply (pf_interp_constr ist gl c)
	2446	\| TacLApply c ->
	2447	let (sigma,c_interp) = pf_interp_constr ist gl c in
	2448	tclTHEN
	2449	(tclEVARS sigma)
	2450	(h_lapply c_interp)
2315	2451
2316	2452	(* Context management *)
2317	2453	\| TacClear (b,l) -> h_clear b (interp_hyp_list ist gl l)

2343	2479
2344	2480	(* Conversion *)
2345	2481	\| TacReduce (r,cl) ->
2346		h_reduce (pf_interp_red_expr ist gl r) (interp_clause ist gl cl)
	2482	let (sigma,r_interp) = pf_interp_red_expr ist gl r in
	2483	tclTHEN
	2484	(tclEVARS sigma)
	2485	(h_reduce r_interp (interp_clause ist gl cl))
2347	2486	\| TacChange (None,c,cl) ->
2348		h_change None
2349		(if (cl.onhyps = None or cl.onhyps = Some []) &
	2487	let (sigma,c_interp) =
	2488	if (cl.onhyps = None or cl.onhyps = Some []) &
2350	2489	(cl.concl_occs = all_occurrences_expr or
2351	2490	cl.concl_occs = no_occurrences_expr)
2352	2491	then pf_interp_type ist gl c
2353		else pf_interp_constr ist gl c)
2354		(interp_clause ist gl cl)
	2492	else pf_interp_constr ist gl c
	2493	in
	2494	tclTHEN
	2495	(tclEVARS sigma)
	2496	(h_change None c_interp (interp_clause ist gl cl))
2355	2497	\| TacChange (Some op,c,cl) ->
2356	2498	let sign,op = interp_typed_pattern ist env sigma op in
2357		h_change (Some op)
2358		(try pf_interp_constr ist (extend_gl_hyps gl sign) c
2359		with Not_found \| Anomaly _ (* Hack *) ->
2360		errorlabstrm "" (strbrk "Failed to get enough information from the left-hand side to type the right-hand side."))
2361		(interp_clause ist gl cl)
	2499	(* spiwack: (2012/04/18) the evar_map output by pf_interp_constr
	2500	is dropped as the evar_map taken as input (from
	2501	extend_gl_hyps) is incorrect. This means that evar
	2502	instantiated by pf_interp_constr may be lost, there. *)
	2503	let (_,c_interp) =
	2504	try pf_interp_constr ist (extend_gl_hyps gl sign) c
	2505	with Not_found \| Anomaly _ (* Hack *) ->
	2506	errorlabstrm "" (strbrk "Failed to get enough information from the left-hand side to type the right-hand side.")
	2507	in
	2508	tclTHEN
	2509	(tclEVARS sigma)
	2510	(h_change (Some op) c_interp (interp_clause ist { gl with sigma=sigma } cl))
2362	2511
2363	2512	(* Equivalence relations *)
2364	2513	\| TacReflexivity -> h_reflexivity
2365	2514	\| TacSymmetry c -> h_symmetry (interp_clause ist gl c)
2366		\| TacTransitivity c -> h_transitivity (Option.map (pf_interp_constr ist gl) c)
	2515	\| TacTransitivity c ->
	2516	begin match c with
	2517	\| None -> h_transitivity None
	2518	\| Some c ->
	2519	let (sigma,c_interp) = pf_interp_constr ist gl c in
	2520	tclTHEN
	2521	(tclEVARS sigma)
	2522	(h_transitivity (Some c_interp))
	2523	end
2367	2524
2368	2525	(* Equality and inversion *)
2369	2526	\| TacRewrite (ev,l,cl,by) ->

2374	2531	Equality.general_multi_multi_rewrite ev l cl
2375	2532	(Option.map (fun by -> tclCOMPLETE (interp_tactic ist by), Equality.Naive) by)
2376	2533	\| TacInversion (DepInversion (k,c,ids),hyp) ->
2377		Inv.dinv k (Option.map (pf_interp_constr ist gl) c)
	2534	let (sigma,c_interp) =
	2535	match c with
	2536	\| None -> sigma , None
	2537	\| Some c ->
	2538	let (sigma,c_interp) = pf_interp_constr ist gl c in
	2539	sigma , Some c_interp
	2540	in
	2541	Inv.dinv k c_interp
2378	2542	(Option.map (interp_intro_pattern ist gl) ids)
2379	2543	(interp_declared_or_quantified_hypothesis ist gl hyp)
2380	2544	\| TacInversion (NonDepInversion (k,idl,ids),hyp) ->

2383	2547	(interp_hyp_list ist gl idl)
2384	2548	(interp_declared_or_quantified_hypothesis ist gl hyp)
2385	2549	\| TacInversion (InversionUsing (c,idl),hyp) ->
	2550	let (sigma,c_interp) = pf_interp_constr ist gl c in
2386	2551	Leminv.lemInv_clause (interp_declared_or_quantified_hypothesis ist gl hyp)
2387		(pf_interp_constr ist gl c)
	2552	c_interp
2388	2553	(interp_hyp_list ist gl idl)
2389	2554
2390	2555	(* For extensions *)
2391	2556	\| TacExtend (loc,opn,l) ->
2392	2557	let tac = lookup_tactic opn in
2393		let args = List.map (interp_genarg ist gl) l in
	2558	let (sigma,args) =
	2559	List.fold_right begin fun a (sigma,acc) ->
	2560	let (sigma,a_interp) = interp_genarg ist { gl with sigma=sigma } a in
	2561	sigma , a_interp::acc
	2562	end l (project gl,[])
	2563	in
2394	2564	abstract_extended_tactic opn args (tac args)
2395	2565	\| TacAlias (loc,s,l,(_,body)) -> fun gl ->
	2566	let evdref = ref gl.sigma in
2396	2567	let rec f x = match genarg_tag x with
2397	2568	\| IntArgType ->
2398	2569	VInteger (out_gen globwit_int x)

2414	2585	\| SortArgType ->
2415	2586	VConstr ([],mkSort (interp_sort (out_gen globwit_sort x)))
2416	2587	\| ConstrArgType ->
2417		mk_constr_value ist gl (out_gen globwit_constr x)
	2588	let (sigma,v) = mk_constr_value ist gl (out_gen globwit_constr x) in
	2589	evdref := sigma;
	2590	v
	2591	\| OpenConstrArgType false ->
	2592	let (sigma,v) = mk_open_constr_value ist gl (snd (out_gen globwit_open_constr x)) in
	2593	evdref := sigma;
	2594	v
2418	2595	\| ConstrMayEvalArgType ->
2419		VConstr
2420		([],interp_constr_may_eval ist gl (out_gen globwit_constr_may_eval x))
	2596	let (sigma,c_interp) = interp_constr_may_eval ist gl (out_gen globwit_constr_may_eval x) in
	2597	evdref := sigma;
	2598	VConstr ([],c_interp)
2421	2599	\| ExtraArgType s when tactic_genarg_level s <> None ->
2422	2600	(* Special treatment of tactic arguments *)
2423		val_interp ist gl
	2601	let (sigma,v) = val_interp ist gl
2424	2602	(out_gen (globwit_tactic (Option.get (tactic_genarg_level s))) x)
	2603	in
	2604	evdref := sigma;
	2605	v
2425	2606	\| List0ArgType ConstrArgType ->
2426	2607	let wit = wit_list0 globwit_constr in
2427		VList (List.map (mk_constr_value ist gl) (out_gen wit x))
	2608	let (sigma,l_interp) =
	2609	List.fold_right begin fun c (sigma,acc) ->
	2610	let (sigma,c_interp) = mk_constr_value ist { gl with sigma=sigma } c in
	2611	sigma , c_interp::acc
	2612	end (out_gen wit x) (project gl,[])
	2613	in
	2614	evdref := sigma;
	2615	VList (l_interp)
2428	2616	\| List0ArgType VarArgType ->
2429	2617	let wit = wit_list0 globwit_var in
2430	2618	VList (List.map (mk_hyp_value ist gl) (out_gen wit x))

2444	2632	VList (List.map mk_ipat (out_gen wit x))
2445	2633	\| List1ArgType ConstrArgType ->
2446	2634	let wit = wit_list1 globwit_constr in
2447		VList (List.map (mk_constr_value ist gl) (out_gen wit x))
	2635	let (sigma, l_interp) =
	2636	List.fold_right begin fun c (sigma,acc) ->
	2637	let (sigma,c_interp) = mk_constr_value ist { gl with sigma=sigma } c in
	2638	sigma , c_interp::acc
	2639	end (out_gen wit x) (project gl,[])
	2640	in
	2641	evdref:=sigma;
	2642	VList l_interp
2448	2643	\| List1ArgType VarArgType ->
2449	2644	let wit = wit_list1 globwit_var in
2450	2645	VList (List.map (mk_hyp_value ist gl) (out_gen wit x))

2468	2663	\| ExtraArgType _ \| BindingsArgType
2469	2664	\| OptArgType _ \| PairArgType _
2470	2665	\| List0ArgType _ \| List1ArgType _
2471		-> error "This generic type is not supported in alias."
	2666	-> error "This argument type is not supported in tactic notations."
2472	2667
2473	2668	in
2474	2669	let lfun = (List.map (fun (x,c) -> (x,f c)) l)@ist.lfun in
2475	2670	let trace = push_trace (loc,LtacNotationCall s) ist.trace in
	2671	let gl = { gl with sigma = !evdref } in
2476	2672	interp_tactic { ist with lfun=lfun; trace=trace } body gl
2477	2673
2478	2674	let make_empty_glob_sign () =
2479	2675	{ ltacvars = ([],[]); ltacrecvars = [];
2480	2676	gsigma = Evd.empty; genv = Global.env() }
	2677
	2678	let fully_empty_glob_sign =
	2679	{ ltacvars = ([],[]); ltacrecvars = [];
	2680	gsigma = Evd.empty; genv = Environ.empty_env }
2481	2681
2482	2682	(* Initial call for interpretation *)
2483	2683	let interp_tac_gen lfun avoid_ids debug t gl =

2487	2687	gsigma = project gl; genv = pf_env gl } t) gl
2488	2688
2489	2689	let eval_tactic t gls =
	2690	db_initialize ();
2490	2691	interp_tactic { lfun=[]; avoid_ids=[]; debug=get_debug(); trace=[] }
2491	2692	t gls
2492	2693

2640	2841	\| TacLetTac (id,c,clp,b) -> TacLetTac (id,subst_glob_constr subst c,clp,b)
2641	2842
2642	2843	(* Automation tactics *)
2643		\| TacTrivial (lems,l) -> TacTrivial (List.map (subst_glob_constr subst) lems,l)
2644		\| TacAuto (n,lems,l) -> TacAuto (n,List.map (subst_glob_constr subst) lems,l)
2645		\| TacAutoTDB n -> TacAutoTDB n
2646		\| TacDestructHyp (b,id) -> TacDestructHyp(b,id)
2647		\| TacDestructConcl -> TacDestructConcl
2648		\| TacSuperAuto (n,l,b1,b2) -> TacSuperAuto (n,l,b1,b2)
2649		\| TacDAuto (n,p,lems) -> TacDAuto (n,p,List.map (subst_glob_constr subst) lems)
	2844	\| TacTrivial (d,lems,l) -> TacTrivial (d,List.map (subst_glob_constr subst) lems,l)
	2845	\| TacAuto (d,n,lems,l) -> TacAuto (d,n,List.map (subst_glob_constr subst) lems,l)
2650	2846
2651	2847	(* Derived basic tactics *)
2652	2848	\| TacSimpleInductionDestruct (isrec,h) as x -> x

2990	3186	Flags.with_option strict_check
2991	3187	(intern_pure_tactic {(make_empty_glob_sign()) with ltacvars=(l,[])}))
2992	3188	let _ = Auto.set_extern_subst_tactic subst_tactic
2993		let _ = Dhyp.set_extern_interp eval_tactic

+8

-6

tactics/tacinterp.mli less more

76	76	gsigma : Evd.evar_map;
77	77	genv : Environ.env }
78	78
	79	val fully_empty_glob_sign : glob_sign
	80
79	81	val add_interp_genarg :
80	82	string ->
81	83	(glob_sign -> raw_generic_argument -> glob_generic_argument) *
82	84	(interp_sign -> goal sigma -> glob_generic_argument ->
83		typed_generic_argument) *
	85	Evd.evar_map * typed_generic_argument) *
84	86	(substitution -> glob_generic_argument -> glob_generic_argument)
85	87	-> unit
86	88
87	89	val interp_genarg :
88		interp_sign -> goal sigma -> glob_generic_argument -> typed_generic_argument
	90	interp_sign -> goal sigma -> glob_generic_argument -> Evd.evar_map * typed_generic_argument
89	91
90	92	val intern_genarg :
91	93	glob_sign -> raw_generic_argument -> glob_generic_argument

113	115	substitution -> glob_constr_and_expr Glob_term.with_bindings -> glob_constr_and_expr Glob_term.with_bindings
114	116
115	117	(** Interprets any expression *)
116		val val_interp : interp_sign -> goal sigma -> glob_tactic_expr -> value
	118	val val_interp : interp_sign -> goal sigma -> glob_tactic_expr -> Evd.evar_map * value
117	119
118	120	(** Interprets an expression that evaluates to a constr *)
119	121	val interp_ltac_constr : interp_sign -> goal sigma -> glob_tactic_expr ->
120		constr
	122	Evd.evar_map * constr
121	123
122	124	(** Interprets redexp arguments *)
123		val interp_redexp : Environ.env -> Evd.evar_map -> raw_red_expr -> red_expr
	125	val interp_redexp : Environ.env -> Evd.evar_map -> raw_red_expr -> Evd.evar_map * red_expr
124	126
125	127	(** Interprets tactic expressions *)
126	128	val interp_tac_gen : (identifier * value) list -> identifier list ->

142	144
143	145	val interp : raw_tactic_expr -> tactic
144	146
145		val eval_ltac_constr : goal sigma -> raw_tactic_expr -> constr
	147	val eval_ltac_constr : goal sigma -> raw_tactic_expr -> Evd.evar_map * constr
146	148
147	149	val subst_tactic : substitution -> glob_tactic_expr -> glob_tactic_expr
148	150

+0

-1

tactics/tacticals.ml less more

52	52	let tclFIRST = Refiner.tclFIRST
53	53	let tclSOLVE = Refiner.tclSOLVE
54	54	let tclTRY = Refiner.tclTRY
55		let tclINFO = Refiner.tclINFO
56	55	let tclCOMPLETE = Refiner.tclCOMPLETE
57	56	let tclAT_LEAST_ONCE = Refiner.tclAT_LEAST_ONCE
58	57	let tclFAIL = Refiner.tclFAIL

+0

-1

tactics/tacticals.mli less more

44	44	val tclFIRST : tactic list -> tactic
45	45	val tclSOLVE : tactic list -> tactic
46	46	val tclTRY : tactic -> tactic
47		val tclINFO : tactic -> tactic
48	47	val tclCOMPLETE : tactic -> tactic
49	48	val tclAT_LEAST_ONCE : tactic -> tactic
50	49	val tclFAIL : int -> std_ppcmds -> tactic

+8

-2

tactics/tactics.ml less more

545	545	str".")
546	546
547	547	let intros_until_gen red h g =
548		tclDO (depth_of_quantified_hypothesis red h g) intro g
	548	tclDO (depth_of_quantified_hypothesis red h g) (if red then introf else intro) g
549	549
550	550	let intros_until_id id = intros_until_gen true (NamedHyp id)
551	551	let intros_until_n_gen red n = intros_until_gen red (AnonHyp n)

2497	2497	tclMAP (fun id ->
2498	2498	tclTRY (generalize_dep ~with_let:true (mkVar id))) vars] gl) gl
2499	2499
	2500	let rec compare_upto_variables x y =
	2501	if (isVar x \|\| isRel x) && (isVar y \|\| isRel y) then true
	2502	else compare_constr compare_upto_variables x y
	2503
2500	2504	let specialize_eqs id gl =
2501	2505	let env = pf_env gl in
2502	2506	let ty = pf_get_hyp_typ gl id in
2503	2507	let evars = ref (project gl) in
2504		let unif env evars c1 c2 = Evarconv.e_conv env evars c2 c1 in
	2508	let unif env evars c1 c2 =
	2509	compare_upto_variables c1 c2 && Evarconv.e_conv env evars c1 c2
	2510	in
2505	2511	let rec aux in_eqs ctx acc ty =
2506	2512	match kind_of_term ty with
2507	2513	\| Prod (na, t, b) ->

+0

-1

tactics/tactics.mllib less more

9	9	Tactics
10	10	Hiddentac
11	11	Elim
12		Dhyp
13	12	Auto
14	13	Equality
15	14	Contradiction

+18

-3

test-suite/bugs/closed/shouldsucceed/2603.v less more

	0	(** Namespace of module vs. namescope of definitions/constructors/...
	1
	2	As noticed by A. Appel in bug #2603, module names and definition
	3	names used to be in the same namespace. But conflict with names
	4	of constructors (or 2nd mutual inductive...) used to not be checked
	5	enough, leading to stange situations.
	6
	7	- In 8.3pl3 we introduced checks that forbid uniformly the following
	8	situations.
	9
	10	- For 8.4 we finally managed to make module names and other names
	11	live in two separate namespace, hence allowing all of the following
	12	situations.
	13	*)
	14
0	15	Module Type T.
1	16	End T.
2	17

8	23
9	24	Module M1 : L with Module E:=K.
10	25	Module E := K.
11		Fail Inductive t := E. (* Used to be accepted, but End M1 below was failing *)
	26	Inductive t := E. (* Used to be accepted, but End M1 below was failing *)
12	27	End M1.
13	28
14	29	Module M2 : L with Module E:=K.
15	30	Inductive t := E.
16		Fail Module E := K. (* Used to be accepted *)
17		Fail End M2. (* Used to be accepted *)
	31	Module E := K. (* Used to be accepted *)
	32	End M2. (* Used to be accepted *)

+19

-0

test-suite/bugs/closed/shouldsucceed/2732.v less more

	0	(* Check correct behavior of add_primitive_tactic in TACEXTEND *)
	1
	2	(* Added also the case of eauto and congruence *)
	3
	4	Ltac thus H := solve [H].
	5
	6	Lemma test: forall n : nat, n <= n.
	7	Proof.
	8	intro.
	9	thus firstorder.
	10	Undo.
	11	thus eauto.
	12	Qed.
	13
	14	Lemma test2: false = true -> False.
	15	Proof.
	16	intro.
	17	thus congruence.
	18	Qed.

+26

-0

test-suite/bugs/closed/shouldsucceed/2733.v less more

	0	Definition goodid : forall {A} (x: A), A := fun A x => x.
	1	Definition wrongid : forall A (x: A), A := fun {A} x => x.
	2
	3	Inductive ty := N \| B.
	4
	5	Inductive alt_list : ty -> ty -> Type :=
	6	\| nil {k} : alt_list k k
	7	\| Ncons {k} : nat -> alt_list B k -> alt_list N k
	8	\| Bcons {k} : bool -> alt_list N k -> alt_list B k.
	9
	10	Definition trullynul k {k'} (l : alt_list k k') :=
	11	match k,l with
	12	\|N,l' => Ncons 0 (Bcons true l')
	13	\|B,l' => Bcons true (Ncons 0 l')
	14	end.
	15
	16	Fixpoint app (P : forall {k k'}, alt_list k k' -> alt_list k k') {t1 t2} (l : alt_list t1 t2) {struct l}: forall {t3}, alt_list t2 t3 ->
	17	alt_list t1 t3 :=
	18	match l with
	19	\| nil _ => fun _ l2 => P l2
	20	\| Ncons _ n l1 => fun _ l2 => Ncons n (app (@P) l1 l2)
	21	\| Bcons _ b l1 => fun _ l2 => Bcons b (app (@P) l1 l2)
	22	end.
	23
	24	Check (fun {t t'} (l: alt_list t t') =>
	25	app trullynul (goodid l) (wrongid _ nil)).

+0

-11

~~test-suite/complexity/autodecomp.v~~ less more

0		(* This example used to be in (at least) exponential time in the number of
1		conjunctive types in the hypotheses before revision 11713 *)
2		(* Expected time < 1.50s *)
3
4		Goal
5		True/\True->
6		True/\True->
7		True/\True->
8		False/\False.
9
10		Timeout 5 Time auto decomp.

+8

-0

test-suite/output/Arguments.out less more

90	90	when the 5th, 6th and 7th arguments evaluate to a constructor
91	91	f is transparent
92	92	Expands to: Constant Top.f
	93	forall w : r, w 3 true = tt
	94	: Prop
	95	The command has indeed failed with message:
	96	=> Error: Unknown interpretation for notation "$".
	97	w 3 true = tt
	98	: Prop
	99	The command has indeed failed with message:
	100	=> Error: Extra argument _.

+12

-0

test-suite/output/Arguments.v less more

37	37	About f.
38	38	Arguments f : clear implicits and scopes.
39	39	About f.
	40	Record r := { pi :> nat -> bool -> unit }.
	41	Notation "$" := 3 (only parsing) : foo_scope.
	42	Notation "$" := true (only parsing) : bar_scope.
	43	Delimit Scope bar_scope with B.
	44	Arguments pi _ _%F _%B.
	45	Check (forall w : r, pi w $ $ = tt).
	46	Fail Check (forall w : r, w $ $ = tt).
	47	Axiom w : r.
	48	Arguments w _%F _%B : extra scopes.
	49	Check (w $ $ = tt).
	50	Fail Arguments w _%F _%B.
	51

+6

-0

test-suite/output/Notations2.out less more

9	9	: nat
10	10	let '(a, _, _) := (2, 3, 4) in a
11	11	: nat
	12	exists myx (y : bool), myx = y
	13	: Prop
12	14	fun (P : nat -> nat -> Prop) (x : nat) => exists x0, P x x0
13	15	: (nat -> nat -> Prop) -> nat -> Prop
14	16	∃ n p : nat, n + p = 0

45	47	\| plus2 _ :: _ => 2
46	48	end
47	49	: list(nat) -> nat
	50	# x : nat => x
	51	: nat -> nat
	52	# _ : nat => 2
	53	: nat -> nat

+15

-0

test-suite/output/Notations2.v less more

23	23	Remove Printing Let prod.
24	24	Check match (0,0,0) with (x,y,z) => x+y+z end.
25	25	Check let '(a,b,c) := ((2,3),4) in a.
	26
	27	(* Check printing of notations with mixed reserved binders (see bug #2571) *)
	28
	29	Implicit Type myx : bool.
	30	Check exists myx y, myx = y.
26	31
27	32	(* Test notation for anonymous functions up to eta-expansion *)
28	33

82	87
83	88	Check mylet f [x;y;z;(a:bool)] := x+y+z+1 in f 0 1 2.
84	89	*)
	90
	91	(* Check notations for functional terms which do not necessarily
	92	depend on their parameter *)
	93	(* Old request mentioned again on coq-club 20/1/2012 *)
	94
	95	Notation "# x : T => t" := (fun x : T => t)
	96	(at level 0, t at level 200, x ident).
	97
	98	Check # x : nat => x.
	99	Check # _ : nat => 2.

+5

-4

test-suite/output/PrintInfos.out less more

36	36	When applied to 1 argument:
37	37	Argument A is implicit
38	38	plus =
39		fix plus (n m : nat) : nat := match n with
40		\| 0 => m
41		\| S p => S (plus p m)
42		end
	39	fix plus (n m : nat) {struct n} : nat :=
	40	match n with
	41	\| 0 => m
	42	\| S p => S (plus p m)
	43	end
43	44	: nat -> nat -> nat
44	45
45	46	Argument scopes are [nat_scope nat_scope]

+52

-31

test-suite/success/Cases.v less more

99	99	\| x => x
100	100	end).
101	101
102		Section testlist.
	102	Module Type testlist.
103	103	Parameter A : Set.
104	104	Inductive list : Set :=
105	105	\| nil : list

118	118	\| nil => l
119	119	\| cons b l => l
120	120	end.
121		Reset list.
122	121	End testlist.
123	122
124	123

912	911	\| LeS n m _ => (S n, S m)
913	912	end).
914	913
915
	914	Module Type F_v1.
916	915	Fixpoint F (n m : nat) (h : Le n m) {struct h} : Le n (S m) :=
917	916	match h in (Le n m) return (Le n (S m)) with
918	917	\| LeO m' => LeO (S m')
919	918	\| LeS n' m' h' => LeS n' (S m') (F n' m' h')
920	919	end.
921
922		Reset F.
923
	920	End F_v1.
	921
	922	Module Type F_v2.
924	923	Fixpoint F (n m : nat) (h : Le n m) {struct h} : Le n (S m) :=
925	924	match h in (Le n m) return (Le n (S m)) with
926	925	\| LeS n m h => LeS n (S m) (F n m h)
927	926	\| LeO m => LeO (S m)
928	927	end.
	928	End F_v2.
929	929
930	930	(* Rend la longueur de la liste *)
931		Definition length1 (n : nat) (l : listn n) :=
	931
	932	Module Type L1.
	933	Definition length (n : nat) (l : listn n) :=
932	934	match l return nat with
933	935	\| consn n _ (consn m _ _) => S (S m)
934	936	\| consn n _ _ => 1
935	937	\| _ => 0
936	938	end.
937
938		Reset length1.
939		Definition length1 (n : nat) (l : listn n) :=
	939	End L1.
	940
	941	Module Type L1'.
	942	Definition length (n : nat) (l : listn n) :=
940	943	match l with
941	944	\| consn n _ (consn m _ _) => S (S m)
942	945	\| consn n _ _ => 1
943	946	\| _ => 0
944	947	end.
945
946
947		Definition length2 (n : nat) (l : listn n) :=
	948	End L1'.
	949
	950	Module Type L2.
	951	Definition length (n : nat) (l : listn n) :=
948	952	match l return nat with
949	953	\| consn n _ (consn m _ _) => S (S m)
950	954	\| consn n _ _ => S n
951	955	\| _ => 0
952	956	end.
953
954		Reset length2.
955
956		Definition length2 (n : nat) (l : listn n) :=
	957	End L2.
	958
	959	Module Type L2'.
	960	Definition length (n : nat) (l : listn n) :=
957	961	match l with
958	962	\| consn n _ (consn m _ _) => S (S m)
959	963	\| consn n _ _ => S n
960	964	\| _ => 0
961	965	end.
962
963		Definition length3 (n : nat) (l : listn n) :=
	966	End L2'.
	967
	968	Module Type L3.
	969	Definition length (n : nat) (l : listn n) :=
964	970	match l return nat with
965	971	\| consn n _ (consn m _ l) => S n
966	972	\| consn n _ _ => 1
967	973	\| _ => 0
968	974	end.
969
970
971		Reset length3.
972
973		Definition length3 (n : nat) (l : listn n) :=
	975	End L3.
	976
	977	Module Type L3'.
	978	Definition length (n : nat) (l : listn n) :=
974	979	match l with
975	980	\| consn n _ (consn m _ l) => S n
976	981	\| consn n _ _ => 1
977	982	\| _ => 0
978	983	end.
979
	984	End L3'.
980	985
981	986	Type match LeO 0 return nat with
982	987	\| LeS n m h => n + m

1255	1260	\| (x, y) => (S x, S y)
1256	1261	end.
1257	1262
1258
	1263	Module Type test_concat.
1259	1264
1260	1265	Parameter concat : forall A : Set, List A -> List A -> List A.
1261	1266

1272	1277	\| _, _ => Nil nat
1273	1278	end.
1274	1279
	1280	End test_concat.
1275	1281
1276	1282	Inductive redexes : Set :=
1277	1283	\| VAR : nat -> redexes

1294	1300	\| _ => 0
1295	1301	end).
1296	1302
1297		Reset concat.
1298	1303	Parameter
1299	1304	concat :
1300	1305	forall n : nat, listn n -> forall m : nat, listn m -> listn (n + m).

1382	1387	(* I.e. to test manipulation of elimination predicate *)
1383	1388	(* ===================================================================== *)
1384	1389
	1390	Module Type test_term.
1385	1391
1386	1392	Parameter LTERM : nat -> Set.
1387	1393	Inductive TERM : Type :=

1396	1402	\| oper op1 l1, oper op2 l2 => False
1397	1403	\| _, _ => False
1398	1404	end.
1399		Reset LTERM.
	1405
	1406	End test_term.
1400	1407
1401	1408
1402	1409

1492	1499	end.
1493	1500
1494	1501
	1502	Module Type ff.
1495	1503
1496	1504	Parameter ff : forall n m : nat, n <> m -> S n <> S m.
1497	1505	Parameter discr_r : forall n : nat, 0 <> S n.

1504	1512	\| S x => or_intror (S x = 0) (discr_l x)
1505	1513	end).
1506	1514
	1515	Module Type eqdec.
1507	1516
1508	1517	Fixpoint eqdec (n m : nat) {struct n} : n = m \/ n <> m :=
1509	1518	match n, m return (n = m \/ n <> m) with

1517	1526	end
1518	1527	end.
1519	1528
1520		Reset eqdec.
	1529	End eqdec.
	1530
	1531	Module Type eqdec'.
1521	1532
1522	1533	Fixpoint eqdec (n : nat) : forall m : nat, n = m \/ n <> m :=
1523	1534	match n return (forall m : nat, n = m \/ n <> m) with

1539	1550	end
1540	1551	end.
1541	1552
	1553	End eqdec'.
1542	1554
1543	1555	Inductive empty : forall n : nat, listn n -> Prop :=
1544	1556	intro_empty : empty 0 niln.

1553	1565	\| consn n a y as b => or_intror (empty (S n) b) (inv_empty n a y)
1554	1566	end).
1555	1567
1556		Reset ff.
	1568	End ff.
	1569
	1570	Module Type ff'.
	1571
1557	1572	Parameter ff : forall n m : nat, n <> m -> S n <> S m.
1558	1573	Parameter discr_r : forall n : nat, 0 <> S n.
1559	1574	Parameter discr_l : forall n : nat, S n <> 0.

1565	1580	\| S x => or_intror (S x = 0) (discr_l x)
1566	1581	end).
1567	1582
	1583	Module Type eqdec.
1568	1584
1569	1585	Fixpoint eqdec (n m : nat) {struct n} : n = m \/ n <> m :=
1570	1586	match n, m return (n = m \/ n <> m) with

1577	1593	\| or_intror h => or_intror (S x = S y) (ff x y h)
1578	1594	end
1579	1595	end.
1580		Reset eqdec.
	1596
	1597	End eqdec.
	1598
	1599	Module Type eqdec'.
1581	1600
1582	1601	Fixpoint eqdec (n : nat) : forall m : nat, n = m \/ n <> m :=
1583	1602	match n return (forall m : nat, n = m \/ n <> m) with

1599	1618	end
1600	1619	end.
1601	1620
	1621	End eqdec'.
	1622	End ff'.
1602	1623
1603	1624	(* ================================================== *)
1604	1625	(* Pour tester parametres *)

+18

-8

test-suite/success/CasesDep.v less more

221	221	de l'arite de chaque operateur *)
222	222
223	223
224		Section Sig.
	224	Module Sig.
225	225
226	226	Record Signature : Type :=
227	227	{Sigma : DSetoid; Arity : Map (Set_of Sigma) (Set_of Dposint)}.

276	276	\| _, _ => False
277	277	end.
278	278
279
	279	Module Type Version1.
280	280
281	281	Definition equalT (t1 t2 : TERM) : Prop :=
282	282	match t1, t2 with

293	293	\| _, _ => False
294	294	end.
295	295
296
297		Reset equalT.
	296	End Version1.
	297
	298
298	299	(* ------------------------------------------------------------------*)
299	300	(* Initial exemple (without patterns) *)
300	301	(-------------------------------------------------------------------)
	302
	303	Module Version2.
301	304
302	305	Fixpoint equalT (t1 : TERM) : TERM -> Prop :=
303	306	match t1 return (TERM -> Prop) with

346	349	end
347	350	end.
348	351
	352	End Version2.
349	353
350	354	(* ---------------------------------------------------------------- *)
351	355	(* Version with simple patterns *)
352	356	(* ---------------------------------------------------------------- *)
353		Reset equalT.
	357
	358	Module Version3.
354	359
355	360	Fixpoint equalT (t1 : TERM) : TERM -> Prop :=
356	361	match t1 with

387	392	end
388	393	end.
389	394
390
391		Reset equalT.
	395	End Version3.
	396
	397	Module Version4.
392	398
393	399	Fixpoint equalT (t1 : TERM) : TERM -> Prop :=
394	400	match t1 with

422	428	end
423	429	end.
424	430
	431	End Version4.
	432
425	433	(* ---------------------------------------------------------------- *)
426	434	(* Version with multiple patterns *)
427	435	(* ---------------------------------------------------------------- *)
428		Reset equalT.
	436
	437	Module Version5.
429	438
430	439	Fixpoint equalT (t1 t2 : TERM) {struct t1} : Prop :=
431	440	match t1, t2 with

444	453	\| _, _ => False
445	454	end.
446	455
	456	End Version5.
447	457
448	458	(* ------------------------------------------------------------------ *)
449	459

+0

-5

test-suite/success/Hints.v less more

14	14	Hint Immediate refl_equal sym_equal: foo.
15	15	Hint Unfold fst sym_equal.
16	16	Hint Unfold fst sym_equal: foo.
17
18		(* What's this stranged syntax ? *)
19		Hint Destruct h6 := 4 Conclusion (_ <= _) => fun H => apply H.
20		Hint Destruct h7 := 4 Discardable Hypothesis (_ <= _) => fun H => apply H.
21		Hint Destruct h8 := 4 Hypothesis (_ <= _) => fun H => apply H.
22	17
23	18	(* Checks that local names are accepted *)
24	19	Section A.

+28

-56

test-suite/success/Mod_params.v less more

19	19	#trace Nametab.exists_cci;;
20	20	*)
21	21
22		Module M.
23		Reset M.
24		Module M (X: SIG).
25		Reset M.
26		Module M (X Y: SIG).
27		Reset M.
28		Module M (X: SIG) (Y: SIG).
29		Reset M.
30		Module M (X Y: SIG) (Z1 Z: SIG).
31		Reset M.
32		Module M (X: SIG) (Y: SIG).
33		Reset M.
34		Module M (X Y: SIG) (Z1 Z: SIG).
35		Reset M.
36		Module M : SIG.
37		Reset M.
38		Module M (X: SIG) : SIG.
39		Reset M.
40		Module M (X Y: SIG) : SIG.
41		Reset M.
42		Module M (X: SIG) (Y: SIG) : SIG.
43		Reset M.
44		Module M (X Y: SIG) (Z1 Z: SIG) : SIG.
45		Reset M.
46		Module M (X: SIG) (Y: SIG) : SIG.
47		Reset M.
48		Module M (X Y: SIG) (Z1 Z: SIG) : SIG.
49		Reset M.
50		Module M := F Q.
51		Reset M.
52		Module M (X: FSIG) := X Q.
53		Reset M.
54		Module M (X Y: FSIG) := X Q.
55		Reset M.
56		Module M (X: FSIG) (Y: SIG) := X Y.
57		Reset M.
58		Module M (X Y: FSIG) (Z1 Z: SIG) := X Z.
59		Reset M.
60		Module M (X: FSIG) (Y: SIG) := X Y.
61		Reset M.
62		Module M (X Y: FSIG) (Z1 Z: SIG) := X Z.
63		Reset M.
64		Module M : SIG := F Q.
65		Reset M.
66		Module M (X: FSIG) : SIG := X Q.
67		Reset M.
68		Module M (X Y: FSIG) : SIG := X Q.
69		Reset M.
70		Module M (X: FSIG) (Y: SIG) : SIG := X Y.
71		Reset M.
72		Module M (X Y: FSIG) (Z1 Z: SIG) : SIG := X Z.
73		Reset M.
74		Module M (X: FSIG) (Y: SIG) : SIG := X Y.
75		Reset M.
76		Module M (X Y: FSIG) (Z1 Z: SIG) : SIG := X Z.
77		Reset M.
	22	Module M01. End M01.
	23	Module M02 (X: SIG). End M02.
	24	Module M03 (X Y: SIG). End M03.
	25	Module M04 (X: SIG) (Y: SIG). End M04.
	26	Module M05 (X Y: SIG) (Z1 Z: SIG). End M05.
	27	Module M06 (X: SIG) (Y: SIG). End M06.
	28	Module M07 (X Y: SIG) (Z1 Z: SIG). End M07.
	29	Module M08 : SIG. End M08.
	30	Module M09 (X: SIG) : SIG. End M09.
	31	Module M10 (X Y: SIG) : SIG. End M10.
	32	Module M11 (X: SIG) (Y: SIG) : SIG. End M11.
	33	Module M12 (X Y: SIG) (Z1 Z: SIG) : SIG. End M12.
	34	Module M13 (X: SIG) (Y: SIG) : SIG. End M13.
	35	Module M14 (X Y: SIG) (Z1 Z: SIG) : SIG. End M14.
	36	Module M15 := F Q.
	37	Module M16 (X: FSIG) := X Q.
	38	Module M17 (X Y: FSIG) := X Q.
	39	Module M18 (X: FSIG) (Y: SIG) := X Y.
	40	Module M19 (X Y: FSIG) (Z1 Z: SIG) := X Z.
	41	Module M20 (X: FSIG) (Y: SIG) := X Y.
	42	Module M21 (X Y: FSIG) (Z1 Z: SIG) := X Z.
	43	Module M22 : SIG := F Q.
	44	Module M23 (X: FSIG) : SIG := X Q.
	45	Module M24 (X Y: FSIG) : SIG := X Q.
	46	Module M25 (X: FSIG) (Y: SIG) : SIG := X Y.
	47	Module M26 (X Y: FSIG) (Z1 Z: SIG) : SIG := X Z.
	48	Module M27 (X: FSIG) (Y: SIG) : SIG := X Y.
	49	Module M28 (X Y: FSIG) (Z1 Z: SIG) : SIG := X Z.

+12

-2

test-suite/success/Notations.v less more

16	16	(* Check that first non empty definition at an empty level can be of any
17	17	associativity *)
18	18
19		Definition marker := O.
	19	Module Type v1.
20	20	Notation "x +1" := (S x) (at level 8, left associativity).
21		Reset marker.
	21	End v1.
	22	Module Type v2.
22	23	Notation "x +1" := (S x) (at level 8, right associativity).
	24	End v2.
23	25
24	26	(* Check that empty levels (here 8 and 2 in pattern) are added in the
25	27	right order *)

85	87	Goal (2 ++++ 3) = 5.
86	88	reflexivity.
87	89	Abort.
	90
	91	(* Check correct failure handling when a non-constructor notation is
	92	used in cases pattern (bug #2724 in 8.3 and 8.4beta) *)
	93
	94	Notation "'FORALL' x .. y , P" := (forall x, .. (forall y, P) ..)
	95	(at level 200, x binder, y binder, right associativity) : type_scope.
	96
	97	Fail Check fun x => match x with S (FORALL x, _) => 0 end.

+37

-50

test-suite/success/RecTutorial.v less more

	0	Module Type LocalNat.
	1
0	2	Inductive nat : Set :=
1	3	\| O : nat
2	4	\| S : nat->nat.

4	6	Check O.
5	7	Check S.
6	8
7		Reset nat.
	9	End LocalNat.
	10
8	11	Print nat.
9	12
10	13

476	479
477	480
478	481
479		(*
480
481		Check (fun (P:Prop->Prop)(p: ex_Prop P) =>
	482
	483	Fail Check (fun (P:Prop->Prop)(p: ex_Prop P) =>
482	484	match p with exP_intro X HX => X end).
	485	(*
483	486	Error:
484	487	Incorrect elimination of "p" in the inductive type
485	488	"ex_Prop", the return type has sort "Type" while it should be

488	491	Elimination of an inductive object of sort "Prop"
489	492	is not allowed on a predicate in sort "Type"
490	493	because proofs can be eliminated only to build proofs
491
492		*)
493
494		(*
495		Check (match prop_inject with (prop_intro P p) => P end).
496
	494	*)
	495
	496
	497	Fail Check (match prop_inject with (prop_intro p) => p end).
	498	(*
497	499	Error:
498	500	Incorrect elimination of "prop_inject" in the inductive type
499	501	"prop", the return type has sort "Type" while it should be

502	504	Elimination of an inductive object of sort "Prop"
503	505	is not allowed on a predicate in sort "Type"
504	506	because proofs can be eliminated only to build proofs
505
506	507	*)
507	508	Print prop_inject.
508	509
509	510	(*
510	511	prop_inject =
511		prop_inject = prop_intro prop (fun H : prop => H)
	512	prop_inject = prop_intro prop
512	513	: prop
513	514	*)
514	515

519	520	Definition typ_inject: typ.
520	521	split.
521	522	exact typ.
522		(*
523		Defined.
524
	523	Fail Defined.
	524	(*
525	525	Error: Universe Inconsistency.
526	526	*)
527	527	Abort.
528		(*
529
530		Inductive aSet : Set :=
	528
	529	Fail Inductive aSet : Set :=
531	530	aSet_intro: Set -> aSet.
532
533
	531	(*
534	532	User error: Large non-propositional inductive types must be in Type
535
536	533	*)
537	534
538	535	Inductive ex_Set (P : Set -> Prop) : Type :=
539	536	exS_intro : forall X : Set, P X -> ex_Set P.
540	537
	538
	539	Module Type Version1.
541	540
542	541	Inductive comes_from_the_left (P Q:Prop): P \/ Q -> Prop :=
543	542	c1 : forall p, comes_from_the_left P Q (or_introl (A:=P) Q p).

552	551	*)
553	552	Abort.
554	553
555		Reset comes_from_the_left.
556
557		(*
558
559
560
561
562
563
564		Definition comes_from_the_left (P Q:Prop)(H:P \/ Q): Prop :=
	554	End Version1.
	555
	556	Fail Definition comes_from_the_left (P Q:Prop)(H:P \/ Q): Prop :=
565	557	match H with
566	558	\| or_introl p => True
567	559	\| or_intror q => False
568	560	end.
569	561
	562	(*
570	563	Error:
571	564	Incorrect elimination of "H" in the inductive type
572	565	"or", the return type has sort "Type" while it should be

575	568	Elimination of an inductive object of sort "Prop"
576	569	is not allowed on a predicate in sort "Type"
577	570	because proofs can be eliminated only to build proofs
578
579	571	*)
580	572
581	573	Definition comes_from_the_left_sumbool

736	728	\| S m => plus'' m (S p)
737	729	end.
738	730
	731	Module Type even_test_v1.
739	732
740	733	Fixpoint even_test (n:nat) : bool :=
741	734	match n

744	737	\| S (S p) => even_test p
745	738	end.
746	739
747
748		Reset even_test.
	740	End even_test_v1.
	741
	742	Module even_test_v2.
749	743
750	744	Fixpoint even_test (n:nat) : bool :=
751	745	match n

760	754	\| S p => even_test p
761	755	end.
762	756
763
764
765	757	Eval simpl in even_test.
766
767
768	758
769	759	Eval simpl in (fun x : nat => even_test x).
770	760

772	762	Eval simpl in (fun x : nat => even_test (plus 5 x)).
773	763
774	764	Eval simpl in (fun x : nat => even_test (plus x 5)).
	765
	766	End even_test_v2.
775	767
776	768
777	769	Section Principle_of_Induction.

865	857
866	858	Require Import Minus.
867	859
868		(*
869		Fixpoint div (x y:nat){struct x}: nat :=
	860	Fail Fixpoint div (x y:nat){struct x}: nat :=
870	861	if eq_nat_dec x 0
871	862	then 0
872	863	else if eq_nat_dec y 0
873	864	then x
874	865	else S (div (x-y) y).
875
	866	(*
876	867	Error:
877	868	Recursive definition of div is ill-formed.
878	869	In environment

970	961	intros A v;inversion v.
971	962	Abort.
972	963
973		(*
974		Lemma Vector.t0_is_vnil_aux : forall (A:Set)(n:nat)(v:Vector.t A n),
975		n= 0 -> v = Vnil A.
976
977		Toplevel input, characters 40281-40287
978		> Lemma Vector.t0_is_vnil_aux : forall (A:Set)(n:nat)(v:Vector.t A n), n= 0 -> v = Vnil A.
979		> ^^^^^^
	964
	965	Fail Lemma vector0_is_vnil_aux : forall (A:Set)(n:nat)(v:Vector.t A n),
	966	n= 0 -> v = Vector.nil A.
	967	(*
980	968	Error: In environment
981	969	A : Set
982	970	n : nat
983	971	v : Vector.t A n
984		e : n = 0
985		The term "Vnil A" has type "Vector.t A 0" while it is expected to have type
	972	The term "[]" has type "Vector.t A 0" while it is expected to have type
986	973	"Vector.t A n"
987	974	*)
988	975	Require Import JMeq.

+0

-7

~~test-suite/success/Reset.v~~ less more

0		(* Check Reset Section *)
1
2		Section A.
3		Definition B := Prop.
4		End A.
5
6		Reset A.

+16

-1

test-suite/success/apply.v less more

96	96
97	97	(* Check use of unification of bindings types in specialize *)
98	98
	99	Module Type Test.
99	100	Variable P : nat -> Prop.
100	101	Variable L : forall (l : nat), P l -> P l.
101	102	Goal P 0 -> True.
102	103	intros.
103	104	specialize L with (1:=H).
104	105	Abort.
105		Reset P.
	106	End Test.
106	107
107	108	(* Two examples that show that hnf_constr is used when unifying types
108	109	of bindings (a simplification of a script from Field_Theory) *)

414	415	Abort.
415	416
416	417	End A.
	418
	419	(* Check "with" clauses refer to names as they are printed *)
	420
	421	Definition hide p := forall n:nat, p = n.
	422
	423	Goal forall n, (forall n, n=0) -> hide n -> n=0.
	424	unfold hide.
	425	intros n H H'.
	426	(* H is displayed as (forall n, n=0) *)
	427	apply H with (n:=n).
	428	Undo.
	429	(* H' is displayed as (forall n0, n=n0) *)
	430	apply H' with (n0:=0).
	431	Qed.

+42

-0

test-suite/success/coercions.v less more

88	88	End A.
89	89	Import A.
90	90	Fail Check S true.
	91
	92	(* Tests after the inheritance condition constraint is relaxed *)
	93
	94	Inductive list (A : Type) : Type :=
	95	nil : list A \| cons : A -> list A -> list A.
	96	Inductive vect (A : Type) : nat -> Type :=
	97	vnil : vect A 0 \| vcons : forall n, A -> vect A n -> vect A (1+n).
	98	Fixpoint size A (l : list A) : nat := match l with nil => 0 \| cons _ tl => 1+size _ tl end.
	99
	100	Section test_non_unif_but_complete.
	101	Fixpoint l2v A (l : list A) : vect A (size A l) :=
	102	match l as l return vect A (size A l) with
	103	\| nil => vnil A
	104	\| cons x xs => vcons A (size A xs) x (l2v A xs)
	105	end.
	106
	107	Local Coercion l2v : list >-> vect.
	108	Check (fun l : list nat => (l : vect _ _)).
	109
	110	End test_non_unif_but_complete.
	111
	112	Section what_we_could_do.
	113	Variables T1 T2 : Type.
	114	Variable c12 : T1 -> T2.
	115
	116	Class coercion (A B : Type) : Type := cast : A -> B.
	117	Instance atom : coercion T1 T2 := c12.
	118	Instance pair A B C D (c1 : coercion A B) (c2 : coercion C D) : coercion (A * C) (B * D) :=
	119	fun x => (c1 (fst x), c2 (snd x)).
	120
	121	Fixpoint l2v2 {A B} {c : coercion A B} (l : list A) : (vect B (size A l)) :=
	122	match l as l return vect B (size A l) with
	123	\| nil => vnil B
	124	\| cons x xs => vcons _ _ (c x) (l2v2 xs) end.
	125
	126	Local Coercion l2v2 : list >-> vect.
	127
	128	(* This shows that there is still something to do to take full profit
	129	of coercions *)
	130	Fail Check (fun l : list (T1 * T1) => (l : vect _ _)).
	131	Check (fun l : list (T1 * T1) => (l2v2 l : vect _ _)).
	132	Section what_we_could_do.⏎

+31

-0

test-suite/success/dependentind.v less more

0	0	Require Import Coq.Program.Program Coq.Program.Equality.
	1
	2	Goal forall (H: forall n m : nat, n = m -> n = 0) x, x = tt.
	3	intros.
	4	dependent destruction x.
	5	reflexivity.
	6	Qed.
1	7
2	8	Variable A : Set.
3	9

83	89	intro. eapply app...
84	90	Defined.
85	91
	92	Lemma weakening_ctx : forall Γ Δ τ, Γ ; Δ ⊢ τ ->
	93	forall Δ', Γ ; Δ' ; Δ ⊢ τ.
	94	Proof with simpl in * ; eqns ; eauto with lambda.
	95	intros Γ Δ τ H.
	96
	97	dependent induction H.
	98
	99	destruct Δ as [\|Δ τ'']...
	100	induction Δ'...
	101
	102	destruct Δ as [\|Δ τ'']...
	103	induction Δ'...
	104
	105	destruct Δ as [\|Δ τ'']...
	106	apply abs.
	107	specialize (IHterm Γ (empty, τ))...
	108
	109	apply abs.
	110	specialize (IHterm Γ (Δ, τ'', τ))...
	111
	112	intro. eapply app...
	113	Defined.
	114
86	115	Lemma exchange : forall Γ Δ α β τ, term (Γ, α, β ; Δ) τ -> term (Γ, β, α ; Δ) τ.
87	116	Proof with simpl in * ; eqns ; eauto.
88	117	intros until 1.

103	132
104	133	eapply app...
105	134	Defined.
	135
	136
106	137
107	138	(** Example by Andrew Kenedy, uses simplification of the first component of dependent pairs. *)
108	139

+70

-0

test-suite/success/evars.v less more

308	308	Definition k7
309	309	(e:forall P : nat -> Prop, (exists n : nat, let n' := n in P n') -> nat)
310	310	(j : forall a, exists n : nat, n = a) a (b:=a) := e _ (j b).
	311
	312	(* An example that uses materialize_evar under binders *)
	313	(* Extracted from bigop.v in the mathematical components library *)
	314
	315	Section Bigop.
	316
	317	Variable bigop : forall R I: Type,
	318	R -> (R -> R -> R) -> list I -> (I->Prop) -> (I -> R) -> R.
	319
	320	Hypothesis eq_bigr :
	321	forall (R : Type) (idx : R) (op : R -> R -> R)
	322	(I : Type) (r : list I) (P : I -> Prop) (F1 F2 : I -> R),
	323	(forall i : I, P i -> F1 i = F2 i) ->
	324	bigop R I idx op r (fun i : I => P i) (fun i : I => F1 i) = idx.
	325
	326	Hypothesis big_tnth :
	327	forall (R : Type) (idx : R) (op : R -> R -> R)
	328	(I : Type) (r : list I) (P : I -> Prop) (F : I -> R),
	329	bigop R I idx op r (fun i : I => P i) (fun i : I => F i) = idx.
	330
	331	Hypothesis big_tnth_with_letin :
	332	forall (R : Type) (idx : R) (op : R -> R -> R)
	333	(I : Type) (r : list I) (P : I -> Prop) (F : I -> R),
	334	bigop R I idx op r (fun i : I => let i:=i in P i) (fun i : I => F i) = idx.
	335
	336	Variable R : Type.
	337	Variable idx : R.
	338	Variable op : R -> R -> R.
	339	Variable I : Type.
	340	Variable J : Type.
	341	Variable rI : list I.
	342	Variable rJ : list J.
	343	Variable xQ : J -> Prop.
	344	Variable P : I -> Prop.
	345	Variable Q : I -> J -> Prop.
	346	Variable F : I -> J -> R.
	347
	348	(* Check unification under binders *)
	349
	350	Check (eq_bigr _ _ _ _ _ _ _ _ (fun _ _ => big_tnth _ _ _ _ rI _ _))
	351	: (bigop R J idx op rJ
	352	(fun j : J => let k:=j in xQ k)
	353	(fun j : J => let k:=j in
	354	bigop R I idx
	355	op rI
	356	(fun i : I => P i /\ Q i k) (fun i : I => let k:=j in F i k))) = idx.
	357
	358	(* Check also with let-in *)
	359
	360	Check (eq_bigr _ _ _ _ _ _ _ _ (fun _ _ => big_tnth_with_letin _ _ _ _ rI _ _))
	361	: (bigop R J idx op rJ
	362	(fun j : J => let k:=j in xQ k)
	363	(fun j : J => let k:=j in
	364	bigop R I idx
	365	op rI
	366	(fun i : I => P i /\ Q i k) (fun i : I => let k:=j in F i k))) = idx.
	367
	368	End Bigop.
	369
	370	(* Check the use of (at least) an heuristic to solve problems of the form
	371	"?x[t] = ?y" where ?y occurs in t without easily knowing if ?y can
	372	eventually be erased in t *)
	373
	374	Section evar_evar_occur.
	375	Variable id : nat -> nat.
	376	Variable f : forall x, id x = 0 -> id x = 0 -> x = 1 /\ x = 2.
	377	Variable g : forall y, id y = 0 /\ id y = 0.
	378	(* Still evars in the resulting type, but constraints should be solved *)
	379	Check match g _ with conj a b => f _ a b end.
	380	End evar_evar_occur.

+5

-3

test-suite/success/hyps_inclusion.v less more

18	18	(* next tactic was failing wrt bug #1325 because type-checking the goal
19	19	detected a syntactically different type for the section variable H *)
20	20	case 0.
21		Reset A.
	21	Abort.
	22	End A.
22	23
23	24	(* Variant with polymorphic inductive types for bug #1325 *)
24	25
25		Section A.
	26	Section B.
26	27	Variable H:not True.
27	28	Inductive I (n:nat) : Type := C : H=H -> I n.
28	29	Goal I 0.
29	30	red in H.
30	31	case 0.
31		Reset A.
	32	Abort.
	33	End B.

+65

-5

test-suite/success/telescope_canonical.v less more

0	0	Structure Inner := mkI { is :> Type }.
1	1	Structure Outer := mkO { os :> Inner }.
2
3	2	Canonical Structure natInner := mkI nat.
4	3	Canonical Structure natOuter := mkO natInner.
	4	Definition hidden_nat := nat.
	5	Axiom P : forall S : Outer, is (os S) -> Prop.
	6	Lemma test1 (n : hidden_nat) : P _ n.
	7	Admitted.
5	8
6		Definition hidden_nat := nat.
	9	Structure Pnat := mkP { getp : nat }.
	10	Definition my_getp := getp.
	11	Axiom W : nat -> Prop.
7	12
8		Axiom P : forall S : Outer, is (os S) -> Prop.
	13	(* Fix *)
	14	Canonical Structure add1Pnat n := mkP (plus n 1).
	15	Definition test_fix n := (refl_equal _ : W (my_getp _) = W (n + 1)).
9	16
10		Lemma foo (n : hidden_nat) : P _ n.
11		Admitted.
	17	(* Case *)
	18	Definition pred n := match n with 0 => 0 \| S m => m end.
	19	Canonical Structure predSS n := mkP (pred n).
	20	Definition test_case x := (refl_equal _ : W (my_getp _) = W (pred x)).
	21	Fail Definition test_case' := (refl_equal _ : W (my_getp _) = W (pred 0)).
	22
	23	Canonical Structure letPnat' := mkP 0.
	24	Definition letin := (let n := 0 in n).
	25	Definition test4 := (refl_equal _ : W (getp _) = W letin).
	26	Definition test41 := (refl_equal _ : W (my_getp _) = W letin).
	27	Definition letin2 (x : nat) := (let n := x in n).
	28	Canonical Structure letPnat'' x := mkP (letin2 x).
	29	Definition test42 x := (refl_equal _ : W (my_getp _) = W (letin2 x)).
	30	Fail Definition test42' x := (refl_equal _ : W (my_getp _) = W x).
	31
	32	Structure Morph := mkM { f :> nat -> nat }.
	33	Definition my_f := f.
	34	Axiom Q : (nat -> nat) -> Prop.
	35
	36	(* Lambda *)
	37	Canonical Structure addMorh x := mkM (plus x).
	38	Definition test_lam x := (refl_equal _ : Q (my_f _) = Q (plus x)).
	39	Definition test_lam' := (refl_equal _ : Q (my_f _) = Q (plus 0)).
	40
	41	(* Simple tests to justify Sort and Prod as "named".
	42	They are already normal, so they cannot loose their names,
	43	but still... *)
	44	Structure Sot := mkS { T : Type }.
	45	Axiom R : Type -> Prop.
	46	Canonical Structure tsot := mkS (Type).
	47	Definition test_sort := (refl_equal _ : R (T _) = R Type).
	48	Canonical Structure tsot2 := mkS (nat -> nat).
	49	Definition test_prod := (refl_equal _ : R (T _) = R (nat -> nat)).
	50
	51	(* Var *)
	52	Section Foo.
	53	Variable v : nat.
	54	Definition my_v := v.
	55	Canonical Structure vP := mkP my_v.
	56	Definition test_var := (refl_equal _ : W (getp _) = W my_v).
	57	Canonical Structure vP' := mkP v.
	58	Definition test_var' := (refl_equal _ : W (my_getp _) = W my_v).
	59	End Foo.
	60
	61	(* Rel *)
	62	Definition test_rel v := (refl_equal _ : W (my_getp _) = W (my_v v)).
	63	Goal True.
	64	pose (x := test_rel 2).
	65	match goal with x := _ : W (my_getp (vP 2)) = _ \|- _ => idtac end.
	66	apply I.
	67	Qed.
	68
	69
	70
	71

+13

-13

theories/Arith/Div2.v less more

10	10	Require Import Compare_dec.
11	11	Require Import Even.
12	12
13		Open Local Scope nat_scope.
	13	Local Open Scope nat_scope.
14	14
15	15	Implicit Type n : nat.
16	16

68	68	(* S n *) inversion_clear H. apply even_div2 in H0 as <-. trivial.
69	69	Qed.
70	70
71		Lemma div2_even : forall n, div2 n = div2 (S n) -> even n
72		with div2_odd : forall n, S (div2 n) = div2 (S n) -> odd n.
	71	Lemma div2_even n : div2 n = div2 (S n) -> even n
	72	with div2_odd n : S (div2 n) = div2 (S n) -> odd n.
73	73	Proof.
74		destruct n; intro H.
75		(* 0 *) constructor.
76		(* S n *) constructor. apply div2_odd. rewrite H. trivial.
77		destruct n; intro H.
78		(* 0 *) discriminate.
79		(* S n *) constructor. apply div2_even. injection H as <-. trivial.
	74	{ destruct n; intro H.
	75	- constructor.
	76	- constructor. apply div2_odd. rewrite H. trivial. }
	77	{ destruct n; intro H.
	78	- discriminate.
	79	- constructor. apply div2_even. injection H as <-. trivial. }
80	80	Qed.
81	81
82	82	Hint Resolve even_div2 div2_even odd_div2 div2_odd: arith.
83	83
84		Lemma even_odd_div2 :
85		forall n,
86		(even n <-> div2 n = div2 (S n)) /\ (odd n <-> S (div2 n) = div2 (S n)).
	84	Lemma even_odd_div2 n :
	85	(even n <-> div2 n = div2 (S n)) /\
	86	(odd n <-> S (div2 n) = div2 (S n)).
87	87	Proof.
88		auto decomp using div2_odd, div2_even, odd_div2, even_div2.
	88	split; split; auto using div2_odd, div2_even, odd_div2, even_div2.
89	89	Qed.
90	90
91	91

+2

-2

theories/Init/Logic.v less more

220	220
221	221	Notation "'exists' x .. y , p" := (ex (fun x => .. (ex (fun y => p)) ..))
222	222	(at level 200, x binder, right associativity,
223		format "'[' 'exists' '/ ' x .. y , '/ ' p ']'")
	223	format "'[' 'exists' '/ ' x .. y , '/ ' p ']'")
224	224	: type_scope.
225	225
226	226	Notation "'exists2' x , p & q" := (ex2 (fun x => p) (fun x => q))

403	403	Notation "'exists' ! x .. y , p" :=
404	404	(ex (unique (fun x => .. (ex (unique (fun y => p))) ..)))
405	405	(at level 200, x binder, right associativity,
406		format "'[' 'exists' ! '/ ' x .. y , '/ ' p ']'")
	406	format "'[' 'exists' ! '/ ' x .. y , '/ ' p ']'")
407	407	: type_scope.
408	408
409	409	Lemma unique_existence : forall (A:Type) (P:A->Prop),

+0

-1

theories/Init/Prelude.v less more

18	18	Declare ML Module "decl_mode_plugin".
19	19	Declare ML Module "cc_plugin".
20	20	Declare ML Module "ground_plugin".
21		Declare ML Module "dp_plugin".
22	21	Declare ML Module "recdef_plugin".
23	22	Declare ML Module "subtac_plugin".
24	23	Declare ML Module "xml_plugin".

+1

-1

theories/Init/Specif.v less more

59	59
60	60	(** Projections of [sig]
61	61
62		An element [y] of a subset [{x:A & (P x)}] is the pair of an [a]
	62	An element [y] of a subset [{x:A \| (P x)}] is the pair of an [a]
63	63	of type [A] and of a proof [h] that [a] satisfies [P]. Then
64	64	[(proj1_sig y)] is the witness [a] and [(proj2_sig y)] is the
65	65	proof of [(P a)] *)

+1

-1

theories/Lists/intro.tex less more

13	13	sets, implemented as lists.
14	14
15	15	\item {\tt Streams.v} defines the type of infinite lists (streams). It is a
16		coinductive type. Basic facts are stated and proved. The streams are
	16	co-inductive type. Basic facts are stated and proved. The streams are
17	17	also polymorphic.
18	18
19	19	\end{itemize}

+8

-8

theories/Logic/ChoiceFacts.v less more

384	384	Lemma subset_types_imp_guarded_rel_choice_iff_rel_choice :
385	385	ProofIrrelevance -> (GuardedRelationalChoice <-> RelationalChoice).
386	386	Proof.
387		auto decomp using
	387	intuition auto using
388	388	guarded_rel_choice_imp_rel_choice,
389	389	rel_choice_and_proof_irrel_imp_guarded_rel_choice.
390	390	Qed.

438	438	FunctionalChoiceOnInhabitedSet /\ IndependenceOfGeneralPremises
439	439	<-> GuardedFunctionalChoice.
440	440	Proof.
441		auto decomp using
	441	intuition auto using
442	442	guarded_fun_choice_imp_indep_of_general_premises,
443	443	guarded_fun_choice_imp_fun_choice,
444	444	fun_choice_and_indep_general_prem_imp_guarded_fun_choice.

479	479	FunctionalChoiceOnInhabitedSet /\ SmallDrinker'sParadox
480	480	<-> OmniscientFunctionalChoice.
481	481	Proof.
482		auto decomp using
	482	intuition auto using
483	483	omniscient_fun_choice_imp_small_drinker,
484	484	omniscient_fun_choice_imp_fun_choice,
485	485	fun_choice_and_small_drinker_imp_omniscient_fun_choice.

546	546	(EpsilonStatement ->
547	547	SmallDrinker'sParadox * ConstructiveIndefiniteDescription).
548	548	Proof.
549		auto decomp using
	549	intuition auto using
550	550	epsilon_imp_constructive_indefinite_description,
551	551	constructive_indefinite_description_and_small_drinker_imp_epsilon,
552	552	epsilon_imp_small_drinker.

688	688	Corollary dep_iff_non_dep_functional_rel_reification :
689	689	FunctionalRelReification <-> DependentFunctionalRelReification.
690	690	Proof.
691		auto decomp using
	691	intuition auto using
692	692	non_dep_dep_functional_rel_reification,
693	693	dep_non_dep_functional_rel_reification.
694	694	Qed.

813	813	(forall P:Prop, P \/ ~ P) ->
814	814	forall C:Prop, ((forall P:Prop, {P} + {~ P}) -> C) -> C.
815	815	Proof.
816		intros FunReify EM C; auto decomp using
817		constructive_definite_descr_excluded_middle,
818		(relative_non_contradiction_of_definite_descr (C:=C)).
	816	intros FunReify EM C H.
	817	apply relative_non_contradiction_of_definite_descr; trivial.
	818	auto using constructive_definite_descr_excluded_middle.
819	819	Qed.
820	820
821	821	(**********************************************************************)

+215

-1226

theories/MSets/MSetAVL.v less more

12	12	It follows the implementation from Ocaml's standard library,
13	13
14	14	All operations given here expect and produce well-balanced trees
15		(in the ocaml sense: heigths of subtrees shouldn't differ by more
	15	(in the ocaml sense: heights of subtrees shouldn't differ by more
16	16	than 2), and hence has low complexities (e.g. add is logarithmic
17	17	in the size of the set). But proving these balancing preservations
18	18	is in fact not necessary for ensuring correct operational behavior

30	30	code after extraction.
31	31	*)
32	32
33		Require Import MSetInterface ZArith Int.
	33	Require Import MSetInterface MSetGenTree ZArith Int.
34	34
35	35	Set Implicit Arguments.
36	36	Unset Strict Implicit.
37		(* for nicer extraction, we create only logical inductive principles *)
	37	(* for nicer extraction, we create inductive principles
	38	only when needed *)
38	39	Local Unset Elimination Schemes.
39	40	Local Unset Case Analysis Schemes.
40	41
41	42	(** * Ops : the pure functions *)
42	43
43		Module Ops (Import I:Int)(X:OrderedType) <: WOps X.
	44	Module Ops (Import I:Int)(X:OrderedType) <: MSetInterface.Ops X.
44	45	Local Open Scope Int_scope.
45		Local Open Scope lazy_bool_scope.
46
47		Definition elt := X.t.
48		Hint Transparent elt.
49
50		( Trees
51
52		The fourth field of [Node] is the height of the tree *)
53
54		Inductive tree :=
55		\| Leaf : tree
56		\| Node : tree -> X.t -> tree -> int -> tree.
	46
	47	( Generic trees instantiated with integer height *)
	48
	49	(** We reuse a generic definition of trees where the information
	50	parameter is a [Int.t]. Functions like mem or fold are also
	51	provided by this generic functor. *)
	52
	53	Include MSetGenTree.Ops X I.
57	54
58	55	Definition t := tree.
59	56
60		( Basic functions on trees: height and cardinal *)
	57	( Height of trees *)
61	58
62	59	Definition height (s : t) : int :=
63	60	match s with
64	61	\| Leaf => 0
65		\| Node _ _ _ h => h
	62	\| Node h _ _ _ => h
66	63	end.
67	64
68		Fixpoint cardinal (s : t) : nat :=
69		match s with
70		\| Leaf => 0%nat
71		\| Node l _ r _ => S (cardinal l + cardinal r)
72		end.
73
74		( Empty Set *)
75
76		Definition empty := Leaf.
77
78		( Emptyness test *)
79
80		Definition is_empty s :=
81		match s with Leaf => true \| _ => false end.
82
83		( Membership *)
84
85		(** The [mem] function is deciding membership. It exploits the
86		binary search tree invariant to achieve logarithmic complexity. *)
87
88		Fixpoint mem x s :=
89		match s with
90		\| Leaf => false
91		\| Node l y r _ => match X.compare x y with
92		\| Lt => mem x l
93		\| Eq => true
94		\| Gt => mem x r
95		end
96		end.
97
98	65	( Singleton set *)
99	66
100		Definition singleton x := Node Leaf x Leaf 1.
	67	Definition singleton x := Node 1 Leaf x Leaf.
101	68
102	69	( Helper functions *)
103	70

105	72	to be balanced and [\|height l - height r\| <= 2]. *)
106	73
107	74	Definition create l x r :=
108		Node l x r (max (height l) (height r) + 1).
	75	Node (max (height l) (height r) + 1) l x r.
109	76
110	77	(** [bal l x r] acts as [create], but performs one step of
111	78	rebalancing if necessary, i.e. assumes [\|height l - height r\| <= 3]. *)

118	85	if gt_le_dec hl (hr+2) then
119	86	match l with
120	87	\| Leaf => assert_false l x r
121		\| Node ll lx lr _ =>
	88	\| Node _ ll lx lr =>
122	89	if ge_lt_dec (height ll) (height lr) then
123	90	create ll lx (create lr x r)
124	91	else
125	92	match lr with
126	93	\| Leaf => assert_false l x r
127		\| Node lrl lrx lrr _ =>
	94	\| Node _ lrl lrx lrr =>
128	95	create (create ll lx lrl) lrx (create lrr x r)
129	96	end
130	97	end

132	99	if gt_le_dec hr (hl+2) then
133	100	match r with
134	101	\| Leaf => assert_false l x r
135		\| Node rl rx rr _ =>
	102	\| Node _ rl rx rr =>
136	103	if ge_lt_dec (height rr) (height rl) then
137	104	create (create l x rl) rx rr
138	105	else
139	106	match rl with
140	107	\| Leaf => assert_false l x r
141		\| Node rll rlx rlr _ =>
	108	\| Node _ rll rlx rlr =>
142	109	create (create l x rll) rlx (create rlr rx rr)
143	110	end
144	111	end

148	115	( Insertion *)
149	116
150	117	Fixpoint add x s := match s with
151		\| Leaf => Node Leaf x Leaf 1
152		\| Node l y r h =>
	118	\| Leaf => Node 1 Leaf x Leaf
	119	\| Node h l y r =>
153	120	match X.compare x y with
154	121	\| Lt => bal (add x l) y r
155		\| Eq => Node l y r h
	122	\| Eq => Node h l y r
156	123	\| Gt => bal l y (add x r)
157	124	end
158	125	end.

166	133	Fixpoint join l : elt -> t -> t :=
167	134	match l with
168	135	\| Leaf => add
169		\| Node ll lx lr lh => fun x =>
	136	\| Node lh ll lx lr => fun x =>
170	137	fix join_aux (r:t) : t := match r with
171		\| Leaf => add x l
172		\| Node rl rx rr rh =>
	138	\| Leaf => add x l
	139	\| Node rh rl rx rr =>
173	140	if gt_le_dec lh (rh+2) then bal ll lx (join lr x r)
174	141	else if gt_le_dec rh (lh+2) then bal (join_aux rl) rx rr
175	142	else create l x r

179	146	( Extraction of minimum element
180	147
181	148	Morally, [remove_min] is to be applied to a non-empty tree
182		[t = Node l x r h]. Since we can't deal here with [assert false]
	149	[t = Node h l x r]. Since we can't deal here with [assert false]
183	150	for [t=Leaf], we pre-unpack [t] (and forget about [h]).
184	151	*)
185	152
186	153	Fixpoint remove_min l x r : t*elt :=
187	154	match l with
188	155	\| Leaf => (r,x)
189		\| Node ll lx lr lh =>
	156	\| Node lh ll lx lr =>
190	157	let (l',m) := remove_min ll lx lr in (bal l' x r, m)
191	158	end.
192	159

200	167	Definition merge s1 s2 := match s1,s2 with
201	168	\| Leaf, _ => s2
202	169	\| _, Leaf => s1
203		\| _, Node l2 x2 r2 h2 =>
	170	\| _, Node _ l2 x2 r2 =>
204	171	let (s2',m) := remove_min l2 x2 r2 in bal s1 m s2'
205	172	end.
206	173

208	175
209	176	Fixpoint remove x s := match s with
210	177	\| Leaf => Leaf
211		\| Node l y r h =>
	178	\| Node _ l y r =>
212	179	match X.compare x y with
213	180	\| Lt => bal (remove x l) y r
214	181	\| Eq => merge l r
215		\| Gt => bal l y (remove x r)
	182	\| Gt => bal l y (remove x r)
216	183	end
217	184	end.
218
219		( Minimum element *)
220
221		Fixpoint min_elt s := match s with
222		\| Leaf => None
223		\| Node Leaf y _ _ => Some y
224		\| Node l _ _ _ => min_elt l
225		end.
226
227		( Maximum element *)
228
229		Fixpoint max_elt s := match s with
230		\| Leaf => None
231		\| Node _ y Leaf _ => Some y
232		\| Node _ _ r _ => max_elt r
233		end.
234
235		( Any element *)
236
237		Definition choose := min_elt.
238	185
239	186	( Concatenation
240	187

245	192	match s1, s2 with
246	193	\| Leaf, _ => s2
247	194	\| _, Leaf => s1
248		\| _, Node l2 x2 r2 _ =>
	195	\| _, Node _ l2 x2 r2 =>
249	196	let (s2',m) := remove_min l2 x2 r2 in
250	197	join s1 m s2'
251	198	end.

263	210
264	211	Fixpoint split x s : triple := match s with
265	212	\| Leaf => << Leaf, false, Leaf >>
266		\| Node l y r h =>
	213	\| Node _ l y r =>
267	214	match X.compare x y with
268	215	\| Lt => let (ll,b,rl) := split x l in << ll, b, join rl y r >>
269	216	\| Eq => << l, true, r >>

276	223	Fixpoint inter s1 s2 := match s1, s2 with
277	224	\| Leaf, _ => Leaf
278	225	\| _, Leaf => Leaf
279		\| Node l1 x1 r1 h1, _ =>
	226	\| Node _ l1 x1 r1, _ =>
280	227	let (l2',pres,r2') := split x1 s2 in
281	228	if pres then join (inter l1 l2') x1 (inter r1 r2')
282	229	else concat (inter l1 l2') (inter r1 r2')

287	234	Fixpoint diff s1 s2 := match s1, s2 with
288	235	\| Leaf, _ => Leaf
289	236	\| _, Leaf => s1
290		\| Node l1 x1 r1 h1, _ =>
	237	\| Node _ l1 x1 r1, _ =>
291	238	let (l2',pres,r2') := split x1 s2 in
292	239	if pres then concat (diff l1 l2') (diff r1 r2')
293	240	else join (diff l1 l2') x1 (diff r1 r2')

310	257	match s1, s2 with
311	258	\| Leaf, _ => s2
312	259	\| _, Leaf => s1
313		\| Node l1 x1 r1 h1, _ =>
	260	\| Node _ l1 x1 r1, _ =>
314	261	let (l2',_,r2') := split x1 s2 in
315	262	join (union l1 l2') x1 (union r1 r2')
316	263	end.
317	264
318		( Elements *)
319
320		(** [elements_tree_aux acc t] catenates the elements of [t] in infix
321		order to the list [acc] *)
322
323		Fixpoint elements_aux (acc : list X.t) (s : t) : list X.t :=
	265	( Filter *)
	266
	267	Fixpoint filter (f:elt->bool) s := match s with
	268	\| Leaf => Leaf
	269	\| Node _ l x r =>
	270	let l' := filter f l in
	271	let r' := filter f r in
	272	if f x then join l' x r' else concat l' r'
	273	end.
	274
	275	( Partition *)
	276
	277	Fixpoint partition (f:elt->bool)(s : t) : t*t :=
324	278	match s with
325		\| Leaf => acc
326		\| Node l x r _ => elements_aux (x :: elements_aux acc r) l
	279	\| Leaf => (Leaf, Leaf)
	280	\| Node _ l x r =>
	281	let (l1,l2) := partition f l in
	282	let (r1,r2) := partition f r in
	283	if f x then (join l1 x r1, concat l2 r2)
	284	else (concat l1 r1, join l2 x r2)
327	285	end.
328	286
329		(** then [elements] is an instanciation with an empty [acc] *)
330
331		Definition elements := elements_aux nil.
332
333		( Filter *)
334
335		Fixpoint filter_acc (f:elt->bool) acc s := match s with
336		\| Leaf => acc
337		\| Node l x r h =>
338		filter_acc f (filter_acc f (if f x then add x acc else acc) l) r
339		end.
340
341		Definition filter f := filter_acc f Leaf.
342
343
344		( Partition *)
345
346		Fixpoint partition_acc (f:elt->bool)(acc : tt)(s : t) : tt :=
347		match s with
348		\| Leaf => acc
349		\| Node l x r _ =>
350		let (acct,accf) := acc in
351		partition_acc f
352		(partition_acc f
353		(if f x then (add x acct, accf) else (acct, add x accf)) l) r
354		end.
355
356		Definition partition f := partition_acc f (Leaf,Leaf).
357
358		( [for_all] and [exists] *)
359
360		Fixpoint for_all (f:elt->bool) s := match s with
361		\| Leaf => true
362		\| Node l x r _ => f x &&& for_all f l &&& for_all f r
363		end.
364
365		Fixpoint exists_ (f:elt->bool) s := match s with
366		\| Leaf => false
367		\| Node l x r _ => f x \|\|\| exists_ f l \|\|\| exists_ f r
368		end.
369
370		( Fold *)
371
372		Fixpoint fold (A : Type) (f : elt -> A -> A)(s : t) : A -> A :=
373		fun a => match s with
374		\| Leaf => a
375		\| Node l x r _ => fold f r (f x (fold f l a))
376		end.
377		Arguments fold [A] f s _.
378
379
380		( Subset *)
381
382		(** In ocaml, recursive calls are made on "half-trees" such as
383		(Node l1 x1 Leaf _) and (Node Leaf x1 r1 _). Instead of these
384		non-structural calls, we propose here two specialized functions for
385		these situations. This version should be almost as efficient as
386		the one of ocaml (closures as arguments may slow things a bit),
387		it is simply less compact. The exact ocaml version has also been
388		formalized (thanks to Function+measure), see [ocaml_subset] in
389		[MSetFullAVL].
390		*)
391
392		Fixpoint subsetl (subset_l1:t->bool) x1 s2 : bool :=
393		match s2 with
394		\| Leaf => false
395		\| Node l2 x2 r2 h2 =>
396		match X.compare x1 x2 with
397		\| Eq => subset_l1 l2
398		\| Lt => subsetl subset_l1 x1 l2
399		\| Gt => mem x1 r2 &&& subset_l1 s2
400		end
401		end.
402
403		Fixpoint subsetr (subset_r1:t->bool) x1 s2 : bool :=
404		match s2 with
405		\| Leaf => false
406		\| Node l2 x2 r2 h2 =>
407		match X.compare x1 x2 with
408		\| Eq => subset_r1 r2
409		\| Lt => mem x1 l2 &&& subset_r1 s2
410		\| Gt => subsetr subset_r1 x1 r2
411		end
412		end.
413
414		Fixpoint subset s1 s2 : bool := match s1, s2 with
415		\| Leaf, _ => true
416		\| Node _ _ _ _, Leaf => false
417		\| Node l1 x1 r1 h1, Node l2 x2 r2 h2 =>
418		match X.compare x1 x2 with
419		\| Eq => subset l1 l2 &&& subset r1 r2
420		\| Lt => subsetl (subset l1) x1 l2 &&& subset r1 s2
421		\| Gt => subsetr (subset r1) x1 r2 &&& subset l1 s2
422		end
423		end.
424
425		( A new comparison algorithm suggested by Xavier Leroy
426
427		Transformation in C.P.S. suggested by Benjamin Grégoire.
428		The original ocaml code (with non-structural recursive calls)
429		has also been formalized (thanks to Function+measure), see
430		[ocaml_compare] in [MSetFullAVL]. The following code with
431		continuations computes dramatically faster in Coq, and
432		should be almost as efficient after extraction.
433		*)
434
435		(** Enumeration of the elements of a tree *)
436
437		Inductive enumeration :=
438		\| End : enumeration
439		\| More : elt -> t -> enumeration -> enumeration.
440
441
442		(** [cons t e] adds the elements of tree [t] on the head of
443		enumeration [e]. *)
444
445		Fixpoint cons s e : enumeration :=
446		match s with
447		\| Leaf => e
448		\| Node l x r h => cons l (More x r e)
449		end.
450
451		(** One step of comparison of elements *)
452
453		Definition compare_more x1 (cont:enumeration->comparison) e2 :=
454		match e2 with
455		\| End => Gt
456		\| More x2 r2 e2 =>
457		match X.compare x1 x2 with
458		\| Eq => cont (cons r2 e2)
459		\| Lt => Lt
460		\| Gt => Gt
461		end
462		end.
463
464		(** Comparison of left tree, middle element, then right tree *)
465
466		Fixpoint compare_cont s1 (cont:enumeration->comparison) e2 :=
467		match s1 with
468		\| Leaf => cont e2
469		\| Node l1 x1 r1 _ =>
470		compare_cont l1 (compare_more x1 (compare_cont r1 cont)) e2
471		end.
472
473		(** Initial continuation *)
474
475		Definition compare_end e2 :=
476		match e2 with End => Eq \| _ => Lt end.
477
478		(** The complete comparison *)
479
480		Definition compare s1 s2 := compare_cont s1 compare_end (cons s2 End).
481
482		( Equality test *)
483
484		Definition equal s1 s2 : bool :=
485		match compare s1 s2 with
486		\| Eq => true
487		\| _ => false
488		end.
489
490	287	End Ops.
491
492	288
493	289
494	290	(** * MakeRaw

499	295	Module MakeRaw (Import I:Int)(X:OrderedType) <: RawSets X.
500	296	Include Ops I X.
501	297
502		(** * Invariants *)
503
504		( Occurrence in a tree *)
505
506		Inductive InT (x : elt) : tree -> Prop :=
507		\| IsRoot : forall l r h y, X.eq x y -> InT x (Node l y r h)
508		\| InLeft : forall l r h y, InT x l -> InT x (Node l y r h)
509		\| InRight : forall l r h y, InT x r -> InT x (Node l y r h).
510
511		Definition In := InT.
512
513		( Some shortcuts *)
514
515		Definition Equal s s' := forall a : elt, InT a s <-> InT a s'.
516		Definition Subset s s' := forall a : elt, InT a s -> InT a s'.
517		Definition Empty s := forall a : elt, ~ InT a s.
518		Definition For_all (P : elt -> Prop) s := forall x, InT x s -> P x.
519		Definition Exists (P : elt -> Prop) s := exists x, InT x s /\ P x.
520
521		( Binary search trees *)
522
523		(** [lt_tree x s]: all elements in [s] are smaller than [x]
524		(resp. greater for [gt_tree]) *)
525
526		Definition lt_tree x s := forall y, InT y s -> X.lt y x.
527		Definition gt_tree x s := forall y, InT y s -> X.lt x y.
528
529		(** [bst t] : [t] is a binary search tree *)
530
531		Inductive bst : tree -> Prop :=
532		\| BSLeaf : bst Leaf
533		\| BSNode : forall x l r h, bst l -> bst r ->
534		lt_tree x l -> gt_tree x r -> bst (Node l x r h).
535
536		(** [bst] is the (decidable) invariant our trees will have to satisfy. *)
537
538		Definition IsOk := bst.
539
540		Class Ok (s:t) : Prop := ok : bst s.
541
542		Instance bst_Ok s (Hs : bst s) : Ok s := { ok := Hs }.
543
544		Fixpoint ltb_tree x s :=
545		match s with
546		\| Leaf => true
547		\| Node l y r _ =>
548		match X.compare x y with
549		\| Gt => ltb_tree x l && ltb_tree x r
550		\| _ => false
551		end
	298	(** Generic definition of binary-search-trees and proofs of
	299	specifications for generic functions such as mem or fold. *)
	300
	301	Include MSetGenTree.Props X I.
	302
	303	(** Automation and dedicated tactics *)
	304
	305	Local Hint Immediate MX.eq_sym.
	306	Local Hint Unfold In lt_tree gt_tree Ok.
	307	Local Hint Constructors InT bst.
	308	Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans @ok.
	309	Local Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node.
	310	Local Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans.
	311	Local Hint Resolve elements_spec2.
	312
	313	(* Sometimes functional induction will expose too much of
	314	a tree structure. The following tactic allows to factor back
	315	a Node whose internal parts occurs nowhere else. *)
	316
	317	(* TODO: why Ltac instead of Tactic Notation don't work ? why clear ? *)
	318
	319	Tactic Notation "factornode" ident(s) :=
	320	try clear s;
	321	match goal with
	322	\| \|- context [Node ?l ?x ?r ?h] =>
	323	set (s:=Node l x r h) in *; clearbody s; clear l x r h
	324	\| _ : context [Node ?l ?x ?r ?h] \|- _ =>
	325	set (s:=Node l x r h) in *; clearbody s; clear l x r h
552	326	end.
553	327
554		Fixpoint gtb_tree x s :=
555		match s with
556		\| Leaf => true
557		\| Node l y r _ =>
558		match X.compare x y with
559		\| Lt => gtb_tree x l && gtb_tree x r
560		\| _ => false
561		end
562		end.
563
564		Fixpoint isok s :=
565		match s with
566		\| Leaf => true
567		\| Node l x r _ => isok l && isok r && ltb_tree x l && gtb_tree x r
568		end.
569
570
571		(** * Correctness proofs *)
572
573		Module Import MX := OrderedTypeFacts X.
574
575		(** * Automation and dedicated tactics *)
576
577		Scheme tree_ind := Induction for tree Sort Prop.
578
579		Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans @ok.
580		Local Hint Immediate MX.eq_sym.
581		Local Hint Unfold In lt_tree gt_tree.
582		Local Hint Constructors InT bst.
583		Local Hint Unfold Ok.
584
585		Tactic Notation "factornode" ident(l) ident(x) ident(r) ident(h)
586		"as" ident(s) :=
587		set (s:=Node l x r h) in *; clearbody s; clear l x r h.
588
589		(** Automatic treatment of [Ok] hypothesis *)
590
591		Ltac inv_ok := match goal with
592		\| H:Ok (Node _ _ _ _) \|- _ => inversion_clear H; inv_ok
593		\| H:Ok Leaf \|- _ => clear H; inv_ok
594		\| H:bst ?x \|- _ => change (Ok x) in H; inv_ok
595		\| _ => idtac
596		end.
597
598		(** A tactic to repeat [inversion_clear] on all hyps of the
599		form [(f (Node _ _ _ _))] *)
600
601		Ltac is_tree_constr c :=
602		match c with
603		\| Leaf => idtac
604		\| Node _ _ _ _ => idtac
605		\| _ => fail
606		end.
607
608		Ltac invtree f :=
609		match goal with
610		\| H:f ?s \|- _ => is_tree_constr s; inversion_clear H; invtree f
611		\| H:f _ ?s \|- _ => is_tree_constr s; inversion_clear H; invtree f
612		\| H:f _ _ ?s \|- _ => is_tree_constr s; inversion_clear H; invtree f
613		\| _ => idtac
614		end.
615
616		Ltac inv := inv_ok; invtree InT.
617
618		Ltac intuition_in := repeat progress (intuition; inv).
619
620		(** Helper tactic concerning order of elements. *)
621
622		Ltac order := match goal with
623		\| U: lt_tree _ ?s, V: InT _ ?s \|- _ => generalize (U _ V); clear U; order
624		\| U: gt_tree _ ?s, V: InT _ ?s \|- _ => generalize (U _ V); clear U; order
625		\| _ => MX.order
626		end.
627
628
629		(** [isok] is indeed a decision procedure for [Ok] *)
630
631		Lemma ltb_tree_iff : forall x s, lt_tree x s <-> ltb_tree x s = true.
632		Proof.
633		induction s as [\|l IHl y r IHr h]; simpl.
634		unfold lt_tree; intuition_in.
635		elim_compare x y.
636		split; intros; try discriminate. assert (X.lt y x) by auto. order.
637		split; intros; try discriminate. assert (X.lt y x) by auto. order.
638		rewrite !andb_true_iff, <-IHl, <-IHr.
639		unfold lt_tree; intuition_in; order.
640		Qed.
641
642		Lemma gtb_tree_iff : forall x s, gt_tree x s <-> gtb_tree x s = true.
643		Proof.
644		induction s as [\|l IHl y r IHr h]; simpl.
645		unfold gt_tree; intuition_in.
646		elim_compare x y.
647		split; intros; try discriminate. assert (X.lt x y) by auto. order.
648		rewrite !andb_true_iff, <-IHl, <-IHr.
649		unfold gt_tree; intuition_in; order.
650		split; intros; try discriminate. assert (X.lt x y) by auto. order.
651		Qed.
652
653		Lemma isok_iff : forall s, Ok s <-> isok s = true.
654		Proof.
655		induction s as [\|l IHl y r IHr h]; simpl.
656		intuition_in.
657		rewrite !andb_true_iff, <- IHl, <-IHr, <- ltb_tree_iff, <- gtb_tree_iff.
658		intuition_in.
659		Qed.
660
661		Instance isok_Ok s : isok s = true -> Ok s \| 10.
662		Proof. intros; apply <- isok_iff; auto. Qed.
663
664
665		(** * Basic results about [In], [lt_tree], [gt_tree], [height] *)
666
667		(** [In] is compatible with [X.eq] *)
668
669		Lemma In_1 :
670		forall s x y, X.eq x y -> InT x s -> InT y s.
671		Proof.
672		induction s; simpl; intuition_in; eauto.
673		Qed.
674		Local Hint Immediate In_1.
675
676		Instance In_compat : Proper (X.eq==>eq==>iff) InT.
677		Proof.
678		apply proper_sym_impl_iff_2; auto with *.
679		repeat red; intros; subst. apply In_1 with x; auto.
680		Qed.
681
682		Lemma In_node_iff :
683		forall l x r h y,
684		InT y (Node l x r h) <-> InT y l \/ X.eq y x \/ InT y r.
685		Proof.
686		intuition_in.
687		Qed.
688
689		(** Results about [lt_tree] and [gt_tree] *)
690
691		Lemma lt_leaf : forall x : elt, lt_tree x Leaf.
692		Proof.
693		red; inversion 1.
694		Qed.
695
696		Lemma gt_leaf : forall x : elt, gt_tree x Leaf.
697		Proof.
698		red; inversion 1.
699		Qed.
700
701		Lemma lt_tree_node :
702		forall (x y : elt) (l r : tree) (h : int),
703		lt_tree x l -> lt_tree x r -> X.lt y x -> lt_tree x (Node l y r h).
704		Proof.
705		unfold lt_tree; intuition_in; order.
706		Qed.
707
708		Lemma gt_tree_node :
709		forall (x y : elt) (l r : tree) (h : int),
710		gt_tree x l -> gt_tree x r -> X.lt x y -> gt_tree x (Node l y r h).
711		Proof.
712		unfold gt_tree; intuition_in; order.
713		Qed.
714
715		Local Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node.
716
717		Lemma lt_tree_not_in :
718		forall (x : elt) (t : tree), lt_tree x t -> ~ InT x t.
719		Proof.
720		intros; intro; order.
721		Qed.
722
723		Lemma lt_tree_trans :
724		forall x y, X.lt x y -> forall t, lt_tree x t -> lt_tree y t.
725		Proof.
726		eauto.
727		Qed.
728
729		Lemma gt_tree_not_in :
730		forall (x : elt) (t : tree), gt_tree x t -> ~ InT x t.
731		Proof.
732		intros; intro; order.
733		Qed.
734
735		Lemma gt_tree_trans :
736		forall x y, X.lt y x -> forall t, gt_tree x t -> gt_tree y t.
737		Proof.
738		eauto.
739		Qed.
740
741		Local Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans.
742
743		(** * Inductions principles for some of the set operators *)
	328	(** Inductions principles for some of the set operators *)
744	329
745	330	Functional Scheme bal_ind := Induction for bal Sort Prop.
746	331	Functional Scheme remove_min_ind := Induction for remove_min Sort Prop.
747	332	Functional Scheme merge_ind := Induction for merge Sort Prop.
748		Functional Scheme min_elt_ind := Induction for min_elt Sort Prop.
749		Functional Scheme max_elt_ind := Induction for max_elt Sort Prop.
750	333	Functional Scheme concat_ind := Induction for concat Sort Prop.
751	334	Functional Scheme inter_ind := Induction for inter Sort Prop.
752	335	Functional Scheme diff_ind := Induction for diff Sort Prop.
753	336	Functional Scheme union_ind := Induction for union Sort Prop.
754	337
755		Ltac induct s x :=
756		induction s as [\|l IHl x' r IHr h]; simpl; intros;
757		[\|elim_compare x x'; intros; inv].
758
759
760		(** * Notations and helper lemma about pairs and triples *)
	338	(** Notations and helper lemma about pairs and triples *)
761	339
762	340	Notation "s #1" := (fst s) (at level 9, format "s '#1'") : pair_scope.
763	341	Notation "s #2" := (snd s) (at level 9, format "s '#2'") : pair_scope.

765	343	Notation "t #b" := (t_in t) (at level 9, format "t '#b'") : pair_scope.
766	344	Notation "t #r" := (t_right t) (at level 9, format "t '#r'") : pair_scope.
767	345
768		Open Local Scope pair_scope.
769
770
771		(** * Empty set *)
772
773		Lemma empty_spec : Empty empty.
774		Proof.
775		intro; intro.
776		inversion H.
777		Qed.
778
779		Instance empty_ok : Ok empty.
780		Proof.
781		auto.
782		Qed.
783
784		(** * Emptyness test *)
785
786		Lemma is_empty_spec : forall s, is_empty s = true <-> Empty s.
787		Proof.
788		destruct s as [\|r x l h]; simpl; auto.
789		split; auto. red; red; intros; inv.
790		split; auto. try discriminate. intro H; elim (H x); auto.
791		Qed.
792
793		(** * Membership *)
794
795		Lemma mem_spec : forall s x `{Ok s}, mem x s = true <-> InT x s.
796		Proof.
797		split.
798		induct s x; auto; try discriminate.
799		induct s x; intuition_in; order.
800		Qed.
801
802
803		(** * Singleton set *)
	346	Local Open Scope pair_scope.
	347
	348	( Singleton set *)
804	349
805	350	Lemma singleton_spec : forall x y, InT y (singleton x) <-> X.eq y x.
806	351	Proof.

812	357	unfold singleton; auto.
813	358	Qed.
814	359
815
816
817		(** * Helper functions *)
	360	( Helper functions *)
818	361
819	362	Lemma create_spec :
820	363	forall l x r y, InT y (create l x r) <-> X.eq y x \/ InT y l \/ InT y r.

845	388	Qed.
846	389
847	390
848		(** * Insertion *)
	391	( Insertion *)
849	392
850	393	Lemma add_spec' : forall s x y,
851	394	InT y (add x s) <-> X.eq y x \/ InT y s.

865	408	Qed.
866	409
867	410
868		Open Scope Int_scope.
869
870		(** * Join *)
871
872		(* Function/Functional Scheme can't deal with internal fix.
873		Let's do its job by hand: *)
	411	Local Open Scope Int_scope.
	412
	413	( Join *)
	414
	415	(** Function/Functional Scheme can't deal with internal fix.
	416	Let's do its job by hand: *)
874	417
875	418	Ltac join_tac :=
876		intro l; induction l as [\| ll _ lx lr Hlr lh];
877		[ \| intros x r; induction r as [\| rl Hrl rx rr _ rh]; unfold join;
	419	intro l; induction l as [\| lh ll _ lx lr Hlr];
	420	[ \| intros x r; induction r as [\| rh rl Hrl rx rr _]; unfold join;
878	421	[ \| destruct (gt_le_dec lh (rh+2)) as [GT\|LE];
879	422	[ match goal with \|- context b [ bal ?a ?b ?c] =>
880	423	replace (bal a b c)
881		with (bal ll lx (join lr x (Node rl rx rr rh))); [ \| auto]
	424	with (bal ll lx (join lr x (Node rh rl rx rr))); [ \| auto]
882	425	end
883	426	\| destruct (gt_le_dec rh (lh+2)) as [GT'\|LE'];
884	427	[ match goal with \|- context b [ bal ?a ?b ?c] =>
885	428	replace (bal a b c)
886		with (bal (join (Node ll lx lr lh) x rl) rx rr); [ \| auto]
	429	with (bal (join (Node lh ll lx lr) x rl) rx rr); [ \| auto]
887	430	end
888	431	\| ] ] ] ]; intros.
889	432

909	452	Qed.
910	453
911	454
912		(** * Extraction of minimum element *)
913
914		Lemma remove_min_spec : forall l x r h y,
915		InT y (Node l x r h) <->
	455	( Extraction of minimum element *)
	456
	457	Lemma remove_min_spec : forall l x r y h,
	458	InT y (Node h l x r) <->
916	459	X.eq y (remove_min l x r)#2 \/ InT y (remove_min l x r)#1.
917	460	Proof.
918	461	intros l x r; functional induction (remove_min l x r); simpl in *; intros.

920	463	rewrite bal_spec, In_node_iff, IHp, e0; simpl; intuition.
921	464	Qed.
922	465
923		Instance remove_min_ok l x r : forall h `(Ok (Node l x r h)),
	466	Instance remove_min_ok l x r : forall h `(Ok (Node h l x r)),
924	467	Ok (remove_min l x r)#1.
925	468	Proof.
926	469	functional induction (remove_min l x r); simpl; intros.
927	470	inv; auto.
928		assert (O : Ok (Node ll lx lr _x)) by (inv; auto).
929		assert (L : lt_tree x (Node ll lx lr _x)) by (inv; auto).
	471	assert (O : Ok (Node _x ll lx lr)) by (inv; auto).
	472	assert (L : lt_tree x (Node _x ll lx lr)) by (inv; auto).
930	473	specialize IHp with (1:=O); rewrite e0 in IHp; auto; simpl in *.
931	474	apply bal_ok; auto.
932	475	inv; auto.

935	478	inv; auto.
936	479	Qed.
937	480
938		Lemma remove_min_gt_tree : forall l x r h `{Ok (Node l x r h)},
	481	Lemma remove_min_gt_tree : forall l x r h `{Ok (Node h l x r)},
939	482	gt_tree (remove_min l x r)#2 (remove_min l x r)#1.
940	483	Proof.
941	484	intros l x r; functional induction (remove_min l x r); simpl; intros.
942	485	inv; auto.
943		assert (O : Ok (Node ll lx lr _x)) by (inv; auto).
944		assert (L : lt_tree x (Node ll lx lr _x)) by (inv; auto).
	486	assert (O : Ok (Node _x ll lx lr)) by (inv; auto).
	487	assert (L : lt_tree x (Node _x ll lx lr)) by (inv; auto).
945	488	specialize IHp with (1:=O); rewrite e0 in IHp; simpl in IHp.
946	489	intro y; rewrite bal_spec; intuition;
947	490	specialize (L m); rewrite remove_min_spec, e0 in L; simpl in L;

950	493	Local Hint Resolve remove_min_gt_tree.
951	494
952	495
953
954		(** * Merging two trees *)
	496	( Merging two trees *)
955	497
956	498	Lemma merge_spec : forall s1 s2 y,
957	499	InT y (merge s1 s2) <-> InT y s1 \/ InT y s2.
958	500	Proof.
959	501	intros s1 s2; functional induction (merge s1 s2); intros;
960		try factornode _x _x0 _x1 _x2 as s1.
	502	try factornode s1.
961	503	intuition_in.
962	504	intuition_in.
963	505	rewrite bal_spec, remove_min_spec, e1; simpl; intuition.

968	510	Ok (merge s1 s2).
969	511	Proof.
970	512	functional induction (merge s1 s2); intros; auto;
971		try factornode _x _x0 _x1 _x2 as s1.
	513	try factornode s1.
972	514	apply bal_ok; auto.
973	515	change s2' with ((s2',m)#1); rewrite <-e1; eauto with *.
974	516	intros y Hy.

979	521
980	522
981	523
982		(** * Deletion *)
	524	( Deletion *)
983	525
984	526	Lemma remove_spec : forall s x y `{Ok s},
985	527	(InT y (remove x s) <-> InT y s /\ ~ X.eq y x).

987	529	induct s x.
988	530	intuition_in.
989	531	rewrite merge_spec; intuition; [order\|order\|intuition_in].
990		elim H6; eauto.
	532	elim H2; eauto.
991	533	rewrite bal_spec, IHl; clear IHl IHr; intuition; [order\|order\|intuition_in].
992	534	rewrite bal_spec, IHr; clear IHl IHr; intuition; [order\|order\|intuition_in].
993	535	Qed.

1007	549	Qed.
1008	550
1009	551
1010		(** * Minimum element *)
1011
1012		Lemma min_elt_spec1 : forall s x, min_elt s = Some x -> InT x s.
1013		Proof.
1014		intro s; functional induction (min_elt s); auto; inversion 1; auto.
1015		Qed.
1016
1017		Lemma min_elt_spec2 : forall s x y `{Ok s},
1018		min_elt s = Some x -> InT y s -> ~ X.lt y x.
1019		Proof.
1020		intro s; functional induction (min_elt s);
1021		try rename _x1 into l1, _x2 into x1, _x3 into r1, _x4 into h1.
1022		discriminate.
1023		intros x y0 U V W.
1024		inversion V; clear V; subst.
1025		inv; order.
1026		intros; inv; auto.
1027		assert (X.lt x y) by (apply H4; apply min_elt_spec1; auto).
1028		order.
1029		assert (X.lt x1 y) by auto.
1030		assert (~X.lt x1 x) by auto.
1031		order.
1032		Qed.
1033
1034		Lemma min_elt_spec3 : forall s, min_elt s = None -> Empty s.
1035		Proof.
1036		intro s; functional induction (min_elt s).
1037		red; red; inversion 2.
1038		inversion 1.
1039		intro H0.
1040		destruct (IHo H0 _x2); auto.
1041		Qed.
1042
1043
1044
1045		(** * Maximum element *)
1046
1047		Lemma max_elt_spec1 : forall s x, max_elt s = Some x -> InT x s.
1048		Proof.
1049		intro s; functional induction (max_elt s); auto; inversion 1; auto.
1050		Qed.
1051
1052		Lemma max_elt_spec2 : forall s x y `{Ok s},
1053		max_elt s = Some x -> InT y s -> ~ X.lt x y.
1054		Proof.
1055		intro s; functional induction (max_elt s);
1056		try rename _x1 into l1, _x2 into x1, _x3 into r1, _x4 into h1.
1057		discriminate.
1058		intros x y0 U V W.
1059		inversion V; clear V; subst.
1060		inv; order.
1061		intros; inv; auto.
1062		assert (X.lt y x1) by auto.
1063		assert (~ X.lt x x1) by auto.
1064		order.
1065		assert (X.lt y x) by (apply H5; apply max_elt_spec1; auto).
1066		order.
1067		Qed.
1068
1069		Lemma max_elt_spec3 : forall s, max_elt s = None -> Empty s.
1070		Proof.
1071		intro s; functional induction (max_elt s).
1072		red; auto.
1073		inversion 1.
1074		intros H0; destruct (IHo H0 _x2); auto.
1075		Qed.
1076
1077
1078
1079		(** * Any element *)
1080
1081		Lemma choose_spec1 : forall s x, choose s = Some x -> InT x s.
1082		Proof.
1083		exact min_elt_spec1.
1084		Qed.
1085
1086		Lemma choose_spec2 : forall s, choose s = None -> Empty s.
1087		Proof.
1088		exact min_elt_spec3.
1089		Qed.
1090
1091		Lemma choose_spec3 : forall s s' x x' `{Ok s, Ok s'},
1092		choose s = Some x -> choose s' = Some x' ->
1093		Equal s s' -> X.eq x x'.
1094		Proof.
1095		unfold choose, Equal; intros s s' x x' Hb Hb' Hx Hx' H.
1096		assert (~X.lt x x').
1097		apply min_elt_spec2 with s'; auto.
1098		rewrite <-H; auto using min_elt_spec1.
1099		assert (~X.lt x' x).
1100		apply min_elt_spec2 with s; auto.
1101		rewrite H; auto using min_elt_spec1.
1102		elim_compare x x'; intuition.
1103		Qed.
1104
1105
1106		(** * Concatenation *)
	552	( Concatenation *)
1107	553
1108	554	Lemma concat_spec : forall s1 s2 y,
1109	555	InT y (concat s1 s2) <-> InT y s1 \/ InT y s2.
1110	556	Proof.
1111	557	intros s1 s2; functional induction (concat s1 s2); intros;
1112		try factornode _x _x0 _x1 _x2 as s1.
	558	try factornode s1.
1113	559	intuition_in.
1114	560	intuition_in.
1115	561	rewrite join_spec, remove_min_spec, e1; simpl; intuition.

1120	566	Ok (concat s1 s2).
1121	567	Proof.
1122	568	functional induction (concat s1 s2); intros; auto;
1123		try factornode _x _x0 _x1 _x2 as s1.
	569	try factornode s1.
1124	570	apply join_ok; auto.
1125	571	change (Ok (s2',m)#1); rewrite <-e1; eauto with *.
1126	572	intros y Hy.

1131	577
1132	578
1133	579
1134		(** * Splitting *)
	580	( Splitting *)
1135	581
1136	582	Lemma split_spec1 : forall s x y `{Ok s},
1137	583	(InT y (split x s)#l <-> InT y s /\ X.lt y x).

1173	619	Proof.
1174	620	induct s x; simpl; auto.
1175	621	specialize (IHl x).
1176		generalize (fun y => @split_spec2 _ x y H1).
	622	generalize (fun y => @split_spec2 l x y _).
1177	623	destruct (split x l); simpl in *; intuition. apply join_ok; auto.
1178	624	intros y; rewrite H; intuition.
1179	625	specialize (IHr x).
1180		generalize (fun y => @split_spec1 _ x y H2).
	626	generalize (fun y => @split_spec1 r x y _).
1181	627	destruct (split x r); simpl in *; intuition. apply join_ok; auto.
1182	628	intros y; rewrite H; intuition.
1183	629	Qed.

1189	635	Proof. intros; destruct (@split_ok s x); auto. Qed.
1190	636
1191	637
1192		(** * Intersection *)
	638	( Intersection *)
1193	639
1194	640	Ltac destruct_split := match goal with
1195	641	\| H : split ?x ?s = << ?u, ?v, ?w >> \|- _ =>

1203	649	Ok (inter s1 s2) /\ (forall y, InT y (inter s1 s2) <-> InT y s1 /\ InT y s2).
1204	650	Proof.
1205	651	intros s1 s2; functional induction inter s1 s2; intros B1 B2;
1206		[intuition_in\|intuition_in \| \| ];
1207		factornode _x0 _x1 _x2 _x3 as s2; destruct_split; inv;
	652	[intuition_in\|intuition_in \| \| ]; factornode s2;
	653	destruct_split; inv;
1208	654	destruct IHt0 as (IHo1,IHi1), IHt1 as (IHo2,IHi2); auto with *;
1209	655	split; intros.
1210		(* Ok join *)
1211		apply join_ok; auto with *; intro y; rewrite ?IHi1, ?IHi2; intuition.
1212		(* InT join *)
1213		rewrite join_spec, IHi1, IHi2, split_spec1, split_spec2; intuition_in.
1214		setoid_replace y with x1; auto. rewrite <- split_spec3; auto.
1215		(* Ok concat *)
1216		apply concat_ok; auto with *; intros y1 y2; rewrite IHi1, IHi2; intuition; order.
1217		(* InT concat *)
1218		rewrite concat_spec, IHi1, IHi2, split_spec1, split_spec2; auto.
1219		intuition_in.
1220		absurd (InT x1 s2).
1221		rewrite <- split_spec3; auto; congruence.
1222		setoid_replace x1 with y; auto.
	656	- (* Ok join *)
	657	apply join_ok; auto with *; intro y; rewrite ?IHi1, ?IHi2; intuition.
	658	- (* InT join *)
	659	rewrite join_spec, IHi1, IHi2, split_spec1, split_spec2; intuition_in.
	660	setoid_replace y with x1; auto. rewrite <- split_spec3; auto.
	661	- (* Ok concat *)
	662	apply concat_ok; auto with *; intros y1 y2; rewrite IHi1, IHi2;
	663	intuition; order.
	664	- (* InT concat *)
	665	rewrite concat_spec, IHi1, IHi2, split_spec1, split_spec2; auto.
	666	intuition_in.
	667	absurd (InT x1 s2).
	668	rewrite <- split_spec3; auto; congruence.
	669	setoid_replace x1 with y; auto.
1223	670	Qed.
1224	671
1225	672	Lemma inter_spec : forall s1 s2 y `{Ok s1, Ok s2},

1230	677	Proof. intros; destruct (@inter_spec_ok s1 s2); auto. Qed.
1231	678
1232	679
1233		(** * Difference *)
	680	( Difference *)
1234	681
1235	682	Lemma diff_spec_ok : forall s1 s2 `{Ok s1, Ok s2},
1236	683	Ok (diff s1 s2) /\ (forall y, InT y (diff s1 s2) <-> InT y s1 /\ ~InT y s2).
1237	684	Proof.
1238	685	intros s1 s2; functional induction diff s1 s2; intros B1 B2;
1239		[intuition_in\|intuition_in \| \| ];
1240		factornode _x0 _x1 _x2 _x3 as s2; destruct_split; inv;
	686	[intuition_in\|intuition_in \| \| ]; factornode s2;
	687	destruct_split; inv;
1241	688	destruct IHt0 as (IHb1,IHi1), IHt1 as (IHb2,IHi2); auto with *;
1242	689	split; intros.
1243		(* Ok concat *)
1244		apply concat_ok; auto; intros y1 y2; rewrite IHi1, IHi2; intuition; order.
1245		(* InT concat *)
1246		rewrite concat_spec, IHi1, IHi2, split_spec1, split_spec2; intuition_in.
1247		absurd (InT x1 s2).
1248		setoid_replace x1 with y; auto.
1249		rewrite <- split_spec3; auto; congruence.
1250		(* Ok join *)
1251		apply join_ok; auto; intro y; rewrite ?IHi1, ?IHi2; intuition.
1252		(* InT join *)
1253		rewrite join_spec, IHi1, IHi2, split_spec1, split_spec2; auto with *.
1254		intuition_in.
1255		absurd (InT x1 s2); auto.
1256		rewrite <- split_spec3; auto; congruence.
1257		setoid_replace x1 with y; auto.
	690	- (* Ok concat *)
	691	apply concat_ok; auto; intros y1 y2; rewrite IHi1, IHi2; intuition; order.
	692	- (* InT concat *)
	693	rewrite concat_spec, IHi1, IHi2, split_spec1, split_spec2; intuition_in.
	694	absurd (InT x1 s2).
	695	+ setoid_replace x1 with y; auto.
	696	+ rewrite <- split_spec3; auto; congruence.
	697	- (* Ok join *)
	698	apply join_ok; auto; intro y; rewrite ?IHi1, ?IHi2; intuition.
	699	- (* InT join *)
	700	rewrite join_spec, IHi1, IHi2, split_spec1, split_spec2; auto with *.
	701	intuition_in.
	702	absurd (InT x1 s2); auto.
	703	* rewrite <- split_spec3; auto; congruence.
	704	* setoid_replace x1 with y; auto.
1258	705	Qed.
1259	706
1260	707	Lemma diff_spec : forall s1 s2 y `{Ok s1, Ok s2},

1265	712	Proof. intros; destruct (@diff_spec_ok s1 s2); auto. Qed.
1266	713
1267	714
1268		(** * Union *)
	715	( Union *)
1269	716
1270	717	Lemma union_spec : forall s1 s2 y `{Ok s1, Ok s2},
1271	718	(InT y (union s1 s2) <-> InT y s1 \/ InT y s2).

1273	720	intros s1 s2; functional induction union s1 s2; intros y B1 B2.
1274	721	intuition_in.
1275	722	intuition_in.
1276		factornode _x0 _x1 _x2 _x3 as s2; destruct_split; inv.
	723	factornode s2; destruct_split; inv.
1277	724	rewrite join_spec, IHt0, IHt1, split_spec1, split_spec2; auto with *.
1278		elim_compare y x1; intuition_in.
	725	destruct (X.compare_spec y x1); intuition_in.
1279	726	Qed.
1280	727
1281	728	Instance union_ok s1 s2 : forall `(Ok s1, Ok s2), Ok (union s1 s2).
1282	729	Proof.
1283	730	functional induction union s1 s2; intros B1 B2; auto.
1284		factornode _x0 _x1 _x2 _x3 as s2; destruct_split; inv.
	731	factornode s2; destruct_split; inv.
1285	732	apply join_ok; auto with *.
1286	733	intro y; rewrite union_spec, split_spec1; intuition_in.
1287	734	intro y; rewrite union_spec, split_spec2; intuition_in.
1288	735	Qed.
1289	736
1290
1291		(** * Elements *)
1292
1293		Lemma elements_spec1' : forall s acc x,
1294		InA X.eq x (elements_aux acc s) <-> InT x s \/ InA X.eq x acc.
1295		Proof.
1296		induction s as [ \| l Hl x r Hr h ]; simpl; auto.
1297		intuition.
1298		inversion H0.
1299		intros.
1300		rewrite Hl.
1301		destruct (Hr acc x0); clear Hl Hr.
1302		intuition; inversion_clear H3; intuition.
1303		Qed.
1304
1305		Lemma elements_spec1 : forall s x, InA X.eq x (elements s) <-> InT x s.
1306		Proof.
1307		intros; generalize (elements_spec1' s nil x); intuition.
1308		inversion_clear H0.
1309		Qed.
1310
1311		Lemma elements_spec2' : forall s acc `{Ok s}, sort X.lt acc ->
1312		(forall x y : elt, InA X.eq x acc -> InT y s -> X.lt y x) ->
1313		sort X.lt (elements_aux acc s).
1314		Proof.
1315		induction s as [ \| l Hl y r Hr h]; simpl; intuition.
1316		inv.
1317		apply Hl; auto.
1318		constructor.
1319		apply Hr; auto.
1320		eapply InA_InfA; eauto with *.
1321		intros.
1322		destruct (elements_spec1' r acc y0); intuition.
1323		intros.
1324		inversion_clear H.
1325		order.
1326		destruct (elements_spec1' r acc x); intuition eauto.
1327		Qed.
1328
1329		Lemma elements_spec2 : forall s `(Ok s), sort X.lt (elements s).
1330		Proof.
1331		intros; unfold elements; apply elements_spec2'; auto.
1332		intros; inversion H0.
1333		Qed.
1334		Local Hint Resolve elements_spec2.
1335
1336		Lemma elements_spec2w : forall s `(Ok s), NoDupA X.eq (elements s).
1337		Proof.
1338		intros. eapply SortA_NoDupA; eauto with *.
1339		Qed.
1340
1341		Lemma elements_aux_cardinal :
1342		forall s acc, (length acc + cardinal s)%nat = length (elements_aux acc s).
1343		Proof.
1344		simple induction s; simpl in \|- *; intuition.
1345		rewrite <- H.
1346		simpl in \|- *.
1347		rewrite <- H0; omega.
1348		Qed.
1349
1350		Lemma elements_cardinal : forall s : tree, cardinal s = length (elements s).
1351		Proof.
1352		exact (fun s => elements_aux_cardinal s nil).
1353		Qed.
1354
1355		Definition cardinal_spec (s:t)(Hs:Ok s) := elements_cardinal s.
1356
1357		Lemma elements_app :
1358		forall s acc, elements_aux acc s = elements s ++ acc.
1359		Proof.
1360		induction s; simpl; intros; auto.
1361		rewrite IHs1, IHs2.
1362		unfold elements; simpl.
1363		rewrite 2 IHs1, IHs2, <- !app_nil_end, !app_ass; auto.
1364		Qed.
1365
1366		Lemma elements_node :
1367		forall l x r h acc,
1368		elements l ++ x :: elements r ++ acc =
1369		elements (Node l x r h) ++ acc.
1370		Proof.
1371		unfold elements; simpl; intros; auto.
1372		rewrite !elements_app, <- !app_nil_end, !app_ass; auto.
1373		Qed.
1374
1375
1376	737	(** * Filter *)
1377	738
1378		Lemma filter_spec' : forall s x acc f,
1379		Proper (X.eq==>eq) f ->
1380		(InT x (filter_acc f acc s) <-> InT x acc \/ InT x s /\ f x = true).
1381		Proof.
1382		induction s; simpl; intros.
1383		intuition_in.
1384		rewrite IHs2, IHs1 by (destruct (f t0); auto).
1385		case_eq (f t0); intros.
1386		rewrite add_spec'; auto.
1387		intuition_in.
1388		rewrite (H _ _ H2).
1389		intuition.
1390		intuition_in.
1391		rewrite (H _ _ H2) in H3.
1392		rewrite H0 in H3; discriminate.
1393		Qed.
1394
1395		Instance filter_ok' : forall s acc f `(Ok s, Ok acc),
1396		Ok (filter_acc f acc s).
1397		Proof.
1398		induction s; simpl; auto.
1399		intros. inv.
1400		destruct (f t0); auto with *.
1401		Qed.
1402
1403	739	Lemma filter_spec : forall s x f,
1404		Proper (X.eq==>eq) f ->
	740	Proper (X.eq==>Logic.eq) f ->
1405	741	(InT x (filter f s) <-> InT x s /\ f x = true).
1406	742	Proof.
1407		unfold filter; intros; rewrite filter_spec'; intuition_in.
1408		Qed.
1409
1410		Instance filter_ok s f `(Ok s) : Ok (filter f s).
1411		Proof.
1412		unfold filter; intros; apply filter_ok'; auto.
	743	induction s as [ \|h l Hl x0 r Hr]; intros x f Hf; simpl.
	744	- intuition_in.
	745	- case_eq (f x0); intros Hx0.
	746	* rewrite join_spec, Hl, Hr; intuition_in.
	747	now setoid_replace x with x0.
	748	* rewrite concat_spec, Hl, Hr; intuition_in.
	749	assert (f x = f x0) by auto. congruence.
	750	Qed.
	751
	752	Lemma filter_weak_spec : forall s x f,
	753	InT x (filter f s) -> InT x s.
	754	Proof.
	755	induction s as [ \|h l Hl x0 r Hr]; intros x f; simpl.
	756	- trivial.
	757	- destruct (f x0).
	758	* rewrite join_spec; intuition_in; eauto.
	759	* rewrite concat_spec; intuition_in; eauto.
	760	Qed.
	761
	762	Instance filter_ok s f `(H : Ok s) : Ok (filter f s).
	763	Proof.
	764	induction H as [ \| h x l r Hl Hfl Hr Hfr Hlt Hgt ].
	765	- constructor.
	766	- simpl.
	767	assert (lt_tree x (filter f l)) by (eauto using filter_weak_spec).
	768	assert (gt_tree x (filter f r)) by (eauto using filter_weak_spec).
	769	destruct (f x); eauto using concat_ok, join_ok.
1413	770	Qed.
1414	771
1415	772
1416	773	(** * Partition *)
1417	774
1418		Lemma partition_spec1' : forall s acc f,
1419		Proper (X.eq==>eq) f -> forall x : elt,
1420		InT x (partition_acc f acc s)#1 <->
1421		InT x acc#1 \/ InT x s /\ f x = true.
1422		Proof.
1423		induction s; simpl; intros.
1424		intuition_in.
1425		destruct acc as [acct accf]; simpl in *.
1426		rewrite IHs2 by
1427		(destruct (f t0); auto; apply partition_acc_avl_1; simpl; auto).
1428		rewrite IHs1 by (destruct (f t0); simpl; auto).
1429		case_eq (f t0); simpl; intros.
1430		rewrite add_spec'; auto.
1431		intuition_in.
1432		rewrite (H _ _ H2).
1433		intuition.
1434		intuition_in.
1435		rewrite (H _ _ H2) in H3.
1436		rewrite H0 in H3; discriminate.
1437		Qed.
1438
1439		Lemma partition_spec2' : forall s acc f,
1440		Proper (X.eq==>eq) f -> forall x : elt,
1441		InT x (partition_acc f acc s)#2 <->
1442		InT x acc#2 \/ InT x s /\ f x = false.
1443		Proof.
1444		induction s; simpl; intros.
1445		intuition_in.
1446		destruct acc as [acct accf]; simpl in *.
1447		rewrite IHs2 by
1448		(destruct (f t0); auto; apply partition_acc_avl_2; simpl; auto).
1449		rewrite IHs1 by (destruct (f t0); simpl; auto).
1450		case_eq (f t0); simpl; intros.
1451		intuition.
1452		intuition_in.
1453		rewrite (H _ _ H2) in H3.
1454		rewrite H0 in H3; discriminate.
1455		rewrite add_spec'; auto.
1456		intuition_in.
1457		rewrite (H _ _ H2).
1458		intuition.
1459		Qed.
1460
1461		Lemma partition_spec1 : forall s f,
1462		Proper (X.eq==>eq) f ->
	775	Lemma partition_spec1' s f : (partition f s)#1 = filter f s.
	776	Proof.
	777	induction s as [ \| h l Hl x r Hr ]; simpl.
	778	- trivial.
	779	- rewrite <- Hl, <- Hr.
	780	now destruct (partition f l), (partition f r), (f x).
	781	Qed.
	782
	783	Lemma partition_spec2' s f :
	784	(partition f s)#2 = filter (fun x => negb (f x)) s.
	785	Proof.
	786	induction s as [ \| h l Hl x r Hr ]; simpl.
	787	- trivial.
	788	- rewrite <- Hl, <- Hr.
	789	now destruct (partition f l), (partition f r), (f x).
	790	Qed.
	791
	792	Lemma partition_spec1 s f :
	793	Proper (X.eq==>Logic.eq) f ->
1463	794	Equal (partition f s)#1 (filter f s).
1464		Proof.
1465		unfold partition; intros s f P x.
1466		rewrite partition_spec1', filter_spec; simpl; intuition_in.
1467		Qed.
1468
1469		Lemma partition_spec2 : forall s f,
1470		Proper (X.eq==>eq) f ->
	795	Proof. now rewrite partition_spec1'. Qed.
	796
	797	Lemma partition_spec2 s f :
	798	Proper (X.eq==>Logic.eq) f ->
1471	799	Equal (partition f s)#2 (filter (fun x => negb (f x)) s).
1472		Proof.
1473		unfold partition; intros s f P x.
1474		rewrite partition_spec2', filter_spec; simpl; intuition_in.
1475		rewrite H1; auto.
1476		right; split; auto.
1477		rewrite negb_true_iff in H1; auto.
1478		intros u v H; rewrite H; auto.
1479		Qed.
1480
1481		Instance partition_ok1' : forall s acc f `(Ok s, Ok acc#1),
1482		Ok (partition_acc f acc s)#1.
1483		Proof.
1484		induction s; simpl; auto.
1485		destruct acc as [acct accf]; simpl in *.
1486		intros. inv.
1487		destruct (f t0); auto.
1488		apply IHs2; simpl; auto.
1489		apply IHs1; simpl; auto with *.
1490		Qed.
1491
1492		Instance partition_ok2' : forall s acc f `(Ok s, Ok acc#2),
1493		Ok (partition_acc f acc s)#2.
1494		Proof.
1495		induction s; simpl; auto.
1496		destruct acc as [acct accf]; simpl in *.
1497		intros. inv.
1498		destruct (f t0); auto.
1499		apply IHs2; simpl; auto.
1500		apply IHs1; simpl; auto with *.
1501		Qed.
	800	Proof. now rewrite partition_spec2'. Qed.
1502	801
1503	802	Instance partition_ok1 s f `(Ok s) : Ok (partition f s)#1.
1504		Proof. apply partition_ok1'; auto. Qed.
	803	Proof. rewrite partition_spec1'; now apply filter_ok. Qed.
1505	804
1506	805	Instance partition_ok2 s f `(Ok s) : Ok (partition f s)#2.
1507		Proof. apply partition_ok2'; auto. Qed.
1508
1509
1510
1511		(** * [for_all] and [exists] *)
1512
1513		Lemma for_all_spec : forall s f, Proper (X.eq==>eq) f ->
1514		(for_all f s = true <-> For_all (fun x => f x = true) s).
1515		Proof.
1516		split.
1517		induction s; simpl; auto; intros; red; intros; inv.
1518		destruct (andb_prop _ _ H0); auto.
1519		destruct (andb_prop _ _ H1); eauto.
1520		apply IHs1; auto.
1521		destruct (andb_prop _ _ H0); auto.
1522		destruct (andb_prop _ _ H1); auto.
1523		apply IHs2; auto.
1524		destruct (andb_prop _ _ H0); auto.
1525		(* <- *)
1526		induction s; simpl; auto.
1527		intros. red in H0.
1528		rewrite IHs1; try red; auto.
1529		rewrite IHs2; try red; auto.
1530		generalize (H0 t0).
1531		destruct (f t0); simpl; auto.
1532		Qed.
1533
1534		Lemma exists_spec : forall s f, Proper (X.eq==>eq) f ->
1535		(exists_ f s = true <-> Exists (fun x => f x = true) s).
1536		Proof.
1537		split.
1538		induction s; simpl; intros; rewrite <- ?orb_lazy_alt in *.
1539		discriminate.
1540		destruct (orb_true_elim _ _ H0) as [H1\|H1].
1541		destruct (orb_true_elim _ _ H1) as [H2\|H2].
1542		exists t0; auto.
1543		destruct (IHs1 H2); auto; exists x; intuition.
1544		destruct (IHs2 H1); auto; exists x; intuition.
1545		(* <- *)
1546		induction s; simpl; destruct 1 as (x,(U,V)); inv; rewrite <- ?orb_lazy_alt.
1547		rewrite (H _ _ (MX.eq_sym H0)); rewrite V; auto.
1548		apply orb_true_intro; left.
1549		apply orb_true_intro; right; apply IHs1; auto; exists x; auto.
1550		apply orb_true_intro; right; apply IHs2; auto; exists x; auto.
1551		Qed.
1552
1553
1554		(** * Fold *)
1555
1556		Lemma fold_spec' :
1557		forall (A : Type) (f : elt -> A -> A) (s : tree) (i : A) (acc : list elt),
1558		fold_left (flip f) (elements_aux acc s) i = fold_left (flip f) acc (fold f s i).
1559		Proof.
1560		induction s as [\|l IHl x r IHr h]; simpl; intros; auto.
1561		rewrite IHl.
1562		simpl. unfold flip at 2.
1563		apply IHr.
1564		Qed.
1565
1566		Lemma fold_spec :
1567		forall (s:t) (A : Type) (i : A) (f : elt -> A -> A),
1568		fold f s i = fold_left (flip f) (elements s) i.
1569		Proof.
1570		unfold elements.
1571		induction s as [\|l IHl x r IHr h]; simpl; intros; auto.
1572		rewrite fold_spec'.
1573		rewrite IHr.
1574		simpl; auto.
1575		Qed.
1576
1577
1578		(** * Subset *)
1579
1580		Lemma subsetl_spec : forall subset_l1 l1 x1 h1 s2
1581		`{Ok (Node l1 x1 Leaf h1), Ok s2},
1582		(forall s `{Ok s}, (subset_l1 s = true <-> Subset l1 s)) ->
1583		(subsetl subset_l1 x1 s2 = true <-> Subset (Node l1 x1 Leaf h1) s2 ).
1584		Proof.
1585		induction s2 as [\|l2 IHl2 x2 r2 IHr2 h2]; simpl; intros.
1586		unfold Subset; intuition; try discriminate.
1587		assert (H': InT x1 Leaf) by auto; inversion H'.
1588		specialize (IHl2 H).
1589		specialize (IHr2 H).
1590		inv.
1591		elim_compare x1 x2.
1592
1593		rewrite H1 by auto; clear H1 IHl2 IHr2.
1594		unfold Subset. intuition_in.
1595		assert (X.eq a x2) by order; intuition_in.
1596		assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
1597
1598		rewrite IHl2 by auto; clear H1 IHl2 IHr2.
1599		unfold Subset. intuition_in.
1600		assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
1601		assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
1602
1603		rewrite <-andb_lazy_alt, andb_true_iff, H1 by auto; clear H1 IHl2 IHr2.
1604		unfold Subset. intuition_in.
1605		constructor 3. setoid_replace a with x1; auto. rewrite <- mem_spec; auto.
1606		rewrite mem_spec; auto.
1607		assert (InT x1 (Node l2 x2 r2 h2)) by auto; intuition_in; order.
1608		Qed.
1609
1610
1611		Lemma subsetr_spec : forall subset_r1 r1 x1 h1 s2,
1612		bst (Node Leaf x1 r1 h1) -> bst s2 ->
1613		(forall s, bst s -> (subset_r1 s = true <-> Subset r1 s)) ->
1614		(subsetr subset_r1 x1 s2 = true <-> Subset (Node Leaf x1 r1 h1) s2).
1615		Proof.
1616		induction s2 as [\|l2 IHl2 x2 r2 IHr2 h2]; simpl; intros.
1617		unfold Subset; intuition; try discriminate.
1618		assert (H': InT x1 Leaf) by auto; inversion H'.
1619		specialize (IHl2 H).
1620		specialize (IHr2 H).
1621		inv.
1622		elim_compare x1 x2.
1623
1624		rewrite H1 by auto; clear H1 IHl2 IHr2.
1625		unfold Subset. intuition_in.
1626		assert (X.eq a x2) by order; intuition_in.
1627		assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
1628
1629		rewrite <-andb_lazy_alt, andb_true_iff, H1 by auto; clear H1 IHl2 IHr2.
1630		unfold Subset. intuition_in.
1631		constructor 2. setoid_replace a with x1; auto. rewrite <- mem_spec; auto.
1632		rewrite mem_spec; auto.
1633		assert (InT x1 (Node l2 x2 r2 h2)) by auto; intuition_in; order.
1634
1635		rewrite IHr2 by auto; clear H1 IHl2 IHr2.
1636		unfold Subset. intuition_in.
1637		assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
1638		assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
1639		Qed.
1640
1641		Lemma subset_spec : forall s1 s2 `{Ok s1, Ok s2},
1642		(subset s1 s2 = true <-> Subset s1 s2).
1643		Proof.
1644		induction s1 as [\|l1 IHl1 x1 r1 IHr1 h1]; simpl; intros.
1645		unfold Subset; intuition_in.
1646		destruct s2 as [\|l2 x2 r2 h2]; simpl; intros.
1647		unfold Subset; intuition_in; try discriminate.
1648		assert (H': InT x1 Leaf) by auto; inversion H'.
1649		inv.
1650		elim_compare x1 x2.
1651
1652		rewrite <-andb_lazy_alt, andb_true_iff, IHl1, IHr1 by auto.
1653		clear IHl1 IHr1.
1654		unfold Subset; intuition_in.
1655		assert (X.eq a x2) by order; intuition_in.
1656		assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
1657		assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
1658
1659		rewrite <-andb_lazy_alt, andb_true_iff, IHr1 by auto.
1660		rewrite (@subsetl_spec (subset l1) l1 x1 h1) by auto.
1661		clear IHl1 IHr1.
1662		unfold Subset; intuition_in.
1663		assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
1664		assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
1665
1666		rewrite <-andb_lazy_alt, andb_true_iff, IHl1 by auto.
1667		rewrite (@subsetr_spec (subset r1) r1 x1 h1) by auto.
1668		clear IHl1 IHr1.
1669		unfold Subset; intuition_in.
1670		assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
1671		assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
1672		Qed.
1673
1674
1675		(** * Comparison *)
1676
1677		( Relations [eq] and [lt] over trees *)
1678
1679		Module L := MakeListOrdering X.
1680
1681		Definition eq := Equal.
1682		Instance eq_equiv : Equivalence eq.
1683		Proof. firstorder. Qed.
1684
1685		Lemma eq_Leq : forall s s', eq s s' <-> L.eq (elements s) (elements s').
1686		Proof.
1687		unfold eq, Equal, L.eq; intros.
1688		setoid_rewrite elements_spec1; firstorder.
1689		Qed.
1690
1691		Definition lt (s1 s2 : t) : Prop :=
1692		exists s1' s2', Ok s1' /\ Ok s2' /\ eq s1 s1' /\ eq s2 s2'
1693		/\ L.lt (elements s1') (elements s2').
1694
1695		Instance lt_strorder : StrictOrder lt.
1696		Proof.
1697		split.
1698		intros s (s1 & s2 & B1 & B2 & E1 & E2 & L).
1699		assert (eqlistA X.eq (elements s1) (elements s2)).
1700		apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto with *.
1701		rewrite <- eq_Leq. transitivity s; auto. symmetry; auto.
1702		rewrite H in L.
1703		apply (StrictOrder_Irreflexive (elements s2)); auto.
1704		intros s1 s2 s3 (s1' & s2' & B1 & B2 & E1 & E2 & L12)
1705		(s2'' & s3' & B2' & B3 & E2' & E3 & L23).
1706		exists s1', s3'; do 4 (split; trivial).
1707		assert (eqlistA X.eq (elements s2') (elements s2'')).
1708		apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto with *.
1709		rewrite <- eq_Leq. transitivity s2; auto. symmetry; auto.
1710		transitivity (elements s2'); auto.
1711		rewrite H; auto.
1712		Qed.
1713
1714		Instance lt_compat : Proper (eq==>eq==>iff) lt.
1715		Proof.
1716		intros s1 s2 E12 s3 s4 E34. split.
1717		intros (s1' & s3' & B1 & B3 & E1 & E3 & LT).
1718		exists s1', s3'; do 2 (split; trivial).
1719		split. transitivity s1; auto. symmetry; auto.
1720		split; auto. transitivity s3; auto. symmetry; auto.
1721		intros (s1' & s3' & B1 & B3 & E1 & E3 & LT).
1722		exists s1', s3'; do 2 (split; trivial).
1723		split. transitivity s2; auto.
1724		split; auto. transitivity s4; auto.
1725		Qed.
1726
1727
1728		(** * Proof of the comparison algorithm *)
1729
1730		(** [flatten_e e] returns the list of elements of [e] i.e. the list
1731		of elements actually compared *)
1732
1733		Fixpoint flatten_e (e : enumeration) : list elt := match e with
1734		\| End => nil
1735		\| More x t r => x :: elements t ++ flatten_e r
1736		end.
1737
1738		Lemma flatten_e_elements :
1739		forall l x r h e,
1740		elements l ++ flatten_e (More x r e) = elements (Node l x r h) ++ flatten_e e.
1741		Proof.
1742		intros; simpl; apply elements_node.
1743		Qed.
1744
1745		Lemma cons_1 : forall s e,
1746		flatten_e (cons s e) = elements s ++ flatten_e e.
1747		Proof.
1748		induction s; simpl; auto; intros.
1749		rewrite IHs1; apply flatten_e_elements.
1750		Qed.
1751
1752		(** Correctness of this comparison *)
1753
1754		Definition Cmp c x y := CompSpec L.eq L.lt x y c.
1755
1756		Local Hint Unfold Cmp flip.
1757
1758		Lemma compare_end_Cmp :
1759		forall e2, Cmp (compare_end e2) nil (flatten_e e2).
1760		Proof.
1761		destruct e2; simpl; constructor; auto. reflexivity.
1762		Qed.
1763
1764		Lemma compare_more_Cmp : forall x1 cont x2 r2 e2 l,
1765		Cmp (cont (cons r2 e2)) l (elements r2 ++ flatten_e e2) ->
1766		Cmp (compare_more x1 cont (More x2 r2 e2)) (x1::l)
1767		(flatten_e (More x2 r2 e2)).
1768		Proof.
1769		simpl; intros; elim_compare x1 x2; simpl; red; auto.
1770		Qed.
1771
1772		Lemma compare_cont_Cmp : forall s1 cont e2 l,
1773		(forall e, Cmp (cont e) l (flatten_e e)) ->
1774		Cmp (compare_cont s1 cont e2) (elements s1 ++ l) (flatten_e e2).
1775		Proof.
1776		induction s1 as [\|l1 Hl1 x1 r1 Hr1 h1]; simpl; intros; auto.
1777		rewrite <- elements_node; simpl.
1778		apply Hl1; auto. clear e2. intros [\|x2 r2 e2].
1779		simpl; auto.
1780		apply compare_more_Cmp.
1781		rewrite <- cons_1; auto.
1782		Qed.
1783
1784		Lemma compare_Cmp : forall s1 s2,
1785		Cmp (compare s1 s2) (elements s1) (elements s2).
1786		Proof.
1787		intros; unfold compare.
1788		rewrite (app_nil_end (elements s1)).
1789		replace (elements s2) with (flatten_e (cons s2 End)) by
1790		(rewrite cons_1; simpl; rewrite <- app_nil_end; auto).
1791		apply compare_cont_Cmp; auto.
1792		intros.
1793		apply compare_end_Cmp; auto.
1794		Qed.
1795
1796		Lemma compare_spec : forall s1 s2 `{Ok s1, Ok s2},
1797		CompSpec eq lt s1 s2 (compare s1 s2).
1798		Proof.
1799		intros.
1800		destruct (compare_Cmp s1 s2); constructor.
1801		rewrite eq_Leq; auto.
1802		intros; exists s1, s2; repeat split; auto.
1803		intros; exists s2, s1; repeat split; auto.
1804		Qed.
1805
1806
1807		(** * Equality test *)
1808
1809		Lemma equal_spec : forall s1 s2 `{Ok s1, Ok s2},
1810		equal s1 s2 = true <-> eq s1 s2.
1811		Proof.
1812		unfold equal; intros s1 s2 B1 B2.
1813		destruct (@compare_spec s1 s2 B1 B2) as [H\|H\|H];
1814		split; intros H'; auto; try discriminate.
1815		rewrite H' in H. elim (StrictOrder_Irreflexive s2); auto.
1816		rewrite H' in H. elim (StrictOrder_Irreflexive s2); auto.
1817		Qed.
	806	Proof. rewrite partition_spec2'; now apply filter_ok. Qed.
1818	807
1819	808	End MakeRaw.
1820	809

+1145

-0

theories/MSets/MSetGenTree.v less more

	0	(***********************************************************************)
	1	(* v * The Coq Proof Assistant / The Coq Development Team *)
	2	(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *)
	3	(* \VV/ *************************************************************)
	4	(* // * This file is distributed under the terms of the *)
	5	(* * GNU Lesser General Public License Version 2.1 *)
	6	(***********************************************************************)
	7
	8	(** * MSetGenTree : sets via generic trees
	9
	10	This module factorizes common parts in implementations
	11	of finite sets as AVL trees and as Red-Black trees. The nodes
	12	of the trees defined here include an generic information
	13	parameter, that will be the heigth in AVL trees and the color
	14	in Red-Black trees. Without more details here about these
	15	information parameters, trees here are not known to be
	16	well-balanced, but simply binary-search-trees.
	17
	18	The operations we could define and prove correct here are the
	19	one that do not build non-empty trees, but only analyze them :
	20
	21	- empty is_empty
	22	- mem
	23	- compare equal subset
	24	- fold cardinal elements
	25	- for_all exists_
	26	- min_elt max_elt choose
	27	*)
	28
	29	Require Import Orders OrdersFacts MSetInterface NPeano.
	30	Local Open Scope list_scope.
	31	Local Open Scope lazy_bool_scope.
	32
	33	(* For nicer extraction, we create induction principles
	34	only when needed *)
	35	Local Unset Elimination Schemes.
	36	Local Unset Case Analysis Schemes.
	37
	38	Module Type InfoTyp.
	39	Parameter t : Set.
	40	End InfoTyp.
	41
	42	(** * Ops : the pure functions *)
	43
	44	Module Type Ops (X:OrderedType)(Info:InfoTyp).
	45
	46	Definition elt := X.t.
	47	Hint Transparent elt.
	48
	49	Inductive tree : Type :=
	50	\| Leaf : tree
	51	\| Node : Info.t -> tree -> X.t -> tree -> tree.
	52
	53	( The empty set and emptyness test *)
	54
	55	Definition empty := Leaf.
	56
	57	Definition is_empty t :=
	58	match t with
	59	\| Leaf => true
	60	\| _ => false
	61	end.
	62
	63	( Membership test *)
	64
	65	(** The [mem] function is deciding membership. It exploits the
	66	binary search tree invariant to achieve logarithmic complexity. *)
	67
	68	Fixpoint mem x t :=
	69	match t with
	70	\| Leaf => false
	71	\| Node _ l k r =>
	72	match X.compare x k with
	73	\| Lt => mem x l
	74	\| Eq => true
	75	\| Gt => mem x r
	76	end
	77	end.
	78
	79	( Minimal, maximal, arbitrary elements *)
	80
	81	Fixpoint min_elt (t : tree) : option elt :=
	82	match t with
	83	\| Leaf => None
	84	\| Node _ Leaf x r => Some x
	85	\| Node _ l x r => min_elt l
	86	end.
	87
	88	Fixpoint max_elt (t : tree) : option elt :=
	89	match t with
	90	\| Leaf => None
	91	\| Node _ l x Leaf => Some x
	92	\| Node _ l x r => max_elt r
	93	end.
	94
	95	Definition choose := min_elt.
	96
	97	( Iteration on elements *)
	98
	99	Fixpoint fold {A: Type} (f: elt -> A -> A) (t: tree) (base: A) : A :=
	100	match t with
	101	\| Leaf => base
	102	\| Node _ l x r => fold f r (f x (fold f l base))
	103	end.
	104
	105	Fixpoint elements_aux acc s :=
	106	match s with
	107	\| Leaf => acc
	108	\| Node _ l x r => elements_aux (x :: elements_aux acc r) l
	109	end.
	110
	111	Definition elements := elements_aux nil.
	112
	113	Fixpoint rev_elements_aux acc s :=
	114	match s with
	115	\| Leaf => acc
	116	\| Node _ l x r => rev_elements_aux (x :: rev_elements_aux acc l) r
	117	end.
	118
	119	Definition rev_elements := rev_elements_aux nil.
	120
	121	Fixpoint cardinal (s : tree) : nat :=
	122	match s with
	123	\| Leaf => 0
	124	\| Node _ l _ r => S (cardinal l + cardinal r)
	125	end.
	126
	127	Fixpoint maxdepth s :=
	128	match s with
	129	\| Leaf => 0
	130	\| Node _ l _ r => S (max (maxdepth l) (maxdepth r))
	131	end.
	132
	133	Fixpoint mindepth s :=
	134	match s with
	135	\| Leaf => 0
	136	\| Node _ l _ r => S (min (mindepth l) (mindepth r))
	137	end.
	138
	139	( Testing universal or existential properties. *)
	140
	141	(** We do not use the standard boolean operators of Coq,
	142	but lazy ones. *)
	143
	144	Fixpoint for_all (f:elt->bool) s := match s with
	145	\| Leaf => true
	146	\| Node _ l x r => f x &&& for_all f l &&& for_all f r
	147	end.
	148
	149	Fixpoint exists_ (f:elt->bool) s := match s with
	150	\| Leaf => false
	151	\| Node _ l x r => f x \|\|\| exists_ f l \|\|\| exists_ f r
	152	end.
	153
	154	( Comparison of trees *)
	155
	156	(** The algorithm here has been suggested by Xavier Leroy,
	157	and transformed into c.p.s. by Benjamin Grégoire.
	158	The original ocaml code (with non-structural recursive calls)
	159	has also been formalized (thanks to Function+measure), see
	160	[ocaml_compare] in [MSetFullAVL]. The following code with
	161	continuations computes dramatically faster in Coq, and
	162	should be almost as efficient after extraction.
	163	*)
	164
	165	(** Enumeration of the elements of a tree. This corresponds
	166	to the "samefringe" notion in the litterature. *)
	167
	168	Inductive enumeration :=
	169	\| End : enumeration
	170	\| More : elt -> tree -> enumeration -> enumeration.
	171
	172
	173	(** [cons t e] adds the elements of tree [t] on the head of
	174	enumeration [e]. *)
	175
	176	Fixpoint cons s e : enumeration :=
	177	match s with
	178	\| Leaf => e
	179	\| Node _ l x r => cons l (More x r e)
	180	end.
	181
	182	(** One step of comparison of elements *)
	183
	184	Definition compare_more x1 (cont:enumeration->comparison) e2 :=
	185	match e2 with
	186	\| End => Gt
	187	\| More x2 r2 e2 =>
	188	match X.compare x1 x2 with
	189	\| Eq => cont (cons r2 e2)
	190	\| Lt => Lt
	191	\| Gt => Gt
	192	end
	193	end.
	194
	195	(** Comparison of left tree, middle element, then right tree *)
	196
	197	Fixpoint compare_cont s1 (cont:enumeration->comparison) e2 :=
	198	match s1 with
	199	\| Leaf => cont e2
	200	\| Node _ l1 x1 r1 =>
	201	compare_cont l1 (compare_more x1 (compare_cont r1 cont)) e2
	202	end.
	203
	204	(** Initial continuation *)
	205
	206	Definition compare_end e2 :=
	207	match e2 with End => Eq \| _ => Lt end.
	208
	209	(** The complete comparison *)
	210
	211	Definition compare s1 s2 := compare_cont s1 compare_end (cons s2 End).
	212
	213	Definition equal s1 s2 :=
	214	match compare s1 s2 with Eq => true \| _ => false end.
	215
	216	( Subset test *)
	217
	218	(** In ocaml, recursive calls are made on "half-trees" such as
	219	(Node _ l1 x1 Leaf) and (Node _ Leaf x1 r1). Instead of these
	220	non-structural calls, we propose here two specialized functions
	221	for these situations. This version should be almost as efficient
	222	as the one of ocaml (closures as arguments may slow things a bit),
	223	it is simply less compact. The exact ocaml version has also been
	224	formalized (thanks to Function+measure), see [ocaml_subset] in
	225	[MSetFullAVL].
	226	*)
	227
	228	Fixpoint subsetl (subset_l1 : tree -> bool) x1 s2 : bool :=
	229	match s2 with
	230	\| Leaf => false
	231	\| Node _ l2 x2 r2 =>
	232	match X.compare x1 x2 with
	233	\| Eq => subset_l1 l2
	234	\| Lt => subsetl subset_l1 x1 l2
	235	\| Gt => mem x1 r2 &&& subset_l1 s2
	236	end
	237	end.
	238
	239	Fixpoint subsetr (subset_r1 : tree -> bool) x1 s2 : bool :=
	240	match s2 with
	241	\| Leaf => false
	242	\| Node _ l2 x2 r2 =>
	243	match X.compare x1 x2 with
	244	\| Eq => subset_r1 r2
	245	\| Lt => mem x1 l2 &&& subset_r1 s2
	246	\| Gt => subsetr subset_r1 x1 r2
	247	end
	248	end.
	249
	250	Fixpoint subset s1 s2 : bool := match s1, s2 with
	251	\| Leaf, _ => true
	252	\| Node _ _ _ _, Leaf => false
	253	\| Node _ l1 x1 r1, Node _ l2 x2 r2 =>
	254	match X.compare x1 x2 with
	255	\| Eq => subset l1 l2 &&& subset r1 r2
	256	\| Lt => subsetl (subset l1) x1 l2 &&& subset r1 s2
	257	\| Gt => subsetr (subset r1) x1 r2 &&& subset l1 s2
	258	end
	259	end.
	260
	261	End Ops.
	262
	263	(** * Props : correctness proofs of these generic operations *)
	264
	265	Module Type Props (X:OrderedType)(Info:InfoTyp)(Import M:Ops X Info).
	266
	267	( Occurrence in a tree *)
	268
	269	Inductive InT (x : elt) : tree -> Prop :=
	270	\| IsRoot : forall c l r y, X.eq x y -> InT x (Node c l y r)
	271	\| InLeft : forall c l r y, InT x l -> InT x (Node c l y r)
	272	\| InRight : forall c l r y, InT x r -> InT x (Node c l y r).
	273
	274	Definition In := InT.
	275
	276	( Some shortcuts *)
	277
	278	Definition Equal s s' := forall a : elt, InT a s <-> InT a s'.
	279	Definition Subset s s' := forall a : elt, InT a s -> InT a s'.
	280	Definition Empty s := forall a : elt, ~ InT a s.
	281	Definition For_all (P : elt -> Prop) s := forall x, InT x s -> P x.
	282	Definition Exists (P : elt -> Prop) s := exists x, InT x s /\ P x.
	283
	284	( Binary search trees *)
	285
	286	(** [lt_tree x s]: all elements in [s] are smaller than [x]
	287	(resp. greater for [gt_tree]) *)
	288
	289	Definition lt_tree x s := forall y, InT y s -> X.lt y x.
	290	Definition gt_tree x s := forall y, InT y s -> X.lt x y.
	291
	292	(** [bst t] : [t] is a binary search tree *)
	293
	294	Inductive bst : tree -> Prop :=
	295	\| BSLeaf : bst Leaf
	296	\| BSNode : forall c x l r, bst l -> bst r ->
	297	lt_tree x l -> gt_tree x r -> bst (Node c l x r).
	298
	299	(** [bst] is the (decidable) invariant our trees will have to satisfy. *)
	300
	301	Definition IsOk := bst.
	302
	303	Class Ok (s:tree) : Prop := ok : bst s.
	304
	305	Instance bst_Ok s (Hs : bst s) : Ok s := { ok := Hs }.
	306
	307	Fixpoint ltb_tree x s :=
	308	match s with
	309	\| Leaf => true
	310	\| Node _ l y r =>
	311	match X.compare x y with
	312	\| Gt => ltb_tree x l && ltb_tree x r
	313	\| _ => false
	314	end
	315	end.
	316
	317	Fixpoint gtb_tree x s :=
	318	match s with
	319	\| Leaf => true
	320	\| Node _ l y r =>
	321	match X.compare x y with
	322	\| Lt => gtb_tree x l && gtb_tree x r
	323	\| _ => false
	324	end
	325	end.
	326
	327	Fixpoint isok s :=
	328	match s with
	329	\| Leaf => true
	330	\| Node _ l x r => isok l && isok r && ltb_tree x l && gtb_tree x r
	331	end.
	332
	333
	334	( Known facts about ordered types *)
	335
	336	Module Import MX := OrderedTypeFacts X.
	337
	338	( Automation and dedicated tactics *)
	339
	340	Scheme tree_ind := Induction for tree Sort Prop.
	341	Scheme bst_ind := Induction for bst Sort Prop.
	342
	343	Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans @ok.
	344	Local Hint Immediate MX.eq_sym.
	345	Local Hint Unfold In lt_tree gt_tree.
	346	Local Hint Constructors InT bst.
	347	Local Hint Unfold Ok.
	348
	349	(** Automatic treatment of [Ok] hypothesis *)
	350
	351	Ltac clear_inversion H := inversion H; clear H; subst.
	352
	353	Ltac inv_ok := match goal with
	354	\| H:Ok (Node _ _ _ _) \|- _ => clear_inversion H; inv_ok
	355	\| H:Ok Leaf \|- _ => clear H; inv_ok
	356	\| H:bst ?x \|- _ => change (Ok x) in H; inv_ok
	357	\| _ => idtac
	358	end.
	359
	360	(** A tactic to repeat [inversion_clear] on all hyps of the
	361	form [(f (Node _ _ _ _))] *)
	362
	363	Ltac is_tree_constr c :=
	364	match c with
	365	\| Leaf => idtac
	366	\| Node _ _ _ _ => idtac
	367	\| _ => fail
	368	end.
	369
	370	Ltac invtree f :=
	371	match goal with
	372	\| H:f ?s \|- _ => is_tree_constr s; clear_inversion H; invtree f
	373	\| H:f _ ?s \|- _ => is_tree_constr s; clear_inversion H; invtree f
	374	\| H:f _ _ ?s \|- _ => is_tree_constr s; clear_inversion H; invtree f
	375	\| _ => idtac
	376	end.
	377
	378	Ltac inv := inv_ok; invtree InT.
	379
	380	Ltac intuition_in := repeat progress (intuition; inv).
	381
	382	(** Helper tactic concerning order of elements. *)
	383
	384	Ltac order := match goal with
	385	\| U: lt_tree _ ?s, V: InT _ ?s \|- _ => generalize (U _ V); clear U; order
	386	\| U: gt_tree _ ?s, V: InT _ ?s \|- _ => generalize (U _ V); clear U; order
	387	\| _ => MX.order
	388	end.
	389
	390
	391	(** [isok] is indeed a decision procedure for [Ok] *)
	392
	393	Lemma ltb_tree_iff : forall x s, lt_tree x s <-> ltb_tree x s = true.
	394	Proof.
	395	induction s as [\|c l IHl y r IHr]; simpl.
	396	unfold lt_tree; intuition_in.
	397	elim_compare x y.
	398	split; intros; try discriminate. assert (X.lt y x) by auto. order.
	399	split; intros; try discriminate. assert (X.lt y x) by auto. order.
	400	rewrite !andb_true_iff, <-IHl, <-IHr.
	401	unfold lt_tree; intuition_in; order.
	402	Qed.
	403
	404	Lemma gtb_tree_iff : forall x s, gt_tree x s <-> gtb_tree x s = true.
	405	Proof.
	406	induction s as [\|c l IHl y r IHr]; simpl.
	407	unfold gt_tree; intuition_in.
	408	elim_compare x y.
	409	split; intros; try discriminate. assert (X.lt x y) by auto. order.
	410	rewrite !andb_true_iff, <-IHl, <-IHr.
	411	unfold gt_tree; intuition_in; order.
	412	split; intros; try discriminate. assert (X.lt x y) by auto. order.
	413	Qed.
	414
	415	Lemma isok_iff : forall s, Ok s <-> isok s = true.
	416	Proof.
	417	induction s as [\|c l IHl y r IHr]; simpl.
	418	intuition_in.
	419	rewrite !andb_true_iff, <- IHl, <-IHr, <- ltb_tree_iff, <- gtb_tree_iff.
	420	intuition_in.
	421	Qed.
	422
	423	Instance isok_Ok s : isok s = true -> Ok s \| 10.
	424	Proof. intros; apply <- isok_iff; auto. Qed.
	425
	426	( Basic results about [In] *)
	427
	428	Lemma In_1 :
	429	forall s x y, X.eq x y -> InT x s -> InT y s.
	430	Proof.
	431	induction s; simpl; intuition_in; eauto.
	432	Qed.
	433	Local Hint Immediate In_1.
	434
	435	Instance In_compat : Proper (X.eq==>eq==>iff) InT.
	436	Proof.
	437	apply proper_sym_impl_iff_2; auto with *.
	438	repeat red; intros; subst. apply In_1 with x; auto.
	439	Qed.
	440
	441	Lemma In_node_iff :
	442	forall c l x r y,
	443	InT y (Node c l x r) <-> InT y l \/ X.eq y x \/ InT y r.
	444	Proof.
	445	intuition_in.
	446	Qed.
	447
	448	Lemma In_leaf_iff : forall x, InT x Leaf <-> False.
	449	Proof.
	450	intuition_in.
	451	Qed.
	452
	453	(** Results about [lt_tree] and [gt_tree] *)
	454
	455	Lemma lt_leaf : forall x : elt, lt_tree x Leaf.
	456	Proof.
	457	red; inversion 1.
	458	Qed.
	459
	460	Lemma gt_leaf : forall x : elt, gt_tree x Leaf.
	461	Proof.
	462	red; inversion 1.
	463	Qed.
	464
	465	Lemma lt_tree_node :
	466	forall (x y : elt) (l r : tree) (i : Info.t),
	467	lt_tree x l -> lt_tree x r -> X.lt y x -> lt_tree x (Node i l y r).
	468	Proof.
	469	unfold lt_tree; intuition_in; order.
	470	Qed.
	471
	472	Lemma gt_tree_node :
	473	forall (x y : elt) (l r : tree) (i : Info.t),
	474	gt_tree x l -> gt_tree x r -> X.lt x y -> gt_tree x (Node i l y r).
	475	Proof.
	476	unfold gt_tree; intuition_in; order.
	477	Qed.
	478
	479	Local Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node.
	480
	481	Lemma lt_tree_not_in :
	482	forall (x : elt) (t : tree), lt_tree x t -> ~ InT x t.
	483	Proof.
	484	intros; intro; order.
	485	Qed.
	486
	487	Lemma lt_tree_trans :
	488	forall x y, X.lt x y -> forall t, lt_tree x t -> lt_tree y t.
	489	Proof.
	490	eauto.
	491	Qed.
	492
	493	Lemma gt_tree_not_in :
	494	forall (x : elt) (t : tree), gt_tree x t -> ~ InT x t.
	495	Proof.
	496	intros; intro; order.
	497	Qed.
	498
	499	Lemma gt_tree_trans :
	500	forall x y, X.lt y x -> forall t, gt_tree x t -> gt_tree y t.
	501	Proof.
	502	eauto.
	503	Qed.
	504
	505	Instance lt_tree_compat : Proper (X.eq ==> Logic.eq ==> iff) lt_tree.
	506	Proof.
	507	apply proper_sym_impl_iff_2; auto.
	508	intros x x' Hx s s' Hs H y Hy. subst. setoid_rewrite <- Hx; auto.
	509	Qed.
	510
	511	Instance gt_tree_compat : Proper (X.eq ==> Logic.eq ==> iff) gt_tree.
	512	Proof.
	513	apply proper_sym_impl_iff_2; auto.
	514	intros x x' Hx s s' Hs H y Hy. subst. setoid_rewrite <- Hx; auto.
	515	Qed.
	516
	517	Local Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans.
	518
	519	Ltac induct s x :=
	520	induction s as [\|i l IHl x' r IHr]; simpl; intros;
	521	[\|elim_compare x x'; intros; inv].
	522
	523	Ltac auto_tc := auto with typeclass_instances.
	524
	525	Ltac ok :=
	526	inv; change bst with Ok in *;
	527	match goal with
	528	\| \|- Ok (Node _ _ _ _) => constructor; auto_tc; ok
	529	\| \|- lt_tree _ (Node _ _ _ _) => apply lt_tree_node; ok
	530	\| \|- gt_tree _ (Node _ _ _ _) => apply gt_tree_node; ok
	531	\| _ => eauto with typeclass_instances
	532	end.
	533
	534	( Empty set *)
	535
	536	Lemma empty_spec : Empty empty.
	537	Proof.
	538	intros x H. inversion H.
	539	Qed.
	540
	541	Instance empty_ok : Ok empty.
	542	Proof.
	543	auto.
	544	Qed.
	545
	546	( Emptyness test *)
	547
	548	Lemma is_empty_spec : forall s, is_empty s = true <-> Empty s.
	549	Proof.
	550	destruct s as [\|c r x l]; simpl; auto.
	551	- split; auto. intros _ x H. inv.
	552	- split; auto. try discriminate. intro H; elim (H x); auto.
	553	Qed.
	554
	555	( Membership *)
	556
	557	Lemma mem_spec : forall s x `{Ok s}, mem x s = true <-> InT x s.
	558	Proof.
	559	split.
	560	- induct s x; now auto.
	561	- induct s x; intuition_in; order.
	562	Qed.
	563
	564	( Minimal and maximal elements *)
	565
	566	Functional Scheme min_elt_ind := Induction for min_elt Sort Prop.
	567	Functional Scheme max_elt_ind := Induction for max_elt Sort Prop.
	568
	569	Lemma min_elt_spec1 s x : min_elt s = Some x -> InT x s.
	570	Proof.
	571	functional induction (min_elt s); auto; inversion 1; auto.
	572	Qed.
	573
	574	Lemma min_elt_spec2 s x y `{Ok s} :
	575	min_elt s = Some x -> InT y s -> ~ X.lt y x.
	576	Proof.
	577	revert y.
	578	functional induction (min_elt s);
	579	try rename _x0 into r; try rename _x2 into l1, _x3 into x1, _x4 into r1.
	580	- discriminate.
	581	- intros y V W.
	582	inversion V; clear V; subst.
	583	inv; order.
	584	- intros; inv; auto.
	585	* assert (X.lt x x0) by (apply H8; apply min_elt_spec1; auto).
	586	order.
	587	* assert (X.lt x1 x0) by auto.
	588	assert (~X.lt x1 x) by auto.
	589	order.
	590	Qed.
	591
	592	Lemma min_elt_spec3 s : min_elt s = None -> Empty s.
	593	Proof.
	594	functional induction (min_elt s).
	595	red; red; inversion 2.
	596	inversion 1.
	597	intro H0.
	598	destruct (IHo H0 _x3); auto.
	599	Qed.
	600
	601	Lemma max_elt_spec1 s x : max_elt s = Some x -> InT x s.
	602	Proof.
	603	functional induction (max_elt s); auto; inversion 1; auto.
	604	Qed.
	605
	606	Lemma max_elt_spec2 s x y `{Ok s} :
	607	max_elt s = Some x -> InT y s -> ~ X.lt x y.
	608	Proof.
	609	revert y.
	610	functional induction (max_elt s);
	611	try rename _x0 into r; try rename _x2 into l1, _x3 into x1, _x4 into r1.
	612	- discriminate.
	613	- intros y V W.
	614	inversion V; clear V; subst.
	615	inv; order.
	616	- intros; inv; auto.
	617	* assert (X.lt x0 x) by (apply H9; apply max_elt_spec1; auto).
	618	order.
	619	* assert (X.lt x0 x1) by auto.
	620	assert (~X.lt x x1) by auto.
	621	order.
	622	Qed.
	623
	624	Lemma max_elt_spec3 s : max_elt s = None -> Empty s.
	625	Proof.
	626	functional induction (max_elt s).
	627	red; red; inversion 2.
	628	inversion 1.
	629	intro H0.
	630	destruct (IHo H0 _x3); auto.
	631	Qed.
	632
	633	Lemma choose_spec1 : forall s x, choose s = Some x -> InT x s.
	634	Proof.
	635	exact min_elt_spec1.
	636	Qed.
	637
	638	Lemma choose_spec2 : forall s, choose s = None -> Empty s.
	639	Proof.
	640	exact min_elt_spec3.
	641	Qed.
	642
	643	Lemma choose_spec3 : forall s s' x x' `{Ok s, Ok s'},
	644	choose s = Some x -> choose s' = Some x' ->
	645	Equal s s' -> X.eq x x'.
	646	Proof.
	647	unfold choose, Equal; intros s s' x x' Hb Hb' Hx Hx' H.
	648	assert (~X.lt x x').
	649	apply min_elt_spec2 with s'; auto.
	650	rewrite <-H; auto using min_elt_spec1.
	651	assert (~X.lt x' x).
	652	apply min_elt_spec2 with s; auto.
	653	rewrite H; auto using min_elt_spec1.
	654	elim_compare x x'; intuition.
	655	Qed.
	656
	657	( Elements *)
	658
	659	Lemma elements_spec1' : forall s acc x,
	660	InA X.eq x (elements_aux acc s) <-> InT x s \/ InA X.eq x acc.
	661	Proof.
	662	induction s as [ \| c l Hl x r Hr ]; simpl; auto.
	663	intuition.
	664	inversion H0.
	665	intros.
	666	rewrite Hl.
	667	destruct (Hr acc x0); clear Hl Hr.
	668	intuition; inversion_clear H3; intuition.
	669	Qed.
	670
	671	Lemma elements_spec1 : forall s x, InA X.eq x (elements s) <-> InT x s.
	672	Proof.
	673	intros; generalize (elements_spec1' s nil x); intuition.
	674	inversion_clear H0.
	675	Qed.
	676
	677	Lemma elements_spec2' : forall s acc `{Ok s}, sort X.lt acc ->
	678	(forall x y : elt, InA X.eq x acc -> InT y s -> X.lt y x) ->
	679	sort X.lt (elements_aux acc s).
	680	Proof.
	681	induction s as [ \| c l Hl y r Hr]; simpl; intuition.
	682	inv.
	683	apply Hl; auto.
	684	constructor.
	685	apply Hr; auto.
	686	eapply InA_InfA; eauto with *.
	687	intros.
	688	destruct (elements_spec1' r acc y0); intuition.
	689	intros.
	690	inversion_clear H.
	691	order.
	692	destruct (elements_spec1' r acc x); intuition eauto.
	693	Qed.
	694
	695	Lemma elements_spec2 : forall s `(Ok s), sort X.lt (elements s).
	696	Proof.
	697	intros; unfold elements; apply elements_spec2'; auto.
	698	intros; inversion H0.
	699	Qed.
	700	Local Hint Resolve elements_spec2.
	701
	702	Lemma elements_spec2w : forall s `(Ok s), NoDupA X.eq (elements s).
	703	Proof.
	704	intros. eapply SortA_NoDupA; eauto with *.
	705	Qed.
	706
	707	Lemma elements_aux_cardinal :
	708	forall s acc, (length acc + cardinal s)%nat = length (elements_aux acc s).
	709	Proof.
	710	simple induction s; simpl; intuition.
	711	rewrite <- H.
	712	simpl.
	713	rewrite <- H0. rewrite (Nat.add_comm (cardinal t0)).
	714	now rewrite <- Nat.add_succ_r, Nat.add_assoc.
	715	Qed.
	716
	717	Lemma elements_cardinal : forall s : tree, cardinal s = length (elements s).
	718	Proof.
	719	exact (fun s => elements_aux_cardinal s nil).
	720	Qed.
	721
	722	Definition cardinal_spec (s:tree)(Hs:Ok s) := elements_cardinal s.
	723
	724	Lemma elements_app :
	725	forall s acc, elements_aux acc s = elements s ++ acc.
	726	Proof.
	727	induction s; simpl; intros; auto.
	728	rewrite IHs1, IHs2.
	729	unfold elements; simpl.
	730	rewrite 2 IHs1, IHs2, !app_nil_r, !app_ass; auto.
	731	Qed.
	732
	733	Lemma elements_node c l x r :
	734	elements (Node c l x r) = elements l ++ x :: elements r.
	735	Proof.
	736	unfold elements; simpl.
	737	now rewrite !elements_app, !app_nil_r.
	738	Qed.
	739
	740	Lemma rev_elements_app :
	741	forall s acc, rev_elements_aux acc s = rev_elements s ++ acc.
	742	Proof.
	743	induction s; simpl; intros; auto.
	744	rewrite IHs1, IHs2.
	745	unfold rev_elements; simpl.
	746	rewrite IHs1, 2 IHs2, !app_nil_r, !app_ass; auto.
	747	Qed.
	748
	749	Lemma rev_elements_node c l x r :
	750	rev_elements (Node c l x r) = rev_elements r ++ x :: rev_elements l.
	751	Proof.
	752	unfold rev_elements; simpl.
	753	now rewrite !rev_elements_app, !app_nil_r.
	754	Qed.
	755
	756	Lemma rev_elements_rev s : rev_elements s = rev (elements s).
	757	Proof.
	758	induction s as [\|c l IHl x r IHr]; trivial.
	759	rewrite elements_node, rev_elements_node, IHl, IHr, rev_app_distr.
	760	simpl. now rewrite !app_ass.
	761	Qed.
	762
	763	(** The converse of [elements_spec2], used in MSetRBT *)
	764
	765	(* TODO: TO MIGRATE ELSEWHERE... *)
	766
	767	Lemma sorted_app_inv l1 l2 :
	768	sort X.lt (l1++l2) ->
	769	sort X.lt l1 /\ sort X.lt l2 /\
	770	forall x1 x2, InA X.eq x1 l1 -> InA X.eq x2 l2 -> X.lt x1 x2.
	771	Proof.
	772	induction l1 as [\|a1 l1 IHl1].
	773	- simpl; repeat split; auto.
	774	intros. now rewrite InA_nil in *.
	775	- simpl. inversion_clear 1 as [ \| ? ? Hs Hhd ].
	776	destruct (IHl1 Hs) as (H1 & H2 & H3).
	777	repeat split.
	778	* constructor; auto.
	779	destruct l1; simpl in *; auto; inversion_clear Hhd; auto.
	780	* trivial.
	781	* intros x1 x2 Hx1 Hx2. rewrite InA_cons in Hx1. destruct Hx1.
	782	+ rewrite H.
	783	apply SortA_InfA_InA with (eqA:=X.eq)(l:=l1++l2); auto_tc.
	784	rewrite InA_app_iff; auto_tc.
	785	+ auto.
	786	Qed.
	787
	788	Lemma elements_sort_ok s : sort X.lt (elements s) -> Ok s.
	789	Proof.
	790	induction s as [\|c l IHl x r IHr].
	791	- auto.
	792	- rewrite elements_node.
	793	intros H. destruct (sorted_app_inv _ _ H) as (H1 & H2 & H3).
	794	inversion_clear H2.
	795	constructor; ok.
	796	* intros y Hy. apply H3.
	797	+ now rewrite elements_spec1.
	798	+ rewrite InA_cons. now left.
	799	* intros y Hy.
	800	apply SortA_InfA_InA with (eqA:=X.eq)(l:=elements r); auto_tc.
	801	now rewrite elements_spec1.
	802	Qed.
	803
	804	( [for_all] and [exists] *)
	805
	806	Lemma for_all_spec s f : Proper (X.eq==>eq) f ->
	807	(for_all f s = true <-> For_all (fun x => f x = true) s).
	808	Proof.
	809	intros Hf; unfold For_all.
	810	induction s as [\|i l IHl x r IHr]; simpl; auto.
	811	- split; intros; inv; auto.
	812	- rewrite <- !andb_lazy_alt, !andb_true_iff, IHl, IHr. clear IHl IHr.
	813	intuition_in. eauto.
	814	Qed.
	815
	816	Lemma exists_spec s f : Proper (X.eq==>eq) f ->
	817	(exists_ f s = true <-> Exists (fun x => f x = true) s).
	818	Proof.
	819	intros Hf; unfold Exists.
	820	induction s as [\|i l IHl x r IHr]; simpl; auto.
	821	- split.
	822	* discriminate.
	823	* intros (y,(H,_)); inv.
	824	- rewrite <- !orb_lazy_alt, !orb_true_iff, IHl, IHr. clear IHl IHr.
	825	split; [intros [[H\|(y,(H,H'))]\|(y,(H,H'))]\|intros (y,(H,H'))].
	826	* exists x; auto.
	827	* exists y; auto.
	828	* exists y; auto.
	829	* inv; [left;left\|left;right\|right]; try (exists y); eauto.
	830	Qed.
	831
	832	( Fold *)
	833
	834	Lemma fold_spec' {A} (f : elt -> A -> A) (s : tree) (i : A) (acc : list elt) :
	835	fold_left (flip f) (elements_aux acc s) i = fold_left (flip f) acc (fold f s i).
	836	Proof.
	837	revert i acc.
	838	induction s as [\|c l IHl x r IHr]; simpl; intros; auto.
	839	rewrite IHl.
	840	simpl. unfold flip at 2.
	841	apply IHr.
	842	Qed.
	843
	844	Lemma fold_spec (s:tree) {A} (i : A) (f : elt -> A -> A) :
	845	fold f s i = fold_left (flip f) (elements s) i.
	846	Proof.
	847	revert i. unfold elements.
	848	induction s as [\|c l IHl x r IHr]; simpl; intros; auto.
	849	rewrite fold_spec'.
	850	rewrite IHr.
	851	simpl; auto.
	852	Qed.
	853
	854
	855	( Subset *)
	856
	857	Lemma subsetl_spec : forall subset_l1 l1 x1 c1 s2
	858	`{Ok (Node c1 l1 x1 Leaf), Ok s2},
	859	(forall s `{Ok s}, (subset_l1 s = true <-> Subset l1 s)) ->
	860	(subsetl subset_l1 x1 s2 = true <-> Subset (Node c1 l1 x1 Leaf) s2 ).
	861	Proof.
	862	induction s2 as [\|c2 l2 IHl2 x2 r2 IHr2]; simpl; intros.
	863	unfold Subset; intuition; try discriminate.
	864	assert (H': InT x1 Leaf) by auto; inversion H'.
	865	specialize (IHl2 H).
	866	specialize (IHr2 H).
	867	inv.
	868	elim_compare x1 x2.
	869
	870	rewrite H1 by auto; clear H1 IHl2 IHr2.
	871	unfold Subset. intuition_in.
	872	assert (X.eq a x2) by order; intuition_in.
	873	assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.
	874
	875	rewrite IHl2 by auto; clear H1 IHl2 IHr2.
	876	unfold Subset. intuition_in.
	877	assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.
	878	assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.
	879
	880	rewrite <-andb_lazy_alt, andb_true_iff, H1 by auto; clear H1 IHl2 IHr2.
	881	unfold Subset. intuition_in.
	882	constructor 3. setoid_replace a with x1; auto. rewrite <- mem_spec; auto.
	883	rewrite mem_spec; auto.
	884	assert (InT x1 (Node c2 l2 x2 r2)) by auto; intuition_in; order.
	885	Qed.
	886
	887
	888	Lemma subsetr_spec : forall subset_r1 r1 x1 c1 s2,
	889	bst (Node c1 Leaf x1 r1) -> bst s2 ->
	890	(forall s, bst s -> (subset_r1 s = true <-> Subset r1 s)) ->
	891	(subsetr subset_r1 x1 s2 = true <-> Subset (Node c1 Leaf x1 r1) s2).
	892	Proof.
	893	induction s2 as [\|c2 l2 IHl2 x2 r2 IHr2]; simpl; intros.
	894	unfold Subset; intuition; try discriminate.
	895	assert (H': InT x1 Leaf) by auto; inversion H'.
	896	specialize (IHl2 H).
	897	specialize (IHr2 H).
	898	inv.
	899	elim_compare x1 x2.
	900
	901	rewrite H1 by auto; clear H1 IHl2 IHr2.
	902	unfold Subset. intuition_in.
	903	assert (X.eq a x2) by order; intuition_in.
	904	assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.
	905
	906	rewrite <-andb_lazy_alt, andb_true_iff, H1 by auto; clear H1 IHl2 IHr2.
	907	unfold Subset. intuition_in.
	908	constructor 2. setoid_replace a with x1; auto. rewrite <- mem_spec; auto.
	909	rewrite mem_spec; auto.
	910	assert (InT x1 (Node c2 l2 x2 r2)) by auto; intuition_in; order.
	911
	912	rewrite IHr2 by auto; clear H1 IHl2 IHr2.
	913	unfold Subset. intuition_in.
	914	assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.
	915	assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.
	916	Qed.
	917
	918	Lemma subset_spec : forall s1 s2 `{Ok s1, Ok s2},
	919	(subset s1 s2 = true <-> Subset s1 s2).
	920	Proof.
	921	induction s1 as [\|c1 l1 IHl1 x1 r1 IHr1]; simpl; intros.
	922	unfold Subset; intuition_in.
	923	destruct s2 as [\|c2 l2 x2 r2]; simpl; intros.
	924	unfold Subset; intuition_in; try discriminate.
	925	assert (H': InT x1 Leaf) by auto; inversion H'.
	926	inv.
	927	elim_compare x1 x2.
	928
	929	rewrite <-andb_lazy_alt, andb_true_iff, IHl1, IHr1 by auto.
	930	clear IHl1 IHr1.
	931	unfold Subset; intuition_in.
	932	assert (X.eq a x2) by order; intuition_in.
	933	assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.
	934	assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.
	935
	936	rewrite <-andb_lazy_alt, andb_true_iff, IHr1 by auto.
	937	rewrite (@subsetl_spec (subset l1) l1 x1 c1) by auto.
	938	clear IHl1 IHr1.
	939	unfold Subset; intuition_in.
	940	assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.
	941	assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.
	942
	943	rewrite <-andb_lazy_alt, andb_true_iff, IHl1 by auto.
	944	rewrite (@subsetr_spec (subset r1) r1 x1 c1) by auto.
	945	clear IHl1 IHr1.
	946	unfold Subset; intuition_in.
	947	assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.
	948	assert (InT a (Node c2 l2 x2 r2)) by auto; intuition_in; order.
	949	Qed.
	950
	951
	952	( Comparison *)
	953
	954	(** Relations [eq] and [lt] over trees *)
	955
	956	Module L := MSetInterface.MakeListOrdering X.
	957
	958	Definition eq := Equal.
	959	Instance eq_equiv : Equivalence eq.
	960	Proof. firstorder. Qed.
	961
	962	Lemma eq_Leq : forall s s', eq s s' <-> L.eq (elements s) (elements s').
	963	Proof.
	964	unfold eq, Equal, L.eq; intros.
	965	setoid_rewrite elements_spec1; firstorder.
	966	Qed.
	967
	968	Definition lt (s1 s2 : tree) : Prop :=
	969	exists s1' s2', Ok s1' /\ Ok s2' /\ eq s1 s1' /\ eq s2 s2'
	970	/\ L.lt (elements s1') (elements s2').
	971
	972	Instance lt_strorder : StrictOrder lt.
	973	Proof.
	974	split.
	975	intros s (s1 & s2 & B1 & B2 & E1 & E2 & L).
	976	assert (eqlistA X.eq (elements s1) (elements s2)).
	977	apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto with *.
	978	rewrite <- eq_Leq. transitivity s; auto. symmetry; auto.
	979	rewrite H in L.
	980	apply (StrictOrder_Irreflexive (elements s2)); auto.
	981	intros s1 s2 s3 (s1' & s2' & B1 & B2 & E1 & E2 & L12)
	982	(s2'' & s3' & B2' & B3 & E2' & E3 & L23).
	983	exists s1', s3'; do 4 (split; trivial).
	984	assert (eqlistA X.eq (elements s2') (elements s2'')).
	985	apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto with *.
	986	rewrite <- eq_Leq. transitivity s2; auto. symmetry; auto.
	987	transitivity (elements s2'); auto.
	988	rewrite H; auto.
	989	Qed.
	990
	991	Instance lt_compat : Proper (eq==>eq==>iff) lt.
	992	Proof.
	993	intros s1 s2 E12 s3 s4 E34. split.
	994	intros (s1' & s3' & B1 & B3 & E1 & E3 & LT).
	995	exists s1', s3'; do 2 (split; trivial).
	996	split. transitivity s1; auto. symmetry; auto.
	997	split; auto. transitivity s3; auto. symmetry; auto.
	998	intros (s1' & s3' & B1 & B3 & E1 & E3 & LT).
	999	exists s1', s3'; do 2 (split; trivial).
	1000	split. transitivity s2; auto.
	1001	split; auto. transitivity s4; auto.
	1002	Qed.
	1003
	1004
	1005	(** Proof of the comparison algorithm *)
	1006
	1007	(** [flatten_e e] returns the list of elements of [e] i.e. the list
	1008	of elements actually compared *)
	1009
	1010	Fixpoint flatten_e (e : enumeration) : list elt := match e with
	1011	\| End => nil
	1012	\| More x t r => x :: elements t ++ flatten_e r
	1013	end.
	1014
	1015	Lemma flatten_e_elements :
	1016	forall l x r c e,
	1017	elements l ++ flatten_e (More x r e) = elements (Node c l x r) ++ flatten_e e.
	1018	Proof.
	1019	intros; simpl. now rewrite elements_node, app_ass.
	1020	Qed.
	1021
	1022	Lemma cons_1 : forall s e,
	1023	flatten_e (cons s e) = elements s ++ flatten_e e.
	1024	Proof.
	1025	induction s; simpl; auto; intros.
	1026	rewrite IHs1; apply flatten_e_elements.
	1027	Qed.
	1028
	1029	(** Correctness of this comparison *)
	1030
	1031	Definition Cmp c x y := CompSpec L.eq L.lt x y c.
	1032
	1033	Local Hint Unfold Cmp flip.
	1034
	1035	Lemma compare_end_Cmp :
	1036	forall e2, Cmp (compare_end e2) nil (flatten_e e2).
	1037	Proof.
	1038	destruct e2; simpl; constructor; auto. reflexivity.
	1039	Qed.
	1040
	1041	Lemma compare_more_Cmp : forall x1 cont x2 r2 e2 l,
	1042	Cmp (cont (cons r2 e2)) l (elements r2 ++ flatten_e e2) ->
	1043	Cmp (compare_more x1 cont (More x2 r2 e2)) (x1::l)
	1044	(flatten_e (More x2 r2 e2)).
	1045	Proof.
	1046	simpl; intros; elim_compare x1 x2; simpl; red; auto.
	1047	Qed.
	1048
	1049	Lemma compare_cont_Cmp : forall s1 cont e2 l,
	1050	(forall e, Cmp (cont e) l (flatten_e e)) ->
	1051	Cmp (compare_cont s1 cont e2) (elements s1 ++ l) (flatten_e e2).
	1052	Proof.
	1053	induction s1 as [\|c1 l1 Hl1 x1 r1 Hr1]; simpl; intros; auto.
	1054	rewrite elements_node, app_ass; simpl.
	1055	apply Hl1; auto. clear e2. intros [\|x2 r2 e2].
	1056	simpl; auto.
	1057	apply compare_more_Cmp.
	1058	rewrite <- cons_1; auto.
	1059	Qed.
	1060
	1061	Lemma compare_Cmp : forall s1 s2,
	1062	Cmp (compare s1 s2) (elements s1) (elements s2).
	1063	Proof.
	1064	intros; unfold compare.
	1065	rewrite (app_nil_end (elements s1)).
	1066	replace (elements s2) with (flatten_e (cons s2 End)) by
	1067	(rewrite cons_1; simpl; rewrite <- app_nil_end; auto).
	1068	apply compare_cont_Cmp; auto.
	1069	intros.
	1070	apply compare_end_Cmp; auto.
	1071	Qed.
	1072
	1073	Lemma compare_spec : forall s1 s2 `{Ok s1, Ok s2},
	1074	CompSpec eq lt s1 s2 (compare s1 s2).
	1075	Proof.
	1076	intros.
	1077	destruct (compare_Cmp s1 s2); constructor.
	1078	rewrite eq_Leq; auto.
	1079	intros; exists s1, s2; repeat split; auto.
	1080	intros; exists s2, s1; repeat split; auto.
	1081	Qed.
	1082
	1083
	1084	( Equality test *)
	1085
	1086	Lemma equal_spec : forall s1 s2 `{Ok s1, Ok s2},
	1087	equal s1 s2 = true <-> eq s1 s2.
	1088	Proof.
	1089	unfold equal; intros s1 s2 B1 B2.
	1090	destruct (@compare_spec s1 s2 B1 B2) as [H\|H\|H];
	1091	split; intros H'; auto; try discriminate.
	1092	rewrite H' in H. elim (StrictOrder_Irreflexive s2); auto.
	1093	rewrite H' in H. elim (StrictOrder_Irreflexive s2); auto.
	1094	Qed.
	1095
	1096	( A few results about [mindepth] and [maxdepth] *)
	1097
	1098	Lemma mindepth_maxdepth s : mindepth s <= maxdepth s.
	1099	Proof.
	1100	induction s; simpl; auto.
	1101	rewrite <- Nat.succ_le_mono.
	1102	transitivity (mindepth s1). apply Nat.le_min_l.
	1103	transitivity (maxdepth s1). trivial. apply Nat.le_max_l.
	1104	Qed.
	1105
	1106	Lemma maxdepth_cardinal s : cardinal s < 2^(maxdepth s).
	1107	Proof.
	1108	unfold Peano.lt.
	1109	induction s as [\|c l IHl x r IHr].
	1110	- auto.
	1111	- simpl. rewrite <- Nat.add_succ_r, <- Nat.add_succ_l, Nat.add_0_r.
	1112	apply Nat.add_le_mono; etransitivity;
	1113	try apply IHl; try apply IHr; apply Nat.pow_le_mono; auto.
	1114	* apply Nat.le_max_l.
	1115	* apply Nat.le_max_r.
	1116	Qed.
	1117
	1118	Lemma mindepth_cardinal s : 2^(mindepth s) <= S (cardinal s).
	1119	Proof.
	1120	unfold Peano.lt.
	1121	induction s as [\|c l IHl x r IHr].
	1122	- auto.
	1123	- simpl. rewrite <- Nat.add_succ_r, <- Nat.add_succ_l, Nat.add_0_r.
	1124	apply Nat.add_le_mono; etransitivity;
	1125	try apply IHl; try apply IHr; apply Nat.pow_le_mono; auto.
	1126	* apply Nat.le_min_l.
	1127	* apply Nat.le_min_r.
	1128	Qed.
	1129
	1130	Lemma maxdepth_log_cardinal s : s <> Leaf ->
	1131	log2 (cardinal s) < maxdepth s.
	1132	Proof.
	1133	intros H.
	1134	apply Nat.log2_lt_pow2. destruct s; simpl; intuition.
	1135	apply maxdepth_cardinal.
	1136	Qed.
	1137
	1138	Lemma mindepth_log_cardinal s : mindepth s <= log2 (S (cardinal s)).
	1139	Proof.
	1140	apply Nat.log2_le_pow2. auto with arith.
	1141	apply mindepth_cardinal.
	1142	Qed.
	1143
	1144	End Props.⏎

+1931

-0

theories/MSets/MSetRBT.v less more

	0	(***********************************************************************)
	1	(* v * The Coq Proof Assistant / The Coq Development Team *)
	2	(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *)
	3	(* \VV/ *************************************************************)
	4	(* // * This file is distributed under the terms of the *)
	5	(* * GNU Lesser General Public License Version 2.1 *)
	6	(***********************************************************************)
	7
	8	(** * MSetRBT : Implementation of MSetInterface via Red-Black trees *)
	9
	10	(** Initial author: Andrew W. Appel, 2011.
	11	Extra modifications by: Pierre Letouzey
	12
	13	The design decisions behind this implementation are described here:
	14
	15	- Efficient Verified Red-Black Trees, by Andrew W. Appel, September 2011.
	16	http://www.cs.princeton.edu/~appel/papers/redblack.pdf
	17
	18	Additional suggested reading:
	19
	20	- Red-Black Trees in a Functional Setting by Chris Okasaki.
	21	Journal of Functional Programming, 9(4):471-477, July 1999.
	22	http://www.eecs.usma.edu/webs/people/okasaki/jfp99redblack.pdf
	23
	24	- Red-black trees with types, by Stefan Kahrs.
	25	Journal of Functional Programming, 11(4), 425-432, 2001.
	26
	27	- Functors for Proofs and Programs, by J.-C. Filliatre and P. Letouzey.
	28	ESOP'04: European Symposium on Programming, pp. 370-384, 2004.
	29	http://www.lri.fr/~filliatr/ftp/publis/fpp.ps.gz
	30	*)
	31
	32	Require MSetGenTree.
	33	Require Import Bool List BinPos Pnat Setoid SetoidList NPeano Psatz.
	34	Local Open Scope list_scope.
	35
	36	(* For nicer extraction, we create induction principles
	37	only when needed *)
	38	Local Unset Elimination Schemes.
	39	Local Unset Case Analysis Schemes.
	40
	41	(** An extra function not (yet?) in MSetInterface.S *)
	42
	43	Module Type MSetRemoveMin (Import M:MSetInterface.S).
	44
	45	Parameter remove_min : t -> option (elt * t).
	46
	47	Axiom remove_min_spec1 : forall s k s',
	48	remove_min s = Some (k,s') ->
	49	min_elt s = Some k /\ remove k s [=] s'.
	50
	51	Axiom remove_min_spec2 : forall s, remove_min s = None -> Empty s.
	52
	53	End MSetRemoveMin.
	54
	55	(** The type of color annotation. *)
	56
	57	Inductive color := Red \| Black.
	58
	59	Module Color.
	60	Definition t := color.
	61	End Color.
	62
	63	(** * Ops : the pure functions *)
	64
	65	Module Ops (X:Orders.OrderedType) <: MSetInterface.Ops X.
	66
	67	( Generic trees instantiated with color *)
	68
	69	(** We reuse a generic definition of trees where the information
	70	parameter is a color. Functions like mem or fold are also
	71	provided by this generic functor. *)
	72
	73	Include MSetGenTree.Ops X Color.
	74
	75	Definition t := tree.
	76	Local Notation Rd := (Node Red).
	77	Local Notation Bk := (Node Black).
	78
	79	( Basic tree *)
	80
	81	Definition singleton (k: elt) : tree := Bk Leaf k Leaf.
	82
	83	( Changing root color *)
	84
	85	Definition makeBlack t :=
	86	match t with
	87	\| Leaf => Leaf
	88	\| Node _ a x b => Bk a x b
	89	end.
	90
	91	Definition makeRed t :=
	92	match t with
	93	\| Leaf => Leaf
	94	\| Node _ a x b => Rd a x b
	95	end.
	96
	97	( Balancing *)
	98
	99	(** We adapt when one side is not a true red-black tree.
	100	Both sides have the same black depth. *)
	101
	102	Definition lbal l k r :=
	103	match l with
	104	\| Rd (Rd a x b) y c => Rd (Bk a x b) y (Bk c k r)
	105	\| Rd a x (Rd b y c) => Rd (Bk a x b) y (Bk c k r)
	106	\| _ => Bk l k r
	107	end.
	108
	109	Definition rbal l k r :=
	110	match r with
	111	\| Rd (Rd b y c) z d => Rd (Bk l k b) y (Bk c z d)
	112	\| Rd b y (Rd c z d) => Rd (Bk l k b) y (Bk c z d)
	113	\| _ => Bk l k r
	114	end.
	115
	116	(** A variant of [rbal], with reverse pattern order.
	117	Is it really useful ? Should we always use it ? *)
	118
	119	Definition rbal' l k r :=
	120	match r with
	121	\| Rd b y (Rd c z d) => Rd (Bk l k b) y (Bk c z d)
	122	\| Rd (Rd b y c) z d => Rd (Bk l k b) y (Bk c z d)
	123	\| _ => Bk l k r
	124	end.
	125
	126	(** Balancing with different black depth.
	127	One side is almost a red-black tree, while the other is
	128	a true red-black tree, but with black depth + 1.
	129	Used in deletion. *)
	130
	131	Definition lbalS l k r :=
	132	match l with
	133	\| Rd a x b => Rd (Bk a x b) k r
	134	\| _ =>
	135	match r with
	136	\| Bk a y b => rbal' l k (Rd a y b)
	137	\| Rd (Bk a y b) z c => Rd (Bk l k a) y (rbal' b z (makeRed c))
	138	\| _ => Rd l k r (* impossible *)
	139	end
	140	end.
	141
	142	Definition rbalS l k r :=
	143	match r with
	144	\| Rd b y c => Rd l k (Bk b y c)
	145	\| _ =>
	146	match l with
	147	\| Bk a x b => lbal (Rd a x b) k r
	148	\| Rd a x (Bk b y c) => Rd (lbal (makeRed a) x b) y (Bk c k r)
	149	\| _ => Rd l k r (* impossible *)
	150	end
	151	end.
	152
	153	( Insertion *)
	154
	155	Fixpoint ins x s :=
	156	match s with
	157	\| Leaf => Rd Leaf x Leaf
	158	\| Node c l y r =>
	159	match X.compare x y with
	160	\| Eq => s
	161	\| Lt =>
	162	match c with
	163	\| Red => Rd (ins x l) y r
	164	\| Black => lbal (ins x l) y r
	165	end
	166	\| Gt =>
	167	match c with
	168	\| Red => Rd l y (ins x r)
	169	\| Black => rbal l y (ins x r)
	170	end
	171	end
	172	end.
	173
	174	Definition add x s := makeBlack (ins x s).
	175
	176	( Deletion *)
	177
	178	Fixpoint append (l:tree) : tree -> tree :=
	179	match l with
	180	\| Leaf => fun r => r
	181	\| Node lc ll lx lr =>
	182	fix append_l (r:tree) : tree :=
	183	match r with
	184	\| Leaf => l
	185	\| Node rc rl rx rr =>
	186	match lc, rc with
	187	\| Red, Red =>
	188	let lrl := append lr rl in
	189	match lrl with
	190	\| Rd lr' x rl' => Rd (Rd ll lx lr') x (Rd rl' rx rr)
	191	\| _ => Rd ll lx (Rd lrl rx rr)
	192	end
	193	\| Black, Black =>
	194	let lrl := append lr rl in
	195	match lrl with
	196	\| Rd lr' x rl' => Rd (Bk ll lx lr') x (Bk rl' rx rr)
	197	\| _ => lbalS ll lx (Bk lrl rx rr)
	198	end
	199	\| Black, Red => Rd (append_l rl) rx rr
	200	\| Red, Black => Rd ll lx (append lr r)
	201	end
	202	end
	203	end.
	204
	205	Fixpoint del x t :=
	206	match t with
	207	\| Leaf => Leaf
	208	\| Node _ a y b =>
	209	match X.compare x y with
	210	\| Eq => append a b
	211	\| Lt =>
	212	match a with
	213	\| Bk _ _ _ => lbalS (del x a) y b
	214	\| _ => Rd (del x a) y b
	215	end
	216	\| Gt =>
	217	match b with
	218	\| Bk _ _ _ => rbalS a y (del x b)
	219	\| _ => Rd a y (del x b)
	220	end
	221	end
	222	end.
	223
	224	Definition remove x t := makeBlack (del x t).
	225
	226	( Removing minimal element *)
	227
	228	Fixpoint delmin l x r : (elt * tree) :=
	229	match l with
	230	\| Leaf => (x,r)
	231	\| Node lc ll lx lr =>
	232	let (k,l') := delmin ll lx lr in
	233	match lc with
	234	\| Black => (k, lbalS l' x r)
	235	\| Red => (k, Rd l' x r)
	236	end
	237	end.
	238
	239	Definition remove_min t : option (elt * tree) :=
	240	match t with
	241	\| Leaf => None
	242	\| Node _ l x r =>
	243	let (k,t) := delmin l x r in
	244	Some (k, makeBlack t)
	245	end.
	246
	247	( Tree-ification
	248
	249	We rebuild a tree of size [if pred then n-1 else n] as soon
	250	as the list [l] has enough elements *)
	251
	252	Definition bogus : tree * list elt := (Leaf, nil).
	253
	254	Notation treeify_t := (list elt -> tree * list elt).
	255
	256	Definition treeify_zero : treeify_t :=
	257	fun acc => (Leaf,acc).
	258
	259	Definition treeify_one : treeify_t :=
	260	fun acc => match acc with
	261	\| x::acc => (Rd Leaf x Leaf, acc)
	262	\| _ => bogus
	263	end.
	264
	265	Definition treeify_cont (f g : treeify_t) : treeify_t :=
	266	fun acc =>
	267	match f acc with
	268	\| (l, x::acc) =>
	269	match g acc with
	270	\| (r, acc) => (Bk l x r, acc)
	271	end
	272	\| _ => bogus
	273	end.
	274
	275	Fixpoint treeify_aux (pred:bool)(n: positive) : treeify_t :=
	276	match n with
	277	\| xH => if pred then treeify_zero else treeify_one
	278	\| xO n => treeify_cont (treeify_aux pred n) (treeify_aux true n)
	279	\| xI n => treeify_cont (treeify_aux false n) (treeify_aux pred n)
	280	end.
	281
	282	Fixpoint plength (l:list elt) := match l with
	283	\| nil => 1%positive
	284	\| _::l => Psucc (plength l)
	285	end.
	286
	287	Definition treeify (l:list elt) :=
	288	fst (treeify_aux true (plength l) l).
	289
	290	( Filtering *)
	291
	292	Fixpoint filter_aux (f: elt -> bool) s acc :=
	293	match s with
	294	\| Leaf => acc
	295	\| Node _ l k r =>
	296	let acc := filter_aux f r acc in
	297	if f k then filter_aux f l (k::acc)
	298	else filter_aux f l acc
	299	end.
	300
	301	Definition filter (f: elt -> bool) (s: t) : t :=
	302	treeify (filter_aux f s nil).
	303
	304	Fixpoint partition_aux (f: elt -> bool) s acc1 acc2 :=
	305	match s with
	306	\| Leaf => (acc1,acc2)
	307	\| Node _ sl k sr =>
	308	let (acc1, acc2) := partition_aux f sr acc1 acc2 in
	309	if f k then partition_aux f sl (k::acc1) acc2
	310	else partition_aux f sl acc1 (k::acc2)
	311	end.
	312
	313	Definition partition (f: elt -> bool) (s:t) : t*t :=
	314	let (ok,ko) := partition_aux f s nil nil in
	315	(treeify ok, treeify ko).
	316
	317	( Union, intersection, difference *)
	318
	319	(** union of the elements of [l1] and [l2] into a third [acc] list. *)
	320
	321	Fixpoint union_list l1 : list elt -> list elt -> list elt :=
	322	match l1 with
	323	\| nil => @rev_append _
	324	\| x::l1' =>
	325	fix union_l1 l2 acc :=
	326	match l2 with
	327	\| nil => rev_append l1 acc
	328	\| y::l2' =>
	329	match X.compare x y with
	330	\| Eq => union_list l1' l2' (x::acc)
	331	\| Lt => union_l1 l2' (y::acc)
	332	\| Gt => union_list l1' l2 (x::acc)
	333	end
	334	end
	335	end.
	336
	337	Definition linear_union s1 s2 :=
	338	treeify (union_list (rev_elements s1) (rev_elements s2) nil).
	339
	340	Fixpoint inter_list l1 : list elt -> list elt -> list elt :=
	341	match l1 with
	342	\| nil => fun _ acc => acc
	343	\| x::l1' =>
	344	fix inter_l1 l2 acc :=
	345	match l2 with
	346	\| nil => acc
	347	\| y::l2' =>
	348	match X.compare x y with
	349	\| Eq => inter_list l1' l2' (x::acc)
	350	\| Lt => inter_l1 l2' acc
	351	\| Gt => inter_list l1' l2 acc
	352	end
	353	end
	354	end.
	355
	356	Definition linear_inter s1 s2 :=
	357	treeify (inter_list (rev_elements s1) (rev_elements s2) nil).
	358
	359	Fixpoint diff_list l1 : list elt -> list elt -> list elt :=
	360	match l1 with
	361	\| nil => fun _ acc => acc
	362	\| x::l1' =>
	363	fix diff_l1 l2 acc :=
	364	match l2 with
	365	\| nil => rev_append l1 acc
	366	\| y::l2' =>
	367	match X.compare x y with
	368	\| Eq => diff_list l1' l2' acc
	369	\| Lt => diff_l1 l2' acc
	370	\| Gt => diff_list l1' l2 (x::acc)
	371	end
	372	end
	373	end.
	374
	375	Definition linear_diff s1 s2 :=
	376	treeify (diff_list (rev_elements s1) (rev_elements s2) nil).
	377
	378	(** [compare_height] returns:
	379	- [Lt] if [height s2] is at least twice [height s1];
	380	- [Gt] if [height s1] is at least twice [height s2];
	381	- [Eq] if heights are approximately equal.
	382	Warning: this is not an equivalence relation! but who cares.... *)
	383
	384	Definition skip_red t :=
	385	match t with
	386	\| Rd t' _ _ => t'
	387	\| _ => t
	388	end.
	389
	390	Definition skip_black t :=
	391	match skip_red t with
	392	\| Bk t' _ _ => t'
	393	\| t' => t'
	394	end.
	395
	396	Fixpoint compare_height (s1x s1 s2 s2x: tree) : comparison :=
	397	match skip_red s1x, skip_red s1, skip_red s2, skip_red s2x with
	398	\| Node _ s1x' _ _, Node _ s1' _ _, Node _ s2' _ _, Node _ s2x' _ _ =>
	399	compare_height (skip_black s2x') s1' s2' (skip_black s2x')
	400	\| _, Leaf, _, Node _ _ _ _ => Lt
	401	\| Node _ _ _ _, _, Leaf, _ => Gt
	402	\| Node _ s1x' _ _, Node _ s1' _ _, Node _ s2' _ _, Leaf =>
	403	compare_height (skip_black s1x') s1' s2' Leaf
	404	\| Leaf, Node _ s1' _ _, Node _ s2' _ _, Node _ s2x' _ _ =>
	405	compare_height Leaf s1' s2' (skip_black s2x')
	406	\| _, _, _, _ => Eq
	407	end.
	408
	409	(** When one tree is quite smaller than the other, we simply
	410	adds repeatively all its elements in the big one.
	411	For trees of comparable height, we rather use [linear_union]. *)
	412
	413	Definition union (t1 t2: t) : t :=
	414	match compare_height t1 t1 t2 t2 with
	415	\| Lt => fold add t1 t2
	416	\| Gt => fold add t2 t1
	417	\| Eq => linear_union t1 t2
	418	end.
	419
	420	Definition diff (t1 t2: t) : t :=
	421	match compare_height t1 t1 t2 t2 with
	422	\| Lt => filter (fun k => negb (mem k t2)) t1
	423	\| Gt => fold remove t2 t1
	424	\| Eq => linear_diff t1 t2
	425	end.
	426
	427	Definition inter (t1 t2: t) : t :=
	428	match compare_height t1 t1 t2 t2 with
	429	\| Lt => filter (fun k => mem k t2) t1
	430	\| Gt => filter (fun k => mem k t1) t2
	431	\| Eq => linear_inter t1 t2
	432	end.
	433
	434	End Ops.
	435
	436	(** * MakeRaw : the pure functions and their specifications *)
	437
	438	Module Type MakeRaw (X:Orders.OrderedType) <: MSetInterface.RawSets X.
	439	Include Ops X.
	440
	441	(** Generic definition of binary-search-trees and proofs of
	442	specifications for generic functions such as mem or fold. *)
	443
	444	Include MSetGenTree.Props X Color.
	445
	446	Local Notation Rd := (Node Red).
	447	Local Notation Bk := (Node Black).
	448
	449	Local Hint Immediate MX.eq_sym.
	450	Local Hint Unfold In lt_tree gt_tree Ok.
	451	Local Hint Constructors InT bst.
	452	Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans @ok.
	453	Local Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node.
	454	Local Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans.
	455	Local Hint Resolve elements_spec2.
	456
	457	( Singleton set *)
	458
	459	Lemma singleton_spec x y : InT y (singleton x) <-> X.eq y x.
	460	Proof.
	461	unfold singleton; intuition_in.
	462	Qed.
	463
	464	Instance singleton_ok x : Ok (singleton x).
	465	Proof.
	466	unfold singleton; auto.
	467	Qed.
	468
	469	( makeBlack, MakeRed *)
	470
	471	Lemma makeBlack_spec s x : InT x (makeBlack s) <-> InT x s.
	472	Proof.
	473	destruct s; simpl; intuition_in.
	474	Qed.
	475
	476	Lemma makeRed_spec s x : InT x (makeRed s) <-> InT x s.
	477	Proof.
	478	destruct s; simpl; intuition_in.
	479	Qed.
	480
	481	Instance makeBlack_ok s `{Ok s} : Ok (makeBlack s).
	482	Proof.
	483	destruct s; simpl; ok.
	484	Qed.
	485
	486	Instance makeRed_ok s `{Ok s} : Ok (makeRed s).
	487	Proof.
	488	destruct s; simpl; ok.
	489	Qed.
	490
	491	( Generic handling for red-matching and red-red-matching *)
	492
	493	Definition isblack t :=
	494	match t with Bk _ _ _ => True \| _ => False end.
	495
	496	Definition notblack t :=
	497	match t with Bk _ _ _ => False \| _ => True end.
	498
	499	Definition notred t :=
	500	match t with Rd _ _ _ => False \| _ => True end.
	501
	502	Definition rcase {A} f g t : A :=
	503	match t with
	504	\| Rd a x b => f a x b
	505	\| _ => g t
	506	end.
	507
	508	Inductive rspec {A} f g : tree -> A -> Prop :=
	509	\| rred a x b : rspec f g (Rd a x b) (f a x b)
	510	\| relse t : notred t -> rspec f g t (g t).
	511
	512	Fact rmatch {A} f g t : rspec (A:=A) f g t (rcase f g t).
	513	Proof.
	514	destruct t as [\|[\|] l x r]; simpl; now constructor.
	515	Qed.
	516
	517	Definition rrcase {A} f g t : A :=
	518	match t with
	519	\| Rd (Rd a x b) y c => f a x b y c
	520	\| Rd a x (Rd b y c) => f a x b y c
	521	\| _ => g t
	522	end.
	523
	524	Notation notredred := (rrcase (fun _ _ _ _ _ => False) (fun _ => True)).
	525
	526	Inductive rrspec {A} f g : tree -> A -> Prop :=
	527	\| rrleft a x b y c : rrspec f g (Rd (Rd a x b) y c) (f a x b y c)
	528	\| rrright a x b y c : rrspec f g (Rd a x (Rd b y c)) (f a x b y c)
	529	\| rrelse t : notredred t -> rrspec f g t (g t).
	530
	531	Fact rrmatch {A} f g t : rrspec (A:=A) f g t (rrcase f g t).
	532	Proof.
	533	destruct t as [\|[\|] l x r]; simpl; try now constructor.
	534	destruct l as [\|[\|] ll lx lr], r as [\|[\|] rl rx rr]; now constructor.
	535	Qed.
	536
	537	Definition rrcase' {A} f g t : A :=
	538	match t with
	539	\| Rd a x (Rd b y c) => f a x b y c
	540	\| Rd (Rd a x b) y c => f a x b y c
	541	\| _ => g t
	542	end.
	543
	544	Fact rrmatch' {A} f g t : rrspec (A:=A) f g t (rrcase' f g t).
	545	Proof.
	546	destruct t as [\|[\|] l x r]; simpl; try now constructor.
	547	destruct l as [\|[\|] ll lx lr], r as [\|[\|] rl rx rr]; now constructor.
	548	Qed.
	549
	550	(** Balancing operations are instances of generic match *)
	551
	552	Fact lbal_match l k r :
	553	rrspec
	554	(fun a x b y c => Rd (Bk a x b) y (Bk c k r))
	555	(fun l => Bk l k r)
	556	l
	557	(lbal l k r).
	558	Proof.
	559	exact (rrmatch _ _ _).
	560	Qed.
	561
	562	Fact rbal_match l k r :
	563	rrspec
	564	(fun a x b y c => Rd (Bk l k a) x (Bk b y c))
	565	(fun r => Bk l k r)
	566	r
	567	(rbal l k r).
	568	Proof.
	569	exact (rrmatch _ _ _).
	570	Qed.
	571
	572	Fact rbal'_match l k r :
	573	rrspec
	574	(fun a x b y c => Rd (Bk l k a) x (Bk b y c))
	575	(fun r => Bk l k r)
	576	r
	577	(rbal' l k r).
	578	Proof.
	579	exact (rrmatch' _ _ _).
	580	Qed.
	581
	582	Fact lbalS_match l x r :
	583	rspec
	584	(fun a y b => Rd (Bk a y b) x r)
	585	(fun l =>
	586	match r with
	587	\| Bk a y b => rbal' l x (Rd a y b)
	588	\| Rd (Bk a y b) z c => Rd (Bk l x a) y (rbal' b z (makeRed c))
	589	\| _ => Rd l x r
	590	end)
	591	l
	592	(lbalS l x r).
	593	Proof.
	594	exact (rmatch _ _ _).
	595	Qed.
	596
	597	Fact rbalS_match l x r :
	598	rspec
	599	(fun a y b => Rd l x (Bk a y b))
	600	(fun r =>
	601	match l with
	602	\| Bk a y b => lbal (Rd a y b) x r
	603	\| Rd a y (Bk b z c) => Rd (lbal (makeRed a) y b) z (Bk c x r)
	604	\| _ => Rd l x r
	605	end)
	606	r
	607	(rbalS l x r).
	608	Proof.
	609	exact (rmatch _ _ _).
	610	Qed.
	611
	612	( Balancing for insertion *)
	613
	614	Lemma lbal_spec l x r y :
	615	InT y (lbal l x r) <-> X.eq y x \/ InT y l \/ InT y r.
	616	Proof.
	617	case lbal_match; intuition_in.
	618	Qed.
	619
	620	Instance lbal_ok l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r) :
	621	Ok (lbal l x r).
	622	Proof.
	623	destruct (lbal_match l x r); ok.
	624	Qed.
	625
	626	Lemma rbal_spec l x r y :
	627	InT y (rbal l x r) <-> X.eq y x \/ InT y l \/ InT y r.
	628	Proof.
	629	case rbal_match; intuition_in.
	630	Qed.
	631
	632	Instance rbal_ok l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r) :
	633	Ok (rbal l x r).
	634	Proof.
	635	destruct (rbal_match l x r); ok.
	636	Qed.
	637
	638	Lemma rbal'_spec l x r y :
	639	InT y (rbal' l x r) <-> X.eq y x \/ InT y l \/ InT y r.
	640	Proof.
	641	case rbal'_match; intuition_in.
	642	Qed.
	643
	644	Instance rbal'_ok l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r) :
	645	Ok (rbal' l x r).
	646	Proof.
	647	destruct (rbal'_match l x r); ok.
	648	Qed.
	649
	650	Hint Rewrite In_node_iff In_leaf_iff
	651	makeRed_spec makeBlack_spec lbal_spec rbal_spec rbal'_spec : rb.
	652
	653	Ltac descolor := destruct_all Color.t.
	654	Ltac destree t := destruct t as [\|[\|] ? ? ?].
	655	Ltac autorew := autorewrite with rb.
	656	Tactic Notation "autorew" "in" ident(H) := autorewrite with rb in H.
	657
	658	( Insertion *)
	659
	660	Lemma ins_spec : forall s x y,
	661	InT y (ins x s) <-> X.eq y x \/ InT y s.
	662	Proof.
	663	induct s x.
	664	- intuition_in.
	665	- intuition_in. setoid_replace y with x; eauto.
	666	- descolor; autorew; rewrite IHl; intuition_in.
	667	- descolor; autorew; rewrite IHr; intuition_in.
	668	Qed.
	669	Hint Rewrite ins_spec : rb.
	670
	671	Instance ins_ok s x `{Ok s} : Ok (ins x s).
	672	Proof.
	673	induct s x; auto; descolor;
	674	(apply lbal_ok \|\| apply rbal_ok \|\| ok); auto;
	675	intros y; autorew; intuition; order.
	676	Qed.
	677
	678	Lemma add_spec' s x y :
	679	InT y (add x s) <-> X.eq y x \/ InT y s.
	680	Proof.
	681	unfold add. now autorew.
	682	Qed.
	683
	684	Hint Rewrite add_spec' : rb.
	685
	686	Lemma add_spec s x y `{Ok s} :
	687	InT y (add x s) <-> X.eq y x \/ InT y s.
	688	Proof.
	689	apply add_spec'.
	690	Qed.
	691
	692	Instance add_ok s x `{Ok s} : Ok (add x s).
	693	Proof.
	694	unfold add; auto_tc.
	695	Qed.
	696
	697	( Balancing for deletion *)
	698
	699	Lemma lbalS_spec l x r y :
	700	InT y (lbalS l x r) <-> X.eq y x \/ InT y l \/ InT y r.
	701	Proof.
	702	case lbalS_match.
	703	- intros; autorew; intuition_in.
	704	- clear l. intros l _.
	705	destruct r as [\|[\|] rl rx rr].
	706	* autorew. intuition_in.
	707	* destree rl; autorew; intuition_in.
	708	* autorew. intuition_in.
	709	Qed.
	710
	711	Instance lbalS_ok l x r :
	712	forall `(Ok l, Ok r, lt_tree x l, gt_tree x r), Ok (lbalS l x r).
	713	Proof.
	714	case lbalS_match; intros.
	715	- ok.
	716	- destruct r as [\|[\|] rl rx rr].
	717	* ok.
	718	* destruct rl as [\|[\|] rll rlx rlr]; intros; ok.
	719	+ apply rbal'_ok; ok.
	720	intros w; autorew; auto.
	721	+ intros w; autorew.
	722	destruct 1 as [Hw\|[Hw\|Hw]]; try rewrite Hw; eauto.
	723	* ok. autorew. apply rbal'_ok; ok.
	724	Qed.
	725
	726	Lemma rbalS_spec l x r y :
	727	InT y (rbalS l x r) <-> X.eq y x \/ InT y l \/ InT y r.
	728	Proof.
	729	case rbalS_match.
	730	- intros; autorew; intuition_in.
	731	- intros t _.
	732	destruct l as [\|[\|] ll lx lr].
	733	* autorew. intuition_in.
	734	* destruct lr as [\|[\|] lrl lrx lrr]; autorew; intuition_in.
	735	* autorew. intuition_in.
	736	Qed.
	737
	738	Instance rbalS_ok l x r :
	739	forall `(Ok l, Ok r, lt_tree x l, gt_tree x r), Ok (rbalS l x r).
	740	Proof.
	741	case rbalS_match; intros.
	742	- ok.
	743	- destruct l as [\|[\|] ll lx lr].
	744	* ok.
	745	* destruct lr as [\|[\|] lrl lrx lrr]; intros; ok.
	746	+ apply lbal_ok; ok.
	747	intros w; autorew; auto.
	748	+ intros w; autorew.
	749	destruct 1 as [Hw\|[Hw\|Hw]]; try rewrite Hw; eauto.
	750	* ok. apply lbal_ok; ok.
	751	Qed.
	752
	753	Hint Rewrite lbalS_spec rbalS_spec : rb.
	754
	755	( Append for deletion *)
	756
	757	Ltac append_tac l r :=
	758	induction l as [\| lc ll _ lx lr IHlr];
	759	[intro r; simpl
	760	\|induction r as [\| rc rl IHrl rx rr _];
	761	[simpl
	762	\|destruct lc, rc;
	763	[specialize (IHlr rl); clear IHrl
	764	\|simpl;
	765	assert (Hr:notred (Bk rl rx rr)) by (simpl; trivial);
	766	set (r:=Bk rl rx rr) in *; clearbody r; clear IHrl rl rx rr;
	767	specialize (IHlr r)
	768	\|change (append _ _) with (Rd (append (Bk ll lx lr) rl) rx rr);
	769	assert (Hl:notred (Bk ll lx lr)) by (simpl; trivial);
	770	set (l:=Bk ll lx lr) in *; clearbody l; clear IHlr ll lx lr
	771	\|specialize (IHlr rl); clear IHrl]]].
	772
	773	Fact append_rr_match ll lx lr rl rx rr :
	774	rspec
	775	(fun a x b => Rd (Rd ll lx a) x (Rd b rx rr))
	776	(fun t => Rd ll lx (Rd t rx rr))
	777	(append lr rl)
	778	(append (Rd ll lx lr) (Rd rl rx rr)).
	779	Proof.
	780	exact (rmatch _ _ _).
	781	Qed.
	782
	783	Fact append_bb_match ll lx lr rl rx rr :
	784	rspec
	785	(fun a x b => Rd (Bk ll lx a) x (Bk b rx rr))
	786	(fun t => lbalS ll lx (Bk t rx rr))
	787	(append lr rl)
	788	(append (Bk ll lx lr) (Bk rl rx rr)).
	789	Proof.
	790	exact (rmatch _ _ _).
	791	Qed.
	792
	793	Lemma append_spec l r x :
	794	InT x (append l r) <-> InT x l \/ InT x r.
	795	Proof.
	796	revert r.
	797	append_tac l r; autorew; try tauto.
	798	- (* Red / Red *)
	799	revert IHlr; case append_rr_match;
	800	[intros a y b \| intros t Ht]; autorew; tauto.
	801	- (* Black / Black *)
	802	revert IHlr; case append_bb_match;
	803	[intros a y b \| intros t Ht]; autorew; tauto.
	804	Qed.
	805
	806	Hint Rewrite append_spec : rb.
	807
	808	Lemma append_ok : forall x l r `{Ok l, Ok r},
	809	lt_tree x l -> gt_tree x r -> Ok (append l r).
	810	Proof.
	811	append_tac l r.
	812	- (* Leaf / _ *)
	813	trivial.
	814	- (* _ / Leaf *)
	815	trivial.
	816	- (* Red / Red *)
	817	intros; inv.
	818	assert (IH : Ok (append lr rl)) by (apply IHlr; eauto). clear IHlr.
	819	assert (X.lt lx rx) by (transitivity x; eauto).
	820	assert (G : gt_tree lx (append lr rl)).
	821	{ intros w. autorew. destruct 1; [\|transitivity x]; eauto. }
	822	assert (L : lt_tree rx (append lr rl)).
	823	{ intros w. autorew. destruct 1; [transitivity x\|]; eauto. }
	824	revert IH G L; case append_rr_match; intros; ok.
	825	- (* Red / Black *)
	826	intros; ok.
	827	intros w; autorew; destruct 1; eauto.
	828	- (* Black / Red *)
	829	intros; ok.
	830	intros w; autorew; destruct 1; eauto.
	831	- (* Black / Black *)
	832	intros; inv.
	833	assert (IH : Ok (append lr rl)) by (apply IHlr; eauto). clear IHlr.
	834	assert (X.lt lx rx) by (transitivity x; eauto).
	835	assert (G : gt_tree lx (append lr rl)).
	836	{ intros w. autorew. destruct 1; [\|transitivity x]; eauto. }
	837	assert (L : lt_tree rx (append lr rl)).
	838	{ intros w. autorew. destruct 1; [transitivity x\|]; eauto. }
	839	revert IH G L; case append_bb_match; intros; ok.
	840	apply lbalS_ok; ok.
	841	Qed.
	842
	843	( Deletion *)
	844
	845	Lemma del_spec : forall s x y `{Ok s},
	846	InT y (del x s) <-> InT y s /\ ~X.eq y x.
	847	Proof.
	848	induct s x.
	849	- intuition_in.
	850	- autorew; intuition_in.
	851	assert (X.lt y x') by eauto. order.
	852	assert (X.lt x' y) by eauto. order.
	853	order.
	854	- destruct l as [\|[\|] ll lx lr]; autorew;
	855	rewrite ?IHl by trivial; intuition_in; order.
	856	- destruct r as [\|[\|] rl rx rr]; autorew;
	857	rewrite ?IHr by trivial; intuition_in; order.
	858	Qed.
	859
	860	Hint Rewrite del_spec : rb.
	861
	862	Instance del_ok s x `{Ok s} : Ok (del x s).
	863	Proof.
	864	induct s x.
	865	- trivial.
	866	- eapply append_ok; eauto.
	867	- assert (lt_tree x' (del x l)).
	868	{ intro w. autorew; trivial. destruct 1. eauto. }
	869	destruct l as [\|[\|] ll lx lr]; auto_tc.
	870	- assert (gt_tree x' (del x r)).
	871	{ intro w. autorew; trivial. destruct 1. eauto. }
	872	destruct r as [\|[\|] rl rx rr]; auto_tc.
	873	Qed.
	874
	875	Lemma remove_spec s x y `{Ok s} :
	876	InT y (remove x s) <-> InT y s /\ ~X.eq y x.
	877	Proof.
	878	unfold remove. now autorew.
	879	Qed.
	880
	881	Hint Rewrite remove_spec : rb.
	882
	883	Instance remove_ok s x `{Ok s} : Ok (remove x s).
	884	Proof.
	885	unfold remove; auto_tc.
	886	Qed.
	887
	888	( Removing the minimal element *)
	889
	890	Lemma delmin_spec l y r c x s' `{O : Ok (Node c l y r)} :
	891	delmin l y r = (x,s') ->
	892	min_elt (Node c l y r) = Some x /\ del x (Node c l y r) = s'.
	893	Proof.
	894	revert y r c x s' O.
	895	induction l as [\|lc ll IH ly lr _].
	896	- simpl. intros y r _ x s' _. injection 1; intros; subst.
	897	now rewrite MX.compare_refl.
	898	- intros y r c x s' O.
	899	simpl delmin.
	900	specialize (IH ly lr). destruct delmin as (x0,s0).
	901	destruct (IH lc x0 s0); clear IH; [ok\|trivial\|].
	902	remember (Node lc ll ly lr) as l.
	903	simpl min_elt in *.
	904	intros E.
	905	replace x0 with x in * by (destruct lc; now injection E).
	906	split.
	907	* subst l; intuition.
	908	* assert (X.lt x y).
	909	{ inversion_clear O.
	910	assert (InT x l) by now apply min_elt_spec1. auto. }
	911	simpl. case X.compare_spec; try order.
	912	destruct lc; injection E; clear E; intros; subst l s0; auto.
	913	Qed.
	914
	915	Lemma remove_min_spec1 s x s' `{Ok s}:
	916	remove_min s = Some (x,s') ->
	917	min_elt s = Some x /\ remove x s = s'.
	918	Proof.
	919	unfold remove_min.
	920	destruct s as [\|c l y r]; try easy.
	921	generalize (delmin_spec l y r c).
	922	destruct delmin as (x0,s0). intros D.
	923	destruct (D x0 s0) as (->,<-); auto.
	924	fold (remove x0 (Node c l y r)).
	925	inversion_clear 1; auto.
	926	Qed.
	927
	928	Lemma remove_min_spec2 s : remove_min s = None -> Empty s.
	929	Proof.
	930	unfold remove_min.
	931	destruct s as [\|c l y r].
	932	- easy.
	933	- now destruct delmin.
	934	Qed.
	935
	936	Lemma remove_min_ok (s:t) `{Ok s}:
	937	match remove_min s with
	938	\| Some (_,s') => Ok s'
	939	\| None => True
	940	end.
	941	Proof.
	942	generalize (remove_min_spec1 s).
	943	destruct remove_min as [(x0,s0)\|]; auto.
	944	intros R. destruct (R x0 s0); auto. subst s0. auto_tc.
	945	Qed.
	946
	947	( Treeify *)
	948
	949	Notation ifpred p n := (if p then pred n else n%nat).
	950
	951	Definition treeify_invariant size (f:treeify_t) :=
	952	forall acc,
	953	size <= length acc ->
	954	let (t,acc') := f acc in
	955	cardinal t = size /\ acc = elements t ++ acc'.
	956
	957	Lemma treeify_zero_spec : treeify_invariant 0 treeify_zero.
	958	Proof.
	959	intro. simpl. auto.
	960	Qed.
	961
	962	Lemma treeify_one_spec : treeify_invariant 1 treeify_one.
	963	Proof.
	964	intros [\|x acc]; simpl; auto; inversion 1.
	965	Qed.
	966
	967	Lemma treeify_cont_spec f g size1 size2 size :
	968	treeify_invariant size1 f ->
	969	treeify_invariant size2 g ->
	970	size = S (size1 + size2) ->
	971	treeify_invariant size (treeify_cont f g).
	972	Proof.
	973	intros Hf Hg EQ acc LE. unfold treeify_cont.
	974	specialize (Hf acc).
	975	destruct (f acc) as (t1,acc1).
	976	destruct Hf as (Hf1,Hf2).
	977	{ lia. }
	978	destruct acc1 as [\|x acc1].
	979	{ exfalso. subst acc.
	980	rewrite <- app_nil_end, <- elements_cardinal in LE. lia. }
	981	specialize (Hg acc1).
	982	destruct (g acc1) as (t2,acc2).
	983	destruct Hg as (Hg1,Hg2).
	984	{ subst acc. rewrite app_length, <- elements_cardinal in LE.
	985	simpl in LE. unfold elt in *. lia. }
	986	simpl. split.
	987	* lia.
	988	* rewrite elements_node, app_ass. simpl. unfold elt in *; congruence.
	989	Qed.
	990
	991	Lemma treeify_aux_spec n (p:bool) :
	992	treeify_invariant (ifpred p (Pos.to_nat n)) (treeify_aux p n).
	993	Proof.
	994	revert p.
	995	induction n as [n\|n\|]; intros p; simpl treeify_aux.
	996	- eapply treeify_cont_spec; [ apply (IHn false) \| apply (IHn p) \| ].
	997	rewrite Pos2Nat.inj_xI. generalize (Pos2Nat.is_pos n).
	998	destruct p; simpl; lia.
	999	- eapply treeify_cont_spec; [ apply (IHn p) \| apply (IHn true) \| ].
	1000	rewrite Pos2Nat.inj_xO. generalize (Pos2Nat.is_pos n).
	1001	destruct p; simpl; lia.
	1002	- destruct p; [ apply treeify_zero_spec \| apply treeify_one_spec ].
	1003	Qed.
	1004
	1005	Lemma plength_spec l : Pos.to_nat (plength l) = S (length l).
	1006	Proof.
	1007	induction l; simpl; now rewrite ?Pos2Nat.inj_succ, ?IHl.
	1008	Qed.
	1009
	1010	Lemma treeify_elements l : elements (treeify l) = l.
	1011	Proof.
	1012	assert (H := treeify_aux_spec (plength l) true l).
	1013	unfold treeify. destruct treeify_aux as (t,acc); simpl in *.
	1014	destruct H as (H,H'). { now rewrite plength_spec. }
	1015	subst l. rewrite plength_spec, app_length, <- elements_cardinal in *.
	1016	destruct acc.
	1017	* now rewrite app_nil_r.
	1018	* simpl in H. lia.
	1019	Qed.
	1020
	1021	Lemma treeify_spec x l : InT x (treeify l) <-> InA X.eq x l.
	1022	Proof.
	1023	intros. now rewrite <- elements_spec1, treeify_elements.
	1024	Qed.
	1025
	1026	Lemma treeify_ok l : sort X.lt l -> Ok (treeify l).
	1027	Proof.
	1028	intros. apply elements_sort_ok. rewrite treeify_elements; auto.
	1029	Qed.
	1030
	1031
	1032	( Filter *)
	1033
	1034	Lemma filter_app A f (l l':list A) :
	1035	List.filter f (l ++ l') = List.filter f l ++ List.filter f l'.
	1036	Proof.
	1037	induction l as [\|x l IH]; simpl; trivial.
	1038	destruct (f x); simpl; now rewrite IH.
	1039	Qed.
	1040
	1041	Lemma filter_aux_elements s f acc :
	1042	filter_aux f s acc = List.filter f (elements s) ++ acc.
	1043	Proof.
	1044	revert acc.
	1045	induction s as [\|c l IHl x r IHr]; simpl; trivial.
	1046	intros acc.
	1047	rewrite elements_node, filter_app. simpl.
	1048	destruct (f x); now rewrite IHl, IHr, app_ass.
	1049	Qed.
	1050
	1051	Lemma filter_elements s f :
	1052	elements (filter f s) = List.filter f (elements s).
	1053	Proof.
	1054	unfold filter.
	1055	now rewrite treeify_elements, filter_aux_elements, app_nil_r.
	1056	Qed.
	1057
	1058	Lemma filter_spec s x f :
	1059	Proper (X.eq==>Logic.eq) f ->
	1060	(InT x (filter f s) <-> InT x s /\ f x = true).
	1061	Proof.
	1062	intros Hf.
	1063	rewrite <- elements_spec1, filter_elements, filter_InA, elements_spec1;
	1064	now auto_tc.
	1065	Qed.
	1066
	1067	Instance filter_ok s f `(Ok s) : Ok (filter f s).
	1068	Proof.
	1069	apply elements_sort_ok.
	1070	rewrite filter_elements.
	1071	apply filter_sort with X.eq; auto_tc.
	1072	Qed.
	1073
	1074	( Partition *)
	1075
	1076	Lemma partition_aux_spec s f acc1 acc2 :
	1077	partition_aux f s acc1 acc2 =
	1078	(filter_aux f s acc1, filter_aux (fun x => negb (f x)) s acc2).
	1079	Proof.
	1080	revert acc1 acc2.
	1081	induction s as [ \| c l Hl x r Hr ]; simpl.
	1082	- trivial.
	1083	- intros acc1 acc2.
	1084	destruct (f x); simpl; now rewrite Hr, Hl.
	1085	Qed.
	1086
	1087	Lemma partition_spec s f :
	1088	partition f s = (filter f s, filter (fun x => negb (f x)) s).
	1089	Proof.
	1090	unfold partition, filter. now rewrite partition_aux_spec.
	1091	Qed.
	1092
	1093	Lemma partition_spec1 s f :
	1094	Proper (X.eq==>Logic.eq) f ->
	1095	Equal (fst (partition f s)) (filter f s).
	1096	Proof. now rewrite partition_spec. Qed.
	1097
	1098	Lemma partition_spec2 s f :
	1099	Proper (X.eq==>Logic.eq) f ->
	1100	Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
	1101	Proof. now rewrite partition_spec. Qed.
	1102
	1103	Instance partition_ok1 s f `(Ok s) : Ok (fst (partition f s)).
	1104	Proof. rewrite partition_spec; now apply filter_ok. Qed.
	1105
	1106	Instance partition_ok2 s f `(Ok s) : Ok (snd (partition f s)).
	1107	Proof. rewrite partition_spec; now apply filter_ok. Qed.
	1108
	1109
	1110	( An invariant for binary list functions with accumulator. *)
	1111
	1112	Ltac inA :=
	1113	rewrite ?InA_app_iff, ?InA_cons, ?InA_nil, ?InA_rev in *; auto_tc.
	1114
	1115	Record INV l1 l2 acc : Prop := {
	1116	l1_sorted : sort X.lt (rev l1);
	1117	l2_sorted : sort X.lt (rev l2);
	1118	acc_sorted : sort X.lt acc;
	1119	l1_lt_acc x y : InA X.eq x l1 -> InA X.eq y acc -> X.lt x y;
	1120	l2_lt_acc x y : InA X.eq x l2 -> InA X.eq y acc -> X.lt x y}.
	1121	Local Hint Resolve l1_sorted l2_sorted acc_sorted.
	1122
	1123	Lemma INV_init s1 s2 `(Ok s1, Ok s2) :
	1124	INV (rev_elements s1) (rev_elements s2) nil.
	1125	Proof.
	1126	rewrite !rev_elements_rev.
	1127	split; rewrite ?rev_involutive; auto; intros; now inA.
	1128	Qed.
	1129
	1130	Lemma INV_sym l1 l2 acc : INV l1 l2 acc -> INV l2 l1 acc.
	1131	Proof.
	1132	destruct 1; now split.
	1133	Qed.
	1134
	1135	Lemma INV_drop x1 l1 l2 acc :
	1136	INV (x1 :: l1) l2 acc -> INV l1 l2 acc.
	1137	Proof.
	1138	intros (l1s,l2s,accs,l1a,l2a). simpl in *.
	1139	destruct (sorted_app_inv _ _ l1s) as (U & V & W); auto.
	1140	split; auto.
	1141	Qed.
	1142
	1143	Lemma INV_eq x1 x2 l1 l2 acc :
	1144	INV (x1 :: l1) (x2 :: l2) acc -> X.eq x1 x2 ->
	1145	INV l1 l2 (x1 :: acc).
	1146	Proof.
	1147	intros (U,V,W,X,Y) EQ. simpl in *.
	1148	destruct (sorted_app_inv _ _ U) as (U1 & U2 & U3); auto.
	1149	destruct (sorted_app_inv _ _ V) as (V1 & V2 & V3); auto.
	1150	split; auto.
	1151	- constructor; auto. apply InA_InfA with X.eq; auto_tc.
	1152	- intros x y; inA; intros Hx [Hy\|Hy].
	1153	+ apply U3; inA.
	1154	+ apply X; inA.
	1155	- intros x y; inA; intros Hx [Hy\|Hy].
	1156	+ rewrite Hy, EQ; apply V3; inA.
	1157	+ apply Y; inA.
	1158	Qed.
	1159
	1160	Lemma INV_lt x1 x2 l1 l2 acc :
	1161	INV (x1 :: l1) (x2 :: l2) acc -> X.lt x1 x2 ->
	1162	INV (x1 :: l1) l2 (x2 :: acc).
	1163	Proof.
	1164	intros (U,V,W,X,Y) EQ. simpl in *.
	1165	destruct (sorted_app_inv _ _ U) as (U1 & U2 & U3); auto.
	1166	destruct (sorted_app_inv _ _ V) as (V1 & V2 & V3); auto.
	1167	split; auto.
	1168	- constructor; auto. apply InA_InfA with X.eq; auto_tc.
	1169	- intros x y; inA; intros Hx [Hy\|Hy].
	1170	+ rewrite Hy; clear Hy. destruct Hx; [order\|].
	1171	transitivity x1; auto. apply U3; inA.
	1172	+ apply X; inA.
	1173	- intros x y; inA; intros Hx [Hy\|Hy].
	1174	+ rewrite Hy. apply V3; inA.
	1175	+ apply Y; inA.
	1176	Qed.
	1177
	1178	Lemma INV_rev l1 l2 acc :
	1179	INV l1 l2 acc -> Sorted X.lt (rev_append l1 acc).
	1180	Proof.
	1181	intros. rewrite rev_append_rev.
	1182	apply SortA_app with X.eq; eauto with *.
	1183	intros x y. inA. eapply l1_lt_acc; eauto.
	1184	Qed.
	1185
	1186	( union *)
	1187
	1188	Lemma union_list_ok l1 l2 acc :
	1189	INV l1 l2 acc -> sort X.lt (union_list l1 l2 acc).
	1190	Proof.
	1191	revert l2 acc.
	1192	induction l1 as [\|x1 l1 IH1];
	1193	[intro l2\|induction l2 as [\|x2 l2 IH2]];
	1194	intros acc inv.
	1195	- eapply INV_rev, INV_sym; eauto.
	1196	- eapply INV_rev; eauto.
	1197	- simpl. case X.compare_spec; intro C.
	1198	* apply IH1. eapply INV_eq; eauto.
	1199	* apply (IH2 (x2::acc)). eapply INV_lt; eauto.
	1200	* apply IH1. eapply INV_sym, INV_lt; eauto. now apply INV_sym.
	1201	Qed.
	1202
	1203	Instance linear_union_ok s1 s2 `(Ok s1, Ok s2) :
	1204	Ok (linear_union s1 s2).
	1205	Proof.
	1206	unfold linear_union. now apply treeify_ok, union_list_ok, INV_init.
	1207	Qed.
	1208
	1209	Instance fold_add_ok s1 s2 `(Ok s1, Ok s2) :
	1210	Ok (fold add s1 s2).
	1211	Proof.
	1212	rewrite fold_spec, <- fold_left_rev_right.
	1213	unfold elt in *.
	1214	induction (rev (elements s1)); simpl; unfold flip in *; auto_tc.
	1215	Qed.
	1216
	1217	Instance union_ok s1 s2 `(Ok s1, Ok s2) : Ok (union s1 s2).
	1218	Proof.
	1219	unfold union. destruct compare_height; auto_tc.
	1220	Qed.
	1221
	1222	Lemma union_list_spec x l1 l2 acc :
	1223	InA X.eq x (union_list l1 l2 acc) <->
	1224	InA X.eq x l1 \/ InA X.eq x l2 \/ InA X.eq x acc.
	1225	Proof.
	1226	revert l2 acc.
	1227	induction l1 as [\|x1 l1 IH1].
	1228	- intros l2 acc; simpl. rewrite rev_append_rev. inA. tauto.
	1229	- induction l2 as [\|x2 l2 IH2]; intros acc; simpl.
	1230	* rewrite rev_append_rev. inA. tauto.
	1231	* case X.compare_spec; intro C.
	1232	+ rewrite IH1, !InA_cons, C; tauto.
	1233	+ rewrite (IH2 (x2::acc)), !InA_cons. tauto.
	1234	+ rewrite IH1, !InA_cons; tauto.
	1235	Qed.
	1236
	1237	Lemma linear_union_spec s1 s2 x :
	1238	InT x (linear_union s1 s2) <-> InT x s1 \/ InT x s2.
	1239	Proof.
	1240	unfold linear_union.
	1241	rewrite treeify_spec, union_list_spec, !rev_elements_rev.
	1242	rewrite !InA_rev, InA_nil, !elements_spec1 by auto_tc.
	1243	tauto.
	1244	Qed.
	1245
	1246	Lemma fold_add_spec s1 s2 x :
	1247	InT x (fold add s1 s2) <-> InT x s1 \/ InT x s2.
	1248	Proof.
	1249	rewrite fold_spec, <- fold_left_rev_right.
	1250	rewrite <- (elements_spec1 s1), <- InA_rev by auto_tc.
	1251	unfold elt in *.
	1252	induction (rev (elements s1)); simpl.
	1253	- rewrite InA_nil. tauto.
	1254	- unfold flip. rewrite add_spec', IHl, InA_cons. tauto.
	1255	Qed.
	1256
	1257	Lemma union_spec' s1 s2 x :
	1258	InT x (union s1 s2) <-> InT x s1 \/ InT x s2.
	1259	Proof.
	1260	unfold union. destruct compare_height.
	1261	- apply linear_union_spec.
	1262	- apply fold_add_spec.
	1263	- rewrite fold_add_spec. tauto.
	1264	Qed.
	1265
	1266	Lemma union_spec : forall s1 s2 y `{Ok s1, Ok s2},
	1267	(InT y (union s1 s2) <-> InT y s1 \/ InT y s2).
	1268	Proof.
	1269	intros; apply union_spec'.
	1270	Qed.
	1271
	1272	( inter *)
	1273
	1274	Lemma inter_list_ok l1 l2 acc :
	1275	INV l1 l2 acc -> sort X.lt (inter_list l1 l2 acc).
	1276	Proof.
	1277	revert l2 acc.
	1278	induction l1 as [\|x1 l1 IH1]; [\|induction l2 as [\|x2 l2 IH2]]; simpl.
	1279	- eauto.
	1280	- eauto.
	1281	- intros acc inv.
	1282	case X.compare_spec; intro C.
	1283	* apply IH1. eapply INV_eq; eauto.
	1284	* apply (IH2 acc). eapply INV_sym, INV_drop, INV_sym; eauto.
	1285	* apply IH1. eapply INV_drop; eauto.
	1286	Qed.
	1287
	1288	Instance linear_inter_ok s1 s2 `(Ok s1, Ok s2) :
	1289	Ok (linear_inter s1 s2).
	1290	Proof.
	1291	unfold linear_inter. now apply treeify_ok, inter_list_ok, INV_init.
	1292	Qed.
	1293
	1294	Instance inter_ok s1 s2 `(Ok s1, Ok s2) : Ok (inter s1 s2).
	1295	Proof.
	1296	unfold inter. destruct compare_height; auto_tc.
	1297	Qed.
	1298
	1299	Lemma inter_list_spec x l1 l2 acc :
	1300	sort X.lt (rev l1) ->
	1301	sort X.lt (rev l2) ->
	1302	(InA X.eq x (inter_list l1 l2 acc) <->
	1303	(InA X.eq x l1 /\ InA X.eq x l2) \/ InA X.eq x acc).
	1304	Proof.
	1305	revert l2 acc.
	1306	induction l1 as [\|x1 l1 IH1].
	1307	- intros l2 acc; simpl. inA. tauto.
	1308	- induction l2 as [\|x2 l2 IH2]; intros acc.
	1309	* simpl. inA. tauto.
	1310	* simpl. intros U V.
	1311	destruct (sorted_app_inv _ _ U) as (U1 & U2 & U3); auto.
	1312	destruct (sorted_app_inv _ _ V) as (V1 & V2 & V3); auto.
	1313	case X.compare_spec; intro C.
	1314	+ rewrite IH1, !InA_cons, C; tauto.
	1315	+ rewrite (IH2 acc); auto. inA. intuition; try order.
	1316	assert (X.lt x x1) by (apply U3; inA). order.
	1317	+ rewrite IH1; auto. inA. intuition; try order.
	1318	assert (X.lt x x2) by (apply V3; inA). order.
	1319	Qed.
	1320
	1321	Lemma linear_inter_spec s1 s2 x `(Ok s1, Ok s2) :
	1322	InT x (linear_inter s1 s2) <-> InT x s1 /\ InT x s2.
	1323	Proof.
	1324	unfold linear_inter.
	1325	rewrite !rev_elements_rev, treeify_spec, inter_list_spec
	1326	by (rewrite rev_involutive; auto_tc).
	1327	rewrite !InA_rev, InA_nil, !elements_spec1 by auto_tc. tauto.
	1328	Qed.
	1329
	1330	Local Instance mem_proper s `(Ok s) :
	1331	Proper (X.eq ==> Logic.eq) (fun k => mem k s).
	1332	Proof.
	1333	intros x y EQ. apply Bool.eq_iff_eq_true; rewrite !mem_spec; auto.
	1334	now rewrite EQ.
	1335	Qed.
	1336
	1337	Lemma inter_spec s1 s2 y `{Ok s1, Ok s2} :
	1338	InT y (inter s1 s2) <-> InT y s1 /\ InT y s2.
	1339	Proof.
	1340	unfold inter. destruct compare_height.
	1341	- now apply linear_inter_spec.
	1342	- rewrite filter_spec, mem_spec by auto_tc; tauto.
	1343	- rewrite filter_spec, mem_spec by auto_tc; tauto.
	1344	Qed.
	1345
	1346	( difference *)
	1347
	1348	Lemma diff_list_ok l1 l2 acc :
	1349	INV l1 l2 acc -> sort X.lt (diff_list l1 l2 acc).
	1350	Proof.
	1351	revert l2 acc.
	1352	induction l1 as [\|x1 l1 IH1];
	1353	[intro l2\|induction l2 as [\|x2 l2 IH2]];
	1354	intros acc inv.
	1355	- eauto.
	1356	- unfold diff_list. eapply INV_rev; eauto.
	1357	- simpl. case X.compare_spec; intro C.
	1358	* apply IH1. eapply INV_drop, INV_sym, INV_drop, INV_sym; eauto.
	1359	* apply (IH2 acc). eapply INV_sym, INV_drop, INV_sym; eauto.
	1360	* apply IH1. eapply INV_sym, INV_lt; eauto. now apply INV_sym.
	1361	Qed.
	1362
	1363	Instance diff_inter_ok s1 s2 `(Ok s1, Ok s2) :
	1364	Ok (linear_diff s1 s2).
	1365	Proof.
	1366	unfold linear_inter. now apply treeify_ok, diff_list_ok, INV_init.
	1367	Qed.
	1368
	1369	Instance fold_remove_ok s1 s2 `(Ok s2) :
	1370	Ok (fold remove s1 s2).
	1371	Proof.
	1372	rewrite fold_spec, <- fold_left_rev_right.
	1373	unfold elt in *.
	1374	induction (rev (elements s1)); simpl; unfold flip in *; auto_tc.
	1375	Qed.
	1376
	1377	Instance diff_ok s1 s2 `(Ok s1, Ok s2) : Ok (diff s1 s2).
	1378	Proof.
	1379	unfold diff. destruct compare_height; auto_tc.
	1380	Qed.
	1381
	1382	Lemma diff_list_spec x l1 l2 acc :
	1383	sort X.lt (rev l1) ->
	1384	sort X.lt (rev l2) ->
	1385	(InA X.eq x (diff_list l1 l2 acc) <->
	1386	(InA X.eq x l1 /\ ~InA X.eq x l2) \/ InA X.eq x acc).
	1387	Proof.
	1388	revert l2 acc.
	1389	induction l1 as [\|x1 l1 IH1].
	1390	- intros l2 acc; simpl. inA. tauto.
	1391	- induction l2 as [\|x2 l2 IH2]; intros acc.
	1392	* intros; simpl. rewrite rev_append_rev. inA. tauto.
	1393	* simpl. intros U V.
	1394	destruct (sorted_app_inv _ _ U) as (U1 & U2 & U3); auto.
	1395	destruct (sorted_app_inv _ _ V) as (V1 & V2 & V3); auto.
	1396	case X.compare_spec; intro C.
	1397	+ rewrite IH1; auto. f_equiv. inA. intuition; try order.
	1398	assert (X.lt x x1) by (apply U3; inA). order.
	1399	+ rewrite (IH2 acc); auto. f_equiv. inA. intuition; try order.
	1400	assert (X.lt x x1) by (apply U3; inA). order.
	1401	+ rewrite IH1; auto. inA. intuition; try order.
	1402	left; split; auto. destruct 1. order.
	1403	assert (X.lt x x2) by (apply V3; inA). order.
	1404	Qed.
	1405
	1406	Lemma linear_diff_spec s1 s2 x `(Ok s1, Ok s2) :
	1407	InT x (linear_diff s1 s2) <-> InT x s1 /\ ~InT x s2.
	1408	Proof.
	1409	unfold linear_diff.
	1410	rewrite !rev_elements_rev, treeify_spec, diff_list_spec
	1411	by (rewrite rev_involutive; auto_tc).
	1412	rewrite !InA_rev, InA_nil, !elements_spec1 by auto_tc. tauto.
	1413	Qed.
	1414
	1415	Lemma fold_remove_spec s1 s2 x `(Ok s2) :
	1416	InT x (fold remove s1 s2) <-> InT x s2 /\ ~InT x s1.
	1417	Proof.
	1418	rewrite fold_spec, <- fold_left_rev_right.
	1419	rewrite <- (elements_spec1 s1), <- InA_rev by auto_tc.
	1420	unfold elt in *.
	1421	induction (rev (elements s1)); simpl; intros.
	1422	- rewrite InA_nil. intuition.
	1423	- unfold flip in *. rewrite remove_spec, IHl, InA_cons. tauto.
	1424	clear IHl. induction l; simpl; auto_tc.
	1425	Qed.
	1426
	1427	Lemma diff_spec s1 s2 y `{Ok s1, Ok s2} :
	1428	InT y (diff s1 s2) <-> InT y s1 /\ ~InT y s2.
	1429	Proof.
	1430	unfold diff. destruct compare_height.
	1431	- now apply linear_diff_spec.
	1432	- rewrite filter_spec, Bool.negb_true_iff,
	1433	<- Bool.not_true_iff_false, mem_spec;
	1434	intuition.
	1435	intros x1 x2 EQ. f_equal. now apply mem_proper.
	1436	- now apply fold_remove_spec.
	1437	Qed.
	1438
	1439	End MakeRaw.
	1440
	1441	(** * Balancing properties
	1442
	1443	We now prove that all operations preserve a red-black invariant,
	1444	and that trees have hence a logarithmic depth.
	1445	*)
	1446
	1447	Module BalanceProps(X:Orders.OrderedType)(Import M : MakeRaw X).
	1448
	1449	Local Notation Rd := (Node Red).
	1450	Local Notation Bk := (Node Black).
	1451	Import M.MX.
	1452
	1453	( Red-Black invariants *)
	1454
	1455	(** In a red-black tree :
	1456	- a red node has no red children
	1457	- the black depth at each node is the same along all paths.
	1458	The black depth is here an argument of the predicate. *)
	1459
	1460	Inductive rbt : nat -> tree -> Prop :=
	1461	\| RB_Leaf : rbt 0 Leaf
	1462	\| RB_Rd n l k r :
	1463	notred l -> notred r -> rbt n l -> rbt n r -> rbt n (Rd l k r)
	1464	\| RB_Bk n l k r : rbt n l -> rbt n r -> rbt (S n) (Bk l k r).
	1465
	1466	(** A red-red tree is almost a red-black tree, except that it has
	1467	a _red_ root node which _may_ have red children. Note that a
	1468	red-red tree is hence non-empty, and all its strict subtrees
	1469	are red-black. *)
	1470
	1471	Inductive rrt (n:nat) : tree -> Prop :=
	1472	\| RR_Rd l k r : rbt n l -> rbt n r -> rrt n (Rd l k r).
	1473
	1474	(** An almost-red-black tree is almost a red-black tree, except that
	1475	it's permitted to have two red nodes in a row at the very root (only).
	1476	We implement this notion by saying that a quasi-red-black tree
	1477	is either a red-black tree or a red-red tree. *)
	1478
	1479	Inductive arbt (n:nat)(t:tree) : Prop :=
	1480	\| ARB_RB : rbt n t -> arbt n t
	1481	\| ARB_RR : rrt n t -> arbt n t.
	1482
	1483	(** The main exported invariant : being a red-black tree for some
	1484	black depth. *)
	1485
	1486	Class Rbt (t:tree) := RBT : exists d, rbt d t.
	1487
	1488	( Basic tactics and results about red-black *)
	1489
	1490	Scheme rbt_ind := Induction for rbt Sort Prop.
	1491	Local Hint Constructors rbt rrt arbt.
	1492	Local Hint Extern 0 (notred _) => (exact I).
	1493	Ltac invrb := intros; invtree rrt; invtree rbt; try contradiction.
	1494	Ltac desarb := match goal with H:arbt _ _ \|- _ => destruct H end.
	1495	Ltac nonzero n := destruct n as [\|n]; [try split; invrb\|].
	1496
	1497	Lemma rr_nrr_rb n t :
	1498	rrt n t -> notredred t -> rbt n t.
	1499	Proof.
	1500	destruct 1 as [l x r Hl Hr].
	1501	destruct l, r; descolor; invrb; auto.
	1502	Qed.
	1503
	1504	Local Hint Resolve rr_nrr_rb.
	1505
	1506	Lemma arb_nrr_rb n t :
	1507	arbt n t -> notredred t -> rbt n t.
	1508	Proof.
	1509	destruct 1; auto.
	1510	Qed.
	1511
	1512	Lemma arb_nr_rb n t :
	1513	arbt n t -> notred t -> rbt n t.
	1514	Proof.
	1515	destruct 1; destruct t; descolor; invrb; auto.
	1516	Qed.
	1517
	1518	Local Hint Resolve arb_nrr_rb arb_nr_rb.
	1519
	1520	( A Red-Black tree has indeed a logarithmic depth *)
	1521
	1522	Definition redcarac s := rcase (fun _ _ _ => 1) (fun _ => 0) s.
	1523
	1524	Lemma rb_maxdepth s n : rbt n s -> maxdepth s <= 2*n + redcarac s.
	1525	Proof.
	1526	induction 1.
	1527	- simpl; auto.
	1528	- replace (redcarac l) with 0 in * by now destree l.
	1529	replace (redcarac r) with 0 in * by now destree r.
	1530	simpl maxdepth. simpl redcarac.
	1531	rewrite Nat.add_succ_r, <- Nat.succ_le_mono.
	1532	now apply Nat.max_lub.
	1533	- simpl. Nat.nzsimpl. rewrite <- Nat.succ_le_mono.
	1534	apply Nat.max_lub; eapply Nat.le_trans; eauto.
	1535	destree l; simpl; lia.
	1536	destree r; simpl; lia.
	1537	Qed.
	1538
	1539	Lemma rb_mindepth s n : rbt n s -> n + redcarac s <= mindepth s.
	1540	Proof.
	1541	induction 1; simpl.
	1542	- trivial.
	1543	- rewrite Nat.add_succ_r.
	1544	apply -> Nat.succ_le_mono.
	1545	replace (redcarac l) with 0 in * by now destree l.
	1546	replace (redcarac r) with 0 in * by now destree r.
	1547	now apply Nat.min_glb.
	1548	- apply -> Nat.succ_le_mono. apply Nat.min_glb; lia.
	1549	Qed.
	1550
	1551	Lemma maxdepth_upperbound s : Rbt s ->
	1552	maxdepth s <= 2 * log2 (S (cardinal s)).
	1553	Proof.
	1554	intros (n,H).
	1555	eapply Nat.le_trans; [eapply rb_maxdepth; eauto\|].
	1556	generalize (rb_mindepth s n H).
	1557	generalize (mindepth_log_cardinal s). lia.
	1558	Qed.
	1559
	1560	Lemma maxdepth_lowerbound s : s<>Leaf ->
	1561	log2 (cardinal s) < maxdepth s.
	1562	Proof.
	1563	apply maxdepth_log_cardinal.
	1564	Qed.
	1565
	1566
	1567	( Singleton *)
	1568
	1569	Lemma singleton_rb x : Rbt (singleton x).
	1570	Proof.
	1571	unfold singleton. exists 1; auto.
	1572	Qed.
	1573
	1574	( [makeBlack] and [makeRed] *)
	1575
	1576	Lemma makeBlack_rb n t : arbt n t -> Rbt (makeBlack t).
	1577	Proof.
	1578	destruct t as [\|[\|] l x r].
	1579	- exists 0; auto.
	1580	- destruct 1; invrb; exists (S n); simpl; auto.
	1581	- exists n; auto.
	1582	Qed.
	1583
	1584	Lemma makeRed_rr t n :
	1585	rbt (S n) t -> notred t -> rrt n (makeRed t).
	1586	Proof.
	1587	destruct t as [\|[\|] l x r]; invrb; simpl; auto.
	1588	Qed.
	1589
	1590	( Balancing *)
	1591
	1592	Lemma lbal_rb n l k r :
	1593	arbt n l -> rbt n r -> rbt (S n) (lbal l k r).
	1594	Proof.
	1595	case lbal_match; intros; desarb; invrb; auto.
	1596	Qed.
	1597
	1598	Lemma rbal_rb n l k r :
	1599	rbt n l -> arbt n r -> rbt (S n) (rbal l k r).
	1600	Proof.
	1601	case rbal_match; intros; desarb; invrb; auto.
	1602	Qed.
	1603
	1604	Lemma rbal'_rb n l k r :
	1605	rbt n l -> arbt n r -> rbt (S n) (rbal' l k r).
	1606	Proof.
	1607	case rbal'_match; intros; desarb; invrb; auto.
	1608	Qed.
	1609
	1610	Lemma lbalS_rb n l x r :
	1611	arbt n l -> rbt (S n) r -> notred r -> rbt (S n) (lbalS l x r).
	1612	Proof.
	1613	intros Hl Hr Hr'.
	1614	destruct r as [\|[\|] rl rx rr]; invrb. clear Hr'.
	1615	revert Hl.
	1616	case lbalS_match.
	1617	- destruct 1; invrb; auto.
	1618	- intros. apply rbal'_rb; auto.
	1619	Qed.
	1620
	1621	Lemma lbalS_arb n l x r :
	1622	arbt n l -> rbt (S n) r -> arbt (S n) (lbalS l x r).
	1623	Proof.
	1624	case lbalS_match.
	1625	- destruct 1; invrb; auto.
	1626	- clear l. intros l Hl Hl' Hr.
	1627	destruct r as [\|[\|] rl rx rr]; invrb.
	1628	* destruct rl as [\|[\|] rll rlx rlr]; invrb.
	1629	right; auto using rbal'_rb, makeRed_rr.
	1630	* left; apply rbal'_rb; auto.
	1631	Qed.
	1632
	1633	Lemma rbalS_rb n l x r :
	1634	rbt (S n) l -> notred l -> arbt n r -> rbt (S n) (rbalS l x r).
	1635	Proof.
	1636	intros Hl Hl' Hr.
	1637	destruct l as [\|[\|] ll lx lr]; invrb. clear Hl'.
	1638	revert Hr.
	1639	case rbalS_match.
	1640	- destruct 1; invrb; auto.
	1641	- intros. apply lbal_rb; auto.
	1642	Qed.
	1643
	1644	Lemma rbalS_arb n l x r :
	1645	rbt (S n) l -> arbt n r -> arbt (S n) (rbalS l x r).
	1646	Proof.
	1647	case rbalS_match.
	1648	- destruct 2; invrb; auto.
	1649	- clear r. intros r Hr Hr' Hl.
	1650	destruct l as [\|[\|] ll lx lr]; invrb.
	1651	* destruct lr as [\|[\|] lrl lrx lrr]; invrb.
	1652	right; auto using lbal_rb, makeRed_rr.
	1653	* left; apply lbal_rb; auto.
	1654	Qed.
	1655
	1656
	1657	( Insertion *)
	1658
	1659	(** The next lemmas combine simultaneous results about rbt and arbt.
	1660	A first solution here: statement with [if ... then ... else] *)
	1661
	1662	Definition ifred s (A B:Prop) := rcase (fun _ _ _ => A) (fun _ => B) s.
	1663
	1664	Lemma ifred_notred s A B : notred s -> (ifred s A B <-> B).
	1665	Proof.
	1666	destruct s; descolor; simpl; intuition.
	1667	Qed.
	1668
	1669	Lemma ifred_or s A B : ifred s A B -> A\/B.
	1670	Proof.
	1671	destruct s; descolor; simpl; intuition.
	1672	Qed.
	1673
	1674	Lemma ins_rr_rb x s n : rbt n s ->
	1675	ifred s (rrt n (ins x s)) (rbt n (ins x s)).
	1676	Proof.
	1677	induction 1 as [ \| n l k r \| n l k r Hl IHl Hr IHr ].
	1678	- simpl; auto.
	1679	- simpl. rewrite ifred_notred in * by trivial.
	1680	elim_compare x k; auto.
	1681	- rewrite ifred_notred by trivial.
	1682	unfold ins; fold ins. (* simpl is too much here ... *)
	1683	elim_compare x k.
	1684	* auto.
	1685	* apply lbal_rb; trivial. apply ifred_or in IHl; intuition.
	1686	* apply rbal_rb; trivial. apply ifred_or in IHr; intuition.
	1687	Qed.
	1688
	1689	Lemma ins_arb x s n : rbt n s -> arbt n (ins x s).
	1690	Proof.
	1691	intros H. apply (ins_rr_rb x), ifred_or in H. intuition.
	1692	Qed.
	1693
	1694	Instance add_rb x s : Rbt s -> Rbt (add x s).
	1695	Proof.
	1696	intros (n,H). unfold add. now apply (makeBlack_rb n), ins_arb.
	1697	Qed.
	1698
	1699	( Deletion *)
	1700
	1701	(** A second approach here: statement with ... /\ ... *)
	1702
	1703	Lemma append_arb_rb n l r : rbt n l -> rbt n r ->
	1704	(arbt n (append l r)) /\
	1705	(notred l -> notred r -> rbt n (append l r)).
	1706	Proof.
	1707	revert r n.
	1708	append_tac l r.
	1709	- split; auto.
	1710	- split; auto.
	1711	- (* Red / Red *)
	1712	intros n. invrb.
	1713	case (IHlr n); auto; clear IHlr.
	1714	case append_rr_match.
	1715	+ intros a x b _ H; split; invrb.
	1716	assert (rbt n (Rd a x b)) by auto. invrb. auto.
	1717	+ split; invrb; auto.
	1718	- (* Red / Black *)
	1719	split; invrb. destruct (IHlr n) as (_,IH); auto.
	1720	- (* Black / Red *)
	1721	split; invrb. destruct (IHrl n) as (_,IH); auto.
	1722	- (* Black / Black *)
	1723	nonzero n.
	1724	invrb.
	1725	destruct (IHlr n) as (IH,_); auto; clear IHlr.
	1726	revert IH.
	1727	case append_bb_match.
	1728	+ intros a x b IH; split; destruct IH; invrb; auto.
	1729	+ split; [left \| invrb]; auto using lbalS_rb.
	1730	Qed.
	1731
	1732	(** A third approach : Lemma ... with ... *)
	1733
	1734	Lemma del_arb s x n : rbt (S n) s -> isblack s -> arbt n (del x s)
	1735	with del_rb s x n : rbt n s -> notblack s -> rbt n (del x s).
	1736	Proof.
	1737	{ revert n.
	1738	induct s x; try destruct c; try contradiction; invrb.
	1739	- apply append_arb_rb; assumption.
	1740	- assert (IHl' := del_rb l x). clear IHr del_arb del_rb.
	1741	destruct l as [\|[\|] ll lx lr]; auto.
	1742	nonzero n. apply lbalS_arb; auto.
	1743	- assert (IHr' := del_rb r x). clear IHl del_arb del_rb.
	1744	destruct r as [\|[\|] rl rx rr]; auto.
	1745	nonzero n. apply rbalS_arb; auto. }
	1746	{ revert n.
	1747	induct s x; try assumption; try destruct c; try contradiction; invrb.
	1748	- apply append_arb_rb; assumption.
	1749	- assert (IHl' := del_arb l x). clear IHr del_arb del_rb.
	1750	destruct l as [\|[\|] ll lx lr]; auto.
	1751	nonzero n. destruct n as [\|n]; [invrb\|]; apply lbalS_rb; auto.
	1752	- assert (IHr' := del_arb r x). clear IHl del_arb del_rb.
	1753	destruct r as [\|[\|] rl rx rr]; auto.
	1754	nonzero n. apply rbalS_rb; auto. }
	1755	Qed.
	1756
	1757	Instance remove_rb s x : Rbt s -> Rbt (remove x s).
	1758	Proof.
	1759	intros (n,H). unfold remove.
	1760	destruct s as [\|[\|] l y r].
	1761	- apply (makeBlack_rb n). auto.
	1762	- apply (makeBlack_rb n). left. apply del_rb; simpl; auto.
	1763	- nonzero n. apply (makeBlack_rb n). apply del_arb; simpl; auto.
	1764	Qed.
	1765
	1766	( Treeify *)
	1767
	1768	Definition treeify_rb_invariant size depth (f:treeify_t) :=
	1769	forall acc,
	1770	size <= length acc ->
	1771	rbt depth (fst (f acc)) /\
	1772	size + length (snd (f acc)) = length acc.
	1773
	1774	Lemma treeify_zero_rb : treeify_rb_invariant 0 0 treeify_zero.
	1775	Proof.
	1776	intros acc _; simpl; auto.
	1777	Qed.
	1778
	1779	Lemma treeify_one_rb : treeify_rb_invariant 1 0 treeify_one.
	1780	Proof.
	1781	intros [\|x acc]; simpl; auto; inversion 1.
	1782	Qed.
	1783
	1784	Lemma treeify_cont_rb f g size1 size2 size d :
	1785	treeify_rb_invariant size1 d f ->
	1786	treeify_rb_invariant size2 d g ->
	1787	size = S (size1 + size2) ->
	1788	treeify_rb_invariant size (S d) (treeify_cont f g).
	1789	Proof.
	1790	intros Hf Hg H acc Hacc.
	1791	unfold treeify_cont.
	1792	specialize (Hf acc).
	1793	destruct (f acc) as (l, acc1). simpl in *.
	1794	destruct Hf as (Hf1, Hf2). { lia. }
	1795	destruct acc1 as [\|x acc2]; simpl in *. { lia. }
	1796	specialize (Hg acc2).
	1797	destruct (g acc2) as (r, acc3). simpl in *.
	1798	destruct Hg as (Hg1, Hg2). { lia. }
	1799	split; [auto \| lia].
	1800	Qed.
	1801
	1802	Lemma treeify_aux_rb n :
	1803	exists d, forall (b:bool),
	1804	treeify_rb_invariant (ifpred b (Pos.to_nat n)) d (treeify_aux b n).
	1805	Proof.
	1806	induction n as [n (d,IHn)\|n (d,IHn)\| ].
	1807	- exists (S d). intros b.
	1808	eapply treeify_cont_rb; [ apply (IHn false) \| apply (IHn b) \| ].
	1809	rewrite Pos2Nat.inj_xI. generalize (Pos2Nat.is_pos n).
	1810	destruct b; simpl; lia.
	1811	- exists (S d). intros b.
	1812	eapply treeify_cont_rb; [ apply (IHn b) \| apply (IHn true) \| ].
	1813	rewrite Pos2Nat.inj_xO. generalize (Pos2Nat.is_pos n).
	1814	destruct b; simpl; lia.
	1815	- exists 0; destruct b;
	1816	[ apply treeify_zero_rb \| apply treeify_one_rb ].
	1817	Qed.
	1818
	1819	(** The black depth of [treeify l] is actually a log2, but
	1820	we don't need to mention that. *)
	1821
	1822	Instance treeify_rb l : Rbt (treeify l).
	1823	Proof.
	1824	unfold treeify.
	1825	destruct (treeify_aux_rb (plength l)) as (d,H).
	1826	exists d.
	1827	apply H.
	1828	now rewrite plength_spec.
	1829	Qed.
	1830
	1831	( Filtering *)
	1832
	1833	Instance filter_rb f s : Rbt (filter f s).
	1834	Proof.
	1835	unfold filter; auto_tc.
	1836	Qed.
	1837
	1838	Instance partition_rb1 f s : Rbt (fst (partition f s)).
	1839	Proof.
	1840	unfold partition. destruct partition_aux. simpl. auto_tc.
	1841	Qed.
	1842
	1843	Instance partition_rb2 f s : Rbt (snd (partition f s)).
	1844	Proof.
	1845	unfold partition. destruct partition_aux. simpl. auto_tc.
	1846	Qed.
	1847
	1848	( Union, intersection, difference *)
	1849
	1850	Instance fold_add_rb s1 s2 : Rbt s2 -> Rbt (fold add s1 s2).
	1851	Proof.
	1852	intros. rewrite fold_spec, <- fold_left_rev_right. unfold elt in *.
	1853	induction (rev (elements s1)); simpl; unfold flip in *; auto_tc.
	1854	Qed.
	1855
	1856	Instance fold_remove_rb s1 s2 : Rbt s2 -> Rbt (fold remove s1 s2).
	1857	Proof.
	1858	intros. rewrite fold_spec, <- fold_left_rev_right. unfold elt in *.
	1859	induction (rev (elements s1)); simpl; unfold flip in *; auto_tc.
	1860	Qed.
	1861
	1862	Lemma union_rb s1 s2 : Rbt s1 -> Rbt s2 -> Rbt (union s1 s2).
	1863	Proof.
	1864	intros. unfold union, linear_union. destruct compare_height; auto_tc.
	1865	Qed.
	1866
	1867	Lemma inter_rb s1 s2 : Rbt s1 -> Rbt s2 -> Rbt (inter s1 s2).
	1868	Proof.
	1869	intros. unfold inter, linear_inter. destruct compare_height; auto_tc.
	1870	Qed.
	1871
	1872	Lemma diff_rb s1 s2 : Rbt s1 -> Rbt s2 -> Rbt (diff s1 s2).
	1873	Proof.
	1874	intros. unfold diff, linear_diff. destruct compare_height; auto_tc.
	1875	Qed.
	1876
	1877	End BalanceProps.
	1878
	1879	(** * Final Encapsulation
	1880
	1881	Now, in order to really provide a functor implementing [S], we
	1882	need to encapsulate everything into a type of binary search trees.
	1883	They also happen to be well-balanced, but this has no influence
	1884	on the correctness of operations, so we won't state this here,
	1885	see [BalanceProps] if you need more than just the MSet interface.
	1886	*)
	1887
	1888	Module Type MSetInterface_S_Ext := MSetInterface.S <+ MSetRemoveMin.
	1889
	1890	Module Make (X: Orders.OrderedType) <:
	1891	MSetInterface_S_Ext with Module E := X.
	1892	Module Raw. Include MakeRaw X. End Raw.
	1893	Include MSetInterface.Raw2Sets X Raw.
	1894
	1895	Definition opt_ok (x:option (elt * Raw.t)) :=
	1896	match x with Some (_,s) => Raw.Ok s \| None => True end.
	1897
	1898	Definition mk_opt_t (x: option (elt * Raw.t))(P: opt_ok x) :
	1899	option (elt * t) :=
	1900	match x as o return opt_ok o -> option (elt * t) with
	1901	\| Some (k,s') => fun P : Raw.Ok s' => Some (k, Mkt s')
	1902	\| None => fun _ => None
	1903	end P.
	1904
	1905	Definition remove_min s : option (elt * t) :=
	1906	mk_opt_t (Raw.remove_min (this s)) (Raw.remove_min_ok s).
	1907
	1908	Lemma remove_min_spec1 s x s' :
	1909	remove_min s = Some (x,s') ->
	1910	min_elt s = Some x /\ Equal (remove x s) s'.
	1911	Proof.
	1912	destruct s as (s,Hs).
	1913	unfold remove_min, mk_opt_t, min_elt, remove, Equal, In; simpl.
	1914	generalize (fun x s' => @Raw.remove_min_spec1 s x s' Hs).
	1915	set (P := Raw.remove_min_ok s). clearbody P.
	1916	destruct (Raw.remove_min s) as [(x0,s0)\|]; try easy.
	1917	intros H U. injection U. clear U; intros; subst. simpl.
	1918	destruct (H x s0); auto. subst; intuition.
	1919	Qed.
	1920
	1921	Lemma remove_min_spec2 s : remove_min s = None -> Empty s.
	1922	Proof.
	1923	destruct s as (s,Hs).
	1924	unfold remove_min, mk_opt_t, Empty, In; simpl.
	1925	generalize (Raw.remove_min_spec2 s).
	1926	set (P := Raw.remove_min_ok s). clearbody P.
	1927	destruct (Raw.remove_min s) as [(x0,s0)\|]; now intuition.
	1928	Qed.
	1929
	1930	End Make.

+2

-0

theories/MSets/vo.itarget less more

	0	MSetGenTree.vo
0	1	MSetAVL.vo
	2	MSetRBT.vo
1	3	MSetDecide.vo
2	4	MSetEqProperties.vo
3	5	MSetFacts.vo

+18

-8

theories/Program/Equality.v less more

27	27	Definition block {A : Type} (a : A) := a.
28	28
29	29	Ltac block_goal := match goal with [ \|- ?T ] => change (block T) end.
30		Ltac unblock_goal := cbv beta delta [block].
	30	Ltac unblock_goal := unfold block in *.
31	31
32	32	(** Notation for heterogenous equality. *)
33	33

213	213
214	214	Ltac simplify_IH_hyps := repeat
215	215	match goal with
216		\| [ hyp : _ \|- _ ] => specialize_eqs hyp
	216	\| [ hyp : context [ block _ ] \|- _ ] =>
	217	specialize_eqs hyp
217	218	end.
218	219
219	220	(** We split substitution tactics in the two directions depending on which

376	377	end.
377	378
378	379	Tactic Notation "intro_block" hyp(H) :=
379		(is_introduced H ; block_goal ; revert_until H) \|\|
	380	(is_introduced H ; block_goal ; revert_until H ; block_goal) \|\|
380	381	(let H' := fresh H in intros until H' ; block_goal) \|\| (intros ; block_goal).
381	382
382	383	Tactic Notation "intro_block_id" ident(H) :=
383		(is_introduced H ; block_goal ; revert_until H) \|\|
	384	(is_introduced H ; block_goal ; revert_until H; block_goal) \|\|
384	385	(let H' := fresh H in intros until H' ; block_goal) \|\| (intros ; block_goal).
385	386
386		Ltac simpl_dep_elim := simplify_dep_elim ; simplify_IH_hyps ; unblock_goal.
	387	Ltac unblock_dep_elim :=
	388	match goal with
	389	\| \|- block ?T =>
	390	match T with context [ block _ ] =>
	391	change T ; intros ; unblock_goal
	392	end
	393	\| _ => unblock_goal
	394	end.
	395
	396	Ltac simpl_dep_elim := simplify_dep_elim ; simplify_IH_hyps ; unblock_dep_elim.
387	397
388	398	Ltac do_intros H :=
389	399	(try intros until H) ; (intro_block_id H \|\| intro_block H).

394	404
395	405	Ltac do_depind tac H :=
396	406	(try intros until H) ; intro_block H ;
397		generalize_eqs_vars H ; tac H ; simplify_dep_elim ; simplify_IH_hyps ; unblock_goal.
	407	generalize_eqs_vars H ; tac H ; simpl_dep_elim.
398	408
399	409	(** To dependent elimination on some hyp. *)
400	410

411	421	(** A variant where generalized variables should be given by the user. *)
412	422
413	423	Ltac do_depelim' rev tac H :=
414		(try intros until H) ; block_goal ; rev H ; generalize_eqs H ; tac H ; simplify_dep_elim ;
415		simplify_IH_hyps ; unblock_goal.
	424	(try intros until H) ; block_goal ; rev H ;
	425	(try revert_until H ; block_goal) ; generalize_eqs H ; tac H ; simpl_dep_elim.
416	426
417	427	(** Calls [destruct] on the generalized hypothesis, results should be similar to inversion.
418	428	By default, we don't try to generalize the hyp by its variable indices. *)

+3

-1

theories/Unicode/Utf8_core.v less more

16	16
17	17	Notation "x ∨ y" := (x \/ y) (at level 85, right associativity) : type_scope.
18	18	Notation "x ∧ y" := (x /\ y) (at level 80, right associativity) : type_scope.
19		Notation "x → y" := (x -> y) (at level 90, right associativity): type_scope.
	19	Notation "x → y" := (x -> y)
	20	(at level 90, y at level 200, right associativity): type_scope.
	21
20	22	Notation "x ↔ y" := (x <-> y) (at level 95, no associativity): type_scope.
21	23	Notation "¬ x" := (~x) (at level 75, right associativity) : type_scope.
22	24	Notation "x ≠ y" := (x <> y) (at level 70) : type_scope.

+9

-1

theories/Vectors/Fin.v less more

13	13	the n-uplet and [FS] set (n-1)-uplet of all the element but the first.
14	14
15	15	Author: Pierre Boutillier
16		Institution: PPS, INRIA 12/2010
	16	Institution: PPS, INRIA 12/2010-01/2012
17	17	*)
18	18
19	19	Inductive t : nat -> Set :=

67	67	end a'
68	68	end.
69	69	End SCHEMES.
	70
	71	Definition FS_inj {n} (x y: t n) (eq: FS x = FS y): x = y :=
	72	match eq in _ = a return
	73	match a as a' in t m return match m with \|0 => Prop \|S n' => t n' -> Prop end
	74	with @F1 _ => fun _ => True \|@FS _ y => fun x' => x' = y end x with
	75	eq_refl => eq_refl
	76	end.
70	77
71	78	(** [to_nat f] = p iff [f] is the p{^ th} element of [fin m]. *)
72	79	Fixpoint to_nat {m} (n : t m) : {i \| i < m} :=

166	173
167	174	Lemma depair_sanity {m n} (o : t m) (p : t n) :
168	175	proj1_sig (to_nat (depair o p)) = n * (proj1_sig (to_nat o)) + (proj1_sig (to_nat p)).
	176	Proof.
169	177	induction o ; simpl.
170	178	rewrite L_sanity. now rewrite Mult.mult_0_r.
171	179

+12

-11

theories/Vectors/VectorDef.v less more

39	39	(rect: forall a {n} (v: t A (S n)), P v -> P (a :: v)) :=
40	40	fix rectS_fix {n} (v: t A (S n)) : P v :=
41	41	match v with
42		\|nil => @id
	42	\|nil => fun devil => False_rect (@ID) devil
43	43	\|cons a 0 v =>
44	44	match v as vnn in t _ nn
45	45	return
46	46	match nn,vnn with
47	47	\|0,vm => P (a :: vm)
48		\|S _,_ => ID
	48	\|S _,_ => _
49	49	end
50	50	with
51	51	\|nil => bas a
52		\|_ :: _ => @id
	52	\|_ :: _ => fun devil => False_rect (@ID) devil
53	53	end
54	54	\|cons a (S nn') v => rect a v (rectS_fix v)
55	55	end.

65	65	\|[] => fun v2 =>
66	66	match v2 with
67	67	\|[] => bas
68		\|_ :: _ => @id
	68	\|_ :: _ => fun devil => False_rect (@ID) devil
69	69	end
70	70	\|h1 :: t1 => fun v2 =>
71	71	match v2 with
72		\|[] => @id
	72	\|[] => fun devil => False_rect (@ID) devil
73	73	\|h2 :: t2 => fun t1' =>
74	74	rect (rect2_fix t1' t2) h1 h2
75	75	end t1

82	82	end.
83	83
84	84	(** A vector of length [S _] is [cons] *)
85		Definition caseS {A} (P : forall n, t A (S n) -> Type)
86		(H : forall h {n} t, @P n (h :: t)) {n} v : P n v :=
87		match v with
88		\|[] => @id (* Why needed ? *)
	85	Definition caseS {A} (P : forall {n}, t A (S n) -> Type)
	86	(H : forall h {n} t, @P n (h :: t)) {n} (v: t A (S n)) : P v :=
	87	match v as v' in t _ m return match m, v' with \|0, _ => False -> True \|S _, v0 => P v' end with
	88	\|[] => fun devil => False_rect _ devil (* subterm !!! *)
89	89	\|h :: t => H h t
90	90	end.
91	91	End SCHEMES.

110	110
111	111	Computational behavior of this function should be the same as
112	112	ocaml function. *)
113		Fixpoint nth {A} {m} (v' : t A m) (p : Fin.t m) {struct p} : A :=
	113	Definition nth {A} :=
	114	fix nth_fix {m} (v' : t A m) (p : Fin.t m) {struct v'} : A :=
114	115	match p in Fin.t m' return t A m' -> A with
115	116	\|Fin.F1 q => fun v => caseS (fun n v' => A) (fun h n t => h) v
116	117	\|Fin.FS q p' => fun v => (caseS (fun n v' => Fin.t n -> A)
117		(fun h n t p0 => nth t p0) v) p'
	118	(fun h n t p0 => nth_fix t p0) v) p'
118	119	end v'.
119	120
120	121	(** An equivalent definition of [nth]. *)

+6

-0

theories/Vectors/VectorSpec.v less more

14	14	Require Fin.
15	15	Require Import VectorDef.
16	16	Import VectorNotations.
	17
	18	Definition cons_inj A a1 a2 n (v1 v2 : t A n)
	19	(eq : a1 :: v1 = a2 :: v2) : a1 = a2 /\ v1 = v2 :=
	20	match eq in _ = x return caseS _ (fun a2' _ v2' => fun v1' => a1 = a2' /\ v1' = v2') x v1
	21	with \| eq_refl => conj eq_refl eq_refl
	22	end.
17	23
18	24	(** Lemmas are done for functions that use [Fin.t] but thanks to [Peano_dec.le_unique], all
19	25	is true for the one that use [lt] *)

+7

-7

theories/Wellfounded/Lexicographic_Product.v less more

53	53	subst x1.
54	54	apply IHAcc0.
55	55	elim inj_pair2 with A B x y' x0; assumption.
56		Qed.
	56	Defined.
57	57
58	58	Theorem wf_lexprod :
59	59	well_founded leA ->

64	64	apply acc_A_B_lexprod; auto with sets; intros.
65	65	red in wfB.
66	66	auto with sets.
67		Qed.
	67	Defined.
68	68
69	69
70	70	End WfLexicographic_Product.

87	87	inversion_clear H5; auto with sets.
88	88	apply IHAcc; auto.
89	89	apply Acc_intro; trivial.
90		Qed.
	90	Defined.
91	91
92	92
93	93	Lemma wf_symprod :

96	96	red in \|- *.
97	97	destruct a.
98	98	apply Acc_symprod; auto with sets.
99		Qed.
	99	Defined.
100	100
101	101	End Wf_Symmetric_Product.
102	102

127	127
128	128	apply sp_noswap.
129	129	apply left_sym; auto with sets.
130		Qed.
	130	Defined.
131	131
132	132
133	133	Lemma Acc_swapprod :

155	155	apply right_sym; auto with sets.
156	156
157	157	auto with sets.
158		Qed.
	158	Defined.
159	159
160	160
161	161	Lemma wf_swapprod : well_founded R -> well_founded SwapProd.

163	163	red in \|- *.
164	164	destruct a; intros.
165	165	apply Acc_swapprod; auto with sets.
166		Qed.
	166	Defined.
167	167
168	168	End Swap.

+68

-68

theories/ZArith/Int.v less more

15	15
16	16	Require Import ZArith.
17	17	Delimit Scope Int_scope with I.
18
	18	Local Open Scope Int_scope.
19	19
20	20	(** * a specification of integers *)
21	21
22	22	Module Type Int.
23	23
24		Open Scope Int_scope.
25
26		Parameter int : Set.
27
28		Parameter i2z : int -> Z.
29		Arguments i2z _%I.
30
31		Parameter _0 : int.
32		Parameter _1 : int.
33		Parameter _2 : int.
34		Parameter _3 : int.
35		Parameter plus : int -> int -> int.
36		Parameter opp : int -> int.
37		Parameter minus : int -> int -> int.
38		Parameter mult : int -> int -> int.
39		Parameter max : int -> int -> int.
	24	Parameter t : Set.
	25	Bind Scope Int_scope with t.
	26
	27	(** For compatibility *)
	28	Definition int := t.
	29
	30	Parameter i2z : t -> Z.
	31
	32	Parameter _0 : t.
	33	Parameter _1 : t.
	34	Parameter _2 : t.
	35	Parameter _3 : t.
	36	Parameter plus : t -> t -> t.
	37	Parameter opp : t -> t.
	38	Parameter minus : t -> t -> t.
	39	Parameter mult : t -> t -> t.
	40	Parameter max : t -> t -> t.
40	41
41	42	Notation "0" := _0 : Int_scope.
42	43	Notation "1" := _1 : Int_scope.

53	54
54	55	Notation "x == y" := (i2z x = i2z y)
55	56	(at level 70, y at next level, no associativity) : Int_scope.
56		Notation "x <= y" := (Zle (i2z x) (i2z y)): Int_scope.
57		Notation "x < y" := (Zlt (i2z x) (i2z y)) : Int_scope.
58		Notation "x >= y" := (Zge (i2z x) (i2z y)) : Int_scope.
59		Notation "x > y" := (Zgt (i2z x) (i2z y)): Int_scope.
	57	Notation "x <= y" := (i2z x <= i2z y)%Z : Int_scope.
	58	Notation "x < y" := (i2z x < i2z y)%Z : Int_scope.
	59	Notation "x >= y" := (i2z x >= i2z y)%Z : Int_scope.
	60	Notation "x > y" := (i2z x > i2z y)%Z : Int_scope.
60	61	Notation "x <= y <= z" := (x <= y /\ y <= z) : Int_scope.
61	62	Notation "x <= y < z" := (x <= y /\ y < z) : Int_scope.
62	63	Notation "x < y < z" := (x < y /\ y < z) : Int_scope.

64	65
65	66	(** Some decidability fonctions (informative). *)
66	67
67		Axiom gt_le_dec : forall x y: int, {x > y} + {x <= y}.
68		Axiom ge_lt_dec : forall x y : int, {x >= y} + {x < y}.
69		Axiom eq_dec : forall x y : int, { x == y } + {~ x==y }.
	68	Axiom gt_le_dec : forall x y : t, {x > y} + {x <= y}.
	69	Axiom ge_lt_dec : forall x y : t, {x >= y} + {x < y}.
	70	Axiom eq_dec : forall x y : t, { x == y } + {~ x==y }.
70	71
71	72	(** Specifications *)
72	73
73	74	(** First, we ask [i2z] to be injective. Said otherwise, our ad-hoc equality
74	75	[==] and the generic [=] are in fact equivalent. We define [==]
75		nonetheless since the translation to [Z] for using automatic tactic is easier. *)
76
77		Axiom i2z_eq : forall n p : int, n == p -> n = p.
	76	nonetheless since the translation to [Z] for using automatic tactic
	77	is easier. *)
	78
	79	Axiom i2z_eq : forall n p : t, n == p -> n = p.
78	80
79	81	(** Then, we express the specifications of the above parameters using their
80	82	Z counterparts. *)
81	83
82		Open Scope Z_scope.
83		Axiom i2z_0 : i2z _0 = 0.
84		Axiom i2z_1 : i2z _1 = 1.
85		Axiom i2z_2 : i2z _2 = 2.
86		Axiom i2z_3 : i2z _3 = 3.
87		Axiom i2z_plus : forall n p, i2z (n + p) = i2z n + i2z p.
88		Axiom i2z_opp : forall n, i2z (-n) = -i2z n.
89		Axiom i2z_minus : forall n p, i2z (n - p) = i2z n - i2z p.
90		Axiom i2z_mult : forall n p, i2z (n * p) = i2z n * i2z p.
91		Axiom i2z_max : forall n p, i2z (max n p) = Zmax (i2z n) (i2z p).
	84	Axiom i2z_0 : i2z _0 = 0%Z.
	85	Axiom i2z_1 : i2z _1 = 1%Z.
	86	Axiom i2z_2 : i2z _2 = 2%Z.
	87	Axiom i2z_3 : i2z _3 = 3%Z.
	88	Axiom i2z_plus : forall n p, i2z (n + p) = (i2z n + i2z p)%Z.
	89	Axiom i2z_opp : forall n, i2z (-n) = (-i2z n)%Z.
	90	Axiom i2z_minus : forall n p, i2z (n - p) = (i2z n - i2z p)%Z.
	91	Axiom i2z_mult : forall n p, i2z (n * p) = (i2z n * i2z p)%Z.
	92	Axiom i2z_max : forall n p, i2z (max n p) = Z.max (i2z n) (i2z p).
92	93
93	94	End Int.
94	95
95	96
96	97	(** * Facts and tactics using [Int] *)
97	98
98		Module MoreInt (I:Int).
99		Import I.
100
101		Open Scope Int_scope.
	99	Module MoreInt (Import I:Int).
	100	Local Notation int := I.t.
102	101
103	102	(** A magic (but costly) tactic that goes from [int] back to the [Z]
104	103	friendly world ... *)

107	106	i2z_0 i2z_1 i2z_2 i2z_3 i2z_plus i2z_opp i2z_minus i2z_mult i2z_max : i2z.
108	107
109	108	Ltac i2z := match goal with
110		\| H : (eq (A:=int) ?a ?b) \|- _ =>
111		generalize (f_equal i2z H);
112		try autorewrite with i2z; clear H; intro H; i2z
113		\| \|- (eq (A:=int) ?a ?b) => apply (i2z_eq a b); try autorewrite with i2z; i2z
114		\| H : _ \|- _ => progress autorewrite with i2z in H; i2z
115		\| _ => try autorewrite with i2z
116		end.
	109	\| H : ?a = ?b \|- _ =>
	110	generalize (f_equal i2z H);
	111	try autorewrite with i2z; clear H; intro H; i2z
	112	\| \|- ?a = ?b =>
	113	apply (i2z_eq a b); try autorewrite with i2z; i2z
	114	\| H : _ \|- _ => progress autorewrite with i2z in H; i2z
	115	\| _ => try autorewrite with i2z
	116	end.
117	117
118	118	(** A reflexive version of the [i2z] tactic *)
119	119

123	123	Anyhow, [i2z_refl] is enough for applying [romega]. *)
124	124
125	125	Ltac i2z_gen := match goal with
126		\| \|- (eq (A:=int) ?a ?b) => apply (i2z_eq a b); i2z_gen
127		\| H : (eq (A:=int) ?a ?b) \|- _ =>
	126	\| \|- ?a = ?b => apply (i2z_eq a b); i2z_gen
	127	\| H : ?a = ?b \|- _ =>
128	128	generalize (f_equal i2z H); clear H; i2z_gen
129		\| H : (eq (A:=Z) ?a ?b) \|- _ => revert H; i2z_gen
130		\| H : (Zlt ?a ?b) \|- _ => revert H; i2z_gen
131		\| H : (Zle ?a ?b) \|- _ => revert H; i2z_gen
132		\| H : (Zgt ?a ?b) \|- _ => revert H; i2z_gen
133		\| H : (Zge ?a ?b) \|- _ => revert H; i2z_gen
	129	\| H : eq (A:=Z) ?a ?b \|- _ => revert H; i2z_gen
	130	\| H : Z.lt ?a ?b \|- _ => revert H; i2z_gen
	131	\| H : Z.le ?a ?b \|- _ => revert H; i2z_gen
	132	\| H : Z.gt ?a ?b \|- _ => revert H; i2z_gen
	133	\| H : Z.ge ?a ?b \|- _ => revert H; i2z_gen
134	134	\| H : _ -> ?X \|- _ =>
135	135	(* A [Set] or [Type] part cannot be dealt with easily
136	136	using the [ExprP] datatype. So we forget it, leaving

200	200
201	201	with z2ez trm :=
202	202	match constr:trm with
203		\| (?x+?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZplus ex ey)
204		\| (?x-?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZminus ex ey)
205		\| (?x*?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZmult ex ey)
206		\| (Zmax ?x ?y) => let ex := z2ez x with ey := z2ez y in constr:(EZmax ex ey)
207		\| (-?x)%Z => let ex := z2ez x in constr:(EZopp ex)
	203	\| (?x + ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZplus ex ey)
	204	\| (?x - ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZminus ex ey)
	205	\| (?x * ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZmult ex ey)
	206	\| (Z.max ?x ?y) => let ex := z2ez x with ey := z2ez y in constr:(EZmax ex ey)
	207	\| (- ?x)%Z => let ex := z2ez x in constr:(EZopp ex)
208	208	\| i2z ?x => let ex := i2ei x in constr:(EZofI ex)
209	209	\| ?x => constr:(EZraw x)
210	210	end.

359	359	(** It's always nice to know that our [Int] interface is realizable :-) *)
360	360
361	361	Module Z_as_Int <: Int.
362		Open Scope Z_scope.
363		Definition int := Z.
	362	Local Open Scope Z_scope.
	363	Definition t := Z.
	364	Definition int := t.
364	365	Definition _0 := 0.
365	366	Definition _1 := 1.
366	367	Definition _2 := 2.

379	380	Lemma i2z_1 : i2z _1 = 1. Proof. auto. Qed.
380	381	Lemma i2z_2 : i2z _2 = 2. Proof. auto. Qed.
381	382	Lemma i2z_3 : i2z _3 = 3. Proof. auto. Qed.
382		Lemma i2z_plus : forall n p, i2z (n + p) = i2z n + i2z p. Proof. auto. Qed.
383		Lemma i2z_opp : forall n, i2z (- n) = - i2z n. Proof. auto. Qed.
384		Lemma i2z_minus : forall n p, i2z (n - p) = i2z n - i2z p. Proof. auto. Qed.
385		Lemma i2z_mult : forall n p, i2z (n * p) = i2z n * i2z p. Proof. auto. Qed.
386		Lemma i2z_max : forall n p, i2z (max n p) = Zmax (i2z n) (i2z p). Proof. auto. Qed.
	383	Lemma i2z_plus n p : i2z (n + p) = i2z n + i2z p. Proof. auto. Qed.
	384	Lemma i2z_opp n : i2z (- n) = - i2z n. Proof. auto. Qed.
	385	Lemma i2z_minus n p : i2z (n - p) = i2z n - i2z p. Proof. auto. Qed.
	386	Lemma i2z_mult n p : i2z (n * p) = i2z n * i2z p. Proof. auto. Qed.
	387	Lemma i2z_max n p : i2z (max n p) = Zmax (i2z n) (i2z p). Proof. auto. Qed.
387	388	End Z_as_Int.
388

+88

-0

theories/ZArith/ZOdiv.v less more

	0	(************************************************************************)
	1	(* v * The Coq Proof Assistant / The Coq Development Team *)
	2	(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *)
	3	(* \VV/ **************************************************************)
	4	(* // * This file is distributed under the terms of the *)
	5	(* * GNU Lesser General Public License Version 2.1 *)
	6	(************************************************************************)
	7
	8	Require Export ZOdiv_def.
	9	Require Import BinInt Zquot.
	10
	11	Notation ZO_div_mod_eq := Z.quot_rem' (only parsing).
	12	Notation ZOmod_lt := Zrem_lt (only parsing).
	13	Notation ZOmod_sgn := Zrem_sgn (only parsing).
	14	Notation ZOmod_sgn2 := Zrem_sgn2 (only parsing).
	15	Notation ZOmod_lt_pos := Zrem_lt_pos (only parsing).
	16	Notation ZOmod_lt_neg := Zrem_lt_neg (only parsing).
	17	Notation ZOmod_lt_pos_pos := Zrem_lt_pos_pos (only parsing).
	18	Notation ZOmod_lt_pos_neg := Zrem_lt_pos_neg (only parsing).
	19	Notation ZOmod_lt_neg_pos := Zrem_lt_neg_pos (only parsing).
	20	Notation ZOmod_lt_neg_neg := Zrem_lt_neg_neg (only parsing).
	21
	22	Notation ZOdiv_opp_l := Zquot_opp_l (only parsing).
	23	Notation ZOdiv_opp_r := Zquot_opp_r (only parsing).
	24	Notation ZOmod_opp_l := Zrem_opp_l (only parsing).
	25	Notation ZOmod_opp_r := Zrem_opp_r (only parsing).
	26	Notation ZOdiv_opp_opp := Zquot_opp_opp (only parsing).
	27	Notation ZOmod_opp_opp := Zrem_opp_opp (only parsing).
	28
	29	Notation Remainder := Remainder (only parsing).
	30	Notation Remainder_alt := Remainder_alt (only parsing).
	31	Notation Remainder_equiv := Remainder_equiv (only parsing).
	32	Notation ZOdiv_mod_unique_full := Zquot_mod_unique_full (only parsing).
	33	Notation ZOdiv_unique_full := Zquot_unique_full (only parsing).
	34	Notation ZOdiv_unique := Zquot_unique (only parsing).
	35	Notation ZOmod_unique_full := Zrem_unique_full (only parsing).
	36	Notation ZOmod_unique := Zrem_unique (only parsing).
	37
	38	Notation ZOmod_0_l := Zrem_0_l (only parsing).
	39	Notation ZOmod_0_r := Zrem_0_r (only parsing).
	40	Notation ZOdiv_0_l := Zquot_0_l (only parsing).
	41	Notation ZOdiv_0_r := Zquot_0_r (only parsing).
	42	Notation ZOmod_1_r := Zrem_1_r (only parsing).
	43	Notation ZOdiv_1_r := Zquot_1_r (only parsing).
	44	Notation ZOdiv_1_l := Zquot_1_l (only parsing).
	45	Notation ZOmod_1_l := Zrem_1_l (only parsing).
	46	Notation ZO_div_same := Z_quot_same (only parsing).
	47	Notation ZO_mod_same := Z_rem_same (only parsing).
	48	Notation ZO_mod_mult := Z_rem_mult (only parsing).
	49	Notation ZO_div_mult := Z_quot_mult (only parsing).
	50
	51	Notation ZO_div_pos := Z_quot_pos (only parsing).
	52	Notation ZO_div_lt := Z_quot_lt (only parsing).
	53	Notation ZOdiv_small := Zquot_small (only parsing).
	54	Notation ZOmod_small := Zrem_small (only parsing).
	55	Notation ZO_div_monotone := Z_quot_monotone (only parsing).
	56	Notation ZO_mult_div_le := Z_mult_quot_le (only parsing).
	57	Notation ZO_mult_div_ge := Z_mult_quot_ge (only parsing).
	58	Definition ZO_div_exact_full_1 a b := proj1 (Z_quot_exact_full a b).
	59	Definition ZO_div_exact_full_2 a b := proj2 (Z_quot_exact_full a b).
	60	Notation ZOmod_le := Zrem_le (only parsing).
	61	Notation ZOdiv_le_upper_bound := Zquot_le_upper_bound (only parsing).
	62	Notation ZOdiv_lt_upper_bound := Zquot_lt_upper_bound (only parsing).
	63	Notation ZOdiv_le_lower_bound := Zquot_le_lower_bound (only parsing).
	64	Notation ZOdiv_sgn := Zquot_sgn (only parsing).
	65
	66	Notation ZO_mod_plus := Z_rem_plus (only parsing).
	67	Notation ZO_div_plus := Z_quot_plus (only parsing).
	68	Notation ZO_div_plus_l := Z_quot_plus_l (only parsing).
	69	Notation ZOdiv_mult_cancel_r := Zquot_mult_cancel_r (only parsing).
	70	Notation ZOdiv_mult_cancel_l := Zquot_mult_cancel_l (only parsing).
	71	Notation ZOmult_mod_distr_l := Zmult_rem_distr_l (only parsing).
	72	Notation ZOmult_mod_distr_r := Zmult_rem_distr_r (only parsing).
	73	Notation ZOmod_mod := Zrem_rem (only parsing).
	74	Notation ZOmult_mod := Zmult_rem (only parsing).
	75	Notation ZOplus_mod := Zplus_rem (only parsing).
	76	Notation ZOplus_mod_idemp_l := Zplus_rem_idemp_l (only parsing).
	77	Notation ZOplus_mod_idemp_r := Zplus_rem_idemp_r (only parsing).
	78	Notation ZOmult_mod_idemp_l := Zmult_rem_idemp_l (only parsing).
	79	Notation ZOmult_mod_idemp_r := Zmult_rem_idemp_r (only parsing).
	80	Notation ZOdiv_ZOdiv := Zquot_Zquot (only parsing).
	81	Notation ZOdiv_mult_le := Zquot_mult_le (only parsing).
	82	Notation ZOmod_divides := Zrem_divides (only parsing).
	83
	84	Notation ZOdiv_eucl_Zdiv_eucl_pos := Zquotrem_Zdiv_eucl_pos (only parsing).
	85	Notation ZOdiv_Zdiv_pos := Zquot_Zdiv_pos (only parsing).
	86	Notation ZOmod_Zmod_pos := Zrem_Zmod_pos (only parsing).
	87	Notation ZOmod_Zmod_zero := Zrem_Zmod_zero (only parsing).

+15

-0

theories/ZArith/ZOdiv_def.v less more

	0	(************************************************************************)
	1	(* v * The Coq Proof Assistant / The Coq Development Team *)
	2	(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *)
	3	(* \VV/ **************************************************************)
	4	(* // * This file is distributed under the terms of the *)
	5	(* * GNU Lesser General Public License Version 2.1 *)
	6	(************************************************************************)
	7
	8	Require Import BinInt.
	9
	10	Notation ZOdiv_eucl := Z.quotrem (only parsing).
	11	Notation ZOdiv := Z.quot (only parsing).
	12	Notation ZOmod := Z.rem (only parsing).
	13
	14	Notation ZOdiv_eucl_correct := Z.quotrem_eq.

+2

-4

theories/ZArith/Zeven.v less more

196	196	Lemma Zquot2_quot n : Z.quot2 n = n ÷ 2.
197	197	Proof.
198	198	assert (AUX : forall m, 0 < m -> Z.quot2 m = m ÷ 2).
199		BeginSubproof.
200		intros m Hm.
	199	{ intros m Hm.
201	200	apply Z.quot_unique with (if Z.odd m then Z.sgn m else 0).
202	201	now apply Z.lt_le_incl.
203	202	rewrite Z.sgn_pos by trivial.
204	203	destruct (Z.odd m); now split.
205		apply Zquot2_odd_eqn.
206		EndSubproof.
	204	apply Zquot2_odd_eqn. }
207	205	destruct (Z.lt_trichotomy 0 n) as [POS\|[NUL\|NEG]].
208	206	- now apply AUX.
209	207	- now subst.

+2

-0

theories/ZArith/vo.itarget less more

22	22	Zmisc.vo
23	23	Znat.vo
24	24	Znumtheory.vo
	25	ZOdiv_def.vo
	26	ZOdiv.vo
25	27	Zquot.vo
26	28	Zorder.vo
27	29	Zpow_def.vo

+14

-12

tools/coq_makefile.ml less more

314	314	print "%.vo %.glob: %.v\n\t$(COQC) $(COQDEBUG) $(COQFLAGS) $*\n\n";
315	315	print "%.vi: %.v\n\t$(COQC) -i $(COQDEBUG) $(COQFLAGS) $*\n\n";
316	316	print "%.g: %.v\n\t$(GALLINA) $<\n\n";
317		print "%.tex: %.v\n\t$(COQDOC) -latex $< -o $@\n\n";
318		print "%.html: %.v %.glob\n\t$(COQDOC) -html $< -o $@\n\n";
319		print "%.g.tex: %.v\n\t$(COQDOC) -latex -g $< -o $@\n\n";
320		print "%.g.html: %.v %.glob\n\t$(COQDOC) -html -g $< -o $@\n\n";
	317	print "%.tex: %.v\n\t$(COQDOC) $(COQDOCFLAGS) -latex $< -o $@\n\n";
	318	print "%.html: %.v %.glob\n\t$(COQDOC) $(COQDOCFLAGS) -html $< -o $@\n\n";
	319	print "%.g.tex: %.v\n\t$(COQDOC) $(COQDOCFLAGS) -latex -g $< -o $@\n\n";
	320	print "%.g.html: %.v %.glob\n\t$(COQDOC)$(COQDOCFLAGS) -html -g $< -o $@\n\n";
321	321	print "%.v.d: %.v\n";
322	322	print "\t$(COQDEP) -slash $(COQLIBS) \"$<\" > \"$@\" \|\| ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n";
323	323	print "%.v.beautified:\n\t$(COQC) $(COQDEBUG) $(COQFLAGS) -beautify $*\n\n"

348	348	print "\n";
349	349	end;
350	350	(* Coq executables and relative variables *)
	351	if !some_vfile \|\| !some_mlpackfile \|\| !some_mllibfile then
	352	print "COQDEP?=$(COQBIN)coqdep -c\n";
351	353	if !some_vfile then begin
352	354	print "COQFLAGS?=-q $(OPT) $(COQLIBS) $(OTHERFLAGS) $(COQ_XML)\n";
353	355	print "COQCHKFLAGS?=-silent -o\n";
	356	print "COQDOCFLAGS?=-interpolate -utf8\n";
354	357	print "COQC?=$(COQBIN)coqc\n";
355		print "COQDEP?=$(COQBIN)coqdep -c\n";
356	358	print "GALLINA?=$(COQBIN)gallina\n";
357	359	print "COQDOC?=$(COQBIN)coqdoc\n";
358	360	print "COQCHK?=$(COQBIN)coqchk\n\n";

373	375	print "CAMLOPTLINK?=$(OCAMLOPT) -rectypes\n";
374	376	print "GRAMMARS?=grammar.cma\n";
375	377	print "CAMLP4EXTEND?=pa_extend.cmo pa_macro.cmo q_MLast.cmo\n";
376		print "CAMLP4OPTIONS?=\n";
	378	print "CAMLP4OPTIONS?=-loc loc\n";
377	379	print "PP?=-pp \"$(CAMLP4BIN)$(CAMLP4)o -I $(CAMLLIB) -I . $(COQSRCLIBS) $(CAMLP4EXTEND) $(GRAMMARS) $(CAMLP4OPTIONS) -impl\"\n\n";
378	380	end;
379	381	match is_install with

563	565	print "gallina: $(GFILES)\n\n";
564	566	print "html: $(GLOBFILES) $(VFILES)\n";
565	567	print "\t- mkdir -p html\n";
566		print "\t$(COQDOC) -toc -html $(COQDOCLIBS) -d html $(VFILES)\n\n";
	568	print "\t$(COQDOC) -toc $(COQDOCFLAGS) -html $(COQDOCLIBS) -d html $(VFILES)\n\n";
567	569	print "gallinahtml: $(GLOBFILES) $(VFILES)\n";
568	570	print "\t- mkdir -p html\n";
569		print "\t$(COQDOC) -toc -html -g $(COQDOCLIBS) -d html $(VFILES)\n\n";
	571	print "\t$(COQDOC) -toc $(COQDOCFLAGS) -html -g $(COQDOCLIBS) -d html $(VFILES)\n\n";
570	572	print "all.ps: $(VFILES)\n";
571		print "\t$(COQDOC) -toc -ps $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^`\n\n";
	573	print "\t$(COQDOC) -toc $(COQDOCFLAGS) -ps $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^`\n\n";
572	574	print "all-gal.ps: $(VFILES)\n";
573		print "\t$(COQDOC) -toc -ps -g $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^`\n\n";
	575	print "\t$(COQDOC) -toc $(COQDOCFLAGS) -ps -g $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^`\n\n";
574	576	print "all.pdf: $(VFILES)\n";
575		print "\t$(COQDOC) -toc -pdf $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^`\n\n";
	577	print "\t$(COQDOC) -toc $(COQDOCFLAGS) -pdf $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^`\n\n";
576	578	print "all-gal.pdf: $(VFILES)\n";
577		print "\t$(COQDOC) -toc -pdf -g $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^`\n\n";
	579	print "\t$(COQDOC) -toc $(COQDOCFLAGS) -pdf -g $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^`\n\n";
578	580	print "validate: $(VOFILES)\n";
579	581	print "\t$(COQCHK) $(COQCHKFLAGS) $(COQLIBS) $(notdir $(^:.vo=))\n\n";
580	582	print "beautify: $(VFILES:=.beautified)\n";

+14

-6

tools/coqdoc/cpretty.mll less more

305	305
306	306	let prf_token =
307	307	"Next" space+ "Obligation"
308		\| "Proof" (space* "." \| space+ "with")
	308	\| "Proof" (space* "." \| space+ "with" \| space+ "using")
	309
	310	let immediate_prf_token =
	311	(* Approximation of a proof term, if not in the prf_token case *)
	312	(* To be checked after prf_token *)
	313	"Proof" space* [^ '.' 'w' 'u']
309	314
310	315	let def_token =
311	316	"Definition"

381	386	\| ("Hypothesis" \| "Hypotheses")
382	387	\| "End"
383	388
384		let end_kw = "Qed" \| "Defined" \| "Save" \| "Admitted" \| "Abort"
	389	let end_kw =
	390	immediate_prf_token \| "Qed" \| "Defined" \| "Save" \| "Admitted" \| "Abort"
385	391
386	392	let extraction =
387	393	"Extraction"

503	509	output_indented_keyword s lexbuf;
504	510	let eol= body lexbuf in
505	511	if eol then coq_bol lexbuf else coq lexbuf }
506		\| space* notation_kw space*
	512	\| space* notation_kw
507	513	{ let s = lexeme lexbuf in
508	514	output_indented_keyword s lexbuf;
509	515	let eol= start_notation_string lexbuf in

604	610	\| prf_token
605	611	{ let eol =
606	612	if not !Cdglobals.gallina then
607		begin backtrack lexbuf; body_bol lexbuf end
	613	begin backtrack lexbuf; body lexbuf end
608	614	else
609	615	let s = lexeme lexbuf in
610	616	let eol =

630	636	Output.ident s (lexeme_start lexbuf);
631	637	let eol = body lexbuf in
632	638	if eol then coq_bol lexbuf else coq lexbuf }
633		\| notation_kw space*
	639	\| notation_kw
634	640	{ let s = lexeme lexbuf in
635	641	Output.ident s (lexeme_start lexbuf);
636	642	let eol= start_notation_string lexbuf in

1095	1101	if eol
1096	1102	then begin if not !Cdglobals.parse_comments then Output.line_break(); body_bol lexbuf end
1097	1103	else body lexbuf }
1098		\| "where" space*
	1104	\| "where"
1099	1105	{ Tokens.flush_sublexer();
1100	1106	Output.ident (lexeme lexbuf) (lexeme_start lexbuf);
1101	1107	start_notation_string lexbuf }

1119	1125	body lexbuf }
1120	1126
1121	1127	and start_notation_string = parse
	1128	\| space { Tokens.flush_sublexer(); Output.char (lexeme_char lexbuf 0);
	1129	start_notation_string lexbuf }
1122	1130	\| '"' (* a true notation *)
1123	1131	{ Output.sublexer '"' (lexeme_start lexbuf);
1124	1132	notation_string lexbuf;

+3

-3

tools/coqdoc/index.ml less more

61	61	for loc = loc1 to loc2 do
62	62	Hashtbl.add reftable (!current_library, loc) (Def (full_ident sp id, ty))
63	63	done;
64		Hashtbl.add deftable id (Ref (!current_library, full_ident sp id, ty))
	64	Hashtbl.add deftable id (Def (full_ident sp id, ty))
65	65
66	66	let add_ref m loc m' sp id ty =
67	67	if Hashtbl.mem reftable (m, loc) then ()

288	288	let l = try Hashtbl.find bt t with Not_found -> [] in
289	289	Hashtbl.replace bt t ((s,m) :: l)
290	290	in
291		let classify (m,_) e = match e with
	291	let classify m e = match e with
292	292	\| Def (s,t) -> add_g s m t; add_bt t s m
293	293	\| Ref _ \| Mod _ -> ()
294	294	in
295		Hashtbl.iter classify reftable;
	295	Hashtbl.iter classify deftable;
296	296	Hashtbl.iter (fun id m -> add_g id m Library; add_bt Library id m) modules;
297	297	{ idx_name = "global";
298	298	idx_entries = sort_entries !gl;

+4

-4

tools/coqdoc/output.ml less more

28	28
29	29	let is_keyword =
30	30	build_table
31		[ "AddPath"; "Axiom"; "Abort"; "Chapter"; "Check"; "Coercion"; "CoFixpoint";
	31	[ "About"; "AddPath"; "Axiom"; "Abort"; "Chapter"; "Check"; "Coercion"; "Compute"; "CoFixpoint";
32	32	"CoInductive"; "Corollary"; "Defined"; "Definition"; "End"; "Eval"; "Example";
33		"Export"; "Fact"; "Fix"; "Fixpoint"; "Global"; "Grammar"; "Goal"; "Hint";
	33	"Export"; "Fact"; "Fix"; "Fixpoint"; "Function"; "Generalizable"; "Global"; "Grammar"; "Goal"; "Hint";
34	34	"Hypothesis"; "Hypotheses";
35	35	"Resolve"; "Unfold"; "Immediate"; "Extern"; "Implicit"; "Import"; "Inductive";
36	36	"Infix"; "Lemma"; "Let"; "Load"; "Local"; "Ltac";
37	37	"Module"; "Module Type"; "Declare Module"; "Include";
38		"Mutual"; "Parameter"; "Parameters"; "Print"; "Proof"; "Proof with"; "Qed";
	38	"Mutual"; "Parameter"; "Parameters"; "Print"; "Printing"; "Proof"; "Proof with"; "Qed";
39	39	"Record"; "Recursive"; "Remark"; "Require"; "Save"; "Scheme";
40	40	"Induction"; "for"; "Sort"; "Section"; "Show"; "Structure"; "Syntactic"; "Syntax"; "Tactic"; "Theorem";
41	41	"Set"; "Types"; "Undo"; "Unset"; "Variable"; "Variables"; "Context";

43	43	"Delimit"; "Bind"; "Open"; "Scope"; "Inline";
44	44	"Implicit Arguments"; "Add"; "Strict";
45	45	"Typeclasses"; "Instance"; "Global Instance"; "Class"; "Instantiation";
46		"subgoal";
	46	"subgoal"; "vm_compute";
47	47	"Opaque"; "Transparent";
48	48	(* Program *)
49	49	"Program Definition"; "Program Example"; "Program Fixpoint"; "Program Lemma";

+1

-0

tools/win32hack.mllib less more

0

Win32hack_filename⏎

+4

-0

tools/win32hack_filename.ml less more

	0	(* The mingw32-ocaml cross-compiler currently uses Filename.dir_sep="/".
	1	Let's tweak that... *)
	2
	3	let _ = Filename.dir_sep.[0] <- '\\'

+225

-0

toplevel/backtrack.ml less more

	0	(************************************************************************)
	1	(* v * The Coq Proof Assistant / The Coq Development Team *)
	2	(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
	3	(* \VV/ **************************************************************)
	4	(* // * This file is distributed under the terms of the *)
	5	(* * GNU Lesser General Public License Version 2.1 *)
	6	(************************************************************************)
	7
	8	open Names
	9	open Vernacexpr
	10
	11	(** Command history stack
	12
	13	We maintain a stack of the past states of the system. Each
	14	successfully interpreted command adds an [info] element
	15	to this stack, storing what were the (label / current proof / ...)
	16	just _after_ the interpretation of this command.
	17
	18	- A label is just an integer, starting from Lib.first_command_label
	19	initially, and incremented at each new successful command.
	20	- If some proofs are opened, we have their number in [nproofs],
	21	the name of the current proof in [prfname], the current depth in
	22	[prfdepth].
	23	- Otherwise, [nproofs = 0], [prfname = None], [prfdepth = 0]
	24	- The text of the command is stored (for Show Script currently).
	25	- A command can be tagged later as non-"reachable" when the current proof
	26	at the time of this command has been ended by Qed/Abort/Restart,
	27	meaning we can't backtrack there.
	28	*)
	29
	30	type info = {
	31	label : int;
	32	nproofs : int;
	33	prfname : identifier option;
	34	prfdepth : int;
	35	cmd : vernac_expr;
	36	mutable reachable : bool;
	37	}
	38
	39	let history : info Stack.t = Stack.create ()
	40
	41	(** For debug purpose, a dump of the history *)
	42
	43	let dump_history () =
	44	let l = ref [] in
	45	Stack.iter (fun i -> l:=i::!l) history;
	46	!l
	47
	48	(** Basic manipulation of the command history stack *)
	49
	50	exception Invalid
	51
	52	let pop () = ignore (Stack.pop history)
	53
	54	let npop n =
	55	(* Since our history stack always contains an initial entry,
	56	it's invalid to try to completely empty it *)
	57	if n < 0 \|\| n >= Stack.length history then raise Invalid
	58	else for i = 1 to n do pop () done
	59
	60	let top () =
	61	try Stack.top history with Stack.Empty -> raise Invalid
	62
	63	(** Search the history stack for a suitable location. We perform first
	64	a non-destructive search: in case of search failure, the stack is
	65	unchanged. *)
	66
	67	exception Found of info
	68
	69	let search test =
	70	try
	71	Stack.iter (fun i -> if test i then raise (Found i)) history;
	72	raise Invalid
	73	with Found i ->
	74	while i != Stack.top history do pop () done
	75
	76	(** Register the end of a command and store the current state *)
	77
	78	let mark_command ast =
	79	Lib.add_frozen_state();
	80	Lib.mark_end_of_command();
	81	Stack.push
	82	{ label = Lib.current_command_label ();
	83	nproofs = List.length (Pfedit.get_all_proof_names ());
	84	prfname = (try Some (Pfedit.get_current_proof_name ()) with _ -> None);
	85	prfdepth = max 0 (Pfedit.current_proof_depth ());
	86	reachable = true;
	87	cmd = ast }
	88	history
	89
	90	(** Backtrack by aborting [naborts] proofs, then setting proof-depth back to
	91	[pnum] and finally going to state number [snum]. *)
	92
	93	let raw_backtrack snum pnum naborts =
	94	for i = 1 to naborts do Pfedit.delete_current_proof () done;
	95	Pfedit.undo_todepth pnum;
	96	Lib.reset_label snum
	97
	98	(** Re-sync the state of the system (label, proofs) with the top
	99	of the history stack. We may end on some earlier state to avoid
	100	re-opening proofs. This function will return the final label
	101	and the number of extra backtracking steps performed. *)
	102
	103	let sync nb_opened_proofs =
	104	(* Backtrack by enough additional steps to avoid re-opening proofs.
	105	Typically, when a Qed has been crossed, we backtrack to the proof start.
	106	NB: We cannot reach the empty stack, since the first entry in the
	107	stack has no opened proofs and is tagged as reachable.
	108	*)
	109	let extra = ref 0 in
	110	while not (top()).reachable do incr extra; pop () done;
	111	let target = top ()
	112	in
	113	(* Now the opened proofs at target is a subset of the opened proofs before
	114	the backtrack, we simply abort the extra proofs (if any).
	115	NB: It is critical here that proofs are nested in a regular way
	116	(i.e. no more Resume or Suspend commands as earlier). This way, we can
	117	simply count the extra proofs to abort instead of taking care of their
	118	names.
	119	*)
	120	let naborts = nb_opened_proofs - target.nproofs in
	121	(* We are now ready to do a low-level backtrack *)
	122	raw_backtrack target.label target.prfdepth naborts;
	123	(target.label, !extra)
	124
	125	(** Backtracking by a certain number of (non-state-preserving) commands.
	126	This is used by Coqide.
	127	It may actually undo more commands than asked : for instance instead
	128	of jumping back in the middle of a finished proof, we jump back before
	129	this proof. The number of extra backtracked command is returned at
	130	the end. *)
	131
	132	let back count =
	133	if count = 0 then 0
	134	else
	135	let nb_opened_proofs = List.length (Pfedit.get_all_proof_names ()) in
	136	npop count;
	137	snd (sync nb_opened_proofs)
	138
	139	(** Backtracking to a certain state number, and reset proofs accordingly.
	140	We may end on some earlier state if needed to avoid re-opening proofs.
	141	Return the final state number. *)
	142
	143	let backto snum =
	144	if snum = Lib.current_command_label () then snum
	145	else
	146	let nb_opened_proofs = List.length (Pfedit.get_all_proof_names ()) in
	147	search (fun i -> i.label = snum);
	148	fst (sync nb_opened_proofs)
	149
	150	(** Old [Backtrack] code with corresponding update of the history stack.
	151	[Backtrack] is now deprecated (in favor of [BackTo]) but is kept for
	152	compatibility with ProofGeneral. It's completely up to ProofGeneral
	153	to decide where to go and how to adapt proofs. Note that the choices
	154	of ProofGeneral are currently not always perfect (for instance when
	155	backtracking an Undo). *)
	156
	157	let backtrack snum pnum naborts =
	158	raw_backtrack snum pnum naborts;
	159	search (fun i -> i.label = snum)
	160
	161	(** [reset_initial] resets the system and clears the command history
	162	stack, only pushing back the initial entry. It should be equivalent
	163	to [backto Lib.first_command_label], but sligthly more efficient. *)
	164
	165	let reset_initial () =
	166	let init_label = Lib.first_command_label in
	167	if Lib.current_command_label () = init_label then ()
	168	else begin
	169	Pfedit.delete_all_proofs ();
	170	Lib.reset_label init_label;
	171	Stack.clear history;
	172	Stack.push
	173	{ label = init_label;
	174	nproofs = 0;
	175	prfname = None;
	176	prfdepth = 0;
	177	reachable = true;
	178	cmd = VernacNop }
	179	history
	180	end
	181
	182	(** Reset to the last known state just before defining [id] *)
	183
	184	let reset_name id =
	185	let lbl =
	186	try Lib.label_before_name id with Not_found -> raise Invalid
	187	in
	188	ignore (backto lbl)
	189
	190	(** When a proof is ended (via either Qed/Admitted/Restart/Abort),
	191	old proof steps should be marked differently to avoid jumping back
	192	to them:
	193	- either this proof isn't there anymore in the proof engine
	194	- either it's there but it's a more recent attempt after a Restart,
	195	so we shouldn't mix the two.
	196	We also mark as unreachable the proof steps cancelled via a Undo. *)
	197
	198	let mark_unreachable ?(after=0) prf_lst =
	199	let fix i = match i.prfname with
	200	\| None -> raise Not_found (* stop hacking the history outside of proofs *)
	201	\| Some p ->
	202	if List.mem p prf_lst && i.prfdepth > after
	203	then i.reachable <- false
	204	in
	205	try Stack.iter fix history with Not_found -> ()
	206
	207	(** Parse the history stack for printing the script of a proof *)
	208
	209	let get_script prf =
	210	let script = ref [] in
	211	let select i = match i.prfname with
	212	\| None -> raise Not_found
	213	\| Some p when p=prf && i.reachable -> script := i :: !script
	214	\| _ -> ()
	215	in
	216	(try Stack.iter select history with Not_found -> ());
	217	(* Get rid of intermediate commands which don't grow the depth *)
	218	let rec filter n = function
	219	\| [] -> []
	220	\| {prfdepth=d; cmd=c}::l when n < d -> c :: filter d l
	221	\| {prfdepth=d}::l -> filter d l
	222	in
	223	(* initial proof depth (after entering the lemma statement) is 1 *)
	224	filter 1 !script

+93

-0

toplevel/backtrack.mli less more

	0	(************************************************************************)
	1	(* v * The Coq Proof Assistant / The Coq Development Team *)
	2	(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
	3	(* \VV/ **************************************************************)
	4	(* // * This file is distributed under the terms of the *)
	5	(* * GNU Lesser General Public License Version 2.1 *)
	6	(************************************************************************)
	7
	8	(** Command history stack
	9
	10	We maintain a stack of the past states of the system after each
	11	(non-state-preserving) interpreted commands
	12	*)
	13
	14	(** [mark_command ast] marks the end of a command:
	15	- it stores a frozen state and a end of command in the Lib stack,
	16	- it stores the current state information in the command history
	17	stack *)
	18
	19	val mark_command : Vernacexpr.vernac_expr -> unit
	20
	21	(** The [Invalid] exception is raised when one of the following function
	22	tries to empty the history stack, or reach an unknown states, etc.
	23	The stack is preserved in these cases. *)
	24
	25	exception Invalid
	26
	27	(** Nota Bene: it is critical for the following functions that proofs
	28	are nested in a regular way (i.e. no more Resume or Suspend commands
	29	as earlier). *)
	30
	31	(** Backtracking by a certain number of (non-state-preserving) commands.
	32	This is used by Coqide.
	33	It may actually undo more commands than asked : for instance instead
	34	of jumping back in the middle of a finished proof, we jump back before
	35	this proof. The number of extra backtracked command is returned at
	36	the end. *)
	37
	38	val back : int -> int
	39
	40	(** Backtracking to a certain state number, and reset proofs accordingly.
	41	We may end on some earlier state if needed to avoid re-opening proofs.
	42	Return the state number on which we finally end. *)
	43
	44	val backto : int -> int
	45
	46	(** Old [Backtrack] code with corresponding update of the history stack.
	47	[Backtrack] is now deprecated (in favor of [BackTo]) but is kept for
	48	compatibility with ProofGeneral. It's completely up to ProofGeneral
	49	to decide where to go and how to adapt proofs. Note that the choices
	50	of ProofGeneral are currently not always perfect (for instance when
	51	backtracking an Undo). *)
	52
	53	val backtrack : int -> int -> int -> unit
	54
	55	(** [reset_initial] resets the system and clears the command history
	56	stack, only pushing back the initial entry. It should be equivalent
	57	to [backto Lib.first_command_label], but sligthly more efficient. *)
	58
	59	val reset_initial : unit -> unit
	60
	61	(** Reset to the last known state just before defining [id] *)
	62
	63	val reset_name : Names.identifier Util.located -> unit
	64
	65	(** When a proof is ended (via either Qed/Admitted/Restart/Abort),
	66	old proof steps should be marked differently to avoid jumping back
	67	to them:
	68	- either this proof isn't there anymore in the proof engine
	69	- either a proof with the same name is there, but it's a more recent
	70	attempt after a Restart/Abort, we shouldn't mix the two.
	71	We also mark as unreachable the proof steps cancelled via a Undo.
	72	*)
	73
	74	val mark_unreachable : ?after:int -> Names.identifier list -> unit
	75
	76	(** Parse the history stack for printing the script of a proof *)
	77
	78	val get_script : Names.identifier -> Vernacexpr.vernac_expr list
	79
	80
	81	(** For debug purpose, a dump of the history *)
	82
	83	type info = {
	84	label : int;
	85	nproofs : int;
	86	prfname : Names.identifier option;
	87	prfdepth : int;
	88	cmd : Vernacexpr.vernac_expr;
	89	mutable reachable : bool;
	90	}
	91
	92	val dump_history : unit -> info list

+1

-1

toplevel/class.ml less more

254	254	in
255	255	check_source (Some cls);
256	256	if not (uniform_cond (llp-ind) lvs) then
257		raise (CoercionError NotUniform);
	257	warning (Pp.string_of_ppcmds (explain_coercion_error coef NotUniform));
258	258	let clt =
259	259	try
260	260	get_target tg ind

+8

-1

toplevel/classes.ml less more

251	251	let term = Termops.it_mkLambda_or_LetIn def ctx in
252	252	Some term, termtype
253	253	in
	254	let _ =
	255	evars := Evarutil.nf_evar_map !evars;
	256	evars := Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals ~fail:true
	257	env !evars;
	258	(* Try resolving fields that are typeclasses automatically. *)
	259	evars := Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars ~fail:false
	260	env !evars
	261	in
254	262	let termtype = Evarutil.nf_evar !evars termtype in
255	263	let term = Option.map (Evarutil.nf_evar !evars) term in
256	264	let evm = undefined_evars !evars in

258	266	if Evd.is_empty evm && term <> None then
259	267	declare_instance_constant k pri global imps ?hook id (Option.get term) termtype
260	268	else begin
261		evars := Typeclasses.resolve_typeclasses ~onlyargs:true ~fail:true env !evars;
262	269	let kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Instance in
263	270	Flags.silently (fun () ->
264	271	Lemmas.start_proof id kind termtype (fun _ -> instance_hook k pri global imps ?hook);

+23

-13

toplevel/command.ml less more

86	86	let typ = nf_evar !evdref (it_mkProd_or_LetIn ty ctx) in
87	87	check_evars env Evd.empty !evdref body;
88	88	check_evars env Evd.empty !evdref typ;
89		imps1@(Impargs.lift_implicits nb_args imps2),
	89	(* Check that all implicit arguments inferable from the term is inferable from the type *)
	90	if not (try List.for_all (fun (key,va) -> List.assoc key impsty = va) imps2 with Not_found -> false)
	91	then warn (str "Implicit arguments declaration relies on type." ++
	92	spc () ++ str "The term declares more implicits than the type here.");
	93	imps1@(Impargs.lift_implicits nb_args impsty),
90	94	{ const_entry_body = body;
91	95	const_entry_secctx = None;
92	96	const_entry_type = Some typ;

249	253	let mldatas = List.map2 (mk_mltype_data evdref env_params params) arities indnames in
250	254
251	255	let constructors =
252		States.with_state_protection (fun () ->
	256	Metasyntax.with_syntax_protection (fun () ->
253	257	(* Temporary declaration of notations and scopes *)
254	258	List.iter (Metasyntax.set_notation_for_interpretation impls) notations;
255	259	(* Interpret the constructor types *)

258	262
259	263	(* Instantiate evars and check all are resolved *)
260	264	let evd = consider_remaining_unif_problems env_params !evdref in
261		let evd = Typeclasses.resolve_typeclasses ~onlyargs:false ~fail:true env_params evd in
	265	let evd = Typeclasses.resolve_typeclasses ~filter:(Typeclasses.no_goals) ~fail:true env_params evd in
262	266	let sigma = evd in
263	267	let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map (nf_evar sigma) cl,impsl)) constructors in
264	268	let ctx_params = Sign.map_rel_context (nf_evar sigma) ctx_params in

458	462	let interp_fix_context evdref env isfix fix =
459	463	let before, after = if isfix then split_at_annot fix.fix_binders fix.fix_annot else [], fix.fix_binders in
460	464	let impl_env, ((env', ctx), imps) = interp_context_evars evdref env before in
461		let _, ((env'', ctx'), imps') = interp_context_evars ~impl_env evdref env' after in
	465	let impl_env', ((env'', ctx'), imps') = interp_context_evars ~impl_env evdref env' after in
462	466	let annot = Option.map (fun _ -> List.length (assums_of_rel_context ctx)) fix.fix_annot in
463		((env'', ctx' @ ctx), imps @ imps', annot)
464
465		let interp_fix_ccl evdref (env,_) fix =
466		interp_type_evars evdref env fix.fix_type
	467	((env'', ctx' @ ctx), (impl_env',imps @ imps'), annot)
	468
	469	let interp_fix_ccl evdref impls (env,_) fix =
	470	interp_type_evars_impls ~impls ~evdref ~fail_evar:false env fix.fix_type
467	471
468	472	let interp_fix_body evdref env_rec impls (_,ctx) fix ccl =
469	473	Option.map (fun body ->

513	517
514	518	(* Interp arities allowing for unresolved types *)
515	519	let evdref = ref Evd.empty in
516		let fixctxs, fiximps, fixannots =
	520	let fixctxs, fiximppairs, fixannots =
517	521	list_split3 (List.map (interp_fix_context evdref env isfix) fixl) in
518		let fixccls = List.map2 (interp_fix_ccl evdref) fixctxs fixl in
	522	let fixctximpenvs, fixctximps = List.split fiximppairs in
	523	let fixccls,fixcclimps = List.split (list_map3 (interp_fix_ccl evdref) fixctximpenvs fixctxs fixl) in
519	524	let fixtypes = List.map2 build_fix_type fixctxs fixccls in
520	525	let fixtypes = List.map (nf_evar !evdref) fixtypes in
	526	let fiximps = list_map3
	527	(fun ctximps cclimps (_,ctx) -> ctximps@(Impargs.lift_implicits (List.length ctx) cclimps))
	528	fixctximps fixcclimps fixctxs in
521	529	let env_rec = push_named_types env fixnames fixtypes in
522	530
523	531	(* Get interpretation metadatas *)

525	533
526	534	(* Interp bodies with rollback because temp use of notations/implicit *)
527	535	let fixdefs =
528		States.with_state_protection (fun () ->
	536	Metasyntax.with_syntax_protection (fun () ->
529	537	List.iter (Metasyntax.set_notation_for_interpretation impls) notations;
530		list_map3 (interp_fix_body evdref env_rec impls) fixctxs fixl fixccls)
	538	list_map4
	539	(fun fixctximpenv -> interp_fix_body evdref env_rec (Idmap.fold Idmap.add fixctximpenv impls))
	540	fixctximpenvs fixctxs fixl fixccls)
531	541	() in
532	542
533	543	(* Instantiate evars and check all are resolved *)

535	545	let fixdefs = List.map (Option.map (nf_evar evd)) fixdefs in
536	546	let fixtypes = List.map (nf_evar evd) fixtypes in
537	547	let fixctxnames = List.map (fun (_,ctx) -> List.map pi1 ctx) fixctxs in
538		let evd = Typeclasses.resolve_typeclasses ~onlyargs:false ~fail:true env evd in
	548	let evd = Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals ~fail:true env evd in
539	549	List.iter (Option.iter (check_evars env_rec Evd.empty evd)) fixdefs;
540	550	List.iter (check_evars env Evd.empty evd) fixtypes;
541	551	if not (List.mem None fixdefs) then begin

+8

-3

toplevel/coqtop.ml less more

246	246	\| "-compat" :: [] -> usage ()
247	247
248	248	\| "-vm" :: rem -> use_vm := true; parse rem
249		\| "-emacs" :: rem -> Flags.print_emacs := true; Pp.make_pp_emacs(); parse rem
	249	\| "-emacs" :: rem ->
	250	Flags.print_emacs := true; Pp.make_pp_emacs();
	251	Vernacentries.qed_display_script := false;
	252	parse rem
250	253	\| "-emacs-U" :: rem ->
251	254	warning "Obsolete option \"-emacs-U\", use -emacs instead.";
252		Flags.print_emacs := true; Pp.make_pp_emacs(); parse rem
	255	parse ("-emacs" :: rem)
253	256
254	257	\| "-unicode" :: rem -> add_require "Utf8_core"; parse rem
255	258

325	328	if_verbose print_header ();
326	329	init_load_path ();
327	330	inputstate ();
	331	Mltop.init_known_plugins ();
328	332	set_vm_opt ();
329	333	engage ();
330	334	if (not !batch_mode\|\| !compile_list=[]) && Global.env_is_empty() then

348	352	Pp.ppnl (with_option raw_print Prettyp.print_full_pure_context ());
349	353	Profile.print_profile ();
350	354	exit 0);
351		Lib.declare_initial_state ()
	355	(* We initialize the command history stack with a first entry *)
	356	Backtrack.mark_command Vernacexpr.VernacNop
352	357
353	358	let init_toplevel = init
354	359

+13

-3

toplevel/himsg.ml less more

30	30
31	31	let pr_lconstr c = quote (pr_lconstr c)
32	32	let pr_lconstr_env e c = quote (pr_lconstr_env e c)
33		let pr_lconstr_env_at_top e c = quote (pr_lconstr_env_at_top e c)
34	33	let pr_ljudge_env e c = let v,t = pr_ljudge_env e c in (quote v,quote t)
35	34
36	35	let pr_db env i =

695	694	str "applied to arguments" ++ spc () ++
696	695	prlist_with_sep pr_spc (pr_lconstr_env env) l
697	696
	697	let is_goal_evar evi = match evi.evar_source with (_, GoalEvar) -> true \| _ -> false
	698
698	699	let pr_constraints printenv env evm =
699	700	let evm = Evd.undefined_evars (Evarutil.nf_evar_map_undefined evm) in
	701	let evm = fold_undefined
	702	(fun ev evi evm' ->
	703	if is_goal_evar evi then Evd.remove evm' ev else evm') evm evm
	704	in
700	705	let l = Evd.to_list evm in
701	706	let (ev, evi) = List.hd l in
702	707	if List.for_all (fun (ev', evi') ->

818	823	else
819	824	mt()) ++ str "."
820	825
	826	let pr_ltype_using_barendregt_convention_env env c =
	827	(* Use goal_concl_style as an approximation of Barendregt's convention (?) *)
	828	quote (pr_goal_concl_style_env env c)
	829
821	830	let error_bad_ind_parameters env c n v1 v2 =
822		let pc = pr_lconstr_env_at_top env c in
	831	let pc = pr_ltype_using_barendregt_convention_env env c in
823	832	let pv1 = pr_lconstr_env env v1 in
824	833	let pv2 = pr_lconstr_env env v2 in
825	834	str "Last occurrence of " ++ pv2 ++ str " must have " ++ pv1 ++

977	986
978	987	let explain_reduction_tactic_error = function
979	988	\| Tacred.InvalidAbstraction (env,c,(env',e)) ->
980		str "The abstracted term" ++ spc () ++ pr_lconstr_env_at_top env c ++
	989	str "The abstracted term" ++ spc () ++
	990	quote (pr_goal_concl_style_env env c) ++
981	991	spc () ++ str "is not well typed." ++ fnl () ++
982	992	explain_type_error env' Evd.empty e
983	993

+117

-3

toplevel/ide_intf.ml less more

5	5	(* * GNU Lesser General Public License Version 2.1 *)
6	6	(************************************************************************)
7	7
	8	(** Protocol version of this file. This is the date of the last modification. *)
	9
	10	(** WARNING: TO BE UPDATED WHEN MODIFIED! *)
	11
	12	let protocol_version = "20120511"
	13
8	14	(** * Interface of calls to Coq by CoqIde *)
9	15
10	16	open Xml_parser

21	27	\| Evars
22	28	\| Hints
23	29	\| Status
	30	\| Search of search_flags
24	31	\| GetOptions
25	32	\| SetOptions of (option_name * option_value) list
26	33	\| InLoadPath of string
27	34	\| MkCases of string
	35	\| Quit
	36	\| About
	37
	38	(** The structure that coqtop should implement *)
	39
	40	type handler = {
	41	interp : raw * verbose * string -> string;
	42	rewind : int -> int;
	43	goals : unit -> goals option;
	44	evars : unit -> evar list option;
	45	hints : unit -> (hint list * hint) option;
	46	status : unit -> status;
	47	search : search_flags -> search_answer list;
	48	get_options : unit -> (option_name * option_state) list;
	49	set_options : (option_name * option_value) list -> unit;
	50	inloadpath : string -> bool;
	51	mkcases : string -> string list list;
	52	quit : unit -> unit;
	53	about : unit -> coq_info;
	54	handle_exn : exn -> location * string;
	55	}
28	56
29	57	(** The actual calls *)
30	58

34	62	let evars : evar list option call = Evars
35	63	let hints : (hint list * hint) option call = Hints
36	64	let status : status call = Status
	65	let search flags : search_answer list call = Search flags
37	66	let get_options : (option_name * option_state) list call = GetOptions
38	67	let set_options l : unit call = SetOptions l
39	68	let inloadpath s : bool call = InLoadPath s
40	69	let mkcases s : string list list call = MkCases s
	70	let quit : unit call = Quit
41	71
42	72	(** * Coq answers to CoqIde *)
43	73

50	80	\| Evars -> Obj.magic (handler.evars () : evar list option)
51	81	\| Hints -> Obj.magic (handler.hints () : (hint list * hint) option)
52	82	\| Status -> Obj.magic (handler.status () : status)
	83	\| Search flags -> Obj.magic (handler.search flags : search_answer list)
53	84	\| GetOptions -> Obj.magic (handler.get_options () : (option_name * option_state) list)
54	85	\| SetOptions opts -> Obj.magic (handler.set_options opts : unit)
55	86	\| InLoadPath s -> Obj.magic (handler.inloadpath s : bool)
56	87	\| MkCases s -> Obj.magic (handler.mkcases s : string list list)
	88	\| Quit -> Obj.magic (handler.quit () : unit)
	89	\| About -> Obj.magic (handler.about () : coq_info)
57	90	in Good res
58	91	with e ->
59	92	let (l, str) = handler.handle_exn e in

174	207	opt_depr = to_bool depr;
175	208	opt_name = to_string name;
176	209	opt_value = to_option_value value;
	210	}
	211	\| _ -> raise Marshal_error
	212
	213	let of_search_constraint = function
	214	\| Name_Pattern s ->
	215	constructor "search_constraint" "name_pattern" [of_string s]
	216	\| Type_Pattern s ->
	217	constructor "search_constraint" "type_pattern" [of_string s]
	218	\| SubType_Pattern s ->
	219	constructor "search_constraint" "subtype_pattern" [of_string s]
	220	\| In_Module m ->
	221	constructor "search_constraint" "in_module" [of_list of_string m]
	222	\| Include_Blacklist ->
	223	constructor "search_constraint" "include_blacklist" []
	224
	225	let to_search_constraint xml = do_match xml "search_constraint"
	226	(fun s args -> match s with
	227	\| "name_pattern" -> Name_Pattern (to_string (singleton args))
	228	\| "type_pattern" -> Type_Pattern (to_string (singleton args))
	229	\| "subtype_pattern" -> SubType_Pattern (to_string (singleton args))
	230	\| "in_module" -> In_Module (to_list to_string (singleton args))
	231	\| "include_blacklist" -> Include_Blacklist
	232	\| _ -> raise Marshal_error)
	233
	234	let of_search_answer ans =
	235	let path = of_list of_string ans.search_answer_full_path in
	236	let name = of_string ans.search_answer_base_name in
	237	let tpe = of_string ans.search_answer_type in
	238	Element ("search_answer", [], [path; name; tpe])
	239
	240	let to_search_answer = function
	241	\| Element ("search_answer", [], [path; name; tpe]) ->
	242	let path = to_list to_string path in
	243	let name = to_string name in
	244	let tpe = to_string tpe in {
	245	search_answer_full_path = path;
	246	search_answer_base_name = name;
	247	search_answer_type = tpe;
177	248	}
178	249	\| _ -> raise Marshal_error
179	250

217	288	Element ("call", ["val", "hints"], [])
218	289	\| Status ->
219	290	Element ("call", ["val", "status"], [])
	291	\| Search flags ->
	292	let args = List.map (of_pair of_search_constraint of_bool) flags in
	293	Element ("call", ["val", "search"], args)
220	294	\| GetOptions ->
221	295	Element ("call", ["val", "getoptions"], [])
222	296	\| SetOptions opts ->

226	300	Element ("call", ["val", "inloadpath"], [PCData file])
227	301	\| MkCases ind ->
228	302	Element ("call", ["val", "mkcases"], [PCData ind])
	303	\| Quit ->
	304	Element ("call", ["val", "quit"], [])
	305	\| About ->
	306	Element ("call", ["val", "about"], [])
229	307
230	308	let to_call = function
231	309	\| Element ("call", attrs, l) ->

241	319	\| "goal" -> Goal
242	320	\| "evars" -> Evars
243	321	\| "status" -> Status
	322	\| "search" ->
	323	let args = List.map (to_pair to_search_constraint to_bool) l in
	324	Search args
244	325	\| "getoptions" -> GetOptions
245	326	\| "setoptions" ->
246	327	let args = List.map (to_pair (to_list to_string) to_option_value) l in

248	329	\| "inloadpath" -> InLoadPath (raw_string l)
249	330	\| "mkcases" -> MkCases (raw_string l)
250	331	\| "hints" -> Hints
	332	\| "quit" -> Quit
	333	\| "about" -> About
251	334	\| _ -> raise Marshal_error
252	335	end
253	336	\| _ -> raise Marshal_error

274	357	let of_goal g =
275	358	let hyp = of_list of_string g.goal_hyp in
276	359	let ccl = of_string g.goal_ccl in
277		Element ("goal", [], [hyp; ccl])
	360	let id = of_string g.goal_id in
	361	Element ("goal", [], [id; hyp; ccl])
278	362
279	363	let to_goal = function
280		\| Element ("goal", [], [hyp; ccl]) ->
	364	\| Element ("goal", [], [id; hyp; ccl]) ->
281	365	let hyp = to_list to_string hyp in
282	366	let ccl = to_string ccl in
283		{ goal_hyp = hyp; goal_ccl = ccl }
	367	let id = to_string id in
	368	{ goal_hyp = hyp; goal_ccl = ccl; goal_id = id; }
284	369	\| _ -> raise Marshal_error
285	370
286	371	let of_goals g =

293	378	let fg = to_list to_goal fg in
294	379	let bg = to_list to_goal bg in
295	380	{ fg_goals = fg; bg_goals = bg; }
	381	\| _ -> raise Marshal_error
	382
	383	let of_coq_info info =
	384	let version = of_string info.coqtop_version in
	385	let protocol = of_string info.protocol_version in
	386	let release = of_string info.release_date in
	387	let compile = of_string info.compile_date in
	388	Element ("coq_info", [], [version; protocol; release; compile])
	389
	390	let to_coq_info = function
	391	\| Element ("coq_info", [], [version; protocol; release; compile]) ->
	392	{
	393	coqtop_version = to_string version;
	394	protocol_version = to_string protocol;
	395	release_date = to_string release;
	396	compile_date = to_string compile;
	397	}
296	398	\| _ -> raise Marshal_error
297	399
298	400	let of_hints =

307	409	\| Evars -> Obj.magic (of_option (of_list of_evar) : evar list option -> xml)
308	410	\| Hints -> Obj.magic (of_hints : (hint list * hint) option -> xml)
309	411	\| Status -> Obj.magic (of_status : status -> xml)
	412	\| Search _ -> Obj.magic (of_list of_search_answer : search_answer list -> xml)
310	413	\| GetOptions -> Obj.magic (of_list (of_pair (of_list of_string) of_option_state) : (option_name * option_state) list -> xml)
311	414	\| SetOptions _ -> Obj.magic (fun _ -> Element ("unit", [], []))
312	415	\| InLoadPath _ -> Obj.magic (of_bool : bool -> xml)
313	416	\| MkCases _ -> Obj.magic (of_list (of_list of_string) : string list list -> xml)
	417	\| Quit -> Obj.magic (fun _ -> Element ("unit", [], []))
	418	\| About -> Obj.magic (of_coq_info : coq_info -> xml)
314	419	in
315	420	of_value convert r
316	421

330	435	\| "evar" -> Obj.magic (to_evar elt : evar)
331	436	\| "option_value" -> Obj.magic (to_option_value elt : option_value)
332	437	\| "option_state" -> Obj.magic (to_option_state elt : option_state)
	438	\| "coq_info" -> Obj.magic (to_coq_info elt : coq_info)
	439	\| "search_answer" -> Obj.magic (to_search_answer elt : search_answer)
333	440	\| _ -> raise Marshal_error
334	441	end
335	442	\| _ -> raise Marshal_error

369	476	\| Evars -> "EVARS"
370	477	\| Hints -> "HINTS"
371	478	\| Status -> "STATUS"
	479	\| Search _ -> "SEARCH"
372	480	\| GetOptions -> "GETOPTIONS"
373	481	\| SetOptions l -> "SETOPTIONS" ^ " [" ^ pr_setoptions l ^ "]"
374	482	\| InLoadPath s -> "INLOADPATH "^s
375	483	\| MkCases s -> "MKCASES "^s
	484	\| Quit -> "QUIT"
	485	\| About -> "ABOUT"
376	486
377	487	let pr_value_gen pr = function
378	488	\| Good v -> "GOOD " ^ pr v

427	537	\| Evars -> pr_value_gen pr_evars (Obj.magic value : evar list option value)
428	538	\| Hints -> pr_value value
429	539	\| Status -> pr_value_gen pr_status (Obj.magic value : status value)
	540	\| Search _ -> pr_value value
430	541	\| GetOptions -> pr_value_gen pr_getoptions (Obj.magic value : (option_name * option_state) list value)
431	542	\| SetOptions _ -> pr_value value
432	543	\| InLoadPath s -> pr_value_gen pr_bool (Obj.magic value : bool value)
433	544	\| MkCases s -> pr_value_gen pr_mkcases (Obj.magic value : string list list value)
	545	\| Quit -> pr_value value
	546	\| About -> pr_value value
	547

+26

-0

toplevel/ide_intf.mli less more

64	64	to check that everything is correct. *)
65	65	val set_options : (option_name * option_value) list -> unit call
66	66
	67	(** Quit gracefully the interpreter. *)
	68	val quit : unit call
	69
	70	(** The structure that coqtop should implement *)
	71
	72	type handler = {
	73	interp : raw * verbose * string -> string;
	74	rewind : int -> int;
	75	goals : unit -> goals option;
	76	evars : unit -> evar list option;
	77	hints : unit -> (hint list * hint) option;
	78	status : unit -> status;
	79	search : search_flags -> search_answer list;
	80	get_options : unit -> (option_name * option_state) list;
	81	set_options : (option_name * option_value) list -> unit;
	82	inloadpath : string -> bool;
	83	mkcases : string -> string list list;
	84	quit : unit -> unit;
	85	about : unit -> coq_info;
	86	handle_exn : exn -> location * string;
	87	}
	88
67	89	val abstract_eval_call : handler -> 'a call -> 'a value
	90
	91	(** * Protocol version *)
	92
	93	val protocol_version : string
68	94
69	95	(** * XML data marshalling *)
70	96

+150

-286

toplevel/ide_slave.ml less more

18	18	when the -ideslave option is passed to Coqtop. Currently CoqIDE is
19	19	the only one using this mode, but we try here to be as generic as
20	20	possible, so this may change in the future... *)
21
22
23		(** Comment the next line for displaying some more debug messages *)
24
25		let prerr_endline _ = ()
26
27	21
28	22	(** Signal handling: we postpone ^C during input and output phases,
29	23	but make it directly raise a Sys.Break during evaluation of the request. *)

58	52	let r = Buffer.contents out_buff in
59	53	Buffer.clear out_buff; r)
60	54
	55	let pr_debug s =
	56	if !Flags.debug then Printf.eprintf "[pid %d] %s\n%!" (Unix.getpid ()) s
61	57
62	58	(** Categories of commands *)
63	59

72	68	["Printing";"Existential";"Instances"];
73	69	["Printing";"Universes"]]
74	70
75		type command_attribute =
76		NavigationCommand \| QueryCommand \| DebugCommand \| KnownOptionCommand
77		\| OtherStatePreservingCommand \| GoalStartingCommand \| SolveCommand
78		\| ProofEndingCommand
79
80		let rec attribute_of_vernac_command = function
81		(* Control *)
82		\| VernacTime com -> attribute_of_vernac_command com
83		\| VernacTimeout(_,com) -> attribute_of_vernac_command com
84		\| VernacFail com -> attribute_of_vernac_command com
85		\| VernacList _ -> [] (* unsupported *)
86		\| VernacLoad _ -> []
87
88		(* Syntax *)
89		\| VernacTacticNotation _ -> []
90		\| VernacSyntaxExtension _ -> []
91		\| VernacDelimiters _ -> []
92		\| VernacBindScope _ -> []
93		\| VernacOpenCloseScope _ -> []
94		\| VernacArgumentsScope _ -> []
95		\| VernacInfix _ -> []
96		\| VernacNotation _ -> []
97
98		(* Gallina *)
99		\| VernacDefinition (_,_,DefineBody _,_) -> []
100		\| VernacDefinition (_,_,ProveBody _,_) -> [GoalStartingCommand]
101		\| VernacStartTheoremProof _ -> [GoalStartingCommand]
102		\| VernacEndProof _ -> [ProofEndingCommand]
103		\| VernacExactProof _ -> [ProofEndingCommand]
104
105		\| VernacAssumption _ -> []
106		\| VernacInductive _ -> []
107		\| VernacFixpoint _ -> []
108		\| VernacCoFixpoint _ -> []
109		\| VernacScheme _ -> []
110		\| VernacCombinedScheme _ -> []
111
112		(* Modules *)
113		\| VernacDeclareModule _ -> []
114		\| VernacDefineModule _ -> []
115		\| VernacDeclareModuleType _ -> []
116		\| VernacInclude _ -> []
117
118		(* Gallina extensions *)
119		\| VernacBeginSection _ -> []
120		\| VernacEndSegment _ -> []
121		\| VernacRequire _ -> []
122		\| VernacImport _ -> []
123		\| VernacCanonical _ -> []
124		\| VernacCoercion _ -> []
125		\| VernacIdentityCoercion _ -> []
126
127		(* Type classes *)
128		\| VernacInstance _ -> []
129		\| VernacContext _ -> []
130		\| VernacDeclareInstances _ -> []
131		\| VernacDeclareClass _ -> []
132
133		(* Solving *)
134		\| VernacSolve _ -> [SolveCommand]
135		\| VernacSolveExistential _ -> [SolveCommand]
136
137		(* Auxiliary file and library management *)
138		\| VernacRequireFrom _ -> []
139		\| VernacAddLoadPath _ -> []
140		\| VernacRemoveLoadPath _ -> []
141		\| VernacAddMLPath _ -> []
142		\| VernacDeclareMLModule _ -> []
143		\| VernacChdir o ->
144		(* TODO: [Chdir d] is currently not undo-able (not stored in coq state).
145		But if we register [Chdir] in the state, loading [initial.coq] will
146		wrongly cd to the compile-time directory at each coqtop launch. *)
147		if o = None then [QueryCommand] else []
148
149		(* State management *)
150		\| VernacWriteState _ -> []
151		\| VernacRestoreState _ -> []
152
153		(* Resetting *)
154		\| VernacRemoveName _ -> [NavigationCommand]
155		\| VernacResetName _ -> [NavigationCommand]
156		\| VernacResetInitial -> [NavigationCommand]
157		\| VernacBack _ -> [NavigationCommand]
158		\| VernacBackTo _ -> [NavigationCommand]
159
160		(* Commands *)
161		\| VernacDeclareTacticDefinition _ -> []
162		\| VernacCreateHintDb _ -> []
163		\| VernacRemoveHints _ -> []
164		\| VernacHints _ -> []
165		\| VernacSyntacticDefinition _ -> []
166		\| VernacDeclareImplicits _ -> []
167		\| VernacArguments _ -> []
168		\| VernacDeclareReduction _ -> []
169		\| VernacReserve _ -> []
170		\| VernacGeneralizable _ -> []
171		\| VernacSetOpacity _ -> []
172		\| VernacSetOption (_,["Ltac";"Debug"], _) -> [DebugCommand]
173		\| VernacSetOption (_,o,BoolValue true) \| VernacUnsetOption (_,o) ->
174		if coqide_known_option o then [KnownOptionCommand] else []
175		\| VernacSetOption _ -> []
176		\| VernacRemoveOption _ -> []
177		\| VernacAddOption _ -> []
178		\| VernacMemOption _ -> [QueryCommand]
179
180		\| VernacPrintOption _ -> [QueryCommand]
181		\| VernacCheckMayEval _ -> [QueryCommand]
182		\| VernacGlobalCheck _ -> [QueryCommand]
183		\| VernacPrint _ -> [QueryCommand]
184		\| VernacSearch _ -> [QueryCommand]
185		\| VernacLocate _ -> [QueryCommand]
186
187		\| VernacComments _ -> [OtherStatePreservingCommand]
188		\| VernacNop -> [OtherStatePreservingCommand]
189
190		(* Proof management *)
191		\| VernacGoal _ -> [GoalStartingCommand]
192
193		\| VernacAbort _ -> []
194		\| VernacAbortAll -> [NavigationCommand]
195		\| VernacRestart -> [NavigationCommand]
196		\| VernacSuspend -> [NavigationCommand]
197		\| VernacResume _ -> [NavigationCommand]
198		\| VernacUndo _ -> [NavigationCommand]
199		\| VernacUndoTo _ -> [NavigationCommand]
200		\| VernacBacktrack _ -> [NavigationCommand]
201
202		\| VernacFocus _ -> [SolveCommand]
203		\| VernacUnfocus -> [SolveCommand]
204		\| VernacShow _ -> [OtherStatePreservingCommand]
205		\| VernacCheckGuard -> [OtherStatePreservingCommand]
206		\| VernacProof (None, None) -> [OtherStatePreservingCommand]
207		\| VernacProof _ -> []
208
209		\| VernacProofMode _ -> []
210		\| VernacBullet _ -> [SolveCommand]
211		\| VernacSubproof _ -> [SolveCommand]
212		\| VernacEndSubproof -> [SolveCommand]
213
214		(* Toplevel control *)
215		\| VernacToplevelControl _ -> []
216
217		(* Extensions *)
218		\| VernacExtend ("Subtac_Obligations", _) -> [GoalStartingCommand]
219		\| VernacExtend _ -> []
220
221		let is_vernac_navigation_command com =
222		List.mem NavigationCommand (attribute_of_vernac_command com)
223
224		let is_vernac_query_command com =
225		List.mem QueryCommand (attribute_of_vernac_command com)
226
227		let is_vernac_known_option_command com =
228		List.mem KnownOptionCommand (attribute_of_vernac_command com)
229
230		let is_vernac_debug_command com =
231		List.mem DebugCommand (attribute_of_vernac_command com)
232
233		let is_vernac_goal_printing_command com =
234		let attribute = attribute_of_vernac_command com in
235		List.mem GoalStartingCommand attribute or
236		List.mem SolveCommand attribute
237
238		let is_vernac_state_preserving_command com =
239		let attribute = attribute_of_vernac_command com in
240		List.mem OtherStatePreservingCommand attribute or
241		List.mem QueryCommand attribute
242
243		let is_vernac_tactic_command com =
244		List.mem SolveCommand (attribute_of_vernac_command com)
245
246		let is_vernac_proof_ending_command com =
247		List.mem ProofEndingCommand (attribute_of_vernac_command com)
248
249
250		(** Command history stack
251
252		We maintain a stack of the past states of the system. Each
253		successfully interpreted command adds a [reset_info] element
254		to this stack, storing what were the (label / open proofs /
255		current proof depth) just _before_ the interpretation of this
256		command. A label is just an integer (cf. BackTo and Bactrack
257		vernac commands).
258		*)
259
260		type reset_info = { label : int; proofs : identifier list; depth : int }
261
262		let com_stk = Stack.create ()
263
264		let compute_reset_info () =
265		{ label = Lib.current_command_label ();
266		proofs = Pfedit.get_all_proof_names ();
267		depth = max 0 (Pfedit.current_proof_depth ()) }
268
269
270		(** Interpretation (cf. [Ide_intf.interp]) *)
	71	let is_known_option cmd = match cmd with
	72	\| VernacSetOption (_,o,BoolValue true)
	73	\| VernacUnsetOption (_,o) -> coqide_known_option o
	74	\| _ -> false
	75
	76	let is_debug cmd = match cmd with
	77	\| VernacSetOption (_,["Ltac";"Debug"], _) -> true
	78	\| _ -> false
	79
	80	let is_query cmd = match cmd with
	81	\| VernacChdir None
	82	\| VernacMemOption _
	83	\| VernacPrintOption _
	84	\| VernacCheckMayEval _
	85	\| VernacGlobalCheck _
	86	\| VernacPrint _
	87	\| VernacSearch _
	88	\| VernacLocate _ -> true
	89	\| _ -> false
	90
	91	let is_undo cmd = match cmd with
	92	\| VernacUndo _ \| VernacUndoTo _ -> true
	93	\| _ -> false
271	94
272	95	(** Check whether a command is forbidden by CoqIDE *)
273	96

275	98	let user_error s =
276	99	raise (Loc.Exc_located (loc, Util.UserError ("CoqIde", str s)))
277	100	in
278		if is_vernac_debug_command ast then
	101	if is_debug ast then
279	102	user_error "Debug mode not available within CoqIDE";
280		if is_vernac_navigation_command ast then
	103	if is_known_option ast then
	104	user_error "Use CoqIDE display menu instead";
	105	if is_navigation_vernac ast then
281	106	user_error "Use CoqIDE navigation instead";
282		if is_vernac_known_option_command ast then
283		user_error "Use CoqIDE display menu instead";
284		if is_vernac_query_command ast then
	107	if is_undo ast then
	108	msgerrnl (str "Warning: rather use CoqIDE navigation instead");
	109	if is_query ast then
285	110	msgerrnl (str "Warning: query commands should not be inserted in scripts")
286	111
287		let raw_eval_expr = Vernac.eval_expr
288
289		let eval_expr loc_ast =
290		let rewind_info = compute_reset_info () in
291		raw_eval_expr loc_ast;
292		Stack.push rewind_info com_stk
	112	(** Interpretation (cf. [Ide_intf.interp]) *)
293	113
294	114	let interp (raw,verbosely,s) =
295		if not raw then (prerr_endline "Starting interp..."; prerr_endline s);
296	115	let pa = Pcoq.Gram.parsable (Stream.of_string s) in
297	116	let loc_ast = Vernac.parse_sentence (pa,None) in
298	117	if not raw then coqide_cmd_checks loc_ast;
299		(* We run tactics silently, since we will query the goal state later.
300		Otherwise, we honor the IDE verbosity flag. *)
301		Flags.make_silent
302		(is_vernac_goal_printing_command (snd loc_ast) \|\| not verbosely);
303		if raw then raw_eval_expr loc_ast else eval_expr loc_ast;
	118	Flags.make_silent (not verbosely);
	119	Vernac.eval_expr ~preserving:raw loc_ast;
304	120	Flags.make_silent true;
305		if not raw then prerr_endline ("...Done with interp of : "^s);
306	121	read_stdout ()
307
308
309		(** Backtracking (cf. [Ide_intf.rewind]).
310		We now rely on the [Backtrack] command just as ProofGeneral. *)
311
312		let rewind count =
313		if count = 0 then 0
314		else
315		let current_proofs = Pfedit.get_all_proof_names ()
316		in
317		(* 1) First, let's pop the history stack exactly [count] times.
318		NB: Normally, the IDE will not rewind by more than the numbers
319		of already interpreted commands, hence no risk of [Stack.Empty].
320		*)
321		let initial_target =
322		for i = 1 to count - 1 do ignore (Stack.pop com_stk) done;
323		Stack.pop com_stk
324		in
325		(* 2) Backtrack by enough additional steps to avoid re-opening proofs.
326		Typically, when a Qed has been crossed, we backtrack to the proof start.
327		NB: We cannot reach the empty stack, since the oldest [reset_info]
328		in the history cannot have opened proofs.
329		*)
330		let already_opened p = List.mem p current_proofs in
331		let rec extra_back n target =
332		if List.for_all already_opened target.proofs then n,target
333		else extra_back (n+1) (Stack.pop com_stk)
334		in
335		let extra_count, target = extra_back 0 initial_target
336		in
337		(* 3) Now that [target.proofs] is a subset of the opened proofs before
338		the rewind, we simply abort the extra proofs (if any).
339		NB: It is critical here that proofs are nested in a regular way
340		(i.e. no Resume or Suspend, as enforced above). This way, we can simply
341		count the extra proofs to abort instead of taking care of their names.
342		*)
343		let naborts = List.length current_proofs - List.length target.proofs
344		in
345		(* 4) We are now ready to call [Backtrack] *)
346		prerr_endline ("Rewind to state "^string_of_int target.label^
347		", proof depth "^string_of_int target.depth^
348		", num of aborts "^string_of_int naborts);
349		Vernacentries.vernac_backtrack target.label target.depth naborts;
350		Lib.mark_end_of_command (); (* We've short-circuited Vernac.eval_expr *)
351		extra_count
352
353	122
354	123	(** Goal display *)
355	124

403	172
404	173	let process_goal sigma g =
405	174	let env = Goal.V82.env sigma g in
	175	let id = Goal.uid g in
406	176	let ccl =
407	177	let norm_constr = Reductionops.nf_evar sigma (Goal.V82.concl sigma g) in
408		string_of_ppcmds (pr_ltype_env_at_top env norm_constr) in
	178	string_of_ppcmds (pr_goal_concl_style_env env norm_constr) in
409	179	let process_hyp h_env d acc =
410	180	let d = Term.map_named_declaration (Reductionops.nf_evar sigma) d in
411	181	(string_of_ppcmds (pr_var_decl h_env d)) :: acc in
412	182	(* (string_of_ppcmds (pr_var_decl h_env d), hyp_next_tac sigma h_env d)::acc in *)
413	183	let hyps =
414	184	List.rev (Environ.fold_named_context process_hyp env ~init: []) in
415		{ Interface.goal_hyp = hyps; Interface.goal_ccl = ccl }
	185	{ Interface.goal_hyp = hyps; Interface.goal_ccl = ccl; Interface.goal_id = id; }
416	186	(* hyps,(ccl,concl_next_tac sigma g)) *)
417	187
418	188	let goals () =

471	241	in
472	242	{ Interface.status_path = path; Interface.status_proofname = proof }
473	243
	244	(** This should be elsewhere... *)
	245	let search flags =
	246	let env = Global.env () in
	247	let rec extract_flags name tpe subtpe mods blacklist = function
	248	\| [] -> (name, tpe, subtpe, mods, blacklist)
	249	\| (Interface.Name_Pattern s, b) :: l ->
	250	let regexp =
	251	try Str.regexp s
	252	with _ -> Util.error ("Invalid regexp: " ^ s)
	253	in
	254	extract_flags ((regexp, b) :: name) tpe subtpe mods blacklist l
	255	\| (Interface.Type_Pattern s, b) :: l ->
	256	let constr = Pcoq.parse_string Pcoq.Constr.lconstr_pattern s in
	257	let (_, pat) = Constrintern.intern_constr_pattern Evd.empty env constr in
	258	extract_flags name ((pat, b) :: tpe) subtpe mods blacklist l
	259	\| (Interface.SubType_Pattern s, b) :: l ->
	260	let constr = Pcoq.parse_string Pcoq.Constr.lconstr_pattern s in
	261	let (_, pat) = Constrintern.intern_constr_pattern Evd.empty env constr in
	262	extract_flags name tpe ((pat, b) :: subtpe) mods blacklist l
	263	\| (Interface.In_Module m, b) :: l ->
	264	let path = String.concat "." m in
	265	let m = Pcoq.parse_string Pcoq.Constr.global path in
	266	let (_, qid) = Libnames.qualid_of_reference m in
	267	let id =
	268	try Nametab.full_name_module qid
	269	with Not_found ->
	270	Util.error ("Module " ^ path ^ " not found.")
	271	in
	272	extract_flags name tpe subtpe ((id, b) :: mods) blacklist l
	273	\| (Interface.Include_Blacklist, b) :: l ->
	274	extract_flags name tpe subtpe mods b l
	275	in
	276	let (name, tpe, subtpe, mods, blacklist) =
	277	extract_flags [] [] [] [] false flags
	278	in
	279	let filter_function ref env constr =
	280	let id = Names.string_of_id (Nametab.basename_of_global ref) in
	281	let path = Libnames.dirpath (Nametab.path_of_global ref) in
	282	let toggle x b = if x then b else not b in
	283	let match_name (regexp, flag) =
	284	toggle (Str.string_match regexp id 0) flag
	285	in
	286	let match_type (pat, flag) =
	287	toggle (Matching.is_matching pat constr) flag
	288	in
	289	let match_subtype (pat, flag) =
	290	toggle (Matching.is_matching_appsubterm ~closed:false pat constr) flag
	291	in
	292	let match_module (mdl, flag) =
	293	toggle (Libnames.is_dirpath_prefix_of mdl path) flag
	294	in
	295	let in_blacklist =
	296	blacklist \|\| (Search.filter_blacklist ref env constr)
	297	in
	298	List.for_all match_name name &&
	299	List.for_all match_type tpe &&
	300	List.for_all match_subtype subtpe &&
	301	List.for_all match_module mods && in_blacklist
	302	in
	303	let ans = ref [] in
	304	let print_function ref env constr =
	305	let name = Names.string_of_id (Nametab.basename_of_global ref) in
	306	let make_path = Names.string_of_id in
	307	let path =
	308	List.rev_map make_path (Names.repr_dirpath (Nametab.dirpath_of_global ref))
	309	in
	310	let answer = {
	311	Interface.search_answer_full_path = path;
	312	Interface.search_answer_base_name = name;
	313	Interface.search_answer_type = string_of_ppcmds (pr_lconstr_env env constr);
	314	} in
	315	ans := answer :: !ans;
	316	in
	317	let () = Search.gen_filtered_search filter_function print_function in
	318	!ans
	319
474	320	let get_options () =
475	321	let table = Goptions.get_tables () in
476	322	let fold key state accu = (key, state) :: accu in

484	330	in
485	331	List.iter iter options
486	332
	333	let about () = {
	334	Interface.coqtop_version = Coq_config.version;
	335	Interface.protocol_version = Ide_intf.protocol_version;
	336	Interface.release_date = Coq_config.date;
	337	Interface.compile_date = Coq_config.compile_date;
	338	}
	339
487	340	(** Grouping all call handlers together + error handling *)
	341
	342	exception Quit
488	343
489	344	let eval_call c =
490	345	let rec handle_exn e =
491	346	catch_break := false;
492		let pr_exn e = string_of_ppcmds (Errors.print e) in
	347	let pr_exn e = (read_stdout ())^("\n"^(string_of_ppcmds (Errors.print e))) in
493	348	match e with
	349	\| Quit ->
	350	(* Here we do send an acknowledgement message to prove everything went
	351	OK. *)
	352	let dummy = Interface.Good () in
	353	let xml_answer = Ide_intf.of_answer Ide_intf.quit dummy in
	354	let () = Xml_utils.print_xml !orig_stdout xml_answer in
	355	let () = flush !orig_stdout in
	356	let () = pr_debug "Exiting gracefully." in
	357	exit 0
494	358	\| Vernacexpr.Drop -> None, "Drop is not allowed by coqide!"
495	359	\| Vernacexpr.Quit -> None, "Quit is not allowed by coqide!"
496	360	\| Vernac.DuringCommandInterp (_,inner) -> handle_exn inner

507	371	r
508	372	in
509	373	let handler = {
510		Interface.interp = interruptible interp;
511		Interface.rewind = interruptible rewind;
512		Interface.goals = interruptible goals;
513		Interface.evars = interruptible evars;
514		Interface.hints = interruptible hints;
515		Interface.status = interruptible status;
516		Interface.inloadpath = interruptible inloadpath;
517		Interface.get_options = interruptible get_options;
518		Interface.set_options = interruptible set_options;
519		Interface.mkcases = interruptible Vernacentries.make_cases;
520		Interface.handle_exn = handle_exn; }
	374	Ide_intf.interp = interruptible interp;
	375	Ide_intf.rewind = interruptible Backtrack.back;
	376	Ide_intf.goals = interruptible goals;
	377	Ide_intf.evars = interruptible evars;
	378	Ide_intf.hints = interruptible hints;
	379	Ide_intf.status = interruptible status;
	380	Ide_intf.search = interruptible search;
	381	Ide_intf.inloadpath = interruptible inloadpath;
	382	Ide_intf.get_options = interruptible get_options;
	383	Ide_intf.set_options = interruptible set_options;
	384	Ide_intf.mkcases = interruptible Vernacentries.make_cases;
	385	Ide_intf.quit = (fun () -> raise Quit);
	386	Ide_intf.about = interruptible about;
	387	Ide_intf.handle_exn = handle_exn; }
521	388	in
522	389	(* If the messages of last command are still there, we remove them *)
523	390	ignore (read_stdout ());

533	400	between coqtop and ide. With marshalling, reading an answer to
534	401	a different request could hang the ide... *)
535	402
536		let pr_debug s =
537		if !Flags.debug then Printf.eprintf "[pid %d] %s\n%!" (Unix.getpid ()) s
538
539	403	let fail err =
540	404	Ide_intf.of_value (fun _ -> assert false) (Interface.Fail (None, err))
541	405

544	408	let () = Xml_parser.check_eof p false in
545	409	init_signal_handler ();
546	410	catch_break := false;
547		(* ensure we have a command separator object (DOT) so that the first
548		command can be reseted. *)
549		Lib.mark_end_of_command();
	411	(* We'll handle goal fetching and display in our own way *)
	412	Vernacentries.enable_goal_printing := false;
	413	Vernacentries.qed_display_script := false;
550	414	try
551	415	while true do
552	416	let xml_answer =

+31

-16

toplevel/interface.mli less more

14	14
15	15	(** The type of coqtop goals *)
16	16	type goal = {
	17	goal_id : string;
	18	(** Unique goal identifier *)
17	19	goal_hyp : string list;
18	20	(** List of hypotheses *)
19	21	goal_ccl : string;

61	63	(** The current value of the option *)
62	64	}
63	65
	66	type search_constraint =
	67	(** Whether the name satisfies a regexp (uses Ocaml Str syntax) *)
	68	\| Name_Pattern of string
	69	(** Whether the object type satisfies a pattern *)
	70	\| Type_Pattern of string
	71	(** Whether some subtype of object type satisfies a pattern *)
	72	\| SubType_Pattern of string
	73	(** Whether the object pertains to a module *)
	74	\| In_Module of string list
	75	(** Bypass the Search blacklist *)
	76	\| Include_Blacklist
	77
	78	(** A list of search constraints; the boolean flag is set to [false] whenever
	79	the flag should be negated. *)
	80	type search_flags = (search_constraint * bool) list
	81
	82	type search_answer = {
	83	search_answer_full_path : string list;
	84	search_answer_base_name : string;
	85	search_answer_type : string;
	86	}
	87
	88	type coq_info = {
	89	coqtop_version : string;
	90	protocol_version : string;
	91	release_date : string;
	92	compile_date : string;
	93	}
	94
64	95	(** * Coq answers to CoqIde *)
65	96
66	97	type location = (int * int) option (* start and end of the error *)

68	99	type 'a value =
69	100	\| Good of 'a
70	101	\| Fail of (location * string)
71
72		(** * The structure that coqtop should implement *)
73
74		type handler = {
75		interp : raw * verbose * string -> string;
76		rewind : int -> int;
77		goals : unit -> goals option;
78		evars : unit -> evar list option;
79		hints : unit -> (hint list * hint) option;
80		status : unit -> status;
81		get_options : unit -> (option_name * option_state) list;
82		set_options : (option_name * option_value) list -> unit;
83		inloadpath : string -> bool;
84		mkcases : string -> string list list;
85		handle_exn : exn -> location * string;
86		}

+12

-0

toplevel/metasyntax.ml less more

985	985	classify_function = classify_notation}
986	986
987	987	(**********************************************************************)
	988
	989	let with_lib_stk_protection f x =
	990	let fs = Lib.freeze () in
	991	try let a = f x in Lib.unfreeze fs; a
	992	with e -> Lib.unfreeze fs; raise e
	993
	994	let with_syntax_protection f x =
	995	with_lib_stk_protection
	996	(with_grammar_rule_protection
	997	(with_notation_protection f)) x
	998
	999	(**********************************************************************)
988	1000	(* Recovering existing syntax *)
989	1001
990	1002	let contract_notation ntn =

+2

-0

toplevel/metasyntax.mli less more

60	60	val print_grammar : string -> unit
61	61
62	62	val check_infix_modifiers : syntax_modifier list -> unit
	63
	64	val with_syntax_protection : ('a -> 'b) -> 'a -> 'b

+20

-3

toplevel/mltop.ml4 less more

234	234	let module_is_known mname =
235	235	Stringset.mem (String.capitalize mname) !known_loaded_modules
236	236
	237	let known_loaded_plugins = ref Stringmap.empty
	238
	239	let init_ml_object mname =
	240	try Stringmap.find mname !known_loaded_plugins ()
	241	with Not_found -> ()
	242
237	243	let load_ml_object mname fname=
238	244	dir_ml_load fname;
239		add_known_module mname
	245	add_known_module mname;
	246	init_ml_object mname
	247
	248	let add_known_plugin init name =
	249	let name = String.capitalize name in
	250	add_known_module name;
	251	known_loaded_plugins := Stringmap.add name init !known_loaded_plugins
	252
	253	let init_known_plugins () =
	254	Stringmap.iter (fun _ f -> f()) !known_loaded_plugins
240	255
241	256	(* Summary of declared ML Modules *)
242	257

259	274	load_ml_object mname fname
260	275	else
261	276	errorlabstrm "Mltop.unfreeze_ml_modules"
262		(str"Loading of ML object file forbidden in a native Coq.");
	277	(str"Loading of ML object file forbidden in a native Coq.")
	278	else init_ml_object mname;
263	279	add_loaded_module mname)
264	280	x
265	281

289	305	raise e
290	306	else
291	307	(if_verbose msgnl (str" failed]");
292		error ("Dynamic link not supported (module "^name^")")))
	308	error ("Dynamic link not supported (module "^name^")"))
	309	else init_ml_object mname)
293	310	mnames
294	311
295	312	let classify_ml_module_object ({mlocal=mlocal} as o) =

+10

-0

toplevel/mltop.mli less more

50	50	val module_is_known : string -> bool
51	51	val load_ml_object : string -> string -> unit
52	52
	53	(* Declare a plugin and its initialization function.
	54	* A plugin is just an ML module with an initialization function.
	55	* Adding a known plugin implies adding it as a known ML module.
	56	* The initialization function is granted to be called after Coq is fully
	57	* bootstrapped, even if the plugin is statically linked with the toplevel *)
	58	val add_known_plugin : (unit -> unit) -> string -> unit
	59
	60	(* Calls all initialization functions in a non-specified order *)
	61	val init_known_plugins : unit -> unit
	62
53	63	(** Summary of Declared ML Modules *)
54	64	val get_loaded_modules : unit -> string list
55	65	val add_loaded_module : string -> unit

+3

-3

toplevel/record.ml less more

80	80	let newps = Evarutil.nf_rel_context_evar sigma newps in
81	81	let newfs = Evarutil.nf_rel_context_evar sigma newfs in
82	82	let ce t = Evarutil.check_evars env0 Evd.empty evars t in
83		List.iter (fun (n, b, t) -> Option.iter ce b; ce t) newps;
84		List.iter (fun (n, b, t) -> Option.iter ce b; ce t) newfs;
	83	List.iter (fun (n, b, t) -> Option.iter ce b; ce t) (List.rev newps);
	84	List.iter (fun (n, b, t) -> Option.iter ce b; ce t) (List.rev newfs);
85	85	imps, newps, impls, newfs
86	86
87	87	let degenerate_decl (na,b,t) =

262	262	begin match finite with
263	263	\| BiFinite ->
264	264	if Termops.dependent (mkRel (nparams+1)) (it_mkProd_or_LetIn mkProp fields) then
265		error "Records declared with the keyword Record or Structure cannot be recursive. Maybe you meant to define an Inductive or CoInductive record."
	265	error "Records declared with the keyword Record or Structure cannot be recursive. You can, however, define recursive records using the Inductive or CoInductive command."
266	266	\| _ -> ()
267	267	end;
268	268	let mie =

+2

-0

toplevel/search.mli less more

32	32	val filter_by_module_from_list :
33	33	dir_path list * bool -> global_reference -> env -> 'a -> bool
34	34
	35	val filter_blacklist : global_reference -> env -> constr -> bool
	36
35	37	(** raw search functions can be used for various extensions.
36	38	They are also used for pcoq. *)
37	39	val gen_filtered_search : (global_reference -> env -> constr -> bool) ->

+0

-3

toplevel/toplevel.ml less more

366	366
367	367	let rec loop () =
368	368	Sys.catch_break true;
369		(* ensure we have a command separator object (DOT) so that the first
370		command can be reseted. *)
371		Lib.mark_end_of_command();
372	369	try
373	370	reset_input_buffer stdin top_buffer;
374	371	while true do do_vernac() done

+1

-0

toplevel/toplevel.mllib less more

12	12	Classes
13	13	Record
14	14	Ppvernac
	15	Backtrack
15	16	Vernacinterp
16	17	Mltop
17	18	Vernacentries

+45

-22

toplevel/vernac.ml less more

50	50	\| Error_in_file (_, _, e) -> e
51	51	\| e -> e
52	52
	53	let user_error loc s = Util.user_err_loc (loc,"_",str s)
	54
53	55	(** Timeout handling *)
54	56
55	57	(** A global default timeout, controled by option "Set Default Timeout n".

96	98	(* restore handler *)
97	99	Sys.set_signal Sys.sigalrm psh
98	100
	101
	102	(* Open an utf-8 encoded file and skip the byte-order mark if any *)
	103
	104	let open_utf8_file_in fname =
	105	let is_bom s =
	106	Char.code s.[0] = 0xEF && Char.code s.[1] = 0xBB && Char.code s.[2] = 0xBF
	107	in
	108	let in_chan = open_in fname in
	109	let s = " " in
	110	if input in_chan s 0 3 < 3 \|\| not (is_bom s) then seek_in in_chan 0;
	111	in_chan
	112
99	113	(* Opening and closing a channel. Open it twice when verbose: the first
100	114	channel is used to read the commands, and the second one to print them.
101	115	Note: we could use only one thanks to seek_in, but seeking on and on in

105	119	let paths = Library.get_load_paths () in
106	120	let _,longfname =
107	121	find_file_in_path ~warn:(Flags.is_verbose()) paths fname in
108		let in_chan = open_in longfname in
109		let verb_ch = if verbosely then Some (open_in longfname) else None in
	122	let in_chan = open_utf8_file_in longfname in
	123	let verb_ch =
	124	if verbosely then Some (open_utf8_file_in longfname) else None in
110	125	let po = Pcoq.Gram.parsable (Stream.of_channel in_chan) in
111	126	(in_chan, longfname, (po, verb_ch))
112	127

165	180	States.unfreeze fs;
166	181	Format.set_formatter_out_channel stdout
167	182
168		let rec vernac_com interpfun (loc,com) =
	183	let rec vernac_com interpfun checknav (loc,com) =
169	184	let rec interp = function
170	185	\| VernacLoad (verbosely, fname) ->
171	186	let fname = expand_path_macros fname in

203	218
204	219	\| VernacList l -> List.iter (fun (_,v) -> interp v) l
205	220
	221	\| v when !just_parsing -> ()
	222
206	223	\| VernacFail v ->
207		if not !just_parsing then begin try
208		interp v; raise HasNotFailed
	224	begin try
	225	(* If the command actually works, ignore its effects on the state *)
	226	States.with_state_protection
	227	(fun v -> interp v; raise HasNotFailed) v
209	228	with e -> match real_error e with
210	229	\| HasNotFailed ->
211	230	errorlabstrm "Fail" (str "The command has not failed !")

218	237	end
219	238
220	239	\| VernacTime v ->
221		if not !just_parsing then begin
222	240	let tstart = System.get_time() in
223	241	interp v;
224	242	let tend = System.get_time() in
225	243	msgnl (str"Finished transaction in " ++
226	244	System.fmt_time_difference tstart tend)
227		end
228	245
229	246	\| VernacTimeout(n,v) ->
230		if not !just_parsing then begin
231	247	current_timeout := Some n;
232	248	interp v
233		end
234	249
235	250	\| v ->
236		if not !just_parsing then
237	251	let psh = default_set_timeout () in
238	252	try
239	253	States.with_heavy_rollback interpfun

242	256	with e -> restore_timeout psh; raise e
243	257	in
244	258	try
	259	checknav loc com;
245	260	current_timeout := !default_timeout;
246	261	if do_beautify () then pr_new_syntax loc (Some com);
247	262	interp com

255	270	if verbosely then Vernacentries.interp
256	271	else Flags.silently Vernacentries.interp
257	272	in
	273	let checknav loc cmd =
	274	if is_navigation_vernac cmd then
	275	user_error loc "Navigation commands forbidden in files"
	276	in
258	277	let (in_chan, fname, input) =
259	278	open_file_twice_if verbosely s in
260	279	try
261	280	(* we go out of the following infinite loop when a End_of_input is
262	281	* raised, which means that we raised the end of the file being loaded *)
263	282	while true do
264		vernac_com interpfun (parse_sentence input);
	283	vernac_com interpfun checknav (parse_sentence input);
265	284	pp_flush ()
266	285	done
267	286	with e -> (* whatever the exception *)

272	291	if do_beautify () then pr_new_syntax (make_loc (max_int,max_int)) None
273	292	\| _ -> raise_with_file fname e
274	293
275
276		(* eval_expr : Util.loc * Vernacexpr.vernac_expr -> unit
277		* execute one vernacular command. Marks the end of the command in the lib_stk
278		* with a new label to make vernac undoing easier. Also freeze state to speed up
279		* backtracking. *)
280		let eval_expr last =
281		vernac_com Vernacentries.interp last;
282		Lib.add_frozen_state();
283		Lib.mark_end_of_command()
	294	(** [eval_expr : ?preserving:bool -> Pp.loc * Vernacexpr.vernac_expr -> unit]
	295	It executes one vernacular command. By default the command is
	296	considered as non-state-preserving, in which case we add it to the
	297	Backtrack stack (triggering a save of a frozen state and the generation
	298	of a new state label). An example of state-preserving command is one coming
	299	from the query panel of Coqide. *)
	300
	301	let checknav loc ast =
	302	if is_deep_navigation_vernac ast then
	303	user_error loc "Navigation commands forbidden in nested commands"
	304
	305	let eval_expr ?(preserving=false) loc_ast =
	306	vernac_com Vernacentries.interp checknav loc_ast;
	307	if not preserving && not (is_navigation_vernac (snd loc_ast)) then
	308	Backtrack.mark_command (snd loc_ast)
284	309
285	310	(* raw_do_vernac : Pcoq.Gram.parsable -> unit
286	311	* vernac_step . parse_sentence *)

316	341	if !Flags.xml_export then !xml_end_library ();
317	342	Dumpglob.end_dump_glob ();
318	343	Library.save_library_to ldir (long_f_dot_v ^ "o")
319
320

+8

-1

toplevel/vernac.mli less more

20	20	exception End_of_input
21	21
22	22	val just_parsing : bool ref
23		val eval_expr : Util.loc * Vernacexpr.vernac_expr -> unit
	23
	24	(** [eval_expr] executes one vernacular command. By default the command is
	25	considered as non-state-preserving, in which case we add it to the
	26	Backtrack stack (triggering a save of a frozen state and the generation
	27	of a new state label). An example of state-preserving command is one coming
	28	from the query panel of Coqide. *)
	29
	30	val eval_expr : ?preserving:bool -> Util.loc * Vernacexpr.vernac_expr -> unit
24	31	val raw_do_vernac : Pcoq.Gram.parsable -> unit
25	32
26	33	(** Set XML hooks *)

+132

-70

toplevel/vernacentries.ml less more

72	72	()
73	73
74	74	let show_script () =
75		(* spiwack: show_script is currently not working *)
76		()
	75	let prf = Pfedit.get_current_proof_name () in
	76	let cmds = Backtrack.get_script prf in
	77	msgnl (Util.prlist_with_sep Pp.fnl Ppvernac.pr_vernac cmds)
77	78
78	79	let show_thesis () =
79	80	msgnl (anomaly "TODO" )

90	91	(* Spiwack: proof tree is currently not working *)
91	92	()
92	93
93		let print_subgoals () = if_verbose (fun () -> msg (pr_open_subgoals ())) ()
	94	let enable_goal_printing = ref true
	95
	96	let print_subgoals () =
	97	if !enable_goal_printing && is_verbose ()
	98	then msg (pr_open_subgoals ())
	99
	100	let try_print_subgoals () =
	101	Pp.flush_all();
	102	try print_subgoals () with Proof_global.NoCurrentProof \| UserError _ -> ()
	103
94	104
95	105	(* Simulate the Intro(s) tactic *)
96	106

340	350	\| None -> None
341	351	\| Some r ->
342	352	let (evc,env)= get_current_context () in
343		Some (interp_redexp env evc r) in
	353	Some (snd (interp_redexp env evc r)) in
344	354	let ce,imps = interp_definition bl red_option c typ_opt in
345	355	declare_definition id (local,k) ce imps hook)
346	356

356	366	(str "Let declarations can only be used in proof editing mode.");
357	367	start_proof_and_print (Global, Proof kind) l hook
358	368
	369	let qed_display_script = ref true
	370
359	371	let vernac_end_proof = function
360		\| Admitted -> admit ()
	372	\| Admitted ->
	373	Backtrack.mark_unreachable [Pfedit.get_current_proof_name ()];
	374	admit ()
361	375	\| Proved (is_opaque,idopt) ->
362		if not !Flags.print_emacs then if_verbose show_script ();
363		match idopt with
	376	let prf = Pfedit.get_current_proof_name () in
	377	if is_verbose () && !qed_display_script then (show_script (); msg (fnl()));
	378	begin match idopt with
364	379	\| None -> save_named is_opaque
365	380	\| Some ((_,id),None) -> save_anonymous is_opaque id
366	381	\| Some ((_,id),Some kind) -> save_anonymous_with_strength kind is_opaque id
	382	end;
	383	Backtrack.mark_unreachable [prf]
367	384
368	385	(* A stupid macro that should be replaced by ``Exact c. Save.'' all along
369	386	the theories [??] *)

722	739	(********************)
723	740	(* State management *)
724	741
725		let abort_refine f x =
726		if Pfedit.refining() then delete_all_proofs ();
727		f x
728		(* used to be: error "Must save or abort current goal first" *)
729
730		let vernac_write_state file = abort_refine States.extern_state file
731
732		let vernac_restore_state file = abort_refine States.intern_state file
733
734
735		(*************)
736		(* Resetting *)
737
738		let vernac_reset_name id = abort_refine Lib.reset_name id
739
740		let vernac_reset_initial () = abort_refine Lib.reset_initial ()
741
742		let vernac_back n = Lib.back n
743
744		let vernac_backto n = Lib.reset_label n
745
746		(* see also [vernac_backtrack] which combines undoing and resetting *)
	742	let vernac_write_state file =
	743	Pfedit.delete_all_proofs ();
	744	States.extern_state file
	745
	746	let vernac_restore_state file =
	747	Pfedit.delete_all_proofs ();
	748	States.intern_state file
	749
747	750	(************)
748	751	(* Commands *)
749	752

771	774	(List.map (List.map (fun (ex,b,f) -> ex, (b,true,f))) imps)
772	775
773	776	let vernac_declare_arguments local r l nargs flags =
	777	let extra_scope_flag = List.mem `ExtraScopes flags in
774	778	let names = List.map (List.map (fun (id, _,_,_,_) -> id)) l in
775	779	let names, rest = List.hd names, List.tl names in
	780	let scopes = List.map (List.map (fun (_,_, s, _,_) -> s)) l in
776	781	if List.exists ((<>) names) rest then
777	782	error "All arguments lists must declare the same names.";
778	783	if not (Util.list_distinct (List.filter ((<>) Anonymous) names)) then

781	786	let inf_names =
782	787	Impargs.compute_implicits_names (Global.env()) (Global.type_of_global sr) in
783	788	let string_of_name = function Anonymous -> "_" \| Name id -> string_of_id id in
784		let rec check li ld = match li, ld with
785		\| [], [] -> ()
786		\| [], x::_ -> error ("Extra argument " ^ string_of_name x ^ ".")
787		\| l, [] -> error ("The following arguments are not declared: " ^
	789	let rec check li ld ls = match li, ld, ls with
	790	\| [], [], [] -> ()
	791	\| [], Anonymous::ld, (Some _)::ls when extra_scope_flag -> check li ld ls
	792	\| [], _::_, (Some _)::ls when extra_scope_flag ->
	793	error "Extra notation scopes can be set on anonymous arguments only"
	794	\| [], x::_, _ -> error ("Extra argument " ^ string_of_name x ^ ".")
	795	\| l, [], _ -> error ("The following arguments are not declared: " ^
788	796	(String.concat ", " (List.map string_of_name l)) ^ ".")
789		\| _::li, _::ld -> check li ld in
	797	\| _::li, _::ld, _::ls -> check li ld ls
	798	\| _ -> assert false in
790	799	if l <> [[]] then
791		List.iter (fun l -> check inf_names l) (names :: rest);
	800	List.iter2 (fun l -> check inf_names l) (names :: rest) scopes;
	801	(* we take extra scopes apart, and we check they are consistent *)
	802	let l, scopes =
	803	let scopes, rest = List.hd scopes, List.tl scopes in
	804	if List.exists (List.exists ((<>) None)) rest then
	805	error "Notation scopes can be given only once";
	806	if not extra_scope_flag then l, scopes else
	807	let l, _ = List.split (List.map (list_chop (List.length inf_names)) l) in
	808	l, scopes in
792	809	(* we interpret _ as the inferred names *)
793	810	let l = if l = [[]] then l else
794	811	let name_anons = function

821	838	let l = List.hd l in
822	839	let some_implicits_specified = implicits <> [[]] in
823	840	let scopes = List.map (function
824		\| (_,_, None,_,_) -> None
825		\| (_,_, Some (o, k), _,_) ->
	841	\| None -> None
	842	\| Some (o, k) ->
826	843	try Some(ignore(Notation.find_scope k); k)
827		with _ -> Some (Notation.find_delimiters_scope o k)) l in
	844	with _ -> Some (Notation.find_delimiters_scope o k)) scopes in
828	845	let some_scopes_specified = List.exists ((<>) None) scopes in
829	846	let rargs =
830	847	Util.list_map_filter (function (n, true) -> Some n \| _ -> None)

951	968	optkey = ["Printing";"Existential";"Instances"];
952	969	optread = (fun () -> !Constrextern.print_evar_arguments);
953	970	optwrite = (:=) Constrextern.print_evar_arguments }
	971
954	972	let _ =
955	973	declare_bool_option
956	974	{ optsync = true;

1093	1111	optkey = ["Ltac";"Debug"];
1094	1112	optread = (fun () -> get_debug () <> Tactic_debug.DebugOff);
1095	1113	optwrite = vernac_debug }
	1114
	1115	let _ =
	1116	declare_bool_option
	1117	{ optsync = true;
	1118	optdepr = false;
	1119	optname = "explicitly parsing implicit arguments";
	1120	optkey = ["Parsing";"Explicit"];
	1121	optread = (fun () -> !Constrintern.parsing_explicit);
	1122	optwrite = (fun b -> Constrintern.parsing_explicit := b) }
1096	1123
1097	1124	let vernac_set_opacity local str =
1098	1125	let glob_ref r =

1149	1176	let module P = Pretype_errors in
1150	1177	let (sigma, env) = get_current_context_of_args glopt in
1151	1178	let sigma', c = interp_open_constr sigma env rc in
	1179	let sigma' = Evarconv.consider_remaining_unif_problems env sigma' in
1152	1180	let j =
1153	1181	try
1154	1182	Evarutil.check_evars env sigma sigma' c;

1161	1189	if !pcoq <> None then (Option.get !pcoq).print_check env j
1162	1190	else msg (print_judgment env j)
1163	1191	\| Some r ->
1164		let redfun = fst (reduction_of_red_expr (interp_redexp env sigma' r)) in
	1192	let (sigma',r_interp) = interp_redexp env sigma' r in
	1193	let redfun = fst (reduction_of_red_expr r_interp) in
1165	1194	if !pcoq <> None
1166	1195	then (Option.get !pcoq).print_eval redfun env sigma' rc j
1167	1196	else msg (print_eval redfun env sigma' rc j)
1168	1197
1169	1198	let vernac_declare_reduction locality s r =
1170		declare_red_expr locality s (interp_redexp (Global.env()) Evd.empty r)
	1199	declare_red_expr locality s (snd (interp_redexp (Global.env()) Evd.empty r))
1171	1200
1172	1201	(* The same but avoiding the current goal context if any *)
1173	1202	let vernac_global_check c =

1285	1314	\| LocateTactic qid -> print_located_tactic qid
1286	1315	\| LocateFile f -> locate_file f
1287	1316
	1317	(****************)
	1318	(* Backtracking *)
	1319
	1320	(** NB: these commands are now forbidden in non-interactive use,
	1321	e.g. inside VernacLoad, VernacList, ... *)
	1322
	1323	let vernac_backto lbl =
	1324	try
	1325	let lbl' = Backtrack.backto lbl in
	1326	if lbl <> lbl' then
	1327	Pp.msg_warning
	1328	(str "Actually back to state "++ Pp.int lbl' ++ str ".");
	1329	try_print_subgoals ()
	1330	with Backtrack.Invalid -> error "Invalid backtrack."
	1331
	1332	let vernac_back n =
	1333	try
	1334	let extra = Backtrack.back n in
	1335	if extra <> 0 then
	1336	Pp.msg_warning
	1337	(str "Actually back by " ++ Pp.int (extra+n) ++ str " steps.");
	1338	try_print_subgoals ()
	1339	with Backtrack.Invalid -> error "Invalid backtrack."
	1340
	1341	let vernac_reset_name id =
	1342	try Backtrack.reset_name id; try_print_subgoals ()
	1343	with Backtrack.Invalid -> error "Invalid Reset."
	1344
	1345	let vernac_reset_initial () = Backtrack.reset_initial ()
	1346
	1347	(* For compatibility with ProofGeneral: *)
	1348
	1349	let vernac_backtrack snum pnum naborts =
	1350	Backtrack.backtrack snum pnum naborts;
	1351	try_print_subgoals ()
	1352
	1353
1288	1354	(********************)
1289	1355	(* Proof management *)
1290	1356
1291	1357	let vernac_abort = function
1292	1358	\| None ->
	1359	Backtrack.mark_unreachable [Pfedit.get_current_proof_name ()];
1293	1360	delete_current_proof ();
1294	1361	if_verbose message "Current goal aborted";
1295	1362	if !pcoq <> None then (Option.get !pcoq).abort ""
1296	1363	\| Some id ->
	1364	Backtrack.mark_unreachable [snd id];
1297	1365	delete_proof id;
1298	1366	let s = string_of_id (snd id) in
1299	1367	if_verbose message ("Goal "^s^" aborted");

1301	1369
1302	1370	let vernac_abort_all () =
1303	1371	if refining() then begin
	1372	Backtrack.mark_unreachable (Pfedit.get_all_proof_names ());
1304	1373	delete_all_proofs ();
1305	1374	message "Current goals aborted"
1306	1375	end else
1307	1376	error "No proof-editing in progress."
1308	1377
1309		let vernac_restart () = restart_proof(); print_subgoals ()
1310
1311		(* Proof switching *)
1312
1313		let vernac_suspend = suspend_proof
1314
1315		let vernac_resume = function
1316		\| None -> resume_last_proof ()
1317		\| Some id -> resume_proof id
	1378	let vernac_restart () =
	1379	Backtrack.mark_unreachable [Pfedit.get_current_proof_name ()];
	1380	restart_proof(); print_subgoals ()
1318	1381
1319	1382	let vernac_undo n =
1320		undo n;
	1383	let d = Pfedit.current_proof_depth () - n in
	1384	Backtrack.mark_unreachable ~after:d [Pfedit.get_current_proof_name ()];
	1385	Pfedit.undo n; print_subgoals ()
	1386
	1387	let vernac_undoto n =
	1388	Backtrack.mark_unreachable ~after:n [Pfedit.get_current_proof_name ()];
	1389	Pfedit.undo_todepth n;
1321	1390	print_subgoals ()
1322
1323		(* backtrack with [naborts] abort, then undo_todepth to [pnum], then
1324		back-to state number [snum]. This allows to backtrack proofs and
1325		state with one command (easier for proofgeneral). *)
1326		let vernac_backtrack snum pnum naborts =
1327		for i = 1 to naborts do vernac_abort None done;
1328		undo_todepth pnum;
1329		vernac_backto snum;
1330		Pp.flush_all();
1331		(* there may be no proof in progress, even if no abort *)
1332		(try print_subgoals () with Proof_global.NoCurrentProof \| UserError _ -> ())
1333
1334	1391
1335	1392	let vernac_focus gln =
1336	1393	let p = Proof_global.give_me_the_proof () in
1337		match gln with
1338		\| None -> Proof.focus focus_command_cond () 1 p; print_subgoals ()
1339		\| Some n -> Proof.focus focus_command_cond () n p; print_subgoals ()
1340
	1394	let n = match gln with None -> 1 \| Some n -> n in
	1395	Proof.focus focus_command_cond () n p; print_subgoals ()
1341	1396
1342	1397	(* Unfocuses one step in the focus stack. *)
1343	1398	let vernac_unfocus () =
1344	1399	let p = Proof_global.give_me_the_proof () in
1345	1400	Proof.unfocus command_focus p; print_subgoals ()
	1401
	1402	(* Checks that a proof is fully unfocused. Raises an error if not. *)
	1403	let vernac_unfocused () =
	1404	let p = Proof_global.give_me_the_proof () in
	1405	if Proof.unfocused p then
	1406	msg (str"The proof is indeed fully unfocused.")
	1407	else
	1408	error "The proof is not fully unfocused."
	1409
1346	1410
1347	1411	(* BeginSubproof / EndSubproof.
1348	1412	BeginSubproof (vernac_subproof) focuses on the first goal, or the goal

1482	1546	\| VernacRestoreState s -> vernac_restore_state s
1483	1547
1484	1548	(* Resetting *)
1485		\| VernacRemoveName id -> Lib.remove_name id
1486	1549	\| VernacResetName id -> vernac_reset_name id
1487	1550	\| VernacResetInitial -> vernac_reset_initial ()
1488	1551	\| VernacBack n -> vernac_back n

1519	1582	\| VernacAbort id -> vernac_abort id
1520	1583	\| VernacAbortAll -> vernac_abort_all ()
1521	1584	\| VernacRestart -> vernac_restart ()
1522		\| VernacSuspend -> vernac_suspend ()
1523		\| VernacResume id -> vernac_resume id
1524	1585	\| VernacUndo n -> vernac_undo n
1525		\| VernacUndoTo n -> undo_todepth n
	1586	\| VernacUndoTo n -> vernac_undoto n
1526	1587	\| VernacBacktrack (snum,pnum,naborts) -> vernac_backtrack snum pnum naborts
1527	1588	\| VernacFocus n -> vernac_focus n
1528	1589	\| VernacUnfocus -> vernac_unfocus ()
	1590	\| VernacUnfocused -> vernac_unfocused ()
1529	1591	\| VernacBullet b -> vernac_bullet b
1530	1592	\| VernacSubproof n -> vernac_subproof n
1531	1593	\| VernacEndSubproof -> vernac_end_subproof ()

+15

-16

toplevel/vernacentries.mli less more

22	22	in the context of the current goal, as for instance in pcoq *)
23	23	val get_current_context_of_args : int option -> Evd.evar_map * Environ.env
24	24
25		(*i
26
27		(** this function is used to analyse the extra arguments in search commands.
28		It is used in pcoq. ) (i anciennement: inside_outside i*)
29		val interp_search_restriction : search_restriction -> dir_path list * bool
30		i*)
31
32	25	type pcoq_hook = {
33	26	start_proof : unit -> unit;
34	27	solve : int -> unit;

43	36
44	37	val set_pcoq_hook : pcoq_hook -> unit
45	38
46		(** This function makes sure that the function given in argument is preceded
47		by a command aborting all proofs if necessary.
48		It is used in pcoq. *)
49		val abort_refine : ('a -> unit) -> 'a -> unit;;
	39	(** The main interpretation function of vernacular expressions *)
50	40
51	41	val interp : Vernacexpr.vernac_expr -> unit
52	42
53		val vernac_reset_name : identifier Util.located -> unit
	43	(** Print subgoals when the verbose flag is on.
	44	Meant to be used inside vernac commands from plugins. *)
54	45
55		val vernac_backtrack : int -> int -> int -> unit
	46	val print_subgoals : unit -> unit
56	47
57		(* Print subgoals when the verbose flag is on. Meant to be used inside
58		vernac commands from plugins. *)
59		val print_subgoals : unit -> unit
	48	(** The printing of goals via [print_subgoals] or during
	49	[interp] can be controlled by the following flag.
	50	Used for instance by coqide, since it has its own
	51	goal-fetching mechanism. *)
	52
	53	val enable_goal_printing : bool ref
	54
	55	(** Should Qed try to display the proof script ?
	56	True by default, but false in ProofGeneral and coqIDE *)
	57
	58	val qed_display_script : bool ref
60	59
61	60	(** Prepare a "match" template for a given inductive type.
62	61	For each branch of the match, we list the constructor name

+22

-6

toplevel/vernacexpr.ml less more

113	113	\| HintsTransparency of reference list * bool
114	114	\| HintsConstructors of reference list
115	115	\| HintsExtern of int * constr_expr option * raw_tactic_expr
116		\| HintsDestruct of identifier *
117		int * (bool,unit) location * constr_expr * raw_tactic_expr
118	116
119	117	type search_restriction =
120	118	\| SearchInside of reference list

299	297	\| VernacRestoreState of string
300	298
301	299	(* Resetting *)
302		\| VernacRemoveName of lident
303	300	\| VernacResetName of lident
304	301	\| VernacResetInitial
305	302	\| VernacBack of int

317	314	(explicitation * bool * bool) list list
318	315	\| VernacArguments of locality_flag * reference or_by_notation *
319	316	((name * bool * (loc * string) option * bool * bool) list) list *
320		int * [ `SimplDontExposeCase \| `SimplNeverUnfold \| `Rename
	317	int * [ `SimplDontExposeCase \| `SimplNeverUnfold \| `Rename \| `ExtraScopes
321	318	\| `ClearImplicits \| `ClearScopes \| `DefaultImplicits ] list
322	319	\| VernacArgumentsScope of locality_flag * reference or_by_notation *
323	320	scope_name option list

345	342	\| VernacAbort of lident option
346	343	\| VernacAbortAll
347	344	\| VernacRestart
348		\| VernacSuspend
349		\| VernacResume of lident option
350	345	\| VernacUndo of int
351	346	\| VernacUndoTo of int
352	347	\| VernacBacktrack of intintint
353	348	\| VernacFocus of int option
354	349	\| VernacUnfocus
	350	\| VernacUnfocused
355	351	\| VernacBullet of bullet
356	352	\| VernacSubproof of int option
357	353	\| VernacEndSubproof

366	362	\| VernacExtend of string * raw_generic_argument list
367	363
368	364	and located_vernac_expr = loc * vernac_expr
	365
	366
	367	(** Categories of [vernac_expr] *)
	368
	369	let rec strip_vernac = function
	370	\| VernacTime c \| VernacTimeout(_,c) \| VernacFail c -> strip_vernac c
	371	\| c -> c (* TODO: what about VernacList ? *)
	372
	373	let rec is_navigation_vernac = function
	374	\| VernacResetInitial
	375	\| VernacResetName _
	376	\| VernacBacktrack _
	377	\| VernacBackTo _
	378	\| VernacBack _ -> true
	379	\| c -> is_deep_navigation_vernac c
	380
	381	and is_deep_navigation_vernac = function
	382	\| VernacTime c \| VernacTimeout (_,c) \| VernacFail c -> is_navigation_vernac c
	383	\| VernacList l -> List.exists (fun (_,c) -> is_navigation_vernac c) l
	384	\| _ -> false
369	385
370	386	(* Locating errors raised just after the dot is parsed but before the
371	387	interpretation phase *)