aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorbertot2006-02-08 13:18:52 +0000
committerbertot2006-02-08 13:18:52 +0000
commit78eff446f542002e24a7ac0d101d0910e15d7b3d (patch)
tree3a10bf23580601878f982b1867189942678eabda
parent8d5c13b842a22a005268f24f73669c585733b894 (diff)
Julien:
+ Recursive definition (repository contrib/recdef) can now be used with GenFixpoint syntax by just replacing the usual {struct x} annotation by {wf R x} where x is one of the function declared arguments and R is a expression well-typed in the x typing environment. + Bug correction in new functional induction + For now no induction principle for general recursive definition is generated. git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/coq/trunk@8012 85f007b7-540e-0410-9357-904b9bb8a0f7
-rw-r--r--.depend462
-rw-r--r--.depend.camlp42
-rw-r--r--Makefile9
-rw-r--r--contrib/funind/indfun.ml271
-rw-r--r--contrib/funind/indfun_common.ml155
-rw-r--r--contrib/funind/indfun_common.mli14
-rw-r--r--contrib/funind/indfun_main.ml466
-rw-r--r--contrib/funind/invfun.ml134
-rw-r--r--contrib/funind/new_arg_principle.ml329
-rw-r--r--contrib/funind/rawterm_to_relation.ml42
-rw-r--r--contrib/recdef/recdef.ml4357
11 files changed, 1187 insertions, 654 deletions
diff --git a/.depend b/.depend
index da83969425..4cc8c1f7cb 100644
--- a/.depend
+++ b/.depend
@@ -54,12 +54,12 @@ kernel/indtypes.cmi: kernel/univ.cmi kernel/typeops.cmi kernel/term.cmi \
kernel/declarations.cmi
kernel/inductive.cmi: kernel/univ.cmi kernel/term.cmi kernel/names.cmi \
kernel/environ.cmi kernel/declarations.cmi
-kernel/mod_subst.cmi: kernel/term.cmi lib/pp.cmi kernel/names.cmi
-kernel/mod_typing.cmi: kernel/environ.cmi kernel/entries.cmi \
- kernel/declarations.cmi
kernel/modops.cmi: lib/util.cmi kernel/univ.cmi kernel/names.cmi \
kernel/mod_subst.cmi kernel/environ.cmi kernel/entries.cmi \
kernel/declarations.cmi
+kernel/mod_subst.cmi: kernel/term.cmi lib/pp.cmi kernel/names.cmi
+kernel/mod_typing.cmi: kernel/environ.cmi kernel/entries.cmi \
+ kernel/declarations.cmi
kernel/names.cmi: lib/predicate.cmi lib/pp.cmi
kernel/pre_env.cmi: lib/util.cmi kernel/univ.cmi kernel/term.cmi \
kernel/sign.cmi kernel/names.cmi kernel/declarations.cmi
@@ -85,9 +85,6 @@ kernel/vm.cmi: kernel/term.cmi kernel/names.cmi kernel/cemitcodes.cmi \
kernel/cbytecodes.cmi
lib/bigint.cmi: lib/pp.cmi
lib/pp.cmi: lib/pp_control.cmi
-lib/rtree.cmi: lib/pp.cmi
-lib/system.cmi: lib/pp.cmi
-lib/util.cmi: lib/pp.cmi lib/compat.cmo
library/declare.cmi: kernel/term.cmi kernel/sign.cmi kernel/safe_typing.cmi \
library/nametab.cmi kernel/names.cmi library/libnames.cmi \
kernel/indtypes.cmi kernel/environ.cmi kernel/entries.cmi \
@@ -118,6 +115,9 @@ library/library.cmi: lib/util.cmi lib/system.cmi lib/pp.cmi kernel/names.cmi \
library/nameops.cmi: kernel/term.cmi lib/pp.cmi kernel/names.cmi
library/nametab.cmi: lib/util.cmi lib/pp.cmi kernel/names.cmi \
library/libnames.cmi
+lib/rtree.cmi: lib/pp.cmi
+lib/system.cmi: lib/pp.cmi
+lib/util.cmi: lib/pp.cmi lib/compat.cmo
parsing/egrammar.cmi: toplevel/vernacexpr.cmo lib/util.cmi \
interp/topconstr.cmi proofs/tacexpr.cmo pretyping/rawterm.cmi \
interp/ppextend.cmi parsing/pcoq.cmi kernel/names.cmi \
@@ -347,11 +347,11 @@ toplevel/record.cmi: toplevel/vernacexpr.cmo interp/topconstr.cmi \
toplevel/searchisos.cmi: kernel/term.cmi kernel/names.cmi \
library/libobject.cmi
toplevel/toplevel.cmi: lib/pp.cmi parsing/pcoq.cmi
-toplevel/vernac.cmi: toplevel/vernacexpr.cmo lib/util.cmi parsing/pcoq.cmi
toplevel/vernacentries.cmi: toplevel/vernacinterp.cmi toplevel/vernacexpr.cmo \
interp/topconstr.cmi kernel/term.cmi kernel/names.cmi \
library/libnames.cmi pretyping/evd.cmi kernel/environ.cmi
toplevel/vernacinterp.cmi: proofs/tacexpr.cmo
+toplevel/vernac.cmi: toplevel/vernacexpr.cmo lib/util.cmi parsing/pcoq.cmi
toplevel/whelp.cmi: interp/topconstr.cmi kernel/term.cmi kernel/names.cmi \
kernel/environ.cmi
contrib/cc/ccalgo.cmi: lib/util.cmi kernel/term.cmi lib/pp.cmi \
@@ -360,9 +360,9 @@ contrib/cc/ccproof.cmi: kernel/names.cmi contrib/cc/ccalgo.cmi
contrib/cc/cctac.cmi: kernel/term.cmi proofs/proof_type.cmi
contrib/correctness/past.cmi: lib/util.cmi interp/topconstr.cmi \
kernel/term.cmi kernel/names.cmi
-contrib/correctness/pcic.cmi: pretyping/rawterm.cmi
contrib/correctness/pcicenv.cmi: kernel/term.cmi kernel/sign.cmi \
kernel/names.cmi
+contrib/correctness/pcic.cmi: pretyping/rawterm.cmi
contrib/correctness/pdb.cmi: kernel/names.cmi
contrib/correctness/peffect.cmi: lib/pp.cmi kernel/names.cmi
contrib/correctness/penv.cmi: kernel/term.cmi kernel/names.cmi \
@@ -382,8 +382,8 @@ contrib/correctness/ptyping.cmi: interp/topconstr.cmi kernel/term.cmi \
kernel/names.cmi
contrib/correctness/putil.cmi: kernel/term.cmi lib/pp.cmi kernel/names.cmi
contrib/correctness/pwp.cmi: kernel/term.cmi
-contrib/dp/dp.cmi: proofs/proof_type.cmi library/libnames.cmi
contrib/dp/dp_cvcl.cmi: contrib/dp/fol.cmi
+contrib/dp/dp.cmi: proofs/proof_type.cmi library/libnames.cmi
contrib/dp/dp_simplify.cmi: contrib/dp/fol.cmi
contrib/dp/dp_sorts.cmi: contrib/dp/fol.cmi
contrib/dp/dp_zenon.cmi: contrib/dp/fol.cmi
@@ -424,14 +424,14 @@ contrib/first-order/sequent.cmi: lib/util.cmi kernel/term.cmi \
library/libnames.cmi lib/heap.cmi contrib/first-order/formula.cmi \
tactics/auto.cmi
contrib/first-order/unify.cmi: kernel/term.cmi
-contrib/funind/indfun_common.cmi: kernel/term.cmi pretyping/rawterm.cmi \
- lib/pp.cmi kernel/names.cmi library/libnames.cmi
+contrib/funind/indfun_common.cmi: kernel/term.cmi kernel/sign.cmi \
+ pretyping/rawterm.cmi lib/pp.cmi kernel/names.cmi library/libnames.cmi
contrib/funind/new_arg_principle.cmi: kernel/term.cmi proofs/tacmach.cmi \
kernel/names.cmi
-contrib/funind/rawterm_to_relation.cmi: interp/topconstr.cmi \
- pretyping/rawterm.cmi kernel/names.cmi
contrib/funind/rawtermops.cmi: lib/util.cmi pretyping/rawterm.cmi \
kernel/names.cmi library/libnames.cmi
+contrib/funind/rawterm_to_relation.cmi: interp/topconstr.cmi \
+ pretyping/rawterm.cmi kernel/names.cmi
contrib/funind/tacinvutils.cmi: lib/util.cmi pretyping/termops.cmi \
kernel/term.cmi tactics/tactics.cmi tactics/tacticals.cmi \
proofs/tacmach.cmi tactics/tacinterp.cmi tactics/refine.cmi \
@@ -517,6 +517,14 @@ ide/config_lexer.cmo: lib/util.cmi ide/config_parser.cmi
ide/config_lexer.cmx: lib/util.cmx ide/config_parser.cmx
ide/config_parser.cmo: lib/util.cmi ide/config_parser.cmi
ide/config_parser.cmx: lib/util.cmx ide/config_parser.cmi
+ide/coqide.cmo: toplevel/vernacexpr.cmo lib/util.cmi ide/undo.cmi \
+ lib/system.cmi ide/preferences.cmi proofs/pfedit.cmi ide/ideutils.cmi \
+ ide/highlight.cmo ide/find_phrase.cmo ide/coq_commands.cmo ide/coq.cmi \
+ ide/command_windows.cmi ide/blaster_window.cmo ide/coqide.cmi
+ide/coqide.cmx: toplevel/vernacexpr.cmx lib/util.cmx ide/undo.cmx \
+ lib/system.cmx ide/preferences.cmx proofs/pfedit.cmx ide/ideutils.cmx \
+ ide/highlight.cmx ide/find_phrase.cmx ide/coq_commands.cmx ide/coq.cmx \
+ ide/command_windows.cmx ide/blaster_window.cmx ide/coqide.cmi
ide/coq.cmo: toplevel/vernacexpr.cmo toplevel/vernacentries.cmi \
toplevel/vernac.cmi lib/util.cmi pretyping/termops.cmi kernel/term.cmi \
proofs/tacmach.cmi tactics/tacinterp.cmi library/states.cmi \
@@ -541,14 +549,6 @@ ide/coq.cmx: toplevel/vernacexpr.cmx toplevel/vernacentries.cmx \
ide/coq.cmi
ide/coq_tactics.cmo: ide/coq_tactics.cmi
ide/coq_tactics.cmx: ide/coq_tactics.cmi
-ide/coqide.cmo: toplevel/vernacexpr.cmo lib/util.cmi ide/undo.cmi \
- lib/system.cmi ide/preferences.cmi proofs/pfedit.cmi ide/ideutils.cmi \
- ide/highlight.cmo ide/find_phrase.cmo ide/coq_commands.cmo ide/coq.cmi \
- ide/command_windows.cmi ide/blaster_window.cmo ide/coqide.cmi
-ide/coqide.cmx: toplevel/vernacexpr.cmx lib/util.cmx ide/undo.cmx \
- lib/system.cmx ide/preferences.cmx proofs/pfedit.cmx ide/ideutils.cmx \
- ide/highlight.cmx ide/find_phrase.cmx ide/coq_commands.cmx ide/coq.cmx \
- ide/command_windows.cmx ide/blaster_window.cmx ide/coqide.cmi
ide/find_phrase.cmo: ide/ideutils.cmi
ide/find_phrase.cmx: ide/ideutils.cmx
ide/highlight.cmo: ide/ideutils.cmi
@@ -727,6 +727,14 @@ kernel/inductive.cmo: lib/util.cmi kernel/univ.cmi kernel/type_errors.cmi \
kernel/inductive.cmx: lib/util.cmx kernel/univ.cmx kernel/type_errors.cmx \
kernel/term.cmx kernel/sign.cmx kernel/reduction.cmx kernel/names.cmx \
kernel/environ.cmx kernel/declarations.cmx kernel/inductive.cmi
+kernel/modops.cmo: lib/util.cmi kernel/univ.cmi kernel/term.cmi lib/pp.cmi \
+ kernel/names.cmi kernel/mod_subst.cmi kernel/environ.cmi \
+ kernel/entries.cmi kernel/declarations.cmi kernel/cemitcodes.cmi \
+ kernel/modops.cmi
+kernel/modops.cmx: lib/util.cmx kernel/univ.cmx kernel/term.cmx lib/pp.cmx \
+ kernel/names.cmx kernel/mod_subst.cmx kernel/environ.cmx \
+ kernel/entries.cmx kernel/declarations.cmx kernel/cemitcodes.cmx \
+ kernel/modops.cmi
kernel/mod_subst.cmo: lib/util.cmi kernel/term.cmi lib/pp.cmi \
kernel/names.cmi kernel/mod_subst.cmi
kernel/mod_subst.cmx: lib/util.cmx kernel/term.cmx lib/pp.cmx \
@@ -741,14 +749,6 @@ kernel/mod_typing.cmx: lib/util.cmx kernel/univ.cmx kernel/typeops.cmx \
kernel/names.cmx kernel/modops.cmx kernel/mod_subst.cmx \
kernel/environ.cmx kernel/entries.cmx kernel/declarations.cmx \
kernel/cemitcodes.cmx kernel/mod_typing.cmi
-kernel/modops.cmo: lib/util.cmi kernel/univ.cmi kernel/term.cmi lib/pp.cmi \
- kernel/names.cmi kernel/mod_subst.cmi kernel/environ.cmi \
- kernel/entries.cmi kernel/declarations.cmi kernel/cemitcodes.cmi \
- kernel/modops.cmi
-kernel/modops.cmx: lib/util.cmx kernel/univ.cmx kernel/term.cmx lib/pp.cmx \
- kernel/names.cmx kernel/mod_subst.cmx kernel/environ.cmx \
- kernel/entries.cmx kernel/declarations.cmx kernel/cemitcodes.cmx \
- kernel/modops.cmi
kernel/names.cmo: lib/util.cmi lib/predicate.cmi lib/pp.cmi lib/hashcons.cmi \
kernel/names.cmi
kernel/names.cmx: lib/util.cmx lib/predicate.cmx lib/pp.cmx lib/hashcons.cmx \
@@ -847,10 +847,10 @@ lib/edit.cmo: lib/util.cmi lib/pp.cmi lib/bstack.cmi lib/edit.cmi
lib/edit.cmx: lib/util.cmx lib/pp.cmx lib/bstack.cmx lib/edit.cmi
lib/explore.cmo: lib/explore.cmi
lib/explore.cmx: lib/explore.cmi
-lib/gmap.cmo: lib/gmap.cmi
-lib/gmap.cmx: lib/gmap.cmi
lib/gmapl.cmo: lib/util.cmi lib/gmap.cmi lib/gmapl.cmi
lib/gmapl.cmx: lib/util.cmx lib/gmap.cmx lib/gmapl.cmi
+lib/gmap.cmo: lib/gmap.cmi
+lib/gmap.cmx: lib/gmap.cmi
lib/gset.cmo: lib/gset.cmi
lib/gset.cmx: lib/gset.cmi
lib/hashcons.cmo: lib/hashcons.cmi
@@ -859,26 +859,14 @@ lib/heap.cmo: lib/heap.cmi
lib/heap.cmx: lib/heap.cmi
lib/options.cmo: lib/util.cmi lib/options.cmi
lib/options.cmx: lib/util.cmx lib/options.cmi
-lib/pp.cmo: lib/pp_control.cmi lib/pp.cmi
-lib/pp.cmx: lib/pp_control.cmx lib/pp.cmi
lib/pp_control.cmo: lib/pp_control.cmi
lib/pp_control.cmx: lib/pp_control.cmi
+lib/pp.cmo: lib/pp_control.cmi lib/pp.cmi
+lib/pp.cmx: lib/pp_control.cmx lib/pp.cmi
lib/predicate.cmo: lib/predicate.cmi
lib/predicate.cmx: lib/predicate.cmi
lib/profile.cmo: lib/profile.cmi
lib/profile.cmx: lib/profile.cmi
-lib/rtree.cmo: lib/util.cmi lib/pp.cmi lib/rtree.cmi
-lib/rtree.cmx: lib/util.cmx lib/pp.cmx lib/rtree.cmi
-lib/stamps.cmo: lib/stamps.cmi
-lib/stamps.cmx: lib/stamps.cmi
-lib/system.cmo: lib/util.cmi lib/pp.cmi config/coq_config.cmi lib/system.cmi
-lib/system.cmx: lib/util.cmx lib/pp.cmx config/coq_config.cmx lib/system.cmi
-lib/tlm.cmo: lib/gset.cmi lib/gmap.cmi lib/tlm.cmi
-lib/tlm.cmx: lib/gset.cmx lib/gmap.cmx lib/tlm.cmi
-lib/util.cmo: lib/pp.cmi lib/compat.cmo lib/util.cmi
-lib/util.cmx: lib/pp.cmx lib/compat.cmx lib/util.cmi
-library/decl_kinds.cmo: lib/util.cmi
-library/decl_kinds.cmx: lib/util.cmx
library/declare.cmo: lib/util.cmi kernel/univ.cmi kernel/typeops.cmi \
kernel/type_errors.cmi kernel/term.cmi library/summary.cmi \
kernel/sign.cmi kernel/safe_typing.cmi kernel/reduction.cmi lib/pp.cmi \
@@ -911,6 +899,8 @@ library/declaremods.cmx: lib/util.cmx library/summary.cmx \
library/libobject.cmx library/libnames.cmx library/lib.cmx \
library/global.cmx kernel/environ.cmx kernel/entries.cmx \
kernel/declarations.cmx library/declaremods.cmi
+library/decl_kinds.cmo: lib/util.cmi
+library/decl_kinds.cmx: lib/util.cmx
library/dischargedhypsmap.cmo: lib/util.cmi kernel/term.cmi \
library/summary.cmi kernel/reduction.cmi library/nametab.cmi \
kernel/names.cmi library/libobject.cmi library/libnames.cmi \
@@ -993,6 +983,16 @@ library/states.cmx: lib/system.cmx library/summary.cmx library/library.cmx \
library/lib.cmx library/states.cmi
library/summary.cmo: lib/util.cmi lib/pp.cmi lib/dyn.cmi library/summary.cmi
library/summary.cmx: lib/util.cmx lib/pp.cmx lib/dyn.cmx library/summary.cmi
+lib/rtree.cmo: lib/util.cmi lib/pp.cmi lib/rtree.cmi
+lib/rtree.cmx: lib/util.cmx lib/pp.cmx lib/rtree.cmi
+lib/stamps.cmo: lib/stamps.cmi
+lib/stamps.cmx: lib/stamps.cmi
+lib/system.cmo: lib/util.cmi lib/pp.cmi config/coq_config.cmi lib/system.cmi
+lib/system.cmx: lib/util.cmx lib/pp.cmx config/coq_config.cmx lib/system.cmi
+lib/tlm.cmo: lib/gset.cmi lib/gmap.cmi lib/tlm.cmi
+lib/tlm.cmx: lib/gset.cmx lib/gmap.cmx lib/tlm.cmi
+lib/util.cmo: lib/pp.cmi lib/compat.cmo lib/util.cmi
+lib/util.cmx: lib/pp.cmx lib/compat.cmx lib/util.cmi
parsing/argextend.cmo: toplevel/vernacexpr.cmo lib/util.cmi \
parsing/q_util.cmi parsing/q_coqast.cmo parsing/pcoq.cmi \
interp/genarg.cmi
@@ -2253,16 +2253,6 @@ toplevel/toplevel.cmx: toplevel/vernacexpr.cmx toplevel/vernac.cmx \
toplevel/toplevel.cmi
toplevel/usage.cmo: config/coq_config.cmi toplevel/usage.cmi
toplevel/usage.cmx: config/coq_config.cmx toplevel/usage.cmi
-toplevel/vernac.cmo: toplevel/vernacinterp.cmi toplevel/vernacexpr.cmo \
- toplevel/vernacentries.cmi lib/util.cmi lib/system.cmi library/states.cmi \
- parsing/ppvernac.cmi lib/pp.cmi proofs/pfedit.cmi parsing/pcoq.cmi \
- lib/options.cmi kernel/names.cmi library/library.cmi library/lib.cmi \
- parsing/lexer.cmi interp/constrintern.cmi toplevel/vernac.cmi
-toplevel/vernac.cmx: toplevel/vernacinterp.cmx toplevel/vernacexpr.cmx \
- toplevel/vernacentries.cmx lib/util.cmx lib/system.cmx library/states.cmx \
- parsing/ppvernac.cmx lib/pp.cmx proofs/pfedit.cmx parsing/pcoq.cmx \
- lib/options.cmx kernel/names.cmx library/library.cmx library/lib.cmx \
- parsing/lexer.cmx interp/constrintern.cmx toplevel/vernac.cmi
toplevel/vernacentries.cmo: kernel/vm.cmi toplevel/vernacinterp.cmi \
toplevel/vernacexpr.cmo kernel/vconv.cmi lib/util.cmi kernel/univ.cmi \
kernel/typeops.cmi interp/topconstr.cmi pretyping/termops.cmi \
@@ -2323,6 +2313,16 @@ toplevel/vernacinterp.cmx: toplevel/vernacexpr.cmx lib/util.cmx \
tactics/tacinterp.cmx proofs/tacexpr.cmx proofs/proof_type.cmx lib/pp.cmx \
lib/options.cmx kernel/names.cmx library/libnames.cmx toplevel/himsg.cmx \
toplevel/vernacinterp.cmi
+toplevel/vernac.cmo: toplevel/vernacinterp.cmi toplevel/vernacexpr.cmo \
+ toplevel/vernacentries.cmi lib/util.cmi lib/system.cmi library/states.cmi \
+ parsing/ppvernac.cmi lib/pp.cmi proofs/pfedit.cmi parsing/pcoq.cmi \
+ lib/options.cmi kernel/names.cmi library/library.cmi library/lib.cmi \
+ parsing/lexer.cmi interp/constrintern.cmi toplevel/vernac.cmi
+toplevel/vernac.cmx: toplevel/vernacinterp.cmx toplevel/vernacexpr.cmx \
+ toplevel/vernacentries.cmx lib/util.cmx lib/system.cmx library/states.cmx \
+ parsing/ppvernac.cmx lib/pp.cmx proofs/pfedit.cmx parsing/pcoq.cmx \
+ lib/options.cmx kernel/names.cmx library/library.cmx library/lib.cmx \
+ parsing/lexer.cmx interp/constrintern.cmx toplevel/vernac.cmi
toplevel/whelp.cmo: toplevel/vernacinterp.cmi lib/util.cmi \
pretyping/termops.cmi kernel/term.cmi proofs/tacmach.cmi lib/system.cmi \
interp/syntax_def.cmi proofs/refiner.cmi pretyping/rawterm.cmi lib/pp.cmi \
@@ -2373,6 +2373,12 @@ contrib/cc/g_congruence.cmx: lib/util.cmx tactics/tactics.cmx \
proofs/refiner.cmx parsing/pptactic.cmx lib/pp.cmx parsing/pcoq.cmx \
interp/genarg.cmx parsing/egrammar.cmx toplevel/cerrors.cmx \
contrib/cc/cctac.cmx
+contrib/correctness/pcicenv.cmo: kernel/univ.cmi kernel/term.cmi \
+ kernel/sign.cmi kernel/names.cmi library/global.cmi \
+ contrib/correctness/pcicenv.cmi
+contrib/correctness/pcicenv.cmx: kernel/univ.cmx kernel/term.cmx \
+ kernel/sign.cmx kernel/names.cmx library/global.cmx \
+ contrib/correctness/pcicenv.cmi
contrib/correctness/pcic.cmo: toplevel/vernacexpr.cmo lib/util.cmi \
kernel/typeops.cmi interp/topconstr.cmi pretyping/termops.cmi \
kernel/term.cmi kernel/sign.cmi toplevel/record.cmi pretyping/rawterm.cmi \
@@ -2387,12 +2393,6 @@ contrib/correctness/pcic.cmx: toplevel/vernacexpr.cmx lib/util.cmx \
library/libnames.cmx kernel/indtypes.cmx library/global.cmx \
kernel/entries.cmx pretyping/detyping.cmx library/declare.cmx \
kernel/declarations.cmx contrib/correctness/pcic.cmi
-contrib/correctness/pcicenv.cmo: kernel/univ.cmi kernel/term.cmi \
- kernel/sign.cmi kernel/names.cmi library/global.cmi \
- contrib/correctness/pcicenv.cmi
-contrib/correctness/pcicenv.cmx: kernel/univ.cmx kernel/term.cmx \
- kernel/sign.cmx kernel/names.cmx library/global.cmx \
- contrib/correctness/pcicenv.cmi
contrib/correctness/pdb.cmo: pretyping/termops.cmi kernel/term.cmi \
library/nametab.cmi kernel/names.cmi library/global.cmi \
interp/constrintern.cmi contrib/correctness/pdb.cmi
@@ -2513,6 +2513,8 @@ contrib/correctness/pwp.cmx: lib/util.cmx pretyping/termops.cmx \
library/nametab.cmx kernel/names.cmx library/libnames.cmx \
tactics/hipattern.cmx library/global.cmx kernel/environ.cmx \
contrib/correctness/pwp.cmi
+contrib/dp/dp_cvcl.cmo: contrib/dp/fol.cmi contrib/dp/dp_cvcl.cmi
+contrib/dp/dp_cvcl.cmx: contrib/dp/fol.cmi contrib/dp/dp_cvcl.cmi
contrib/dp/dp.cmo: lib/util.cmi pretyping/typing.cmi pretyping/termops.cmi \
kernel/term.cmi tactics/tactics.cmi tactics/tacticals.cmi \
proofs/tacmach.cmi library/summary.cmi parsing/printer.cmi lib/pp.cmi \
@@ -2531,8 +2533,6 @@ contrib/dp/dp.cmx: lib/util.cmx pretyping/typing.cmx pretyping/termops.cmx \
contrib/dp/dp_zenon.cmx contrib/dp/dp_sorts.cmx \
contrib/dp/dp_simplify.cmx contrib/dp/dp_cvcl.cmx kernel/declarations.cmx \
interp/coqlib.cmx contrib/dp/dp.cmi
-contrib/dp/dp_cvcl.cmo: contrib/dp/fol.cmi contrib/dp/dp_cvcl.cmi
-contrib/dp/dp_cvcl.cmx: contrib/dp/fol.cmi contrib/dp/dp_cvcl.cmi
contrib/dp/dp_simplify.cmo: contrib/dp/fol.cmi contrib/dp/dp_simplify.cmi
contrib/dp/dp_simplify.cmx: contrib/dp/fol.cmi contrib/dp/dp_simplify.cmi
contrib/dp/dp_sorts.cmo: contrib/dp/fol.cmi contrib/dp/dp_sorts.cmi
@@ -2807,64 +2807,66 @@ contrib/fourier/g_fourier.cmx: lib/util.cmx tactics/tacinterp.cmx \
proofs/tacexpr.cmx proofs/refiner.cmx parsing/pptactic.cmx lib/pp.cmx \
parsing/pcoq.cmx contrib/fourier/fourierR.cmx parsing/egrammar.cmx \
toplevel/cerrors.cmx
-contrib/funind/indfun.cmo: toplevel/vernacexpr.cmo lib/util.cmi \
- interp/topconstr.cmi pretyping/termops.cmi kernel/term.cmi \
- library/states.cmi contrib/funind/rawterm_to_relation.cmi \
- pretyping/rawterm.cmi lib/pp.cmi lib/options.cmi interp/notation.cmi \
- contrib/funind/new_arg_principle.cmi kernel/names.cmi \
- library/libnames.cmi pretyping/indrec.cmi \
- contrib/funind/indfun_common.cmi library/impargs.cmi library/global.cmi \
- pretyping/evd.cmi kernel/environ.cmi library/decl_kinds.cmo \
- interp/constrintern.cmi toplevel/command.cmi
-contrib/funind/indfun.cmx: toplevel/vernacexpr.cmx lib/util.cmx \
- interp/topconstr.cmx pretyping/termops.cmx kernel/term.cmx \
- library/states.cmx contrib/funind/rawterm_to_relation.cmx \
- pretyping/rawterm.cmx lib/pp.cmx lib/options.cmx interp/notation.cmx \
- contrib/funind/new_arg_principle.cmx kernel/names.cmx \
- library/libnames.cmx pretyping/indrec.cmx \
- contrib/funind/indfun_common.cmx library/impargs.cmx library/global.cmx \
- pretyping/evd.cmx kernel/environ.cmx library/decl_kinds.cmx \
- interp/constrintern.cmx toplevel/command.cmx
-contrib/funind/indfun_common.cmo: lib/util.cmi kernel/term.cmi \
- pretyping/rawterm.cmi lib/pp.cmi library/nametab.cmi kernel/names.cmi \
- library/nameops.cmi library/libnames.cmi library/global.cmi \
- kernel/declarations.cmi interp/coqlib.cmi \
- contrib/funind/indfun_common.cmi
-contrib/funind/indfun_common.cmx: lib/util.cmx kernel/term.cmx \
- pretyping/rawterm.cmx lib/pp.cmx library/nametab.cmx kernel/names.cmx \
- library/nameops.cmx library/libnames.cmx library/global.cmx \
- kernel/declarations.cmx interp/coqlib.cmx \
- contrib/funind/indfun_common.cmi
+contrib/funind/indfun_common.cmo: lib/util.cmi pretyping/termops.cmi \
+ kernel/term.cmi kernel/sign.cmi pretyping/rawterm.cmi lib/pp.cmi \
+ library/nametab.cmi kernel/names.cmi library/nameops.cmi \
+ library/libnames.cmi library/global.cmi kernel/declarations.cmi \
+ interp/coqlib.cmi contrib/funind/indfun_common.cmi
+contrib/funind/indfun_common.cmx: lib/util.cmx pretyping/termops.cmx \
+ kernel/term.cmx kernel/sign.cmx pretyping/rawterm.cmx lib/pp.cmx \
+ library/nametab.cmx kernel/names.cmx library/nameops.cmx \
+ library/libnames.cmx library/global.cmx kernel/declarations.cmx \
+ interp/coqlib.cmx contrib/funind/indfun_common.cmi
contrib/funind/indfun_main.cmo: toplevel/vernacinterp.cmi lib/util.cmi \
interp/topconstr.cmi kernel/term.cmi tactics/tacticals.cmi \
tactics/tacinterp.cmi proofs/tacexpr.cmo proofs/refiner.cmi \
- pretyping/rawterm.cmi parsing/pptactic.cmi lib/pp.cmi parsing/pcoq.cmi \
- library/nametab.cmi kernel/names.cmi library/nameops.cmi \
+ pretyping/rawterm.cmi parsing/pptactic.cmi parsing/ppconstr.cmi \
+ lib/pp.cmi parsing/pcoq.cmi kernel/names.cmi library/nameops.cmi \
library/libnames.cmi parsing/lexer.cmi contrib/funind/invfun.cmo \
pretyping/indrec.cmi contrib/funind/indfun_common.cmi \
- contrib/funind/indfun.cmo tactics/hiddentac.cmi interp/genarg.cmi \
- parsing/g_vernac.cmo parsing/g_constr.cmo parsing/egrammar.cmi \
- toplevel/cerrors.cmi
+ contrib/funind/indfun.cmo tactics/hiddentac.cmi library/global.cmi \
+ interp/genarg.cmi parsing/g_vernac.cmo parsing/g_constr.cmo \
+ parsing/egrammar.cmi kernel/declarations.cmi toplevel/cerrors.cmi
contrib/funind/indfun_main.cmx: toplevel/vernacinterp.cmx lib/util.cmx \
interp/topconstr.cmx kernel/term.cmx tactics/tacticals.cmx \
tactics/tacinterp.cmx proofs/tacexpr.cmx proofs/refiner.cmx \
- pretyping/rawterm.cmx parsing/pptactic.cmx lib/pp.cmx parsing/pcoq.cmx \
- library/nametab.cmx kernel/names.cmx library/nameops.cmx \
+ pretyping/rawterm.cmx parsing/pptactic.cmx parsing/ppconstr.cmx \
+ lib/pp.cmx parsing/pcoq.cmx kernel/names.cmx library/nameops.cmx \
library/libnames.cmx parsing/lexer.cmx contrib/funind/invfun.cmx \
pretyping/indrec.cmx contrib/funind/indfun_common.cmx \
- contrib/funind/indfun.cmx tactics/hiddentac.cmx interp/genarg.cmx \
- parsing/g_vernac.cmx parsing/g_constr.cmx parsing/egrammar.cmx \
- toplevel/cerrors.cmx
-contrib/funind/invfun.cmo: lib/util.cmi kernel/term.cmi tactics/tactics.cmi \
- tactics/tacticals.cmi proofs/tacmach.cmi pretyping/rawterm.cmi lib/pp.cmi \
+ contrib/funind/indfun.cmx tactics/hiddentac.cmx library/global.cmx \
+ interp/genarg.cmx parsing/g_vernac.cmx parsing/g_constr.cmx \
+ parsing/egrammar.cmx kernel/declarations.cmx toplevel/cerrors.cmx
+contrib/funind/indfun.cmo: toplevel/vernacexpr.cmo lib/util.cmi \
+ interp/topconstr.cmi pretyping/termops.cmi kernel/term.cmi \
+ library/states.cmi contrib/recdef/recdef.cmo \
+ contrib/funind/rawterm_to_relation.cmi pretyping/rawterm.cmi lib/pp.cmi \
+ lib/options.cmi interp/notation.cmi contrib/funind/new_arg_principle.cmi \
kernel/names.cmi library/libnames.cmi pretyping/indrec.cmi \
- contrib/funind/indfun_common.cmi tactics/hiddentac.cmi \
- tactics/extratactics.cmi tactics/equality.cmi
-contrib/funind/invfun.cmx: lib/util.cmx kernel/term.cmx tactics/tactics.cmx \
- tactics/tacticals.cmx proofs/tacmach.cmx pretyping/rawterm.cmx lib/pp.cmx \
+ contrib/funind/indfun_common.cmi library/impargs.cmi library/global.cmi \
+ pretyping/evd.cmi kernel/environ.cmi library/decl_kinds.cmo \
+ interp/constrintern.cmi toplevel/command.cmi
+contrib/funind/indfun.cmx: toplevel/vernacexpr.cmx lib/util.cmx \
+ interp/topconstr.cmx pretyping/termops.cmx kernel/term.cmx \
+ library/states.cmx contrib/recdef/recdef.cmx \
+ contrib/funind/rawterm_to_relation.cmx pretyping/rawterm.cmx lib/pp.cmx \
+ lib/options.cmx interp/notation.cmx contrib/funind/new_arg_principle.cmx \
kernel/names.cmx library/libnames.cmx pretyping/indrec.cmx \
- contrib/funind/indfun_common.cmx tactics/hiddentac.cmx \
- tactics/extratactics.cmx tactics/equality.cmx
+ contrib/funind/indfun_common.cmx library/impargs.cmx library/global.cmx \
+ pretyping/evd.cmx kernel/environ.cmx library/decl_kinds.cmx \
+ interp/constrintern.cmx toplevel/command.cmx
+contrib/funind/invfun.cmo: lib/util.cmi kernel/term.cmi tactics/tactics.cmi \
+ tactics/tacticals.cmi proofs/tacmach.cmi contrib/funind/tacinvutils.cmi \
+ kernel/sign.cmi pretyping/rawterm.cmi lib/pp.cmi kernel/names.cmi \
+ library/libnames.cmi pretyping/indrec.cmi \
+ contrib/funind/indfun_common.cmi tactics/hiddentac.cmi library/global.cmi \
+ tactics/extratactics.cmi tactics/equality.cmi kernel/declarations.cmi
+contrib/funind/invfun.cmx: lib/util.cmx kernel/term.cmx tactics/tactics.cmx \
+ tactics/tacticals.cmx proofs/tacmach.cmx contrib/funind/tacinvutils.cmx \
+ kernel/sign.cmx pretyping/rawterm.cmx lib/pp.cmx kernel/names.cmx \
+ library/libnames.cmx pretyping/indrec.cmx \
+ contrib/funind/indfun_common.cmx tactics/hiddentac.cmx library/global.cmx \
+ tactics/extratactics.cmx tactics/equality.cmx kernel/declarations.cmx
contrib/funind/new_arg_principle.cmo: toplevel/vernacexpr.cmo \
toplevel/vernacentries.cmi lib/util.cmi pretyping/unification.cmi \
pretyping/termops.cmi kernel/term.cmi tactics/tactics.cmi \
@@ -2872,7 +2874,7 @@ contrib/funind/new_arg_principle.cmo: toplevel/vernacexpr.cmo \
proofs/tacmach.cmi tactics/tacinterp.cmi pretyping/rawterm.cmi \
proofs/proof_type.cmi parsing/printer.cmi parsing/ppconstr.cmi lib/pp.cmi \
proofs/pfedit.cmi lib/options.cmi library/nametab.cmi kernel/names.cmi \
- library/libnames.cmi pretyping/indrec.cmi \
+ library/nameops.cmi library/libnames.cmi pretyping/indrec.cmi \
contrib/funind/indfun_common.cmi tactics/hiddentac.cmi library/global.cmi \
interp/genarg.cmi pretyping/evd.cmi tactics/equality.cmi \
kernel/environ.cmi kernel/entries.cmi tactics/eauto.cmi \
@@ -2887,7 +2889,7 @@ contrib/funind/new_arg_principle.cmx: toplevel/vernacexpr.cmx \
proofs/tacmach.cmx tactics/tacinterp.cmx pretyping/rawterm.cmx \
proofs/proof_type.cmx parsing/printer.cmx parsing/ppconstr.cmx lib/pp.cmx \
proofs/pfedit.cmx lib/options.cmx library/nametab.cmx kernel/names.cmx \
- library/libnames.cmx pretyping/indrec.cmx \
+ library/nameops.cmx library/libnames.cmx pretyping/indrec.cmx \
contrib/funind/indfun_common.cmx tactics/hiddentac.cmx library/global.cmx \
interp/genarg.cmx pretyping/evd.cmx tactics/equality.cmx \
kernel/environ.cmx kernel/entries.cmx tactics/eauto.cmx \
@@ -2895,6 +2897,18 @@ contrib/funind/new_arg_principle.cmx: toplevel/vernacexpr.cmx \
interp/coqlib.cmx toplevel/command.cmx kernel/closure.cmx \
pretyping/clenv.cmx toplevel/cerrors.cmx contrib/cc/cctac.cmx \
contrib/funind/new_arg_principle.cmi
+contrib/funind/rawtermops.cmo: lib/util.cmi proofs/tactic_debug.cmi \
+ tactics/tacinterp.cmi pretyping/rawterm.cmi parsing/printer.cmi \
+ parsing/ppconstr.cmi lib/pp.cmi kernel/names.cmi library/nameops.cmi \
+ library/libnames.cmi pretyping/inductiveops.cmi \
+ contrib/funind/indfun_common.cmi library/global.cmi pretyping/evd.cmi \
+ interp/coqlib.cmi contrib/funind/rawtermops.cmi
+contrib/funind/rawtermops.cmx: lib/util.cmx proofs/tactic_debug.cmx \
+ tactics/tacinterp.cmx pretyping/rawterm.cmx parsing/printer.cmx \
+ parsing/ppconstr.cmx lib/pp.cmx kernel/names.cmx library/nameops.cmx \
+ library/libnames.cmx pretyping/inductiveops.cmx \
+ contrib/funind/indfun_common.cmx library/global.cmx pretyping/evd.cmx \
+ interp/coqlib.cmx contrib/funind/rawtermops.cmi
contrib/funind/rawterm_to_relation.cmo: toplevel/vernacexpr.cmo lib/util.cmi \
interp/topconstr.cmi kernel/term.cmi contrib/funind/rawtermops.cmi \
pretyping/rawterm.cmi parsing/printer.cmi parsing/ppvernac.cmi lib/pp.cmi \
@@ -2909,18 +2923,6 @@ contrib/funind/rawterm_to_relation.cmx: toplevel/vernacexpr.cmx lib/util.cmx \
contrib/funind/indfun_common.cmx library/impargs.cmx interp/coqlib.cmx \
interp/constrextern.cmx toplevel/command.cmx toplevel/cerrors.cmx \
contrib/funind/rawterm_to_relation.cmi
-contrib/funind/rawtermops.cmo: lib/util.cmi proofs/tactic_debug.cmi \
- tactics/tacinterp.cmi pretyping/rawterm.cmi parsing/printer.cmi \
- parsing/ppconstr.cmi lib/pp.cmi kernel/names.cmi library/nameops.cmi \
- library/libnames.cmi pretyping/inductiveops.cmi \
- contrib/funind/indfun_common.cmi library/global.cmi pretyping/evd.cmi \
- interp/coqlib.cmi contrib/funind/rawtermops.cmi
-contrib/funind/rawtermops.cmx: lib/util.cmx proofs/tactic_debug.cmx \
- tactics/tacinterp.cmx pretyping/rawterm.cmx parsing/printer.cmx \
- parsing/ppconstr.cmx lib/pp.cmx kernel/names.cmx library/nameops.cmx \
- library/libnames.cmx pretyping/inductiveops.cmx \
- contrib/funind/indfun_common.cmx library/global.cmx pretyping/evd.cmx \
- interp/coqlib.cmx contrib/funind/rawtermops.cmi
contrib/funind/tacinv.cmo: toplevel/vernacinterp.cmi lib/util.cmi \
pretyping/typing.cmi pretyping/termops.cmi kernel/term.cmi \
tactics/tactics.cmi tactics/tacticals.cmi pretyping/tacred.cmi \
@@ -3117,6 +3119,14 @@ contrib/interface/pbp.cmx: lib/util.cmx pretyping/typing.cmx \
proofs/logic.cmx library/libnames.cmx tactics/hipattern.cmx \
library/global.cmx interp/genarg.cmx pretyping/evd.cmx kernel/environ.cmx \
interp/coqlib.cmx contrib/interface/pbp.cmi
+contrib/interface/showproof_ct.cmo: contrib/interface/xlate.cmi \
+ contrib/interface/vtp.cmi contrib/interface/translate.cmi \
+ parsing/printer.cmi lib/pp.cmi toplevel/metasyntax.cmi library/global.cmi \
+ contrib/interface/ascent.cmi
+contrib/interface/showproof_ct.cmx: contrib/interface/xlate.cmx \
+ contrib/interface/vtp.cmx contrib/interface/translate.cmx \
+ parsing/printer.cmx lib/pp.cmx toplevel/metasyntax.cmx library/global.cmx \
+ contrib/interface/ascent.cmi
contrib/interface/showproof.cmo: toplevel/vernacinterp.cmi lib/util.cmi \
pretyping/typing.cmi contrib/interface/translate.cmi \
pretyping/termops.cmi kernel/term.cmi proofs/tacmach.cmi \
@@ -3139,14 +3149,6 @@ contrib/interface/showproof.cmx: toplevel/vernacinterp.cmx lib/util.cmx \
interp/genarg.cmx pretyping/evd.cmx kernel/environ.cmx \
kernel/declarations.cmx interp/constrintern.cmx pretyping/clenv.cmx \
contrib/interface/showproof.cmi
-contrib/interface/showproof_ct.cmo: contrib/interface/xlate.cmi \
- contrib/interface/vtp.cmi contrib/interface/translate.cmi \
- parsing/printer.cmi lib/pp.cmi toplevel/metasyntax.cmi library/global.cmi \
- contrib/interface/ascent.cmi
-contrib/interface/showproof_ct.cmx: contrib/interface/xlate.cmx \
- contrib/interface/vtp.cmx contrib/interface/translate.cmx \
- parsing/printer.cmx lib/pp.cmx toplevel/metasyntax.cmx library/global.cmx \
- contrib/interface/ascent.cmi
contrib/interface/translate.cmo: contrib/interface/xlate.cmi \
contrib/interface/vtp.cmi toplevel/vernacinterp.cmi lib/util.cmi \
kernel/term.cmi proofs/tacmach.cmi kernel/sign.cmi proofs/proof_type.cmi \
@@ -3477,18 +3479,12 @@ contrib/subtac/sparser.cmx: toplevel/vernacinterp.cmx \
parsing/egrammar.cmx toplevel/cerrors.cmx
contrib/subtac/sutils.cmo: contrib/subtac/sutils.cmi
contrib/subtac/sutils.cmx: contrib/subtac/sutils.cmi
-contrib/xml/acic.cmo: kernel/term.cmi kernel/names.cmi
-contrib/xml/acic.cmx: kernel/term.cmx kernel/names.cmx
contrib/xml/acic2Xml.cmo: contrib/xml/xml.cmi lib/util.cmi kernel/term.cmi \
kernel/names.cmi contrib/xml/cic2acic.cmo contrib/xml/acic.cmo
contrib/xml/acic2Xml.cmx: contrib/xml/xml.cmx lib/util.cmx kernel/term.cmx \
kernel/names.cmx contrib/xml/cic2acic.cmx contrib/xml/acic.cmx
-contrib/xml/cic2Xml.cmo: contrib/xml/xml.cmi contrib/xml/unshare.cmi \
- tactics/tacinterp.cmi contrib/xml/cic2acic.cmo contrib/xml/acic2Xml.cmo \
- contrib/xml/acic.cmo
-contrib/xml/cic2Xml.cmx: contrib/xml/xml.cmx contrib/xml/unshare.cmx \
- tactics/tacinterp.cmx contrib/xml/cic2acic.cmx contrib/xml/acic2Xml.cmx \
- contrib/xml/acic.cmx
+contrib/xml/acic.cmo: kernel/term.cmi kernel/names.cmi
+contrib/xml/acic.cmx: kernel/term.cmx kernel/names.cmx
contrib/xml/cic2acic.cmo: lib/util.cmi contrib/xml/unshare.cmi \
kernel/univ.cmi pretyping/termops.cmi kernel/term.cmi \
pretyping/reductionops.cmi parsing/printer.cmi lib/pp.cmi \
@@ -3507,6 +3503,12 @@ contrib/xml/cic2acic.cmx: lib/util.cmx contrib/xml/unshare.cmx \
kernel/environ.cmx contrib/xml/doubleTypeInference.cmx \
library/dischargedhypsmap.cmx library/declare.cmx kernel/declarations.cmx \
contrib/xml/acic.cmx
+contrib/xml/cic2Xml.cmo: contrib/xml/xml.cmi contrib/xml/unshare.cmi \
+ tactics/tacinterp.cmi contrib/xml/cic2acic.cmo contrib/xml/acic2Xml.cmo \
+ contrib/xml/acic.cmo
+contrib/xml/cic2Xml.cmx: contrib/xml/xml.cmx contrib/xml/unshare.cmx \
+ tactics/tacinterp.cmx contrib/xml/cic2acic.cmx contrib/xml/acic2Xml.cmx \
+ contrib/xml/acic.cmx
contrib/xml/doubleTypeInference.cmo: lib/util.cmi contrib/xml/unshare.cmi \
kernel/typeops.cmi pretyping/termops.cmi kernel/term.cmi \
pretyping/retyping.cmi pretyping/reductionops.cmi kernel/reduction.cmi \
@@ -3547,8 +3549,6 @@ contrib/xml/proofTree2Xml.cmx: contrib/xml/xml.cmx lib/util.cmx \
contrib/xml/cic2acic.cmx contrib/xml/acic2Xml.cmx contrib/xml/acic.cmx
contrib/xml/unshare.cmo: contrib/xml/unshare.cmi
contrib/xml/unshare.cmx: contrib/xml/unshare.cmi
-contrib/xml/xml.cmo: contrib/xml/xml.cmi
-contrib/xml/xml.cmx: contrib/xml/xml.cmi
contrib/xml/xmlcommand.cmo: contrib/xml/xml.cmi toplevel/vernac.cmi \
lib/util.cmi contrib/xml/unshare.cmi kernel/term.cmi proofs/tacmach.cmi \
pretyping/recordops.cmi proofs/proof_trees.cmi \
@@ -3579,10 +3579,8 @@ contrib/xml/xmlentries.cmx: contrib/xml/xmlcommand.cmx \
toplevel/vernacinterp.cmx lib/util.cmx lib/pp.cmx parsing/pcoq.cmx \
parsing/lexer.cmx interp/genarg.cmx parsing/extend.cmx \
parsing/egrammar.cmx toplevel/cerrors.cmx
-ide/utils/configwin.cmo: ide/utils/configwin_types.cmo \
- ide/utils/configwin_ihm.cmo ide/utils/configwin.cmi
-ide/utils/configwin.cmx: ide/utils/configwin_types.cmx \
- ide/utils/configwin_ihm.cmx ide/utils/configwin.cmi
+contrib/xml/xml.cmo: contrib/xml/xml.cmi
+contrib/xml/xml.cmx: contrib/xml/xml.cmi
ide/utils/configwin_html_config.cmo: ide/utils/uoptions.cmi \
ide/utils/configwin_types.cmo ide/utils/configwin_messages.cmo \
ide/utils/configwin_ihm.cmo
@@ -3593,6 +3591,10 @@ ide/utils/configwin_ihm.cmo: ide/utils/uoptions.cmi ide/utils/okey.cmi \
ide/utils/configwin_types.cmo ide/utils/configwin_messages.cmo
ide/utils/configwin_ihm.cmx: ide/utils/uoptions.cmx ide/utils/okey.cmx \
ide/utils/configwin_types.cmx ide/utils/configwin_messages.cmx
+ide/utils/configwin.cmo: ide/utils/configwin_types.cmo \
+ ide/utils/configwin_ihm.cmo ide/utils/configwin.cmi
+ide/utils/configwin.cmx: ide/utils/configwin_types.cmx \
+ ide/utils/configwin_ihm.cmx ide/utils/configwin.cmi
ide/utils/configwin_types.cmo: ide/utils/uoptions.cmi \
ide/utils/configwin_keys.cmo
ide/utils/configwin_types.cmx: ide/utils/uoptions.cmx \
@@ -3655,8 +3657,6 @@ contrib/funind/tacinv.cmo: parsing/grammar.cma
contrib/funind/tacinv.cmx: parsing/grammar.cma
contrib/first-order/g_ground.cmo: parsing/grammar.cma
contrib/first-order/g_ground.cmx: parsing/grammar.cma
-contrib/funind/indfun_main.cmo: parsing/grammar.cma
-contrib/funind/indfun_main.cmx: parsing/grammar.cma
contrib/subtac/sparser.cmo: parsing/grammar.cma
contrib/subtac/sparser.cmx: parsing/grammar.cma
contrib/subtac/g_eterm.cmo: parsing/grammar.cma
@@ -3665,6 +3665,8 @@ contrib/rtauto/g_rtauto.cmo: parsing/grammar.cma
contrib/rtauto/g_rtauto.cmx: parsing/grammar.cma
contrib/recdef/recdef.cmo: parsing/grammar.cma
contrib/recdef/recdef.cmx: parsing/grammar.cma
+contrib/funind/indfun_main.cmo: parsing/grammar.cma
+contrib/funind/indfun_main.cmx: parsing/grammar.cma
contrib/interface/debug_tac.cmo: parsing/grammar.cma
contrib/interface/debug_tac.cmx: parsing/grammar.cma
contrib/interface/centaur.cmo: parsing/grammar.cma
@@ -3718,102 +3720,96 @@ tools/coq_makefile.cmx:
tools/coq-tex.cmo:
tools/coq-tex.cmx:
coq_fix_code.o: kernel/byterun/coq_fix_code.c \
- /home/logical/local//lib/ocaml/caml/config.h \
- /home/logical/local//lib/ocaml/caml/compatibility.h \
- /home/logical/local//lib/ocaml/caml/misc.h \
- /home/logical/local//lib/ocaml/caml/config.h \
- /home/logical/local//lib/ocaml/caml/mlvalues.h \
- /home/logical/local//lib/ocaml/caml/misc.h \
- /home/logical/local//lib/ocaml/caml/fail.h \
- /home/logical/local//lib/ocaml/caml/mlvalues.h \
- /home/logical/local//lib/ocaml/caml/memory.h \
+ /user/jforest/home//lib/ocaml/caml/config.h \
+ /user/jforest/home//lib/ocaml/caml/compatibility.h \
+ /user/jforest/home//lib/ocaml/caml/misc.h \
+ /user/jforest/home//lib/ocaml/caml/config.h \
+ /user/jforest/home//lib/ocaml/caml/mlvalues.h \
+ /user/jforest/home//lib/ocaml/caml/misc.h \
+ /user/jforest/home//lib/ocaml/caml/fail.h \
+ /user/jforest/home//lib/ocaml/caml/mlvalues.h \
+ /user/jforest/home//lib/ocaml/caml/memory.h \
kernel/byterun/coq_instruct.h kernel/byterun/coq_fix_code.h
coq_interp.o: kernel/byterun/coq_interp.c kernel/byterun/coq_gc.h \
- /home/logical/local//lib/ocaml/caml/mlvalues.h \
- /home/logical/local//lib/ocaml/caml/compatibility.h \
- /home/logical/local//lib/ocaml/caml/config.h \
- /home/logical/local//lib/ocaml/caml/misc.h \
- /home/logical/local//lib/ocaml/caml/alloc.h \
- /home/logical/local//lib/ocaml/caml/mlvalues.h \
+ /user/jforest/home//lib/ocaml/caml/mlvalues.h \
+ /user/jforest/home//lib/ocaml/caml/compatibility.h \
+ /user/jforest/home//lib/ocaml/caml/config.h \
+ /user/jforest/home//lib/ocaml/caml/misc.h \
+ /user/jforest/home//lib/ocaml/caml/alloc.h \
+ /user/jforest/home//lib/ocaml/caml/mlvalues.h \
kernel/byterun/coq_instruct.h kernel/byterun/coq_fix_code.h \
- kernel/byterun/coq_memory.h \
- /home/logical/local//lib/ocaml/caml/config.h \
- /home/logical/local//lib/ocaml/caml/fail.h \
- /home/logical/local//lib/ocaml/caml/misc.h \
- /home/logical/local//lib/ocaml/caml/memory.h \
- kernel/byterun/coq_values.h kernel/byterun/coq_jumptbl.h
+ kernel/byterun/coq_memory.h /user/jforest/home//lib/ocaml/caml/config.h \
+ /user/jforest/home//lib/ocaml/caml/fail.h \
+ /user/jforest/home//lib/ocaml/caml/misc.h \
+ /user/jforest/home//lib/ocaml/caml/memory.h kernel/byterun/coq_values.h \
+ kernel/byterun/coq_jumptbl.h
coq_memory.o: kernel/byterun/coq_memory.c kernel/byterun/coq_gc.h \
- /home/logical/local//lib/ocaml/caml/mlvalues.h \
- /home/logical/local//lib/ocaml/caml/compatibility.h \
- /home/logical/local//lib/ocaml/caml/config.h \
- /home/logical/local//lib/ocaml/caml/misc.h \
- /home/logical/local//lib/ocaml/caml/alloc.h \
- /home/logical/local//lib/ocaml/caml/mlvalues.h \
+ /user/jforest/home//lib/ocaml/caml/mlvalues.h \
+ /user/jforest/home//lib/ocaml/caml/compatibility.h \
+ /user/jforest/home//lib/ocaml/caml/config.h \
+ /user/jforest/home//lib/ocaml/caml/misc.h \
+ /user/jforest/home//lib/ocaml/caml/alloc.h \
+ /user/jforest/home//lib/ocaml/caml/mlvalues.h \
kernel/byterun/coq_instruct.h kernel/byterun/coq_fix_code.h \
- kernel/byterun/coq_memory.h \
- /home/logical/local//lib/ocaml/caml/config.h \
- /home/logical/local//lib/ocaml/caml/fail.h \
- /home/logical/local//lib/ocaml/caml/misc.h \
- /home/logical/local//lib/ocaml/caml/memory.h
+ kernel/byterun/coq_memory.h /user/jforest/home//lib/ocaml/caml/config.h \
+ /user/jforest/home//lib/ocaml/caml/fail.h \
+ /user/jforest/home//lib/ocaml/caml/misc.h \
+ /user/jforest/home//lib/ocaml/caml/memory.h
coq_values.o: kernel/byterun/coq_values.c kernel/byterun/coq_fix_code.h \
- /home/logical/local//lib/ocaml/caml/mlvalues.h \
- /home/logical/local//lib/ocaml/caml/compatibility.h \
- /home/logical/local//lib/ocaml/caml/config.h \
- /home/logical/local//lib/ocaml/caml/misc.h \
- kernel/byterun/coq_instruct.h kernel/byterun/coq_memory.h \
- /home/logical/local//lib/ocaml/caml/config.h \
- /home/logical/local//lib/ocaml/caml/fail.h \
- /home/logical/local//lib/ocaml/caml/mlvalues.h \
- /home/logical/local//lib/ocaml/caml/misc.h \
- /home/logical/local//lib/ocaml/caml/memory.h \
- kernel/byterun/coq_values.h /home/logical/local//lib/ocaml/caml/alloc.h
+ /user/jforest/home//lib/ocaml/caml/mlvalues.h \
+ /user/jforest/home//lib/ocaml/caml/compatibility.h \
+ /user/jforest/home//lib/ocaml/caml/config.h \
+ /user/jforest/home//lib/ocaml/caml/misc.h kernel/byterun/coq_instruct.h \
+ kernel/byterun/coq_memory.h /user/jforest/home//lib/ocaml/caml/config.h \
+ /user/jforest/home//lib/ocaml/caml/fail.h \
+ /user/jforest/home//lib/ocaml/caml/mlvalues.h \
+ /user/jforest/home//lib/ocaml/caml/misc.h \
+ /user/jforest/home//lib/ocaml/caml/memory.h kernel/byterun/coq_values.h \
+ /user/jforest/home//lib/ocaml/caml/alloc.h
coq_fix_code.d.o: kernel/byterun/coq_fix_code.c \
- /home/logical/local//lib/ocaml/caml/config.h \
- /home/logical/local//lib/ocaml/caml/compatibility.h \
- /home/logical/local//lib/ocaml/caml/misc.h \
- /home/logical/local//lib/ocaml/caml/config.h \
- /home/logical/local//lib/ocaml/caml/mlvalues.h \
- /home/logical/local//lib/ocaml/caml/misc.h \
- /home/logical/local//lib/ocaml/caml/fail.h \
- /home/logical/local//lib/ocaml/caml/mlvalues.h \
- /home/logical/local//lib/ocaml/caml/memory.h \
+ /user/jforest/home//lib/ocaml/caml/config.h \
+ /user/jforest/home//lib/ocaml/caml/compatibility.h \
+ /user/jforest/home//lib/ocaml/caml/misc.h \
+ /user/jforest/home//lib/ocaml/caml/config.h \
+ /user/jforest/home//lib/ocaml/caml/mlvalues.h \
+ /user/jforest/home//lib/ocaml/caml/misc.h \
+ /user/jforest/home//lib/ocaml/caml/fail.h \
+ /user/jforest/home//lib/ocaml/caml/mlvalues.h \
+ /user/jforest/home//lib/ocaml/caml/memory.h \
kernel/byterun/coq_instruct.h kernel/byterun/coq_fix_code.h
coq_interp.d.o: kernel/byterun/coq_interp.c kernel/byterun/coq_gc.h \
- /home/logical/local//lib/ocaml/caml/mlvalues.h \
- /home/logical/local//lib/ocaml/caml/compatibility.h \
- /home/logical/local//lib/ocaml/caml/config.h \
- /home/logical/local//lib/ocaml/caml/misc.h \
- /home/logical/local//lib/ocaml/caml/alloc.h \
- /home/logical/local//lib/ocaml/caml/mlvalues.h \
+ /user/jforest/home//lib/ocaml/caml/mlvalues.h \
+ /user/jforest/home//lib/ocaml/caml/compatibility.h \
+ /user/jforest/home//lib/ocaml/caml/config.h \
+ /user/jforest/home//lib/ocaml/caml/misc.h \
+ /user/jforest/home//lib/ocaml/caml/alloc.h \
+ /user/jforest/home//lib/ocaml/caml/mlvalues.h \
kernel/byterun/coq_instruct.h kernel/byterun/coq_fix_code.h \
- kernel/byterun/coq_memory.h \
- /home/logical/local//lib/ocaml/caml/config.h \
- /home/logical/local//lib/ocaml/caml/fail.h \
- /home/logical/local//lib/ocaml/caml/misc.h \
- /home/logical/local//lib/ocaml/caml/memory.h \
- kernel/byterun/coq_values.h kernel/byterun/coq_jumptbl.h
+ kernel/byterun/coq_memory.h /user/jforest/home//lib/ocaml/caml/config.h \
+ /user/jforest/home//lib/ocaml/caml/fail.h \
+ /user/jforest/home//lib/ocaml/caml/misc.h \
+ /user/jforest/home//lib/ocaml/caml/memory.h kernel/byterun/coq_values.h \
+ kernel/byterun/coq_jumptbl.h
coq_memory.d.o: kernel/byterun/coq_memory.c kernel/byterun/coq_gc.h \
- /home/logical/local//lib/ocaml/caml/mlvalues.h \
- /home/logical/local//lib/ocaml/caml/compatibility.h \
- /home/logical/local//lib/ocaml/caml/config.h \
- /home/logical/local//lib/ocaml/caml/misc.h \
- /home/logical/local//lib/ocaml/caml/alloc.h \
- /home/logical/local//lib/ocaml/caml/mlvalues.h \
+ /user/jforest/home//lib/ocaml/caml/mlvalues.h \
+ /user/jforest/home//lib/ocaml/caml/compatibility.h \
+ /user/jforest/home//lib/ocaml/caml/config.h \
+ /user/jforest/home//lib/ocaml/caml/misc.h \
+ /user/jforest/home//lib/ocaml/caml/alloc.h \
+ /user/jforest/home//lib/ocaml/caml/mlvalues.h \
kernel/byterun/coq_instruct.h kernel/byterun/coq_fix_code.h \
- kernel/byterun/coq_memory.h \
- /home/logical/local//lib/ocaml/caml/config.h \
- /home/logical/local//lib/ocaml/caml/fail.h \
- /home/logical/local//lib/ocaml/caml/misc.h \
- /home/logical/local//lib/ocaml/caml/memory.h
+ kernel/byterun/coq_memory.h /user/jforest/home//lib/ocaml/caml/config.h \
+ /user/jforest/home//lib/ocaml/caml/fail.h \
+ /user/jforest/home//lib/ocaml/caml/misc.h \
+ /user/jforest/home//lib/ocaml/caml/memory.h
coq_values.d.o: kernel/byterun/coq_values.c kernel/byterun/coq_fix_code.h \
- /home/logical/local//lib/ocaml/caml/mlvalues.h \
- /home/logical/local//lib/ocaml/caml/compatibility.h \
- /home/logical/local//lib/ocaml/caml/config.h \
- /home/logical/local//lib/ocaml/caml/misc.h \
- kernel/byterun/coq_instruct.h kernel/byterun/coq_memory.h \
- /home/logical/local//lib/ocaml/caml/config.h \
- /home/logical/local//lib/ocaml/caml/fail.h \
- /home/logical/local//lib/ocaml/caml/mlvalues.h \
- /home/logical/local//lib/ocaml/caml/misc.h \
- /home/logical/local//lib/ocaml/caml/memory.h \
- kernel/byterun/coq_values.h /home/logical/local//lib/ocaml/caml/alloc.h
+ /user/jforest/home//lib/ocaml/caml/mlvalues.h \
+ /user/jforest/home//lib/ocaml/caml/compatibility.h \
+ /user/jforest/home//lib/ocaml/caml/config.h \
+ /user/jforest/home//lib/ocaml/caml/misc.h kernel/byterun/coq_instruct.h \
+ kernel/byterun/coq_memory.h /user/jforest/home//lib/ocaml/caml/config.h \
+ /user/jforest/home//lib/ocaml/caml/fail.h \
+ /user/jforest/home//lib/ocaml/caml/mlvalues.h \
+ /user/jforest/home//lib/ocaml/caml/misc.h \
+ /user/jforest/home//lib/ocaml/caml/memory.h kernel/byterun/coq_values.h \
+ /user/jforest/home//lib/ocaml/caml/alloc.h
diff --git a/.depend.camlp4 b/.depend.camlp4
index 2a2a94e300..95f25b75b2 100644
--- a/.depend.camlp4
+++ b/.depend.camlp4
@@ -18,11 +18,11 @@ contrib/jprover/jprover.ml: parsing/grammar.cma
contrib/cc/g_congruence.ml: parsing/grammar.cma
contrib/funind/tacinv.ml: parsing/grammar.cma
contrib/first-order/g_ground.ml: parsing/grammar.cma
-contrib/funind/indfun_main.ml: parsing/grammar.cma
contrib/subtac/sparser.ml: parsing/grammar.cma
contrib/subtac/g_eterm.ml: parsing/grammar.cma
contrib/rtauto/g_rtauto.ml: parsing/grammar.cma
contrib/recdef/recdef.ml: parsing/grammar.cma
+contrib/funind/indfun_main.ml: parsing/grammar.cma
contrib/interface/debug_tac.ml: parsing/grammar.cma
contrib/interface/centaur.ml: parsing/grammar.cma
parsing/lexer.ml:
diff --git a/Makefile b/Makefile
index c726840be5..476fa00f17 100644
--- a/Makefile
+++ b/Makefile
@@ -307,14 +307,15 @@ RTAUTOCMO=contrib/rtauto/proof_search.cmo contrib/rtauto/refl_tauto.cmo \
ML4FILES += contrib/jprover/jprover.ml4 contrib/cc/g_congruence.ml4 \
contrib/funind/tacinv.ml4 contrib/first-order/g_ground.ml4 \
- contrib/funind/indfun_main.ml4 \
contrib/subtac/sparser.ml4 contrib/subtac/g_eterm.ml4 \
- contrib/rtauto/g_rtauto.ml4 contrib/recdef/recdef.ml4
+ contrib/rtauto/g_rtauto.ml4 contrib/recdef/recdef.ml4 \
+ contrib/funind/indfun_main.ml4
+
CONTRIB=$(OMEGACMO) $(ROMEGACMO) $(RINGCMO) $(DPCMO) $(FIELDCMO) \
$(FOURIERCMO) $(EXTRACTIONCMO) $(JPROVERCMO) $(XMLCMO) \
- $(CCCMO) $(FUNINDCMO) $(FOCMO) $(SUBTACCMO) $(RTAUTOCMO) \
- $(RECDEFCMO) $(NEWRINGCMO)
+ $(CCCMO) $(FOCMO) $(SUBTACCMO) $(RTAUTOCMO) \
+ $(RECDEFCMO) $(FUNINDCMO) $(NEWRINGCMO)
CMA=$(CLIBS) $(CAMLP4OBJS)
CMXA=$(CMA:.cma=.cmxa)
diff --git a/contrib/funind/indfun.ml b/contrib/funind/indfun.ml
index 5f5bcb3f43..c02c83c3a1 100644
--- a/contrib/funind/indfun.ml
+++ b/contrib/funind/indfun.ml
@@ -7,7 +7,9 @@ open Indfun_common
open Libnames
open Rawterm
-type annot = identifier
+type annot =
+ Struct of identifier
+ | Wf of Topconstr.constr_expr * identifier
type newfixpoint_expr =
@@ -95,7 +97,7 @@ let register is_rec fixpoint_exprl =
Command.build_recursive fixpoint_exprl (Options.boxed_definitions())
-let generate_correction_proof_struct is_rec ind_kn mut_ind newfixpoint_exprl =
+let generate_correction_proof_struct ind_kn newfixpoint_exprl =
let fname_kn (fname,_,_,_,_) =
let f_ref = Ident (dummy_loc,fname) in
locate_with_msg
@@ -120,66 +122,217 @@ let generate_correction_proof_struct is_rec ind_kn mut_ind newfixpoint_exprl =
newfixpoint_exprl
);
()
-
-let do_generate_principle fix_rec_l =
- let compute_annot (name,annot,args,types,body) =
- let names = List.map snd (Topconstr.names_of_local_assums args) in
- match annot with
- | None ->
- if List.length names > 1 then
+
+let compute_annot (name,annot,args,types,body) =
+ let names = List.map snd (Topconstr.names_of_local_assums args) in
+ match annot with
+ | None ->
+ if List.length names > 1 then
user_err_loc
(dummy_loc,"GenFixpoint",
Pp.str "the recursive argument needs to be specified");
- let new_annot = (id_of_name (List.hd names)) in
- (name,new_annot,args,types,body)
- | Some r -> (name,r,args,types,body)
+ let new_annot = (id_of_name (List.hd names)) in
+ (name,Struct new_annot,args,types,body)
+ | Some r -> (name,r,args,types,body)
+
+
+
+let rec is_rec names =
+ let names = List.fold_right Idset.add names Idset.empty in
+ let check_id id = Idset.mem id names in
+ let rec lookup = function
+ | RVar(_,id) -> check_id id
+ | RRef _ | REvar _ | RPatVar _ | RSort _ | RHole _ | RDynamic _ -> false
+ | RCast(_,b,_,_) -> lookup b
+ | RRec _ -> assert false
+ | RIf _ -> failwith "Rif not implemented"
+ | RLetTuple _ -> failwith "RLetTuple not implemented"
+ | RLetIn(_,_,t,b) | RLambda(_,_,t,b) | RProd(_,_,t,b) ->
+ lookup t || lookup b
+ | RApp(_,f,args) -> List.exists lookup (f::args)
+ | RCases(_,_,el,brl) ->
+ List.exists (fun (e,_) -> lookup e) el ||
+ List.exists (fun (_,_,_,ret)-> lookup ret) brl
in
- let newfixpoint_exprl = List.map compute_annot fix_rec_l in
- let prepare_body (name,annot,args,types,body) rt =
- let fun_args,rt' = chop_rlambda_n (Topconstr.local_binders_length args) rt in
- (name,annot,args,types,body,fun_args,rt')
+ lookup
+
+
+let register_struct is_rec fixpoint_exprl =
+ match fixpoint_exprl with
+ | [(fname,_,bl,ret_type,body),_] when not is_rec ->
+ Command.declare_definition
+ fname
+ (Decl_kinds.Global,Options.boxed_definitions (),Decl_kinds.Definition)
+ bl
+ None
+ body
+ (Some ret_type)
+ (fun _ _ -> ())
+ | _ ->
+ Command.build_recursive fixpoint_exprl (Options.boxed_definitions())
+
+let register_wf fname wf_rel_expr wf_arg args ret_type body =
+ let type_of_f = Command.generalize_constr_expr ret_type args in
+ let rec_arg_num =
+ let names =
+ List.map
+ snd
+ (Topconstr.names_of_local_assums args)
+ in
+ Util.list_index (Name wf_arg) names
in
- match build_newrecursive newfixpoint_exprl with
- | [] -> assert false
- | l ->
- let l' = List.map2 prepare_body newfixpoint_exprl l in
- let names = List.map (function (name,_,_,_,_,_,_) -> name) l' in
- let funs_args = List.map (function (_,_,_,_,_,fun_args,_) -> fun_args) l' in
- let funs_types = List.map (function (_,_,_,types,_,_,_) -> types) l' in
-(* let t1 = Sys.time () in *)
- Rawterm_to_relation.build_inductive names funs_args funs_types l;
-(* let t2 = Sys.time () in *)
-(* Pp.msgnl (str "Time to compute graph" ++ str (string_of_float (t2 -. t1))); *)
- let f_R_mut = Ident (dummy_loc,mk_rel_id (List.nth names 0)) in
- let ind =
- locate_with_msg
- (pr_reference f_R_mut++str ": Not an inductive type!")
- locate_ind
- f_R_mut
- in
- let mut_ind,_ = Global.lookup_inductive ind in
- let is_rec =
- List.exists (is_rec names) l
- in
-(* msgnl (str "Inductives registered ... "); *)
- let fixpoint_exprl : (Topconstr.fixpoint_expr*'a) list =
- List.map
- (fun (fname,annot,args,types,body) ->
- let names = List.map snd (Topconstr.names_of_local_assums args) in
- let annot =
- match annot with
- | id ->
- Util.list_index (Name id) names - 1
+ let unbounded_eq =
+ let f_app_args =
+ Topconstr.CApp
+ (dummy_loc,
+ (None,Topconstr.mkIdentC fname) ,
+ (List.map
+ (function
+ | _,Anonymous -> assert false
+ | _,Name e -> (Topconstr.mkIdentC e,None)
+ )
+ (Topconstr.names_of_local_assums args)
+ )
+ )
+ in
+ Topconstr.CApp (dummy_loc,(None,Topconstr.mkIdentC (id_of_string "eq")),
+ [(f_app_args,None);(body,None)])
+ in
+ let eq = Command.generalize_constr_expr unbounded_eq args in
+ Recdef.recursive_definition fname type_of_f wf_rel_expr rec_arg_num eq
+
+
+
+let register (fixpoint_exprl : newfixpoint_expr list) =
+ let recdefs = build_newrecursive fixpoint_exprl in
+ let is_struct =
+ match fixpoint_exprl with
+ | [((name,Wf (wf_rel,wf_x),args,types,body))] ->
+ register_wf name wf_rel wf_x args types body;
+ false
+ | _ ->
+
+ let old_fixpoint_exprl =
+ List.map
+ (function
+ | (name,Struct id,args,types,body) ->
+ let names =
+ List.map
+ snd
+ (Topconstr.names_of_local_assums args)
+ in
+ let annot = Util.list_index (Name id) names - 1 in
+ (name,annot,args,types,body),(None:Vernacexpr.decl_notation)
+ | (_,Wf _,_,_,_) ->
+ error
+ ("Cannot use mutual definition with well-founded recursion")
+ )
+ fixpoint_exprl
+ in
+ (* ok all the expressions are structural *)
+ let fix_names =
+ List.map (function (name,_,_,_,_) -> name) fixpoint_exprl
+ in
+ let is_rec = List.exists (is_rec fix_names) recdefs in
+ register_struct is_rec old_fixpoint_exprl;
+ true
+
+ in
+ recdefs,is_struct
+
+let prepare_body (name,annot,args,types,body) rt =
+ let fun_args,rt' = chop_rlambda_n (Topconstr.local_binders_length args) rt in
+ (fun_args,rt')
+
+let do_generate_principle fix_rec_l =
+ (* we first of all checks whether on not all the correct
+ assumption are here
+ *)
+ let newfixpoint_exprl = List.map compute_annot fix_rec_l in
+ (* we can then register the functions *)
+ let recdefs,is_struct = register newfixpoint_exprl in
+(* Pp.msgnl (str "Fixpoint(s) registered"); *)
+ let names = List.map (function (name,_,_,_,_) -> name) fix_rec_l in
+ let fun_bodies = List.map2 prepare_body newfixpoint_exprl recdefs in
+ let funs_args = List.map fst fun_bodies in
+ let funs_types = List.map (function (_,_,_,types,_) -> types) fix_rec_l in
+ try
+ (* We then register the Inductive graphs of the functions *)
+ Rawterm_to_relation.build_inductive names funs_args funs_types recdefs;
+ let f_R_mut = Ident (dummy_loc,mk_rel_id (List.nth names 0)) in
+ let ind =
+ locate_with_msg
+ (pr_reference f_R_mut++str ": Not an inductive type!")
+ locate_ind
+ f_R_mut
+ in
+ (* let mut_ind,_ = Global.lookup_inductive ind in *)
+ if is_struct
+ then
+ generate_correction_proof_struct (fst ind) newfixpoint_exprl
+ with _ -> ()
+;;
+
+
+(* let do_generate_principle fix_rec_l = *)
+(* let compute_annot (name,annot,args,types,body) = *)
+(* let names = List.map snd (Topconstr.names_of_local_assums args) in *)
+(* match annot with *)
+(* | None -> *)
+(* if List.length names > 1 then *)
+(* user_err_loc *)
+(* (dummy_loc,"GenFixpoint", *)
+(* Pp.str "the recursive argument needs to be specified"); *)
+(* let new_annot = (id_of_name (List.hd names)) in *)
+(* (name,new_annot,args,types,body) *)
+(* | Some r -> (name,r,args,types,body) *)
+(* in *)
+(* let newfixpoint_exprl = List.map compute_annot fix_rec_l in *)
+(* let prepare_body (name,annot,args,types,body) rt = *)
+(* let fun_args,rt' = chop_rlambda_n (Topconstr.local_binders_length args) rt in *)
+(* (name,annot,args,types,body,fun_args,rt') *)
+(* in *)
+(* match build_newrecursive newfixpoint_exprl with *)
+(* | [] -> assert false *)
+(* | l -> *)
+(* let l' = List.map2 prepare_body newfixpoint_exprl l in *)
+(* let names = List.map (function (name,_,_,_,_,_,_) -> name) l' in *)
+(* let funs_args = List.map (function (_,_,_,_,_,fun_args,_) -> fun_args) l' in *)
+(* let funs_types = List.map (function (_,_,_,types,_,_,_) -> types) l' in *)
+(* (\* let t1 = Sys.time () in *\) *)
+(* Rawterm_to_relation.build_inductive names funs_args funs_types l; *)
+(* (\* let t2 = Sys.time () in *\) *)
+(* (\* Pp.msgnl (str "Time to compute graph" ++ str (string_of_float (t2 -. t1))); *\) *)
+(* let f_R_mut = Ident (dummy_loc,mk_rel_id (List.nth names 0)) in *)
+(* let ind = *)
+(* locate_with_msg *)
+(* (pr_reference f_R_mut++str ": Not an inductive type!") *)
+(* locate_ind *)
+(* f_R_mut *)
+(* in *)
+(* let mut_ind,_ = Global.lookup_inductive ind in *)
+(* let is_rec = *)
+(* List.exists (is_rec names) l *)
+(* in *)
+(* (\* msgnl (str "Inductives registered ... "); *\) *)
+(* let fixpoint_exprl : (Topconstr.fixpoint_expr*'a) list = *)
+(* List.map *)
+(* (fun (fname,annot,args,types,body) -> *)
+(* let names = List.map snd (Topconstr.names_of_local_assums args) in *)
+(* let annot = *)
+(* match annot with *)
+(* | id -> *)
+(* Util.list_index (Name id) names - 1 *)
- in
- (fname,annot,args,types,body),(None:Vernacexpr.decl_notation)
- )
- newfixpoint_exprl
- in
- register is_rec fixpoint_exprl;
-
- generate_correction_proof_struct
- is_rec
- (fst ind)
- mut_ind
- newfixpoint_exprl
+(* in *)
+(* (fname,annot,args,types,body),(None:Vernacexpr.decl_notation) *)
+(* ) *)
+(* newfixpoint_exprl *)
+(* in *)
+(* register is_rec fixpoint_exprl; *)
+
+(* generate_correction_proof_struct *)
+(* is_rec *)
+(* (fst ind) *)
+(* mut_ind *)
+(* newfixpoint_exprl *)
diff --git a/contrib/funind/indfun_common.ml b/contrib/funind/indfun_common.ml
index 19c68d4834..3969623006 100644
--- a/contrib/funind/indfun_common.ml
+++ b/contrib/funind/indfun_common.ml
@@ -156,3 +156,158 @@ let find_reference sl s =
let eq = lazy(coq_constant "eq")
let refl_equal = lazy(coq_constant "refl_equal")
+
+(************************************************)
+(* Should be removed latter *)
+(* Comes from new induction (cf Pierre) *)
+(************************************************)
+
+open Sign
+open Term
+
+type elim_scheme = { (* lists are in reverse order! *)
+ params: rel_context; (* (prm1,tprm1);(prm2,tprm2)...(prmp,tprmp) *)
+ predicates: rel_context; (* (Qq, (Tq_1 -> Tq_2 ->...-> Tq_nq)), (Q1,...) *)
+ branches: rel_context; (* branchr,...,branch1 *)
+ args: rel_context; (* (xni, Ti_ni) ... (x1, Ti_1) *)
+ indarg: rel_declaration option; (* Some (H,I prm1..prmp x1...xni) if present, None otherwise *)
+ concl: types; (* Qi x1...xni HI, some prmis may not be present *)
+ indarg_in_concl:bool; (* true if HI appears at the end of conclusion (dependent scheme) *)
+}
+
+
+
+let occur_rel n c =
+ let res = not (noccurn n c) in
+ res
+
+let list_filter_firsts f l =
+ let rec list_filter_firsts_aux f acc l =
+ match l with
+ | e::l' when f e -> list_filter_firsts_aux f (acc@[e]) l'
+ | _ -> acc,l
+ in
+ list_filter_firsts_aux f [] l
+
+let count_rels_from n c =
+ let rels = Termops.free_rels c in
+ let cpt,rg = ref 0, ref n in
+ while Util.Intset.mem !rg rels do
+ cpt:= !cpt+1; rg:= !rg+1;
+ done;
+ !cpt
+
+let count_nonfree_rels_from n c =
+ let rels = Termops.free_rels c in
+ if Util.Intset.exists (fun x -> x >= n) rels then
+ let cpt,rg = ref 0, ref n in
+ while not (Util.Intset.mem !rg rels) do
+ cpt:= !cpt+1; rg:= !rg+1;
+ done;
+ !cpt
+ else raise Not_found
+
+(* cuts a list in two parts, first of size n. Size must be greater than n *)
+let cut_list n l =
+ let rec cut_list_aux acc n l =
+ if n<=0 then acc,l
+ else match l with
+ | [] -> assert false
+ | e::l' -> cut_list_aux (acc@[e]) (n-1) l' in
+ let res = cut_list_aux [] n l in
+ res
+
+let exchange_hd_prod subst_hd t =
+ let hd,args= decompose_app t in mkApp (subst_hd,Array.of_list args)
+
+let compute_elim_sig elimt =
+ (* conclusion is the final (Qi ...) *)
+ let hyps,conclusion = decompose_prod_assum elimt in
+ (* ccl is conclusion where Qi (that is rel <something>) is replaced
+ by a constant (Prop) to avoid it being counted as an arg or
+parameter in the following. *)
+ let ccl = exchange_hd_prod mkProp conclusion in
+ (* indarg is the inductive argument if it exists. If it exists it is
+the last hyp before the conclusion, so it is the first element of
+ hyps. To know the first elmt is an inductive arg, we check if the
+ it appears in the conclusion (as rel 1). If yes, then it is not
+ an inductive arg, otherwise it is. There is a pathological case
+ with False_inf where Qi is rel 1, so we first get rid of Qi in
+ ccl. *)
+ (* if last arg of ccl is an application then this a functional ind
+principle *) let last_arg_ccl =
+ try List.hd (List.rev (snd (decompose_app ccl)))
+ with Failure "hd" -> mkProp in (* dummy constr that is not an app
+*) let hyps',indarg,dep =
+ if isApp last_arg_ccl
+ then
+ hyps,None , false (* no HI at all *)
+ else
+ try
+ if noccurn 1 ccl (* rel 1 does not occur in ccl *)
+ then
+ List.tl hyps , Some (List.hd hyps), false (* it does not
+occur in concl *) else
+ List.tl hyps , Some (List.hd hyps) , true (* it does occur in concl *)
+ with Failure s -> Util.error "cannot recognise an induction schema"
+ in
+
+ (* Arguments [xni...x1] must appear in the conclusion, so we count
+ successive rels appearing in conclusion **Qi is not considered a
+rel** *) let nargs = count_rels_from
+ (match indarg with
+ | None -> 1
+ | Some _ -> 2) ccl in
+ let args,hyps'' = cut_list nargs hyps' in
+ let rel_is_pred (_,_,c) = isSort (snd(decompose_prod_assum c)) in
+ let branches,hyps''' =
+ list_filter_firsts (function x -> not (rel_is_pred x)) hyps''
+ in
+ (* Now we want to know which hyps remaining are predicates and which
+ are parameters *)
+ (* We rebuild
+
+ forall (x1:Ti_1) (xni:Ti_ni) (HI:I prm1..prmp x1...xni), DUMMY
+x1...xni HI ^^^^^^^^^^^^^^^^^^^^^^^^^ ^^
+ optional
+opt
+
+ Free rels appearing in this term are parameters. We catch all of
+ them if HI is present. In this case the number of parameters is
+ the number of free rels. Otherwise (principle generated by
+ functional induction or by hand) WE GUESS that all parameters
+ appear in Ti_js, IS THAT TRUE??.
+
+ TODO: if we want to generalize to the case where arges are merged
+ with branches (?) and/or where several predicates are cited in
+ the conclusion, we should do something more precise than just
+ counting free rels.
+ *)
+ let concl_with_indarg =
+ match indarg with
+ | None -> ccl
+ | Some c -> it_mkProd_or_LetIn ccl [c] in
+ let concl_with_args = it_mkProd_or_LetIn concl_with_indarg args in
+(* let nparams2 = Util.Intset.cardinal (Termops.free_rels concl_with_args) in *)
+ let nparams =
+ try List.length (hyps'''@branches) - count_nonfree_rels_from 1
+ concl_with_args with Not_found -> 0 in
+ let preds,params = cut_list (List.length hyps''' - nparams) hyps''' in
+ let elimscheme = {
+ params = params;
+ predicates = preds;
+ branches = branches;
+ args = args;
+ indarg = indarg;
+ concl = conclusion;
+ indarg_in_concl = dep;
+ }
+ in
+ elimscheme
+
+let get_params elimt =
+ (compute_elim_sig elimt).params
+(************************************************)
+(* end of Should be removed latter *)
+(* Comes from new induction (cf Pierre) *)
+(************************************************)
diff --git a/contrib/funind/indfun_common.mli b/contrib/funind/indfun_common.mli
index 639063faf6..c784dd5dde 100644
--- a/contrib/funind/indfun_common.mli
+++ b/contrib/funind/indfun_common.mli
@@ -37,3 +37,17 @@ val def_of_const : Term.constr -> Term.constr
val eq : Term.constr Lazy.t
val refl_equal : Term.constr Lazy.t
val const_of_id: identifier -> constant
+
+
+type elim_scheme = { (* lists are in reverse order! *)
+ params: Sign.rel_context; (* (prm1,tprm1);(prm2,tprm2)...(prmp,tprmp) *)
+ predicates: Sign.rel_context; (* (Qq, (Tq_1 -> Tq_2 ->...-> Tq_nq)), (Q1,...) *)
+ branches: Sign.rel_context; (* branchr,...,branch1 *)
+ args: Sign.rel_context; (* (xni, Ti_ni) ... (x1, Ti_1) *)
+ indarg: Term.rel_declaration option; (* Some (H,I prm1..prmp x1...xni) if present, None otherwise *)
+ concl: Term.types; (* Qi x1...xni HI, some prmis may not be present *)
+ indarg_in_concl:bool; (* true if HI appears at the end of conclusion (dependent scheme) *)
+}
+
+
+val compute_elim_sig : Term.types -> elim_scheme
diff --git a/contrib/funind/indfun_main.ml4 b/contrib/funind/indfun_main.ml4
index ec417411a5..55f67b5b8a 100644
--- a/contrib/funind/indfun_main.ml4
+++ b/contrib/funind/indfun_main.ml4
@@ -33,9 +33,7 @@ open G_vernac
open Indfun
open Topconstr
-open Tacinterp;;
-
-let _ = ref 0;;
+open Tacinterp
TACTIC EXTEND newfuninv
@@ -59,21 +57,41 @@ TACTIC EXTEND newfunind
let princ_name =
(
Indrec.make_elimination_ident
- ( id_of_string ((string_of_id fname)^"_2"))
+ fname
(Tacticals.elimination_sort_of_goal g)
)
in
- let princ =
- let _,princ_ref =
- qualid_of_reference (Libnames.Ident (Util.dummy_loc,princ_name))
+ let princ = const_of_id princ_name in
+ let princ_info =
+ let princ_type =
+ (try (match (Global.lookup_constant princ) with
+ {Declarations.const_type=t} -> t
+ )
+ with _ -> assert false)
in
- try Nametab.locate_constant princ_ref
- with Not_found -> Util.error "Don't know the induction scheme to use"
+ compute_elim_sig princ_type
+ in
+ let frealargs =
+ try
+ snd (Util.list_chop (List.length princ_info.params) args)
+ with _ ->
+ msg_warning
+ (str "computing non parameters argument for " ++
+ Ppconstr.pr_id princ_name ++ fnl () ++
+ str " detected params number is : " ++
+ str (string_of_int (List.length princ_info.params)) ++ fnl ()++
+ str " while number of arguments is " ++
+ str (string_of_int (List.length args)) ++ fnl ()
+(* str " number of predicates " ++ *)
+(* str (string_of_int (List.length princ_info.predicates))++ fnl () ++ *)
+(* str " number of branches " ++ *)
+(* str (string_of_int (List.length princ_info.branches)) *)
+ );args
+
in
-
Tacticals.tclTHEN
(Hiddentac.h_reduce
- (Rawterm.Pattern (List.map (fun e -> ([],e)) (args@[c])))
+ (Rawterm.Pattern (List.map (fun e -> ([],e)) (frealargs@[c])))
Tacticals.onConcl
)
((Hiddentac.h_apply (mkConst princ,Rawterm.NoBindings)))
@@ -82,7 +100,8 @@ TACTIC EXTEND newfunind
END
VERNAC ARGUMENT EXTEND rec_annotation2
- [ "{" "struct" ident(id) "}"] -> [ id ]
+ [ "{" "struct" ident(id) "}"] -> [ Struct id ]
+| [ "{" "wf" constr(r) ident(id) "}" ] -> [ Wf(r,id) ]
END
@@ -104,7 +123,8 @@ VERNAC ARGUMENT EXTEND rec_definition2
(Util.dummy_loc,"GenFixpoint",
Pp.str "the recursive argument needs to be specified");
in
- let check_exists_args id =
+ let check_exists_args an =
+ let id = match an with Struct id -> id | Wf(_,id) -> id in
(try ignore(Util.list_index (Name id) names - 1); annot
with Not_found -> Util.user_err_loc
(Util.dummy_loc,"GenFixpoint",
@@ -117,7 +137,7 @@ VERNAC ARGUMENT EXTEND rec_definition2
check_one_name ();
annot
| Some an ->
- check_exists_args an
+ check_exists_args an
in
(id, ni, bl, type_, def) ]
END
@@ -133,4 +153,20 @@ VERNAC COMMAND EXTEND GenFixpoint
["GenFixpoint" rec_definitions2(recsl)] ->
[ do_generate_principle recsl]
END
-
+(*
+
+VERNAC COMMAND EXTEND RecursiveDefinition
+ [ "Recursive" "Definition" ident(f) constr(type_of_f) constr(r) constr(wf)
+ constr(proof) integer_opt(rec_arg_num) constr(eq) ] ->
+ [ ignore(proof);ignore(wf);
+ let rec_arg_num =
+ match rec_arg_num with
+ | None -> 1
+ | Some n -> n
+ in
+ recursive_definition f type_of_f r rec_arg_num eq ]
+| [ "Recursive" "Definition" ident(f) constr(type_of_f) constr(r) constr(wf)
+ "[" ne_constr_list(proof) "]" constr(eq) ] ->
+ [ ignore(proof);ignore(wf);recursive_definition f type_of_f r 1 eq ]
+END
+*)
diff --git a/contrib/funind/invfun.ml b/contrib/funind/invfun.ml
index 963621bf71..a8429d3c47 100644
--- a/contrib/funind/invfun.ml
+++ b/contrib/funind/invfun.ml
@@ -1,13 +1,14 @@
open Util
open Names
open Term
-
+open Tacinvutils
open Pp
open Indfun_common
open Libnames
open Tacticals
open Tactics
open Tacmach
+open Sign
let tac_pattern l =
@@ -36,7 +37,7 @@ let intro_discr_until n tac : tactic =
(fun g' ->
let id,_,t = pf_last_hyp g' in
tclORELSE
- (Extratactics.h_discrHyp (Rawterm.NamedHyp id))
+ (tclABSTRACT None (Extratactics.h_discrHyp (Rawterm.NamedHyp id)))
(intro_discr_until ((id,t)::acc))
g'
)
@@ -47,7 +48,7 @@ let intro_discr_until n tac : tactic =
let rec discr_rew_in_H hypname idl : tactic =
match idl with
- | [] -> Extratactics.h_discrHyp (Rawterm.NamedHyp hypname)
+ | [] -> (Extratactics.h_discrHyp (Rawterm.NamedHyp hypname))
| ((id,t)::idl') ->
match kind_of_term t with
| App(eq',[| _ ; arg1 ; _ |]) when eq_constr eq' (Lazy.force eq) ->
@@ -64,69 +65,27 @@ let rec discr_rew_in_H hypname idl : tactic =
| _ -> discr_rew_in_H hypname idl'
let finalize fname hypname idl : tactic =
- tclTRY
+ tclTRY (
(tclTHEN
(Hiddentac.h_reduce
(Rawterm.Unfold [[],EvalConstRef fname])
(Tacticals.onHyp hypname)
)
(discr_rew_in_H hypname idl)
- )
-
+ ))
-let invfun (hypname:identifier) (fid:identifier) : tactic=
+let gen_fargs fargs : tactic =
fun g ->
- let nprod_goal = nb_prod (pf_concl g) in
- let f_ind_id =
- (
- Indrec.make_elimination_ident
- ( id_of_string ((string_of_id fid)^"_2"))
- (Tacticals.elimination_sort_of_goal g)
- )
- in
- let fname = const_of_id fid in
- let princ = const_of_id f_ind_id in
- let _,_,typhyp = List.find (fun (id,_,_) -> hypname=id) (pf_hyps g) in
- match kind_of_term typhyp with
- | App(eq',[| _ ; arg1 ; arg2 |]) when eq_constr eq' (Lazy.force eq) ->
-(* let valf = def_of_const (mkConst fname) in *)
- let eq_arg1 , eq_arg2 , tac, fargs =
- match kind_of_term arg1 , kind_of_term arg2 with
- | App(f, args),_ when eq_constr f (mkConst fname) ->
- arg1 , arg2 , tclIDTAC , args
- | _,App(f, args) when eq_constr f (mkConst fname) ->
- arg2 , arg1 , symmetry_in hypname , args
- | _ , _ -> error "inversion impossible"
- in
- let gen_fargs : tactic =
- fun g ->
- generalize
- (List.map
- (fun arg ->
- let targ = pf_type_of g arg in
- let refl_arg = mkApp (Lazy.force refl_equal , [|targ ; arg|]) in
- refl_arg
- )
- (Array.to_list fargs)
- ) g
- in
- let pat_args =
- (List.map (fun e -> ([-1],e)) (Array.to_list fargs)) @ [[],eq_arg1] in
-
- tclTHENSEQ
- [
- tac;
- gen_fargs;
- tac_pattern pat_args;
- Hiddentac.h_apply (mkConst princ,Rawterm.NoBindings);
- intro_discr_until nprod_goal (finalize fname hypname)
-
- ]
- g
-
-
- | _ -> error "inversion impossible"
-
+ generalize
+ (List.map
+ (fun arg ->
+ let targ = pf_type_of g arg in
+ let refl_arg = mkApp (Lazy.force refl_equal , [|targ ; arg|]) in
+ refl_arg
+ )
+ (Array.to_list fargs)
+ )
+ g
let invfun (hypname:identifier) (fid:identifier) : tactic=
@@ -135,17 +94,41 @@ let invfun (hypname:identifier) (fid:identifier) : tactic=
let f_ind_id =
(
Indrec.make_elimination_ident
- ( id_of_string ((string_of_id fid)^"_2"))
+ fid
(Tacticals.elimination_sort_of_goal g)
)
in
let fname = const_of_id fid in
let princ = const_of_id f_ind_id in
+ let princ_info =
+ let princ_type =
+ (try (match (Global.lookup_constant princ) with
+ {Declarations.const_type=t} -> t
+ )
+ with _ -> assert false)
+ in
+ compute_elim_sig princ_type
+ in
let _,_,typhyp = List.find (fun (id,_,_) -> hypname=id) (pf_hyps g) in
+ let do_invert fargs appf : tactic =
+ let frealargs = (snd (array_chop (List.length princ_info.params) fargs))
+ in
+ let pat_args =
+ (List.map (fun e -> ([-1],e)) (Array.to_list frealargs)) @ [[],appf]
+ in
+ tclTHENSEQ
+ [
+ gen_fargs frealargs;
+ tac_pattern pat_args;
+ Hiddentac.h_apply (mkConst princ,Rawterm.NoBindings);
+ intro_discr_until nprod_goal (finalize fname hypname)
+
+ ]
+ in
match kind_of_term typhyp with
| App(eq',[| _ ; arg1 ; arg2 |]) when eq_constr eq' (Lazy.force eq) ->
(* let valf = def_of_const (mkConst fname) in *)
- let eq_arg1 , eq_arg2 , tac, fargs =
+ let eq_arg1 , eq_arg2 , good_eq_form , fargs =
match kind_of_term arg1 , kind_of_term arg2 with
| App(f, args),_ when eq_constr f (mkConst fname) ->
arg1 , arg2 , tclIDTAC , args
@@ -153,32 +136,13 @@ let invfun (hypname:identifier) (fid:identifier) : tactic=
arg2 , arg1 , symmetry_in hypname , args
| _ , _ -> error "inversion impossible"
in
- let gen_fargs : tactic =
- fun g ->
- generalize
- (List.map
- (fun arg ->
- let targ = pf_type_of g arg in
- let refl_arg = mkApp (Lazy.force refl_equal , [|targ ; arg|]) in
- refl_arg
- )
- (Array.to_list fargs)
- ) g
- in
- let pat_args =
- (List.map (fun e -> ([-1],e)) (Array.to_list fargs)) @ [[],eq_arg1] in
-
- tclTHENSEQ
- [
- tac;
- gen_fargs;
- tac_pattern pat_args;
- Hiddentac.h_apply (mkConst princ,Rawterm.NoBindings);
- intro_discr_until nprod_goal (finalize fname hypname)
-
- ]
+ tclTHEN
+ good_eq_form
+ (do_invert fargs eq_arg1)
g
-
+ | App(f',fargs) when eq_constr f' (mkConst fname) ->
+ do_invert fargs typhyp g
+
| _ -> error "inversion impossible"
diff --git a/contrib/funind/new_arg_principle.ml b/contrib/funind/new_arg_principle.ml
index f0106d91fb..a33f0f6c54 100644
--- a/contrib/funind/new_arg_principle.ml
+++ b/contrib/funind/new_arg_principle.ml
@@ -185,9 +185,6 @@ let compute_new_princ_type_from_rel with_concl replace
compute_new_princ_type_for_letin env x v t b
| _ -> pre_princ,[]
in
-(* let _tim2 = Sys.time() in *)
-
-
(* if Tacinterp.get_debug () <> Tactic_debug.DebugOff *)
(* then *)
(* msgnl (str "compute_new_princ_type for "++ *)
@@ -333,16 +330,7 @@ let exactify_proof rec_pos ptes_to_fix : tactic =
let eq_or = eq_constr or_as_ind in
let tac_res tac: tactic =
fun g ->
-(* let concl = pf_concl g in *)
-(* if eq_constr concl (Coqlib.build_coq_True ()) *)
-(* then exact_no_check (Coqlib.build_coq_I ()) g *)
-(* else *)
match kind_of_term (pf_concl g) with
-(* | LetIn _ | Case _ -> *)
-(* tclTHEN *)
-(* (tclPROGRESS (h_reduce (Rawterm.Simpl None) onConcl)) *)
-(* tac *)
-(* g *)
| Prod _ -> tclTHEN intro tac g
| App(f,_) ->
if eq_not f
@@ -385,7 +373,7 @@ let exactify_proof rec_pos ptes_to_fix : tactic =
let rec exactify_proof g =
tclFIRST
[
- tclSOLVE [my_reflexivity(* Tactics.reflexivity *)];
+ tclSOLVE [my_reflexivity];
tclSOLVE [Eauto.e_assumption];
tclSOLVE [Tactics.reflexivity ];
tac_res exactify_proof
@@ -486,10 +474,6 @@ let finalize_proof rec_pos fixes (hyps:identifier list) =
tclTHENS
(try Equality.replace (args.(nargs -1)) t
with _ ->
-(* Pp.msgnl (str "Cannot replace " ++ *)
-(* pr_lconstr_env (pf_env g) args.(nargs - 1) ++ *)
-(* str " with " ++ pr_lconstr_env (pf_env g) t *)
-(* ); *)
tclFAIL 0 (str "")
)
[tac;
@@ -517,7 +501,6 @@ let do_prove_princ_for_struct
finalize_proof rec_pos fixes hyps with_concl fnames term
in
let rec do_prove_princ_for_struct do_finalize term g =
-(* Pp.msgnl (str "Proving with body : " ++ pr_lconstr_env (pf_env g) term); *)
(* if Tacinterp.get_debug () <> Tactic_debug.DebugOff *)
(* then msgnl (str "Proving with body : " ++ pr_lconstr_env (pf_env g) term); *)
let tac =
@@ -618,7 +601,6 @@ let prove_princ_for_struct with_concl f_names fun_num nparams : tactic =
begin Some (idxs.(fix_num) - nparams),substl (List.rev fnames_as_constr) ca.(fix_num) end
| b -> None,fbody
in
-(* msgnl (str "fbody : " ++ Printer.pr_lconstr fbody); *)
let f_real_args = nb_lam fbody - nparams in
let test_goal_for_hyps g =
let goal_nb_prod = nb_prod (pf_concl g) in
@@ -626,7 +608,7 @@ let prove_princ_for_struct with_concl f_names fun_num nparams : tactic =
in
let test_goal_for_args g =
let goal_nb_prod = nb_prod (pf_concl g) in
- (with_concl && goal_nb_prod <= 1)||
+ (with_concl && goal_nb_prod < 1 )||
((not with_concl) && goal_nb_prod = 0 )
in
let rec intro_params tac params n : tactic =
@@ -719,8 +701,8 @@ let prove_princ_for_struct with_concl f_names fun_num nparams : tactic =
(* msgnl (str "introducing args"); *)
intro_args
(fun args ->
- tclTHEN
- (reduce_fname (Array.to_list f_names))
+(* tclTHEN *)
+(* (reduce_fname (Array.to_list f_names)) *)
(tac params ptes ptes_to_fix hyps args))
[]
)
@@ -748,10 +730,41 @@ let prove_princ_for_struct with_concl f_names fun_num nparams : tactic =
(fun params ptes ptes_to_fix hyps args g ->
let app_f = apply_fbody g params args in
(* msgnl (str "proving"); *)
- tac (Array.to_list f_names) ptes ptes_to_fix hyps app_f g
+ match rec_arg_num with
+ Some rec_arg_num ->
+ let actual_args =
+ List.fold_left (fun y x -> x::y)
+ (List.rev args)
+ params
+ in
+ let to_replace = applist(mkConst f_names.(fun_num),List.map mkVar actual_args) in
+
+ tclTHENS
+ (Equality.replace
+ to_replace
+ app_f
+ )
+ [
+ tac (Array.to_list f_names) ptes ptes_to_fix hyps app_f;
+ let id = List.nth (List.rev args) (rec_arg_num ) in
+ (tclTHENSEQ
+ [(h_simplest_case (mkVar id));
+ tclTRY Tactics.intros_reflexivity
+ ]
+ )
+(* Tactics.reflexivity) *)
+ ]
+ g
+ | None ->
+ tclTHEN
+ (reduce_fname (Array.to_list f_names))
+ (tac (Array.to_list f_names) ptes ptes_to_fix hyps app_f)
+ g
+
+(* tac (Array.to_list f_names) ptes ptes_to_fix hyps app_f g *)
)
in
- prepare_goal_tac (fun g -> (* Pp.msgnl (str "starting proof real .... "); *)do_prove_princ_for_struct rec_arg_num with_concl g)
+ prepare_goal_tac (fun g -> do_prove_princ_for_struct rec_arg_num with_concl g)
@@ -871,25 +884,17 @@ let generate_new_structural_principle
match new_princ_name with
| Some (id) -> id
| None ->
- let id_of_f =
- let id = id_of_label (con_label f) in
- if with_concl
- then id_of_string ((string_of_id id)^"_2")
- else id
- in
- Indrec.make_elimination_ident (id_of_f) (family_of_sort toSort)
+ let id_of_f = id_of_label (con_label f) in
+ Indrec.make_elimination_ident id_of_f (family_of_sort toSort)
in
let hook _ _ =
- let id_of_f =
- let id = id_of_label (con_label f) in
- if with_concl
- then id_of_string ((string_of_id id)^"_2")
- else id
- in
+ let id_of_f = id_of_label (con_label f) in
let register_with_sort fam_sort =
let s = Termops.new_sort_in_family fam_sort in
let name = Indrec.make_elimination_ident id_of_f fam_sort in
- let value = change_property_sort mutr_nparams s new_principle_type new_princ_name in
+ let value =
+ change_property_sort mutr_nparams s new_principle_type new_princ_name
+ in
let ce =
{ const_entry_body = value;
const_entry_type = None;
@@ -907,7 +912,7 @@ let generate_new_structural_principle
in
register_with_sort InProp;
register_with_sort InSet
- in
+ in
begin
Command.start_proof
new_princ_name
@@ -941,3 +946,249 @@ let generate_new_structural_principle
)
end
+
+
+
+
+
+
+(*************************************************)
+let next_ident_away = Nameops.next_ident_away
+
+
+(* let base_leaf_eq eqs f_id g = *)
+(* let ids = ids_of_named_context (pf_hyps g) in *)
+(* let k = next_ident_away (id_of_string "k") ids in *)
+(* let p = next_ident_away (id_of_string "p") (k::ids) in *)
+(* let v = next_ident_away (id_of_string "v") (p::k::ids) in *)
+(* let heq = next_ident_away (id_of_string "heq") (v::p::k::ids) in *)
+(* let heq1 = next_ident_away (id_of_string "heq") (heq::v::p::k::ids) in *)
+(* let hex = next_ident_away (id_of_string "hex") (heq1::heq::v::p::k::ids) in *)
+(* tclTHENLIST [ *)
+(* intros_using [v; hex]; *)
+(* simplest_elim (mkVar hex); *)
+(* intros_using [p;heq1]; *)
+(* tclTRY *)
+(* (Equality.rewriteRL *)
+(* (mkApp(mkVar heq1, *)
+(* [|mkApp (Lazy.force Recdef.coq_S, [|mkVar p|]); *)
+(* mkApp(Lazy.force Recdef.lt_n_Sn, [|mkVar p|]); f_id|]))); *)
+(* Recdef.list_rewrite true eqs; *)
+(* apply (Lazy.force refl_equal)] g;; *)
+
+(* let f_S t = mkApp(Lazy.force Recdef.coq_S, [|t|]);; *)
+
+(* let rec introduce_all_values_eq cont_tac f p heq1 pmax *)
+(* bounds le_proofs eqs ids = *)
+(* function *)
+(* [] -> *)
+(* tclTHENLIST *)
+(* [tclTHENS *)
+(* (Equality.general_rewrite_bindings false *)
+(* (mkVar heq1, *)
+(* Rawterm.ExplicitBindings[dummy_loc,Rawterm.NamedHyp (id_of_string "k"), *)
+(* f_S(f_S(mkVar pmax)); *)
+(* dummy_loc,Rawterm.NamedHyp (id_of_string "def"), *)
+(* f])) *)
+(* [tclTHENLIST *)
+(* [Recdef.list_rewrite true eqs; cont_tac pmax le_proofs]; *)
+(* tclTHENLIST[apply (Lazy.force Recdef.le_lt_SS); *)
+(* Recdef.compute_le_proofs le_proofs]]] *)
+(* | arg::args -> *)
+(* let v' = next_ident_away (id_of_string "v") ids in *)
+(* let ids = v'::ids in *)
+(* let hex' = next_ident_away Recdef.hex_id ids in *)
+(* let ids = hex'::ids in *)
+(* let p' = next_ident_away Recdef.p_id ids in *)
+(* let ids = p'::ids in *)
+(* let new_pmax = next_ident_away Recdef.pmax_id ids in *)
+(* let ids = pmax::ids in *)
+(* let hle1 = next_ident_away Recdef.hle_id ids in *)
+(* let ids = hle1::ids in *)
+(* let hle2 = next_ident_away Recdef.hle_id ids in *)
+(* let ids = hle2::ids in *)
+(* let heq = next_ident_away Recdef.heq_id ids in *)
+(* let ids = heq::ids in *)
+(* let heq2 = *)
+(* next_ident_away Recdef.heq_id ids in *)
+(* let ids = heq2::ids in *)
+(* tclTHENLIST *)
+(* [Recdef.mkCaseEq(mkApp(termine, Array.of_list arg)); *)
+(* intros_using [v'; hex']; *)
+(* simplest_elim(mkVar hex'); *)
+(* intros_using [p']; *)
+(* simplest_elim(mkApp(Lazy.force max_constr, [|mkVar pmax; *)
+(* mkVar p'|])); *)
+(* intros_using [new_pmax;hle1;hle2]; *)
+(* introduce_all_values_eq *)
+(* (fun pmax' le_proofs'-> *)
+(* tclTHENLIST *)
+(* [cont_tac pmax' le_proofs'; *)
+(* intros_using [heq;heq2]; *)
+(* rewriteLR (mkVar heq2); *)
+(* tclTHENS *)
+(* (general_rewrite_bindings false *)
+(* (mkVar heq, *)
+(* ExplicitBindings *)
+(* [dummy_loc, NamedHyp k_id, *)
+(* f_S(mkVar pmax'); *)
+(* dummy_loc, NamedHyp def_id, f])) *)
+(* [tclIDTAC; *)
+(* tclTHENLIST *)
+(* [apply (Lazy.force le_lt_n_Sm); *)
+(* compute_le_proofs le_proofs']]]) *)
+(* functional termine f p heq1 new_pmax *)
+(* (p'::bounds)((mkVar pmax)::le_proofs) eqs *)
+(* (heq2::heq::hle2::hle1::new_pmax::p'::hex'::v'::ids) args] *)
+
+
+(* let rec_leaf_eq f ids eqs expr fn args = *)
+(* let p = next_ident_away (id_of_string "id") ids in *)
+(* let ids = p::ids in *)
+(* let v = next_ident_away (id_of_string "v") ids in *)
+(* let ids = v::ids in *)
+(* let hex = next_ident_away (id_of_string "hex") ids in *)
+(* let ids = hex::ids in *)
+(* let heq1 = next_ident_away (id_of_string "heq") ids in *)
+(* let ids = heq1::ids in *)
+(* let hle1 = next_ident_away (id_of_string "hle") ids in *)
+(* let ids = hle1::ids in *)
+(* tclTHENLIST *)
+(* [intros_using [v;hex]; *)
+(* simplest_elim (mkVar hex); *)
+(* intros_using [p;heq1]; *)
+(* generalize [mkApp(Lazy.force Recdef.le_n,[|mkVar p|])]; *)
+(* intros_using [hle1]; *)
+(* (\* introduce_all_values_eq (fun _ _ -> tclIDTAC) *\) *)
+(* (\* f p heq1 p [] [] eqs ids args; *\) *)
+(* (\* apply (Lazy.force refl_equal) *\)] *)
+
+open Libnames
+let rec nthtl = function
+ l, 0 -> l | _::tl, n -> nthtl (tl, n-1) | [], _ -> [];;
+let mkCaseEq a =
+ (fun g ->
+(* commentaire de Yves: on pourra avoir des problemes si
+ a n'est pas bien type dans l'environnement du but *)
+ let type_of_a = pf_type_of g a in
+ (tclTHEN (generalize [mkApp(Lazy.force refl_equal, [| type_of_a; a|])])
+ (tclTHEN
+ (fun g2 ->
+ change_in_concl None
+ (Tacred.pattern_occs [([2], a)] (pf_env g2) Evd.empty (pf_concl g2))
+ g2)
+ (simplest_case a))) g);;
+
+let rec (find_call_occs:
+ constr -> constr -> (constr list ->constr)*(constr list list)) =
+ fun f expr ->
+ match (kind_of_term expr) with
+ App (g, args) when g = f ->
+ (* For now we suppose that the function takes only one argument. *)
+ (fun l -> List.hd l), [Array.to_list args]
+ | App (g, args) ->
+ let (largs: constr list) = Array.to_list args in
+ let rec find_aux = function
+ [] -> (fun x -> []), []
+ | a::tl ->
+ (match find_aux tl with
+ (cf, ((arg1::args) as opt_args)) ->
+ (match find_call_occs f a with
+ cf2, (_ :: _ as other_args) ->
+ let len1 = List.length other_args in
+ (fun l ->
+ cf2 l::(cf (nthtl(l,len1)))), other_args@opt_args
+ | _, [] -> (fun x -> a::cf x), opt_args)
+ | _, [] ->
+ (match find_call_occs f a with
+ cf, (arg1::args) -> (fun l -> cf l::tl), (arg1::args)
+ | _, [] -> (fun x -> a::tl), [])) in
+ begin
+ match (find_aux largs) with
+ cf, [] -> (fun l -> mkApp(g, args)), []
+ | cf, args ->
+ (fun l -> mkApp (g, Array.of_list (cf l))), args
+ end
+ | Rel(_) -> error "find_call_occs : Rel"
+ | Var(id) -> (fun l -> expr), []
+ | Meta(_) -> error "find_call_occs : Meta"
+ | Evar(_) -> error "find_call_occs : Evar"
+ | Sort(_) -> error "find_call_occs : Sort"
+ | Cast(_,_,_) -> error "find_call_occs : cast"
+ | Prod(_,_,_) -> error "find_call_occs : Prod"
+ | Lambda(_,_,_) -> error "find_call_occs : Lambda"
+ | LetIn(_,_,_,_) -> error "find_call_occs : let in"
+ | Const(_) -> (fun l -> expr), []
+ | Ind(_) -> (fun l -> expr), []
+ | Construct (_, _) -> (fun l -> expr), []
+ | Case(i,t,a,r) ->
+ (match find_call_occs f a with
+ cf, (arg1::args) -> (fun l -> mkCase(i, t, (cf l), r)),(arg1::args)
+ | _ -> (fun l -> mkCase(i, t, a, r)),[])
+ | Fix(_) -> error "find_call_occs : Fix"
+ | CoFix(_) -> error "find_call_occs : CoFix";;
+
+let rec mk_intros_and_continue (extra_eqn:bool)
+ cont_function (eqs:constr list) (expr:constr) g =
+ let ids=ids_of_named_context (pf_hyps g) in
+ match kind_of_term expr with
+ Lambda (n, _, b) ->
+ let n1 = (match n with
+ Name x -> x
+ | Anonymous -> (id_of_string "anonymous") ) in
+ let new_n = next_ident_away n1 ids in
+ tclTHEN (intro_using new_n)
+ (mk_intros_and_continue extra_eqn cont_function eqs
+ (subst1 (mkVar new_n) b)) g
+ | _ ->
+ if extra_eqn then
+ let teq = next_ident_away (id_of_string "teq") ids in
+ tclTHENSEQ
+ [(intro_using teq); Equality.rewriteLR (mkVar teq);
+ (cont_function (mkVar teq::eqs) expr)] g
+ else
+ cont_function eqs expr g;;
+
+let base_leaf_eq eqs f = tclTRY reflexivity
+
+let rec_leaf_eq f ids eqs expr fn args = tclTRY reflexivity
+
+
+let rec prove_eq (f:constr)
+ (eqs:constr list)
+ (expr:constr) =
+ tclTRY
+ (match kind_of_term expr with
+ Case(_,t,a,l) ->
+ (match find_call_occs f a with
+ _,[] ->
+ tclTHENS(mkCaseEq a)(* (simplest_case a) *)
+ (List.map
+ (mk_intros_and_continue true
+ (prove_eq f) eqs)
+ (Array.to_list l))
+ | _,_::_ ->
+ (match find_call_occs f expr with
+ _,[] -> base_leaf_eq eqs f
+ | fn,args ->
+ fun g ->
+ let ids = pf_ids_of_hyps g in
+ rec_leaf_eq f ids eqs expr fn args g
+ )
+ )
+ | _ ->
+ (match find_call_occs f expr with
+ _,[] -> base_leaf_eq eqs f
+ | fn,args ->
+ fun g ->
+ let ids = pf_ids_of_hyps g in
+ rec_leaf_eq f ids eqs expr fn args g
+ )
+ )
+
+
+let prove_eq f expr =
+ let fname = destConst f in
+ tclTHEN
+ (Tactics.unfold_constr (ConstRef fname))
+ (mk_intros_and_continue false (prove_eq f) [] expr)
diff --git a/contrib/funind/rawterm_to_relation.ml b/contrib/funind/rawterm_to_relation.ml
index 2f52e86d2f..48cc2ce3a5 100644
--- a/contrib/funind/rawterm_to_relation.ml
+++ b/contrib/funind/rawterm_to_relation.ml
@@ -568,19 +568,22 @@ let is_res id =
(* rebuild the raw constructors expression.
eliminates some meaningless equality, applies some rewrites......
*)
-let rec rebuild_cons relname args rt =
+let rec rebuild_cons relname args crossed_types rt =
match rt with
| RProd(_,n,t,b) ->
+ let not_free_in_t id = not (is_free_in id t) in
+ let new_crossed_types = t::crossed_types in
begin
match t with
| RApp(_,(RVar(_,res_id) as res_rt),args') when is_res res_id ->
begin
match args' with
| (RVar(_,this_relname))::args' ->
- let new_b,id_to_exclude = rebuild_cons relname args b in
+ let new_b,id_to_exclude = rebuild_cons relname args new_crossed_types b in
let new_t =
mkRApp(mkRVar(mk_rel_id this_relname),args'@[res_rt])
- in mkRProd(n,new_t,new_b),id_to_exclude
+ in mkRProd(n,new_t,new_b),
+ Idset.filter not_free_in_t id_to_exclude
| _ -> (* the first args is the name of the function! *)
assert false
end
@@ -588,36 +591,46 @@ let rec rebuild_cons relname args rt =
when eq_as_ref = Lazy.force Coqlib.coq_eq_ref
->
let is_in_b = is_free_in id b in
- let keep_eq = not (List.exists (is_free_in id) args) || is_in_b in
+ let keep_eq =
+ not (List.exists (is_free_in id) args) || is_in_b ||
+ List.exists (is_free_in id) crossed_types
+ in
let new_args = List.map (replace_var_by_term id rt) args in
let subst_b =
if is_in_b then b else replace_var_by_term id rt b
in
- let new_b,id_to_exclude = rebuild_cons relname new_args subst_b in
+ let new_b,id_to_exclude = rebuild_cons relname new_args new_crossed_types subst_b in
if keep_eq then mkRProd(n,t,new_b),id_to_exclude
else new_b, Idset.add id id_to_exclude
| _ ->
- let new_b,id_to_exclude = rebuild_cons relname args b in
+ let new_b,id_to_exclude = rebuild_cons relname args new_crossed_types b in
match n with
| Name id when Idset.mem id id_to_exclude ->
- new_b,Idset.remove id id_to_exclude
- | _ -> mkRProd(n,t,new_b),id_to_exclude
+ new_b,Idset.remove id
+ (Idset.filter not_free_in_t id_to_exclude)
+ | _ -> mkRProd(n,t,new_b),Idset.filter not_free_in_t id_to_exclude
end
| RLambda(_,n,t,b) ->
begin
- let new_b,id_to_exclude = rebuild_cons relname args b in
+ let not_free_in_t id = not (is_free_in id t) in
+ let new_crossed_types = t :: crossed_types in
+ let new_b,id_to_exclude = rebuild_cons relname args new_crossed_types b in
match n with
| Name id when Idset.mem id id_to_exclude ->
- new_b,Idset.remove id id_to_exclude
- | _ -> RProd(dummy_loc,n,t,new_b),id_to_exclude
+ new_b,
+ Idset.remove id (Idset.filter not_free_in_t id_to_exclude)
+ | _ ->
+ RProd(dummy_loc,n,t,new_b),Idset.filter not_free_in_t id_to_exclude
end
| RLetIn(_,n,t,b) ->
begin
- let new_b,id_to_exclude = rebuild_cons relname args b in
+ let not_free_in_t id = not (is_free_in id t) in
+ let new_b,id_to_exclude = rebuild_cons relname args (t::crossed_types) b in
match n with
| Name id when Idset.mem id id_to_exclude ->
- new_b,Idset.remove id id_to_exclude
- | _ -> RLetIn(dummy_loc,n,t,new_b),id_to_exclude
+ new_b,Idset.remove id (Idset.filter not_free_in_t id_to_exclude)
+ | _ -> RLetIn(dummy_loc,n,t,new_b),
+ Idset.filter not_free_in_t id_to_exclude
end
| _ -> mkRApp(mkRVar relname,args@[rt]),Idset.empty
@@ -699,6 +712,7 @@ let build_inductive funnames funsargs returned_types (rtl:rawconstr list) =
| Name id, _ -> mkRVar id
)
funsargs.(i))
+ []
rt
)
)
diff --git a/contrib/recdef/recdef.ml4 b/contrib/recdef/recdef.ml4
index 7e62893d57..a416e3882c 100644
--- a/contrib/recdef/recdef.ml4
+++ b/contrib/recdef/recdef.ml4
@@ -44,12 +44,13 @@ open Eauto
open Genarg
-let observe_tac s tac g =
- msgnl (Printer.pr_goal (sig_it g));
- try let v = tac g in msgnl ((str s)++(str " ")++(str "finished")); v
- with e ->
- msgnl (str "observation "++str s++str " raised an exception"); raise e;;
+let observe_tac s tac g = tac g
+(* let observe_tac s tac g = *)
+(* begin try msgnl (Printer.pr_goal (sig_it g)) with _ -> assert false end; *)
+(* try let v = tac g in msgnl ((str s)++(str " ")++(str "finished")); v *)
+(* with e -> *)
+(* msgnl (str "observation "++str s++str " raised an exception"); raise e;; *)
let hyp_ids = List.map id_of_string
["x";"v";"k";"def";"p";"h";"n";"h'"; "anonymous"; "teq"; "rec_res";
@@ -199,27 +200,29 @@ let max_constr = lazy(constr_of_reference (Lazy.force max_ref))
let nat = lazy(coq_constant "nat")
let lt = lazy(coq_constant "lt")
-let mkCaseEq a =
+let mkCaseEq a : tactic =
(fun g ->
(* commentaire de Yves: on pourra avoir des problemes si
a n'est pas bien type dans l'environnement du but *)
- let type_of_a = (type_of (pf_env g) Evd.empty a) in
+ let type_of_a = pf_type_of g a in
(tclTHEN (generalize [mkApp(Lazy.force refl_equal, [| type_of_a; a|])])
(tclTHEN
(fun g2 ->
- change_in_concl None
- (pattern_occs [([2], a)] (pf_env g2) Evd.empty (pf_concl g2))
- g2)
+ change_in_concl None
+ (pattern_occs [([2], a)] (pf_env g2) Evd.empty (pf_concl g2))
+ g2)
(simplest_case a))) g);;
let rec mk_intros_and_continue (extra_eqn:bool)
cont_function (eqs:constr list) (expr:constr) g =
- let ids=ids_of_named_context (pf_hyps g) in
+ let ids = pf_ids_of_hyps g in
match kind_of_term expr with
- Lambda (n, _, b) ->
- let n1 = (match n with
- Name x -> x
- | Anonymous -> ano_id ) in
+ | Lambda (n, _, b) ->
+ let n1 =
+ match n with
+ Name x -> x
+ | Anonymous -> ano_id
+ in
let new_n = next_ident_away n1 ids in
tclTHEN (intro_using new_n)
(mk_intros_and_continue extra_eqn cont_function eqs
@@ -230,7 +233,7 @@ let rec mk_intros_and_continue (extra_eqn:bool)
tclTHEN (intro_using teq)
(cont_function (mkVar teq::eqs) expr) g
else
- cont_function eqs expr g;;
+ cont_function eqs expr g
let const_of_ref = function
ConstRef kn -> kn
@@ -241,8 +244,21 @@ let simpl_iter () =
(Lazy
{rBeta=true;rIota=true;rZeta= true; rDelta=false;
rConst = [ EvalConstRef (const_of_ref (Lazy.force iter_ref))]})
- onConcl;;
-
+ onConcl
+
+let tclUSER l g =
+ let b,l =
+ match l with
+ None -> true,[]
+ | Some l -> false,l
+ in
+ tclTHEN
+ (h_clear b l)
+ (* (tclIDTAC_MESSAGE (str "USER"++fnl())) *)
+ tclIDTAC
+ g
+
+
let list_rewrite (rev:bool) (eqs: constr list) =
tclREPEAT
(List.fold_right
@@ -263,7 +279,7 @@ let base_leaf (func:global_reference) eqs expr =
(tclTHEN (simplest_elim
(mkApp (Lazy.force gt_antirefl,
[| Lazy.force coq_O |])))
- default_auto)); tclIDTAC];
+ default_auto)); tclIDTAC ];
intros;
simpl_iter();
unfold_constr func;
@@ -360,50 +376,27 @@ let rec introduce_all_equalities func eqs values specs bound le_proofs
introduce_all_equalities func eqs values specs
(mkVar pmax) ((mkVar pmax)::le_proofs)
(heq::cond_eqs)] g;;
-
-let rec introduce_all_values func context_fn
- eqs proofs hrec args values specs =
- match args with
- [] ->
- tclTHENLIST
- [split(ImplicitBindings
- [context_fn (List.map mkVar (List.rev values))]);
- introduce_all_equalities func eqs
- (List.rev values) (List.rev specs) (Lazy.force coq_O) [] []]
- | arg::args ->
- (fun g ->
- let ids = ids_of_named_context (pf_hyps g) in
- let rec_res = next_ident_away rec_res_id ids in
- let ids = rec_res::ids in
- let hspec = next_ident_away hspec_id ids in
- let tac = introduce_all_values func context_fn eqs proofs
- hrec args
- (rec_res::values)(hspec::specs) in
- (tclTHENS
- (simplest_elim (mkApp(mkVar hrec, [|arg|])))
- [tclTHENLIST [intros_using [rec_res; hspec];
- tac]; tclIDTAC
-(* tclTHENLIST
- [list_rewrite true eqs;
- List.fold_right
- (fun proof tac ->
- tclORELSE
- (tclCOMPLETE
- (tclTHENLIST
- [e_resolve_constr proof;
- tclORELSE default_full_auto e_assumption]))
- tac)
- proofs
- (fun g ->
- (msgnl (str "complete proof failed for decreasing call");
- msgnl (Printer.pr_goal (sig_it g)); tclFAIL 0 "" g))]*)
-]) g)
-
+
+let string_match s =
+ try
+ for i = 0 to 3 do
+ if String.get s i <> String.get "Acc_" i then failwith ""
+ done;
+ with Invalid_argument _ -> failwith ""
-
-let rec new_introduce_all_values acc_inv func context_fn
+let retrieve_acc_var g =
+ (* Julien: I don't like this version .... *)
+ let hyps = pf_ids_of_hyps g in
+ map_succeed
+ (fun id ->
+ try
+ string_match (string_of_id id);
+ id
+ with _ -> failwith "")
+ hyps
+
+let rec introduce_all_values acc_inv func context_fn
eqs hrec args values specs =
- tclTRY
(match args with
[] ->
tclTHENLIST
@@ -417,7 +410,7 @@ let rec new_introduce_all_values acc_inv func context_fn
let rec_res = next_ident_away rec_res_id ids in
let ids = rec_res::ids in
let hspec = next_ident_away hspec_id ids in
- let tac = new_introduce_all_values acc_inv func context_fn eqs
+ let tac = introduce_all_values acc_inv func context_fn eqs
hrec args
(rec_res::values)(hspec::specs) in
(tclTHENS
@@ -428,7 +421,9 @@ let rec new_introduce_all_values acc_inv func context_fn
(apply (Lazy.force acc_inv))
[ h_assumption
;
- tclIDTAC
+ (fun g ->
+ tclUSER (Some (hrec::hspec::(retrieve_acc_var g)@specs)) g
+ )
]
)
]) g)
@@ -436,12 +431,12 @@ let rec new_introduce_all_values acc_inv func context_fn
)
-let new_rec_leaf acc_inv hrec (func:global_reference) eqs expr =
+let rec_leaf acc_inv hrec (func:global_reference) eqs expr =
match find_call_occs (mkVar (get_f (constr_of_reference func))) expr with
| context_fn, args ->
- new_introduce_all_values acc_inv func context_fn eqs hrec args [] []
+ introduce_all_values acc_inv func context_fn eqs hrec args [] []
-let rec new_proveterminate acc_inv (hrec:identifier) (* (proofs:constr list) *)
+let rec proveterminate acc_inv (hrec:identifier) (* (proofs:constr list) *)
(f_constr:constr) (func:global_reference) (eqs:constr list) (expr:constr) =
try
(* let _ = msgnl (str "entering proveterminate") in *)
@@ -457,7 +452,7 @@ try
v
)
(List.map (mk_intros_and_continue true
- (new_proveterminate acc_inv hrec f_constr func)
+ (proveterminate acc_inv hrec f_constr func)
eqs)
(Array.to_list l))
| _, _::_ ->
@@ -465,7 +460,7 @@ try
match find_call_occs f_constr expr with
_,[] -> base_leaf func eqs expr
| _, _:: _ ->
- new_rec_leaf acc_inv hrec func eqs expr
+ rec_leaf acc_inv hrec func eqs expr
)
)
| _ -> (match find_call_occs f_constr expr with
@@ -474,55 +469,28 @@ try
base_leaf func eqs expr
with e -> (msgerrnl (str "failure in base case");raise e ))
| _, _::_ ->
- new_rec_leaf acc_inv hrec func eqs expr) in
+ rec_leaf acc_inv hrec func eqs expr) in
(* let _ = msgnl(str "exiting proveterminate") in *)
v
with e ->
msgerrnl(str "failure in proveterminate");
-(* raise e *)
- tclIDTAC
+ raise e
let hyp_terminates func =
- let a_arrow_b = (arg_type (constr_of_reference func)) in
- let (_,a,b) = destProd a_arrow_b in
- let left=
- mkApp (Lazy.force iter,
- [|a_arrow_b ;(mkRel 3);
- (constr_of_reference func); (mkRel 1); (mkRel 6)|]) in
- let right= (mkRel 5) in
- let equality = mkApp(Lazy.force eq, [|b; left; right|]) in
- let result = (mkProd ((Name def_id) , a_arrow_b, equality)) in
- let cond = mkApp(Lazy.force lt, [|(mkRel 2); (mkRel 1)|]) in
- let nb_iter =
- mkApp(Lazy.force ex,
- [|Lazy.force nat;
- (mkLambda
- (Name
- p_id,
- Lazy.force nat,
- (mkProd (Name k_id, Lazy.force nat,
- mkArrow cond result))))|])in
- let value = mkApp(Lazy.force coq_sig,
- [|b;
- (mkLambda (Name v_id, b, nb_iter))|]) in
- mkProd ((Name x_id), a, value)
-
-
-let new_hyp_terminates func =
let a_arrow_b = arg_type (constr_of_reference func) in
let rev_args,b = decompose_prod a_arrow_b in
let left =
mkApp(Lazy.force iter,
Array.of_list
- (a_arrow_b:: mkRel 3::
+ (lift 5 a_arrow_b:: mkRel 3::
constr_of_reference func::mkRel 1::
List.rev (list_map_i (fun i _ -> mkRel (6+i)) 0 rev_args)
)
)
in
let right = mkRel 5 in
- let equality = mkApp(Lazy.force eq, [|b; left; right|]) in
- let result = (mkProd ((Name def_id) , a_arrow_b, equality)) in
+ let equality = mkApp(Lazy.force eq, [|lift 5 b; left; right|]) in
+ let result = (mkProd ((Name def_id) , lift 4 a_arrow_b, equality)) in
let cond = mkApp(Lazy.force lt, [|(mkRel 2); (mkRel 1)|]) in
let nb_iter =
mkApp(Lazy.force ex,
@@ -539,10 +507,16 @@ let new_hyp_terminates func =
compose_prod rev_args value
-let new_start input_type ids args_id relation rec_arg_num rec_arg_id tac : tactic =
+let start input_type ids args_id relation rec_arg_num rec_arg_id tac : tactic =
begin
fun g ->
let nargs = List.length args_id in
+ let pre_rec_args =
+ List.rev_map
+ mkVar (fst (list_chop (rec_arg_num - 1) args_id))
+ in
+ let relation = substl pre_rec_args relation in
+ let input_type = substl pre_rec_args input_type in
let wf_thm = next_ident_away (id_of_string ("wf_R")) ids in
let wf_rec_arg =
next_ident_away
@@ -562,83 +536,67 @@ let new_start input_type ids args_id relation rec_arg_num rec_arg_id tac : tacti
tclTHEN
(intros_using args_id)
(tclTHENS
- (assert_tac
- true (* the assert thm is in first subgoal *)
- (Name wf_rec_arg)
- (mkApp (Lazy.force acc_rel,[|input_type;relation;mkVar rec_arg_id|]))
- )
- [
- (* accesibility proof *)
- tclTHENS
- (assert_tac
- true
- (Name wf_thm)
- (mkApp (Lazy.force well_founded,[|input_type;relation|]))
- )
- [
- (* interactive proof of the well_foundness of the relation *)
- tclIDTAC;
- (* well_foundness -> Acc for any element *)
- h_apply ((mkApp(mkVar wf_thm,[|mkVar rec_arg_id |])),Rawterm.NoBindings)
- ]
- ;
- (* rest of the proof *)
- tclTHENSEQ
- [onNLastHyps (nargs+1)
- (fun (id,_,_) ->
- tclTHEN (generalize [mkVar id]) (h_clear false [id])
+ (observe_tac
+ "first assert"
+ (assert_tac
+ true (* the assert thm is in first subgoal *)
+ (Name wf_rec_arg)
+ (mkApp (Lazy.force acc_rel,
+ [|input_type;relation;mkVar rec_arg_id|])
+ )
+ )
+ )
+ [
+ (* accesibility proof *)
+ tclTHENS
+ (observe_tac
+ "second assert"
+ (assert_tac
+ true
+ (Name wf_thm)
+ (mkApp (Lazy.force well_founded,[|input_type;relation|]))
+ )
)
- ;
- h_fix (Some hrec) (nargs+1);
- intros_using args_id;
- intro_using wf_rec_arg;
- tac hrec acc_inv
- ]
- ]
+ [
+ (* interactive proof of the well_foundness of the relation *)
+ tclUSER None;
+ (* well_foundness -> Acc for any element *)
+ observe_tac
+ "apply wf_thm"
+ (h_apply ((mkApp(mkVar wf_thm,
+ [|mkVar rec_arg_id |])),Rawterm.NoBindings)
+ )
+ ]
+ ;
+ (* rest of the proof *)
+ tclTHENSEQ
+ [observe_tac "generalize"
+ (onNLastHyps (nargs+1)
+ (fun (id,_,_) ->
+ tclTHEN (generalize [mkVar id]) (h_clear false [id])
+ ))
+ ;
+ observe_tac "h_fix" (h_fix (Some hrec) (nargs+1));
+ intros_using args_id;
+ intro_using wf_rec_arg;
+ observe_tac "tac" (tac hrec acc_inv)
+ ]
+ ]
) g
end
-let start n_name input_type relation wf_thm =
- (fun g ->
-try
- let ids = ids_of_named_context (pf_hyps g) in
- let hrec = next_ident_away hrec_id (n_name::ids) in
- let wf_c = mkApp(Lazy.force well_founded_induction,
- [|input_type; relation; wf_thm|]) in
- let x = next_ident_away x_id (hrec::n_name::ids) in
- let v =
- (fun g ->
- let v =
- tclTHENLIST
- [intro_using x;
- general_elim (mkVar x, ImplicitBindings[]) (wf_c, ImplicitBindings[]);
- clear [x];
- intros_using [n_name; hrec]] g in
- v), hrec in
- v
-with e -> msgerrnl(str "error in start"); raise e);;
-
-(* let rec instantiate_lambda t = function *)
-(* | [] -> t *)
-(* | a::l -> let (bound_name, _, body) = destLambda t in *)
-(* (match bound_name with *)
-(* Name id -> instantiate_lambda (subst1 a body) l *)
-(* | Anonymous -> body) ;; *)
let rec instantiate_lambda t l =
match l with
| [] -> t
| a::l ->
let (bound_name, _, body) = destLambda t in
-(* (match bound_name with *)
-(* Name id -> instantiate_lambda (subst1 a body) l *)
-(* | Anonymous -> body)*)
instantiate_lambda (subst1 a body) l
;;
-let new_whole_start func input_type relation rec_arg_num : tactic =
+let whole_start func input_type relation rec_arg_num : tactic =
begin
fun g ->
let ids = ids_of_named_context (pf_hyps g) in
@@ -664,7 +622,7 @@ let new_whole_start func input_type relation rec_arg_num : tactic =
in
let rec_arg_id = List.nth n_ids (rec_arg_num - 1) in
let expr = instantiate_lambda func_body (mkVar f_id::(List.map mkVar n_ids)) in
- new_start
+ start
input_type
ids
n_ids
@@ -672,56 +630,35 @@ let new_whole_start func input_type relation rec_arg_num : tactic =
rec_arg_num
rec_arg_id
(fun hrec acc_inv g ->
- try
- (new_proveterminate
- acc_inv
- hrec
- (mkVar f_id)
- func
- []
- expr
- )
- g
- with e -> msgnl (str "debug : found an exception");raise e
+ (proveterminate
+ acc_inv
+ hrec
+ (mkVar f_id)
+ func
+ []
+ expr
+ )
+ g
)
g
end
-let new_com_terminate fonctional_ref input_type relation_ast rec_arg_num
+let com_terminate fonctional_ref input_type relation rec_arg_num
thm_name hook =
let (evmap, env) = Command.get_current_context() in
- let (relation:constr)= interp_constr evmap env relation_ast in
- (start_proof thm_name
- (Global, Proof Lemma) (Environ.named_context_val env)
- (new_hyp_terminates fonctional_ref) hook;
- by (new_whole_start fonctional_ref
- input_type relation rec_arg_num ));;
+ start_proof thm_name
+ (Global, Proof Lemma) (Environ.named_context_val env)
+ (hyp_terminates fonctional_ref) hook;
+ by (whole_start fonctional_ref
+ input_type relation rec_arg_num )
+
let ind_of_ref = function
| IndRef (ind,i) -> (ind,i)
| _ -> anomaly "IndRef expected"
-let (value_f:constr -> global_reference -> constr) =
- fun a fterm ->
- let d0 = dummy_loc in
- let x_id = x_id in
- let v_id = v_id in
- let value =
- RLambda
- (d0, Name x_id, RDynamic(d0, constr_in a),
- RCases
- (d0,None,
- [RApp(d0, RRef(d0,fterm), [RVar(d0, x_id)]),(Anonymous,None)],
- [d0, [v_id], [PatCstr(d0,(ind_of_ref
- (Lazy.force coq_sig_ref),1),
- [PatVar(d0, Name v_id);
- PatVar(d0, Anonymous)],
- Anonymous)],
- RVar(d0,v_id)])) in
- understand Evd.empty (Global.env()) value;;
-
let (value_f:constr list -> global_reference -> constr) =
fun al fterm ->
let d0 = dummy_loc in
@@ -967,25 +904,37 @@ let recursive_definition f type_of_f r rec_arg_num eq =
let env = push_rel (Name f,None,function_type) (Global.env()) in
let res_vars,eq' = decompose_prod (interp_constr Evd.empty env eq) in
let res =
+(* Pp.msgnl (str "res_var :=" ++ Printer.pr_lconstr_env (push_rel_context (List.map (function (x,t) -> (x,None,t)) res_vars) env) eq'); *)
+(* Pp.msgnl (str "rec_arg_num := " ++ str (string_of_int rec_arg_num)); *)
+(* Pp.msgnl (str "eq' := " ++ str (string_of_int rec_arg_num)); *)
match kind_of_term eq' with
| App(e,[|_;_;eq_fix|]) ->
mkLambda (Name f,function_type,compose_lam res_vars eq_fix)
- | _ -> failwith "Recursive Definition"
+ | _ -> failwith "Recursive Definition (res not eq)"
in
- let _,function_type_before_rec_arg = decompose_prod_n (rec_arg_num - 1) function_type in
+ let pre_rec_args,function_type_before_rec_arg = decompose_prod_n (rec_arg_num - 1) function_type in
let (_, rec_arg_type, _) = destProd function_type_before_rec_arg in
let arg_types = List.rev_map snd (fst (decompose_prod_n (List.length res_vars) function_type)) in
let equation_id = add_suffix f "_equation" in
let functional_id = add_suffix f "_F" in
let term_id = add_suffix f "_terminate" in
let functional_ref = declare_fun functional_id (IsDefinition Definition) res in
+(* let _ = Pp.msgnl (str "res := " ++ Printer.pr_lconstr res) in *)
+ let env_with_pre_rec_args = push_rel_context(List.map (function (x,t) -> (x,None,t)) pre_rec_args) env in
+ let relation =
+ interp_constr
+ Evd.empty
+ env_with_pre_rec_args
+ r
+ in
+(* let _ = Pp.msgnl (str "relation := " ++ Printer.pr_lconstr_env env_with_pre_rec_args relation) in *)
let hook _ _ =
let term_ref = Nametab.locate (make_short_qualid term_id) in
let f_ref = declare_f f (IsProof Lemma) arg_types term_ref in
(* let _ = message "start second proof" in *)
com_eqn equation_id functional_ref f_ref term_ref eq
in
- new_com_terminate functional_ref rec_arg_type r rec_arg_num term_id hook
+ com_terminate functional_ref rec_arg_type relation rec_arg_num term_id hook
;;
VERNAC COMMAND EXTEND RecursiveDefinition