diff options
| author |  Samuel Mimram <smimram@debian.org> | 2007-08-18 20:34:57 +0000 |
|---|---|---|
| committer | Samuel Mimram <smimram@debian.org> | 2007-08-18 20:34:57 +0000 |
| commit | 72b9a7df489ea47b3e5470741fd39f6100d31676 (patch) | |
| tree | 60108a573d2a80d2dd4e3833649890e32427ff8d | |
| parent | 55ce117e8083477593cf1ff2e51a3641c7973830 (diff) | |
Imported Upstream version 8.1.pl1+dfsgupstream/8.1.pl1+dfsg
128 files changed, 3643 insertions, 2657 deletions
@@ -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/sign.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 @@ -86,9 +86,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 \ @@ -119,6 +116,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 \ @@ -367,11 +367,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 \ lib/util.cmi 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 \ @@ -381,9 +381,9 @@ contrib/cc/ccproof.cmi: kernel/term.cmi kernel/names.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 \ @@ -403,8 +403,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 @@ -453,10 +453,10 @@ contrib/funind/functional_principles_types.cmi: kernel/term.cmi \ contrib/funind/indfun_common.cmi: kernel/term.cmi proofs/tacexpr.cmo \ pretyping/rawterm.cmi lib/pp.cmi kernel/names.cmi library/libnames.cmi \ kernel/entries.cmi library/decl_kinds.cmo -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 \ @@ -490,24 +490,22 @@ contrib/jprover/jlogic.cmi: contrib/jprover/jterm.cmi contrib/jprover/jterm.cmi: contrib/jprover/opname.cmi contrib/rtauto/refl_tauto.cmi: kernel/term.cmi proofs/tacmach.cmi \ proofs/proof_type.cmi contrib/rtauto/proof_search.cmi kernel/names.cmi -contrib/subtac/context.cmi: kernel/term.cmi kernel/names.cmi contrib/subtac/eterm.cmi: lib/util.cmi kernel/term.cmi proofs/tacmach.cmi \ kernel/names.cmi pretyping/evd.cmi -contrib/subtac/subtac.cmi: toplevel/vernacexpr.cmo lib/util.cmi contrib/subtac/subtac_cases.cmi: lib/util.cmi kernel/term.cmi \ pretyping/rawterm.cmi kernel/names.cmi pretyping/inductiveops.cmi \ pretyping/evd.cmi pretyping/evarutil.cmi kernel/environ.cmi \ - pretyping/coercion.cmi + pretyping/coercion.cmi pretyping/cases.cmi contrib/subtac/subtac_coercion.cmi: pretyping/coercion.cmi contrib/subtac/subtac_command.cmi: toplevel/vernacexpr.cmo \ interp/topconstr.cmi kernel/term.cmi pretyping/pretyping.cmi lib/pp.cmi \ kernel/names.cmi library/libnames.cmi pretyping/evd.cmi \ kernel/environ.cmi interp/constrintern.cmi contrib/subtac/subtac_errors.cmi: lib/util.cmi lib/pp.cmi -contrib/subtac/subtac_interp_fixpoint.cmi: lib/util.cmi interp/topconstr.cmi \ - lib/pp.cmi kernel/names.cmi library/libnames.cmi +contrib/subtac/subtac.cmi: toplevel/vernacexpr.cmo lib/util.cmi contrib/subtac/subtac_obligations.cmi: lib/util.cmi interp/topconstr.cmi \ - kernel/term.cmi proofs/proof_type.cmi kernel/names.cmi + kernel/term.cmi proofs/tacexpr.cmo proofs/proof_type.cmi lib/pp.cmi \ + kernel/names.cmi contrib/subtac/subtac_pretyping.cmi: interp/topconstr.cmi kernel/term.cmi \ kernel/sign.cmi pretyping/pretyping.cmi kernel/names.cmi \ library/global.cmi pretyping/evd.cmi kernel/environ.cmi @@ -563,6 +561,16 @@ 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 lib/pp.cmi proofs/pfedit.cmi \ + ide/ideutils.cmi ide/highlight.cmo ide/find_phrase.cmo \ + proofs/decl_mode.cmi config/coq_config.cmi 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 lib/pp.cmx proofs/pfedit.cmx \ + ide/ideutils.cmx ide/highlight.cmx ide/find_phrase.cmx \ + proofs/decl_mode.cmx config/coq_config.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 lib/system.cmi \ @@ -587,16 +595,6 @@ ide/coq.cmx: toplevel/vernacexpr.cmx toplevel/vernacentries.cmx \ config/coq_config.cmx toplevel/cerrors.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 lib/pp.cmi proofs/pfedit.cmi \ - ide/ideutils.cmi ide/highlight.cmo ide/find_phrase.cmo \ - proofs/decl_mode.cmi config/coq_config.cmi 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 lib/pp.cmx proofs/pfedit.cmx \ - ide/ideutils.cmx ide/highlight.cmx ide/find_phrase.cmx \ - proofs/decl_mode.cmx config/coq_config.cmx ide/coq_commands.cmx \ - ide/coq.cmx ide/command_windows.cmx ide/blaster_window.cmx ide/coqide.cmi ide/find_phrase.cmo: ide/preferences.cmi ide/ideutils.cmi ide/find_phrase.cmx: ide/preferences.cmx ide/ideutils.cmx ide/highlight.cmo: ide/ideutils.cmi @@ -779,6 +777,14 @@ 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/closure.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 \ @@ -793,14 +799,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 \ @@ -838,15 +836,15 @@ kernel/sign.cmo: lib/util.cmi kernel/term.cmi kernel/names.cmi \ kernel/sign.cmx: lib/util.cmx kernel/term.cmx kernel/names.cmx \ kernel/sign.cmi kernel/subtyping.cmo: lib/util.cmi kernel/univ.cmi kernel/typeops.cmi \ - kernel/term.cmi kernel/sign.cmi kernel/reduction.cmi kernel/names.cmi \ - kernel/modops.cmi kernel/mod_subst.cmi kernel/inductive.cmi \ - kernel/environ.cmi kernel/entries.cmi kernel/declarations.cmi \ - kernel/subtyping.cmi + kernel/term.cmi kernel/sign.cmi kernel/reduction.cmi kernel/pre_env.cmi \ + kernel/names.cmi kernel/modops.cmi kernel/mod_subst.cmi \ + kernel/inductive.cmi kernel/environ.cmi kernel/entries.cmi \ + kernel/declarations.cmi kernel/subtyping.cmi kernel/subtyping.cmx: lib/util.cmx kernel/univ.cmx kernel/typeops.cmx \ - kernel/term.cmx kernel/sign.cmx kernel/reduction.cmx kernel/names.cmx \ - kernel/modops.cmx kernel/mod_subst.cmx kernel/inductive.cmx \ - kernel/environ.cmx kernel/entries.cmx kernel/declarations.cmx \ - kernel/subtyping.cmi + kernel/term.cmx kernel/sign.cmx kernel/reduction.cmx kernel/pre_env.cmx \ + kernel/names.cmx kernel/modops.cmx kernel/mod_subst.cmx \ + kernel/inductive.cmx kernel/environ.cmx kernel/entries.cmx \ + kernel/declarations.cmx kernel/subtyping.cmi kernel/term.cmo: lib/util.cmi kernel/univ.cmi lib/pp.cmi kernel/names.cmi \ lib/hashcons.cmi kernel/esubst.cmi kernel/term.cmi kernel/term.cmx: lib/util.cmx kernel/univ.cmx lib/pp.cmx kernel/names.cmx \ @@ -901,10 +899,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 @@ -913,24 +911,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/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 \ @@ -963,6 +951,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 \ @@ -1045,6 +1035,14 @@ 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/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 @@ -1138,17 +1136,19 @@ parsing/g_tactic.cmx: lib/util.cmx interp/topconstr.cmx proofs/tacexpr.cmx \ pretyping/rawterm.cmx lib/pp.cmx parsing/pcoq.cmx kernel/names.cmx \ parsing/lexer.cmx interp/genarg.cmx parsing/g_vernac.cmo: toplevel/vernacexpr.cmo lib/util.cmi \ - interp/topconstr.cmi pretyping/recordops.cmi interp/ppextend.cmi \ - lib/pp.cmi parsing/pcoq.cmi lib/options.cmi kernel/names.cmi \ - library/nameops.cmi parsing/lexer.cmi library/goptions.cmi \ - interp/genarg.cmi parsing/g_constr.cmo parsing/extend.cmi \ - proofs/decl_mode.cmi library/decl_kinds.cmo toplevel/class.cmi + interp/topconstr.cmi pretyping/recordops.cmi pretyping/rawterm.cmi \ + interp/ppextend.cmi lib/pp.cmi parsing/pcoq.cmi lib/options.cmi \ + kernel/names.cmi library/nameops.cmi parsing/lexer.cmi \ + library/goptions.cmi interp/genarg.cmi parsing/g_constr.cmo \ + parsing/extend.cmi proofs/decl_mode.cmi library/decl_kinds.cmo \ + toplevel/class.cmi parsing/g_vernac.cmx: toplevel/vernacexpr.cmx lib/util.cmx \ - interp/topconstr.cmx pretyping/recordops.cmx interp/ppextend.cmx \ - lib/pp.cmx parsing/pcoq.cmx lib/options.cmx kernel/names.cmx \ - library/nameops.cmx parsing/lexer.cmx library/goptions.cmx \ - interp/genarg.cmx parsing/g_constr.cmx parsing/extend.cmx \ - proofs/decl_mode.cmx library/decl_kinds.cmx toplevel/class.cmx + interp/topconstr.cmx pretyping/recordops.cmx pretyping/rawterm.cmx \ + interp/ppextend.cmx lib/pp.cmx parsing/pcoq.cmx lib/options.cmx \ + kernel/names.cmx library/nameops.cmx parsing/lexer.cmx \ + library/goptions.cmx interp/genarg.cmx parsing/g_constr.cmx \ + parsing/extend.cmx proofs/decl_mode.cmx library/decl_kinds.cmx \ + toplevel/class.cmx parsing/g_xml.cmo: lib/util.cmi kernel/term.cmi proofs/tacexpr.cmo \ pretyping/rawterm.cmi lib/pp.cmi parsing/pcoq.cmi library/nametab.cmi \ kernel/names.cmi library/libnames.cmi pretyping/inductiveops.cmi \ @@ -2405,16 +2405,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 \ @@ -2479,6 +2469,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 \ @@ -2527,6 +2527,12 @@ contrib/cc/g_congruence.cmx: lib/util.cmx tactics/tactics.cmx \ tactics/tacticals.cmx tactics/tacinterp.cmx proofs/tacexpr.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 \ @@ -2541,12 +2547,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 @@ -2667,6 +2667,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 pretyping/reductionops.cmi \ @@ -2683,8 +2685,6 @@ contrib/dp/dp.cmx: lib/util.cmx pretyping/typing.cmx pretyping/termops.cmx \ library/global.cmx contrib/dp/fol.cmi pretyping/evd.cmx \ kernel/environ.cmx contrib/dp/dp_why.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 @@ -3017,38 +3017,6 @@ contrib/funind/functional_principles_types.cmx: lib/util.cmx \ kernel/environ.cmx kernel/entries.cmx library/declare.cmx \ kernel/declarations.cmx library/decl_kinds.cmx toplevel/command.cmx \ kernel/closure.cmx contrib/funind/functional_principles_types.cmi -contrib/funind/indfun.cmo: toplevel/vernacexpr.cmo lib/util.cmi \ - kernel/typeops.cmi interp/topconstr.cmi pretyping/termops.cmi \ - kernel/term.cmi tactics/tactics.cmi tactics/tacticals.cmi \ - proofs/tacmach.cmi tactics/tacinterp.cmi proofs/tacexpr.cmo \ - library/states.cmi kernel/sign.cmi contrib/recdef/recdef.cmo \ - contrib/funind/rawterm_to_relation.cmi pretyping/rawterm.cmi \ - parsing/printer.cmi parsing/ppconstr.cmi lib/pp.cmi lib/options.cmi \ - interp/notation.cmi kernel/names.cmi library/nameops.cmi \ - library/libnames.cmi contrib/funind/invfun.cmo pretyping/indrec.cmi \ - contrib/funind/indfun_common.cmi library/impargs.cmi \ - tactics/hiddentac.cmi library/global.cmi \ - contrib/funind/functional_principles_types.cmi \ - contrib/funind/functional_principles_proofs.cmi pretyping/evd.cmi \ - tactics/equality.cmi kernel/environ.cmi kernel/declarations.cmi \ - library/decl_kinds.cmo interp/constrintern.cmi interp/constrextern.cmi \ - toplevel/command.cmi toplevel/cerrors.cmi -contrib/funind/indfun.cmx: toplevel/vernacexpr.cmx lib/util.cmx \ - kernel/typeops.cmx interp/topconstr.cmx pretyping/termops.cmx \ - kernel/term.cmx tactics/tactics.cmx tactics/tacticals.cmx \ - proofs/tacmach.cmx tactics/tacinterp.cmx proofs/tacexpr.cmx \ - library/states.cmx kernel/sign.cmx contrib/recdef/recdef.cmx \ - contrib/funind/rawterm_to_relation.cmx pretyping/rawterm.cmx \ - parsing/printer.cmx parsing/ppconstr.cmx lib/pp.cmx lib/options.cmx \ - interp/notation.cmx kernel/names.cmx library/nameops.cmx \ - library/libnames.cmx contrib/funind/invfun.cmx pretyping/indrec.cmx \ - contrib/funind/indfun_common.cmx library/impargs.cmx \ - tactics/hiddentac.cmx library/global.cmx \ - contrib/funind/functional_principles_types.cmx \ - contrib/funind/functional_principles_proofs.cmx pretyping/evd.cmx \ - tactics/equality.cmx kernel/environ.cmx kernel/declarations.cmx \ - library/decl_kinds.cmx interp/constrintern.cmx interp/constrextern.cmx \ - toplevel/command.cmx toplevel/cerrors.cmx contrib/funind/indfun_common.cmo: lib/util.cmi pretyping/termops.cmi \ kernel/term.cmi library/summary.cmi proofs/refiner.cmi \ pretyping/reductionops.cmi pretyping/rawterm.cmi proofs/proof_type.cmi \ @@ -3097,6 +3065,38 @@ contrib/funind/indfun_main.cmx: toplevel/vernacinterp.cmx lib/util.cmx \ contrib/funind/functional_principles_types.cmx pretyping/evd.cmx \ parsing/egrammar.cmx interp/coqlib.cmx interp/constrintern.cmx \ toplevel/cerrors.cmx +contrib/funind/indfun.cmo: toplevel/vernacexpr.cmo lib/util.cmi \ + kernel/typeops.cmi interp/topconstr.cmi pretyping/termops.cmi \ + kernel/term.cmi tactics/tactics.cmi tactics/tacticals.cmi \ + proofs/tacmach.cmi tactics/tacinterp.cmi proofs/tacexpr.cmo \ + library/states.cmi kernel/sign.cmi contrib/recdef/recdef.cmo \ + contrib/funind/rawterm_to_relation.cmi pretyping/rawterm.cmi \ + parsing/printer.cmi parsing/ppconstr.cmi lib/pp.cmi lib/options.cmi \ + interp/notation.cmi kernel/names.cmi library/nameops.cmi \ + library/libnames.cmi contrib/funind/invfun.cmo pretyping/indrec.cmi \ + contrib/funind/indfun_common.cmi library/impargs.cmi \ + tactics/hiddentac.cmi library/global.cmi \ + contrib/funind/functional_principles_types.cmi \ + contrib/funind/functional_principles_proofs.cmi pretyping/evd.cmi \ + tactics/equality.cmi kernel/environ.cmi kernel/declarations.cmi \ + library/decl_kinds.cmo interp/constrintern.cmi interp/constrextern.cmi \ + toplevel/command.cmi toplevel/cerrors.cmi +contrib/funind/indfun.cmx: toplevel/vernacexpr.cmx lib/util.cmx \ + kernel/typeops.cmx interp/topconstr.cmx pretyping/termops.cmx \ + kernel/term.cmx tactics/tactics.cmx tactics/tacticals.cmx \ + proofs/tacmach.cmx tactics/tacinterp.cmx proofs/tacexpr.cmx \ + library/states.cmx kernel/sign.cmx contrib/recdef/recdef.cmx \ + contrib/funind/rawterm_to_relation.cmx pretyping/rawterm.cmx \ + parsing/printer.cmx parsing/ppconstr.cmx lib/pp.cmx lib/options.cmx \ + interp/notation.cmx kernel/names.cmx library/nameops.cmx \ + library/libnames.cmx contrib/funind/invfun.cmx pretyping/indrec.cmx \ + contrib/funind/indfun_common.cmx library/impargs.cmx \ + tactics/hiddentac.cmx library/global.cmx \ + contrib/funind/functional_principles_types.cmx \ + contrib/funind/functional_principles_proofs.cmx pretyping/evd.cmx \ + tactics/equality.cmx kernel/environ.cmx kernel/declarations.cmx \ + library/decl_kinds.cmx interp/constrintern.cmx interp/constrextern.cmx \ + toplevel/command.cmx toplevel/cerrors.cmx contrib/funind/invfun.cmo: toplevel/vernacentries.cmi lib/util.cmi \ pretyping/typing.cmi pretyping/termops.cmi kernel/term.cmi \ tactics/tauto.cmo tactics/tactics.cmi tactics/tacticals.cmi \ @@ -3141,6 +3141,16 @@ contrib/funind/merge.cmx: toplevel/vernacexpr.cmx lib/util.cmx \ kernel/inductive.cmx library/global.cmx pretyping/evd.cmx \ kernel/environ.cmx pretyping/detyping.cmx kernel/declarations.cmx \ interp/constrintern.cmx interp/constrextern.cmx toplevel/command.cmx +contrib/funind/rawtermops.cmo: lib/util.cmi kernel/term.cmi \ + pretyping/rawterm.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 kernel/term.cmx \ + pretyping/rawterm.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 \ pretyping/typing.cmi interp/topconstr.cmi pretyping/termops.cmi \ kernel/term.cmi tactics/tacinterp.cmi lib/system.cmi kernel/sign.cmi \ @@ -3165,16 +3175,6 @@ contrib/funind/rawterm_to_relation.cmx: toplevel/vernacexpr.cmx lib/util.cmx \ pretyping/detyping.cmx kernel/declarations.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 pretyping/rawterm.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 pretyping/rawterm.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 \ @@ -3371,6 +3371,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 kernel/typeops.cmi contrib/interface/translate.cmi \ pretyping/termops.cmi kernel/term.cmi proofs/tacmach.cmi \ @@ -3393,14 +3401,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 \ @@ -3508,33 +3508,35 @@ contrib/recdef/recdef.cmo: toplevel/vernacinterp.cmi \ kernel/typeops.cmi interp/topconstr.cmi pretyping/termops.cmi \ kernel/term.cmi tactics/tactics.cmi tactics/tacticals.cmi \ proofs/tactic_debug.cmi pretyping/tacred.cmi proofs/tacmach.cmi \ - tactics/tacinterp.cmi kernel/safe_typing.cmi pretyping/rawterm.cmi \ - proofs/proof_type.cmi parsing/printer.cmi pretyping/pretyping.cmi \ - parsing/ppconstr.cmi lib/pp.cmi proofs/pfedit.cmi parsing/pcoq.cmi \ - lib/options.cmi library/nametab.cmi kernel/names.cmi library/nameops.cmi \ - library/libnames.cmi library/lib.cmi tactics/hiddentac.cmi \ - library/global.cmi interp/genarg.cmi pretyping/evd.cmi \ - tactics/equality.cmi kernel/environ.cmi kernel/entries.cmi \ - tactics/elim.cmi parsing/egrammar.cmi tactics/eauto.cmi \ - library/declare.cmi kernel/declarations.cmi library/decl_kinds.cmo \ - interp/coqlib.cmi interp/constrintern.cmi toplevel/command.cmi \ - kernel/closure.cmi toplevel/cerrors.cmi tactics/auto.cmi + tactics/tacinterp.cmi kernel/safe_typing.cmi pretyping/reductionops.cmi \ + pretyping/rawterm.cmi proofs/proof_type.cmi parsing/printer.cmi \ + pretyping/pretyping.cmi parsing/ppconstr.cmi lib/pp.cmi proofs/pfedit.cmi \ + parsing/pcoq.cmi lib/options.cmi library/nametab.cmi kernel/names.cmi \ + library/nameops.cmi library/libnames.cmi library/lib.cmi \ + tactics/hiddentac.cmi library/global.cmi interp/genarg.cmi \ + pretyping/evd.cmi tactics/equality.cmi kernel/environ.cmi \ + kernel/entries.cmi tactics/elim.cmi parsing/egrammar.cmi \ + tactics/eauto.cmi library/declare.cmi kernel/declarations.cmi \ + library/decl_kinds.cmo interp/coqlib.cmi interp/constrintern.cmi \ + toplevel/command.cmi kernel/closure.cmi toplevel/cerrors.cmi \ + tactics/auto.cmi contrib/recdef/recdef.cmx: toplevel/vernacinterp.cmx \ toplevel/vernacentries.cmx lib/util.cmx pretyping/typing.cmx \ kernel/typeops.cmx interp/topconstr.cmx pretyping/termops.cmx \ kernel/term.cmx tactics/tactics.cmx tactics/tacticals.cmx \ proofs/tactic_debug.cmx pretyping/tacred.cmx proofs/tacmach.cmx \ - tactics/tacinterp.cmx kernel/safe_typing.cmx pretyping/rawterm.cmx \ - proofs/proof_type.cmx parsing/printer.cmx pretyping/pretyping.cmx \ - parsing/ppconstr.cmx lib/pp.cmx proofs/pfedit.cmx parsing/pcoq.cmx \ - lib/options.cmx library/nametab.cmx kernel/names.cmx library/nameops.cmx \ - library/libnames.cmx library/lib.cmx tactics/hiddentac.cmx \ - library/global.cmx interp/genarg.cmx pretyping/evd.cmx \ - tactics/equality.cmx kernel/environ.cmx kernel/entries.cmx \ - tactics/elim.cmx parsing/egrammar.cmx tactics/eauto.cmx \ - library/declare.cmx kernel/declarations.cmx library/decl_kinds.cmx \ - interp/coqlib.cmx interp/constrintern.cmx toplevel/command.cmx \ - kernel/closure.cmx toplevel/cerrors.cmx tactics/auto.cmx + tactics/tacinterp.cmx kernel/safe_typing.cmx pretyping/reductionops.cmx \ + pretyping/rawterm.cmx proofs/proof_type.cmx parsing/printer.cmx \ + pretyping/pretyping.cmx parsing/ppconstr.cmx lib/pp.cmx proofs/pfedit.cmx \ + parsing/pcoq.cmx lib/options.cmx library/nametab.cmx kernel/names.cmx \ + library/nameops.cmx library/libnames.cmx library/lib.cmx \ + tactics/hiddentac.cmx library/global.cmx interp/genarg.cmx \ + pretyping/evd.cmx tactics/equality.cmx kernel/environ.cmx \ + kernel/entries.cmx tactics/elim.cmx parsing/egrammar.cmx \ + tactics/eauto.cmx library/declare.cmx kernel/declarations.cmx \ + library/decl_kinds.cmx interp/coqlib.cmx interp/constrintern.cmx \ + toplevel/command.cmx kernel/closure.cmx toplevel/cerrors.cmx \ + tactics/auto.cmx contrib/ring/g_quote.cmo: lib/util.cmi tactics/tacinterp.cmi \ proofs/tacexpr.cmo contrib/ring/quote.cmo parsing/pptactic.cmi lib/pp.cmi \ parsing/pcoq.cmi interp/genarg.cmi parsing/egrammar.cmi \ @@ -3636,44 +3638,42 @@ contrib/rtauto/refl_tauto.cmx: lib/util.cmx pretyping/termops.cmx \ kernel/environ.cmx interp/coqlib.cmx kernel/closure.cmx \ contrib/rtauto/refl_tauto.cmi contrib/setoid_ring/newring.cmo: toplevel/vernacinterp.cmi lib/util.cmi \ - pretyping/typing.cmi kernel/typeops.cmi interp/topconstr.cmi \ - pretyping/termops.cmi kernel/term.cmi tactics/tactics.cmi \ - tactics/tacticals.cmi proofs/tacmach.cmi tactics/tacinterp.cmi \ - proofs/tacexpr.cmo library/summary.cmi tactics/setoid_replace.cmi \ - pretyping/retyping.cmi proofs/refiner.cmi pretyping/reductionops.cmi \ - pretyping/rawterm.cmi contrib/ring/quote.cmo proofs/proof_type.cmi \ - parsing/printer.cmi pretyping/pretyping.cmi parsing/pptactic.cmi \ - lib/pp.cmi parsing/pcoq.cmi library/nametab.cmi kernel/names.cmi \ - kernel/mod_subst.cmi library/libobject.cmi library/libnames.cmi \ - library/lib.cmi parsing/lexer.cmi library/global.cmi interp/genarg.cmi \ - pretyping/evd.cmi kernel/esubst.cmi kernel/environ.cmi kernel/entries.cmi \ + pretyping/typing.cmi interp/topconstr.cmi pretyping/termops.cmi \ + kernel/term.cmi tactics/tactics.cmi tactics/tacticals.cmi \ + proofs/tacmach.cmi tactics/tacinterp.cmi proofs/tacexpr.cmo \ + library/summary.cmi tactics/setoid_replace.cmi pretyping/retyping.cmi \ + proofs/refiner.cmi pretyping/reductionops.cmi pretyping/rawterm.cmi \ + contrib/ring/quote.cmo proofs/proof_type.cmi parsing/printer.cmi \ + pretyping/pretyping.cmi parsing/pptactic.cmi lib/pp.cmi parsing/pcoq.cmi \ + library/nametab.cmi kernel/names.cmi kernel/mod_subst.cmi \ + library/libobject.cmi library/libnames.cmi library/lib.cmi \ + parsing/lexer.cmi library/global.cmi interp/genarg.cmi pretyping/evd.cmi \ + kernel/esubst.cmi kernel/environ.cmi kernel/entries.cmi \ parsing/egrammar.cmi library/declare.cmi library/decl_kinds.cmo \ interp/coqlib.cmi interp/constrintern.cmi kernel/closure.cmi \ toplevel/cerrors.cmi contrib/setoid_ring/newring.cmx: toplevel/vernacinterp.cmx lib/util.cmx \ - pretyping/typing.cmx kernel/typeops.cmx interp/topconstr.cmx \ - pretyping/termops.cmx kernel/term.cmx tactics/tactics.cmx \ - tactics/tacticals.cmx proofs/tacmach.cmx tactics/tacinterp.cmx \ - proofs/tacexpr.cmx library/summary.cmx tactics/setoid_replace.cmx \ - pretyping/retyping.cmx proofs/refiner.cmx pretyping/reductionops.cmx \ - pretyping/rawterm.cmx contrib/ring/quote.cmx proofs/proof_type.cmx \ - parsing/printer.cmx pretyping/pretyping.cmx parsing/pptactic.cmx \ - lib/pp.cmx parsing/pcoq.cmx library/nametab.cmx kernel/names.cmx \ - kernel/mod_subst.cmx library/libobject.cmx library/libnames.cmx \ - library/lib.cmx parsing/lexer.cmx library/global.cmx interp/genarg.cmx \ - pretyping/evd.cmx kernel/esubst.cmx kernel/environ.cmx kernel/entries.cmx \ + pretyping/typing.cmx interp/topconstr.cmx pretyping/termops.cmx \ + kernel/term.cmx tactics/tactics.cmx tactics/tacticals.cmx \ + proofs/tacmach.cmx tactics/tacinterp.cmx proofs/tacexpr.cmx \ + library/summary.cmx tactics/setoid_replace.cmx pretyping/retyping.cmx \ + proofs/refiner.cmx pretyping/reductionops.cmx pretyping/rawterm.cmx \ + contrib/ring/quote.cmx proofs/proof_type.cmx parsing/printer.cmx \ + pretyping/pretyping.cmx parsing/pptactic.cmx lib/pp.cmx parsing/pcoq.cmx \ + library/nametab.cmx kernel/names.cmx kernel/mod_subst.cmx \ + library/libobject.cmx library/libnames.cmx library/lib.cmx \ + parsing/lexer.cmx library/global.cmx interp/genarg.cmx pretyping/evd.cmx \ + kernel/esubst.cmx kernel/environ.cmx kernel/entries.cmx \ parsing/egrammar.cmx library/declare.cmx library/decl_kinds.cmx \ interp/coqlib.cmx interp/constrintern.cmx kernel/closure.cmx \ toplevel/cerrors.cmx -contrib/subtac/context.cmo: kernel/term.cmi kernel/names.cmi \ - contrib/subtac/context.cmi -contrib/subtac/context.cmx: kernel/term.cmx kernel/names.cmx \ - contrib/subtac/context.cmi -contrib/subtac/eterm.cmo: lib/util.cmi kernel/term.cmi tactics/tacticals.cmi \ - lib/pp.cmi lib/options.cmi kernel/names.cmi pretyping/evd.cmi \ +contrib/subtac/eterm.cmo: lib/util.cmi pretyping/termops.cmi kernel/term.cmi \ + tactics/tacticals.cmi contrib/subtac/subtac_utils.cmi lib/pp.cmi \ + lib/options.cmi kernel/names.cmi library/global.cmi pretyping/evd.cmi \ pretyping/evarutil.cmi kernel/environ.cmi contrib/subtac/eterm.cmi -contrib/subtac/eterm.cmx: lib/util.cmx kernel/term.cmx tactics/tacticals.cmx \ - lib/pp.cmx lib/options.cmx kernel/names.cmx pretyping/evd.cmx \ +contrib/subtac/eterm.cmx: lib/util.cmx pretyping/termops.cmx kernel/term.cmx \ + tactics/tacticals.cmx contrib/subtac/subtac_utils.cmx lib/pp.cmx \ + lib/options.cmx kernel/names.cmx library/global.cmx pretyping/evd.cmx \ pretyping/evarutil.cmx kernel/environ.cmx contrib/subtac/eterm.cmi contrib/subtac/g_eterm.cmo: lib/util.cmi proofs/tacmach.cmi \ tactics/tacinterp.cmi proofs/tacexpr.cmo proofs/refiner.cmi \ @@ -3699,56 +3699,26 @@ contrib/subtac/g_subtac.cmx: toplevel/vernacinterp.cmx \ lib/pp.cmx parsing/pcoq.cmx lib/options.cmx kernel/names.cmx \ library/nameops.cmx library/libnames.cmx interp/genarg.cmx \ parsing/egrammar.cmx toplevel/cerrors.cmx -contrib/subtac/subtac.cmo: toplevel/vernacexpr.cmo lib/util.cmi \ - kernel/typeops.cmi kernel/type_errors.cmi pretyping/termops.cmi \ - kernel/term.cmi tactics/tacinterp.cmi proofs/tacexpr.cmo \ - contrib/subtac/subtac_utils.cmi contrib/subtac/subtac_pretyping.cmi \ - contrib/subtac/subtac_obligations.cmi contrib/subtac/subtac_errors.cmi \ - contrib/subtac/subtac_command.cmi contrib/subtac/subtac_coercion.cmi \ - kernel/sign.cmi pretyping/reductionops.cmi pretyping/recordops.cmi \ - pretyping/rawterm.cmi parsing/printer.cmi pretyping/pretype_errors.cmi \ - parsing/ppconstr.cmi lib/pp.cmi proofs/pfedit.cmi pretyping/pattern.cmi \ - lib/options.cmi library/nametab.cmi kernel/names.cmi library/library.cmi \ - library/libnames.cmi library/lib.cmi toplevel/himsg.cmi \ - library/global.cmi pretyping/evd.cmi pretyping/evarutil.cmi \ - pretyping/evarconv.cmi contrib/subtac/eterm.cmi kernel/environ.cmi \ - lib/dyn.cmi library/decl_kinds.cmo interp/coqlib.cmi \ - contrib/subtac/context.cmi toplevel/command.cmi pretyping/classops.cmi \ - toplevel/cerrors.cmi contrib/subtac/subtac.cmi -contrib/subtac/subtac.cmx: toplevel/vernacexpr.cmx lib/util.cmx \ - kernel/typeops.cmx kernel/type_errors.cmx pretyping/termops.cmx \ - kernel/term.cmx tactics/tacinterp.cmx proofs/tacexpr.cmx \ - contrib/subtac/subtac_utils.cmx contrib/subtac/subtac_pretyping.cmx \ - contrib/subtac/subtac_obligations.cmx contrib/subtac/subtac_errors.cmx \ - contrib/subtac/subtac_command.cmx contrib/subtac/subtac_coercion.cmx \ - kernel/sign.cmx pretyping/reductionops.cmx pretyping/recordops.cmx \ - pretyping/rawterm.cmx parsing/printer.cmx pretyping/pretype_errors.cmx \ - parsing/ppconstr.cmx lib/pp.cmx proofs/pfedit.cmx pretyping/pattern.cmx \ - lib/options.cmx library/nametab.cmx kernel/names.cmx library/library.cmx \ - library/libnames.cmx library/lib.cmx toplevel/himsg.cmx \ - library/global.cmx pretyping/evd.cmx pretyping/evarutil.cmx \ - pretyping/evarconv.cmx contrib/subtac/eterm.cmx kernel/environ.cmx \ - lib/dyn.cmx library/decl_kinds.cmx interp/coqlib.cmx \ - contrib/subtac/context.cmx toplevel/command.cmx pretyping/classops.cmx \ - toplevel/cerrors.cmx contrib/subtac/subtac.cmi contrib/subtac/subtac_cases.cmo: lib/util.cmi kernel/typeops.cmi \ kernel/type_errors.cmi pretyping/termops.cmi kernel/term.cmi \ contrib/subtac/subtac_utils.cmi kernel/sign.cmi pretyping/retyping.cmi \ - pretyping/reductionops.cmi pretyping/rawterm.cmi parsing/printer.cmi \ - pretyping/pretype_errors.cmi lib/pp.cmi kernel/names.cmi \ - library/nameops.cmi pretyping/inductiveops.cmi kernel/inductive.cmi \ - library/global.cmi pretyping/evd.cmi pretyping/evarutil.cmi \ - pretyping/evarconv.cmi kernel/environ.cmi kernel/declarations.cmi \ - pretyping/coercion.cmi kernel/closure.cmi contrib/subtac/subtac_cases.cmi + pretyping/reductionops.cmi kernel/reduction.cmi pretyping/rawterm.cmi \ + parsing/printer.cmi pretyping/pretype_errors.cmi lib/pp.cmi \ + kernel/names.cmi library/nameops.cmi pretyping/inductiveops.cmi \ + kernel/inductive.cmi library/global.cmi pretyping/evd.cmi \ + pretyping/evarutil.cmi pretyping/evarconv.cmi kernel/environ.cmi \ + kernel/declarations.cmi pretyping/coercion.cmi kernel/closure.cmi \ + pretyping/cases.cmi contrib/subtac/subtac_cases.cmi contrib/subtac/subtac_cases.cmx: lib/util.cmx kernel/typeops.cmx \ kernel/type_errors.cmx pretyping/termops.cmx kernel/term.cmx \ contrib/subtac/subtac_utils.cmx kernel/sign.cmx pretyping/retyping.cmx \ - pretyping/reductionops.cmx pretyping/rawterm.cmx parsing/printer.cmx \ - pretyping/pretype_errors.cmx lib/pp.cmx kernel/names.cmx \ - library/nameops.cmx pretyping/inductiveops.cmx kernel/inductive.cmx \ - library/global.cmx pretyping/evd.cmx pretyping/evarutil.cmx \ - pretyping/evarconv.cmx kernel/environ.cmx kernel/declarations.cmx \ - pretyping/coercion.cmx kernel/closure.cmx contrib/subtac/subtac_cases.cmi + pretyping/reductionops.cmx kernel/reduction.cmx pretyping/rawterm.cmx \ + parsing/printer.cmx pretyping/pretype_errors.cmx lib/pp.cmx \ + kernel/names.cmx library/nameops.cmx pretyping/inductiveops.cmx \ + kernel/inductive.cmx library/global.cmx pretyping/evd.cmx \ + pretyping/evarutil.cmx pretyping/evarconv.cmx kernel/environ.cmx \ + kernel/declarations.cmx pretyping/coercion.cmx kernel/closure.cmx \ + pretyping/cases.cmx contrib/subtac/subtac_cases.cmi contrib/subtac/subtac_coercion.cmo: lib/util.cmi pretyping/typing.cmi \ kernel/typeops.cmi pretyping/termops.cmi kernel/term.cmi \ contrib/subtac/subtac_utils.cmi contrib/subtac/subtac_errors.cmi \ @@ -3757,8 +3727,8 @@ contrib/subtac/subtac_coercion.cmo: lib/util.cmi pretyping/typing.cmi \ pretyping/pretype_errors.cmi lib/pp.cmi kernel/names.cmi \ library/nameops.cmi library/global.cmi pretyping/evd.cmi \ pretyping/evarutil.cmi pretyping/evarconv.cmi contrib/subtac/eterm.cmi \ - kernel/environ.cmi interp/coqlib.cmi contrib/subtac/context.cmi \ - pretyping/classops.cmi contrib/subtac/subtac_coercion.cmi + kernel/environ.cmi interp/coqlib.cmi pretyping/classops.cmi \ + contrib/subtac/subtac_coercion.cmi contrib/subtac/subtac_coercion.cmx: lib/util.cmx pretyping/typing.cmx \ kernel/typeops.cmx pretyping/termops.cmx kernel/term.cmx \ contrib/subtac/subtac_utils.cmx contrib/subtac/subtac_errors.cmx \ @@ -3767,8 +3737,8 @@ contrib/subtac/subtac_coercion.cmx: lib/util.cmx pretyping/typing.cmx \ pretyping/pretype_errors.cmx lib/pp.cmx kernel/names.cmx \ library/nameops.cmx library/global.cmx pretyping/evd.cmx \ pretyping/evarutil.cmx pretyping/evarconv.cmx contrib/subtac/eterm.cmx \ - kernel/environ.cmx interp/coqlib.cmx contrib/subtac/context.cmx \ - pretyping/classops.cmx contrib/subtac/subtac_coercion.cmi + kernel/environ.cmx interp/coqlib.cmx pretyping/classops.cmx \ + contrib/subtac/subtac_coercion.cmi contrib/subtac/subtac_command.cmo: toplevel/vernacexpr.cmo lib/util.cmi \ pretyping/typing.cmi interp/topconstr.cmi pretyping/termops.cmi \ kernel/term.cmi tactics/tactics.cmi tactics/tacticals.cmi \ @@ -3811,48 +3781,76 @@ contrib/subtac/subtac_errors.cmo: lib/util.cmi parsing/printer.cmi lib/pp.cmi \ contrib/subtac/subtac_errors.cmi contrib/subtac/subtac_errors.cmx: lib/util.cmx parsing/printer.cmx lib/pp.cmx \ contrib/subtac/subtac_errors.cmi -contrib/subtac/subtac_interp_fixpoint.cmo: lib/util.cmi kernel/typeops.cmi \ - kernel/type_errors.cmi interp/topconstr.cmi pretyping/termops.cmi \ - kernel/term.cmi contrib/subtac/subtac_utils.cmi \ - contrib/subtac/subtac_errors.cmi contrib/subtac/subtac_coercion.cmi \ - kernel/sign.cmi pretyping/reductionops.cmi pretyping/recordops.cmi \ - pretyping/rawterm.cmi parsing/printer.cmi pretyping/pretype_errors.cmi \ - parsing/ppconstr.cmi lib/pp.cmi pretyping/pattern.cmi kernel/names.cmi \ - library/nameops.cmi library/libnames.cmi library/global.cmi \ +contrib/subtac/subtac.cmo: toplevel/vernacexpr.cmo lib/util.cmi \ + kernel/typeops.cmi kernel/type_errors.cmi pretyping/termops.cmi \ + kernel/term.cmi tactics/tacinterp.cmi proofs/tacexpr.cmo \ + contrib/subtac/subtac_utils.cmi contrib/subtac/subtac_pretyping.cmi \ + contrib/subtac/subtac_errors.cmi contrib/subtac/subtac_command.cmi \ + contrib/subtac/subtac_coercion.cmi kernel/sign.cmi \ + pretyping/reductionops.cmi pretyping/recordops.cmi pretyping/rawterm.cmi \ + parsing/printer.cmi pretyping/pretype_errors.cmi parsing/ppconstr.cmi \ + lib/pp.cmi proofs/pfedit.cmi pretyping/pattern.cmi lib/options.cmi \ + library/nametab.cmi kernel/names.cmi library/library.cmi \ + library/libnames.cmi library/lib.cmi toplevel/himsg.cmi \ + library/global.cmi pretyping/evd.cmi pretyping/evarutil.cmi \ + pretyping/evarconv.cmi contrib/subtac/eterm.cmi kernel/environ.cmi \ + lib/dyn.cmi pretyping/detyping.cmi library/decl_kinds.cmo \ + interp/coqlib.cmi toplevel/command.cmi pretyping/classops.cmi \ + toplevel/cerrors.cmi pretyping/cases.cmi contrib/subtac/subtac.cmi +contrib/subtac/subtac.cmx: toplevel/vernacexpr.cmx lib/util.cmx \ + kernel/typeops.cmx kernel/type_errors.cmx pretyping/termops.cmx \ + kernel/term.cmx tactics/tacinterp.cmx proofs/tacexpr.cmx \ + contrib/subtac/subtac_utils.cmx contrib/subtac/subtac_pretyping.cmx \ + contrib/subtac/subtac_errors.cmx contrib/subtac/subtac_command.cmx \ + contrib/subtac/subtac_coercion.cmx kernel/sign.cmx \ + pretyping/reductionops.cmx pretyping/recordops.cmx pretyping/rawterm.cmx \ + parsing/printer.cmx pretyping/pretype_errors.cmx parsing/ppconstr.cmx \ + lib/pp.cmx proofs/pfedit.cmx pretyping/pattern.cmx lib/options.cmx \ + library/nametab.cmx kernel/names.cmx library/library.cmx \ + library/libnames.cmx library/lib.cmx toplevel/himsg.cmx \ + library/global.cmx pretyping/evd.cmx pretyping/evarutil.cmx \ + pretyping/evarconv.cmx contrib/subtac/eterm.cmx kernel/environ.cmx \ + lib/dyn.cmx pretyping/detyping.cmx library/decl_kinds.cmx \ + interp/coqlib.cmx toplevel/command.cmx pretyping/classops.cmx \ + toplevel/cerrors.cmx pretyping/cases.cmx contrib/subtac/subtac.cmi +contrib/subtac/subtac_obligations.cmo: lib/util.cmi kernel/term.cmi \ + tactics/tacinterp.cmi proofs/tacexpr.cmo library/summary.cmi \ + contrib/subtac/subtac_utils.cmi proofs/refiner.cmi \ + pretyping/reductionops.cmi proofs/proof_type.cmi parsing/ppconstr.cmi \ + lib/pp.cmi proofs/pfedit.cmi lib/options.cmi kernel/names.cmi \ + library/libobject.cmi library/libnames.cmi library/lib.cmi \ + library/global.cmi pretyping/evd.cmi kernel/entries.cmi \ + library/declare.cmi library/decl_kinds.cmo toplevel/command.cmi \ + tactics/auto.cmi contrib/subtac/subtac_obligations.cmi +contrib/subtac/subtac_obligations.cmx: lib/util.cmx kernel/term.cmx \ + tactics/tacinterp.cmx proofs/tacexpr.cmx library/summary.cmx \ + contrib/subtac/subtac_utils.cmx proofs/refiner.cmx \ + pretyping/reductionops.cmx proofs/proof_type.cmx parsing/ppconstr.cmx \ + lib/pp.cmx proofs/pfedit.cmx lib/options.cmx kernel/names.cmx \ + library/libobject.cmx library/libnames.cmx library/lib.cmx \ + library/global.cmx pretyping/evd.cmx kernel/entries.cmx \ + library/declare.cmx library/decl_kinds.cmx toplevel/command.cmx \ + tactics/auto.cmx contrib/subtac/subtac_obligations.cmi +contrib/subtac/subtac_pretyping_F.cmo: lib/util.cmi kernel/typeops.cmi \ + kernel/type_errors.cmi pretyping/termops.cmi kernel/term.cmi \ + contrib/subtac/subtac_cases.cmi kernel/sign.cmi pretyping/retyping.cmi \ + pretyping/reductionops.cmi pretyping/recordops.cmi pretyping/rawterm.cmi \ + pretyping/pretyping.cmi pretyping/pretype_errors.cmi lib/pp.cmi \ + pretyping/pattern.cmi kernel/names.cmi library/nameops.cmi \ + library/libnames.cmi pretyping/inductiveops.cmi kernel/inductive.cmi \ pretyping/evd.cmi pretyping/evarutil.cmi pretyping/evarconv.cmi \ - contrib/subtac/eterm.cmi kernel/environ.cmi lib/dyn.cmi interp/coqlib.cmi \ - contrib/subtac/context.cmi pretyping/classops.cmi \ - contrib/subtac/subtac_interp_fixpoint.cmi -contrib/subtac/subtac_interp_fixpoint.cmx: lib/util.cmx kernel/typeops.cmx \ - kernel/type_errors.cmx interp/topconstr.cmx pretyping/termops.cmx \ - kernel/term.cmx contrib/subtac/subtac_utils.cmx \ - contrib/subtac/subtac_errors.cmx contrib/subtac/subtac_coercion.cmx \ - kernel/sign.cmx pretyping/reductionops.cmx pretyping/recordops.cmx \ - pretyping/rawterm.cmx parsing/printer.cmx pretyping/pretype_errors.cmx \ - parsing/ppconstr.cmx lib/pp.cmx pretyping/pattern.cmx kernel/names.cmx \ - library/nameops.cmx library/libnames.cmx library/global.cmx \ + kernel/environ.cmi lib/dyn.cmi kernel/declarations.cmi \ + pretyping/coercion.cmi pretyping/classops.cmi +contrib/subtac/subtac_pretyping_F.cmx: lib/util.cmx kernel/typeops.cmx \ + kernel/type_errors.cmx pretyping/termops.cmx kernel/term.cmx \ + contrib/subtac/subtac_cases.cmx kernel/sign.cmx pretyping/retyping.cmx \ + pretyping/reductionops.cmx pretyping/recordops.cmx pretyping/rawterm.cmx \ + pretyping/pretyping.cmx pretyping/pretype_errors.cmx lib/pp.cmx \ + pretyping/pattern.cmx kernel/names.cmx library/nameops.cmx \ + library/libnames.cmx pretyping/inductiveops.cmx kernel/inductive.cmx \ pretyping/evd.cmx pretyping/evarutil.cmx pretyping/evarconv.cmx \ - contrib/subtac/eterm.cmx kernel/environ.cmx lib/dyn.cmx interp/coqlib.cmx \ - contrib/subtac/context.cmx pretyping/classops.cmx \ - contrib/subtac/subtac_interp_fixpoint.cmi -contrib/subtac/subtac_obligations.cmo: lib/util.cmi pretyping/termops.cmi \ - kernel/term.cmi library/summary.cmi contrib/subtac/subtac_utils.cmi \ - proofs/refiner.cmi pretyping/reductionops.cmi proofs/proof_type.cmi \ - parsing/ppconstr.cmi lib/pp.cmi proofs/pfedit.cmi lib/options.cmi \ - kernel/names.cmi library/libobject.cmi library/libnames.cmi \ - library/global.cmi pretyping/evd.cmi kernel/environ.cmi \ - kernel/entries.cmi library/declare.cmi library/decl_kinds.cmo \ - toplevel/command.cmi tactics/auto.cmi \ - contrib/subtac/subtac_obligations.cmi -contrib/subtac/subtac_obligations.cmx: lib/util.cmx pretyping/termops.cmx \ - kernel/term.cmx library/summary.cmx contrib/subtac/subtac_utils.cmx \ - proofs/refiner.cmx pretyping/reductionops.cmx proofs/proof_type.cmx \ - parsing/ppconstr.cmx lib/pp.cmx proofs/pfedit.cmx lib/options.cmx \ - kernel/names.cmx library/libobject.cmx library/libnames.cmx \ - library/global.cmx pretyping/evd.cmx kernel/environ.cmx \ - kernel/entries.cmx library/declare.cmx library/decl_kinds.cmx \ - toplevel/command.cmx tactics/auto.cmx \ - contrib/subtac/subtac_obligations.cmi + kernel/environ.cmx lib/dyn.cmx kernel/declarations.cmx \ + pretyping/coercion.cmx pretyping/classops.cmx contrib/subtac/subtac_pretyping.cmo: toplevel/vernacexpr.cmo lib/util.cmi \ kernel/typeops.cmi kernel/type_errors.cmi interp/topconstr.cmi \ pretyping/termops.cmi kernel/term.cmi contrib/subtac/subtac_utils.cmi \ @@ -3864,8 +3862,8 @@ contrib/subtac/subtac_pretyping.cmo: toplevel/vernacexpr.cmo lib/util.cmi \ pretyping/pattern.cmi kernel/names.cmi library/nameops.cmi \ library/libnames.cmi library/global.cmi pretyping/evd.cmi \ pretyping/evarutil.cmi pretyping/evarconv.cmi contrib/subtac/eterm.cmi \ - kernel/environ.cmi lib/dyn.cmi interp/coqlib.cmi \ - contrib/subtac/context.cmi interp/constrintern.cmi pretyping/classops.cmi \ + kernel/environ.cmi lib/dyn.cmi interp/coqlib.cmi interp/constrintern.cmi \ + toplevel/command.cmi pretyping/classops.cmi \ contrib/subtac/subtac_pretyping.cmi contrib/subtac/subtac_pretyping.cmx: toplevel/vernacexpr.cmx lib/util.cmx \ kernel/typeops.cmx kernel/type_errors.cmx interp/topconstr.cmx \ @@ -3878,29 +3876,9 @@ contrib/subtac/subtac_pretyping.cmx: toplevel/vernacexpr.cmx lib/util.cmx \ pretyping/pattern.cmx kernel/names.cmx library/nameops.cmx \ library/libnames.cmx library/global.cmx pretyping/evd.cmx \ pretyping/evarutil.cmx pretyping/evarconv.cmx contrib/subtac/eterm.cmx \ - kernel/environ.cmx lib/dyn.cmx interp/coqlib.cmx \ - contrib/subtac/context.cmx interp/constrintern.cmx pretyping/classops.cmx \ + kernel/environ.cmx lib/dyn.cmx interp/coqlib.cmx interp/constrintern.cmx \ + toplevel/command.cmx pretyping/classops.cmx \ contrib/subtac/subtac_pretyping.cmi -contrib/subtac/subtac_pretyping_F.cmo: lib/util.cmi kernel/typeops.cmi \ - kernel/type_errors.cmi pretyping/termops.cmi kernel/term.cmi \ - contrib/subtac/subtac_cases.cmi kernel/sign.cmi pretyping/retyping.cmi \ - pretyping/reductionops.cmi pretyping/recordops.cmi pretyping/rawterm.cmi \ - pretyping/pretyping.cmi pretyping/pretype_errors.cmi lib/pp.cmi \ - pretyping/pattern.cmi kernel/names.cmi library/nameops.cmi \ - library/libnames.cmi pretyping/inductiveops.cmi kernel/inductive.cmi \ - pretyping/evd.cmi pretyping/evarutil.cmi pretyping/evarconv.cmi \ - kernel/environ.cmi lib/dyn.cmi kernel/declarations.cmi \ - pretyping/coercion.cmi pretyping/classops.cmi -contrib/subtac/subtac_pretyping_F.cmx: lib/util.cmx kernel/typeops.cmx \ - kernel/type_errors.cmx pretyping/termops.cmx kernel/term.cmx \ - contrib/subtac/subtac_cases.cmx kernel/sign.cmx pretyping/retyping.cmx \ - pretyping/reductionops.cmx pretyping/recordops.cmx pretyping/rawterm.cmx \ - pretyping/pretyping.cmx pretyping/pretype_errors.cmx lib/pp.cmx \ - pretyping/pattern.cmx kernel/names.cmx library/nameops.cmx \ - library/libnames.cmx pretyping/inductiveops.cmx kernel/inductive.cmx \ - pretyping/evd.cmx pretyping/evarutil.cmx pretyping/evarconv.cmx \ - kernel/environ.cmx lib/dyn.cmx kernel/declarations.cmx \ - pretyping/coercion.cmx pretyping/classops.cmx contrib/subtac/subtac_utils.cmo: lib/util.cmi interp/topconstr.cmi \ pretyping/termops.cmi kernel/term.cmi tactics/tactics.cmi \ tactics/tacticals.cmi proofs/tacexpr.cmo kernel/reduction.cmi \ @@ -3921,18 +3899,12 @@ contrib/subtac/subtac_utils.cmx: lib/util.cmx interp/topconstr.cmx \ pretyping/evarutil.cmx kernel/entries.cmx library/decl_kinds.cmx \ interp/coqlib.cmx interp/constrextern.cmx toplevel/command.cmx \ contrib/subtac/subtac_utils.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 kernel/typeops.cmi pretyping/termops.cmi kernel/term.cmi \ pretyping/reductionops.cmi parsing/printer.cmi lib/pp.cmi \ @@ -3951,21 +3923,27 @@ 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 \ - proofs/redexpr.cmi pretyping/rawterm.cmi parsing/printer.cmi lib/pp.cmi \ - kernel/names.cmi library/libnames.cmi pretyping/inductiveops.cmi \ - kernel/inductive.cmi pretyping/evd.cmi pretyping/evarutil.cmi \ - kernel/environ.cmi kernel/conv_oracle.cmi contrib/xml/acic.cmo \ + pretyping/rawterm.cmi parsing/printer.cmi lib/pp.cmi kernel/names.cmi \ + library/libnames.cmi pretyping/inductiveops.cmi kernel/inductive.cmi \ + pretyping/evd.cmi pretyping/evarutil.cmi kernel/environ.cmi \ + kernel/closure.cmi contrib/xml/acic.cmo \ contrib/xml/doubleTypeInference.cmi contrib/xml/doubleTypeInference.cmx: lib/util.cmx contrib/xml/unshare.cmx \ kernel/typeops.cmx pretyping/termops.cmx kernel/term.cmx \ pretyping/retyping.cmx pretyping/reductionops.cmx kernel/reduction.cmx \ - proofs/redexpr.cmx pretyping/rawterm.cmx parsing/printer.cmx lib/pp.cmx \ - kernel/names.cmx library/libnames.cmx pretyping/inductiveops.cmx \ - kernel/inductive.cmx pretyping/evd.cmx pretyping/evarutil.cmx \ - kernel/environ.cmx kernel/conv_oracle.cmx contrib/xml/acic.cmx \ + pretyping/rawterm.cmx parsing/printer.cmx lib/pp.cmx kernel/names.cmx \ + library/libnames.cmx pretyping/inductiveops.cmx kernel/inductive.cmx \ + pretyping/evd.cmx pretyping/evarutil.cmx kernel/environ.cmx \ + kernel/closure.cmx contrib/xml/acic.cmx \ contrib/xml/doubleTypeInference.cmi contrib/xml/proof2aproof.cmo: lib/util.cmi contrib/xml/unshare.cmi \ pretyping/termops.cmi kernel/term.cmi parsing/tactic_printer.cmi \ @@ -3991,30 +3969,28 @@ 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/typeops.cmi kernel/term.cmi \ proofs/tacmach.cmi pretyping/recordops.cmi proofs/proof_trees.cmi \ - contrib/xml/proof2aproof.cmo proofs/pfedit.cmi library/nametab.cmi \ - kernel/names.cmi library/library.cmi library/libobject.cmi \ - library/libnames.cmi library/lib.cmi parsing/lexer.cmi \ - pretyping/inductiveops.cmi kernel/inductive.cmi library/global.cmi \ - pretyping/evd.cmi pretyping/evarutil.cmi kernel/environ.cmi \ - library/declare.cmi kernel/declarations.cmi library/decl_kinds.cmo \ - config/coq_config.cmi contrib/xml/cic2acic.cmo contrib/xml/acic2Xml.cmo \ - contrib/xml/acic.cmo contrib/xml/xmlcommand.cmi + contrib/xml/proof2aproof.cmo lib/pp.cmi proofs/pfedit.cmi \ + library/nametab.cmi kernel/names.cmi library/library.cmi \ + library/libobject.cmi library/libnames.cmi library/lib.cmi \ + parsing/lexer.cmi pretyping/inductiveops.cmi kernel/inductive.cmi \ + library/global.cmi pretyping/evd.cmi pretyping/evarutil.cmi \ + kernel/environ.cmi library/declare.cmi kernel/declarations.cmi \ + library/decl_kinds.cmo config/coq_config.cmi contrib/xml/cic2acic.cmo \ + contrib/xml/acic2Xml.cmo contrib/xml/acic.cmo contrib/xml/xmlcommand.cmi contrib/xml/xmlcommand.cmx: contrib/xml/xml.cmx toplevel/vernac.cmx \ lib/util.cmx contrib/xml/unshare.cmx kernel/typeops.cmx kernel/term.cmx \ proofs/tacmach.cmx pretyping/recordops.cmx proofs/proof_trees.cmx \ - contrib/xml/proof2aproof.cmx proofs/pfedit.cmx library/nametab.cmx \ - kernel/names.cmx library/library.cmx library/libobject.cmx \ - library/libnames.cmx library/lib.cmx parsing/lexer.cmx \ - pretyping/inductiveops.cmx kernel/inductive.cmx library/global.cmx \ - pretyping/evd.cmx pretyping/evarutil.cmx kernel/environ.cmx \ - library/declare.cmx kernel/declarations.cmx library/decl_kinds.cmx \ - config/coq_config.cmx contrib/xml/cic2acic.cmx contrib/xml/acic2Xml.cmx \ - contrib/xml/acic.cmx contrib/xml/xmlcommand.cmi + contrib/xml/proof2aproof.cmx lib/pp.cmx proofs/pfedit.cmx \ + library/nametab.cmx kernel/names.cmx library/library.cmx \ + library/libobject.cmx library/libnames.cmx library/lib.cmx \ + parsing/lexer.cmx pretyping/inductiveops.cmx kernel/inductive.cmx \ + library/global.cmx pretyping/evd.cmx pretyping/evarutil.cmx \ + kernel/environ.cmx library/declare.cmx kernel/declarations.cmx \ + library/decl_kinds.cmx config/coq_config.cmx contrib/xml/cic2acic.cmx \ + contrib/xml/acic2Xml.cmx contrib/xml/acic.cmx contrib/xml/xmlcommand.cmi contrib/xml/xmlentries.cmo: contrib/xml/xmlcommand.cmi \ toplevel/vernacinterp.cmi lib/util.cmi lib/pp.cmi parsing/pcoq.cmi \ parsing/lexer.cmi interp/genarg.cmi parsing/extend.cmi \ @@ -4023,16 +3999,10 @@ 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 -doc/refman/euclid.cmo: doc/refman/euclid.cmi -doc/refman/euclid.cmx: doc/refman/euclid.cmi -doc/refman/heapsort.cmo: doc/refman/heapsort.cmi -doc/refman/heapsort.cmx: doc/refman/heapsort.cmi +contrib/xml/xml.cmo: contrib/xml/xml.cmi +contrib/xml/xml.cmx: contrib/xml/xml.cmi ide/utils/config_file.cmo: ide/utils/config_file.cmi ide/utils/config_file.cmx: ide/utils/config_file.cmi -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_html_config.cmo: ide/utils/configwin_types.cmo \ ide/utils/configwin_messages.cmo ide/utils/configwin_ihm.cmo \ ide/utils/config_file.cmi @@ -4043,6 +4013,10 @@ ide/utils/configwin_ihm.cmo: ide/utils/okey.cmi ide/utils/configwin_types.cmo \ ide/utils/configwin_messages.cmo ide/utils/config_file.cmi ide/utils/configwin_ihm.cmx: ide/utils/okey.cmx ide/utils/configwin_types.cmx \ ide/utils/configwin_messages.cmx ide/utils/config_file.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/configwin_keys.cmo \ ide/utils/config_file.cmi ide/utils/configwin_types.cmx: ide/utils/configwin_keys.cmx \ @@ -4180,38 +4154,39 @@ tools/coq_makefile.cmx: tools/coq-tex.cmo: tools/coq-tex.cmx: coq_fix_code.o: kernel/byterun/coq_fix_code.c \ - /usr/local/lib/ocaml/caml/config.h \ - /usr/local/lib/ocaml/caml/compatibility.h \ - /usr/local/lib/ocaml/caml/misc.h /usr/local/lib/ocaml/caml/config.h \ - /usr/local/lib/ocaml/caml/mlvalues.h /usr/local/lib/ocaml/caml/misc.h \ - /usr/local/lib/ocaml/caml/fail.h /usr/local/lib/ocaml/caml/mlvalues.h \ - /usr/local/lib/ocaml/caml/memory.h kernel/byterun/coq_instruct.h \ + /usr/lib/ocaml/3.09.2/caml/config.h \ + /usr/lib/ocaml/3.09.2/caml/compatibility.h \ + /usr/lib/ocaml/3.09.2/caml/misc.h /usr/lib/ocaml/3.09.2/caml/config.h \ + /usr/lib/ocaml/3.09.2/caml/mlvalues.h /usr/lib/ocaml/3.09.2/caml/misc.h \ + /usr/lib/ocaml/3.09.2/caml/fail.h /usr/lib/ocaml/3.09.2/caml/mlvalues.h \ + /usr/lib/ocaml/3.09.2/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 \ - /usr/local/lib/ocaml/caml/mlvalues.h \ - /usr/local/lib/ocaml/caml/compatibility.h \ - /usr/local/lib/ocaml/caml/config.h /usr/local/lib/ocaml/caml/misc.h \ - /usr/local/lib/ocaml/caml/alloc.h /usr/local/lib/ocaml/caml/mlvalues.h \ - kernel/byterun/coq_instruct.h kernel/byterun/coq_fix_code.h \ - kernel/byterun/coq_memory.h /usr/local/lib/ocaml/caml/config.h \ - /usr/local/lib/ocaml/caml/fail.h /usr/local/lib/ocaml/caml/misc.h \ - /usr/local/lib/ocaml/caml/memory.h kernel/byterun/coq_values.h \ - kernel/byterun/coq_jumptbl.h + /usr/lib/ocaml/3.09.2/caml/mlvalues.h \ + /usr/lib/ocaml/3.09.2/caml/compatibility.h \ + /usr/lib/ocaml/3.09.2/caml/config.h /usr/lib/ocaml/3.09.2/caml/misc.h \ + /usr/lib/ocaml/3.09.2/caml/alloc.h \ + /usr/lib/ocaml/3.09.2/caml/mlvalues.h kernel/byterun/coq_instruct.h \ + kernel/byterun/coq_fix_code.h kernel/byterun/coq_memory.h \ + /usr/lib/ocaml/3.09.2/caml/config.h /usr/lib/ocaml/3.09.2/caml/fail.h \ + /usr/lib/ocaml/3.09.2/caml/misc.h /usr/lib/ocaml/3.09.2/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 \ - /usr/local/lib/ocaml/caml/mlvalues.h \ - /usr/local/lib/ocaml/caml/compatibility.h \ - /usr/local/lib/ocaml/caml/config.h /usr/local/lib/ocaml/caml/misc.h \ - /usr/local/lib/ocaml/caml/alloc.h /usr/local/lib/ocaml/caml/mlvalues.h \ - kernel/byterun/coq_instruct.h kernel/byterun/coq_fix_code.h \ - kernel/byterun/coq_memory.h /usr/local/lib/ocaml/caml/config.h \ - /usr/local/lib/ocaml/caml/fail.h /usr/local/lib/ocaml/caml/misc.h \ - /usr/local/lib/ocaml/caml/memory.h kernel/byterun/coq_interp.h + /usr/lib/ocaml/3.09.2/caml/mlvalues.h \ + /usr/lib/ocaml/3.09.2/caml/compatibility.h \ + /usr/lib/ocaml/3.09.2/caml/config.h /usr/lib/ocaml/3.09.2/caml/misc.h \ + /usr/lib/ocaml/3.09.2/caml/alloc.h \ + /usr/lib/ocaml/3.09.2/caml/mlvalues.h kernel/byterun/coq_instruct.h \ + kernel/byterun/coq_fix_code.h kernel/byterun/coq_memory.h \ + /usr/lib/ocaml/3.09.2/caml/config.h /usr/lib/ocaml/3.09.2/caml/fail.h \ + /usr/lib/ocaml/3.09.2/caml/misc.h /usr/lib/ocaml/3.09.2/caml/memory.h \ + kernel/byterun/coq_interp.h coq_values.o: kernel/byterun/coq_values.c kernel/byterun/coq_fix_code.h \ - /usr/local/lib/ocaml/caml/mlvalues.h \ - /usr/local/lib/ocaml/caml/compatibility.h \ - /usr/local/lib/ocaml/caml/config.h /usr/local/lib/ocaml/caml/misc.h \ + /usr/lib/ocaml/3.09.2/caml/mlvalues.h \ + /usr/lib/ocaml/3.09.2/caml/compatibility.h \ + /usr/lib/ocaml/3.09.2/caml/config.h /usr/lib/ocaml/3.09.2/caml/misc.h \ kernel/byterun/coq_instruct.h kernel/byterun/coq_memory.h \ - /usr/local/lib/ocaml/caml/config.h /usr/local/lib/ocaml/caml/fail.h \ - /usr/local/lib/ocaml/caml/mlvalues.h /usr/local/lib/ocaml/caml/misc.h \ - /usr/local/lib/ocaml/caml/memory.h kernel/byterun/coq_values.h \ - /usr/local/lib/ocaml/caml/alloc.h + /usr/lib/ocaml/3.09.2/caml/config.h /usr/lib/ocaml/3.09.2/caml/fail.h \ + /usr/lib/ocaml/3.09.2/caml/mlvalues.h /usr/lib/ocaml/3.09.2/caml/misc.h \ + /usr/lib/ocaml/3.09.2/caml/memory.h kernel/byterun/coq_values.h \ + /usr/lib/ocaml/3.09.2/caml/alloc.h diff --git a/.depend.coq b/.depend.coq index e2fa8ff5..f8b4cd6c 100644 --- a/.depend.coq +++ b/.depend.coq @@ -364,8 +364,12 @@ contrib/field/LegacyField_Tactic.vo: contrib/field/LegacyField_Tactic.v theories contrib/field/LegacyField.vo: contrib/field/LegacyField.v contrib/field/LegacyField_Compl.vo contrib/field/LegacyField_Theory.vo contrib/field/LegacyField_Tactic.vo contrib/fourier/Fourier_util.vo: contrib/fourier/Fourier_util.v theories/Reals/Rbase.vo contrib/fourier/Fourier.vo: contrib/fourier/Fourier.v contrib/ring/quote.cmo contrib/ring/ring.cmo contrib/fourier/fourier.cmo contrib/fourier/fourierR.cmo contrib/field/field.cmo contrib/fourier/Fourier_util.vo contrib/field/LegacyField.vo theories/Reals/DiscrR.vo -contrib/subtac/FixSub.vo: contrib/subtac/FixSub.v theories/Init/Wf.vo theories/Arith/Wf_nat.vo theories/Arith/Lt.vo -contrib/subtac/Utils.vo: contrib/subtac/Utils.v +contrib/subtac/SubtacTactics.vo: contrib/subtac/SubtacTactics.v theories/Logic/Eqdep.vo +contrib/subtac/Heq.vo: contrib/subtac/Heq.v theories/Logic/JMeq.vo +contrib/subtac/Utils.vo: contrib/subtac/Utils.v contrib/subtac/SubtacTactics.vo theories/Bool/Sumbool.vo theories/Logic/ProofIrrelevance.vo contrib/subtac/Heq.vo +contrib/subtac/FixSub.vo: contrib/subtac/FixSub.v theories/Init/Wf.vo contrib/subtac/Utils.vo theories/Arith/Wf_nat.vo theories/Arith/Lt.vo +contrib/subtac/Subtac.vo: contrib/subtac/Subtac.v contrib/subtac/Utils.vo contrib/subtac/FixSub.vo +contrib/subtac/FunctionalExtensionality.vo: contrib/subtac/FunctionalExtensionality.v contrib/subtac/Utils.vo contrib/subtac/FixSub.vo contrib/rtauto/Bintree.vo: contrib/rtauto/Bintree.v theories/Lists/List.vo theories/NArith/BinPos.vo contrib/rtauto/Rtauto.vo: contrib/rtauto/Rtauto.v theories/Lists/List.vo contrib/rtauto/Bintree.vo theories/Bool/Bool.vo theories/NArith/BinPos.vo contrib/recdef/Recdef.vo: contrib/recdef/Recdef.v theories/Arith/Compare_dec.vo theories/Arith/Wf_nat.vo @@ -1,3 +1,24 @@ +Changes from V8.1 to V8.1pl1 +============================ + +Bug fixes + +- Many bugs have been fixed (cf coq-bugs web page) + +Tactics + +- All known failures of ROmega have been fixed. It should now be a + faithful and quicker replacement for Omega (except when nat parts + are involved). ROmega and Omega now handle <->. + +Libraries + +- Better computational behavior of some constants (eq_nat_dec and + le_lt_dec more efficient, Z_lt_le_dec and Positive_as_OT.compare + transparent) [exceptionally source of incompatibilities]. +- Loading FSets/FMap used to open unwanted scopes of integer datatypes + (see bug #1347). These scopes may need to be manually opened now. + Changes from V8.1gamma to V8.1 ============================== @@ -7,7 +28,7 @@ Bug fixes Tactics -- New tactic ring, ring_simplify and new tactic field now able to manage +- New tactics ring, ring_simplify and new tactic field now able to manage power to a positive integer constant. Tactic ring on Z and R, and field on R manage power (may lead to incompatibilities with V8.1gamma). - Tactic field_simplify now applicable in hypotheses. @@ -6,7 +6,7 @@ # # GNU Lesser General Public License Version 2.1 # ####################################################################### -# $Id: Makefile 9606 2007-02-07 12:21:01Z notin $ +# $Id: Makefile 10014 2007-07-17 15:14:39Z notin $ # Makefile for Coq @@ -42,7 +42,10 @@ help: # build and install the three subsystems: coq, coqide, pcoq -world: revision coq coqide pcoq +world: depend dependcoq + $(MAKE) worldnodep + +worldnodep: revision coq coqide pcoq install: install-coq install-coqide install-pcoq #install-manpages: install-coq-manpages install-pcoq-manpages @@ -245,8 +248,6 @@ NEWRINGCMO=\ contrib/setoid_ring/newring.cmo DPCMO=contrib/dp/dp_why.cmo contrib/dp/dp.cmo contrib/dp/g_dp.cmo -# contrib/dp/dp_simplify.cmo contrib/dp/dp_zenon.cmo contrib/dp/dp_cvcl.cmo \ -# contrib/dp/dp_sorts.cmo FIELDCMO=\ contrib/field/field.cmo @@ -303,11 +304,10 @@ CCCMO=contrib/cc/ccalgo.cmo contrib/cc/ccproof.cmo contrib/cc/cctac.cmo \ contrib/cc/g_congruence.cmo SUBTACCMO=contrib/subtac/subtac_utils.cmo contrib/subtac/eterm.cmo \ - contrib/subtac/g_eterm.cmo contrib/subtac/context.cmo \ + contrib/subtac/g_eterm.cmo \ contrib/subtac/subtac_errors.cmo contrib/subtac/subtac_coercion.cmo \ contrib/subtac/subtac_obligations.cmo contrib/subtac/subtac_cases.cmo \ contrib/subtac/subtac_pretyping_F.cmo contrib/subtac/subtac_pretyping.cmo \ - contrib/subtac/subtac_interp_fixpoint.cmo \ contrib/subtac/subtac_command.cmo contrib/subtac/subtac.cmo \ contrib/subtac/g_subtac.cmo @@ -376,9 +376,7 @@ kernel/copcodes.ml: kernel/byterun/coq_instruct.h kernel/byterun/coq_instruct.h | \ awk -f kernel/make-opcodes > kernel/copcodes.ml -bytecompfile : kernel/byterun/coq_jumptbl.h kernel/copcodes.ml - -beforedepend:: bytecompfile +BEFOREDEPEND+= kernel/byterun/coq_jumptbl.h kernel/copcodes.ml clean :: rm -f kernel/byterun/coq_jumptbl.h kernel/copcodes.ml @@ -450,7 +448,7 @@ scripts/tolink.ml: Makefile $(HIDE)echo "let core_objs = \""$(OBJSCMO)"\"" >> $@ $(HIDE)echo "let ide = \""$(COQIDECMO)"\"" >> $@ -beforedepend:: scripts/tolink.ml +BEFOREDEPEND+= scripts/tolink.ml # coqc @@ -614,9 +612,9 @@ COQIDECMO=ide/utils/okey.cmo ide/utils/config_file.cmo \ COQIDECMX=$(COQIDECMO:.cmo=.cmx) COQIDEFLAGS=-thread -I +lablgtk2 -beforedepend:: ide/config_lexer.ml ide/find_phrase.ml ide/highlight.ml -beforedepend:: ide/config_parser.mli ide/config_parser.ml -beforedepend:: ide/utf8_convert.ml +BEFOREDEPEND+= ide/config_lexer.ml ide/find_phrase.ml ide/highlight.ml +BEFOREDEPEND+= ide/config_parser.mli ide/config_parser.ml +BEFOREDEPEND+= ide/utf8_convert.ml COQIDEVO=ide/utf8.vo @@ -1077,7 +1075,8 @@ JPROVERVO= CCVO= -SUBTACVO=contrib/subtac/Utils.vo contrib/subtac/FixSub.vo contrib/subtac/Subtac.vo \ +SUBTACVO=contrib/subtac/SubtacTactics.vo contrib/subtac/Heq.vo \ + contrib/subtac/Utils.vo contrib/subtac/FixSub.vo contrib/subtac/Subtac.vo \ contrib/subtac/FunctionalExtensionality.vo RTAUTOVO = \ @@ -1169,7 +1168,7 @@ $(COQDEP): $(COQDEPCMO) $(SHOW)'OCAMLC -o $@' $(HIDE)$(OCAMLC) $(BYTEFLAGS) -o $@ unix.cma $(COQDEPCMO) $(OSDEPLIBS) -beforedepend:: tools/coqdep_lexer.ml $(COQDEP) +BEFOREDEPEND+= tools/coqdep_lexer.ml $(COQDEP) GALLINACMO=tools/gallina_lexer.cmo tools/gallina.cmo @@ -1177,7 +1176,7 @@ $(GALLINA): $(GALLINACMO) $(SHOW)'OCAMLC -o $@' $(HIDE)$(OCAMLC) $(BYTEFLAGS) -o $@ $(GALLINACMO) -beforedepend:: tools/gallina_lexer.ml +BEFOREDEPEND+= tools/gallina_lexer.ml $(COQMAKEFILE): tools/coq_makefile.cmo $(SHOW)'OCAMLC -o $@' @@ -1187,13 +1186,13 @@ $(COQTEX): tools/coq-tex.cmo $(SHOW)'OCAMLC -o $@' $(HIDE)$(OCAMLC) $(BYTEFLAGS) -o $@ str.cma tools/coq-tex.cmo -beforedepend:: tools/coqwc.ml +BEFOREDEPEND+= tools/coqwc.ml $(COQWC): tools/coqwc.cmo $(SHOW)'OCAMLC -o $@' $(HIDE)$(OCAMLC) $(BYTEFLAGS) -o $@ tools/coqwc.cmo -beforedepend:: tools/coqdoc/pretty.ml tools/coqdoc/index.ml +BEFOREDEPEND+= tools/coqdoc/pretty.ml tools/coqdoc/index.ml COQDOCCMO=$(CONFIG) tools/coqdoc/cdglobals.cmo tools/coqdoc/alpha.cmo \ tools/coqdoc/index.cmo tools/coqdoc/output.cmo \ @@ -1233,14 +1232,16 @@ archclean:: ########################################################################### COQINSTALLPREFIX= +OLDROOT= + # Can be changed for a local installation (to make packages). # You must NOT put a "/" at the end (Cygnus for win32 does not like "//"). -FULLBINDIR=$(COQINSTALLPREFIX)$(BINDIR) -FULLCOQLIB=$(COQINSTALLPREFIX)$(COQLIB) -FULLMANDIR=$(COQINSTALLPREFIX)$(MANDIR) -FULLEMACSLIB=$(COQINSTALLPREFIX)$(EMACSLIB) -FULLCOQDOCDIR=$(COQINSTALLPREFIX)$(COQDOCDIR) +FULLBINDIR=$(BINDIR:"$(OLDROOT)%="$(COQINSTALLPREFIX)%) +FULLCOQLIB=$(COQLIB:"$(OLDROOT)%="$(COQINSTALLPREFIX)%) +FULLMANDIR=$(MANDIR:"$(OLDROOT)%="$(COQINSTALLPREFIX)%) +FULLEMACSLIB=$(EMACSLIB:"$(OLDROOT)%="$(COQINSTALLPREFIX)%) +FULLCOQDOCDIR=$(COQDOCDIR:"$(OLDROOT)%="$(COQINSTALLPREFIX)%) install-coq: install-binaries install-library install-coq-info install-coqlight: install-binaries install-library-light @@ -1499,9 +1500,9 @@ ML4FILES +=parsing/g_minicoq.ml4 \ parsing/g_decl_mode.ml4 -# beforedepend:: $(GRAMMARCMO) +# BEFOREDEPEND+= $(GRAMMARCMO) -# beforedepend:: parsing/pcoq.ml parsing/extend.ml +# BEFOREDEPEND+= parsing/pcoq.ml parsing/extend.ml # File using pa_ifdef and only necessary for parsing ml files @@ -1652,6 +1653,9 @@ archclean:: $(SHOW)'OCAMLC4 $<' $(HIDE)$(OCAMLC) $(BYTEFLAGS) -pp "$(CAMLP4O) $(CAMLP4EXTENDFLAGS) `$(CAMLP4DEPS) $<` $(CAMLP4COMPAT) -impl" -c -impl $< +%.ml: %.ml4 + $(CAMLP4O) $(CAMLP4EXTENDFLAGS) pa_ifdef.cmo pr_o.cmo `$(CAMLP4DEPS) $<` $(CAMLP4COMPAT) -impl $< > $@ || rm -f $@ + #.v.vo: # $(BOOTCOQTOP) -compile $* @@ -1713,9 +1717,11 @@ cleanconfig:: # Dependencies ########################################################################### +.PHONY: alldepend dependcoq scratchdepend + alldepend: depend dependcoq -dependcoq:: beforedepend +dependcoq: $(COQDEP) -coqlib . -R theories Coq -R contrib Coq $(COQINCLUDES) \ $(ALLFSETS:.vo=.v) $(ALLREALS:.vo=.v) $(ALLVO:.vo=.v) > .depend.coq @@ -1724,7 +1730,7 @@ dependcoq:: beforedepend # by making scratchdepend, one gets dependencies OK for .ml files and # .ml4 files not using fancy parsers. This is sufficient to get beforedepend # and depend targets successfully built -scratchdepend:: dependp4 +scratchdepend: dependp4 $(OCAMLDEP) $(DEPFLAGS) */*.mli */*/*.mli */*.ml */*/*.ml > .depend -$(MAKE) -k -f Makefile.dep $(ML4FILESML) $(OCAMLDEP) $(DEPFLAGS) */*.mli */*/*.mli */*.ml */*/*.ml > .depend @@ -1737,18 +1743,17 @@ scratchdepend:: dependp4 ML4FILESML = $(ML4FILES:.ml4=.ml) # Expresses dependencies of the .ml4 files w.r.t their grammars -dependp4:: + +.PHONY: dependp4 +dependp4: $(ML4FILES) rm -f .depend.camlp4 for f in $(ML4FILES); do \ printf "%s" `dirname $$f`/`basename $$f .ml4`".ml: " >> .depend.camlp4; \ echo `$(CAMLP4DEPS) $$f` >> .depend.camlp4; \ done -# Produce the .ml files using Makefile.dep -ml4filesml:: .depend.camlp4 - $(MAKE) -f Makefile.dep $(ML4FILESML) - -depend: beforedepend dependp4 ml4filesml +.PHONY: depend +depend: $(BEFOREDEPEND) dependp4 $(ML4FILESML) # 1. We express dependencies of the .ml files w.r.t their grammars # 2. Then we are able to produce the .ml files using Makefile.dep # 3. We compute the dependencies inside the .ml files using ocamldep @@ -1761,7 +1766,7 @@ depend: beforedepend dependp4 ml4filesml echo `$(CAMLP4DEPS) $$f` >> .depend; \ done # 5. We express dependencies of .o files - $(CC) -MM $(CINCLUDES) kernel/byterun/*.c >> .depend + $(CC) -I $(CAMLHLIB) -MM kernel/byterun/*.c >> .depend # 6. Finally, we erase the generated .ml files rm -f $(ML4FILESML) # 7. Since .depend contains correct dependencies .depend.devel can be deleted @@ -1782,6 +1787,7 @@ devel: -include .depend -include .depend.coq +-include .depend.camlp4 clean:: find . -name "\.#*" -exec rm -f {} \; @@ -68,11 +68,7 @@ BUGS REPORT. Send your bug reports by filling a form at - http://coq.inria.fr/bin/coq-bugs - - or by E-mail to - - coq-bugs@coq.inria.fr + http://logical.futurs.inria.fr/coq-bugs To be effective, bug reports should mention the Caml version used to compile and run Coq, the Coq version (coqtop -v), the configuration @@ -36,8 +36,6 @@ COMPILATION. - Windows cvs client (very useful if you have access to the Coq archive). - If you are lost, you could find help at: coq-bugs@pauillac.inria.fr. - Good luck :-) The Coq Team. @@ -6,8 +6,8 @@ # ################################## -VERSION=8.1 -DATE="Feb. 2007" +VERSION=8.1pl1 +DATE="Jul. 2007" # a local which command for sh which () { @@ -386,30 +386,34 @@ esac # lablgtk2 and CoqIDE -if [ "$coqide_spec" = "no" ] ; then -if test -x "${CAMLLIB}/lablgtk2" ; then - if grep -q -w convert_with_fallback "${CAMLLIB}/lablgtk2/glib.mli" ; then - if test -f "${CAMLLIB}/threads/threads.cmxa" ; then - echo "LablGtk2 found, native threads: native CoqIde will be available" - COQIDE=opt; - else - echo "LablGtk2 found, no native threads: bytecode CoqIde will be available" - COQIDE=byte - fi - if grep "class view " "${CAMLLIB}/lablgtk2/gText.mli" | grep -q "\[>" ; then - LABLGTKGE26=yes; - else - LABLGTKGE26=no - fi; - else - echo "LablGtk2 found but too old: CoqIde will not be available" - COQIDE=no; - fi -else +# -byte-only should imply -coqide byte, unless the user decides otherwise + +if [ "$best_compiler" = "byte" -a "$coqide_spec" = "no" ]; then + coqide_spec=yes + COQIDE=byte +fi + +# Which coqide is asked ? which one is possible ? + +if [ "$coqide_spec" = "yes" -a "$COQIDE" = "no" ]; then + echo "CoqIde disabled as requested" +elif [ ! -x "${CAMLLIB}/lablgtk2" ]; then echo "LablGtk2 not found: CoqIde will not be available" COQIDE=no +elif [ -z "`grep -w convert_with_fallback ${CAMLLIB}/lablgtk2/glib.mli`" ]; then + echo "LablGtk2 found but too old: CoqIde will not be available" + COQIDE=no; +elif [ "$coqide_spec" = "yes" -a "$COQIDE" = "byte" ]; then + echo "LablGtk2 found, bytecode CoqIde will be used as requested" + COQIDE=byte +elif [ ! -f "${CAMLLIB}/threads/threads.cmxa" ]; then + echo "LablGtk2 found, no native threads: bytecode CoqIde will be available" + COQIDE=byte +else + echo "LablGtk2 found, native threads: native CoqIde will be available" + COQIDE=opt fi -fi + # Tell on windows if ocaml understands cygwin or windows path formats @@ -748,15 +752,17 @@ if test "$coq_debug_flag" = "-g" ; then chmod a-w,a+x $OCAMLDEBUGCOQ fi -################################################## -# Fixing lablgtk types +#################################################### +# Fixing lablgtk types (before/after 2.6.0) #################################################### -if [ "$LABLGTKGE26" = "yes" ] ; then - cp -f ide/undo_lablgtk_ge26.mli ide/undo.mli -else - cp -f ide/undo_lablgtk_lt26.mli ide/undo.mli -fi +if [ ! "$COQIDE" = "no" ]; then + if grep "class view " "$CAMLLIB/lablgtk2/gText.mli" | grep -q "\[>" ; then + cp -f ide/undo_lablgtk_ge26.mli ide/undo.mli + else + cp -f ide/undo_lablgtk_lt26.mli ide/undo.mli + fi +fi ################################################## # The end @@ -767,4 +773,4 @@ echo echo "*Warning* To compile the system for a new architecture" echo " don't forget to do a 'make archclean' before './configure'." -# $Id: configure 9637 2007-02-10 08:32:28Z notin $ +# $Id: configure 10039 2007-07-20 22:04:33Z notin $ diff --git a/contrib/cc/ccproof.ml b/contrib/cc/ccproof.ml index 1ffa347a..d336f599 100644 --- a/contrib/cc/ccproof.ml +++ b/contrib/cc/ccproof.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ccproof.ml 9151 2006-09-19 13:32:22Z corbinea $ *) +(* $Id: ccproof.ml 9856 2007-05-24 14:05:40Z corbinea $ *) (* This file uses the (non-compressed) union-find structure to generate *) (* proof-trees that will be transformed into proof-terms in cctac.ml4 *) @@ -16,58 +16,107 @@ open Names open Term open Ccalgo -type proof= +type rule= Ax of constr | SymAx of constr | Refl of term | Trans of proof*proof | Congr of proof*proof | Inject of proof*constructor*int*int - -let pcongr=function - Refl t1, Refl t2 -> Refl (Appli (t1,t2)) - | p1, p2 -> Congr (p1,p2) - -let rec ptrans=function - Refl _, p ->p - | p, Refl _ ->p - | Trans(p1,p2), p3 ->ptrans(p1,ptrans (p2,p3)) - | Congr(p1,p2), Congr(p3,p4) ->pcongr(ptrans(p1,p3),ptrans(p2,p4)) - | Congr(p1,p2), Trans(Congr(p3,p4),p5) -> - ptrans(pcongr(ptrans(p1,p3),ptrans(p2,p4)),p5) - | p1, p2 ->Trans (p1,p2) - -let rec psym=function - Refl p->Refl p - | SymAx s->Ax s - | Ax s-> SymAx s - | Inject (p,c,n,a)-> Inject (psym p,c,n,a) - | Trans (p1,p2)-> ptrans (psym p2,psym p1) - | Congr (p1,p2)-> pcongr (psym p1,psym p2) +and proof = + {p_lhs:term;p_rhs:term;p_rule:rule} + +let prefl t = {p_lhs=t;p_rhs=t;p_rule=Refl t} + +let pcongr p1 p2 = + match p1.p_rule,p2.p_rule with + Refl t1, Refl t2 -> prefl (Appli (t1,t2)) + | _, _ -> + {p_lhs=Appli (p1.p_lhs,p2.p_lhs); + p_rhs=Appli (p1.p_rhs,p2.p_rhs); + p_rule=Congr (p1,p2)} + +let rec ptrans p1 p3= + match p1.p_rule,p3.p_rule with + Refl _, _ ->p3 + | _, Refl _ ->p1 + | Trans(p1,p2), _ ->ptrans p1 (ptrans p2 p3) + | Congr(p1,p2), Congr(p3,p4) ->pcongr (ptrans p1 p3) (ptrans p2 p4) + | Congr(p1,p2), Trans({p_rule=Congr(p3,p4)},p5) -> + ptrans (pcongr (ptrans p1 p3) (ptrans p2 p4)) p5 + | _, _ -> + if p1.p_rhs = p3.p_lhs then + {p_lhs=p1.p_lhs; + p_rhs=p3.p_rhs; + p_rule=Trans (p1,p3)} + else anomaly "invalid cc transitivity" -let pcongr=function - Refl t1, Refl t2 ->Refl (Appli (t1,t2)) - | p1, p2 -> Congr (p1,p2) +let rec psym p = + match p.p_rule with + Refl _ -> p + | SymAx s -> + {p_lhs=p.p_rhs; + p_rhs=p.p_lhs; + p_rule=Ax s} + | Ax s-> + {p_lhs=p.p_rhs; + p_rhs=p.p_lhs; + p_rule=SymAx s} + | Inject (p0,c,n,a)-> + {p_lhs=p.p_rhs; + p_rhs=p.p_lhs; + p_rule=Inject (psym p0,c,n,a)} + | Trans (p1,p2)-> ptrans (psym p2) (psym p1) + | Congr (p1,p2)-> pcongr (psym p1) (psym p2) + +let pax axioms s = + let l,r = Hashtbl.find axioms s in + {p_lhs=l; + p_rhs=r; + p_rule=Ax s} + +let psymax axioms s = + let l,r = Hashtbl.find axioms s in + {p_lhs=r; + p_rhs=l; + p_rule=SymAx s} + +let rec nth_arg t n= + match t with + Appli (t1,t2)-> + if n>0 then + nth_arg t1 (n-1) + else t2 + | _ -> anomaly "nth_arg: not enough args" + +let pinject p c n a = + {p_lhs=nth_arg p.p_lhs (n-a); + p_rhs=nth_arg p.p_rhs (n-a); + p_rule=Inject(p,c,n,a)} let build_proof uf= - + + let axioms = axioms uf in + let rec equal_proof i j= - if i=j then Refl (term uf i) else + if i=j then prefl (term uf i) else let (li,lj)=join_path uf i j in - ptrans (path_proof i li,psym (path_proof j lj)) + ptrans (path_proof i li) (psym (path_proof j lj)) and edge_proof ((i,j),eq)= let pi=equal_proof i eq.lhs in let pj=psym (equal_proof j eq.rhs) in let pij= match eq.rule with - Axiom (s,reversed)->if reversed then SymAx s else Ax s + Axiom (s,reversed)-> + if reversed then psymax axioms s + else pax axioms s | Congruence ->congr_proof eq.lhs eq.rhs | Injection (ti,ipac,tj,jpac,k) -> let p=ind_proof ti ipac tj jpac in let cinfo= get_constructor_info uf ipac.cnode in - Inject(p,cinfo.ci_constr,cinfo.ci_nhyps,k) - in ptrans(ptrans (pi,pij),pj) + pinject p cinfo.ci_constr cinfo.ci_nhyps k + in ptrans (ptrans pi pij) pj and constr_proof i t ipac= if ipac.args=[] then @@ -79,49 +128,26 @@ let build_proof uf= let rj=find uf j in let u=find_pac uf rj npac in let p=constr_proof j u npac in - ptrans (equal_proof i t, pcongr (p,Refl targ)) + ptrans (equal_proof i t) (pcongr p (prefl targ)) and path_proof i=function - [] -> Refl (term uf i) - | x::q->ptrans (path_proof (snd (fst x)) q,edge_proof x) + [] -> prefl (term uf i) + | x::q->ptrans (path_proof (snd (fst x)) q) (edge_proof x) and congr_proof i j= let (i1,i2) = subterms uf i and (j1,j2) = subterms uf j in - pcongr (equal_proof i1 j1, equal_proof i2 j2) + pcongr (equal_proof i1 j1) (equal_proof i2 j2) and ind_proof i ipac j jpac= let p=equal_proof i j and p1=constr_proof i i ipac and p2=constr_proof j j jpac in - ptrans(psym p1,ptrans(p,p2)) + ptrans (psym p1) (ptrans p p2) in function `Prove (i,j) -> equal_proof i j | `Discr (i,ci,j,cj)-> ind_proof i ci j cj -let rec nth_arg t n= - match t with - Appli (t1,t2)-> - if n>0 then - nth_arg t1 (n-1) - else t2 - | _ -> anomaly "nth_arg: not enough args" -let rec type_proof axioms p= - match p with - Ax s->Hashtbl.find axioms s - | SymAx s-> let (t1,t2)=Hashtbl.find axioms s in (t2,t1) - | Refl t-> t,t - | Trans (p1,p2)-> - let (s1,t1)=type_proof axioms p1 - and (t2,s2)=type_proof axioms p2 in - if t1=t2 then (s1,s2) else anomaly "invalid cc transitivity" - | Congr (p1,p2)-> - let (i1,j1)=type_proof axioms p1 - and (i2,j2)=type_proof axioms p2 in - Appli (i1,i2),Appli (j1,j2) - | Inject (p,c,n,a)-> - let (ti,tj)=type_proof axioms p in - nth_arg ti (n-a),nth_arg tj (n-a) diff --git a/contrib/cc/ccproof.mli b/contrib/cc/ccproof.mli index abdd6fea..572b2c53 100644 --- a/contrib/cc/ccproof.mli +++ b/contrib/cc/ccproof.mli @@ -6,26 +6,26 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ccproof.mli 9151 2006-09-19 13:32:22Z corbinea $ *) +(* $Id: ccproof.mli 9856 2007-05-24 14:05:40Z corbinea $ *) open Ccalgo open Names open Term -type proof = +type rule= Ax of constr | SymAx of constr | Refl of term - | Trans of proof * proof - | Congr of proof * proof - | Inject of proof * constructor * int * int + | Trans of proof*proof + | Congr of proof*proof + | Inject of proof*constructor*int*int +and proof = + private {p_lhs:term;p_rhs:term;p_rule:rule} val build_proof : forest -> [ `Discr of int * pa_constructor * int * pa_constructor | `Prove of int * int ] -> proof -val type_proof : - (constr, (term * term)) Hashtbl.t -> proof -> term * term diff --git a/contrib/cc/cctac.ml b/contrib/cc/cctac.ml index ea8aceeb..86251254 100644 --- a/contrib/cc/cctac.ml +++ b/contrib/cc/cctac.ml @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: cctac.ml 9151 2006-09-19 13:32:22Z corbinea $ *) +(* $Id: cctac.ml 9856 2007-05-24 14:05:40Z corbinea $ *) (* This file is the interface between the c-c algorithm and Coq *) @@ -37,6 +37,12 @@ let _f_equal = constant ["Init";"Logic"] "f_equal" let _eq_rect = constant ["Init";"Logic"] "eq_rect" +let _refl_equal = constant ["Init";"Logic"] "refl_equal" + +let _sym_eq = constant ["Init";"Logic"] "sym_eq" + +let _trans_eq = constant ["Init";"Logic"] "trans_eq" + let _eq = constant ["Init";"Logic"] "eq" let _False = constant ["Init";"Logic"] "False" @@ -210,54 +216,73 @@ let build_projection intype outtype (cstr:constructor) special default gls= (* generate an adhoc tactic following the proof tree *) -let rec proof_tac axioms=function - Ax c -> exact_check c - | SymAx c -> tclTHEN symmetry (exact_check c) - | Refl t -> reflexivity - | Trans (p1,p2)->let t=(constr_of_term (snd (type_proof axioms p1))) in - (tclTHENS (transitivity t) - [(proof_tac axioms p1);(proof_tac axioms p2)]) - | Congr (p1,p2)-> - fun gls-> - let (f1,f2)=(type_proof axioms p1) - and (x1,x2)=(type_proof axioms p2) in - let tf1=constr_of_term f1 and tx1=constr_of_term x1 - and tf2=constr_of_term f2 and tx2=constr_of_term x2 in - let typf=pf_type_of gls tf1 and typx=pf_type_of gls tx1 - and typfx=pf_type_of gls (mkApp(tf1,[|tx1|])) in - let id=pf_get_new_id (id_of_string "f") gls in - let appx1=mkLambda(Name id,typf,mkApp(mkRel 1,[|tx1|])) in - let lemma1= - mkApp(Lazy.force _f_equal,[|typf;typfx;appx1;tf1;tf2|]) - and lemma2= - mkApp(Lazy.force _f_equal,[|typx;typfx;tf2;tx1;tx2|]) in - (tclTHENS (transitivity (mkApp(tf2,[|tx1|]))) - [tclTHEN (apply lemma1) (proof_tac axioms p1); - tclFIRST - [tclTHEN (apply lemma2) (proof_tac axioms p2); - reflexivity; - fun gls -> - errorlabstrm "Congruence" - (Pp.str - "I don't know how to handle dependent equality")]] - gls) - | Inject (prf,cstr,nargs,argind) as gprf-> - (fun gls -> - let ti,tj=type_proof axioms prf in - let ai,aj=type_proof axioms gprf in - let cti=constr_of_term ti in - let ctj=constr_of_term tj in - let cai=constr_of_term ai in - let intype=pf_type_of gls cti in - let outtype=pf_type_of gls cai in +let _M =mkMeta + +let rec proof_tac p gls = + match p.p_rule with + Ax c -> exact_check c gls + | SymAx c -> + let l=constr_of_term p.p_lhs and + r=constr_of_term p.p_rhs in + let typ = pf_type_of gls l in + exact_check + (mkApp(Lazy.force _sym_eq,[|typ;r;l;c|])) gls + | Refl t -> + let lr = constr_of_term t in + let typ = pf_type_of gls lr in + exact_check + (mkApp(Lazy.force _refl_equal,[|typ;constr_of_term t|])) gls + | Trans (p1,p2)-> + let t1 = constr_of_term p1.p_lhs and + t2 = constr_of_term p1.p_rhs and + t3 = constr_of_term p2.p_rhs in + let typ = pf_type_of gls t2 in + let prf = + mkApp(Lazy.force _trans_eq,[|typ;t1;t2;t3;_M 1;_M 2|]) in + tclTHENS (refine prf) [(proof_tac p1);(proof_tac p2)] gls + | Congr (p1,p2)-> + let tf1=constr_of_term p1.p_lhs + and tx1=constr_of_term p2.p_lhs + and tf2=constr_of_term p1.p_rhs + and tx2=constr_of_term p2.p_rhs in + let typf = pf_type_of gls tf1 in + let typx = pf_type_of gls tx1 in + let typfx = prod_applist typf [tx1] in + let id = pf_get_new_id (id_of_string "f") gls in + let appx1 = mkLambda(Name id,typf,mkApp(mkRel 1,[|tx1|])) in + let lemma1 = + mkApp(Lazy.force _f_equal, + [|typf;typfx;appx1;tf1;tf2;_M 1|]) in + let lemma2= + mkApp(Lazy.force _f_equal,[|typx;typfx;tf2;tx1;tx2;_M 1|]) in + let prf = + mkApp(Lazy.force _trans_eq, + [|typfx; + mkApp(tf1,[|tx1|]); + mkApp(tf2,[|tx1|]); + mkApp(tf2,[|tx2|]);_M 2;_M 3|]) in + tclTHENS (refine prf) + [tclTHEN (refine lemma1) (proof_tac p1); + tclFIRST + [tclTHEN (refine lemma2) (proof_tac p2); + reflexivity; + fun gls -> + errorlabstrm "Congruence" + (Pp.str + "I don't know how to handle dependent equality")]] gls + | Inject (prf,cstr,nargs,argind) -> + let ti=constr_of_term prf.p_lhs in + let tj=constr_of_term prf.p_rhs in + let default=constr_of_term p.p_lhs in + let intype=pf_type_of gls ti in + let outtype=pf_type_of gls default in let special=mkRel (1+nargs-argind) in - let default=constr_of_term ai in let proj=build_projection intype outtype cstr special default gls in let injt= - mkApp (Lazy.force _f_equal,[|intype;outtype;proj;cti;ctj|]) in - tclTHEN (apply injt) (proof_tac axioms prf) gls) + mkApp (Lazy.force _f_equal,[|intype;outtype;proj;ti;tj;_M 1|]) in + tclTHEN (refine injt) (proof_tac prf) gls -let refute_tac axioms c t1 t2 p gls = +let refute_tac c t1 t2 p gls = let tt1=constr_of_term t1 and tt2=constr_of_term t2 in let intype=pf_type_of gls tt1 in let neweq= @@ -266,9 +291,9 @@ let refute_tac axioms c t1 t2 p gls = let hid=pf_get_new_id (id_of_string "Heq") gls in let false_t=mkApp (c,[|mkVar hid|]) in tclTHENS (true_cut (Name hid) neweq) - [proof_tac axioms p; simplest_elim false_t] gls + [proof_tac p; simplest_elim false_t] gls -let convert_to_goal_tac axioms c t1 t2 p gls = +let convert_to_goal_tac c t1 t2 p gls = let tt1=constr_of_term t1 and tt2=constr_of_term t2 in let sort=pf_type_of gls tt2 in let neweq=mkApp(Lazy.force _eq,[|sort;tt1;tt2|]) in @@ -278,20 +303,19 @@ let convert_to_goal_tac axioms c t1 t2 p gls = let endt=mkApp (Lazy.force _eq_rect, [|sort;tt1;identity;c;tt2;mkVar e|]) in tclTHENS (true_cut (Name e) neweq) - [proof_tac axioms p;exact_check endt] gls + [proof_tac p;exact_check endt] gls -let convert_to_hyp_tac axioms c1 t1 c2 t2 p gls = +let convert_to_hyp_tac c1 t1 c2 t2 p gls = let tt2=constr_of_term t2 in let h=pf_get_new_id (id_of_string "H") gls in let false_t=mkApp (c2,[|mkVar h|]) in tclTHENS (true_cut (Name h) tt2) - [convert_to_goal_tac axioms c1 t1 t2 p; + [convert_to_goal_tac c1 t1 t2 p; simplest_elim false_t] gls -let discriminate_tac axioms cstr p gls = - let t1,t2=type_proof axioms p in - let tt1=constr_of_term t1 and tt2=constr_of_term t2 in - let intype=pf_type_of gls tt1 in +let discriminate_tac cstr p gls = + let t1=constr_of_term p.p_lhs and t2=constr_of_term p.p_rhs in + let intype=pf_type_of gls t1 in let concl=pf_concl gls in let outsort=mkType (new_univ ()) in let xid=pf_get_new_id (id_of_string "X") gls in @@ -303,12 +327,12 @@ let discriminate_tac axioms cstr p gls = let hid=pf_get_new_id (id_of_string "Heq") gls in let proj=build_projection intype outtype cstr trivial concl gls in let injt=mkApp (Lazy.force _f_equal, - [|intype;outtype;proj;tt1;tt2;mkVar hid|]) in + [|intype;outtype;proj;t1;t2;mkVar hid|]) in let endt=mkApp (Lazy.force _eq_rect, [|outtype;trivial;pred;identity;concl;injt|]) in - let neweq=mkApp(Lazy.force _eq,[|intype;tt1;tt2|]) in + let neweq=mkApp(Lazy.force _eq,[|intype;t1;t2|]) in tclTHENS (true_cut (Name hid) neweq) - [proof_tac axioms p;exact_check endt] gls + [proof_tac p;exact_check endt] gls (* wrap everything *) @@ -333,12 +357,12 @@ let cc_tactic depth additionnal_terms gls= debug Pp.msgnl (Pp.str "Goal solved, generating proof ..."); match reason with Discrimination (i,ipac,j,jpac) -> - let p=build_proof uf (`Discr (i,ipac,j,jpac)) in + let p=build_proof uf (`Discr (i,ipac,j,jpac)) in let cstr=(get_constructor_info uf ipac.cnode).ci_constr in - discriminate_tac (axioms uf) cstr p gls + discriminate_tac cstr p gls | Incomplete -> let metacnt = ref 0 in - let newmeta _ = incr metacnt; mkMeta !metacnt in + let newmeta _ = incr metacnt; _M !metacnt in let terms_to_complete = List.map (build_term_to_complete uf newmeta) @@ -363,14 +387,13 @@ let cc_tactic depth additionnal_terms gls= | Contradiction dis -> let p=build_proof uf (`Prove (dis.lhs,dis.rhs)) in let ta=term uf dis.lhs and tb=term uf dis.rhs in - let axioms = axioms uf in match dis.rule with - Goal -> proof_tac axioms p gls - | Hyp id -> refute_tac axioms id ta tb p gls + Goal -> proof_tac p gls + | Hyp id -> refute_tac id ta tb p gls | HeqG id -> - convert_to_goal_tac axioms id ta tb p gls + convert_to_goal_tac id ta tb p gls | HeqnH (ida,idb) -> - convert_to_hyp_tac axioms ida ta idb tb p gls + convert_to_hyp_tac ida ta idb tb p gls let cc_fail gls = diff --git a/contrib/funind/functional_principles_proofs.ml b/contrib/funind/functional_principles_proofs.ml index ff4f7499..dec7273b 100644 --- a/contrib/funind/functional_principles_proofs.ml +++ b/contrib/funind/functional_principles_proofs.ml @@ -621,33 +621,39 @@ let build_proof fun g -> (* observe (str "proving on " ++ Printer.pr_lconstr_env (pf_env g) term);*) - match kind_of_term dyn_infos.info with - | Case(_,_,t,_) -> - let g_nb_prod = nb_prod (pf_concl g) in - let type_of_term = pf_type_of g t in - let term_eq = - make_refl_eq type_of_term t + match kind_of_term dyn_infos.info with | Case(ci,ct,t,cb) -> + let do_finalize_t dyn_info' = + fun g -> + let t = dyn_info'.info in + let dyn_infos = {dyn_info' with info = + mkCase(ci,ct,t,cb)} in + let g_nb_prod = nb_prod (pf_concl g) in + let type_of_term = pf_type_of g t in + let term_eq = + make_refl_eq type_of_term t + in + tclTHENSEQ + [ + h_generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps)); + thin dyn_infos.rec_hyps; + pattern_option [[-1],t] None; + h_simplest_case t; + (fun g' -> + let g'_nb_prod = nb_prod (pf_concl g') in + let nb_instanciate_partial = g'_nb_prod - g_nb_prod in + observe_tac "treat_new_case" + (treat_new_case + ptes_infos + nb_instanciate_partial + (build_proof do_finalize) + t + dyn_infos) + g' + ) + + ] g in - tclTHENSEQ - [ - h_generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps)); - thin dyn_infos.rec_hyps; - pattern_option [[-1],t] None; - h_simplest_case t; - (fun g' -> - let g'_nb_prod = nb_prod (pf_concl g') in - let nb_instanciate_partial = g'_nb_prod - g_nb_prod in - observe_tac "treat_new_case" - (treat_new_case - ptes_infos - nb_instanciate_partial - (build_proof do_finalize) - t - dyn_infos) - g' - ) - - ] g + build_proof do_finalize_t {dyn_infos with info = t} g | Lambda(n,t,b) -> begin match kind_of_term( pf_concl g) with @@ -1474,7 +1480,7 @@ let prove_principle_for_gen (mkApp (delayed_force acc_rel,[|input_type;relation;mkVar rec_arg_id|])) ); observe_tac "reverting" (revert (List.rev (acc_rec_arg_id::args_ids))); - observe_tac "h_fix" (h_fix (Some fix_id) (npost_rec_arg + 1)); + observe_tac "h_fix" (h_fix (Some fix_id) (List.length args_ids + 1)); h_intros (List.rev (acc_rec_arg_id::args_ids)); Equality.rewriteLR (mkConst eq_ref); observe_tac "finish" (fun gl' -> diff --git a/contrib/funind/indfun.ml b/contrib/funind/indfun.ml index 6e2af224..82bee01f 100644 --- a/contrib/funind/indfun.ml +++ b/contrib/funind/indfun.ml @@ -209,7 +209,7 @@ let rec is_rec names = let rec lookup names = function | RVar(_,id) -> check_id id names | RRef _ | REvar _ | RPatVar _ | RSort _ | RHole _ | RDynamic _ -> false - | RCast(_,b,_,_) -> lookup names b + | RCast(_,b,_) -> lookup names b | RRec _ -> error "RRec not handled" | RIf(_,b,_,lhs,rhs) -> (lookup names b) || (lookup names lhs) || (lookup names rhs) @@ -270,7 +270,30 @@ let derive_inversion fix_names = if do_observe () then Cerrors.explain_exn e else mt ()) with _ -> () -let generate_principle +let warning_error names e = + match e with + | Building_graph e -> + Pp.msg_warning + (str "Cannot define graph(s) for " ++ + h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ + if do_observe () then (spc () ++ Cerrors.explain_exn e) else mt ()) + | Defining_principle e -> + Pp.msg_warning + (str "Cannot define principle(s) for "++ + h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ + if do_observe () then Cerrors.explain_exn e else mt ()) + | _ -> anomaly "" + +let error_error names e = + match e with + | Building_graph e -> + errorlabstrm "" + (str "Cannot define graph(s) for " ++ + h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ + if do_observe () then (spc () ++ Cerrors.explain_exn e) else mt ()) + | _ -> anomaly "" + +let generate_principle on_error is_general do_built fix_rec_l recdefs interactive_proof (continue_proof : int -> Names.constant array -> Term.constr array -> int -> Tacmach.tactic) : unit = @@ -324,18 +347,7 @@ let generate_principle () end with e -> - match e with - | Building_graph e -> - Pp.msg_warning - (str "Cannot define graph(s) for " ++ - h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ - if do_observe () then (spc () ++ Cerrors.explain_exn e) else mt ()) - | Defining_principle e -> - Pp.msg_warning - (str "Cannot define principle(s) for "++ - h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ - if do_observe () then Cerrors.explain_exn e else mt ()) - | _ -> anomaly "" + on_error names e let register_struct is_rec fixpoint_exprl = match fixpoint_exprl with @@ -459,13 +471,14 @@ let register_mes fname rec_impls wf_mes_expr wf_arg using_lemmas args ret_type b using_lemmas args ret_type body -let do_generate_principle register_built interactive_proof fixpoint_exprl = +let do_generate_principle on_error register_built interactive_proof fixpoint_exprl = let recdefs,rec_impls = build_newrecursive fixpoint_exprl in let _is_struct = match fixpoint_exprl with | [((name,Some (Wf (wf_rel,wf_x,using_lemmas)),args,types,body))] -> let pre_hook = generate_principle + on_error true register_built fixpoint_exprl @@ -478,6 +491,7 @@ let do_generate_principle register_built interactive_proof fixpoint_exprl = | [((name,Some (Mes (wf_mes,wf_x,using_lemmas)),args,types,body))] -> let pre_hook = generate_principle + on_error true register_built fixpoint_exprl @@ -530,6 +544,7 @@ let do_generate_principle register_built interactive_proof fixpoint_exprl = let is_rec = List.exists (is_rec fix_names) recdefs in if register_built then register_struct is_rec old_fixpoint_exprl; generate_principle + on_error false register_built fixpoint_exprl @@ -596,8 +611,10 @@ let rec add_args id new_args b = | CPatVar _ -> b | CEvar _ -> b | CSort _ -> b - | CCast(loc,b1,ck,b2) -> - CCast(loc,add_args id new_args b1,ck,add_args id new_args b2) + | CCast(loc,b1,CastConv(ck,b2)) -> + CCast(loc,add_args id new_args b1,CastConv(ck,add_args id new_args b2)) + | CCast(loc,b1,CastCoerce) -> + CCast(loc,add_args id new_args b1,CastCoerce) | CNotation _ -> anomaly "add_args : CNotation" | CPrim _ -> b | CDelimiters _ -> anomaly "add_args : CDelimiters" @@ -732,7 +749,7 @@ let make_graph (f_ref:global_reference) = let id = id_of_label (con_label c) in [(id,None,nal_tas,t,b)] in - do_generate_principle false false expr_list; + do_generate_principle error_error false false expr_list; (* We register the infos *) let mp,dp,_ = repr_con c in List.iter @@ -742,6 +759,6 @@ let make_graph (f_ref:global_reference) = (* let make_graph _ = assert false *) -let do_generate_principle = do_generate_principle true +let do_generate_principle = do_generate_principle warning_error true diff --git a/contrib/funind/indfun_main.ml4 b/contrib/funind/indfun_main.ml4 index 26a1066c..9cee9edc 100644 --- a/contrib/funind/indfun_main.ml4 +++ b/contrib/funind/indfun_main.ml4 @@ -203,7 +203,10 @@ VERNAC COMMAND EXTEND NewFunctionalScheme match fas with | (_,fun_name,_)::_ -> begin - make_graph (Nametab.global fun_name); + begin + make_graph (Nametab.global fun_name) + end + ; try Functional_principles_types.build_scheme fas with Functional_principles_types.No_graph_found -> Util.error ("Cannot generate induction principle(s)") diff --git a/contrib/funind/invfun.ml b/contrib/funind/invfun.ml index 04110ea9..9ec02d4c 100644 --- a/contrib/funind/invfun.ml +++ b/contrib/funind/invfun.ml @@ -478,7 +478,72 @@ let generalize_depedent_of x hyp g = - + (* [intros_with_rewrite] do the intros in each branch and treat each new hypothesis + (unfolding, substituting, destructing cases \ldots) + *) +let rec intros_with_rewrite g = + observe_tac "intros_with_rewrite" intros_with_rewrite_aux g +and intros_with_rewrite_aux : tactic = + fun g -> + let eq_ind = Coqlib.build_coq_eq () in + match kind_of_term (pf_concl g) with + | Prod(_,t,t') -> + begin + match kind_of_term t with + | App(eq,args) when (eq_constr eq eq_ind) -> + if isVar args.(1) + then + let id = pf_get_new_id (id_of_string "y") g in + tclTHENSEQ [ h_intro id; + generalize_depedent_of (destVar args.(1)) id; + tclTRY (Equality.rewriteLR (mkVar id)); + intros_with_rewrite + ] + g + else + begin + let id = pf_get_new_id (id_of_string "y") g in + tclTHENSEQ[ + h_intro id; + tclTRY (Equality.rewriteLR (mkVar id)); + intros_with_rewrite + ] g + end + | Ind _ when eq_constr t (Coqlib.build_coq_False ()) -> + Tauto.tauto g + | Case(_,_,v,_) -> + tclTHENSEQ[ + h_case (v,Rawterm.NoBindings); + intros_with_rewrite + ] g + | LetIn _ -> + tclTHENSEQ[ + h_reduce + (Rawterm.Cbv + {Rawterm.all_flags + with Rawterm.rDelta = false; + }) + onConcl + ; + intros_with_rewrite + ] g + | _ -> + let id = pf_get_new_id (id_of_string "y") g in + tclTHENSEQ [ h_intro id;intros_with_rewrite] g + end + | LetIn _ -> + tclTHENSEQ[ + h_reduce + (Rawterm.Cbv + {Rawterm.all_flags + with Rawterm.rDelta = false; + }) + onConcl + ; + intros_with_rewrite + ] g + | _ -> tclIDTAC g + let rec reflexivity_with_destruct_cases g = let destruct_case () = try @@ -492,10 +557,34 @@ let rec reflexivity_with_destruct_cases g = | _ -> reflexivity with _ -> reflexivity in - tclFIRST + let eq_ind = Coqlib.build_coq_eq () in + let discr_inject = + Tacticals.onAllClauses ( + fun sc g -> + match sc with + None -> tclIDTAC g + | Some ((_,id),_) -> + match kind_of_term (pf_type_of g (mkVar id)) with + | App(eq,[|_;t1;t2|]) when eq_constr eq eq_ind -> + if Equality.discriminable (pf_env g) (project g) t1 t2 + then Equality.discr id g + else if Equality.injectable (pf_env g) (project g) t1 t2 + then tclTHEN (Equality.inj [] id) intros_with_rewrite g + else tclIDTAC g + | _ -> tclIDTAC g + ) + in + (tclFIRST [ reflexivity; - destruct_case () - ] + destruct_case (); + (* We reach this point ONLY if + the same value is matched (at least) two times + along binding path. + In this case, either we have a discriminable hypothesis and we are done, + either at least an injectable one and we do the injection before continuing + *) + tclTHEN (tclPROGRESS discr_inject ) reflexivity_with_destruct_cases + ]) g @@ -566,7 +655,6 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = ) branches in - let eq_ind = Coqlib.build_coq_eq () in (* We will need to change the function by its body using [f_equation] if it is recursive (that is the graph is infinite or unfold if the graph is finite @@ -596,71 +684,6 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = ] else unfold_in_concl [([],Names.EvalConstRef (destConst f))] in - (* [intros_with_rewrite] do the intros in each branch and treat each new hypothesis - (unfolding, substituting, destructing cases \ldots) - *) - let rec intros_with_rewrite_aux : tactic = - fun g -> - match kind_of_term (pf_concl g) with - | Prod(_,t,t') -> - begin - match kind_of_term t with - | App(eq,args) when (eq_constr eq eq_ind) -> - if isVar args.(1) - then - let id = pf_get_new_id (id_of_string "y") g in - tclTHENSEQ [ h_intro id; - generalize_depedent_of (destVar args.(1)) id; - tclTRY (Equality.rewriteLR (mkVar id)); - intros_with_rewrite - ] - g - else - begin - let id = pf_get_new_id (id_of_string "y") g in - tclTHENSEQ[ - h_intro id; - tclTRY (Equality.rewriteLR (mkVar id)); - intros_with_rewrite - ] g - end - | Ind _ when eq_constr t (Coqlib.build_coq_False ()) -> - Tauto.tauto g - | Case(_,_,v,_) -> - tclTHENSEQ[ - h_case (v,Rawterm.NoBindings); - intros_with_rewrite - ] g - | LetIn _ -> - tclTHENSEQ[ - h_reduce - (Rawterm.Cbv - {Rawterm.all_flags - with Rawterm.rDelta = false; - }) - onConcl - ; - intros_with_rewrite - ] g - | _ -> - let id = pf_get_new_id (id_of_string "y") g in - tclTHENSEQ [ h_intro id;intros_with_rewrite] g - end - | LetIn _ -> - tclTHENSEQ[ - h_reduce - (Rawterm.Cbv - {Rawterm.all_flags - with Rawterm.rDelta = false; - }) - onConcl - ; - intros_with_rewrite - ] g - | _ -> tclIDTAC g - and intros_with_rewrite g = - observe_tac "intros_with_rewrite" intros_with_rewrite_aux g - in (* The proof of each branche itself *) let ind_number = ref 0 in let min_constr_number = ref 0 in @@ -698,7 +721,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = h_intro graph_principle_id; observe_tac "" (tclTHEN_i (observe_tac "elim" ((elim (mkVar hres,Rawterm.NoBindings) (Some (mkVar graph_principle_id,Rawterm.NoBindings))))) - (fun i g -> prove_branche i g )) + (fun i g -> observe_tac "prove_branche" (prove_branche i) g )) ] g diff --git a/contrib/funind/rawterm_to_relation.ml b/contrib/funind/rawterm_to_relation.ml index aca84f06..b34a1097 100644 --- a/contrib/funind/rawterm_to_relation.ml +++ b/contrib/funind/rawterm_to_relation.ml @@ -351,7 +351,7 @@ let rec find_type_of nb b = then raise (Invalid_argument "find_type_of : not a valid inductive"); ind_type end - | RCast(_,b,_,_) -> find_type_of nb b + | RCast(_,b,_) -> find_type_of nb b | RApp _ -> assert false (* we have decomposed any application via raw_decompose_app *) | _ -> raise (Invalid_argument "not a ref") @@ -575,7 +575,7 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return = let f_res = build_entry_lc env funnames args_res.to_avoid f in combine_results combine_app f_res args_res | RDynamic _ ->error "Not handled RDynamic" - | RCast(_,b,_,_) -> + | RCast(_,b,_) -> (* for an applied cast we just trash the cast part and restart the work. @@ -685,7 +685,7 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return = end | RRec _ -> error "Not handled RRec" - | RCast(_,b,_,_) -> + | RCast(_,b,_) -> build_entry_lc env funnames avoid b | RDynamic _ -> error "Not handled RDynamic" and build_entry_lc_from_case env funname make_discr diff --git a/contrib/funind/rawtermops.ml b/contrib/funind/rawtermops.ml index ba5c2bbd..113ddd8b 100644 --- a/contrib/funind/rawtermops.ml +++ b/contrib/funind/rawtermops.ml @@ -18,7 +18,7 @@ let mkRLetIn(n,t,b) = RLetIn(dummy_loc,n,t,b) let mkRCases(rto,l,brl) = RCases(dummy_loc,rto,l,brl) let mkRSort s = RSort(dummy_loc,s) let mkRHole () = RHole(dummy_loc,Evd.BinderType Anonymous) -let mkRCast(b,t) = RCast(dummy_loc,b,CastCoerce,t) +let mkRCast(b,t) = RCast(dummy_loc,b,CastConv (Term.DEFAULTcast,t)) (* Some basic functions to decompose rawconstrs @@ -145,8 +145,10 @@ let change_vars = | RRec _ -> error "Local (co)fixes are not supported" | RSort _ -> rt | RHole _ -> rt - | RCast(loc,b,k,t) -> - RCast(loc,change_vars mapping b,k,change_vars mapping t) + | RCast(loc,b,CastConv (k,t)) -> + RCast(loc,change_vars mapping b, CastConv (k,change_vars mapping t)) + | RCast(loc,b,CastCoerce) -> + RCast(loc,change_vars mapping b,CastCoerce) | RDynamic _ -> error "Not handled RDynamic" and change_vars_br mapping ((loc,idl,patl,res) as br) = let new_mapping = List.fold_right Idmap.remove idl mapping in @@ -324,8 +326,10 @@ let rec alpha_rt excluded rt = | RRec _ -> error "Not handled RRec" | RSort _ -> rt | RHole _ -> rt - | RCast (loc,b,k,t) -> - RCast(loc,alpha_rt excluded b,k,alpha_rt excluded t) + | RCast (loc,b,CastConv (k,t)) -> + RCast(loc,alpha_rt excluded b,CastConv(k,alpha_rt excluded t)) + | RCast (loc,b,CastCoerce) -> + RCast(loc,alpha_rt excluded b,CastCoerce) | RDynamic _ -> error "Not handled RDynamic" | RApp(loc,f,args) -> RApp(loc, @@ -375,7 +379,8 @@ let is_free_in id = | RRec _ -> raise (UserError("",str "Not handled RRec")) | RSort _ -> false | RHole _ -> false - | RCast (_,b,_,t) -> is_free_in b || is_free_in t + | RCast (_,b,CastConv (_,t)) -> is_free_in b || is_free_in t + | RCast (_,b,CastCoerce) -> is_free_in b | RDynamic _ -> raise (UserError("",str "Not handled RDynamic")) and is_free_in_br (_,ids,_,rt) = (not (List.mem id ids)) && is_free_in rt @@ -469,8 +474,10 @@ let replace_var_by_term x_id term = | RRec _ -> raise (UserError("",str "Not handled RRec")) | RSort _ -> rt | RHole _ -> rt - | RCast(loc,b,k,t) -> - RCast(loc,replace_var_by_pattern b,k,replace_var_by_pattern t) + | RCast(loc,b,CastConv(k,t)) -> + RCast(loc,replace_var_by_pattern b,CastConv(k,replace_var_by_pattern t)) + | RCast(loc,b,CastCoerce) -> + RCast(loc,replace_var_by_pattern b,CastCoerce) | RDynamic _ -> raise (UserError("",str "Not handled RDynamic")) and replace_var_by_pattern_br ((loc,idl,patl,res) as br) = if List.exists (fun id -> id_ord id x_id == 0) idl @@ -554,7 +561,8 @@ let ids_of_rawterm c = | RLambda (loc,na,ty,c) -> idof na :: ids_of_rawterm [] ty @ ids_of_rawterm [] c @ acc | RProd (loc,na,ty,c) -> idof na :: ids_of_rawterm [] ty @ ids_of_rawterm [] c @ acc | RLetIn (loc,na,b,c) -> idof na :: ids_of_rawterm [] b @ ids_of_rawterm [] c @ acc - | RCast (loc,c,k,t) -> ids_of_rawterm [] c @ ids_of_rawterm [] t @ acc + | RCast (loc,c,CastConv(k,t)) -> ids_of_rawterm [] c @ ids_of_rawterm [] t @ acc + | RCast (loc,c,CastCoerce) -> ids_of_rawterm [] c @ acc | RIf (loc,c,(na,po),b1,b2) -> ids_of_rawterm [] c @ ids_of_rawterm [] b1 @ ids_of_rawterm [] b2 @ acc | RLetTuple (_,nal,(na,po),b,c) -> List.map idof nal @ ids_of_rawterm [] b @ ids_of_rawterm [] c @ acc @@ -619,8 +627,10 @@ let zeta_normalize = | RRec _ -> raise (UserError("",str "Not handled RRec")) | RSort _ -> rt | RHole _ -> rt - | RCast(loc,b,k,t) -> - RCast(loc,zeta_normalize_term b,k,zeta_normalize_term t) + | RCast(loc,b,CastConv(k,t)) -> + RCast(loc,zeta_normalize_term b,CastConv(k,zeta_normalize_term t)) + | RCast(loc,b,CastCoerce) -> + RCast(loc,zeta_normalize_term b,CastCoerce) | RDynamic _ -> raise (UserError("",str "Not handled RDynamic")) and zeta_normalize_br (loc,idl,patl,res) = (loc,idl,patl,zeta_normalize_term res) @@ -660,7 +670,8 @@ let expand_as = expand_as map br1, expand_as map br2) | RRec _ -> error "Not handled RRec" | RDynamic _ -> error "Not handled RDynamic" - | RCast(loc,b,kind,t) -> RCast(loc,expand_as map b,kind,expand_as map t) + | RCast(loc,b,CastConv(kind,t)) -> RCast(loc,expand_as map b,CastConv(kind,expand_as map t)) + | RCast(loc,b,CastCoerce) -> RCast(loc,expand_as map b,CastCoerce) | RCases(loc,po,el,brl) -> RCases(loc, option_map (expand_as map) po, List.map (fun (rt,t) -> expand_as map rt,t) el, List.map (expand_as_br map) brl) diff --git a/contrib/interface/xlate.ml b/contrib/interface/xlate.ml index 60195229..df03a579 100644 --- a/contrib/interface/xlate.ml +++ b/contrib/interface/xlate.ml @@ -408,9 +408,10 @@ and (xlate_formula:Topconstr.constr_expr -> Ascent.ct_FORMULA) = function | CDynamic (_, _) -> assert false | CDelimiters (_, key, num) -> CT_num_encapsulator(CT_num_type key , xlate_formula num) - | CCast (_, e,_, t) -> + | CCast (_, e, CastConv (_, t)) -> CT_coerce_TYPED_FORMULA_to_FORMULA (CT_typed_formula(xlate_formula e, xlate_formula t)) + | CCast (_, e, CastCoerce) -> assert false | CPatVar (_, (_,i)) when is_int_meta i -> CT_coerce_ID_to_FORMULA(CT_metac (CT_int (int_of_meta i))) | CPatVar (_, (false, s)) -> diff --git a/contrib/omega/coq_omega.ml b/contrib/omega/coq_omega.ml index da0817d1..be9ea5ae 100644 --- a/contrib/omega/coq_omega.ml +++ b/contrib/omega/coq_omega.ml @@ -13,7 +13,7 @@ (* *) (**************************************************************************) -(* $Id: coq_omega.ml 8934 2006-06-09 14:30:12Z herbelin $ *) +(* $Id: coq_omega.ml 9963 2007-07-09 14:02:20Z letouzey $ *) open Util open Pp @@ -302,6 +302,7 @@ let coq_eq_ind_r = lazy (constant "eq_ind_r") let coq_dec_or = lazy (constant "dec_or") let coq_dec_and = lazy (constant "dec_and") let coq_dec_imp = lazy (constant "dec_imp") +let coq_dec_iff = lazy (constant "dec_iff") let coq_dec_not = lazy (constant "dec_not") let coq_dec_False = lazy (constant "dec_False") let coq_dec_not_not = lazy (constant "dec_not_not") @@ -312,6 +313,7 @@ let coq_not_and = lazy (constant "not_and") let coq_not_imp = lazy (constant "not_imp") let coq_not_not = lazy (constant "not_not") let coq_imp_simp = lazy (constant "imp_simp") +let coq_iff = lazy (constant "iff") (* uses build_coq_and, build_coq_not, build_coq_or, build_coq_ex *) @@ -388,6 +390,8 @@ let destructurate_prop t = | _, [_;_] when c = Lazy.force coq_Zgt -> Kapp (Zgt,args) | _, [_;_] when c = build_coq_and () -> Kapp (And,args) | _, [_;_] when c = build_coq_or () -> Kapp (Or,args) + | _, [t1;t2] when c = Lazy.force coq_iff -> + Kapp (And,[mkArrow t1 t2;mkArrow t2 t1]) | _, [_] when c = build_coq_not () -> Kapp (Not,args) | _, [] when c = build_coq_False () -> Kapp (False,args) | _, [] when c = build_coq_True () -> Kapp (True,args) diff --git a/contrib/recdef/recdef.ml4 b/contrib/recdef/recdef.ml4 index 353fcdb3..a4acd9a9 100644 --- a/contrib/recdef/recdef.ml4 +++ b/contrib/recdef/recdef.ml4 @@ -46,6 +46,9 @@ open Eauto open Genarg +let compute_renamed_type gls c = + rename_bound_var (pf_env gls) [] (pf_type_of gls c) + let qed () = Command.save_named true let defined () = Command.save_named false @@ -388,32 +391,57 @@ let rec compute_le_proofs = function | a::tl -> tclORELSE assumption (tclTHENS - (apply_with_bindings - (delayed_force le_trans, - ExplicitBindings[dummy_loc,NamedHyp(id_of_string "m"),a])) + (fun g -> + let le_trans = delayed_force le_trans in + let t_le_trans = compute_renamed_type g le_trans in + let m_id = + let _,_,t = destProd t_le_trans in + let na,_,_ = destProd t in + Nameops.out_name na + in + apply_with_bindings + (le_trans, + ExplicitBindings[dummy_loc,NamedHyp m_id,a]) + g + ) [compute_le_proofs tl; tclORELSE (apply (delayed_force le_n)) assumption]) let make_lt_proof pmax le_proof = tclTHENS - (apply_with_bindings - (delayed_force le_lt_trans, - ExplicitBindings[dummy_loc,NamedHyp(id_of_string "m"), pmax])) - [compute_le_proofs le_proof; - tclTHENLIST[apply (delayed_force lt_S_n); default_full_auto]];; + (fun g -> + let le_lt_trans = delayed_force le_lt_trans in + let t_le_lt_trans = compute_renamed_type g le_lt_trans in + let m_id = + let _,_,t = destProd t_le_lt_trans in + let na,_,_ = destProd t in + Nameops.out_name na + in + apply_with_bindings + (le_lt_trans, + ExplicitBindings[dummy_loc,NamedHyp m_id, pmax]) g) + [observe_tac "compute_le_proofs" (compute_le_proofs le_proof); + tclTHENLIST[observe_tac "lt_S_n" (apply (delayed_force lt_S_n)); default_full_auto]];; let rec list_cond_rewrite k def pmax cond_eqs le_proofs = match cond_eqs with [] -> tclIDTAC | eq::eqs -> (fun g -> + let t_eq = compute_renamed_type g (mkVar eq) in + let k_id,def_id = + let k_na,_,t = destProd t_eq in + let _,_,t = destProd t in + let def_na,_,_ = destProd t in + Nameops.out_name k_na,Nameops.out_name def_na + in tclTHENS (general_rewrite_bindings false (mkVar eq, ExplicitBindings[dummy_loc, NamedHyp k_id, mkVar k; dummy_loc, NamedHyp def_id, mkVar def])) [list_cond_rewrite k def pmax eqs le_proofs; - make_lt_proof pmax le_proofs] g + observe_tac "make_lt_proof" (make_lt_proof pmax le_proofs)] g ) let rec introduce_all_equalities func eqs values specs bound le_proofs @@ -1023,12 +1051,20 @@ let rec introduce_all_values_eq cont_tac functional termine [] -> tclTHENLIST [tclTHENS - (general_rewrite_bindings false + (fun gls -> + let t_eq = compute_renamed_type gls (mkVar heq1) in + let k_id,def_id = + let k_na,_,t = destProd t_eq in + let _,_,t = destProd t in + let def_na,_,_ = destProd t in + Nameops.out_name k_na,Nameops.out_name def_na + in + general_rewrite_bindings false (mkVar heq1, ExplicitBindings[dummy_loc,NamedHyp k_id, f_S(f_S(mkVar pmax)); dummy_loc,NamedHyp def_id, - f])) + f]) gls ) [tclTHENLIST [simpl_iter(); unfold_constr (reference_of_constr functional); @@ -1067,12 +1103,22 @@ let rec introduce_all_values_eq cont_tac functional termine h_intros [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])) + ( fun g -> + let t_eq = compute_renamed_type g (mkVar heq) in + let k_id,def_id = + let k_na,_,t = destProd t_eq in + let _,_,t = destProd t in + let def_na,_,_ = destProd t in + Nameops.out_name k_na,Nameops.out_name def_na + in + general_rewrite_bindings false + (mkVar heq, + ExplicitBindings + [dummy_loc, NamedHyp k_id, + f_S(mkVar pmax'); + dummy_loc, NamedHyp def_id, f]) + g + ) [tclIDTAC; tclTHENLIST [apply (delayed_force le_lt_n_Sm); @@ -1132,9 +1178,9 @@ let rec prove_eq (termine:constr) (f:constr)(functional:global_reference) | fn,args -> fun g -> let ids = ids_of_named_context (pf_hyps g) in - rec_leaf_eq + observe_tac "rec_leaf_eq" (rec_leaf_eq termine f ids (constr_of_reference functional) - eqs expr fn args g));; + eqs expr fn args) g));; let (com_eqn : identifier -> global_reference -> global_reference -> global_reference @@ -1159,10 +1205,19 @@ let (com_eqn : identifier -> ) ) ); +(* (try Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowProof) with _ -> ()); + Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowScript); +*) Options.silently defined (); );; +let nf_zeta env = + Reductionops.clos_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]) + env + Evd.empty + + let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num eq generate_induction_principle using_lemmas : unit = let function_type = interp_constr Evd.empty (Global.env()) type_of_f in @@ -1171,10 +1226,12 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let equation_lemma_type = interp_gen (OfType None) Evd.empty env ~impls:([],rec_impls) eq in (* Pp.msgnl (Printer.pr_lconstr equation_lemma_type); *) let res_vars,eq' = decompose_prod equation_lemma_type in + let env_eq' = Environ.push_rel_context (List.map (fun (x,y) -> (x,None,y)) res_vars) env in + let eq' = nf_zeta env_eq' eq' in let res = (* Pp.msgnl (str "res_var :=" ++ Printer.pr_lconstr_env (push_rel_context (List.map (function (x,t) -> (x,None,t)) res_vars) env) eq'); *) (* Pp.msgnl (str "rec_arg_num := " ++ str (string_of_int rec_arg_num)); *) -(* Pp.msgnl (str "eq' := " ++ str (string_of_int rec_arg_num)); *) +(* Pp.msgnl (str "eq' := " ++ Printer.pr_lconstr_env env eq' ++ fnl () ++str (string_of_int rec_arg_num)); *) match kind_of_term eq' with | App(e,[|_;_;eq_fix|]) -> mkLambda (Name function_name,function_type,subst_var function_name (compose_lam res_vars eq_fix)) @@ -1201,16 +1258,19 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let term_ref = Nametab.locate (make_short_qualid term_id) in let f_ref = declare_f function_name (IsProof Lemma) arg_types term_ref in (* message "start second proof"; *) + let continue = ref true in begin try com_eqn equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type) with e -> begin if Tacinterp.get_debug () <> Tactic_debug.DebugOff - then anomalylabstrm "" (str "Cannot create equation Lemma " ++ Cerrors.explain_exn e); - ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,functional_id) with _ -> ()); - anomaly "Cannot create equation Lemma" + then (Pp.msgnl (str "Cannot create equation Lemma " ++ Cerrors.explain_exn e); continue := false) + else (ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,functional_id) with _ -> ()); + anomaly "Cannot create equation Lemma") end end; + if !continue + then let eq_ref = Nametab.locate (make_short_qualid equation_id ) in let f_ref = destConst (constr_of_reference f_ref) and functional_ref = destConst (constr_of_reference functional_ref) diff --git a/contrib/romega/ReflOmegaCore.v b/contrib/romega/ReflOmegaCore.v index 83ea5b63..d20cafc1 100644 --- a/contrib/romega/ReflOmegaCore.v +++ b/contrib/romega/ReflOmegaCore.v @@ -1848,6 +1848,15 @@ Definition exact_divide (k : Z) (body : term) (t : nat) end | false => TrueTerm end + | NeqTerm (Tint Z0) b => + match eq_term (scalar_norm t (body * Tint k)%term) b with + | true => + match eq_Z k 0 with + | true => FalseTerm + | false => NeqTerm (Tint 0) body + end + | false => TrueTerm + end | _ => TrueTerm end. @@ -1858,18 +1867,24 @@ Theorem exact_divide_valid : unfold valid1, exact_divide in |- *; intros k1 k2 t ep e p1; Simplify; simpl in |- *; auto; elim_eq_term (scalar_norm t (k2 * Tint k1)%term) t1; simpl in |- *; auto; elim_eq_Z k1 0; simpl in |- *; - auto; intros H1 H2; elim H2; elim scalar_norm_stable; - simpl in |- *; generalize H1; case (interp_term e k2); + auto; intros H1 H2; elim H2; elim scalar_norm_stable; + simpl in |- *; + [ + generalize H1; case (interp_term e k2); try trivial; (case k1; simpl in |- *; [ intros; absurd (0 = 0); assumption | intros p2 p3 H3 H4; discriminate H4 - | intros p2 p3 H3 H4; discriminate H4 ]). - + | intros p2 p3 H3 H4; discriminate H4 ]) + | + subst k1; rewrite Zmult_comm; simpl in *; intros; absurd (0=0); trivial + | + generalize H1; case (interp_term e k2); + try trivial; intros p2 p3 H3 H4; discriminate H4 + ]. Qed. - (* \paragraph{[O_DIV_APPROX]} La preuve reprend le schéma de la précédente mais on est sur une opération de type valid1 et non sur une opération terminale. *) @@ -1954,7 +1969,7 @@ Definition state (m : Z) (s : step) (prop1 prop2 : proposition) := match prop1 with | EqTerm (Tint Z0) b1 => match prop2 with - | EqTerm (Tint Z0) (b2 + - b3)%term => + | EqTerm b2 b3 => EqTerm (Tint 0) (rewrite s (b1 + (- b3 + b2) * Tint m)%term) | _ => TrueTerm end @@ -1965,10 +1980,8 @@ Theorem state_valid : forall (m : Z) (s : step), valid2 (state m s). unfold valid2 in |- *; intros m s ep e p1 p2; unfold state in |- *; Simplify; simpl in |- *; auto; elim (rewrite_stable s e); simpl in |- *; - intros H1 H2; elim H1; - rewrite (Zplus_comm (- interp_term e t5) (interp_term e t3)); - elim H2; simpl in |- *; reflexivity. - + intros H1 H2; elim H1. + rewrite H2; rewrite Zplus_opp_l; simpl; reflexivity. Qed. (* \subsubsection{Tactiques générant plusieurs but} diff --git a/contrib/romega/refl_omega.ml b/contrib/romega/refl_omega.ml index 285fc0ca..e7e7b3c5 100644 --- a/contrib/romega/refl_omega.ml +++ b/contrib/romega/refl_omega.ml @@ -6,6 +6,10 @@ *************************************************************************) +(* The addition on int, since it while be hidden soon by the one on BigInt *) + +let (+.) = (+) + open Const_omega module OmegaSolver = Omega.MakeOmegaSolver (Bigint) open OmegaSolver @@ -792,6 +796,9 @@ and oproposition_of_constr env ((negated,depends,origin,path) as ctxt) gl c = | Kimp(t1,t2) -> binprop env ctxt (not negated) (not negated) gl (fun i x y -> Pimp(i,x,y)) t1 t2 + | Kapp("iff",[t1;t2]) -> + binprop env ctxt negated negated gl + (fun i x y -> Pand(i,x,y)) (Term.mkArrow t1 t2) (Term.mkArrow t2 t1) | _ -> Pprop c with e when Logic.catchable_exception e -> Pprop c @@ -995,10 +1002,10 @@ let rec equas_of_solution_tree = function list_union (equas_of_solution_tree t1) (equas_of_solution_tree t2) | Leaf s -> s.s_equa_deps - -(* Because of really_useful_prop, decidable formulas such as Pfalse - and Ptrue are moved to Pprop, thus breaking the decidability check - in ReflOmegaCore.concl_to_hyp... *) +(* [really_useful_prop] pushes useless props in a new Pprop variable *) +(* Things get shorter, but may also get wrong, since a Prop is considered + to be undecidable in ReflOmegaCore.concl_to_hyp, whereas for instance + Pfalse is decidable. So should not be used on conclusion (??) *) let really_useful_prop l_equa c = let rec real_of = function @@ -1034,6 +1041,14 @@ let really_useful_prop l_equa c = None -> Pprop (real_of c) | Some t -> t +let rec vars_of_prop = function + | Pequa(_,e) -> vars_of_equations [e] + | Pnot p -> vars_of_prop p + | Por(_,p1,p2) -> list_union (vars_of_prop p1) (vars_of_prop p2) + | Pand(_,p1,p2) -> list_union (vars_of_prop p1) (vars_of_prop p2) + | Pimp(_,p1,p2) -> list_union (vars_of_prop p1) (vars_of_prop p2) + | _ -> [] + let rec display_solution_tree ch = function Leaf t -> output_string ch @@ -1160,10 +1175,15 @@ let replay_history env env_hyp = | CONSTANT_NUL e :: l -> mkApp (Lazy.force coq_s_constant_nul, [| mk_nat (get_hyp env_hyp e) |]) - | NEGATE_CONTRADICT(e1,e2,b) :: l -> + | NEGATE_CONTRADICT(e1,e2,true) :: l -> mkApp (Lazy.force coq_s_negate_contradict, [| mk_nat (get_hyp env_hyp e1.id); mk_nat (get_hyp env_hyp e2.id) |]) + | NEGATE_CONTRADICT(e1,e2,false) :: l -> + mkApp (Lazy.force coq_s_negate_contradict_inv, + [| mk_nat (List.length e2.body); + mk_nat (get_hyp env_hyp e1.id); + mk_nat (get_hyp env_hyp e2.id) |]) | SPLIT_INEQ(e,(e1,l1),(e2,l2)) :: l -> let i = get_hyp env_hyp e.id in let r1 = loop (CCEqua e1 :: env_hyp) l1 in @@ -1254,14 +1274,18 @@ let resolution env full_reified_goal systems_list = let l_hyps = id_concl :: list_remove id_concl l_hyps' in let useful_hyps = List.map (fun id -> List.assoc id full_reified_goal) l_hyps in - let useful_vars = vars_of_equations equations in + let useful_vars = + let really_useful_vars = vars_of_equations equations in + let concl_vars = vars_of_prop (List.assoc id_concl full_reified_goal) in + list_uniq (List.sort compare (really_useful_vars @ concl_vars)) + in (* variables a introduire *) let to_introduce = add_stated_equations env solution_tree in let stated_vars = List.map (fun (v,_,_,_) -> v) to_introduce in let l_generalize_arg = List.map (fun (_,t,_,_) -> t) to_introduce in let hyp_stated_vars = List.map (fun (_,_,_,id) -> CCEqua id) to_introduce in (* L'environnement de base se construit en deux morceaux : - - les variables des équations utiles + - les variables des équations utiles (et de la conclusion) - les nouvelles variables declarées durant les preuves *) let all_vars_env = useful_vars @ stated_vars in let basic_env = @@ -1280,8 +1304,7 @@ let resolution env full_reified_goal systems_list = to_introduce in let reified_concl = match useful_hyps with - (Pnot p) :: _ -> - reified_of_proposition env (really_useful_prop useful_equa_id p) + (Pnot p) :: _ -> reified_of_proposition env p | _ -> reified_of_proposition env Pfalse in let l_reified_terms = (List.map @@ -1301,9 +1324,13 @@ let resolution env full_reified_goal systems_list = [| e.e_trace |] | ((O_left | O_mono) :: l) -> app coq_p_left [| loop l |] | (O_right :: l) -> app coq_p_right [| loop l |] in - app coq_pair_step - [| mk_nat (list_index e.e_origin.o_hyp l_hyps) ; - loop e.e_origin.o_path |] in + let correct_index = + let i = list_index e.e_origin.o_hyp l_hyps in + (* PL: it seems that additionnally introduced hyps are in the way during + normalization, hence this index shifting... *) + if i=0 then 0 else i +. List.length to_introduce + in + app coq_pair_step [| mk_nat correct_index; loop e.e_origin.o_path |] in let normalization_trace = mk_list (Lazy.force coq_h_step) (List.map normalize_equation equations) in diff --git a/contrib/setoid_ring/InitialRing.v b/contrib/setoid_ring/InitialRing.v index bbdcd443..f5f845c2 100644 --- a/contrib/setoid_ring/InitialRing.v +++ b/contrib/setoid_ring/InitialRing.v @@ -13,6 +13,7 @@ Require Import BinNat. Require Import Setoid. Require Import Ring_theory. Require Import Ring_polynom. +Import List. Set Implicit Arguments. @@ -172,7 +173,7 @@ Section ZMORPHISM. Lemma gen_Zeqb_ok : forall x y, Zeq_bool x y = true -> [x] == [y]. Proof. - intros x y H; repeat rewrite same_genZ. + intros x y H. assert (H1 := Zeqb_ok x y H);unfold IDphi in H1. rewrite H1;rrefl. Qed. @@ -365,9 +366,236 @@ Section NMORPHISM. End NMORPHISM. +(* Words on N : initial structure for almost-rings. *) +Definition Nword := list N. +Definition NwO : Nword := nil. +Definition NwI : Nword := 1%N :: nil. + +Definition Nwcons n (w : Nword) : Nword := + match w, n with + | nil, 0%N => nil + | _, _ => n :: w + end. + +Fixpoint Nwadd (w1 w2 : Nword) {struct w1} : Nword := + match w1, w2 with + | n1::w1', n2:: w2' => (n1+n2)%N :: Nwadd w1' w2' + | nil, _ => w2 + | _, nil => w1 + end. + +Definition Nwopp (w:Nword) : Nword := Nwcons 0%N w. + +Definition Nwsub w1 w2 := Nwadd w1 (Nwopp w2). + +Fixpoint Nwscal (n : N) (w : Nword) {struct w} : Nword := + match w with + | m :: w' => (n*m)%N :: Nwscal n w' + | nil => nil + end. + +Fixpoint Nwmul (w1 w2 : Nword) {struct w1} : Nword := + match w1 with + | 0%N::w1' => Nwopp (Nwmul w1' w2) + | n1::w1' => Nwsub (Nwscal n1 w2) (Nwmul w1' w2) + | nil => nil + end. +Fixpoint Nw_is0 (w : Nword) : bool := + match w with + | nil => true + | 0%N :: w' => Nw_is0 w' + | _ => false + end. + +Fixpoint Nweq_bool (w1 w2 : Nword) {struct w1} : bool := + match w1, w2 with + | n1::w1', n2::w2' => + if Neq_bool n1 n2 then Nweq_bool w1' w2' else false + | nil, _ => Nw_is0 w2 + | _, nil => Nw_is0 w1 + end. + +Section NWORDMORPHISM. + Variable R : Type. + Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). + Variable req : R -> R -> Prop. + Notation "0" := rO. Notation "1" := rI. + Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). + Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). + Notation "x == y" := (req x y). + Variable Rsth : Setoid_Theory R req. + Add Setoid R req Rsth as R_setoid5. + Ltac rrefl := gen_reflexivity Rsth. + Variable Reqe : ring_eq_ext radd rmul ropp req. + Add Morphism radd : radd_ext5. exact (Radd_ext Reqe). Qed. + Add Morphism rmul : rmul_ext5. exact (Rmul_ext Reqe). Qed. + Add Morphism ropp : ropp_ext5. exact (Ropp_ext Reqe). Qed. + + Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req. + Add Morphism rsub : rsub_ext7. exact (ARsub_ext Rsth Reqe ARth). Qed. + Ltac norm := gen_srewrite 0 1 radd rmul rsub ropp req Rsth Reqe ARth. + Ltac add_push := gen_add_push radd Rsth Reqe ARth. + + Fixpoint gen_phiNword (w : Nword) : R := + match w with + | nil => 0 + | n :: nil => gen_phiN rO rI radd rmul n + | N0 :: w' => - gen_phiNword w' + | n::w' => gen_phiN rO rI radd rmul n - gen_phiNword w' + end. + + Lemma gen_phiNword0_ok : forall w, Nw_is0 w = true -> gen_phiNword w == 0. +Proof. +induction w; simpl in |- *; intros; auto. + reflexivity. + + destruct a. + destruct w. + reflexivity. + + rewrite IHw in |- *; trivial. + apply (ARopp_zero Rsth Reqe ARth). + + discriminate. +Qed. + + Lemma gen_phiNword_cons : forall w n, + gen_phiNword (n::w) == gen_phiN rO rI radd rmul n - gen_phiNword w. +induction w. + destruct n; simpl in |- *; norm. + + intros. + destruct n; norm. +Qed. + + Lemma gen_phiNword_Nwcons : forall w n, + gen_phiNword (Nwcons n w) == gen_phiN rO rI radd rmul n - gen_phiNword w. +destruct w; intros. + destruct n; norm. + + unfold Nwcons in |- *. + rewrite gen_phiNword_cons in |- *. + reflexivity. +Qed. + + Lemma gen_phiNword_ok : forall w1 w2, + Nweq_bool w1 w2 = true -> gen_phiNword w1 == gen_phiNword w2. +induction w1; intros. + simpl in |- *. + rewrite (gen_phiNword0_ok _ H) in |- *. + reflexivity. + + rewrite gen_phiNword_cons in |- *. + destruct w2. + simpl in H. + destruct a; try discriminate. + rewrite (gen_phiNword0_ok _ H) in |- *. + norm. + + simpl in H. + rewrite gen_phiNword_cons in |- *. + case_eq (Neq_bool a n); intros. + rewrite H0 in H. + rewrite <- (Neq_bool_ok _ _ H0) in |- *. + rewrite (IHw1 _ H) in |- *. + reflexivity. + + rewrite H0 in H; discriminate H. +Qed. + + +Lemma Nwadd_ok : forall x y, + gen_phiNword (Nwadd x y) == gen_phiNword x + gen_phiNword y. +induction x; intros. + simpl in |- *. + norm. + + destruct y. + simpl Nwadd; norm. + + simpl Nwadd in |- *. + repeat rewrite gen_phiNword_cons in |- *. + rewrite (fun sreq => gen_phiN_add Rsth sreq (ARth_SRth ARth)) in |- *. + destruct Reqe; constructor; trivial. + + rewrite IHx in |- *. + norm. + add_push (- gen_phiNword x); reflexivity. +Qed. + +Lemma Nwopp_ok : forall x, gen_phiNword (Nwopp x) == - gen_phiNword x. +simpl in |- *. +unfold Nwopp in |- *; simpl in |- *. +intros. +rewrite gen_phiNword_Nwcons in |- *; norm. +Qed. + +Lemma Nwscal_ok : forall n x, + gen_phiNword (Nwscal n x) == gen_phiN rO rI radd rmul n * gen_phiNword x. +induction x; intros. + norm. + + simpl Nwscal in |- *. + repeat rewrite gen_phiNword_cons in |- *. + rewrite (fun sreq => gen_phiN_mult Rsth sreq (ARth_SRth ARth)) in |- *. + destruct Reqe; constructor; trivial. + + rewrite IHx in |- *. + norm. +Qed. + +Lemma Nwmul_ok : forall x y, + gen_phiNword (Nwmul x y) == gen_phiNword x * gen_phiNword y. +induction x; intros. + norm. + + destruct a. + simpl Nwmul in |- *. + rewrite Nwopp_ok in |- *. + rewrite IHx in |- *. + rewrite gen_phiNword_cons in |- *. + norm. + + simpl Nwmul in |- *. + unfold Nwsub in |- *. + rewrite Nwadd_ok in |- *. + rewrite Nwscal_ok in |- *. + rewrite Nwopp_ok in |- *. + rewrite IHx in |- *. + rewrite gen_phiNword_cons in |- *. + norm. +Qed. + +(* Proof that [.] satisfies morphism specifications *) + Lemma gen_phiNword_morph : + ring_morph 0 1 radd rmul rsub ropp req + NwO NwI Nwadd Nwmul Nwsub Nwopp Nweq_bool gen_phiNword. +constructor. + reflexivity. + + reflexivity. + + exact Nwadd_ok. + + intros. + unfold Nwsub in |- *. + rewrite Nwadd_ok in |- *. + rewrite Nwopp_ok in |- *. + norm. + + exact Nwmul_ok. + + exact Nwopp_ok. + + exact gen_phiNword_ok. +Qed. + +End NWORDMORPHISM. + + + (* syntaxification of constants in an abstract ring: - the inverse of gen_phiPOS - Why we do not reconnize only rI ?????? *) + the inverse of gen_phiPOS *) Ltac inv_gen_phi_pos rI add mul t := let rec inv_cst t := match t with @@ -390,6 +618,18 @@ End NMORPHISM. end in inv_cst t. +(* The (partial) inverse of gen_phiNword *) + Ltac inv_gen_phiNword rO rI add mul opp t := + match t with + rO => constr:NwO + | _ => + match inv_gen_phi_pos rI add mul t with + NotConstant => NotConstant + | ?p => constr:(Npos p::nil) + end + end. + + (* The inverse of gen_phiN *) Ltac inv_gen_phiN rO rI add mul t := match t with @@ -417,9 +657,18 @@ End NMORPHISM. end end. -(* A simpl tactic reconninzing nothing *) - Ltac inv_morph_nothing t := constr:(NotConstant). +(* A simple tactic recognizing only 0 and 1. The inv_gen_phiX above + are only optimisations that directly returns the reifid constant + instead of resorting to the constant propagation of the simplification + algorithm. *) +Ltac inv_gen_phi rO rI cO cI t := + match t with + | rO => cO + | rI => cI + end. +(* A simple tactic recognizing no constant *) + Ltac inv_morph_nothing t := constr:(NotConstant). Ltac coerce_to_almost_ring set ext rspec := match type of rspec with @@ -441,7 +690,7 @@ Ltac abstract_ring_morphism set ext rspec := | ring_theory _ _ _ _ _ _ _ => constr:(gen_phiZ_morph set ext rspec) | semi_ring_theory _ _ _ _ _ => constr:(gen_phiN_morph set ext rspec) | almost_ring_theory _ _ _ _ _ _ _ => - fail 1 "an almost ring cannot be abstract" + constr:(gen_phiNword_morph set ext rspec) | _ => fail 1 "bad ring structure" end. @@ -502,7 +751,7 @@ Ltac ring_elements set ext rspec pspec sspec rk := | ring_morph _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ => m | @semi_morph _ _ _ _ _ _ _ _ _ _ _ _ _ => constr:(SRmorph_Rmorph set m) - | _ => fail 2 " ici" + | _ => fail 2 "ring anomaly" end | _ => fail 1 "ill-formed ring kind" end in diff --git a/contrib/setoid_ring/Ring_tac.v b/contrib/setoid_ring/Ring_tac.v index 7419f184..b55c5443 100644 --- a/contrib/setoid_ring/Ring_tac.v +++ b/contrib/setoid_ring/Ring_tac.v @@ -108,31 +108,37 @@ Ltac FV Cst CstPow add mul sub opp pow t fv := (* syntaxification of ring expressions *) Ltac mkPolexpr C Cst CstPow radd rmul rsub ropp rpow t fv := let rec mkP t := + let f := match Cst t with | InitialRing.NotConstant => match t with | (radd ?t1 ?t2) => + fun _ => let e1 := mkP t1 in let e2 := mkP t2 in constr:(PEadd e1 e2) | (rmul ?t1 ?t2) => + fun _ => let e1 := mkP t1 in let e2 := mkP t2 in constr:(PEmul e1 e2) | (rsub ?t1 ?t2) => + fun _ => let e1 := mkP t1 in let e2 := mkP t2 in constr:(PEsub e1 e2) | (ropp ?t1) => + fun _ => let e1 := mkP t1 in constr:(PEopp e1) | (rpow ?t1 ?n) => match CstPow n with | InitialRing.NotConstant => - let p := Find_at t fv in constr:(PEX C p) - | ?c => let e1 := mkP t1 in constr:(PEpow e1 c) + fun _ => let p := Find_at t fv in constr:(PEX C p) + | ?c => fun _ => let e1 := mkP t1 in constr:(PEpow e1 c) end | _ => - let p := Find_at t fv in constr:(PEX C p) + fun _ => let p := Find_at t fv in constr:(PEX C p) end - | ?c => constr:(PEc c) - end + | ?c => fun _ => constr:(@PEc C c) + end in + f () in mkP t. Ltac ParseRingComponents lemma := diff --git a/contrib/setoid_ring/newring.ml4 b/contrib/setoid_ring/newring.ml4 index 8b2ce26b..f963fc9c 100644 --- a/contrib/setoid_ring/newring.ml4 +++ b/contrib/setoid_ring/newring.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(*i $Id: newring.ml4 9603 2007-02-07 00:41:16Z barras $ i*) +(*i $Id: newring.ml4 9968 2007-07-11 15:49:07Z barras $ i*) open Pp open Util @@ -166,8 +166,10 @@ let decl_constant na c = const_entry_boxed = true}, IsProof Lemma)) -let ltac_call tac args = +let ltac_call tac (args:glob_tactic_arg list) = TacArg(TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force tac),args)) +let ltac_acall tac (args:glob_tactic_arg list) = + TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force tac),args) let ltac_lcall tac args = TacArg(TacCall(dummy_loc, ArgVar(dummy_loc, id_of_string tac),args)) @@ -276,12 +278,18 @@ let coq_mk_reqe = my_constant "mk_reqe" let coq_semi_ring_theory = my_constant "semi_ring_theory" let coq_mk_seqe = my_constant "mk_seqe" +let ltac_inv_morph_gen = zltac"inv_gen_phi" let ltac_inv_morphZ = zltac"inv_gen_phiZ" let ltac_inv_morphN = zltac"inv_gen_phiN" +let ltac_inv_morphNword = zltac"inv_gen_phiNword" let coq_abstract = my_constant"Abstract" let coq_comp = my_constant"Computational" let coq_morph = my_constant"Morphism" +(* morphism *) +let coq_ring_morph = my_constant "ring_morph" +let coq_semi_morph = my_constant "semi_morph" + (* power function *) let ltac_inv_morph_nothing = zltac"inv_morph_nothing" let coq_pow_N_pow_N = my_constant "pow_N_pow_N" @@ -527,6 +535,18 @@ let dest_ring env sigma th_spec = | _ -> error "bad ring structure" +let dest_morph env sigma m_spec = + let m_typ = Retyping.get_type_of env sigma m_spec in + match kind_of_term m_typ with + App(f,[|r;zero;one;add;mul;sub;opp;req; + c;czero;cone;cadd;cmul;csub;copp;ceqb;phi|]) + when f = Lazy.force coq_ring_morph -> + (c,czero,cone,cadd,cmul,Some csub,Some copp,ceqb,phi) + | App(f,[|r;zero;one;add;mul;req;c;czero;cone;cadd;cmul;ceqb;phi|]) + when f = Lazy.force coq_semi_morph -> + (c,czero,cone,cadd,cmul,None,None,ceqb,phi) + | _ -> error "bad morphism structure" + type coeff_spec = Computational of constr (* equality test *) @@ -545,22 +565,34 @@ type cst_tac_spec = CstTac of raw_tactic_expr | Closed of reference list -let interp_cst_tac kind (zero,one,add,mul,opp) cst_tac = +let interp_cst_tac env sigma rk kind (zero,one,add,mul,opp) cst_tac = match cst_tac with Some (CstTac t) -> Tacinterp.glob_tactic t | Some (Closed lc) -> closed_term_ast (List.map Nametab.global lc) | None -> - (match opp, kind with - None, _ -> + (match rk, opp, kind with + Abstract, None, _ -> let t = ArgArg(dummy_loc,Lazy.force ltac_inv_morphN) in TacArg(TacCall(dummy_loc,t,List.map carg [zero;one;add;mul])) - | Some opp, Some _ -> + | Abstract, Some opp, Some _ -> let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morphZ) in TacArg(TacCall(dummy_loc,t,List.map carg [zero;one;add;mul;opp])) - | _ -> error"a tactic must be specified for an almost_ring") + | Abstract, Some opp, None -> + let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morphNword) in + TacArg + (TacCall(dummy_loc,t,List.map carg [zero;one;add;mul;opp])) + | Computational _,_,_ -> + let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morph_gen) in + TacArg + (TacCall(dummy_loc,t,List.map carg [zero;one;zero;one])) + | Morphism mth,_,_ -> + let (_,czero,cone,_,_,_,_,_,_) = dest_morph env sigma mth in + let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morph_gen) in + TacArg + (TacCall(dummy_loc,t,List.map carg [zero;one;czero;cone]))) let make_hyp env c = - let t = (Typeops.typing env c).uj_type in + let t = Retyping.get_type_of env Evd.empty c in lapp coq_mkhypo [|t;c|] let make_hyp_list env lH = @@ -608,7 +640,8 @@ let add_theory name rth eqth morphth cst_tac (pre,post) power sign = let lemma1 = decl_constant (string_of_id name^"_ring_lemma1") lemma1 in let lemma2 = decl_constant (string_of_id name^"_ring_lemma2") lemma2 in - let cst_tac = interp_cst_tac kind (zero,one,add,mul,opp) cst_tac in + let cst_tac = + interp_cst_tac env sigma morphth kind (zero,one,add,mul,opp) cst_tac in let pretac = match pre with Some t -> Tacinterp.glob_tactic t @@ -980,7 +1013,8 @@ let add_field_theory name fth eqth morphth cst_tac inj (pre,post) power sign = let lemma3 = decl_constant (string_of_id name^"_field_lemma3") lemma3 in let lemma4 = decl_constant (string_of_id name^"_field_lemma4") lemma4 in let cond_lemma = decl_constant (string_of_id name^"_lemma5") cond_lemma in - let cst_tac = interp_cst_tac kind (zero,one,add,mul,opp) cst_tac in + let cst_tac = + interp_cst_tac env sigma morphth kind (zero,one,add,mul,opp) cst_tac in let pretac = match pre with Some t -> Tacinterp.glob_tactic t diff --git a/contrib/subtac/FixSub.v b/contrib/subtac/FixSub.v index 46121ff1..f047b729 100644 --- a/contrib/subtac/FixSub.v +++ b/contrib/subtac/FixSub.v @@ -1,6 +1,8 @@ Require Import Wf. Require Import Coq.subtac.Utils. +(** Reformulation of the Wellfounded module using subsets where possible. *) + Section Well_founded. Variable A : Type. Variable R : A -> A -> Prop. @@ -75,23 +77,70 @@ Require Import Wf_nat. Require Import Lt. Section Well_founded_measure. -Variable A : Type. -Variable f : A -> nat. -Definition R := fun x y => f x < f y. + Variable A : Type. + Variable m : A -> nat. + + Section Acc. + + Variable P : A -> Type. + + Variable F_sub : forall x:A, (forall y: { y : A | m y < m x }, P (proj1_sig y)) -> P x. + + Fixpoint Fix_measure_F_sub (x : A) (r : Acc lt (m x)) {struct r} : P x := + F_sub x (fun y: { y : A | m y < m x} => Fix_measure_F_sub (proj1_sig y) + (Acc_inv r (m (proj1_sig y)) (proj2_sig y))). + + Definition Fix_measure_sub (x : A) := Fix_measure_F_sub x (lt_wf (m x)). + + End Acc. -Section FixPoint. + Section FixPoint. + Variable P : A -> Type. + + Variable F_sub : forall x:A, (forall y: { y : A | m y < m x }, P (proj1_sig y)) -> P x. + + Notation Fix_F := (Fix_measure_F_sub P F_sub) (only parsing). (* alias *) + + Definition Fix_measure (x:A) := Fix_measure_F_sub P F_sub x (lt_wf (m x)). + + Hypothesis + F_ext : + forall (x:A) (f g:forall y:{y:A | m y < m x}, P (`y)), + (forall y:{ y:A | m y < m x}, f y = g y) -> F_sub x f = F_sub x g. -Variable P : A -> Type. + Lemma Fix_measure_F_eq : + forall (x:A) (r:Acc lt (m x)), + F_sub x (fun (y:{y:A|m y < m x}) => Fix_F (`y) (Acc_inv r (m (proj1_sig y)) (proj2_sig y))) = Fix_F x r. + Proof. + intros x. + set (y := m x). + unfold Fix_measure_F_sub. + intros r ; case r ; auto. + Qed. + + Lemma Fix_measure_F_inv : forall (x:A) (r s:Acc lt (m x)), Fix_F x r = Fix_F x s. + Proof. + intros x r s. + rewrite (proof_irrelevance (Acc lt (m x)) r s) ; auto. + Qed. -Variable F_sub : forall x:A, (forall y: { y : A | f y < f x }, P (proj1_sig y)) -> P x. - -Fixpoint Fix_measure_F_sub (x : A) (r : Acc lt (f x)) {struct r} : P x := - F_sub x (fun y: { y : A | f y < f x} => Fix_measure_F_sub (proj1_sig y) - (Acc_inv r (f (proj1_sig y)) (proj2_sig y))). + Lemma Fix_measure_eq : forall x:A, Fix_measure x = F_sub x (fun (y:{y:A| m y < m x}) => Fix_measure (proj1_sig y)). + Proof. + intro x; unfold Fix_measure in |- *. + rewrite <- (Fix_measure_F_eq ). + apply F_ext; intros. + apply Fix_measure_F_inv. + Qed. -Definition Fix_measure_sub (x : A) := Fix_measure_F_sub x (lt_wf (f x)). + Lemma fix_measure_sub_eq : + forall x : A, + Fix_measure_sub P F_sub x = + let f_sub := F_sub in + f_sub x (fun {y : A | m y < m x}=> Fix_measure (`y)). + exact Fix_measure_eq. + Qed. -End FixPoint. + End FixPoint. End Well_founded_measure. diff --git a/contrib/subtac/FunctionalExtensionality.v b/contrib/subtac/FunctionalExtensionality.v index 1a12ac82..4610f346 100644 --- a/contrib/subtac/FunctionalExtensionality.v +++ b/contrib/subtac/FunctionalExtensionality.v @@ -1,3 +1,11 @@ +Lemma equal_f : forall A B : Type, forall (f g : A -> B), + f = g -> forall x, f x = g x. +Proof. + intros. + rewrite H. + auto. +Qed. + Axiom fun_extensionality : forall A B (f g : A -> B), (forall x, f x = g x) -> f = g. @@ -23,3 +31,17 @@ Proof. apply (fun_extensionality_dep _ _ _ _ H). rewrite H0 ; auto. Qed. + +Lemma fix_sub_measure_eq_ext : + forall (A : Type) (f : A -> nat) (P : A -> Type) + (F_sub : forall x : A, (forall {y : A | f y < f x}, P (`y)) -> P x), + forall x : A, + Fix_measure_sub A f P F_sub x = + F_sub x (fun {y : A | f y < f x}=> Fix_measure_sub A f P F_sub (`y)). +Proof. + intros ; apply Fix_measure_eq ; auto. + intros. + assert(f0 = g). + apply (fun_extensionality_dep _ _ _ _ H). + rewrite H0 ; auto. +Qed. diff --git a/contrib/subtac/Heq.v b/contrib/subtac/Heq.v new file mode 100644 index 00000000..f2b216d9 --- /dev/null +++ b/contrib/subtac/Heq.v @@ -0,0 +1,34 @@ +Require Export JMeq. + +(** Notation for heterogenous equality. *) + +Notation " [ x : X ] = [ y : Y ] " := (@JMeq X x Y y) (at level 0, X at next level, Y at next level). + +(** Do something on an heterogeneous equality appearing in the context. *) + +Ltac on_JMeq tac := + match goal with + | [ H : @JMeq ?x ?X ?y ?Y |- _ ] => tac H + end. + +(** Try to apply [JMeq_eq] to get back a regular equality when the two types are equal. *) + +Ltac simpl_one_JMeq := + on_JMeq + ltac:(fun H => let H' := fresh "H" in + assert (H' := JMeq_eq H) ; clear H ; rename H' into H). + +(** Repeat it for every possible hypothesis. *) + +Ltac simpl_JMeq := repeat simpl_one_JMeq. + +(** Just simplify an h.eq. without clearing it. *) + +Ltac simpl_one_dep_JMeq := + on_JMeq + ltac:(fun H => let H' := fresh "H" in + assert (H' := JMeq_eq H)). + + + + diff --git a/contrib/subtac/SubtacTactics.v b/contrib/subtac/SubtacTactics.v new file mode 100644 index 00000000..a00234dd --- /dev/null +++ b/contrib/subtac/SubtacTactics.v @@ -0,0 +1,158 @@ +Ltac induction_with_subterm c H := + let x := fresh "x" in + let y := fresh "y" in + (remember c as x ; rewrite <- y in H ; induction H ; subst). + +Ltac induction_on_subterm c := + let x := fresh "x" in + let y := fresh "y" in + (set(x := c) ; assert(y:x = c) by reflexivity ; clearbody x ; induction x ; inversion y ; try subst ; + clear y). + +Ltac induction_with_subterms c c' H := + let x := fresh "x" in + let y := fresh "y" in + let z := fresh "z" in + let w := fresh "w" in + (set(x := c) ; assert(y:x = c) by reflexivity ; + set(z := c') ; assert(w:z = c') by reflexivity ; + rewrite <- y in H ; rewrite <- w in H ; + induction H ; subst). + + +Ltac destruct_one_pair := + match goal with + | [H : (_ /\ _) |- _] => destruct H + | [H : prod _ _ |- _] => destruct H + end. + +Ltac destruct_pairs := repeat (destruct_one_pair). + +Ltac destruct_one_ex := + let tac H := let ph := fresh "H" in destruct H as [H ph] in + match goal with + | [H : (ex _) |- _] => tac H + | [H : (sig ?P) |- _ ] => tac H + | [H : (ex2 _) |- _] => tac H + end. + +Ltac destruct_exists := repeat (destruct_one_ex). + +Tactic Notation "destruct" "exist" ident(t) ident(Ht) := destruct t as [t Ht]. + +Tactic Notation "destruct" "or" ident(H) := destruct H as [H|H]. + +Tactic Notation "contradiction" "by" constr(t) := + let H := fresh in assert t as H by auto with * ; contradiction. + +Ltac discriminates := + match goal with + | [ H : ?x <> ?x |- _ ] => elim H ; reflexivity + | _ => discriminate + end. + +Ltac destruct_conjs := repeat (destruct_one_pair || destruct_one_ex). + +Ltac on_last_hyp tac := + match goal with + [ H : _ |- _ ] => tac H + end. + +Tactic Notation "on_last_hyp" tactic(t) := on_last_hyp t. + +Ltac revert_last := + match goal with + [ H : _ |- _ ] => revert H + end. + +Ltac reverse := repeat revert_last. + +Ltac on_call f tac := + match goal with + | H : ?T |- _ => + match T with + | context [f ?x ?y ?z ?w ?v ?u] => tac (f x y z w v u) + | context [f ?x ?y ?z ?w ?v] => tac (f x y z w v) + | context [f ?x ?y ?z ?w] => tac (f x y z w) + | context [f ?x ?y ?z] => tac (f x y z) + | context [f ?x ?y] => tac (f x y) + | context [f ?x] => tac (f x) + end + | |- ?T => + match T with + | context [f ?x ?y ?z ?w ?v ?u] => tac (f x y z w v u) + | context [f ?x ?y ?z ?w ?v] => tac (f x y z w v) + | context [f ?x ?y ?z ?w] => tac (f x y z w) + | context [f ?x ?y ?z] => tac (f x y z) + | context [f ?x ?y] => tac (f x y) + | context [f ?x] => tac (f x) + end + end. + +(* Destructs calls to f in hypothesis or conclusion, useful if f creates a subset object *) +Ltac destruct_call f := + let tac t := destruct t in on_call f tac. + +Ltac destruct_call_as f l := + let tac t := destruct t as l in on_call f tac. + +Tactic Notation "destruct_call" constr(f) := destruct_call f. +Tactic Notation "destruct_call" constr(f) "as" simple_intropattern(l) := destruct_call_as f l. + +Ltac myinjection := + let tac H := inversion H ; subst ; clear H in + match goal with + | [ H : ?f ?a = ?f' ?a' |- _ ] => tac H + | [ H : ?f ?a ?b = ?f' ?a' ?b' |- _ ] => tac H + | [ H : ?f ?a ?b ?c = ?f' ?a' ?b' ?c' |- _ ] => tac H + | [ H : ?f ?a ?b ?c ?d= ?f' ?a' ?b' ?c' ?d' |- _ ] => tac H + | [ H : ?f ?a ?b ?c ?d ?e= ?f' ?a' ?b' ?c' ?d' ?e' |- _ ] => tac H + | [ H : ?f ?a ?b ?c ?d ?e ?g= ?f' ?a' ?b' ?c' ?d' ?e' ?g' |- _ ] => tac H + | [ H : ?f ?a ?b ?c ?d ?e ?g ?h= ?f' ?a' ?b' ?c' ?d' ?e'?g' ?h' |- _ ] => tac H + | [ H : ?f ?a ?b ?c ?d ?e ?g ?h ?i = ?f' ?a' ?b' ?c' ?d' ?e'?g' ?h' ?i' |- _ ] => tac H + | [ H : ?f ?a ?b ?c ?d ?e ?g ?h ?i ?j = ?f' ?a' ?b' ?c' ?d' ?e'?g' ?h' ?i' ?j' |- _ ] => tac H + | _ => idtac + end. + +Ltac destruct_nondep H := let H0 := fresh "H" in assert(H0 := H); destruct H0. + +Ltac bang := + match goal with + | |- ?x => + match x with + | context [False_rect _ ?p] => elim p + end + end. + +Require Import Eqdep. + +Ltac elim_eq_rect := + match goal with + | [ |- ?t ] => + match t with + | context [ @eq_rect _ _ _ _ _ ?p ] => + let P := fresh "P" in + set (P := p); simpl in P ; + try ((case P ; clear P) || (clearbody P; rewrite (UIP_refl _ _ P); clear P)) + | context [ @eq_rect _ _ _ _ _ ?p _ ] => + let P := fresh "P" in + set (P := p); simpl in P ; + try ((case P ; clear P) || (clearbody P; rewrite (UIP_refl _ _ P); clear P)) + end + end. + +Ltac real_elim_eq_rect := + match goal with + | [ |- ?t ] => + match t with + | context [ @eq_rect _ _ _ _ _ ?p ] => + let P := fresh "P" in + set (P := p); simpl in P ; + ((case P ; clear P) || (clearbody P; rewrite (UIP_refl _ _ P); clear P)) + | context [ @eq_rect _ _ _ _ _ ?p _ ] => + let P := fresh "P" in + set (P := p); simpl in P ; + ((case P ; clear P) || (clearbody P; rewrite (UIP_refl _ _ P); clear P)) + end + end. +
\ No newline at end of file diff --git a/contrib/subtac/Utils.v b/contrib/subtac/Utils.v index 4a2208ce..76f49dd3 100644 --- a/contrib/subtac/Utils.v +++ b/contrib/subtac/Utils.v @@ -1,75 +1,65 @@ +Require Export Coq.subtac.SubtacTactics. + Set Implicit Arguments. -Notation "'fun' { x : A | P } => Q" := - (fun x:{x:A|P} => Q) - (at level 200, x ident, right associativity). +(** Wrap a proposition inside a subset. *) -Notation "( x & ? )" := (@exist _ _ x _) : core_scope. +Notation " {{ x }} " := (tt : { y : unit | x }). + +(** A simpler notation for subsets defined on a cartesian product. *) + +Notation "{ ( x , y ) : A | P }" := + (sig (fun anonymous : A => let (x,y) := anonymous in P)) + (x ident, y ident) : type_scope. + +(** Generates an obligation to prove False. *) Notation " ! " := (False_rect _ _). -Definition ex_pi1 (A : Prop) (P : A -> Prop) (t : ex P) : A. -intros. -induction t. -exact x. -Defined. +(** Abbreviation for first projection and hiding of proofs of subset objects. *) + +Notation " ` t " := (proj1_sig t) (at level 10) : core_scope. +Notation "( x & ? )" := (@exist _ _ x _) : core_scope. + +(** Coerces objects to their support before comparing them. *) -Lemma ex_pi2 : forall (A : Prop) (P : A -> Prop) (t : ex P), - P (ex_pi1 t). -intros A P. -dependent inversion t. -simpl. -exact p. -Defined. +Notation " x '`=' y " := ((x :>) = (y :>)) (at level 70). +(** Quantifying over subsets. *) + +Notation "'fun' { x : A | P } => Q" := + (fun x:{x:A|P} => Q) + (at level 200, x ident, right associativity). -Notation "` t" := (proj1_sig t) (at level 100) : core_scope. Notation "'forall' { x : A | P } , Q" := (forall x:{x:A|P}, Q) (at level 200, x ident, right associativity). -Lemma subset_simpl : forall (A : Set) (P : A -> Prop) - (t : sig P), P (` t). -Proof. -intros. -induction t. - simpl ; auto. -Qed. - -Ltac destruct_one_pair := - match goal with - | [H : (ex _) |- _] => destruct H - | [H : (ex2 _) |- _] => destruct H - | [H : (sig _) |- _] => destruct H - | [H : (_ /\ _) |- _] => destruct H -end. - -Ltac destruct_exists := repeat (destruct_one_pair) . - -Ltac subtac_simpl := simpl ; intros ; destruct_exists ; simpl in * ; try subst ; auto with arith. - -(* Destructs calls to f in hypothesis or conclusion, useful if f creates a subset object *) -Ltac destruct_call f := - match goal with - | H : ?T |- _ => - match T with - context [f ?x ?y ?z] => destruct (f x y z) - | context [f ?x ?y] => destruct (f x y) - | context [f ?x] => destruct (f x) - end - | |- ?T => - match T with - context [f ?x ?y ?z] => let n := fresh "H" in set (n:=f x y z); destruct n - | context [f ?x ?y] => let n := fresh "H" in set (n:=f x y); destruct n - | context [f ?x] => let n := fresh "H" in set (n:=f x); destruct n - end - end. +Require Import Coq.Bool.Sumbool. + +(** Construct a dependent disjunction from a boolean. *) + +Notation "'dec'" := (sumbool_of_bool) (at level 0). +(** The notations [in_right] and [in_left] construct objects of a dependent disjunction. *) + +Notation in_right := (@right _ _ _). +Notation in_left := (@left _ _ _). + +(** Default simplification tactic. *) + +Ltac subtac_simpl := simpl ; intros ; destruct_conjs ; simpl in * ; try subst ; + try (solve [ red ; intros ; discriminate ]) ; auto with *. + +(** Extraction directives *) Extraction Inline proj1_sig. Extract Inductive unit => "unit" [ "()" ]. Extract Inductive bool => "bool" [ "true" "false" ]. Extract Inductive sumbool => "bool" [ "true" "false" ]. -Extract Inductive prod => "pair" [ "" ]. -Extract Inductive sigT => "pair" [ "" ]. +(* Extract Inductive prod "'a" "'b" => " 'a * 'b " [ "(,)" ]. *) +(* Extract Inductive sigT => "prod" [ "" ]. *) Require Export ProofIrrelevance. +Require Export Coq.subtac.Heq. + +Delimit Scope program_scope with program. diff --git a/contrib/subtac/context.ml b/contrib/subtac/context.ml deleted file mode 100644 index 236b0ea5..00000000 --- a/contrib/subtac/context.ml +++ /dev/null @@ -1,35 +0,0 @@ -open Term -open Names - -type t = rel_declaration list (* name, optional coq interp, algorithmic type *) - -let assoc n t = - let _, term, typ = List.find (fun (x, _, _) -> x = n) t in - term, typ - -let assoc_and_index x l = - let rec aux i = function - (y, term, typ) :: tl -> if x = y then i, term, typ else aux (succ i) tl - | [] -> raise Not_found - in aux 0 l - -let id_of_name = function - Name id -> id - | Anonymous -> raise (Invalid_argument "id_of_name") -(* - -let subst_ctx ctx c = - let rec aux ((ctx, n, c) as acc) = function - (name, None, typ) :: tl -> - aux (((id_of_name name, None, rel_to_vars ctx typ) :: ctx), - pred n, c) tl - | (name, Some term, typ) :: tl -> - let t' = Term.substnl [term] n c in - aux (ctx, n, t') tl - | [] -> acc - in - let (x, _, z) = aux ([], pred (List.length ctx), c) (List.rev ctx) in - (x, rel_to_vars x z) -*) - -let subst_env env c = (env, c) diff --git a/contrib/subtac/context.mli b/contrib/subtac/context.mli deleted file mode 100644 index 671d6f36..00000000 --- a/contrib/subtac/context.mli +++ /dev/null @@ -1,5 +0,0 @@ -type t = Term.rel_declaration list -val assoc : 'a -> ('a * 'b * 'c) list -> 'b * 'c -val assoc_and_index : 'a -> ('a * 'b * 'c) list -> int * 'b * 'c -val id_of_name : Names.name -> Names.identifier -val subst_env : 'a -> 'b -> 'a * 'b diff --git a/contrib/subtac/eterm.ml b/contrib/subtac/eterm.ml index 1844fea5..2a84fdd0 100644 --- a/contrib/subtac/eterm.ml +++ b/contrib/subtac/eterm.ml @@ -11,52 +11,33 @@ open Evd open List open Pp open Util +open Subtac_utils -let reverse_array arr = - Array.of_list (List.rev (Array.to_list arr)) - let trace s = if !Options.debug then (msgnl s; msgerr s) else () -(** Utilities to find indices in lists *) -let list_index x l = - let rec aux i = function - k :: tl -> if k = x then i else aux (succ i) tl - | [] -> raise Not_found - in aux 0 l - -let list_assoc_index x l = - let rec aux i = function - (k, _, v) :: tl -> if k = x then i else aux (succ i) tl - | [] -> raise Not_found - in aux 0 l - - (** Substitute evar references in t using De Bruijn indices, where n binders were passed through. *) let subst_evar_constr evs n t = let seen = ref Intset.empty in - let evar_info id = - let rec aux i = function - (k, x) :: tl -> - if k = id then x else aux (succ i) tl - | [] -> raise Not_found - in aux 0 evs - in + let evar_info id = List.assoc id evs in let rec substrec depth c = match kind_of_term c with | Evar (k, args) -> - let (id, idstr), hyps, _, _ = + let (id, idstr), hyps, chop, _, _ = try evar_info k with Not_found -> anomaly ("eterm: existential variable " ^ string_of_int k ^ " not found") in seen := Intset.add id !seen; -(* (try trace (str "Evar " ++ int k ++ str " found, applied to " ++ int (Array.length args) ++ str "arguments," ++ *) -(* int (List.length hyps) ++ str " hypotheses"); with _ -> () ); *) (* Evar arguments are created in inverse order, and we must not apply to defined ones (i.e. LetIn's) *) + let args = + let n = match chop with None -> 0 | Some c -> c in + let (l, r) = list_chop n (List.rev (Array.to_list args)) in + List.rev r + in let args = let rec aux hyps args acc = match hyps, args with @@ -66,9 +47,13 @@ let subst_evar_constr evs n t = aux tlh tla acc | [], [] -> acc | _, _ -> acc (*failwith "subst_evars: invalid argument"*) - in aux hyps (Array.to_list args) [] - in - mkApp (mkVar idstr, Array.of_list args) + in aux hyps args [] + in + (try trace (str "Evar " ++ int k ++ str " found, applied to " ++ int (List.length args) ++ str "arguments," ++ + int (List.length hyps) ++ str " hypotheses" ++ spc () ++ + pp_list (fun x -> my_print_constr (Global.env ()) x) args); + with _ -> ()); + mkApp (mkVar idstr, Array.of_list args) | _ -> map_constr_with_binders succ substrec depth c in let t' = substrec 0 t in @@ -78,10 +63,7 @@ let subst_evar_constr evs n t = (** Substitute variable references in t using De Bruijn indices, where n binders were passed through. *) let subst_vars acc n t = - let var_index id = - let idx = list_index id acc in - idx + 1 - in + let var_index id = Util.list_index id acc in let rec substrec depth c = match kind_of_term c with | Var v -> (try mkRel (depth + (var_index v)) with Not_found -> c) | _ -> map_constr_with_binders succ substrec depth c @@ -89,47 +71,58 @@ let subst_vars acc n t = substrec 0 t (** Rewrite type of an evar ([ H1 : t1, ... Hn : tn |- concl ]) - to a product : forall H1 : t1, ..., forall Hn : tn, concl. + to a product : forall H1 : t1, ..., forall Hn : tn, concl. Changes evars and hypothesis references to variable references. + A little optimization: don't include unnecessary let-ins and their dependencies. *) -let etype_of_evar evs ev hyps = +let etype_of_evar evs hyps concl = let rec aux acc n = function (id, copt, t) :: tl -> let t', s = subst_evar_constr evs n t in let t'' = subst_vars acc 0 t' in - let copt', s = - match copt with + let rest, s' = aux (id :: acc) (succ n) tl in + let s' = Intset.union s s' in + (match copt with Some c -> - let c', s' = subst_evar_constr evs n c in - Some c', Intset.union s s' - | None -> None, s - in - let copt' = option_map (subst_vars acc 0) copt' in - let rest, s' = aux (id :: acc) (succ n) tl in - mkNamedProd_or_LetIn (id, copt', t'') rest, Intset.union s' s + if noccurn 1 rest then lift (-1) rest, s' + else + let c', s'' = subst_evar_constr evs n c in + let c' = subst_vars acc 0 c' in + mkNamedProd_or_LetIn (id, Some c', t'') rest, Intset.union s'' s' + | None -> + mkNamedProd_or_LetIn (id, None, t'') rest, s') | [] -> - let t', s = subst_evar_constr evs n ev.evar_concl in + let t', s = subst_evar_constr evs n concl in subst_vars acc 0 t', s in aux [] 0 (rev hyps) open Tacticals -let rec take n l = - if n = 0 then [] else List.hd l :: take (pred n) (List.tl l) - let trunc_named_context n ctx = let len = List.length ctx in - take (len - n) ctx + list_firstn (len - n) ctx -let eterm_obligations name nclen evm t tycon = +let rec chop_product n t = + if n = 0 then Some t + else + match kind_of_term t with + | Prod (_, _, b) -> if noccurn 1 b then chop_product (pred n) (Termops.pop b) else None + | _ -> None + +let eterm_obligations name nclen isevars evm fs t tycon = (* 'Serialize' the evars, we assume that the types of the existentials refer to previous existentials in the list only *) + trace (str " In eterm: isevars: " ++ my_print_evardefs isevars); + trace (str "Term given to eterm" ++ spc () ++ + Termops.print_constr_env (Global.env ()) t); let evl = List.rev (to_list evm) in let evn = let i = ref (-1) in List.rev_map (fun (id, ev) -> incr i; - (id, (!i, id_of_string (string_of_id name ^ "_obligation_" ^ string_of_int (succ !i))), ev)) evl + (id, (!i, id_of_string + (string_of_id name ^ "_obligation_" ^ string_of_int (succ !i))), + ev)) evl in let evts = (* Remove existential variables in types and build the corresponding products *) @@ -137,8 +130,22 @@ let eterm_obligations name nclen evm t tycon = (fun (id, (n, nstr), ev) l -> let hyps = Environ.named_context_of_val ev.evar_hyps in let hyps = trunc_named_context nclen hyps in - let evtyp, deps = etype_of_evar l ev hyps in - let y' = (id, ((n, nstr), hyps, evtyp, deps)) in + let evtyp, deps = etype_of_evar l hyps ev.evar_concl in + let evtyp, hyps, chop = + match chop_product fs evtyp with + Some t -> + (try + trace (str "Choped a product: " ++ spc () ++ + Termops.print_constr_env (Global.env ()) evtyp ++ str " to " ++ spc () ++ + Termops.print_constr_env (Global.env ()) t); + with _ -> ()); + t, trunc_named_context fs hyps, fs + | None -> evtyp, hyps, 0 + in + let loc, k = evar_source id isevars in + let opacity = match k with QuestionMark o -> o | _ -> true in + let opaque = if not opacity || chop <> fs then None else Some chop in + let y' = (id, ((n, nstr), hyps, opaque, evtyp, deps)) in y' :: l) evn [] in @@ -146,26 +153,20 @@ let eterm_obligations name nclen evm t tycon = subst_evar_constr evts 0 t in let evars = - List.map (fun (_, ((_, name), _, typ, deps)) -> name, typ, deps) evts + List.map (fun (_, ((_, name), _, opaque, typ, deps)) -> name, typ, not (opaque = None), deps) evts in -(* (try *) -(* trace (str "Term given to eterm" ++ spc () ++ *) -(* Termops.print_constr_env (Global.env ()) t); *) -(* trace (str "Term constructed in eterm" ++ spc () ++ *) -(* Termops.print_constr_env (Global.env ()) t'); *) -(* ignore(iter *) -(* (fun (name, typ, deps) -> *) -(* trace (str "Evar :" ++ spc () ++ str (string_of_id name) ++ *) -(* Termops.print_constr_env (Global.env ()) typ)) *) -(* evars); *) -(* with _ -> ()); *) + (try + trace (str "Term constructed in eterm" ++ spc () ++ + Termops.print_constr_env (Global.env ()) t'); + ignore(iter + (fun (name, typ, _, deps) -> + trace (str "Evar :" ++ spc () ++ str (string_of_id name) ++ + Termops.print_constr_env (Global.env ()) typ)) + evars); + with _ -> ()); Array.of_list (List.rev evars), t' -let mkMetas n = - let rec aux i acc = - if i > 0 then aux (pred i) (Evarutil.mk_new_meta () :: acc) - else acc - in aux n [] +let mkMetas n = list_tabulate (fun _ -> Evarutil.mk_new_meta ()) n (* let eterm evm t (tycon : types option) = *) (* let t, tycon, evs = eterm_term evm t tycon in *) diff --git a/contrib/subtac/eterm.mli b/contrib/subtac/eterm.mli index 3a571ee1..76994c06 100644 --- a/contrib/subtac/eterm.mli +++ b/contrib/subtac/eterm.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: eterm.mli 9326 2006-10-31 12:57:26Z msozeau $ i*) +(*i $Id: eterm.mli 9976 2007-07-12 11:58:30Z msozeau $ i*) open Tacmach open Term @@ -18,7 +18,10 @@ val mkMetas : int -> constr list (* val eterm_term : evar_map -> constr -> types option -> constr * types option * (identifier * types) list *) -val eterm_obligations : identifier -> int -> evar_map -> constr -> types option -> - (identifier * types * Intset.t) array * constr (* Obl. name, type as product and dependencies as indexes into the array *) +(* id, named context length, evars, number of + function prototypes to try to clear from evars contexts, object and optional type *) +val eterm_obligations : identifier -> int -> evar_defs -> evar_map -> int -> constr -> types option -> + (identifier * types * bool * Intset.t) array * constr + (* Obl. name, type as product, opacity (true = opaque) and dependencies as indexes into the array *) val etermtac : open_constr -> tactic diff --git a/contrib/subtac/g_subtac.ml4 b/contrib/subtac/g_subtac.ml4 index e31326e9..43a3bec4 100644 --- a/contrib/subtac/g_subtac.ml4 +++ b/contrib/subtac/g_subtac.ml4 @@ -10,7 +10,7 @@ Syntax for the subtac terms and types. Elaborated from correctness/psyntax.ml4 by Jean-Christophe Filliâtre *) -(* $Id: g_subtac.ml4 9588 2007-02-02 16:17:13Z herbelin $ *) +(* $Id: g_subtac.ml4 9976 2007-07-12 11:58:30Z msozeau $ *) (*i camlp4deps: "parsing/grammar.cma" i*) @@ -104,15 +104,36 @@ VERNAC COMMAND EXTEND Subtac_Obligations | [ "Next" "Obligation" ] -> [ Subtac_obligations.next_obligation None ] END +VERNAC COMMAND EXTEND Subtac_Solve_Obligation +| [ "Solve" "Obligation" integer(num) "of" ident(name) "using" tactic(t) ] -> + [ Subtac_obligations.try_solve_obligation num (Some name) (Tacinterp.interp t) ] +| [ "Solve" "Obligation" integer(num) "using" tactic(t) ] -> + [ Subtac_obligations.try_solve_obligation num None (Tacinterp.interp t) ] + END + VERNAC COMMAND EXTEND Subtac_Solve_Obligations -| [ "Solve" "Obligations" "of" ident(name) "using" tactic(t) ] -> [ Subtac_obligations.solve_obligations (Some name) (Tacinterp.interp t) ] -| [ "Solve" "Obligations" "using" tactic(t) ] -> [ Subtac_obligations.solve_obligations None (Tacinterp.interp t) ] +| [ "Solve" "Obligations" "of" ident(name) "using" tactic(t) ] -> + [ Subtac_obligations.try_solve_obligations (Some name) (Tacinterp.interp t) ] +| [ "Solve" "Obligations" "using" tactic(t) ] -> + [ Subtac_obligations.try_solve_obligations None (Tacinterp.interp t) ] +| [ "Solve" "Obligations" ] -> + [ Subtac_obligations.try_solve_obligations None (Subtac_obligations.default_tactic ()) ] + END + +VERNAC COMMAND EXTEND Subtac_Solve_All_Obligations +| [ "Solve" "All" "Obligations" "using" tactic(t) ] -> + [ Subtac_obligations.solve_all_obligations (Tacinterp.interp t) ] +| [ "Solve" "All" "Obligations" ] -> + [ Subtac_obligations.solve_all_obligations (Subtac_obligations.default_tactic ()) ] + END + +VERNAC COMMAND EXTEND Subtac_Admit_Obligations | [ "Admit" "Obligations" "of" ident(name) ] -> [ Subtac_obligations.admit_obligations (Some name) ] | [ "Admit" "Obligations" ] -> [ Subtac_obligations.admit_obligations None ] END VERNAC COMMAND EXTEND Subtac_Set_Solver -| [ "Obligations" "Tactic" ":=" tactic(t) ] -> [ Subtac_obligations.set_default_tactic (Tacinterp.interp t) ] +| [ "Obligations" "Tactic" ":=" tactic(t) ] -> [ Subtac_obligations.set_default_tactic (Tacinterp.glob_tactic t) ] END VERNAC COMMAND EXTEND Subtac_Show_Obligations diff --git a/contrib/subtac/subtac.ml b/contrib/subtac/subtac.ml index 5e46bead..8bc310d5 100644 --- a/contrib/subtac/subtac.ml +++ b/contrib/subtac/subtac.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: subtac.ml 9563 2007-01-31 09:37:18Z msozeau $ *) +(* $Id: subtac.ml 9976 2007-07-12 11:58:30Z msozeau $ *) open Global open Pp @@ -37,85 +37,11 @@ open Subtac_utils open Coqlib open Printer open Subtac_errors -open Context open Eterm let require_library dirpath = let qualid = (dummy_loc, qualid_of_dirpath (dirpath_of_string dirpath)) in Library.require_library [qualid] None -(* -let subtac_one_fixpoint env isevars (f, decl) = - let ((id, n, bl, typ, body), decl) = - Subtac_interp_fixpoint.rewrite_fixpoint env [] (f, decl) - in - let _ = - try trace (str "Working on a single fixpoint rewritten as: " ++ spc () ++ - Ppconstr.pr_constr_expr body) - with _ -> () - in ((id, n, bl, typ, body), decl) -*) - -let subtac_fixpoint isevars l = - (* TODO: Copy command.build_recursive *) - () -(* -let save id const (locality,kind) hook = - let {const_entry_body = pft; - const_entry_type = tpo; - const_entry_opaque = opacity } = const in - let l,r = match locality with - | Local when Lib.sections_are_opened () -> - let k = logical_kind_of_goal_kind kind in - let c = SectionLocalDef (pft, tpo, opacity) in - let _ = declare_variable id (Lib.cwd(), c, k) in - (Local, VarRef id) - | Local -> - let k = logical_kind_of_goal_kind kind in - let kn = declare_constant id (DefinitionEntry const, k) in - (Global, ConstRef kn) - | Global -> - let k = logical_kind_of_goal_kind kind in - let kn = declare_constant id (DefinitionEntry const, k) in - (Global, ConstRef kn) in - Pfedit.delete_current_proof (); - hook l r; - definition_message id - -let save_named opacity = - let id,(const,persistence,hook) = Pfedit.cook_proof () in - let const = { const with const_entry_opaque = opacity } in - save id const persistence hook - -let check_anonymity id save_ident = - if atompart_of_id id <> "Unnamed_thm" then - error "This command can only be used for unnamed theorem" -(* - message("Overriding name "^(string_of_id id)^" and using "^save_ident) -*) - -let save_anonymous opacity save_ident = - let id,(const,persistence,hook) = Pfedit.cook_proof () in - let const = { const with const_entry_opaque = opacity } in - check_anonymity id save_ident; - save save_ident const persistence hook - -let save_anonymous_with_strength kind opacity save_ident = - let id,(const,_,hook) = Pfedit.cook_proof () in - let const = { const with const_entry_opaque = opacity } in - check_anonymity id save_ident; - (* we consider that non opaque behaves as local for discharge *) - save save_ident const (Global, Proof kind) hook - -let subtac_end_proof = function - | Admitted -> admit () - | Proved (is_opaque,idopt) -> - if_verbose show_script (); - match idopt with - | None -> save_named is_opaque - | Some ((_,id),None) -> save_anonymous is_opaque id - | Some ((_,id),Some kind) -> save_anonymous_with_strength kind is_opaque id - - *) open Pp open Ppconstr @@ -142,48 +68,45 @@ let start_proof_com env isevars sopt kind (bl,t) hook = let print_subgoals () = Options.if_verbose (fun () -> msg (Printer.pr_open_subgoals ())) () -let subtac_utils_path = - make_dirpath (List.map id_of_string ["Utils";contrib_name;"Coq"]) -let utils_tac s = - lazy(make_kn (MPfile subtac_utils_path) (make_dirpath []) (mk_label s)) - -let utils_call tac args = - TacArg(TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force (utils_tac tac)),args)) - let start_proof_and_print env isevars idopt k t hook = start_proof_com env isevars idopt k t hook; print_subgoals () - (*if !pcoq <> None then (out_some !pcoq).start_proof ()*) + +let _ = Detyping.set_detype_anonymous (fun loc n -> RVar (loc, id_of_string ("Anonymous_REL_" ^ string_of_int n))) + +let assumption_message id = + Options.if_verbose message ((string_of_id id) ^ " is assumed") -let _ = Subtac_obligations.set_default_tactic - (Tacinterp.eval_tactic (utils_call "subtac_simpl" [])) +let declare_assumption env isevars idl is_coe k bl c = + if not (Pfedit.refining ()) then + let evm, c, typ = + Subtac_pretyping.subtac_process env isevars (snd (List.hd idl)) [] (Command.generalize_constr_expr c bl) None + in + List.iter (Command.declare_one_assumption is_coe k c) idl + else + errorlabstrm "Command.Assumption" + (str "Cannot declare an assumption while in proof editing mode.") + +let vernac_assumption env isevars kind l = + List.iter (fun (is_coe,(idl,c)) -> declare_assumption env isevars idl is_coe kind [] c) l let subtac (loc, command) = check_required_library ["Coq";"Init";"Datatypes"]; check_required_library ["Coq";"Init";"Specif"]; - (* check_required_library ["Coq";"Logic";"JMeq"]; *) +(* check_required_library ["Coq";"Logic";"JMeq"]; *) require_library "Coq.subtac.FixSub"; require_library "Coq.subtac.Utils"; + require_library "Coq.Logic.JMeq"; let env = Global.env () in let isevars = ref (create_evar_defs Evd.empty) in try - match command with + match command with VernacDefinition (defkind, (locid, id), expr, hook) -> (match expr with ProveBody (bl, c) -> Subtac_pretyping.subtac_proof env isevars id bl c None -(* let evm, c, ctyp = in *) -(* trace (str "Starting proof"); *) -(* Command.start_proof id goal_kind c hook; *) -(* trace (str "Started proof"); *) - | DefineBody (bl, _, c, tycon) -> - Subtac_pretyping.subtac_proof env isevars id bl c tycon - (* let tac = Eterm.etermtac (evm, c) in *) - (* trace (str "Starting proof"); *) - (* Command.start_proof id goal_kind ctyp hook; *) - (* trace (str "Started proof"); *) - (* Pfedit.by tac) *)) + Subtac_pretyping.subtac_proof env isevars id bl c tycon) | VernacFixpoint (l, b) -> let _ = trace (str "Building fixpoint") in ignore(Subtac_command.build_recursive l b) @@ -199,6 +122,8 @@ let subtac (loc, command) = start_proof_and_print env isevars (Some id) (Global, Proof thkind) (bl,t) hook + | VernacAssumption (stre,l) -> + vernac_assumption env isevars stre l (*| VernacEndProof e -> subtac_end_proof e*) @@ -237,6 +162,10 @@ let subtac (loc, command) = str "Uncoercible terms:" ++ spc () ++ x ++ spc () ++ str "and" ++ spc () ++ y in msg_warning cmds + + | Cases.PatternMatchingError (env, exn) as e -> + debug 2 (Himsg.explain_pattern_matching_error env exn); + raise e | Type_errors.TypeError (env, exn) as e -> debug 2 (Himsg.explain_type_error env exn); diff --git a/contrib/subtac/subtac.mli b/contrib/subtac/subtac.mli index 25922782..b51150aa 100644 --- a/contrib/subtac/subtac.mli +++ b/contrib/subtac/subtac.mli @@ -1,3 +1,2 @@ val require_library : string -> unit -val subtac_fixpoint : 'a -> 'b -> unit val subtac : Util.loc * Vernacexpr.vernac_expr -> unit diff --git a/contrib/subtac/subtac_cases.ml b/contrib/subtac/subtac_cases.ml index fbe1ac37..04cad7c0 100644 --- a/contrib/subtac/subtac_cases.ml +++ b/contrib/subtac/subtac_cases.ml @@ -8,6 +8,7 @@ (* $Id: cases.ml 9399 2006-11-22 16:11:53Z herbelin $ *) +open Cases open Util open Names open Nameops @@ -29,52 +30,6 @@ open Evarconv open Subtac_utils -(* Pattern-matching errors *) - -type pattern_matching_error = - | BadPattern of constructor * constr - | BadConstructor of constructor * inductive - | WrongNumargConstructor of constructor * int - | WrongNumargInductive of inductive * int - | WrongPredicateArity of constr * constr * constr - | NeedsInversion of constr * constr - | UnusedClause of cases_pattern list - | NonExhaustive of cases_pattern list - | CannotInferPredicate of (constr * types) array - -exception PatternMatchingError of env * pattern_matching_error - -let raise_pattern_matching_error (loc,ctx,te) = - Stdpp.raise_with_loc loc (PatternMatchingError(ctx,te)) - -let error_bad_pattern_loc loc cstr ind = - raise_pattern_matching_error (loc, Global.env(), BadPattern (cstr,ind)) - -let error_bad_constructor_loc loc cstr ind = - raise_pattern_matching_error (loc, Global.env(), BadConstructor (cstr,ind)) - -let error_wrong_numarg_constructor_loc loc env c n = - raise_pattern_matching_error (loc, env, WrongNumargConstructor(c,n)) - -let error_wrong_numarg_inductive_loc loc env c n = - raise_pattern_matching_error (loc, env, WrongNumargInductive(c,n)) - -let error_wrong_predicate_arity_loc loc env c n1 n2 = - raise_pattern_matching_error (loc, env, WrongPredicateArity (c,n1,n2)) - -let error_needs_inversion env x t = - raise (PatternMatchingError (env, NeedsInversion (x,t))) - -module type S = sig - val compile_cases : - loc -> - (type_constraint -> env -> rawconstr -> unsafe_judgment) * - Evd.evar_defs ref -> - type_constraint -> - env -> rawconstr option * tomatch_tuple * cases_clauses -> - unsafe_judgment -end - (************************************************************************) (* Pattern-matching compilation (Cases) *) (************************************************************************) @@ -1500,7 +1455,7 @@ let set_arity_signature dep n arsign tomatchl pred x = in decomp_block [] pred (tomatchl,arsign) -let prepare_predicate_from_tycon loc dep env isevars tomatchs sign c = +let oldprepare_predicate_from_tycon loc dep env isevars tomatchs sign c = let cook (n, l, env, signs) = function | c,IsInd (_,IndType(indf,realargs)) -> let indf' = lift_inductive_family n indf in @@ -1587,6 +1542,39 @@ let extract_arity_signature env0 tomatchl tmsign = | _ -> assert false in List.rev (buildrec 0 (tomatchl,tmsign)) +let extract_arity_signatures env0 tomatchl tmsign = + let get_one_sign tm (na,t) = + match tm with + | NotInd (bo,typ) -> + (match t with + | None -> [na,bo,typ] + | Some (loc,_,_,_) -> + user_err_loc (loc,"", + str "Unexpected type annotation for a term of non inductive type")) + | IsInd (_,IndType(indf,realargs)) -> + let (ind,params) = dest_ind_family indf in + let nrealargs = List.length realargs in + let realnal = + match t with + | Some (loc,ind',nparams,realnal) -> + if ind <> ind' then + user_err_loc (loc,"",str "Wrong inductive type"); + if List.length params <> nparams + or nrealargs <> List.length realnal then + anomaly "Ill-formed 'in' clause in cases"; + List.rev realnal + | None -> list_tabulate (fun _ -> Anonymous) nrealargs in + let arsign = fst (get_arity env0 indf) in + (na,None,build_dependent_inductive env0 indf) + ::(try List.map2 (fun x (_,c,t) ->(x,c,t)) realnal arsign with _ -> assert false) in + let rec buildrec = function + | [],[] -> [] + | (_,tm)::ltm, x::tmsign -> + let l = get_one_sign tm x in + l :: buildrec (ltm,tmsign) + | _ -> assert false + in List.rev (buildrec (tomatchl,tmsign)) + let inh_conv_coerce_to_tycon loc env isevars j tycon = match tycon with | Some p -> @@ -1596,44 +1584,80 @@ let inh_conv_coerce_to_tycon loc env isevars j tycon = | None -> j let out_ind = function IsInd (_, IndType(x, y)) -> (x, y) | _ -> assert(false) - -let list_mapi f l = - let rec aux n = function - [] -> [] - | hd :: tl -> f n hd :: aux (succ n) tl - in aux 0 l - -let constr_of_pat env isevars ty pat idents = - let rec typ env ty pat idents = + +let string_of_name name = + match name with + | Anonymous -> "anonymous" + | Name n -> string_of_id n + +let id_of_name n = id_of_string (string_of_name n) + +let make_prime_id name = + let str = string_of_name name in + id_of_string str, id_of_string (str ^ "'") + +let prime avoid name = + let previd, id = make_prime_id name in + previd, next_ident_away_from id avoid + +let make_prime avoid prevname = + let previd, id = prime !avoid prevname in + avoid := id :: !avoid; + previd, id + +let eq_id avoid id = + let hid = id_of_string ("Heq_" ^ string_of_id id) in + let hid' = next_ident_away_from hid avoid in + hid' + +let mk_eq typ x y = mkApp (Lazy.force eq_ind, [| typ; x ; y |]) +let mk_eq_refl typ x = mkApp (Lazy.force eq_refl, [| typ; x |]) +let mk_JMeq typ x typ' y = mkApp (Lazy.force Subtac_utils.jmeq_ind, [| typ; x ; typ'; y |]) +let mk_JMeq_refl typ x = mkApp (Lazy.force Subtac_utils.jmeq_refl, [| typ; x |]) + +let hole = RHole (dummy_loc, Evd.QuestionMark true) + +let context_of_arsign l = + let (x, _) = List.fold_right + (fun c (x, n) -> + (lift_rel_context n c @ x, List.length c + n)) + l ([], 0) + in x + +let constr_of_pat env isevars arsign pat avoid = + let rec typ env (ty, realargs) pat avoid = trace (str "Typing pattern " ++ Printer.pr_cases_pattern pat ++ str " in env " ++ print_env env ++ str" should have type: " ++ my_print_constr env ty); match pat with | PatVar (l,name) -> - let name, idents' = match name with - Name n -> name, idents + trace (str "Treating pattern variable " ++ str (string_of_id (id_of_name name))); + let name, avoid = match name with + Name n -> name, avoid | Anonymous -> - let n' = next_ident_away_from (id_of_string "wildcard") idents in - Name n', n' :: idents + let previd, id = prime avoid (Name (id_of_string "wildcard")) in + Name id, id :: avoid in -(* trace (str "Treating pattern variable " ++ str (string_of_id (id_of_name name))); *) - PatVar (l, name), [name, None, ty], mkRel 1, 1, idents' + trace (str "Treated pattern variable " ++ str (string_of_id (id_of_name name))); + PatVar (l, name), [name, None, ty] @ realargs, mkRel 1, ty, (List.map (fun x -> mkRel 1) realargs), 1, avoid | PatCstr (l,((_, i) as cstr),args,alias) -> - let _ind = inductive_of_constructor cstr in - let IndType (indf, realargs) = find_rectype env (Evd.evars_of !isevars) ty in + let cind = inductive_of_constructor cstr in + let IndType (indf, _) = find_rectype env (Evd.evars_of !isevars) (lift (-(List.length realargs)) ty) in let ind, params = dest_ind_family indf in + if ind <> cind then error_bad_constructor_loc l cstr ind; let cstrs = get_constructors env indf in let ci = cstrs.(i-1) in let nb_args_constr = ci.cs_nargs in assert(nb_args_constr = List.length args); - let idents' = idents in - let patargs, args, sign, env, n, m, idents' = + let patargs, args, sign, env, n, m, avoid = List.fold_right2 - (fun (na, c, t) ua (patargs, args, sign, env, n, m, idents) -> - let pat', sign', arg', n', idents' = typ env (lift (n - m) t) ua idents in + (fun (na, c, t) ua (patargs, args, sign, env, n, m, avoid) -> + let pat', sign', arg', typ', argtypargs, n', avoid = + typ env (lift (n - m) t, []) ua avoid + in let args' = arg' :: List.map (lift n') args in let env' = push_rels sign' env in - (pat' :: patargs, args', sign' @ sign, env', n' + n, succ m, idents')) - ci.cs_args (List.rev args) ([], [], [], env, 0, 0, idents') + (pat' :: patargs, args', sign' @ sign, env', n' + n, succ m, avoid)) + ci.cs_args (List.rev args) ([], [], [], env, 0, 0, avoid) in let args = List.rev args in let patargs = List.rev patargs in @@ -1641,120 +1665,244 @@ let constr_of_pat env isevars ty pat idents = let cstr = mkConstruct ci.cs_cstr in let app = applistc cstr (List.map (lift (List.length sign)) params) in let app = applistc app args in -(* trace (str "New pattern: " ++ Printer.pr_cases_pattern pat'); *) -(* let alname = if alias <> Anonymous then alias else Name (id_of_string "anon") in *) -(* let al = alname, Some (mkRel 1), lift 1 ty in *) - if alias <> Anonymous then - pat', (alias, Some app, ty) :: sign, lift 1 app, n + 1, idents' - else pat', sign, app, n, idents' + trace (str "Getting type of app: " ++ my_print_constr env app); + let apptype = Retyping.get_type_of env (Evd.evars_of !isevars) app in + trace (str "Family and args of apptype: " ++ my_print_constr env apptype); + let IndType (indf, realargs) = find_rectype env (Evd.evars_of !isevars) apptype in + trace (str "Got Family and args of apptype: " ++ my_print_constr env apptype); + match alias with + Anonymous -> + pat', sign, app, apptype, realargs, n, avoid + | Name id -> + let sign = (alias, None, lift m ty) :: sign in + let avoid = id :: avoid in + let sign, i, avoid = + try + let env = push_rels sign env in + isevars := the_conv_x_leq (push_rels sign env) (lift (succ m) ty) (lift 1 apptype) !isevars; + trace (str "convertible types for alias : " ++ my_print_constr env (lift (succ m) ty) + ++ my_print_constr env (lift 1 apptype)); + let eq_t = mk_eq (lift (succ m) ty) + (mkRel 1) (* alias *) + (lift 1 app) (* aliased term *) + in + let neq = eq_id avoid id in + (Name neq, Some (mkRel 0), eq_t) :: sign, 2, neq :: avoid + with Reduction.NotConvertible -> sign, 1, avoid + in + (* Mark the equality as a hole *) + pat', sign, lift i app, lift i apptype, realargs, n + i, avoid in - let pat', sign, y, z, idents = typ env ty pat idents in - let c = it_mkProd_or_LetIn y sign in - trace (str "Constr_of_pat gives: " ++ my_print_constr env c); - pat', (sign, y), idents - -let mk_refl typ a = mkApp (Lazy.force eq_refl, [| typ; a |]) - -let vars_of_ctx = - List.rev_map (fun (na, _, t) -> - match na with - Anonymous -> raise (Invalid_argument "vars_of_ctx") - | Name n -> RVar (dummy_loc, n)) - -(*let build_ineqs eqns pats = - List.fold_left - (fun (sign, c) eqn -> - let acc = fold_left3 - (fun acc prevpat (ppat_sign, ppat_c, ppat_ty) (pat, pat_c) -> - match acc with - None -> None - | Some (sign,len, c) -> - if is_included pat prevpat then - let lens = List.length ppat_sign in - let acc = - (lift_rels lens ppat_sign @ sign, - lens + len, - mkApp (Lazy.force eq_ind, - [| ppat_ty ; ppat_c ; - lift (lens + len) pat_c |]) :: c) - in Some acc - else None) - (sign, c) eqn.patterns eqn.c_patterns pats - in match acc with - None -> (sign, c) - | Some (sign, len, c) -> - it_mkProd_or_LetIn c sign - - ) - ([], []) eqns*) - -let constrs_of_pats typing_fun tycon env isevars eqns tomatchs = +(* let tycon, arity = mk_tycon_from_sign env isevars arsign arity in *) + let pat', sign, patc, patty, args, z, avoid = typ env (pi3 (List.hd arsign), List.tl arsign) pat avoid in + let c = it_mkProd_or_LetIn patc sign in + trace (str "arity signature is : " ++ my_print_rel_context env arsign); + trace (str "signature is : " ++ my_print_rel_context env sign); + trace (str "patty, args are : " ++ my_print_constr env (applistc patty args)); + trace (str "Constr_of_pat gives: " ++ my_print_constr env c); + trace (str "with args: " ++ pp_list (my_print_constr (push_rels sign env)) args); + pat', (sign, patc, (pi3 (List.hd arsign), args), pat'), avoid + + +(* shadows functional version *) +let eq_id avoid id = + let hid = id_of_string ("Heq_" ^ string_of_id id) in + let hid' = next_ident_away_from hid !avoid in + avoid := hid' :: !avoid; + hid' + +let rels_of_patsign = + List.map (fun ((na, b, t) as x) -> + match b with + | Some t' when kind_of_term t' = Rel 0 -> (na, None, t) + | _ -> x) + +let vars_of_ctx ctx = + let _, y = + List.fold_right (fun (na, b, t) (prev, vars) -> + match b with + | Some t' when kind_of_term t' = Rel 0 -> + prev, + (RApp (dummy_loc, + (RRef (dummy_loc, Lazy.force refl_ref)), [hole; RVar (dummy_loc, prev)])) :: vars + | _ -> + match na with + Anonymous -> raise (Invalid_argument "vars_of_ctx") + | Name n -> n, RVar (dummy_loc, n) :: vars) + ctx (id_of_string "vars_of_ctx: error", []) + in List.rev y + +let rec is_included x y = + match x, y with + | PatVar _, _ -> true + | _, PatVar _ -> true + | PatCstr (l, (_, i), args, alias), PatCstr (l', (_, i'), args', alias') -> + if i = i' then List.for_all2 is_included args args' + else false + +(* liftsign is the current pattern's signature length *) +let build_ineqs prevpatterns pats liftsign = + let _tomatchs = List.length pats in + let diffs = + List.fold_left + (fun c eqnpats -> + let acc = List.fold_left2 + (fun acc (ppat_sign, ppat_c, (ppat_ty, ppat_tyargs), ppat) + (curpat_sign, curpat_c, (curpat_ty, curpat_tyargs), curpat) -> + match acc with + None -> None + | Some (sign, len, n, c) -> (* FixMe: do not work with ppat_args *) + if is_included curpat ppat then + (* Length of previous pattern's signature *) + let lens = List.length ppat_sign in + (* Accumulated length of previous pattern's signatures *) + let len' = lens + len in + trace (str "Lifting " ++ my_print_constr Environ.empty_env curpat_c ++ str " by " + ++ int len'); + let acc = + ((* Jump over previous prevpat signs *) + lift_rel_context len ppat_sign @ sign, + len', + succ n, (* nth pattern *) + mkApp (Lazy.force eq_ind, + [| lift (lens + liftsign) ppat_ty ; + liftn liftsign (succ lens) ppat_c ; + lift len' curpat_c |]) :: + List.map + (fun t -> + liftn (List.length curpat_sign) (succ len') (* Jump over the curpat signature *) + (lift lens t (* Jump over this prevpat signature *))) c) + in Some acc + else None) + (Some ([], 0, 0, [])) eqnpats pats + in match acc with + None -> c + | Some (sign, len, _, c') -> + let conj = it_mkProd_or_LetIn (mk_not (mk_conj c')) + (lift_rel_context liftsign sign) + in + conj :: c) + [] prevpatterns + in match diffs with [] -> None + | _ -> Some (mk_conj diffs) + +let subst_rel_context k ctx subst = + let (_, ctx') = + List.fold_right + (fun (n, b, t) (k, acc) -> + (succ k, (n, option_map (substnl subst k) b, substnl subst k t) :: acc)) + ctx (k, []) + in ctx' + +let lift_rel_contextn n k sign = + let rec liftrec k = function + | (na,c,t)::sign -> + (na,option_map (liftn n k) c,type_app (liftn n k) t) + ::(liftrec (k-1) sign) + | [] -> [] + in + liftrec (rel_context_length sign + k) sign + +let constrs_of_pats typing_fun tycon env isevars eqns tomatchs sign neqs eqs arity = let i = ref 0 in - List.fold_left - (fun (branches, eqns) eqn -> - let _, newpatterns, pats = - List.fold_right2 (fun pat (_, ty) (idents, newpatterns, pats) -> - let x, y, z = constr_of_pat env isevars (type_of_tomatch ty) pat idents in - (z, x :: newpatterns, y :: pats)) - eqn.patterns tomatchs ([], [], []) - in - let rhs_rels, signlen = - List.fold_left (fun (renv, n) (sign,_) -> - ((lift_rel_context n sign) @ renv, List.length sign + n)) - ([], 0) pats in - let eqs, _, _ = List.fold_left2 - (fun (eqs, n, slen) (sign, c) (tm, ty) -> - let len = n + signlen in (* Number of already defined equations + signature *) - let csignlen = List.length sign in - let slen' = slen - csignlen in (* Lift to get pattern variables signature *) - let c = liftn (signlen - slen) signlen c in (* Lift to jump over previous ind signatures for pattern variables outside sign - in c (e.g. type arguments of constructors instanciated by variables ) *) - let cstr = lift (slen' + n) c in -(* trace (str "lift " ++ my_print_constr (push_rels sign env) c ++ *) -(* str " by " ++ int ++ str " to get " ++ *) -(* my_print_constr (push_rels sign env) cstr); *) - let app = - mkApp (Lazy.force eq_ind, - [| lift len (type_of_tomatch ty); cstr; lift len tm |]) - in app :: eqs, succ n, slen') - ([], 0, signlen) pats tomatchs - in - let eqs_rels = List.map (fun eq -> Name (id_of_string "H"), None, eq) eqs in -(* let ineqs = build_ineqs eqns newpatterns in *) - let rhs_rels' = eqs_rels @ rhs_rels in - let rhs_env = push_rels rhs_rels' env in -(* (try trace (str "branch env: " ++ print_env rhs_env) *) -(* with _ -> trace (str "error in print branch env")); *) - let tycon = lift_tycon (List.length eqs + signlen) tycon in - - let j = typing_fun tycon rhs_env eqn.rhs.it in -(* (try trace (str "in env: " ++ my_print_env rhs_env ++ str"," ++ *) -(* str "Typed branch: " ++ Prettyp.print_judgment rhs_env j); *) -(* with _ -> *) -(* trace (str "Error in typed branch pretty printing")); *) + let (x, y, z) = + List.fold_left + (fun (branches, eqns, prevpatterns) eqn -> + let _, newpatterns, pats = + List.fold_left2 + (fun (idents, newpatterns, pats) pat arsign -> + let pat', cpat, idents = constr_of_pat env isevars arsign pat idents in + (idents, pat' :: newpatterns, cpat :: pats)) + ([], [], []) eqn.patterns sign + in + let newpatterns = List.rev newpatterns and pats = List.rev pats in + let rhs_rels, pats, signlen = + List.fold_left + (fun (renv, pats, n) (sign,c, (s, args), p) -> + (* Recombine signatures and terms of all of the row's patterns *) +(* trace (str "treating pattern:" ++ my_print_constr Environ.empty_env c); *) + let sign' = lift_rel_context n sign in + let len = List.length sign' in + (sign' @ renv, + (* lift to get outside of previous pattern's signatures. *) + (sign', liftn n (succ len) c, (s, List.map (liftn n (succ len)) args), p) :: pats, + len + n)) + ([], [], 0) pats in + let pats, _ = List.fold_left + (* lift to get outside of past patterns to get terms in the combined environment. *) + (fun (pats, n) (sign, c, (s, args), p) -> + let len = List.length sign in + ((rels_of_patsign sign, lift n c, (s, List.map (lift n) args), p) :: pats, len + n)) + ([], 0) pats + in + let rhs_rels' = rels_of_patsign rhs_rels in + let _signenv = push_rel_context rhs_rels' env in +(* trace (str "Env with signature is: " ++ my_print_env _signenv); *) + let ineqs = build_ineqs prevpatterns pats signlen in + let eqs_rels = + let eqs = (*List.concat (List.rev eqs)*) context_of_arsign eqs in + let args, nargs = + List.fold_right (fun (sign, c, (_, args), _) (allargs,n) -> +(* trace (str "treating arg:" ++ my_print_constr Environ.empty_env c); *) + (args @ c :: allargs, List.length args + succ n)) + pats ([], 0) + in + let args = List.rev args in +(* trace (str " equalities " ++ my_print_rel_context Environ.empty_env eqs); *) +(* trace (str " args " ++ pp_list (my_print_constr _signenv) args); *) + (* Make room for substitution of prime arguments by constr patterns *) + let eqs' = lift_rel_contextn signlen nargs eqs in + let eqs'' = subst_rel_context 0 eqs' args in +(* trace (str " new equalities " ++ my_print_rel_context Environ.empty_env eqs'); *) +(* trace (str " subtituted equalities " ++ my_print_rel_context _signenv eqs''); *) + eqs'' + in + let rhs_rels', lift_ineqs = + match ineqs with + None -> eqs_rels @ rhs_rels', 0 + | Some ineqs -> + (* let _ = trace (str"Generated inequalities: " ++ my_print_constr env ineqs) in *) + lift_rel_context 1 eqs_rels @ ((Anonymous, None, ineqs) :: rhs_rels'), 1 + in + let rhs_env = push_rels rhs_rels' env in +(* (try trace (str "branch env: " ++ print_env rhs_env) *) +(* with _ -> trace (str "error in print branch env")); *) + let tycon = lift_tycon (List.length eqs_rels + lift_ineqs + signlen) tycon in + + let j = typing_fun tycon rhs_env eqn.rhs.it in +(* (try trace (str "in env: " ++ my_print_env rhs_env ++ str"," ++ *) +(* str "Typed branch: " ++ Prettyp.print_judgment rhs_env j); *) +(* with _ -> *) +(* trace (str "Error in typed branch pretty printing")); *) let bbody = it_mkLambda_or_LetIn j.uj_val rhs_rels' and btype = it_mkProd_or_LetIn j.uj_type rhs_rels' in let branch_name = id_of_string ("branch_" ^ (string_of_int !i)) in let branch_decl = (Name branch_name, Some (lift !i bbody), (lift !i btype)) in -(* (try trace (str "Branch decl: " ++ pr_rel_decl env (Name branch_name, Some bbody, btype)) *) -(* with _ -> trace (str "Error in branch decl pp")); *) + (* (try trace (str "Branch decl: " ++ pr_rel_decl env (Name branch_name, Some bbody, btype)) *) + (* with _ -> trace (str "Error in branch decl pp")); *) let branch = let bref = RVar (dummy_loc, branch_name) in - match vars_of_ctx rhs_rels with - [] -> bref - | l -> RApp (dummy_loc, bref, l) + match vars_of_ctx rhs_rels with + [] -> bref + | l -> RApp (dummy_loc, bref, l) in -(* let branch = *) -(* List.fold_left (fun br (eqH, _, t) -> RLambda (dummy_loc, eqH, RHole (dummy_loc, Evd.InternalHole), br)) branch eqs_rels *) -(* in *) -(* (try trace (str "New branch: " ++ Printer.pr_rawconstr branch) *) -(* with _ -> trace (str "Error in new branch pp")); *) - incr i; - let rhs = { eqn.rhs with it = branch } in - (branch_decl :: branches, - { eqn with patterns = newpatterns; rhs = rhs } :: eqns)) - ([], []) eqns - + let branch = match ineqs with + Some _ -> RApp (dummy_loc, branch, [ hole ]) + | None -> branch + in + (* let branch = *) + (* List.fold_left (fun br (eqH, _, t) -> RLambda (dummy_loc, eqH, RHole (dummy_loc, Evd.InternalHole), br)) branch eqs_rels *) + (* in *) + (* (try trace (str "New branch: " ++ Printer.pr_rawconstr branch) *) + (* with _ -> trace (str "Error in new branch pp")); *) + incr i; + let rhs = { eqn.rhs with it = branch } in + (branch_decl :: branches, + { eqn with patterns = newpatterns; rhs = rhs } :: eqns, + pats :: prevpatterns)) + ([], [], []) eqns + in x, y + (* liftn_rel_declaration *) @@ -1769,52 +1917,28 @@ let constrs_of_pats typing_fun tycon env isevars eqns tomatchs = * A type constraint but no annotation case: it is assumed non dependent. *) -let prepare_predicate_from_tycon loc typing_fun isevars env tomatchs arsign tycon = - (* We extract the signature of the arity *) -(* List.iter *) -(* (fun arsign -> *) -(* trace (str "arity signature: " ++ my_print_rel_context env arsign)) *) -(* arsign; *) -(* let env = List.fold_right push_rels arsign env in *) - let allnames = List.rev (List.map (List.map pi1) arsign) in - let nar = List.fold_left (fun n names -> List.length names + n) 0 allnames in - let pred = out_some (valcon_of_tycon tycon) in - let predcclj, pred, neqs = - let _, _, eqs = - List.fold_left2 - (fun (neqs, slift, eqs) ctx (tm,ty) -> - let len = List.length ctx in - let _name, _, _typ' = List.hd ctx in (* FixMe: Ignoring dependent inductives *) - let eq = mkApp (Lazy.force eq_ind, - [| lift (neqs + nar) (type_of_tomatch ty); - mkRel (neqs + slift); - lift (neqs + nar) tm|]) - in - (succ neqs, slift - len, (Anonymous, None, eq) :: eqs)) - (0, nar, []) (List.rev arsign) tomatchs - in - let len = List.length eqs in - it_mkProd_wo_LetIn (lift (nar + len) pred) eqs, pred, len - in - let predccl = nf_isevar !isevars predcclj in -(* let env' = List.fold_right push_rel_context arsign env in *) -(* trace (str " Env:" ++ my_print_env env' ++ str" Predicate: " ++ my_print_constr env' predccl); *) - build_initial_predicate true allnames predccl, pred - let prepare_predicate_from_rettyp loc typing_fun isevars env tomatchs sign tycon rtntyp = (* We extract the signature of the arity *) let arsign = extract_arity_signature env tomatchs sign in +(* (try List.iter *) +(* (fun arsign -> *) +(* trace (str "arity signature: " ++ my_print_rel_context env arsign)) *) +(* arsign; *) +(* with _ -> trace (str "error in arity signature printing")); *) let env = List.fold_right push_rels arsign env in let allnames = List.rev (List.map (List.map pi1) arsign) in - let predcclj = typing_fun (mk_tycon (new_Type ())) env rtntyp in -(* let _ = *) -(* option_map (fun tycon -> *) -(* isevars := Coercion.inh_conv_coerces_to loc env !isevars predcclj.uj_val *) -(* (lift_tycon_type (List.length arsign) tycon)) *) -(* tycon *) -(* in *) - let predccl = (j_nf_isevar !isevars predcclj).uj_val in - Some (build_initial_predicate true allnames predccl) + match rtntyp with + | Some rtntyp -> + let predcclj = typing_fun (mk_tycon (new_Type ())) env rtntyp in + let predccl = (j_nf_isevar !isevars predcclj).uj_val in + Some (build_initial_predicate true allnames predccl) + | None -> + match valcon_of_tycon tycon with + | Some ty -> + let names,pred = + oldprepare_predicate_from_tycon loc false env isevars tomatchs sign ty + in Some (build_initial_predicate true names pred) + | None -> None let lift_ctx n ctx = let ctx', _ = @@ -1837,70 +1961,240 @@ let abstract_tomatch env tomatchs = ([], [], []) tomatchs in List.rev prev, ctx +let is_dependent_ind = function + IsInd (_, IndType (indf, args)) when List.length args > 0 -> true + | _ -> false + +let build_dependent_signature env evars avoid tomatchs arsign = + let avoid = ref avoid in + let arsign = List.rev arsign in + let allnames = List.rev (List.map (List.map pi1) arsign) in + let nar = List.fold_left (fun n names -> List.length names + n) 0 allnames in + let eqs, neqs, refls, slift, arsign' = + List.fold_left2 + (fun (eqs, neqs, refl_args, slift, arsigns) (tm, ty) arsign -> + (* The accumulator: + previous eqs, + number of previous eqs, + lift to get outside eqs and in the introduced variables ('as' and 'in'), + new arity signatures + *) + match ty with + IsInd (ty, IndType (indf, args)) when List.length args > 0 -> + (* Build the arity signature following the names in matched terms as much as possible *) + let argsign = List.tl arsign in (* arguments in inverse application order *) + let (appn, appb, appt) as _appsign = List.hd arsign in (* The matched argument *) +(* let _ = trace (str "Working on dependent arg: " ++ my_print_rel_context *) +(* (push_rel_context argsign env) [_appsign]) *) +(* in *) + let argsign = List.rev argsign in (* arguments in application order *) + let env', nargeqs, argeqs, refl_args, slift, argsign' = + List.fold_left2 + (fun (env, nargeqs, argeqs, refl_args, slift, argsign') arg (name, b, t) -> +(* trace (str "Matching indexes: " ++ my_print_constr env arg ++ *) +(* str " and " ++ my_print_rel_context env [(name,b,t)]); *) + let argt = Retyping.get_type_of env evars arg in + let eq, refl_arg = + if Reductionops.is_conv env evars argt t then + (mk_eq (lift (nargeqs + slift) argt) + (mkRel (nargeqs + slift)) + (lift (nargeqs + nar) arg), + mk_eq_refl argt arg) + else + (mk_JMeq (lift (nargeqs + slift) appt) + (mkRel (nargeqs + slift)) + (lift (nargeqs + nar) argt) + (lift (nargeqs + nar) arg), + mk_JMeq_refl argt arg) + in + let previd, id = + let name = + match kind_of_term arg with + Rel n -> pi1 (lookup_rel n (rel_context env)) + | _ -> name + in + make_prime avoid name + in + (env, succ nargeqs, + (Name (eq_id avoid previd), None, eq) :: argeqs, + refl_arg :: refl_args, + pred slift, + (Name id, b, t) :: argsign')) + (env, 0, [], [], slift, []) args argsign + in +(* trace (str "neqs: " ++ int neqs ++ spc () ++ *) +(* str "nargeqs: " ++ int nargeqs ++spc () ++ *) +(* str "slift: " ++ int slift ++spc () ++ *) +(* str "nar: " ++ int nar); *) + let eq = mk_JMeq + (lift (nargeqs + slift) appt) + (mkRel (nargeqs + slift)) + (lift (nargeqs + nar) ty) + (lift (nargeqs + nar) tm) + in + let refl_eq = mk_JMeq_refl ty tm in + let previd, id = make_prime avoid appn in + (((Name (eq_id avoid previd), None, eq) :: argeqs) :: eqs, + succ nargeqs, + refl_eq :: refl_args, + pred slift, + (((Name id, appb, appt) :: argsign') :: arsigns)) + + | _ -> + (* Non dependent inductive or not inductive, just use a regular equality *) + let (name, b, typ) = match arsign with [x] -> x | _ -> assert(false) in + let previd, id = make_prime avoid name in + let arsign' = (Name id, b, typ) in +(* let _ = trace (str "Working on arg: " ++ my_print_rel_context *) +(* env [arsign']) *) +(* in *) + let tomatch_ty = type_of_tomatch ty in + let eq = + mk_eq (lift nar tomatch_ty) + (mkRel slift) (lift nar tm) +(* mk_eq (lift (neqs + nar) tomatch_ty) *) +(* (mkRel (neqs + slift)) (lift (neqs + nar) tm) *) + in + ([(Name (eq_id avoid previd), None, eq)] :: eqs, succ neqs, + (mk_eq_refl tomatch_ty tm) :: refl_args, + pred slift, (arsign' :: []) :: arsigns)) + ([], 0, [], nar, []) tomatchs arsign + in + let arsign'' = List.rev arsign' in + assert(slift = 0); (* we must have folded over all elements of the arity signature *) +(* begin try *) +(* List.iter *) +(* (fun arsign -> *) +(* trace (str "old arity signature: " ++ my_print_rel_context env arsign)) *) +(* arsign; *) + List.iter + (fun c -> + trace (str "new arity signature: " ++ my_print_rel_context env c)) + (arsign''); +(* with _ -> trace (str "error in arity signature printing") *) +(* end; *) + let env' = push_rel_context (context_of_arsign arsign') env in + let _eqsenv = push_rel_context (context_of_arsign eqs) env' in + (try trace (str "Where env with eqs is: " ++ my_print_env _eqsenv); + trace (str "args: " ++ List.fold_left (fun acc x -> acc ++ my_print_constr env x) + (mt()) refls) + with _ -> trace (str "error in equalities signature printing")); + arsign'', allnames, nar, eqs, neqs, refls + +(* let len = List.length eqs in *) +(* it_mkProd_wo_LetIn (lift (nar + len) pred) eqs, pred, len *) + + (**************************************************************************) (* Main entry of the matching compilation *) -let compile_cases loc (typing_fun, isevars) (tycon : Evarutil.type_constraint) env (predopt, tomatchl, eqns)= - let tycon0 = tycon in +let liftn_rel_context n k sign = + let rec liftrec k = function + | (na,c,t)::sign -> + (na,option_map (liftn n k) c,type_app (liftn n k) t) + ::(liftrec (k-1) sign) + | [] -> [] + in + liftrec (k + rel_context_length sign) sign + +let nf_evars_env evar_defs (env : env) : env = + let nf t = nf_isevar evar_defs t in + let env0 : env = reset_context env in + let f e (na, b, t) e' : env = + Environ.push_named (na, option_map nf b, nf t) e' + in + let env' = Environ.fold_named_context f ~init:env0 env in + Environ.fold_rel_context (fun e (na, b, t) e' -> Environ.push_rel (na, option_map nf b, nf t) e') + ~init:env' env + +let compile_cases loc (typing_fun, isevars) (tycon : Evarutil.type_constraint) env (predopt, tomatchl, eqns) = (* We build the matrix of patterns and right-hand-side *) let matx = matx_of_eqns env eqns in (* We build the vector of terms to match consistently with the *) (* constructors found in patterns *) let tomatchs = coerce_to_indtype typing_fun isevars env matx tomatchl in +(* isevars := nf_evar_defs !isevars; *) +(* let env = nf_evars_env !isevars (env : env) in *) +(* trace (str "Evars : " ++ my_print_evardefs !isevars); *) +(* trace (str "Env : " ++ my_print_env env); *) + let tomatchs, tomatchs_lets = abstract_tomatch env tomatchs in let tomatchs_len = List.length tomatchs_lets in let tycon = lift_tycon tomatchs_len tycon in let env = push_rel_context tomatchs_lets env in - match predopt with - None -> - let lets, matx = constrs_of_pats typing_fun tycon env isevars matx tomatchs in - let matx = List.rev matx in - let len = List.length lets in - let sign = - let arsign = extract_arity_signature env tomatchs (List.map snd tomatchl) in - List.map (lift_rel_context len) arsign - in - let env = push_rels lets env in - let matx = List.map (fun eqn -> { eqn with rhs = { eqn.rhs with rhs_env = env } }) matx in - let tycon = lift_tycon len tycon in - let tomatchs = List.map (fun (x, y) -> lift len x, lift_tomatch_type len y) tomatchs in - let args = List.map (fun (tm,ty) -> mk_refl (type_of_tomatch ty) tm) tomatchs in - - (* We build the elimination predicate if any and check its consistency *) - (* with the type of arguments to match *) - let pred, opred = prepare_predicate_from_tycon loc typing_fun isevars env tomatchs sign tycon in - (* We push the initial terms to match and push their alias to rhs' envs *) - (* names of aliases will be recovered from patterns (hence Anonymous here) *) - let initial_pushed = List.map (fun tm -> Pushed (tm,[])) tomatchs in - - let pb = - { env = env; - isevars = isevars; - pred = Some pred; - tomatch = initial_pushed; - history = start_history (List.length initial_pushed); - mat = matx; - caseloc = loc; - typing_function = typing_fun } in - - let _, j = compile pb in - (* We check for unused patterns *) - List.iter (check_unused_pattern env) matx; - let ty = out_some (valcon_of_tycon tycon0) in - let body = it_mkLambda_or_LetIn (applistc j.uj_val args) lets in - let j = - { uj_val = it_mkLambda_or_LetIn body tomatchs_lets; - uj_type = ty; } - in - inh_conv_coerce_to_tycon loc env isevars j tycon0 - - | Some rtntyp -> - (* We build the elimination predicate if any and check its consistency *) - (* with the type of arguments to match *) - let tmsign = List.map snd tomatchl in - let pred = prepare_predicate_from_rettyp loc typing_fun isevars env tomatchs tmsign tycon rtntyp in - + let _isdep = List.exists (fun (x, y) -> is_dependent_ind y) tomatchs in + if predopt = None then + let len = List.length eqns in + let sign, allnames, signlen, eqs, neqs, args = + (* The arity signature *) + let arsign = extract_arity_signatures env tomatchs (List.map snd tomatchl) in + (* Build the dependent arity signature, the equalities which makes + the first part of the predicate and their instantiations. *) + trace (str "Arity signatures : " ++ my_print_rel_context env (context_of_arsign arsign)); + let avoid = [] in + build_dependent_signature env (Evd.evars_of !isevars) avoid tomatchs arsign + + in + let tycon_constr = + match valcon_of_tycon tycon with + | None -> mkExistential env isevars + | Some t -> t + in + let lets, matx = + (* Type the rhs under the assumption of equations *) + constrs_of_pats typing_fun tycon env isevars matx tomatchs sign neqs + (eqs : rel_context list) (lift (signlen + neqs) tycon_constr) in + + let matx = List.rev matx in + let _ = assert(len = List.length lets) in + let env = push_rels lets env in + let matx = List.map (fun eqn -> { eqn with rhs = { eqn.rhs with rhs_env = env } }) matx in + let tomatchs = List.map (fun (x, y) -> lift len x, lift_tomatch_type len y) tomatchs in + let args = List.rev_map (lift len) args in + let sign = List.map (lift_rel_context len) sign in + let pred = it_mkProd_wo_LetIn (lift (signlen + neqs) tycon_constr) + (context_of_arsign eqs) in + + let pred = liftn len (succ signlen) pred in +(* it_mkProd_wo_LetIn (lift (len + signlen + neqs) tycon_constr) (liftn_rel_context len signlen eqs) in*) + (* We build the elimination predicate if any and check its consistency *) + (* with the type of arguments to match *) + let _signenv = List.fold_right push_rels sign env in +(* trace (str "Using predicate: " ++ my_print_constr signenv pred ++ str " in env: " ++ my_print_env signenv ++ str " len is " ++ int len); *) + + let pred = + (* prepare_predicate_from_tycon loc typing_fun isevars env tomatchs eqs allnames signlen sign tycon in *) + build_initial_predicate true allnames pred in + (* We push the initial terms to match and push their alias to rhs' envs *) + (* names of aliases will be recovered from patterns (hence Anonymous here) *) + let initial_pushed = List.map (fun tm -> Pushed (tm,[])) tomatchs in + + let pb = + { env = env; + isevars = isevars; + pred = Some pred; + tomatch = initial_pushed; + history = start_history (List.length initial_pushed); + mat = matx; + caseloc = loc; + typing_function = typing_fun } in + + let _, j = compile pb in + (* We check for unused patterns *) + List.iter (check_unused_pattern env) matx; + let body = it_mkLambda_or_LetIn (applistc j.uj_val args) lets in + let j = + { uj_val = it_mkLambda_or_LetIn body tomatchs_lets; + uj_type = lift (-tomatchs_len) (nf_isevar !isevars tycon_constr); } + in j +(* inh_conv_coerce_to_tycon loc env isevars j tycon0 *) + else + (* We build the elimination predicate if any and check its consistency *) + (* with the type of arguments to match *) + let tmsign = List.map snd tomatchl in + let pred = prepare_predicate_from_rettyp loc typing_fun isevars env tomatchs tmsign tycon predopt in + (* We push the initial terms to match and push their alias to rhs' envs *) (* names of aliases will be recovered from patterns (hence Anonymous here) *) let initial_pushed = List.map (fun tm -> Pushed (tm,[])) tomatchs in diff --git a/contrib/subtac/subtac_cases.mli b/contrib/subtac/subtac_cases.mli index 9e902126..02fe016d 100644 --- a/contrib/subtac/subtac_cases.mli +++ b/contrib/subtac/subtac_cases.mli @@ -19,32 +19,5 @@ open Rawterm open Evarutil (*i*) -type pattern_matching_error = - | BadPattern of constructor * constr - | BadConstructor of constructor * inductive - | WrongNumargConstructor of constructor * int - | WrongNumargInductive of inductive * int - | WrongPredicateArity of constr * constr * constr - | NeedsInversion of constr * constr - | UnusedClause of cases_pattern list - | NonExhaustive of cases_pattern list - | CannotInferPredicate of (constr * types) array - -exception PatternMatchingError of env * pattern_matching_error - -val error_wrong_numarg_constructor_loc : loc -> env -> constructor -> int -> 'a - -val error_wrong_numarg_inductive_loc : loc -> env -> inductive -> int -> 'a - -(*s Compilation of pattern-matching. *) - -module type S = sig - val compile_cases : - loc -> - (type_constraint -> env -> rawconstr -> unsafe_judgment) * evar_defs ref -> - type_constraint -> - env -> rawconstr option * tomatch_tuple * cases_clauses -> - unsafe_judgment -end - -module Cases_F(C : Coercion.S) : S +(*s Compilation of pattern-matching, subtac style. *) +module Cases_F(C : Coercion.S) : Cases.S diff --git a/contrib/subtac/subtac_coercion.ml b/contrib/subtac/subtac_coercion.ml index 3613ec4f..c764443f 100644 --- a/contrib/subtac/subtac_coercion.ml +++ b/contrib/subtac/subtac_coercion.ml @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: subtac_coercion.ml 9563 2007-01-31 09:37:18Z msozeau $ *) +(* $Id: subtac_coercion.ml 9976 2007-07-12 11:58:30Z msozeau $ *) open Util open Names @@ -26,7 +26,6 @@ open Subtac_utils open Coqlib open Printer open Subtac_errors -open Context open Eterm open Pp @@ -86,6 +85,13 @@ module Coercion = struct let hnf env isevars c = whd_betadeltaiota env (evars_of !isevars) c + let lift_args n sign = + let rec liftrec k = function + | t::sign -> liftn n k t :: (liftrec (k-1) sign) + | [] -> [] + in + liftrec (List.length sign) sign + let rec mu env isevars t = let isevars = ref isevars in let rec aux v = @@ -113,15 +119,41 @@ module Coercion = struct (* (try debug 1 (str "coerce_unify from " ++ (my_print_constr env x) ++ *) (* str " to "++ my_print_constr env y) *) (* with _ -> ()); *) - try - isevars := the_conv_x_leq env x y !isevars; -(* (try debug 1 (str "Unified " ++ (my_print_constr env x) ++ *) -(* str " and "++ my_print_constr env y); *) -(* with _ -> ()); *) - None - with Reduction.NotConvertible -> coerce' env (hnf env isevars x) (hnf env isevars y) + let x = hnf env isevars x and y = hnf env isevars y in + try + isevars := the_conv_x_leq env x y !isevars; + (* (try debug 1 (str "Unified " ++ (my_print_constr env x) ++ *) + (* str " and "++ my_print_constr env y); *) + (* with _ -> ()); *) + None + with Reduction.NotConvertible -> coerce' env x y and coerce' env x y : (Term.constr -> Term.constr) option = let subco () = subset_coerce env isevars x y in + let rec coerce_application typ c c' l l' = + let len = Array.length l in + let rec aux tele typ i co = + if i < len then + let hdx = l.(i) and hdy = l'.(i) in + try isevars := the_conv_x_leq env hdx hdy !isevars; + let (n, eqT, restT) = destProd typ in + aux (hdx :: tele) (subst1 hdy restT) (succ i) co + with Reduction.NotConvertible -> + let (n, eqT, restT) = destProd typ in + let restargs = lift_args 1 + (List.rev (Array.to_list (Array.sub l (succ i) (len - (succ i))))) + in + let args = List.rev (restargs @ mkRel 1 :: lift_args 1 tele) in + let pred = mkLambda (n, eqT, applistc (lift 1 c) args) in + let eq = mkApp (Lazy.force eq_ind, [| eqT; hdx; hdy |]) in +(* let jmeq = mkApp (Lazy.force jmeq_ind, [| eqT; hdx; eqT; hdy |]) in *) + let evar = make_existential dummy_loc env isevars eq in + let eq_app x = mkApp (Lazy.force eq_rect, + [| eqT; hdx; pred; x; hdy; evar|]) in + trace (str"Inserting coercion at application"); + aux (hdy :: tele) (subst1 hdy restT) (succ i) (fun x -> eq_app (co x)) + else co + in aux [] typ 0 (fun x -> x) + in (* (try debug 1 (str "coerce' from " ++ (my_print_constr env x) ++ *) (* str " to "++ my_print_constr env y); *) (* with _ -> ()); *) @@ -214,40 +246,25 @@ module Coercion = struct mkApp (prod.intro, [| a'; b'; x ; y |])) end else - (* if len = 1 && len = Array.length l' && i = i' then *) -(* let argx, argy = l.(0), l'.(0) in *) -(* let indtyp = Inductiveops.type_of_inductive env i in *) -(* let argname, argtype, _ = destProd indtyp in *) -(* let eq = *) -(* mkApp (Lazy.force eqind, [| argtype; argx; argy |]) *) -(* in *) -(* let pred = mkLambda (argname, argtype, *) -(* mkApp (mkInd i, [| mkRel 1 |])) *) -(* in *) -(* let evar = make_existential dummy_loc env isevars eq in *) -(* Some (fun x -> *) -(* mkApp (Lazy.force eqrec, *) -(* [| argtype; argx; pred; x; argy; evar |])) *) -(* else *)subco () + if i = i' && len = Array.length l' then + let evm = evars_of !isevars in + let typ = Typing.type_of env evm c in + (try subco () + with NoSubtacCoercion -> + +(* if not (is_arity env evm typ) then *) + Some (coerce_application typ c c' l l')) +(* else subco () *) + else + subco () | x, y when x = y -> - let lam_type = Typing.type_of env (evars_of !isevars) c in - let rec coerce typ i co = - if i < Array.length l then - let hdx = l.(i) and hdy = l'.(i) in - let (n, eqT, restT) = destProd typ in - let pred = mkLambda (n, eqT, mkApp (lift 1 c, [| mkRel 1 |])) in - let eq = mkApp (Lazy.force eq_ind, [| eqT; hdx; hdy |]) in - let evar = make_existential dummy_loc env isevars eq in - let eq_app x = mkApp (Lazy.force eq_rect, - [| eqT; hdx; pred; x; hdy; evar|]) - in - coerce (subst1 hdy restT) (succ i) (fun x -> eq_app (co x)) - else co - in - if Array.length l = Array.length l' then ( - trace (str"Inserting coercion at application"); - Some (coerce lam_type 0 (fun x -> x)) - ) else subco () + if Array.length l = Array.length l' then + let evm = evars_of !isevars in + let lam_type = Typing.type_of env evm c in +(* if not (is_arity env evm lam_type) then ( *) + Some (coerce_application lam_type c c' l l') +(* ) else subco () *) + else subco () | _ -> subco ()) | _, _ -> subco () diff --git a/contrib/subtac/subtac_command.ml b/contrib/subtac/subtac_command.ml index 68ab8c46..86139039 100644 --- a/contrib/subtac/subtac_command.ml +++ b/contrib/subtac/subtac_command.ml @@ -56,7 +56,6 @@ let interp_gen kind isevars env ?(impls=([],[])) ?(allow_soapp=false) ?(ltacvars=([],[])) c = let c' = Constrintern.intern_gen (kind=IsType) ~impls ~allow_soapp ~ltacvars (Evd.evars_of !isevars) env c in - let c' = Subtac_utils.rewrite_cases env c' in (* (try trace (str "Pretyping " ++ my_print_constr_expr c) with _ -> ()); *) let c' = SPretyping.pretype_gen isevars env ([],[]) kind c' in evar_nf isevars c' @@ -178,10 +177,10 @@ let build_wellfounded (recname, n, bl,arityc,body) r measure notation boxed = let env = Global.env() in let nc = named_context env in let nc_len = named_context_length nc in -(* let pr c = my_print_constr env c in *) -(* let prr = Printer.pr_rel_context env in *) -(* let prn = Printer.pr_named_context env in *) -(* let pr_rel env = Printer.pr_rel_context env in *) + let pr c = my_print_constr env c in + let prr = Printer.pr_rel_context env in + let _prn = Printer.pr_named_context env in + let _pr_rel env = Printer.pr_rel_context env in (* let _ = *) (* try debug 2 (str "In named context: " ++ prn (named_context env) ++ str "Rewriting fixpoint: " ++ Ppconstr.pr_id recname ++ *) (* Ppconstr.pr_binders bl ++ str " : " ++ *) @@ -193,40 +192,42 @@ let build_wellfounded (recname, n, bl,arityc,body) r measure notation boxed = let after, ((argname, _, argtyp) as arg), before = split_args (succ n) binders_rel in let before_length, after_length = List.length before, List.length after in let argid = match argname with Name n -> n | _ -> assert(false) in - let _liftafter = lift_binders 1 after_length after in + let liftafter = lift_binders 1 after_length after in let envwf = push_rel_context before env in let wf_rel, wf_rel_fun, measure_fn = let rconstr_body, rconstr = let app = mkAppC (r, [mkIdentC (id_of_name argname)]) in let env = push_rel_context [arg] envwf in let capp = interp_constr isevars env app in - capp, mkLambda (argname, argtyp, capp) + capp, mkLambda (argname, argtyp, capp) in + trace (str"rconstr_body: " ++ pr rconstr_body); if measure then let lt_rel = constr_of_global (Lazy.force lt_ref) in let name s = Name (id_of_string s) in - let wf_rel_fun = - (fun x y -> - mkApp (lt_rel, [| subst1 x rconstr_body; - subst1 y rconstr_body |])) - in + let wf_rel_fun lift x y = (* lift to before_env *) + trace (str"lifter rconstr_body:" ++ pr (liftn lift 2 rconstr_body)); + mkApp (lt_rel, [| subst1 x (liftn lift 2 rconstr_body); + subst1 y (liftn lift 2 rconstr_body) |]) + in let wf_rel = mkLambda (name "x", argtyp, mkLambda (name "y", lift 1 argtyp, - wf_rel_fun (mkRel 2) (mkRel 1))) + wf_rel_fun 0 (mkRel 2) (mkRel 1))) in wf_rel, wf_rel_fun , Some rconstr - else rconstr, (fun x y -> mkApp (rconstr, [|x; y|])), None + else rconstr, (fun lift x y -> mkApp (rconstr, [|x; y|])), None in let wf_proof = mkApp (Lazy.force well_founded, [| argtyp ; wf_rel |]) in let argid' = id_of_string (string_of_id argid ^ "'") in - let wfarg len = (Name argid', None, + let wfarg len = (Name argid', None, mkSubset (Name argid') (lift len argtyp) - (wf_rel_fun (mkRel 1) (mkRel (len + 1)))) + (wf_rel_fun (succ len) (mkRel 1) (mkRel (len + 1)))) in let top_bl = after @ (arg :: before) in - let intern_bl = after @ (wfarg 1 :: arg :: before) in + let intern_bl = liftafter @ (wfarg 1 :: arg :: before) in + (try trace (str "Intern bl: " ++ prr intern_bl) with _ -> ()); let top_env = push_rel_context top_bl env in let _intern_env = push_rel_context intern_bl env in let top_arity = interp_type isevars top_env arityc in @@ -234,36 +235,45 @@ let build_wellfounded (recname, n, bl,arityc,body) r measure notation boxed = let projection = mkApp (proj, [| argtyp ; (mkLambda (Name argid', argtyp, - (wf_rel_fun (mkRel 1) (mkRel 3)))) ; + (wf_rel_fun 1 (mkRel 1) (mkRel 3)))) ; mkRel 1 |]) in - (* (try debug 2 (str "Top arity: " ++ my_print_constr top_env top_arity) with _ -> ()); *) - let intern_arity = substnl [projection] after_length top_arity in -(* (try debug 2 (str "Top arity after subst: " ++ my_print_constr intern_env intern_arity) with _ -> ()); *) + let intern_arity = it_mkProd_or_LetIn top_arity after in + (try trace (str "After length: " ++ int after_length ++ str "Top env: " ++ prr top_bl ++ spc () ++ str "Top arity: " ++ my_print_constr top_env top_arity); + trace (str "Before lifting arity: " ++ my_print_constr env top_arity) with _ -> ()); + (* Top arity is in top_env = after :: arg :: before *) +(* let intern_arity' = liftn 1 (succ after_length) top_arity in (\* arity in after :: wfarg :: arg :: before *\) *) +(* (try trace (str "projection: " "After lifting arity: " ++ my_print_constr env intern_arity' ++ spc ()); *) +(* trace (str "Intern env: " ++ prr intern_bl ++ str "intern_arity': " ++ my_print_constr _intern_env intern_arity') with _ -> ()); *) + let intern_arity = substl [projection] intern_arity in (* substitute the projection of wfarg for arg *) + (try trace (str "Top arity after subst: " ++ my_print_constr (Global.env ()) intern_arity) with _ -> ()); +(* let intern_arity = liftn 1 (succ after_length) intern_arity in (\* back in after :: wfarg :: arg :: before (ie, jump over arg) *\) *) +(* (try trace (str "Top arity after subst and lift: " ++ my_print_constr (Global.env ()) intern_arity) with _ -> ()); *) let intern_before_env = push_rel_context before env in - let intern_fun_bl = after @ [wfarg 1] in +(* let intern_fun_bl = liftafter @ [wfarg 1] in (\* FixMe dependencies *\) *) (* (try debug 2 (str "Intern fun bl: " ++ prr intern_fun_bl) with _ -> ()); *) - let intern_fun_arity = intern_arity in -(* (try debug 2 (str "Intern fun arity: " ++ *) -(* my_print_constr intern_env intern_fun_arity) with _ -> ()); *) - let intern_fun_arity_prod = it_mkProd_or_LetIn intern_fun_arity intern_fun_bl in + (try trace (str "Intern arity: " ++ + my_print_constr _intern_env intern_arity) with _ -> ()); + let intern_fun_arity_prod = it_mkProd_or_LetIn intern_arity [wfarg 1] in + (try trace (str "Intern fun arity product: " ++ + my_print_constr (push_rel_context [arg] intern_before_env) intern_fun_arity_prod) with _ -> ()); let intern_fun_binder = (Name recname, None, intern_fun_arity_prod) in - let fun_bl = after @ (intern_fun_binder :: [arg]) in + let fun_bl = liftafter @ (intern_fun_binder :: [arg]) in (* (try debug 2 (str "Fun bl: " ++ pr_rel intern_before_env fun_bl ++ spc ()) with _ -> ()); *) let fun_env = push_rel_context fun_bl intern_before_env in let fun_arity = interp_type isevars fun_env arityc in let intern_body = interp_casted_constr isevars fun_env body fun_arity in let intern_body_lam = it_mkLambda_or_LetIn intern_body fun_bl in -(* let _ = *) -(* try debug 2 (str "Fun bl: " ++ prr fun_bl ++ spc () ++ *) -(* str "Intern bl" ++ prr intern_bl ++ spc () ++ *) -(* str "Top bl" ++ prr top_bl ++ spc () ++ *) -(* str "Intern arity: " ++ pr intern_arity ++ *) -(* str "Top arity: " ++ pr top_arity ++ spc () ++ *) + let _ = + try trace ((* str "Fun bl: " ++ prr fun_bl ++ spc () ++ *) + str "Intern bl" ++ prr intern_bl ++ spc ()) +(* str "Top bl" ++ prr top_bl ++ spc () ++ *) +(* str "Intern arity: " ++ pr intern_arity ++ *) +(* str "Top arity: " ++ pr top_arity ++ spc () ++ *) (* str "Intern body " ++ pr intern_body_lam) *) -(* with _ -> () *) -(* in *) + with _ -> () + in let _impl = if Impargs.is_implicit_args() then Impargs.compute_implicits top_env top_arity @@ -276,13 +286,16 @@ let build_wellfounded (recname, n, bl,arityc,body) r measure notation boxed = mkApp (constr_of_reference (Lazy.force fix_sub_ref), [| argtyp ; wf_rel ; - make_existential dummy_loc intern_before_env isevars wf_proof ; + make_existential dummy_loc ~opaque:false intern_before_env isevars wf_proof ; prop ; intern_body_lam |]) | Some f -> - mkApp (constr_of_reference (Lazy.force fix_measure_sub_ref), - [| argtyp ; f ; prop ; - intern_body_lam |]) + lift (succ after_length) + (mkApp (constr_of_reference (Lazy.force fix_measure_sub_ref), + [| argtyp ; + f ; + prop ; + intern_body_lam |])) in let def_appl = applist (fix_def, gen_rels (after_length + 1)) in let def = it_mkLambda_or_LetIn def_appl binders_rel in @@ -294,15 +307,22 @@ let build_wellfounded (recname, n, bl,arityc,body) r measure notation boxed = (* ++ str "Coq type: " ++ my_print_constr env fullctyp) *) (* with _ -> () *) (* in *) - let evm = non_instanciated_map env isevars in + let evm = evars_of_term (Evd.evars_of !isevars) Evd.empty fullctyp in + let evm = evars_of_term (Evd.evars_of !isevars) evm fullcoqc in + let evm = non_instanciated_map env isevars evm in + (* let _ = try trace (str "Non instanciated evars map: " ++ Evd.pr_evar_map evm) with _ -> () in *) - let evars, evars_def = Eterm.eterm_obligations recname nc_len evm fullcoqc (Some fullctyp) in + let evars, evars_def = Eterm.eterm_obligations recname nc_len !isevars evm 0 fullcoqc (Some fullctyp) in (* (try trace (str "Generated obligations : "); *) (* Array.iter *) (* (fun (n, t, _) -> trace (str "Evar " ++ str (string_of_id n) ++ spc () ++ my_print_constr env t)) *) (* evars; *) (* with _ -> ()); *) Subtac_obligations.add_definition recname evars_def fullctyp evars + +let nf_evar_context isevars ctx = + List.map (fun (n, b, t) -> + (n, option_map (Evarutil.nf_isevar isevars) b, Evarutil.nf_isevar isevars t)) ctx let build_mutrec l boxed = let sigma = Evd.empty and env = Global.env () in @@ -368,10 +388,13 @@ let build_mutrec l boxed = let (isevars, info, def) = defrec.(i) in (* let _ = try trace (str "In solve evars, isevars is: " ++ Evd.pr_evar_defs !isevars) with _ -> () in *) let def = evar_nf isevars def in + let x, y, typ = arrec.(i) in + let typ = evar_nf isevars typ in + arrec.(i) <- (x, y, typ); + let rec_sign = nf_evar_context !isevars rec_sign in let isevars = Evd.undefined_evars !isevars in (* let _ = try trace (str "In solve evars, undefined is: " ++ Evd.pr_evar_defs isevars) with _ -> () in *) let evm = Evd.evars_of isevars in - let _, _, typ = arrec.(i) in let id = namerec.(i) in (* Generalize by the recursive prototypes *) let def = @@ -379,7 +402,7 @@ let build_mutrec l boxed = and typ = Termops.it_mkNamedProd_or_LetIn typ rec_sign in - let evars, def = Eterm.eterm_obligations id nc_len evm def (Some typ) in + let evars, def = Eterm.eterm_obligations id nc_len isevars evm recdefs def (Some typ) in collect_evars (succ i) ((id, def, typ, evars) :: acc) else acc in diff --git a/contrib/subtac/subtac_interp_fixpoint.ml b/contrib/subtac/subtac_interp_fixpoint.ml deleted file mode 100644 index bb35833f..00000000 --- a/contrib/subtac/subtac_interp_fixpoint.ml +++ /dev/null @@ -1,154 +0,0 @@ -open Global -open Pp -open Util -open Names -open Sign -open Evd -open Term -open Termops -open Reductionops -open Environ -open Type_errors -open Typeops -open Libnames -open Classops -open List -open Recordops -open Evarutil -open Pretype_errors -open Rawterm -open Evarconv -open Pattern -open Dyn -open Topconstr - -open Subtac_coercion -open Subtac_utils -open Coqlib -open Printer -open Subtac_errors -open Context -open Eterm - - -let mkAppExplC (f, args) = CAppExpl (dummy_loc, (None, f), args) - -let mkSubset name typ prop = - mkAppExplC (sig_ref, - [ typ; mkLambdaC ([name], typ, prop) ]) - -let mkProj1 u p x = - mkAppExplC (proj1_sig_ref, [ u; p; x ]) - -let mkProj2 u p x = - mkAppExplC (proj2_sig_ref, [ u; p; x ]) - -let list_of_local_binders l = - let rec aux acc = function - Topconstr.LocalRawDef (n, c) :: tl -> aux ((n, c) :: acc) tl - | Topconstr.LocalRawAssum (nl, c) :: tl -> - aux (List.fold_left (fun acc n -> (n, c) :: acc) acc nl) tl - | [] -> List.rev acc - in aux [] l - -let abstract_constr_expr_bl abs c bl = - List.fold_right (fun (n, t) c -> abs ([n], t, c)) bl c - -let pr_binder_list b = - List.fold_right (fun ((loc, name), t) acc -> Nameops.pr_name name ++ str " : " ++ - Ppconstr.pr_constr_expr t ++ spc () ++ acc) b (mt ()) - - -let rec rewrite_rec_calls l c = c -(* -let rewrite_fixpoint env l (f, decl) = - let (id, (n, ro), bl, typ, body) = f in - let body = rewrite_rec_calls l body in - match ro with - CStructRec -> ((id, (n, ro), bl, typ, body), decl) - | CWfRec wfrel -> - let bls = list_of_local_binders bl in - let _ = trace (str "Rewriting fixpoint: " ++ Ppconstr.pr_id id ++ - Ppconstr.pr_binders bl ++ str " : " ++ - Ppconstr.pr_constr_expr typ ++ str " := " ++ spc () ++ - Ppconstr.pr_constr_expr body) - in - let before, after = list_chop n bls in - let _ = trace (str "Binders before the recursion arg: " ++ spc () ++ - pr_binder_list before ++ str "; after the recursion arg: " ++ - pr_binder_list after) - in - let ((locn, name) as lnid, ntyp), after = match after with - hd :: tl -> hd, tl - | _ -> assert(false) (* Rec arg must be in after *) - in - let nid = match name with - Name id -> id - | Anonymous -> assert(false) (* Rec arg _must_ be named *) - in - let _wfproof = - let _wf_rel = mkAppExplC (well_founded_ref, [ntyp; wfrel]) in - (*make_existential_expr dummy_loc before wf_rel*) - mkRefC lt_wf_ref - in - let nid', accproofid = - let nid = string_of_id nid in - id_of_string (nid ^ "'"), id_of_string ("Acc_" ^ nid) - in - let lnid', laccproofid = (dummy_loc, Name nid'), (dummy_loc, Name accproofid) in - let wf_prop = (mkAppC (wfrel, [ mkIdentC nid'; mkIdentC nid ])) in - let lam_wf_prop = mkLambdaC ([lnid'], ntyp, wf_prop) in - let typnid' = mkSubset lnid' ntyp wf_prop in - let internal_type = - abstract_constr_expr_bl mkProdC - (mkProdC ([lnid'], typnid', - mkLetInC (lnid, mkProj1 ntyp lam_wf_prop (mkIdentC nid'), - abstract_constr_expr_bl mkProdC typ after))) - before - in - let body' = - let body = - (* cast or we will loose some info at pretyping time as body - is a function *) - CCast (dummy_loc, body, CastConv DEFAULTcast, typ) - in - let body' = (* body abstracted by rec call *) - mkLambdaC ([(dummy_loc, Name id)], internal_type, body) - in - mkAppC (body', - [mkLambdaC - ([lnid'], typnid', - mkAppC (mkIdentC id, - [mkProj1 ntyp lam_wf_prop (mkIdentC nid'); - (mkAppExplC (acc_inv_ref, - [ ntyp; wfrel; - mkIdentC nid; - mkIdentC accproofid; - mkProj1 ntyp lam_wf_prop (mkIdentC nid'); - mkProj2 ntyp lam_wf_prop (mkIdentC nid') ])) ]))]) - in - let acctyp = mkAppExplC (acc_ref, [ ntyp; wfrel; mkIdentC nid ]) in - let bl' = - let rec aux acc = function - Topconstr.LocalRawDef _ as x :: tl -> - aux (x :: acc) tl - | Topconstr.LocalRawAssum (bl, typ) as assum :: tl -> - let rec aux' bl' = function - ((loc, name') as x) :: tl -> - if name' = name then - (if tl = [] then [] else [LocalRawAssum (tl, typ)]) @ - LocalRawAssum ([(dummy_loc, Name accproofid)], acctyp) :: - [LocalRawAssum (List.rev (x :: bl'), typ)] - else aux' (x :: bl') tl - | [] -> [assum] - in aux (aux' [] bl @ acc) tl - | [] -> List.rev acc - in aux [] bl - in - let _ = trace (str "Rewrote fixpoint: " ++ Ppconstr.pr_id id ++ - Ppconstr.pr_binders bl' ++ str " : " ++ - Ppconstr.pr_constr_expr typ ++ str " := " ++ spc () ++ - Ppconstr.pr_constr_expr body') - in (id, (succ n, ro), bl', typ, body'), decl - -*) diff --git a/contrib/subtac/subtac_interp_fixpoint.mli b/contrib/subtac/subtac_interp_fixpoint.mli deleted file mode 100644 index 149e7580..00000000 --- a/contrib/subtac/subtac_interp_fixpoint.mli +++ /dev/null @@ -1,17 +0,0 @@ -val mkAppExplC : - Libnames.reference * Topconstr.constr_expr list -> Topconstr.constr_expr -val mkSubset : - Names.name Util.located -> - Topconstr.constr_expr -> Topconstr.constr_expr -> Topconstr.constr_expr -val mkProj1 : - Topconstr.constr_expr -> - Topconstr.constr_expr -> Topconstr.constr_expr -> Topconstr.constr_expr -val mkProj2 : - Topconstr.constr_expr -> - Topconstr.constr_expr -> Topconstr.constr_expr -> Topconstr.constr_expr -val list_of_local_binders : - Topconstr.local_binder list -> - (Names.name Util.located * Topconstr.constr_expr) list -val pr_binder_list : - (('a * Names.name) * Topconstr.constr_expr) list -> Pp.std_ppcmds -val rewrite_rec_calls : 'a -> 'b -> 'b diff --git a/contrib/subtac/subtac_obligations.ml b/contrib/subtac/subtac_obligations.ml index d6c1772f..d182f7cd 100644 --- a/contrib/subtac/subtac_obligations.ml +++ b/contrib/subtac/subtac_obligations.ml @@ -1,3 +1,4 @@ +(* -*- default-directory: "~/research/coq/trunk/" -*- *) open Printf open Pp open Subtac_utils @@ -12,12 +13,22 @@ open Decl_kinds open Util open Evd -type obligation_info = (Names.identifier * Term.types * Intset.t) array +let pperror cmd = Util.errorlabstrm "Subtac" cmd +let error s = pperror (str s) + +exception NoObligations of identifier option + +let explain_no_obligations = function + Some ident -> str "No obligations for program " ++ str (string_of_id ident) + | None -> str "No obligations remaining" + +type obligation_info = (Names.identifier * Term.types * bool * Intset.t) array type obligation = { obl_name : identifier; obl_type : types; obl_body : constr option; + obl_opaque : bool; obl_deps : Intset.t; } @@ -36,8 +47,9 @@ let assumption_message id = Options.if_verbose message ((string_of_id id) ^ " is assumed") let default_tactic : Proof_type.tactic ref = ref Refiner.tclIDTAC +let default_tactic_expr : Tacexpr.glob_tactic_expr ref = ref (Obj.magic ()) -let set_default_tactic t = default_tactic := t +let set_default_tactic t = default_tactic_expr := t; default_tactic := Tacinterp.eval_tactic t let evar_of_obligation o = { evar_hyps = Global.named_context_val () ; evar_concl = o.obl_type ; @@ -81,26 +93,35 @@ let map_first m = let from_prg : program_info ProgMap.t ref = ref ProgMap.empty +let freeze () = !from_prg, !default_tactic_expr +let unfreeze (v, t) = from_prg := v; set_default_tactic t +let init () = + from_prg := ProgMap.empty; set_default_tactic (Subtac_utils.utils_call "subtac_simpl" []) + let _ = Summary.declare_summary "program-tcc-table" - { Summary.freeze_function = (fun () -> !from_prg); - Summary.unfreeze_function = - (fun v -> from_prg := v); - Summary.init_function = - (fun () -> from_prg := ProgMap.empty); + { Summary.freeze_function = freeze; + Summary.unfreeze_function = unfreeze; + Summary.init_function = init; Summary.survive_module = false; Summary.survive_section = false } -open Evd +let progmap_union = ProgMap.fold ProgMap.add -let terms_of_evar ev = - match ev.evar_body with - Evar_defined b -> - let nc = Environ.named_context_of_val ev.evar_hyps in - let body = Termops.it_mkNamedLambda_or_LetIn b nc in - let typ = Termops.it_mkNamedProd_or_LetIn ev.evar_concl nc in - body, typ - | _ -> assert(false) +let cache (_, (infos, tac)) = + from_prg := infos; + default_tactic_expr := tac + +let (input,output) = + declare_object + { (default_object "Program state") with + cache_function = cache; + load_function = (fun _ -> cache); + open_function = (fun _ -> cache); + classify_function = (fun _ -> Dispose); + export_function = (fun x -> Some x) } + +open Evd let rec intset_to = function -1 -> Intset.empty @@ -113,7 +134,8 @@ let subst_body prg = let declare_definition prg = let body = subst_body prg in (try trace (str "Declaring: " ++ Ppconstr.pr_id prg.prg_name ++ spc () ++ - my_print_constr (Global.env()) body); + my_print_constr (Global.env()) body ++ str " : " ++ + my_print_constr (Global.env()) prg.prg_type); with _ -> ()); let ce = { const_entry_body = body; @@ -163,7 +185,7 @@ let declare_obligation obl body = let ce = { const_entry_body = body; const_entry_type = Some obl.obl_type; - const_entry_opaque = false; + const_entry_opaque = obl.obl_opaque; const_entry_boxed = false} in let constant = Declare.declare_constant obl.obl_name @@ -190,42 +212,53 @@ let red = Reductionops.nf_betaiota let init_prog_info n b t deps nvrec obls = let obls' = Array.mapi - (fun i (n, t, d) -> + (fun i (n, t, o, d) -> debug 2 (str "Adding obligation " ++ int i ++ str " with deps : " ++ str (string_of_intset d)); { obl_name = n ; obl_body = None; - obl_type = red t; + obl_type = red t; obl_opaque = o; obl_deps = d }) obls in { prg_name = n ; prg_body = b; prg_type = red t; prg_obligations = (obls', Array.length obls'); prg_deps = deps; prg_nvrec = nvrec; } -let pperror cmd = Util.errorlabstrm "Subtac" cmd -let error s = pperror (str s) - let get_prog name = let prg_infos = !from_prg in match name with Some n -> (try ProgMap.find n prg_infos - with Not_found -> error ("No obligations for program " ^ string_of_id n)) + with Not_found -> raise (NoObligations (Some n))) | None -> (let n = map_cardinal prg_infos in match n with - 0 -> error "No obligations remaining" + 0 -> raise (NoObligations None) | 1 -> map_first prg_infos | _ -> error "More than one program with unsolved obligations") +let get_prog_err n = + try get_prog n with NoObligations id -> pperror (explain_no_obligations id) + let obligations_solved prg = (snd prg.prg_obligations) = 0 +let update_state s = +(* msgnl (str "Updating obligations info"); *) + Lib.add_anonymous_leaf (input s) + +let obligations_message rem = + if rem > 0 then + if rem = 1 then + Options.if_verbose msgnl (int rem ++ str " obligation remaining") + else + Options.if_verbose msgnl (int rem ++ str " obligations remaining") + else + Options.if_verbose msgnl (str "No more obligations remaining") + let update_obls prg obls rem = let prg' = { prg with prg_obligations = (obls, rem) } in from_prg := map_replace prg.prg_name prg' !from_prg; - if rem > 0 then ( - Options.if_verbose msgnl (int rem ++ str " obligation(s) remaining"); - ) + obligations_message rem; + if rem > 0 then () else ( - Options.if_verbose msgnl (str "No more obligations remaining"); match prg'.prg_deps with [] -> declare_definition prg'; @@ -235,7 +268,10 @@ let update_obls prg obls rem = if List.for_all (fun x -> obligations_solved x) progs then (declare_mutual_definition progs; from_prg := List.fold_left - (fun acc x -> ProgMap.remove x.prg_name acc) !from_prg progs)) + (fun acc x -> + ProgMap.remove x.prg_name acc) !from_prg progs)); + update_state (!from_prg, !default_tactic_expr); + rem let is_defined obls x = obls.(x).obl_body <> None @@ -246,7 +282,24 @@ let deps_remaining obls deps = else x :: acc) deps [] -let solve_obligation prg num = +let kind_of_opacity o = + if o then Subtac_utils.goal_proof_kind + else Subtac_utils.goal_kind + +let obligations_of_evars evars = + let arr = + Array.of_list + (List.map + (fun (n, t) -> + { obl_name = n; + obl_type = t; + obl_body = None; + obl_opaque = false; + obl_deps = Intset.empty; + }) evars) + in arr, Array.length arr + +let rec solve_obligation prg num = let user_num = succ num in let obls, rem = prg.prg_obligations in let obl = obls.(num) in @@ -256,22 +309,23 @@ let solve_obligation prg num = match deps_remaining obls obl.obl_deps with [] -> let obl = subst_deps_obl obls obl in - Command.start_proof obl.obl_name Subtac_utils.goal_proof_kind obl.obl_type + Command.start_proof obl.obl_name (kind_of_opacity obl.obl_opaque) obl.obl_type (fun strength gr -> debug 2 (str "Proof of obligation " ++ int user_num ++ str " finished"); let obl = { obl with obl_body = Some (Libnames.constr_of_global gr) } in let obls = Array.copy obls in let _ = obls.(num) <- obl in - update_obls prg obls (pred rem)); + if update_obls prg obls (pred rem) <> 0 then + auto_solve_obligations (Some prg.prg_name)); trace (str "Started obligation " ++ int user_num ++ str " proof: " ++ Subtac_utils.my_print_constr (Global.env ()) obl.obl_type); Pfedit.by !default_tactic | l -> pperror (str "Obligation " ++ int user_num ++ str " depends on obligation(s) " ++ str (string_of_list ", " (fun x -> string_of_int (succ x)) l)) -let subtac_obligation (user_num, name, typ) = +and subtac_obligation (user_num, name, typ) = let num = pred user_num in - let prg = get_prog name in + let prg = get_prog_err name in let obls, rem = prg.prg_obligations in if num < Array.length obls then let obl = obls.(num) in @@ -280,20 +334,8 @@ let subtac_obligation (user_num, name, typ) = | Some r -> error "Obligation already solved" else error (sprintf "Unknown obligation number %i" (succ num)) - -let obligations_of_evars evars = - let arr = - Array.of_list - (List.map - (fun (n, t) -> - { obl_name = n; - obl_type = t; - obl_body = None; - obl_deps = Intset.empty; - }) evars) - in arr, Array.length arr - -let solve_obligation_by_tac prg obls i tac = + +and solve_obligation_by_tac prg obls i tac = let obl = obls.(i) in match obl.obl_body with Some _ -> false @@ -302,13 +344,15 @@ let solve_obligation_by_tac prg obls i tac = if deps_remaining obls obl.obl_deps = [] then let obl = subst_deps_obl obls obl in let t = Subtac_utils.solve_by_tac (evar_of_obligation obl) tac in - obls.(i) <- { obl with obl_body = Some t }; + if obl.obl_opaque then + obls.(i) <- declare_obligation obl t + else + obls.(i) <- { obl with obl_body = Some t }; true else false with _ -> false) -let solve_obligations n tac = - let prg = get_prog n in +and solve_prg_obligations prg tac = let obls, rem = prg.prg_obligations in let rem = ref rem in let obls' = Array.copy obls in @@ -320,6 +364,27 @@ let solve_obligations n tac = in update_obls prg obls' !rem +and solve_obligations n tac = + let prg = get_prog_err n in + solve_prg_obligations prg tac + +and solve_all_obligations tac = + ProgMap.iter (fun k v -> ignore(solve_prg_obligations v tac)) !from_prg + +and try_solve_obligation n prg tac = + let prg = get_prog prg in + let obls, rem = prg.prg_obligations in + let obls' = Array.copy obls in + if solve_obligation_by_tac prg obls' n tac then + ignore(update_obls prg obls' (pred rem)); + +and try_solve_obligations n tac = + try ignore (solve_obligations n tac) with NoObligations _ -> () + +and auto_solve_obligations n : unit = + Options.if_verbose msgnl (str "Solving obligations automatically..."); + try_solve_obligations n !default_tactic + let add_definition n b t obls = Options.if_verbose pp (str (string_of_id n) ++ str " has type-checked"); let prg = init_prog_info n b t [] (Array.make 0 0) obls in @@ -332,7 +397,7 @@ let add_definition n b t obls = let len = Array.length obls in let _ = Options.if_verbose ppnl (str ", generating " ++ int len ++ str " obligation(s)") in from_prg := ProgMap.add n prg !from_prg; - solve_obligations (Some n) !default_tactic) + auto_solve_obligations (Some n)) let add_mutual_definitions l nvrec = let deps = List.map (fun (n, b, t, obls) -> n) l in @@ -343,22 +408,21 @@ let add_mutual_definitions l nvrec = !from_prg l in from_prg := upd; - List.iter (fun x -> solve_obligations (Some x) !default_tactic) deps + List.iter (fun x -> auto_solve_obligations (Some x)) deps let admit_obligations n = - let prg = get_prog n in + let prg = get_prog_err n in let obls, rem = prg.prg_obligations in - let obls' = - Array.mapi (fun i x -> + Array.iteri (fun i x -> match x.obl_body with None -> - let kn = Declare.declare_constant x.obl_name (ParameterEntry x.obl_type, IsAssumption Conjectural) in - assumption_message x.obl_name; - { x with obl_body = Some (mkConst kn) } - | Some _ -> x) - obls - in - update_obls prg obls' 0 + let x = subst_deps_obl obls x in + let kn = Declare.declare_constant x.obl_name (ParameterEntry x.obl_type, IsAssumption Conjectural) in + assumption_message x.obl_name; + obls.(i) <- { x with obl_body = Some (mkConst kn) } + | Some _ -> ()) + obls; + ignore(update_obls prg obls 0) exception Found of int @@ -367,21 +431,17 @@ let array_find f arr = raise Not_found with Found i -> i -let rec next_obligation n = - let prg = get_prog n in +let next_obligation n = + let prg = get_prog_err n in let obls, rem = prg.prg_obligations in let i = array_find (fun x -> x.obl_body = None && deps_remaining obls x.obl_deps = []) obls - in - if solve_obligation_by_tac prg obls i !default_tactic then ( - update_obls prg obls (pred rem); - next_obligation n - ) else solve_obligation prg i + in solve_obligation prg i open Pp let show_obligations n = - let prg = get_prog n in + let prg = get_prog_err n in let n = prg.prg_name in let obls, rem = prg.prg_obligations in msgnl (int rem ++ str " obligation(s) remaining: "); @@ -392,3 +452,4 @@ let show_obligations n = | Some _ -> ()) obls +let default_tactic () = !default_tactic diff --git a/contrib/subtac/subtac_obligations.mli b/contrib/subtac/subtac_obligations.mli index 3981d4c6..f015b80b 100644 --- a/contrib/subtac/subtac_obligations.mli +++ b/contrib/subtac/subtac_obligations.mli @@ -1,8 +1,10 @@ open Util -type obligation_info = (Names.identifier * Term.types * Intset.t) array +type obligation_info = (Names.identifier * Term.types * bool * Intset.t) array + (* ident, type, opaque or transparent, dependencies *) -val set_default_tactic : Proof_type.tactic -> unit +val set_default_tactic : Tacexpr.glob_tactic_expr -> unit +val default_tactic : unit -> Proof_type.tactic val add_definition : Names.identifier -> Term.constr -> Term.types -> obligation_info -> unit @@ -14,8 +16,20 @@ val subtac_obligation : int * Names.identifier option * Topconstr.constr_expr op val next_obligation : Names.identifier option -> unit -val solve_obligations : Names.identifier option -> Proof_type.tactic -> unit +val solve_obligations : Names.identifier option -> Proof_type.tactic -> int +(* Number of remaining obligations to be solved for this program *) + +val solve_all_obligations : Proof_type.tactic -> unit + +val try_solve_obligation : int -> Names.identifier option -> Proof_type.tactic -> unit + +val try_solve_obligations : Names.identifier option -> Proof_type.tactic -> unit val show_obligations : Names.identifier option -> unit val admit_obligations : Names.identifier option -> unit + +exception NoObligations of Names.identifier option + +val explain_no_obligations : Names.identifier option -> Pp.std_ppcmds + diff --git a/contrib/subtac/subtac_pretyping.ml b/contrib/subtac/subtac_pretyping.ml index 4d1ac731..cce9a358 100644 --- a/contrib/subtac/subtac_pretyping.ml +++ b/contrib/subtac/subtac_pretyping.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: subtac_pretyping.ml 9563 2007-01-31 09:37:18Z msozeau $ *) +(* $Id: subtac_pretyping.ml 9976 2007-07-12 11:58:30Z msozeau $ *) open Global open Pp @@ -36,7 +36,6 @@ open Subtac_utils open Coqlib open Printer open Subtac_errors -open Context open Eterm module Pretyping = Subtac_pretyping_F.SubtacPretyping_F(Subtac_coercion.Coercion) @@ -89,18 +88,18 @@ let list_split_at index l = open Vernacexpr -let coqintern evd env : Topconstr.constr_expr -> Rawterm.rawconstr = Constrintern.intern_constr (evars_of evd) env -let coqinterp evd env : Topconstr.constr_expr -> Term.constr = Constrintern.interp_constr (evars_of evd) env +let coqintern_constr evd env : Topconstr.constr_expr -> Rawterm.rawconstr = Constrintern.intern_constr (evars_of evd) env +let coqintern_type evd env : Topconstr.constr_expr -> Rawterm.rawconstr = Constrintern.intern_type (evars_of evd) env let env_with_binders env isevars l = let rec aux ((env, rels) as acc) = function Topconstr.LocalRawDef ((loc, name), def) :: tl -> - let rawdef = coqintern !isevars env def in + let rawdef = coqintern_constr !isevars env def in let coqdef, deftyp = interp env isevars rawdef empty_tycon in let reldecl = (name, Some coqdef, deftyp) in aux (push_rel reldecl env, reldecl :: rels) tl | Topconstr.LocalRawAssum (bl, typ) :: tl -> - let rawtyp = coqintern !isevars env typ in + let rawtyp = coqintern_type !isevars env typ in let coqtyp, typtyp = interp env isevars rawtyp empty_tycon in let acc = List.fold_left (fun (env, rels) (loc, name) -> @@ -113,36 +112,37 @@ let env_with_binders env isevars l = in aux (env, []) l let subtac_process env isevars id l c tycon = - let env_binders, binders_rel = env_with_binders env isevars l in + let c = Command.abstract_constr_expr c l in +(* let env_binders, binders_rel = env_with_binders env isevars l in *) let tycon = match tycon with None -> empty_tycon | Some t -> - let t = coqintern !isevars env_binders t in - let coqt, ttyp = interp env_binders isevars t empty_tycon in + let t = Command.generalize_constr_expr t l in + let t = coqintern_type !isevars env t in + let coqt, ttyp = interp env isevars t empty_tycon in mk_tycon coqt in - let c = coqintern !isevars env_binders c in - let c = Subtac_utils.rewrite_cases env c in - let coqc, ctyp = interp env_binders isevars c tycon in -(* let _ = try trace (str "Interpreted term: " ++ my_print_constr env_binders coqc ++ spc () ++ *) -(* str "Coq type: " ++ my_print_constr env_binders ctyp) *) -(* with _ -> () *) + let c = coqintern_constr !isevars env c in + let coqc, ctyp = interp env isevars c tycon in +(* let _ = try trace (str "Interpreted term: " ++ my_print_constr env coqc ++ spc () ++ *) +(* str "Coq type: " ++ my_print_constr env ctyp) *) +(* with _ -> () *) (* in *) -(* let _ = try trace (str "Original evar map: " ++ Evd.pr_evar_map (evars ())) with _ -> () in *) +(* let _ = try trace (str "Original evar map: " ++ Evd.pr_evar_map (evars_of !isevars)) with _ -> () in *) - let fullcoqc = it_mkLambda_or_LetIn coqc binders_rel - and fullctyp = it_mkProd_or_LetIn ctyp binders_rel - in - let fullcoqc = Evarutil.nf_evar (evars_of !isevars) fullcoqc in - let fullctyp = Evarutil.nf_evar (evars_of !isevars) fullctyp in - -(* let _ = try trace (str "After evar normalization: " ++ spc () ++ *) -(* str "Coq term: " ++ my_print_constr env fullcoqc ++ spc () *) -(* ++ str "Coq type: " ++ my_print_constr env fullctyp) *) -(* with _ -> () *) +(* let fullcoqc = it_mkLambda_or_LetIn coqc binders_rel *) +(* and fullctyp = it_mkProd_or_LetIn ctyp binders_rel *) (* in *) - let evm = non_instanciated_map env isevars in + let fullcoqc = Evarutil.nf_evar (evars_of !isevars) coqc in + let fullctyp = Evarutil.nf_evar (evars_of !isevars) ctyp in +(* let evm = evars_of_term (evars_of !isevars) Evd.empty fullctyp in *) +(* let evm = evars_of_term (evars_of !isevars) evm fullcoqc in *) +(* let _ = try trace (str "After evar normalization remain: " ++ spc () ++ *) +(* Evd.pr_evar_map evm) *) +(* with _ -> () *) +(* in *) + let evm = non_instanciated_map env isevars (evars_of !isevars) in (* let _ = try trace (str "Non instanciated evars map: " ++ Evd.pr_evar_map evm) with _ -> () in *) evm, fullcoqc, fullctyp @@ -152,5 +152,5 @@ let subtac_proof env isevars id l c tycon = let nc = named_context env in let nc_len = named_context_length nc in let evm, coqc, coqt = subtac_process env isevars id l c tycon in - let evars, def = Eterm.eterm_obligations id nc_len evm coqc (Some coqt) in + let evars, def = Eterm.eterm_obligations id nc_len !isevars evm 0 coqc (Some coqt) in add_definition id def coqt evars diff --git a/contrib/subtac/subtac_pretyping_F.ml b/contrib/subtac/subtac_pretyping_F.ml index 6244aef3..53eec0b6 100644 --- a/contrib/subtac/subtac_pretyping_F.ml +++ b/contrib/subtac/subtac_pretyping_F.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: subtac_pretyping_F.ml 9563 2007-01-31 09:37:18Z msozeau $ *) +(* $Id: subtac_pretyping_F.ml 9976 2007-07-12 11:58:30Z msozeau $ *) open Pp open Util @@ -93,7 +93,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct (* coerce to tycon if any *) let inh_conv_coerce_to_tycon loc env isevars j = function - | None -> j + | None -> j_nf_isevar !isevars j | Some t -> evd_comb2 (Coercion.inh_conv_coerce_to loc env) isevars j t let push_rels vars env = List.fold_right push_rel vars env @@ -364,21 +364,21 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct error_case_not_inductive_loc cloc env (evars_of !isevars) cj in let cstrs = get_constructors env indf in - if Array.length cstrs <> 1 then - user_err_loc (loc,"",str "Destructing let is only for inductive types with one constructor"); - let cs = cstrs.(0) in - if List.length nal <> cs.cs_nargs then - user_err_loc (loc,"", str "Destructing let on this type expects " ++ int cs.cs_nargs ++ str " variables"); - let fsign = List.map2 (fun na (_,c,t) -> (na,c,t)) - (List.rev nal) cs.cs_args in - let env_f = push_rels fsign env in - (* Make dependencies from arity signature impossible *) - let arsgn = - let arsgn,_ = get_arity env indf in - if not !allow_anonymous_refs then - List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn - else arsgn - in + if Array.length cstrs <> 1 then + user_err_loc (loc,"",str "Destructing let is only for inductive types with one constructor"); + let cs = cstrs.(0) in + if List.length nal <> cs.cs_nargs then + user_err_loc (loc,"", str "Destructing let on this type expects " ++ int cs.cs_nargs ++ str " variables"); + let fsign = List.map2 (fun na (_,c,t) -> (na,c,t)) + (List.rev nal) cs.cs_args in + let env_f = push_rels fsign env in + (* Make dependencies from arity signature impossible *) + let arsgn = + let arsgn,_ = get_arity env indf in + if not !allow_anonymous_refs then + List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn + else arsgn + in let psign = (na,None,build_dependent_inductive env indf)::arsgn in let nar = List.length arsgn in (match po with @@ -495,13 +495,13 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct ((fun vtyc env -> pretype vtyc env isevars lvar),isevars) tycon env (* loc *) (po,tml,eqns) - | RCast(loc,c,k,t) -> + | RCast(loc,c,k) -> let cj = match k with CastCoerce -> let cj = pretype empty_tycon env isevars lvar c in evd_comb1 (Coercion.inh_coerce_to_base loc env) isevars cj - | CastConv k -> + | CastConv (k,t) -> let tj = pretype_type empty_valcon env isevars lvar t in let cj = pretype (mk_tycon tj.utj_val) env isevars lvar c in (* User Casts are for helping pretyping, experimentally not to be kept*) diff --git a/contrib/subtac/subtac_utils.ml b/contrib/subtac/subtac_utils.ml index 01dee3e9..28fe6352 100644 --- a/contrib/subtac/subtac_utils.ml +++ b/contrib/subtac/subtac_utils.ml @@ -32,6 +32,7 @@ let fix_sub_ref = make_ref ["subtac";"FixSub"] "Fix_sub" let fix_measure_sub_ref = make_ref ["subtac";"FixSub"] "Fix_measure_sub" let lt_ref = make_ref ["Init";"Peano"] "lt" let lt_wf_ref = make_ref ["Wf_nat"] "lt_wf" +let refl_ref = make_ref ["Init";"Logic"] "refl_equal" let make_ref s = Qualid (dummy_loc, qualid_of_string s) let sig_ref = make_ref "Init.Specif.sig" @@ -54,6 +55,10 @@ let eq_refl = lazy (init_constant ["Init"; "Logic"] "refl_equal") let eq_ind_ref = lazy (init_reference ["Init"; "Logic"] "eq") let refl_equal_ref = lazy (init_reference ["Init"; "Logic"] "refl_equal") +let not_ref = lazy (init_constant ["Init"; "Logic"] "not") + +let and_typ = lazy (Coqlib.build_coq_and ()) + let eqdep_ind = lazy (init_constant [ "Logic";"Eqdep"] "eq_dep") let eqdep_rec = lazy (init_constant ["Logic";"Eqdep"] "eq_dep_rec") let eqdep_ind_ref = lazy (init_reference [ "Logic";"Eqdep"] "eq_dep") @@ -61,8 +66,7 @@ let eqdep_intro_ref = lazy (init_reference [ "Logic";"Eqdep"] "eq_dep_intro") let jmeq_ind = lazy (init_constant ["Logic";"JMeq"] "JMeq") let jmeq_rec = lazy (init_constant ["Logic";"JMeq"] "JMeq_rec") -let jmeq_ind_ref = lazy (init_reference ["Logic";"JMeq"] "JMeq") -let jmeq_refl_ref = lazy (init_reference ["Logic";"JMeq"] "JMeq_refl") +let jmeq_refl = lazy (init_constant ["Logic";"JMeq"] "JMeq_refl") let ex_ind = lazy (init_constant ["Init"; "Logic"] "ex") let ex_intro = lazy (init_reference ["Init"; "Logic"] "ex_intro") @@ -126,6 +130,10 @@ let trace s = else () else () +let rec pp_list f = function + [] -> mt() + | x :: y -> f x ++ spc () ++ pp_list f y + let wf_relations = Hashtbl.create 10 let std_relations () = @@ -145,8 +153,8 @@ let app_opt c e = let print_args env args = Array.fold_right (fun a acc -> my_print_constr env a ++ spc () ++ acc) args (str "") -let make_existential loc env isevars c = - let evar = Evarutil.e_new_evar isevars env ~src:(loc, QuestionMark) c in +let make_existential loc ?(opaque = true) env isevars c = + let evar = Evarutil.e_new_evar isevars env ~src:(loc, QuestionMark opaque) c in let (key, args) = destEvar evar in (try trace (str "Constructed evar " ++ int key ++ str " applied to args: " ++ print_args env args ++ str " for type: "++ @@ -162,25 +170,33 @@ let make_existential_expr loc env c = let string_of_hole_kind = function | ImplicitArg _ -> "ImplicitArg" | BinderType _ -> "BinderType" - | QuestionMark -> "QuestionMark" + | QuestionMark _ -> "QuestionMark" | CasesType -> "CasesType" | InternalHole -> "InternalHole" | TomatchTypeParameter _ -> "TomatchTypeParameter" - -let non_instanciated_map env evd = - let evm = evars_of !evd in - List.fold_left - (fun evm (key, evi) -> - let (loc,k) = evar_source key !evd in - debug 2 (str "evar " ++ int key ++ str " has kind " ++ - str (string_of_hole_kind k)); - match k with - QuestionMark -> Evd.add evm key evi - | _ -> + +let evars_of_term evc init c = + let rec evrec acc c = + match kind_of_term c with + | Evar (n, _) when Evd.mem evc n -> Evd.add acc n (Evd.find evc n) + | Evar (n, _) -> assert(false) + | _ -> fold_constr evrec acc c + in + evrec init c + +let non_instanciated_map env evd evm = + List.fold_left + (fun evm (key, evi) -> + let (loc,k) = evar_source key !evd in + debug 2 (str "evar " ++ int key ++ str " has kind " ++ + str (string_of_hole_kind k)); + match k with + QuestionMark _ -> Evd.add evm key evi + | _ -> debug 2 (str " and is an implicit"); Pretype_errors.error_unsolvable_implicit loc env evm k) - Evd.empty (Evarutil.non_instantiated evm) - + Evd.empty (Evarutil.non_instantiated evm) + let global_kind = Decl_kinds.IsDefinition Decl_kinds.Definition let goal_kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Definition @@ -247,11 +263,30 @@ let mk_ex_pi1 a b c = let mk_ex_pi2 a b c = mkApp (Lazy.force ex_pi2, [| a; b; c |]) - let mkSubset name typ prop = mkApp ((Lazy.force sig_).typ, [| typ; mkLambda (name, typ, prop) |]) +let mk_eq typ x y = mkApp (Lazy.force eq_ind, [| typ; x ; y |]) +let mk_eq_refl typ x = mkApp (Lazy.force eq_refl, [| typ; x |]) +let mk_JMeq typ x typ' y = mkApp (Lazy.force jmeq_ind, [| typ; x ; typ'; y |]) +let mk_JMeq_refl typ x = mkApp (Lazy.force jmeq_refl, [| typ; x |]) + +let unsafe_fold_right f = function + hd :: tl -> List.fold_right f tl hd + | [] -> raise (Invalid_argument "unsafe_fold_right") + +let mk_conj l = + let conj_typ = Lazy.force and_typ in + unsafe_fold_right + (fun c conj -> + mkApp (conj_typ, [| c ; conj |])) + l + +let mk_not c = + let notc = Lazy.force not_ref in + mkApp (notc, [| c |]) + let and_tac l hook = let andc = Coqlib.build_coq_and () in let rec aux ((accid, goal, tac, extract) as acc) = function @@ -301,291 +336,7 @@ let destruct_ex ext ex = in aux ex ext open Rawterm - -let rec concatMap f l = - match l with - hd :: tl -> f hd @ concatMap f tl - | [] -> [] -let list_mapi f = - let rec aux i = function - hd :: tl -> f i hd :: aux (succ i) tl - | [] -> [] - in aux 0 - -(* -let make_discr (loc, po, tml, eqns) = - let mkHole = RHole (dummy_loc, InternalHole) in - - let rec vars_of_pat = function - RPatVar (loc, n) -> (match n with Anonymous -> [] | Name n -> [n]) - | RPatCstr (loc, csrt, pats, _) -> - concatMap vars_of_pat pats - in - let rec constr_of_pat l = function - RPatVar (loc, n) -> - (match n with - Anonymous -> - let n = next_name_away_from "x" l in - RVar n, (n :: l) - | Name n -> RVar n, l) - | RPatCstr (loc, csrt, pats, _) -> - let (args, vars) = - List.fold_left - (fun (args, vars) x -> - let c, vars = constr_of_pat vars x in - c :: args, vars) - ([], l) pats - in - RApp ((RRef (dummy_loc, ConstructRef cstr)), args), vars - in - let rec constr_of_pat l = function - RPatVar (loc, n) -> - (match n with - Anonymous -> - let n = next_name_away_from "x" l in - RVar n, (n :: l) - | Name n -> RVar n, l) - | RPatCstr (loc, csrt, pats, _) -> - let (args, vars) = - List.fold_left - (fun (args, vars) x -> - let c, vars = constr_of_pat vars x in - c :: args, vars) - ([], l) pats - in - RApp ((RRef (dummy_loc, ConstructRef cstr)), args), vars - in - let constrs_of_pats v l = - List.fold_left - (fun (v, acc) x -> - let x', v' = constr_of_pat v x in - (l', v' :: acc)) - (v, []) l - in - let rec pat_of_pat l = function - RPatVar (loc, n) -> - let n', l = match n with - Anonymous -> - let n = next_name_away_from "x" l in - n, n :: l - | Name n -> n, n :: l - in - RPatVar (loc, Name n'), l - | RPatCstr (loc, cstr, pats, (loc, alias)) -> - let args, vars, s = - List.fold_left (fun (args, vars) x -> - let pat', vars = pat_of_pat vars pat in - pat' :: args, vars) - ([], alias :: l) pats - in RPatCstr (loc, cstr, args, (loc, alias)), vars - in - let pats_of_pats l = - List.fold_left - (fun (v, acc) x -> - let x', v' = pat_of_pat v x in - (v', x' :: acc)) - ([], []) l - in - let eq_of_pat p used c = - let constr, vars' = constr_of_pat used p in - let eq = RApp (dummy_loc, RRef (dummy_loc, Lazy.force eqind_ref), [mkHole; constr; c]) in - vars', eq - in - let eqs_of_pats ps used cstrs = - List.fold_left2 - (fun (vars, eqs) pat c -> - let (vars', eq) = eq_of_pat pat c in - match eqs with - None -> Some eq - | Some eqs -> - Some (RApp (dummy_loc, RRef (dummy_loc, Lazy.force and_ref), [eq, eqs]))) - (used, None) ps cstrs - in - let quantify c l = - List.fold_left - (fun acc name -> RProd (dummy_loc, name, mkHole, acc)) - c l - in - let quantpats = - List.fold_left - (fun (acc, pats) ((loc, idl, cpl, c) as x) -> - let vars, cpl = pats_of_pats cpl in - let l', constrs = constrs_of_pats vars cpl in - let discrs = - List.map (fun (_, _, cpl', _) -> - let qvars, eqs = eqs_of_pats cpl' l' constrs in - let neg = RApp (dummy_loc, RRef (dummy_loc, Lazy.force not_ref), [out_some eqs]) in - let pat_ineq = quantify qvars neg in - - ) - pats in - - - - - - - - (x, pat_ineq)) - in - List.fold_left - (fun acc ((loc, idl, cpl, c0) pat) -> - - - let c' = - List.fold_left - (fun acc (n, t) -> - RLambda (dummy_loc, n, mkHole, acc)) - c eqs_types - in (loc, idl, cpl, c')) - eqns - i -*) -(* let rewrite_cases_aux (loc, po, tml, eqns) = *) -(* let tml = list_mapi (fun i (c, (n, opt)) -> c, *) -(* ((match n with *) -(* Name id -> (match c with *) -(* | RVar (_, id') when id = id' -> *) -(* Name (id_of_string (string_of_id id ^ "'")) *) -(* | _ -> n) *) -(* | Anonymous -> Name (id_of_string ("x" ^ string_of_int i))), *) -(* opt)) tml *) -(* in *) -(* let mkHole = RHole (dummy_loc, InternalHole) in *) -(* (\* let mkeq c n = RApp (dummy_loc, RRef (dummy_loc, (Lazy.force eqind_ref)), *\) *) -(* (\* [mkHole; c; n]) *\) *) -(* (\* in *\) *) -(* let mkeq c n = RApp (dummy_loc, RRef (dummy_loc, (Lazy.force eqdep_ind_ref)), *) -(* [mkHole; c; mkHole; n]) *) -(* in *) -(* let eqs_types = *) -(* List.map *) -(* (fun (c, (n, _)) -> *) -(* let id = match n with Name id -> id | _ -> assert false in *) -(* let heqid = id_of_string ("Heq" ^ string_of_id id) in *) -(* Name heqid, mkeq c (RVar (dummy_loc, id))) *) -(* tml *) -(* in *) -(* let po = *) -(* List.fold_right *) -(* (fun (n,t) acc -> *) -(* RProd (dummy_loc, Anonymous, t, acc)) *) -(* eqs_types (match po with *) -(* Some e -> e *) -(* | None -> mkHole) *) -(* in *) -(* let eqns = *) -(* List.map (fun (loc, idl, cpl, c) -> *) -(* let c' = *) -(* List.fold_left *) -(* (fun acc (n, t) -> *) -(* RLambda (dummy_loc, n, mkHole, acc)) *) -(* c eqs_types *) -(* in (loc, idl, cpl, c')) *) -(* eqns *) -(* in *) -(* let mk_refl_equal c = RApp (dummy_loc, RRef (dummy_loc, Lazy.force refl_equal_ref), *) -(* [mkHole; c]) *) -(* in *) -(* (\*let mk_refl_equal c = RApp (dummy_loc, RRef (dummy_loc, Lazy.force refl_equal_ref), *) -(* [mkHole; c]) *) -(* in*\) *) -(* let refls = List.map (fun (c, _) -> mk_refl_equal c) tml in *) -(* let case = RCases (loc,Some po,tml,eqns) in *) -(* let app = RApp (dummy_loc, case, refls) in *) -(* app *) - -(* let rec rewrite_cases c = *) -(* match c with *) -(* RCases _ -> let c' = map_rawconstr rewrite_cases c in *) -(* (match c' with *) -(* | RCases (x, y, z, w) -> rewrite_cases_aux (x,y,z,w) *) -(* | _ -> assert(false)) *) -(* | _ -> map_rawconstr rewrite_cases c *) - -(* let rewrite_cases env c = *) -(* let c' = rewrite_cases c in *) -(* let _ = trace (str "Rewrote cases: " ++ spc () ++ my_print_rawconstr env c') in *) -(* c' *) - -let list_mapi f = - let rec aux i = function - hd :: tl -> f i hd :: aux (succ i) tl - | [] -> [] - in aux 0 - -open Rawterm - -let rewrite_cases_aux (loc, po, tml, eqns) = - let tml' = list_mapi (fun i (c, (n, opt)) -> c, - ((match n with - Name id -> (match c with - | RVar (_, id') when id = id' -> - id, (id_of_string (string_of_id id ^ "Heq_id")) - | RVar (_, id') -> - id', id - | _ -> id_of_string (string_of_id id ^ "Heq_id"), id) - | Anonymous -> - let str = "Heq_id" ^ string_of_int i in - id_of_string str, id_of_string (str ^ "'")), - opt)) tml - in - let mkHole = RHole (dummy_loc, InternalHole) in - let mkCoerceCast c = RCast (dummy_loc, c, CastCoerce, mkHole) in - let mkeq c n = RApp (dummy_loc, RRef (dummy_loc, (Lazy.force eq_ind_ref)), - [mkHole; c; n]) - in - let eqs_types = - List.map - (fun (c, ((id, id'), _)) -> - let heqid = id_of_string ("Heq" ^ string_of_id id) in - Name heqid, mkeq (RVar (dummy_loc, id')) c) - tml' - in - let po = - List.fold_right - (fun (n,t) acc -> - RProd (dummy_loc, Anonymous, t, acc)) - eqs_types (match po with - Some e -> e - | None -> mkHole) - in - let eqns = - List.map (fun (loc, idl, cpl, c) -> - let c' = - List.fold_left - (fun acc (n, t) -> - RLambda (dummy_loc, n, mkHole, acc)) - c eqs_types - in (loc, idl, cpl, c')) - eqns - in - let mk_refl_equal c = RApp (dummy_loc, RRef (dummy_loc, Lazy.force refl_equal_ref), - [mkHole; c]) - in - let refls = List.map (fun (c, ((id, _), _)) -> mk_refl_equal (mkCoerceCast c)) tml' in - let tml'' = List.map (fun (c, ((id, id'), opt)) -> c, (Name id', opt)) tml' in - let case = RCases (loc,Some po,tml'',eqns) in - let app = RApp (dummy_loc, case, refls) in -(* let letapp = List.fold_left (fun acc (c, ((id, id'), opt)) -> RLetIn (dummy_loc, Name id, c, acc)) *) -(* app tml' *) -(* in *) - app - -let rec rewrite_cases c = - match c with - RCases _ -> let c' = map_rawconstr rewrite_cases c in - (match c' with - | RCases (x, y, z, w) -> rewrite_cases_aux (x,y,z,w) - | _ -> assert(false)) - | _ -> map_rawconstr rewrite_cases c - -let rewrite_cases env c = c -(* let c' = rewrite_cases c in *) -(* let _ = trace (str "Rewrote cases: " ++ spc () ++ my_print_rawconstr env c') in *) -(* c' *) - let id_of_name = function Name n -> n | Anonymous -> raise (Invalid_argument "id_of_name") @@ -601,23 +352,6 @@ let recursive_message v = spc () ++ str "are recursively defined") (* Solve an obligation using tactics, return the corresponding proof term *) -(* -let solve_by_tac ev t = - debug 1 (str "Solving goal using tactics: " ++ Evd.pr_evar_info ev); - let goal = Proof_trees.mk_goal ev.evar_hyps ev.evar_concl None in - debug 1 (str "Goal created"); - let ts = Tacmach.mk_pftreestate goal in - debug 1 (str "Got pftreestate"); - let solved_state = Tacmach.solve_pftreestate t ts in - debug 1 (str "Solved goal"); - let _, l = Tacmach.extract_open_pftreestate solved_state in - List.iter (fun (_, x) -> debug 1 (str "left hole of type " ++ my_print_constr (Global.env()) x)) l; - let c = Tacmach.extract_pftreestate solved_state in - debug 1 (str "Extracted term"); - debug 1 (str "Term constructed in solve by tac: " ++ my_print_constr (Global.env ()) c); - c - *) - let solve_by_tac evi t = debug 2 (str "Solving goal using tactics: " ++ Evd.pr_evar_info evi); let id = id_of_string "H" in @@ -705,3 +439,12 @@ let pr_evar_defs evd = if meta_list evd = [] then mt() else str"METAS:"++brk(0,1)++pr_meta_map evd in v 0 (pp_evm ++ pp_met) + +let subtac_utils_path = + make_dirpath (List.map id_of_string ["Utils";contrib_name;"Coq"]) +let utils_tac s = + lazy(make_kn (MPfile subtac_utils_path) (make_dirpath []) (mk_label s)) + +let utils_call tac args = + TacArg(TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force (utils_tac tac)),args)) + diff --git a/contrib/subtac/subtac_utils.mli b/contrib/subtac/subtac_utils.mli index 482640f9..5a5dd427 100644 --- a/contrib/subtac/subtac_utils.mli +++ b/contrib/subtac/subtac_utils.mli @@ -27,6 +27,7 @@ val fix_sub_ref : global_reference lazy_t val fix_measure_sub_ref : global_reference lazy_t val lt_ref : global_reference lazy_t val lt_wf_ref : global_reference lazy_t +val refl_ref : global_reference lazy_t val sig_ref : reference val proj1_sig_ref : reference val proj2_sig_ref : reference @@ -37,13 +38,16 @@ val eq_ind : constr lazy_t val eq_rec : constr lazy_t val eq_rect : constr lazy_t val eq_refl : constr lazy_t -val eq_ind_ref : global_reference lazy_t -val refl_equal_ref : global_reference lazy_t + +val not_ref : constr lazy_t +val and_typ : constr lazy_t val eqdep_ind : constr lazy_t val eqdep_rec : constr lazy_t -val eqdep_ind_ref : global_reference lazy_t -val eqdep_intro_ref : global_reference lazy_t + +val jmeq_ind : constr lazy_t +val jmeq_rec : constr lazy_t +val jmeq_refl : constr lazy_t val boolind : constr lazy_t val sumboolind : constr lazy_t @@ -79,10 +83,11 @@ val wf_relations : (constr, constr lazy_t) Hashtbl.t type binders = local_binder list val app_opt : ('a -> 'a) option -> 'a -> 'a val print_args : env -> constr array -> std_ppcmds -val make_existential : loc -> env -> evar_defs ref -> types -> constr +val make_existential : loc -> ?opaque:bool -> env -> evar_defs ref -> types -> constr val make_existential_expr : loc -> 'a -> 'b -> constr_expr val string_of_hole_kind : hole_kind -> string -val non_instanciated_map : env -> evar_defs ref -> evar_map +val evars_of_term : evar_map -> evar_map -> constr -> evar_map +val non_instanciated_map : env -> evar_defs ref -> evar_map -> evar_map val global_kind : logical_kind val goal_kind : locality_flag * goal_object_kind val global_proof_kind : logical_kind @@ -95,6 +100,12 @@ val mkProj1 : constr -> constr -> constr -> constr val mkProj1 : constr -> constr -> constr -> constr val mk_ex_pi1 : constr -> constr -> constr -> constr val mk_ex_pi1 : constr -> constr -> constr -> constr +val mk_eq : types -> constr -> constr -> types +val mk_eq_refl : types -> constr -> constr +val mk_JMeq : types -> constr-> types -> constr -> types +val mk_JMeq_refl : types -> constr -> constr +val mk_conj : types list -> types +val mk_not : types -> types val build_dependent_sum : (identifier * types) list -> Proof_type.tactic * types val and_tac : (identifier * 'a * constr * Proof_type.tactic) list -> @@ -102,7 +113,6 @@ val and_tac : (identifier * 'a * constr * Proof_type.tactic) list -> val destruct_ex : constr -> constr -> constr list -val rewrite_cases : Environ.env -> Rawterm.rawconstr -> Rawterm.rawconstr val id_of_name : name -> identifier val definition_message : identifier -> unit @@ -114,3 +124,7 @@ val string_of_list : string -> ('a -> string) -> 'a list -> string val string_of_intset : Intset.t -> string val pr_evar_defs : evar_defs -> Pp.std_ppcmds + +val utils_call : string -> Tacexpr.glob_tactic_arg list -> Tacexpr.glob_tactic_expr + +val pp_list : ('a -> Pp.std_ppcmds) -> 'a list -> Pp.std_ppcmds diff --git a/contrib/subtac/test/ListDep.v b/contrib/subtac/test/ListDep.v index 7ab720f6..97cef9a5 100644 --- a/contrib/subtac/test/ListDep.v +++ b/contrib/subtac/test/ListDep.v @@ -1,3 +1,4 @@ +(* -*- coq-prog-args: ("-emacs-U" "-debug") -*- *) Require Import List. Require Import Coq.subtac.Utils. @@ -21,63 +22,25 @@ Section Map_DependentRecursor. Variable l : list U. Variable f : { x : U | In x l } -> V. + Obligations Tactic := unfold sub_list in * ; + subtac_simpl ; intuition. + Program Fixpoint map_rec ( l' : list U | sub_list l' l ) - { measure l' length } : { r : list V | length r = length l' } := + { measure length l' } : { r : list V | length r = length l' } := match l' with nil => nil | cons x tl => let tl' := map_rec tl in f x :: tl' end. - Obligation 1. - intros. - destruct tl' ; simpl ; simpl in e. - subst x0 tl0. - rewrite <- Heql'. - rewrite e. - auto. - Qed. - - Obligation 2. - simpl. - intros. - destruct l'. - simpl in Heql'. - destruct x0 ; simpl ; try discriminate. - inversion Heql'. - inversion s. - apply H. - auto with datatypes. - Qed. - - - Obligation 3 of map_rec. - simpl. - intros. - rewrite <- Heql'. + Next Obligation. + destruct_call map_rec. + simpl in *. + subst l'. simpl ; auto with arith. - Qed. - - Obligation 4. - simpl. - intros. - destruct l'. - simpl in Heql'. - destruct x0 ; simpl ; try discriminate. - inversion Heql'. - subst x tl. - apply sub_list_tl with u ; auto. - Qed. - - Obligation 5. - intros. - rewrite <- Heql' ; auto. - Qed. - - Program Definition map : list V := map_rec l. - Obligation 1. - split ; auto. - Qed. + Qed. + + Program Definition map : list V := map_rec l. End Map_DependentRecursor. diff --git a/contrib/subtac/test/ListsTest.v b/contrib/subtac/test/ListsTest.v index b8d13fe6..3ceea173 100644 --- a/contrib/subtac/test/ListsTest.v +++ b/contrib/subtac/test/ListsTest.v @@ -70,7 +70,22 @@ Section Nth. Next Obligation. Proof. - inversion l0. + intros. + inversion H. Defined. + + Program Fixpoint nth' (l : list A) (n : nat | n < length l) { struct l } : A := + match l, n with + | hd :: _, 0 => hd + | _ :: tl, S n' => nth' tl n' + | nil, _ => ! + end. + + Next Obligation. + Proof. + intros. + inversion H. + Defined. + End Nth. diff --git a/contrib/xml/cic2acic.ml b/contrib/xml/cic2acic.ml index ff07c3c4..8a5967a2 100644 --- a/contrib/xml/cic2acic.ml +++ b/contrib/xml/cic2acic.ml @@ -22,8 +22,13 @@ let get_module_path_of_section_path path = List.filter (function modul -> Libnames.is_dirpath_prefix_of modul dirpath) modules with - [modul] -> modul - | _ -> raise TwoModulesWhoseDirPathIsOneAPrefixOfTheOther + [] -> + Pp.warning ("Modules not supported: reference to "^ + Libnames.string_of_path path^" will be wrong"); + dirpath + | [modul] -> modul + | _ -> + raise TwoModulesWhoseDirPathIsOneAPrefixOfTheOther ;; (*CSC: Problem: here we are using the wrong (???) hypothesis that there do *) @@ -652,11 +657,13 @@ print_endline "PASSATO" ; flush stdout ; A.ALambdas (new_passed_lambdas, t') ) | T.LetIn (n,s,t,d) -> - let n' = + let id = match n with - N.Anonymous -> N.Anonymous - | _ -> - N.Name (Nameops.next_name_away n (Termops.ids_of_context env)) + N.Anonymous -> N.id_of_string "_X" + | N.Name id -> id + in + let n' = + N.Name (Nameops.next_ident_away id (Termops.ids_of_context env)) in Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; let sourcesort = diff --git a/contrib/xml/doubleTypeInference.ml b/contrib/xml/doubleTypeInference.ml index c7d3b4ff..cce78891 100644 --- a/contrib/xml/doubleTypeInference.ml +++ b/contrib/xml/doubleTypeInference.ml @@ -26,31 +26,13 @@ let cprop = (N.mk_label "CProp") ;; -let whd_betadeltaiotacprop env evar_map ty = +let whd_betadeltaiotacprop env _evar_map ty = let module R = Rawterm in - let red_exp = - R.Hnf (*** Instead CProp is made Opaque ***) -(* - R.Cbv - {R.rBeta = true ; R.rIota = true ; R.rDelta = true; R.rZeta=true ; - R.rConst = [Names.EvalConstRef cprop] - } -*) - in -Conv_oracle.set_opaque_const cprop; -prerr_endline "###whd_betadeltaiotacprop:" ; -let xxx = -(*Pp.msgerr (Printer.pr_lconstr_env env ty);*) -prerr_endline ""; - (fst (Redexpr.reduction_of_red_expr red_exp)) env evar_map ty -in -prerr_endline "###FINE" ; -(* -Pp.msgerr (Printer.pr_lconstr_env env xxx); -*) -prerr_endline ""; -Conv_oracle.set_transparent_const cprop; -xxx + let module C = Closure in + let module CR = C.RedFlags in + (*** CProp is made Opaque ***) + let flags = CR.red_sub C.betadeltaiota (CR.fCONST cprop) in + C.whd_val (C.create_clos_infos flags env) (C.inject ty) ;; diff --git a/contrib/xml/xmlcommand.ml b/contrib/xml/xmlcommand.ml index f286d2c8..01271323 100644 --- a/contrib/xml/xmlcommand.ml +++ b/contrib/xml/xmlcommand.ml @@ -461,11 +461,42 @@ let kind_of_constant kn = match Declare.constant_kind (Nametab.sp_of_global(Libnames.ConstRef kn)) with | DK.IsAssumption DK.Definitional -> "AXIOM","Declaration" | DK.IsAssumption DK.Logical -> "AXIOM","Axiom" - | DK.IsAssumption DK.Conjectural -> "AXIOM","Conjecture" + | DK.IsAssumption DK.Conjectural -> + Pp.warning "Conjecture not supported in dtd (used Declaration instead)"; + "AXIOM","Declaration" | DK.IsDefinition DK.Definition -> "DEFINITION","Definition" - | DK.IsDefinition DK.Example -> "DEFINITION","Example" - | DK.IsDefinition _ -> Util.anomaly "Unsupported constant kind" - | DK.IsProof thm -> "THEOREM",DK.string_of_theorem_kind thm + | DK.IsDefinition DK.Example -> + Pp.warning "Example not supported in dtd (used Definition instead)"; + "DEFINITION","Definition" + | DK.IsDefinition DK.Coercion -> + Pp.warning "Coercion not supported in dtd (used Definition instead)"; + "DEFINITION","Definition" + | DK.IsDefinition DK.SubClass -> + Pp.warning "SubClass not supported in dtd (used Definition instead)"; + "DEFINITION","Definition" + | DK.IsDefinition DK.CanonicalStructure -> + Pp.warning "CanonicalStructure not supported in dtd (used Definition instead)"; + "DEFINITION","Definition" + | DK.IsDefinition DK.Fixpoint -> + Pp.warning "Fixpoint not supported in dtd (used Definition instead)"; + "DEFINITION","Definition" + | DK.IsDefinition DK.CoFixpoint -> + Pp.warning "CoFixpoint not supported in dtd (used Definition instead)"; + "DEFINITION","Definition" + | DK.IsDefinition DK.Scheme -> + Pp.warning "Scheme not supported in dtd (used Definition instead)"; + "DEFINITION","Definition" + | DK.IsDefinition DK.StructureComponent -> + Pp.warning "StructureComponent not supported in dtd (used Definition instead)"; + "DEFINITION","Definition" + | DK.IsDefinition DK.IdentityCoercion -> + Pp.warning "IdentityCoercion not supported in dtd (used Definition instead)"; + "DEFINITION","Definition" + | DK.IsProof (DK.Theorem|DK.Lemma|DK.Corollary|DK.Fact|DK.Remark as thm) -> + "THEOREM",DK.string_of_theorem_kind thm + | DK.IsProof _ -> + Pp.warning "Unsupported theorem kind (used Theorem instead)"; + "THEOREM",DK.string_of_theorem_kind DK.Theorem ;; let kind_of_global r = diff --git a/doc/Makefile b/doc/Makefile index 6209b0c8..403e2047 100644 --- a/doc/Makefile +++ b/doc/Makefile @@ -116,7 +116,7 @@ REFMANCOQTEXFILES=\ refman/Setoid.v.tex refman/Helm.tex # refman/Natural.v.tex REFMANTEXFILES=\ - refman/headers.tex \ + refman/headers.sty \ refman/Reference-Manual.tex refman/RefMan-pre.tex \ refman/RefMan-int.tex refman/RefMan-pro.tex \ refman/RefMan-com.tex \ @@ -152,7 +152,7 @@ refman/Reference-Manual.pdf: refman/Reference-Manual.tex ### Reference Manual (browsable format) -refman/Reference-Manual.html: refman/Reference-Manual.dvi # to ensure bbl file +refman/Reference-Manual.html: refman/headers.hva refman/Reference-Manual.dvi # to ensure bbl file (cd refman; hevea -fix -exec xxdate.exe ./Reference-Manual.tex) refman/html/index.html: refman/Reference-Manual.html $(REFMANPNGFILES) \ diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index f63b6cf4..81ab034b 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -1,8 +1,13 @@ -<html> +<!DOCTYPE html + PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" + "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> + +<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en"> <head> -<link rel="stylesheet" href="coqdoc.css" type="text/css"> -<title>The Coq Standard Library +<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-15"/> +<link rel="stylesheet" href="css/context.css" type="text/css"> +<title>The Coq Standard Library</title> </head> <body> @@ -60,6 +65,7 @@ through the <tt>Require Import</tt> command.</p> theories/Logic/Hurkens.v theories/Logic/ProofIrrelevance.v theories/Logic/ProofIrrelevanceFacts.v + theories/Logic/ConstructiveEpsilon.v </dd> <dt> <b>Arith</b>: @@ -203,6 +209,8 @@ through the <tt>Require Import</tt> command.</p> theories/Reals/SeqProp.v theories/Reals/SeqSeries.v theories/Reals/Sqrt_reg.v + theories/Reals/LegacyRfield.v + theories/Reals/Rpow_def.v (theories/Reals/Reals.v) </dd> @@ -289,6 +297,7 @@ through the <tt>Require Import</tt> command.</p> theories/Lists/SetoidList.v theories/Lists/Streams.v theories/Lists/TheoryList.v + theories/Lists/ListTactics.v </dd> <dt> <b>FSets</b>: diff --git a/ide/coq_commands.ml b/ide/coq_commands.ml index 30d99f5b..677c5eff 100644 --- a/ide/coq_commands.ml +++ b/ide/coq_commands.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: coq_commands.ml 7102 2005-06-03 13:14:27Z coq $ *) +(* $Id: coq_commands.ml 9976 2007-07-12 11:58:30Z msozeau $ *) let commands = [ [(* "Abort"; *) @@ -77,10 +77,17 @@ let commands = [ ["Module"; "Module Type"; "Mutual Inductive";]; - ["Notation";]; - ["Opaque";]; + ["Notation"; + "Next Obligation";]; + ["Opaque"; + "Obligations Tactic";]; ["Parameter"; - "Proof."]; + "Proof."; + "Program Definition"; + "Program Fixpoint"; + "Program Lemma"; + "Program Theorem"; + ]; ["Qed."; ]; ["Read Module"; @@ -155,6 +162,8 @@ let state_preserving = [ "Extraction Module"; "Inspect"; "Locate"; + + "Obligations"; "Print"; "Print All."; "Print Classes"; diff --git a/ide/highlight.mll b/ide/highlight.mll index 27ead696..2f099208 100644 --- a/ide/highlight.mll +++ b/ide/highlight.mll @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: highlight.mll 8880 2006-05-31 10:52:08Z notin $ *) +(* $Id: highlight.mll 9976 2007-07-12 11:58:30Z msozeau $ *) { @@ -28,7 +28,8 @@ "Notation"; "Proof" ; "Print"; "Qed" ; "Require" ; "Reset"; "Undo"; "Save" ; "Section" ; "Unset" ; - "Set" ; "Notation" + "Set" ; "Notation"; + "Implicit"; "Arguments"; "Unfold"; "Resolve" ]; Hashtbl.mem h @@ -36,7 +37,7 @@ let h = Hashtbl.create 97 in List.iter (fun s -> Hashtbl.add h s ()) [ "forall"; "fun"; "match"; "fix"; "cofix"; "with"; "for"; - "end"; "as"; "let"; "if"; "then"; "else"; "return"; + "end"; "as"; "let"; "in"; "dest"; "if"; "then"; "else"; "return"; "Prop"; "Set"; "Type"]; Hashtbl.mem h @@ -45,7 +46,7 @@ List.iter (fun s -> Hashtbl.add h s ()) [ "Theorem" ; "Lemma" ; "Fact" ; "Remark" ; "Corollary" ; "Proposition" ; "Property" ; "Definition" ; "Let" ; "Example" ; "SubClass" ; "Inductive" ; "CoInductive" ; - "Record" ; "Structure" ; "Fixpoint" ; "CoFixpoint"; + "Record" ; "Structure" ; "Fixpoint" ; "CoFixpoint"; "Hypothesis" ; "Variable" ; "Axiom" ; "Parameter" ; "Conjecture" ; "Hypotheses" ; "Variables" ; "Axioms" ; "Parameters" ]; @@ -74,12 +75,14 @@ let declaration = "Inductive" | "CoInductive" | "Record" | "Structure" | "Fixpoint" | "CoFixpoint" + rule next_order = parse | "(*" { comment_start := lexeme_start lexbuf; comment lexbuf } | "Module Type" { lexeme_start lexbuf, lexeme_end lexbuf, "kwd" } + | "Program" space+ ident as id { lexeme_start lexbuf, lexeme_end lexbuf, "decl" } | ident as id { if is_keyword id then lexeme_start lexbuf, lexeme_end lexbuf, "kwd" diff --git a/ide/utils/configwin_ihm.ml b/ide/utils/configwin_ihm.ml index e9ba9789..240fd829 100644 --- a/ide/utils/configwin_ihm.ml +++ b/ide/utils/configwin_ihm.ml @@ -1108,10 +1108,6 @@ let edit ?(with_apply=true) List.iter (fun param_box -> param_box#apply) list_param_box ; apply () in - let f_ok () = - List.iter (fun param_box -> param_box#apply) list_param_box ; - Return_ok - in let destroy () = tooltips#destroy () ; dialog#destroy (); @@ -1120,7 +1116,7 @@ let edit ?(with_apply=true) try match dialog#run () with | `APPLY -> f_apply (); iter Return_apply - | `OK -> destroy (); f_ok () + | `OK -> f_apply (); destroy (); Return_ok | _ -> destroy (); rep with Failure s -> diff --git a/interp/constrextern.ml b/interp/constrextern.ml index ffedcfff..349e8629 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: constrextern.ml 9226 2006-10-09 16:11:01Z herbelin $ *) +(* $Id: constrextern.ml 9976 2007-07-12 11:58:30Z msozeau $ *) (*i*) open Pp @@ -191,9 +191,11 @@ let rec check_same_type ty1 ty2 = | CHole _, CHole _ -> () | CPatVar(_,i1), CPatVar(_,i2) when i1=i2 -> () | CSort(_,s1), CSort(_,s2) when s1=s2 -> () - | CCast(_,a1,_,b1), CCast(_,a2,_,b2) -> + | CCast(_,a1,CastConv (_,b1)), CCast(_,a2, CastConv(_,b2)) -> check_same_type a1 a2; check_same_type b1 b2 + | CCast(_,a1,CastCoerce), CCast(_,a2, CastCoerce) -> + check_same_type a1 a2 | CNotation(_,n1,e1), CNotation(_,n2,e2) when n1=n2 -> List.iter2 check_same_type e1 e2 | CPrim(_,i1), CPrim(_,i2) when i1=i2 -> () @@ -283,8 +285,8 @@ let rec same_raw c d = | RSort(_,s1), RSort(_,s2) -> if s1<>s2 then failwith "RSort" | RHole _, _ -> () | _, RHole _ -> () - | RCast(_,c1,_,_),r2 -> same_raw c1 r2 - | r1, RCast(_,c2,_,_) -> same_raw r1 c2 + | RCast(_,c1,_),r2 -> same_raw c1 r2 + | r1, RCast(_,c2,_) -> same_raw r1 c2 | RDynamic(_,d1), RDynamic(_,d2) -> if d1<>d2 then failwith"RDynamic" | _ -> failwith "same_raw" @@ -402,7 +404,7 @@ let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat = try if !Options.raw_print or !print_no_symbol then raise No_match; let (na,sc,p) = uninterp_prim_token_cases_pattern pat in - match availability_of_prim_token sc scopes with + match availability_of_prim_token sc scopes p with | None -> raise No_match | Some key -> let loc = cases_pattern_loc pat in @@ -602,7 +604,7 @@ let rec share_fix_binders n rbl ty def = let extern_possible_prim_token scopes r = try let (sc,n) = uninterp_prim_token r in - match availability_of_prim_token sc scopes with + match availability_of_prim_token sc scopes n with | None -> None | Some key -> Some (insert_delimiters (CPrim (loc_of_rawconstr r,n)) key) with No_match -> @@ -744,8 +746,10 @@ let rec extern inctx scopes vars r = | RHole (loc,e) -> CHole loc - | RCast (loc,c,k,t) -> - CCast (loc,sub_extern true scopes vars c,k,extern_typ scopes vars t) + | RCast (loc,c, CastConv (k,t)) -> + CCast (loc,sub_extern true scopes vars c, CastConv (k,extern_typ scopes vars t)) + | RCast (loc,c, CastCoerce) -> + CCast (loc,sub_extern true scopes vars c, CastCoerce) | RDynamic (loc,d) -> CDynamic (loc,d) @@ -813,7 +817,7 @@ and extern_symbol (tmp_scope,scopes as allscopes) vars t = function let (t,args) = match t,n with | RApp (_,f,args), Some n when List.length args > n -> let args1, args2 = list_chop n args in - RApp (dummy_loc,f,args1), args2 + (if n = 0 then f else RApp (dummy_loc,f,args1)), args2 | _ -> t,[] in (* Try matching ... *) let subst = match_aconstr t pat in diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 4550518d..e1ee5486 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: constrintern.ml 9611 2007-02-07 15:51:01Z herbelin $ *) +(* $Id: constrintern.ml 9976 2007-07-12 11:58:30Z msozeau $ *) open Pp open Util @@ -384,7 +384,7 @@ let check_number_of_pattern loc n l = if n<>p then raise (InternalisationError (loc,BadPatternsNumber (n,p))) let check_or_pat_variables loc ids idsl = - if List.exists ((<>) ids) idsl then + if List.exists (fun ids' -> not (list_eq_set ids ids')) idsl then user_err_loc (loc, "", str "The components of this disjunctive pattern must bind the same variables") @@ -424,17 +424,17 @@ let rec subst_pat_iterator y t (subst,p) = match p with let pl = simple_product_of_cases_patterns l' in List.map (fun (subst',pl) -> subst'@subst,PatCstr (loc,id,pl,alias)) pl -let subst_cases_pattern loc (ids,asubst as aliases) intern subst scopes a = - let rec aux aliases subst = function +let subst_cases_pattern loc alias intern subst scopes a = + let rec aux alias subst = function | AVar id -> begin (* subst remembers the delimiters stack in the interpretation *) (* of the notations *) try let (a,(scopt,subscopes)) = List.assoc id subst in - intern (subscopes@scopes) ([],[]) scopt a + intern (subscopes@scopes) ([],[]) scopt a with Not_found -> - if id = ldots_var then [],[[], PatVar (loc,Name id)] else + if id = ldots_var then [], [[], PatVar (loc,Name id)] else anomaly ("Unbound pattern notation variable: "^(string_of_id id)) (* (* Happens for local notation joint with inductive/fixpoint defs *) @@ -444,33 +444,34 @@ let subst_cases_pattern loc (ids,asubst as aliases) intern subst scopes a = *) end | ARef (ConstructRef c) -> - (ids,[asubst, PatCstr (loc,c, [], alias_of aliases)]) + ([],[[], PatCstr (loc,c, [], alias)]) | AApp (ARef (ConstructRef (ind,_ as c)),args) -> let nparams = (fst (Global.lookup_inductive ind)).Declarations.mind_nparams in let _,args = list_chop nparams args in - let idslpll = List.map (aux ([],[]) subst) args in - let ids',pll = product_of_cases_patterns ids idslpll in + let idslpll = List.map (aux Anonymous subst) args in + let ids',pll = product_of_cases_patterns [] idslpll in let pl' = List.map (fun (subst,pl) -> - subst,PatCstr (loc,c,pl,alias_of aliases)) pll in - ids', pl' + subst,PatCstr (loc,c,pl,alias)) pll in + ids', pl' | AList (x,_,iter,terminator,lassoc) -> (try (* All elements of the list are in scopes (scopt,subscopes) *) let (a,(scopt,subscopes)) = List.assoc x subst in - let termin = aux ([],[]) subst terminator in + let termin = aux Anonymous subst terminator in let l = decode_patlist_value a in let idsl,v = List.fold_right (fun a (tids,t) -> - let uids,u = aux ([],[]) ((x,(a,(scopt,subscopes)))::subst) iter in + let uids,u = aux Anonymous ((x,(a,(scopt,subscopes)))::subst) iter in let pll = List.map (subst_pat_iterator ldots_var t) u in tids@uids, List.flatten pll) (if lassoc then List.rev l else l) termin in - ids@idsl, v + idsl, List.map (fun ((subst, pl) as x) -> + match pl with PatCstr (loc, c, pl, Anonymous) -> (subst, PatCstr (loc, c, pl, alias)) | _ -> x) v with Not_found -> anomaly "Inconsistent substitution of recursive notation") | t -> user_err_loc (loc,"",str "Invalid notation for pattern") - in aux aliases subst a - + in aux alias subst a + (* Differentiating between constructors and matching variables *) type pattern_qualid_kind = | ConstrPat of (constructor * cases_pattern list) @@ -565,11 +566,12 @@ let rec intern_cases_pattern genv scopes (ids,subst as aliases) tmp_scope = intern_cases_pattern genv scopes aliases tmp_scope a | CPatNotation (loc, ntn, args) -> let ntn,args = contract_pat_notation ntn args in - let ((ids,c),df) = Notation.interp_notation loc ntn (tmp_scope,scopes) in + let ((ids',c),df) = Notation.interp_notation loc ntn (tmp_scope,scopes) in if !dump then dump_notation_location (patntn_loc loc args ntn) df; - let subst = List.map2 (fun (id,scl) a -> (id,(a,scl))) ids args in - subst_cases_pattern loc aliases (intern_cases_pattern genv) subst scopes + let subst = List.map2 (fun (id,scl) a -> (id,(a,scl))) ids' args in + let ids'',pl = subst_cases_pattern loc (alias_of aliases) (intern_cases_pattern genv) subst scopes c + in ids@ids'', pl | CPatPrim (loc, p) -> let a = alias_of aliases in let (c,df) = Notation.interp_prim_token_cases_pattern loc p a @@ -915,7 +917,7 @@ let internalise sigma globalenv env allow_soapp lvar c = let p' = option_map (intern_type env'') po in RIf (loc, c', (na', p'), intern env b1, intern env b2) | CHole loc -> - RHole (loc, Evd.QuestionMark) + RHole (loc, Evd.QuestionMark true) | CPatVar (loc, n) when allow_soapp -> RPatVar (loc, n) | CPatVar (loc, (false,n)) -> @@ -926,8 +928,10 @@ let internalise sigma globalenv env allow_soapp lvar c = REvar (loc, n, None) | CSort (loc, s) -> RSort(loc,s) - | CCast (loc, c1, k, c2) -> - RCast (loc,intern env c1,k,intern_type env c2) + | CCast (loc, c1, CastConv (k, c2)) -> + RCast (loc,intern env c1, CastConv (k, intern_type env c2)) + | CCast (loc, c1, CastCoerce) -> + RCast (loc,intern env c1, CastCoerce) | CDynamic (loc,d) -> RDynamic (loc,d) @@ -1087,6 +1091,8 @@ let intern_gen isarity sigma env let intern_constr sigma env c = intern_gen false sigma env c +let intern_type sigma env c = intern_gen true sigma env c + let intern_pattern env patt = try intern_cases_pattern env [] ([],[]) None patt diff --git a/interp/constrintern.mli b/interp/constrintern.mli index d88a058d..4479fcd4 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: constrintern.mli 9154 2006-09-20 17:18:18Z corbinea $ i*) +(*i $Id: constrintern.mli 9976 2007-07-12 11:58:30Z msozeau $ i*) (*i*) open Names @@ -51,6 +51,8 @@ type ltac_sign = identifier list * unbound_ltac_var_map val intern_constr : evar_map -> env -> constr_expr -> rawconstr +val intern_type : evar_map -> env -> constr_expr -> rawconstr + val intern_gen : bool -> evar_map -> env -> ?impls:full_implicits_env -> ?allow_soapp:bool -> ?ltacvars:ltac_sign -> constr_expr -> rawconstr @@ -59,10 +61,6 @@ val intern_pattern : env -> cases_pattern_expr -> Names.identifier list * ((Names.identifier * Names.identifier) list * Rawterm.cases_pattern) list -val intern_pattern : env -> cases_pattern_expr -> - Names.identifier list * - ((Names.identifier * Names.identifier) list * Rawterm.cases_pattern) list - (*s Composing internalisation with pretyping *) (* Main interpretation function *) diff --git a/interp/notation.ml b/interp/notation.ml index 7d70b296..08c6f31f 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: notation.ml 9481 2007-01-11 19:17:56Z herbelin $ *) +(* $Id: notation.ml 9694 2007-03-09 18:09:53Z herbelin $ *) (*i*) open Util @@ -393,8 +393,14 @@ let uninterp_prim_token_cases_pattern c = | Some n -> (na,sc,n) with Not_found -> raise No_match -let availability_of_prim_token printer_scope local_scopes = - let f scope = Hashtbl.mem prim_token_interpreter_tab scope in +let availability_of_prim_token printer_scope local_scopes t = + let f scope = + try + (* raise Not_found if no primitive interpreter for scope *) + let interp = Hashtbl.find prim_token_interpreter_tab scope in + (* raise Not_found if no primitive interpreter for this token in scope *) + let _ = interp dummy_loc t in true + with Not_found -> false in let scopes = make_current_scopes local_scopes in option_map snd (find_without_delimiters f (Some printer_scope,None) scopes) diff --git a/interp/notation.mli b/interp/notation.mli index 7be1f9fe..f5c8bdac 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: notation.mli 9481 2007-01-11 19:17:56Z herbelin $ i*) +(*i $Id: notation.mli 9694 2007-03-09 18:09:53Z herbelin $ i*) (*i*) open Util @@ -93,7 +93,7 @@ val uninterp_prim_token_cases_pattern : cases_pattern -> name * scope_name * prim_token val availability_of_prim_token : - scope_name -> local_scopes -> delimiters option option + scope_name -> local_scopes -> prim_token -> delimiters option option (*s Declare and interpret back and forth a notation *) diff --git a/interp/reserve.ml b/interp/reserve.ml index aee981bd..3ec0182b 100644 --- a/interp/reserve.ml +++ b/interp/reserve.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: reserve.ml 8752 2006-04-27 19:37:33Z herbelin $ i*) +(*i $Id: reserve.ml 9976 2007-07-12 11:58:30Z msozeau $ i*) (* Reserved names *) @@ -73,7 +73,8 @@ let rec unloc = function bl, Array.map unloc tyl, Array.map unloc bv) - | RCast (_,c,k,t) -> RCast (dummy_loc,unloc c,k,unloc t) + | RCast (_,c, CastConv (k,t)) -> RCast (dummy_loc,unloc c, CastConv (k,unloc t)) + | RCast (_,c, CastCoerce) -> RCast (dummy_loc,unloc c, CastCoerce) | RSort (_,x) -> RSort (dummy_loc,x) | RHole (_,x) -> RHole (dummy_loc,x) | RRef (_,x) -> RRef (dummy_loc,x) diff --git a/interp/topconstr.ml b/interp/topconstr.ml index 936b6830..af147866 100644 --- a/interp/topconstr.ml +++ b/interp/topconstr.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: topconstr.ml 9226 2006-10-09 16:11:01Z herbelin $ *) +(* $Id: topconstr.ml 9976 2007-07-12 11:58:30Z msozeau $ *) (*i*) open Pp @@ -45,7 +45,7 @@ type aconstr = | ASort of rawsort | AHole of Evd.hole_kind | APatVar of patvar - | ACast of aconstr * cast_type * aconstr + | ACast of aconstr * aconstr cast_type (**********************************************************************) (* Re-interpret a notation as a rawconstr, taking care of binders *) @@ -102,7 +102,10 @@ let rawconstr_of_aconstr_with_binders loc g f e = function | AIf (c,(na,po),b1,b2) -> let e,na = name_fold_map g e na in RIf (loc,f e c,(na,option_map (f e) po),f e b1,f e b2) - | ACast (c,k,t) -> RCast (loc,f e c, k,f e t) + | ACast (c,k) -> RCast (loc,f e c, + match k with + | CastConv (k,t) -> CastConv (k,f e t) + | CastCoerce -> CastCoerce) | ASort x -> RSort (loc,x) | AHole x -> RHole (loc,x) | APatVar n -> RPatVar (loc,(false,n)) @@ -196,7 +199,9 @@ let aconstr_and_vars_of_rawconstr a = | RIf (loc,c,(na,po),b1,b2) -> add_name found na; AIf (aux c,(na,option_map aux po),aux b1,aux b2) - | RCast (_,c,k,t) -> ACast (aux c,k,aux t) + | RCast (_,c,k) -> ACast (aux c, + match k with CastConv (k,t) -> CastConv (k,aux t) + | CastCoerce -> CastCoerce) | RSort (_,s) -> ASort s | RHole (_,w) -> AHole w | RRef (_,r) -> ARef r @@ -342,15 +347,21 @@ let rec subst_aconstr subst bound raw = let ref',t = subst_global subst ref in if ref' == ref then raw else AHole (Evd.InternalHole) - | AHole (Evd.BinderType _ | Evd.QuestionMark | Evd.CasesType | - Evd.InternalHole | Evd.TomatchTypeParameter _) -> raw - - | ACast (r1,k,r2) -> - let r1' = subst_aconstr subst bound r1 - and r2' = subst_aconstr subst bound r2 in - if r1' == r1 && r2' == r2 then raw else - ACast (r1',k,r2') - + | AHole (Evd.BinderType _ | Evd.QuestionMark _ | Evd.CasesType + | Evd.InternalHole | Evd.TomatchTypeParameter _) -> raw + + | ACast (r1,k) -> + match k with + CastConv (k, r2) -> + let r1' = subst_aconstr subst bound r1 + and r2' = subst_aconstr subst bound r2 in + if r1' == r1 && r2' == r2 then raw else + ACast (r1',CastConv (k,r2')) + | CastCoerce -> + let r1' = subst_aconstr subst bound r1 in + if r1' == r1 then raw else + ACast (r1',CastCoerce) + let encode_list_value l = RApp (dummy_loc,RVar (dummy_loc,ldots_var),l) @@ -454,8 +465,10 @@ let rec match_ alp metas sigma a1 a2 = match (a1,a2) with let (alp,sigma) = List.fold_left2 (match_names metas) (alp,sigma) nal1 nal2 in match_ alp metas sigma c1 c2 - | RCast(_,c1,_,t1), ACast(c2,_,t2) -> + | RCast(_,c1, CastConv(_,t1)), ACast(c2, CastConv (_,t2)) -> match_ alp metas (match_ alp metas sigma c1 c2) t1 t2 + | RCast(_,c1, CastCoerce), ACast(c2, CastCoerce) -> + match_ alp metas sigma c1 c2 | RSort (_,s1), ASort s2 when s1 = s2 -> sigma | RPatVar _, AHole _ -> (*Don't hide Metas, they bind in ltac*) raise No_match | a, AHole _ -> sigma @@ -554,7 +567,7 @@ type constr_expr = | CPatVar of loc * (bool * patvar) | CEvar of loc * existential_key | CSort of loc * rawsort - | CCast of loc * constr_expr * cast_type * constr_expr + | CCast of loc * constr_expr * constr_expr cast_type | CNotation of loc * notation * constr_expr list | CPrim of loc * prim_token | CDelimiters of loc * string * constr_expr @@ -616,7 +629,7 @@ let constr_loc = function | CPatVar (loc,_) -> loc | CEvar (loc,_) -> loc | CSort (loc,_) -> loc - | CCast (loc,_,_,_) -> loc + | CCast (loc,_,_) -> loc | CNotation (loc,_,_) -> loc | CPrim (loc,_) -> loc | CDelimiters (loc,_,_) -> loc @@ -694,7 +707,8 @@ let fold_constr_expr_with_binders g f n acc = function | CApp (loc,(_,t),l) -> List.fold_left (f n) (f n acc t) (List.map fst l) | CProdN (_,l,b) | CLambdaN (_,l,b) -> fold_constr_expr_binders g f n acc b l | CLetIn (_,na,a,b) -> fold_constr_expr_binders g f n acc b [[na],a] - | CCast (loc,a,_,b) -> f n (f n acc a) b + | CCast (loc,a,CastConv(_,b)) -> f n (f n acc a) b + | CCast (loc,a,CastCoerce) -> f n acc a | CNotation (_,_,l) -> List.fold_left (f n) acc l | CDelimiters (loc,_,a) -> f n acc a | CHole _ | CEvar _ | CPatVar _ | CSort _ | CPrim _ | CDynamic _ | CRef _ -> @@ -731,7 +745,7 @@ let occur_var_constr_expr id c = Idset.mem id (free_vars_of_constr_expr c) let mkIdentC id = CRef (Ident (dummy_loc, id)) let mkRefC r = CRef r let mkAppC (f,l) = CApp (dummy_loc, (None,f), List.map (fun x -> (x,None)) l) -let mkCastC (a,k,b) = CCast (dummy_loc,a,k,b) +let mkCastC (a,k) = CCast (dummy_loc,a,k) let mkLambdaC (idl,a,b) = CLambdaN (dummy_loc,[idl,a],b) let mkLetInC (id,a,b) = CLetIn (dummy_loc,id,a,b) let mkProdC (idl,a,b) = CProdN (dummy_loc,[idl,a],b) @@ -786,7 +800,8 @@ let map_constr_expr_with_binders g f e = function | CLambdaN (loc,bl,b) -> let (e,bl) = map_binders f g e bl in CLambdaN (loc,bl,f e b) | CLetIn (loc,na,a,b) -> CLetIn (loc,na,f e a,f (name_fold g (snd na) e) b) - | CCast (loc,a,k,b) -> CCast (loc,f e a,k,f e b) + | CCast (loc,a,CastConv (k,b)) -> CCast (loc,f e a,CastConv(k, f e b)) + | CCast (loc,a,CastCoerce) -> CCast (loc,f e a,CastCoerce) | CNotation (loc,n,l) -> CNotation (loc,n,List.map (f e) l) | CDelimiters (loc,s,a) -> CDelimiters (loc,s,f e a) | CHole _ | CEvar _ | CPatVar _ | CSort _ diff --git a/interp/topconstr.mli b/interp/topconstr.mli index 131e4170..3c359bd5 100644 --- a/interp/topconstr.mli +++ b/interp/topconstr.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: topconstr.mli 9226 2006-10-09 16:11:01Z herbelin $ i*) +(*i $Id: topconstr.mli 9976 2007-07-12 11:58:30Z msozeau $ i*) (*i*) open Pp @@ -41,7 +41,7 @@ type aconstr = | ASort of rawsort | AHole of Evd.hole_kind | APatVar of patvar - | ACast of aconstr * cast_type * aconstr + | ACast of aconstr * aconstr cast_type (**********************************************************************) (* Translate a rawconstr into a notation given the list of variables *) @@ -127,7 +127,7 @@ type constr_expr = | CPatVar of loc * (bool * patvar) | CEvar of loc * existential_key | CSort of loc * rawsort - | CCast of loc * constr_expr * cast_type * constr_expr + | CCast of loc * constr_expr * constr_expr cast_type | CNotation of loc * notation * constr_expr list | CPrim of loc * prim_token | CDelimiters of loc * string * constr_expr @@ -167,7 +167,7 @@ val ids_of_cases_indtype : constr_expr -> identifier list val mkIdentC : identifier -> constr_expr val mkRefC : reference -> constr_expr val mkAppC : constr_expr * constr_expr list -> constr_expr -val mkCastC : constr_expr * cast_type * constr_expr -> constr_expr +val mkCastC : constr_expr * constr_expr cast_type -> constr_expr val mkLambdaC : name located list * constr_expr * constr_expr -> constr_expr val mkLetInC : name located * constr_expr * constr_expr -> constr_expr val mkProdC : name located list * constr_expr * constr_expr -> constr_expr diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml index 71a9aa0e..4e09a0ed 100644 --- a/kernel/cemitcodes.ml +++ b/kernel/cemitcodes.ml @@ -23,7 +23,7 @@ let patch_int buff pos n = let out_buffer = ref(String.create 1024) and out_position = ref 0 - +(* let out_word b1 b2 b3 b4 = let p = !out_position in if p >= String.length !out_buffer then begin @@ -37,6 +37,28 @@ let out_word b1 b2 b3 b4 = String.unsafe_set !out_buffer (p+2) (Char.unsafe_chr b3); String.unsafe_set !out_buffer (p+3) (Char.unsafe_chr b4); out_position := p + 4 +*) +let out_word b1 b2 b3 b4 = + let p = !out_position in + if p >= String.length !out_buffer then begin + let len = String.length !out_buffer in + let new_len = + if len <= Sys.max_string_length / 2 + then 2 * len + else + if len = Sys.max_string_length + then raise (Invalid_argument "String.create") (* Pas la bonne execption +.... *) + else Sys.max_string_length in + let new_buffer = String.create new_len in + String.blit !out_buffer 0 new_buffer 0 len; + out_buffer := new_buffer + end; + String.unsafe_set !out_buffer p (Char.unsafe_chr b1); + String.unsafe_set !out_buffer (p+1) (Char.unsafe_chr b2); + String.unsafe_set !out_buffer (p+2) (Char.unsafe_chr b3); + String.unsafe_set !out_buffer (p+3) (Char.unsafe_chr b4); + out_position := p + 4 let out opcode = out_word opcode 0 0 0 diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml index 6d2064bf..2942e101 100644 --- a/kernel/mod_subst.ml +++ b/kernel/mod_subst.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: mod_subst.ml 7538 2005-11-08 17:14:52Z herbelin $ *) +(* $Id: mod_subst.ml 9874 2007-06-04 13:46:11Z soubiran $ *) open Pp open Util @@ -25,7 +25,7 @@ let apply_opt_resolver resolve kn = match resolve with None -> None | Some resolve -> - try List.assoc kn resolve with Not_found -> assert false + try List.assoc kn resolve with Not_found -> None type substitution_domain = MSI of mod_self_id | MBI of mod_bound_id @@ -110,6 +110,16 @@ let subst_con sub con = None -> con',mkConst con' | Some t -> con',t +let subst_con0 sub con = + let mp,dir,l = repr_con con in + match subst_mp0 sub mp with + None -> None + | Some (mp',resolve) -> + let con' = make_con mp' dir l in + match apply_opt_resolver resolve con with + None -> Some (mkConst con') + | Some t -> Some t + (* Here the semantics is completely unclear. What does "Hint Unfold t" means when "t" is a parameter? Does the user mean "Unfold X.t" or does she mean "Unfold y" @@ -119,16 +129,14 @@ let subst_evaluable_reference subst = function | EvalVarRef id -> EvalVarRef id | EvalConstRef kn -> EvalConstRef (fst (subst_con subst kn)) -(* -This should be rewritten to prevent duplication of constr's when not -necessary. -For now, it uses map_constr and is rather ineffective -*) let rec map_kn f f' c = let func = map_kn f f' in match kind_of_term c with - | Const kn -> f' kn + | Const kn -> + (match f' kn with + None -> c + | Some const ->const) | Ind (kn,i) -> (match f kn with None -> c @@ -138,18 +146,64 @@ let rec map_kn f f' c = (match f kn with None -> c | Some kn' -> - mkConstruct ((kn',i),j)) - | Case (ci,p,c,l) -> - let ci' = - { ci with - ci_ind = - let (kn,i) = ci.ci_ind in - match f kn with None -> ci.ci_ind | Some kn' -> kn',i } in - mkCase (ci', func p, func c, array_smartmap func l) - | _ -> map_constr func c + mkConstruct ((kn',i),j)) + | Case (ci,p,ct,l) -> + let ci_ind = + let (kn,i) = ci.ci_ind in + (match f kn with None -> ci.ci_ind | Some kn' -> kn',i ) in + let p' = func p in + let ct' = func ct in + let l' = array_smartmap func l in + if (ci.ci_ind==ci_ind && p'==p + && l'==l && ct'==ct)then c + else + mkCase ({ci with ci_ind = ci_ind}, + p',ct', l') + | Cast (ct,k,t) -> + let ct' = func ct in + let t'= func t in + if (t'==t && ct'==ct) then c + else mkCast (ct', k, t') + | Prod (na,t,ct) -> + let ct' = func ct in + let t'= func t in + if (t'==t && ct'==ct) then c + else mkProd (na, t', ct') + | Lambda (na,t,ct) -> + let ct' = func ct in + let t'= func t in + if (t'==t && ct'==ct) then c + else mkLambda (na, t', ct') + | LetIn (na,b,t,ct) -> + let ct' = func ct in + let t'= func t in + let b'= func b in + if (t'==t && ct'==ct && b==b') then c + else mkLetIn (na, b', t', ct') + | App (ct,l) -> + let ct' = func ct in + let l' = array_smartmap func l in + if (ct'== ct && l'==l) then c + else mkApp (ct',l') + | Evar (e,l) -> + let l' = array_smartmap func l in + if (l'==l) then c + else mkEvar (e,l') + | Fix (ln,(lna,tl,bl)) -> + let tl' = array_smartmap func tl in + let bl' = array_smartmap func bl in + if (bl == bl'&& tl == tl') then c + else mkFix (ln,(lna,tl',bl')) + | CoFix(ln,(lna,tl,bl)) -> + let tl' = array_smartmap func tl in + let bl' = array_smartmap func bl in + if (bl == bl'&& tl == tl') then c + else mkCoFix (ln,(lna,tl',bl')) + | _ -> c + let subst_mps sub = - map_kn (subst_kn0 sub) (fun con -> snd (subst_con sub con)) + map_kn (subst_kn0 sub) (subst_con0 sub) let rec replace_mp_in_mp mpfrom mpto mp = match mp with @@ -172,50 +226,57 @@ exception ChangeDomain of resolver let join (subst1 : substitution) (subst2 : substitution) = let apply_subst (sub : substitution) key (mp,resolve) = let mp',resolve' = - match subst_mp0 sub mp with - None -> mp, None - | Some (mp',resolve') -> mp',resolve' in + match subst_mp0 sub mp with + None -> mp, None + | Some (mp',resolve') -> mp',resolve' in let resolve'' : resolver option = - try - let res = - match resolve with - Some res -> res - | None -> - match resolve' with - None -> raise BothSubstitutionsAreIdentitySubstitutions - | Some res -> raise (ChangeDomain res) - in - Some - (List.map - (fun (kn,topt) -> - kn, - match topt with - None -> - (match key with - MSI msid -> - let kn' = replace_mp_in_con (MPself msid) mp kn in - apply_opt_resolver resolve' kn' - | MBI mbid -> - let kn' = replace_mp_in_con (MPbound mbid) mp kn in - apply_opt_resolver resolve' kn') - | Some t -> Some (subst_mps sub t)) res) - with - BothSubstitutionsAreIdentitySubstitutions -> None - | ChangeDomain res -> - Some - ((List.map - (fun (kn,topt) -> - let key' = - match key with - MSI msid -> MPself msid - | MBI mbid -> MPbound mbid in - (* let's replace mp with key in kn *) - let kn' = replace_mp_in_con mp key' kn in - kn',topt)) res) + try + let res = + match resolve with + Some res -> res + | None -> + match resolve' with + None -> raise BothSubstitutionsAreIdentitySubstitutions + | Some res -> raise (ChangeDomain res) + in + Some + (List.map + (fun (kn,topt) -> + kn, + match topt with + None -> + (match key with + MSI msid -> + let kn' = replace_mp_in_con (MPself msid) mp kn in + apply_opt_resolver resolve' kn' + | MBI mbid -> + let kn' = replace_mp_in_con (MPbound mbid) mp kn in + apply_opt_resolver resolve' kn') + | Some t -> Some (subst_mps sub t)) res) + with + BothSubstitutionsAreIdentitySubstitutions -> None + | ChangeDomain res -> + let rec changeDom = function + | [] -> [] + | (kn,topt)::r -> + let key' = + match key with + MSI msid -> MPself msid + | MBI mbid -> MPbound mbid in + let kn' = replace_mp_in_con mp key' kn in + if kn==kn' then + (*the key does not appear in mp, we remove it + from the resolver that we are building*) + changeDom r + else + (kn',topt)::(changeDom r) + in + Some (changeDom res) in - mp',resolve'' in + mp',resolve'' in let subst = Umap.mapi (apply_subst subst2) subst1 in - Umap.fold Umap.add subst2 subst + Umap.fold Umap.add subst2 subst + let rec occur_in_path uid path = match uid,path with diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index 352a1e46..70de3034 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: mod_typing.ml 9558 2007-01-30 14:58:42Z soubiran $ i*) +(*i $Id: mod_typing.ml 9980 2007-07-12 13:32:37Z soubiran $ i*) open Util open Names @@ -131,8 +131,12 @@ and merge_with env mtb with_decl = let equiv = match old.msb_equiv with | None -> Some mp - | Some mp' -> - check_modpath_equiv env' mp mp'; + | Some mp' -> + begin + try + check_modpath_equiv env' mp mp' + with Not_equiv_path -> error_not_equal mp mp + end; Some mp in let msb = diff --git a/kernel/modops.ml b/kernel/modops.ml index 8bab3c9d..fb00cfcd 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: modops.ml 9558 2007-01-30 14:58:42Z soubiran $ i*) +(*i $Id: modops.ml 9980 2007-07-12 13:32:37Z soubiran $ i*) (*i*) open Util @@ -33,10 +33,11 @@ let error_not_a_functor _ = error "Application of not a functor" let error_incompatible_modtypes _ _ = error "Incompatible module types" -let error_not_equal _ _ = error "Not equal modules" - -let error_not_match l _ = error ("Signature components for label "^string_of_label l^" do not match") +let error_not_equal p1 p2 = error ((string_of_mp p1)^" and "^(string_of_mp p2)^" are not equal modules") +let error_not_match l l1 l2 = error (l1^" is not a subtype of "^l2^": "^ + "Signature components for label "^(string_of_label l)^" do not match.") + let error_no_such_label l = error ("No such label "^string_of_label l) let error_incompatible_labels l l' = @@ -89,7 +90,7 @@ let error_circularity_in_subtyping l l1 l2 = error ("An occurrence of "^l^" creates a circularity\n during the subtyping verification between "^l1^" and "^l2^".") let error_no_such_label_sub l l1 l2 = - error (l1^" is not a subtype of "^l2^".\nThe field "^(string_of_label l)^" is missing (or invisible) in "^l1^".") + error (l1^" is not a subtype of "^l2^":"^"The field "^(string_of_label l)^" is missing in "^l1^".") let rec scrape_modtype env = function @@ -124,6 +125,7 @@ let destr_functor = function | MTBfunsig (arg_id,arg_t,body_t) -> (arg_id,arg_t,body_t) | mtb -> error_not_a_functor mtb +exception Not_equiv_path let rec check_modpath_equiv env mp1 mp2 = if mp1=mp2 then () else @@ -132,7 +134,7 @@ let rec check_modpath_equiv env mp1 mp2 = | None -> let mb2 = lookup_module mp2 env in (match mb2.mod_equiv with - | None -> error_not_equal mp1 mp2 + | None -> raise Not_equiv_path | Some mp2' -> check_modpath_equiv env mp2' mp1) | Some mp1' -> check_modpath_equiv env mp2 mp1' @@ -244,16 +246,16 @@ and constants_of_modtype env mp modtype = | MTBfunsig _ -> [] (* returns a resolver for kn that maps mbid to mp *) -(* Nota: Some delta-expansions used to happen here. - Browse SVN if you want to know more. *) +(* Desactivated until v8.2, waiting for the integration +of "Parameter Inline". *) let resolver_of_environment mbid modtype mp env = let constants = constants_of_modtype env (MPbound mbid) modtype in - let resolve = List.map (fun (con,_) -> con,None) constants in - Mod_subst.make_resolver resolve + let _ = List.map (fun (con,_) -> con,None) constants in + Mod_subst.make_resolver [] let strengthen_const env mp l cb = - match cb.const_opaque, cb.const_body with + match cb.const_opaque, cb.const_body with | false, Some _ -> cb | true, Some _ | _, None -> diff --git a/kernel/modops.mli b/kernel/modops.mli index 55f81079..61761bb7 100644 --- a/kernel/modops.mli +++ b/kernel/modops.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: modops.mli 9558 2007-01-30 14:58:42Z soubiran $ i*) +(*i $Id: modops.mli 9980 2007-07-12 13:32:37Z soubiran $ i*) (*i*) open Util @@ -21,6 +21,7 @@ open Mod_subst (* Various operations on modules and module types *) exception Circularity of string +exception Not_equiv_path (* recursively unfold MTBdent module types *) val scrape_modtype : env -> module_type_body -> module_type_body @@ -70,7 +71,7 @@ val error_incompatible_modtypes : val error_not_equal : module_path -> module_path -> 'a -val error_not_match : label -> specification_body -> 'a +val error_not_match : label -> string -> string -> 'a val error_incompatible_labels : label -> label -> 'a diff --git a/kernel/names.ml b/kernel/names.ml index 383d7879..4273fe14 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: names.ml 9558 2007-01-30 14:58:42Z soubiran $ *) +(* $Id: names.ml 9980 2007-07-12 13:32:37Z soubiran $ *) open Pp open Util @@ -65,7 +65,7 @@ let repr_dirpath x = x let empty_dirpath = [] let string_of_dirpath = function - | [] -> "<empty>" + | [] -> "" | sl -> String.concat "." (List.map string_of_id (List.rev sl)) diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index d1a10651..2e6e5a34 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: subtyping.ml 9558 2007-01-30 14:58:42Z soubiran $ i*) +(*i $Id: subtyping.ml 10031 2007-07-19 18:05:46Z soubiran $ i*) (*i*) open Util @@ -72,9 +72,11 @@ let check_conv_error error cst f env a1 a2 = NotConvertible -> error () (* for now we do not allow reorderings *) -let check_inductive cst env msid1 l info1 mib2 spec2 = +let check_inductive cst env msid1 l info1 mib2 spec2 path1 path2 = let kn = make_kn (MPself msid1) empty_dirpath l in - let error () = error_not_match l spec2 in + let error () = error_not_match l + (String.concat "." (List.map string_of_id (List.rev path1))) + (String.concat "." (List.map string_of_id (List.rev path2))) in let check_conv cst f = check_conv_error error cst f in let mib1 = match info1 with @@ -192,8 +194,10 @@ let check_inductive cst env msid1 l info1 mib2 spec2 = in cst -let check_constant cst env msid1 l info1 cb2 spec2 = - let error () = error_not_match l spec2 in +let check_constant cst env msid1 l info1 cb2 spec2 msid2 path1 path2 = + let error () = error_not_match l + (String.concat "." (List.map string_of_id (List.rev path1))) + (String.concat "." (List.map string_of_id (List.rev path2))) in let check_conv cst f = check_conv_error error cst f in let check_type cst env t1 t2 = @@ -251,17 +255,53 @@ let check_constant cst env msid1 l info1 cb2 spec2 = let cst = check_type cst env typ1 typ2 in let con = make_con (MPself msid1) empty_dirpath l in let cst = - match cb2.const_body with - | None -> cst - | Some lc2 -> - let c2 = Declarations.force lc2 in - let c1 = match cb1.const_body with - | Some lc1 -> Declarations.force lc1 - | None -> mkConst con - in - check_conv cst conv env c1 c2 + match cb2.const_body with + | None -> cst + | Some lc2 -> + let c2 = Declarations.force lc2 in + let c1 = match cb1.const_body with + | Some lc1 -> Declarations.force lc1 + | None -> mkConst con + in + begin + match cb1.const_opaque,cb2.const_opaque with + false,false |true,true -> + check_conv cst conv env c1 c2 + | false,true -> + begin + match kind_of_term c1 with + | Const con' -> + let c1 = + match (Pre_env.lookup_constant con' + (pre_env env)).const_body with + Some c -> Declarations.force c + | None -> mkConst con' + in + check_conv cst conv env c1 c2 + | _ -> + check_conv cst conv env c1 c2 + end + | true,false-> + begin + match (kind_of_term c2) with + | Const con'-> + if con' = con + then cst + else + let c2 = + match (Pre_env.lookup_constant con' + (pre_env env)).const_body with + Some c -> Declarations.force c + | None -> mkConst con' + in + check_conv cst conv env c1 c2 + | _ -> + check_conv cst conv env c1 c2 + end + end + in - cst + cst | IndType ((kn,i),mind1) -> ignore (Util.error ( "The kernel does not recognize yet that a parameter can be " ^ @@ -286,60 +326,77 @@ let check_constant cst env msid1 l info1 cb2 spec2 = check_conv cst conv env ty1 ty2 | _ -> error () -let rec check_modules cst env msid1 l msb1 msb2 = +let rec check_modules cst env msid1 l msb1 msb2 path1 path2 = let mp = (MPdot(MPself msid1,l)) in let mty1 = strengthen env msb1.msb_modtype mp in - let cst = check_modtypes cst env mty1 msb2.msb_modtype false in - begin - match msb1.msb_equiv, msb2.msb_equiv with - | _, None -> () - | None, Some mp2 -> - check_modpath_equiv env mp mp2 - | Some mp1, Some mp2 -> - check_modpath_equiv env mp1 mp2 - end; - cst + let cst = check_modtypes cst env mty1 msb2.msb_modtype false + path1 path2 in + begin + match msb1.msb_equiv, msb2.msb_equiv with + | _, None -> () + | None, Some mp2 -> + begin + try + check_modpath_equiv env mp mp2 + with Not_equiv_path -> error_not_equal mp mp2 + end + | Some mp1, Some mp2 -> try + check_modpath_equiv env mp1 mp2 + with Not_equiv_path -> error_not_equal mp1 mp2 + end; + cst -and check_signatures cst env (msid1,sig1) (msid2,sig2') = +and check_signatures cst env (msid1,sig1) (msid2,sig2') path1 path2= let mp1 = MPself msid1 in let env = add_signature mp1 sig1 env in let sig2 = try subst_signature_msid msid2 mp1 sig2' with | Circularity l -> - error_circularity_in_subtyping l (string_of_msid msid1) (string_of_msid msid2) in + error_circularity_in_subtyping l + (String.concat "." (List.map string_of_id (List.rev path1))) + (String.concat "." (List.map string_of_id (List.rev path2))) + in let map1 = make_label_map mp1 sig1 in let check_one_body cst (l,spec2) = let info1 = try Labmap.find l map1 with - Not_found -> error_no_such_label_sub l (string_of_msid msid1) (string_of_msid msid2) + Not_found -> error_no_such_label_sub l + (String.concat "." (List.map string_of_id (List.rev path1))) + (String.concat "." (List.map string_of_id (List.rev path2))) in match spec2 with | SPBconst cb2 -> - check_constant cst env msid1 l info1 cb2 spec2 + check_constant cst env msid1 l info1 cb2 spec2 msid2 path1 path2 | SPBmind mib2 -> - check_inductive cst env msid1 l info1 mib2 spec2 + check_inductive cst env msid1 l info1 mib2 spec2 path1 path2 | SPBmodule msb2 -> let msb1 = match info1 with | Module msb -> msb - | _ -> error_not_match l spec2 + | _ -> error_not_match l + (String.concat "." (List.map string_of_id (List.rev path1))) + (String.concat "." (List.map string_of_id (List.rev path2))) + in - check_modules cst env msid1 l msb1 msb2 + check_modules cst env msid1 l msb1 msb2 path1 path2 | SPBmodtype mtb2 -> let mtb1 = match info1 with | Modtype mtb -> mtb - | _ -> error_not_match l spec2 + | _ -> error_not_match l + (String.concat "." (List.map string_of_id (List.rev path1))) + (String.concat "." (List.map string_of_id (List.rev path2))) + in - check_modtypes cst env mtb1 mtb2 true + check_modtypes cst env mtb1 mtb2 true path1 path2 in List.fold_left check_one_body cst sig2 -and check_modtypes cst env mtb1 mtb2 equiv = +and check_modtypes cst env mtb1 mtb2 equiv path1 path2 = if mtb1==mtb2 then cst else (* just in case :) *) let mtb1' = scrape_modtype env mtb1 in let mtb2' = scrape_modtype env mtb2 in @@ -347,14 +404,17 @@ and check_modtypes cst env mtb1 mtb2 equiv = match mtb1', mtb2' with | MTBsig (msid1,list1), MTBsig (msid2,list2) -> - let cst = check_signatures cst env (msid1,list1) (msid2,list2) in + let cst = check_signatures cst env (msid1,list1) (msid2,list2) + ((id_of_msid msid1)::path1) ((id_of_msid msid2)::path2) in if equiv then check_signatures cst env (msid2,list2) (msid1,list1) + ((id_of_msid msid2)::path2) ((id_of_msid msid1)::path1) else cst | MTBfunsig (arg_id1,arg_t1,body_t1), MTBfunsig (arg_id2,arg_t2,body_t2) -> - let cst = check_modtypes cst env arg_t2 arg_t1 equiv in + let cst = check_modtypes cst env arg_t2 arg_t1 equiv + [] [] in (* contravariant *) let env = add_module (MPbound arg_id2) (module_body_of_type arg_t2) env @@ -367,9 +427,10 @@ and check_modtypes cst env mtb1 mtb2 equiv = body_t1 in check_modtypes cst env body_t1' body_t2 equiv + path1 path2 | MTBident _ , _ -> anomaly "Subtyping: scrape failed" | _ , MTBident _ -> anomaly "Subtyping: scrape failed" | _ , _ -> error_incompatible_modtypes mtb1 mtb2 let check_subtypes env sup super = - check_modtypes Constraint.empty env sup super false + check_modtypes Constraint.empty env sup super false [] [] diff --git a/lib/util.ml b/lib/util.ml index 89cfd6fc..bf70acc7 100644 --- a/lib/util.ml +++ b/lib/util.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: util.ml 9225 2006-10-09 15:59:23Z herbelin $ *) +(* $Id: util.ml 9766 2007-04-13 13:26:28Z herbelin $ *) open Pp @@ -267,6 +267,12 @@ let rec list_remove_first a = function | b::l -> b::list_remove_first a l | [] -> raise Not_found +let list_eq_set l1 l2 = + let rec aux l1 = function + | [] -> l1 = [] + | a::l2 -> aux (list_remove_first a l1) l2 in + try aux l1 l2 with Not_found -> false + let list_for_all2eq f l1 l2 = try List.for_all2 f l1 l2 with Failure _ -> false let list_map_i f = diff --git a/lib/util.mli b/lib/util.mli index b2d8f135..cc44a677 100644 --- a/lib/util.mli +++ b/lib/util.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(*i $Id: util.mli 9225 2006-10-09 15:59:23Z herbelin $ i*) +(*i $Id: util.mli 9766 2007-04-13 13:26:28Z herbelin $ i*) (*i*) open Pp @@ -78,6 +78,7 @@ module Stringmap : Map.S with type key = string (*s Lists. *) val list_add_set : 'a -> 'a list -> 'a list +val list_eq_set : 'a list -> 'a list -> bool val list_intersect : 'a list -> 'a list -> 'a list val list_union : 'a list -> 'a list -> 'a list val list_unionq : 'a list -> 'a list -> 'a list diff --git a/library/dischargedhypsmap.ml b/library/dischargedhypsmap.ml index 255f5e75..f515dcb0 100644 --- a/library/dischargedhypsmap.ml +++ b/library/dischargedhypsmap.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: dischargedhypsmap.ml 9488 2007-01-17 11:11:58Z herbelin $ *) +(* $Id: dischargedhypsmap.ml 9903 2007-06-21 17:02:07Z herbelin $ *) open Util open Libnames @@ -31,7 +31,7 @@ let get_discharged_hyps sp = try Spmap.find sp !discharged_hyps_map with Not_found -> - anomaly ("No discharged hypothesis for object " ^ string_of_path sp) + [] (*s Registration as global tables and rollback. *) diff --git a/library/library.ml b/library/library.ml index b68c3eb5..3a3328ad 100644 --- a/library/library.ml +++ b/library/library.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: library.ml 9637 2007-02-10 08:32:28Z notin $ *) +(* $Id: library.ml 9525 2007-01-24 08:43:01Z herbelin $ *) open Pp open Util @@ -300,7 +300,7 @@ let (in_import, out_import) = (*s Loading from disk to cache (preparation phase) *) -let vo_magic_number = 080100 (* V8.1 *) +let vo_magic_number = 080992 (* V8.1 beta2 *) let (raw_extern_library, raw_intern_library) = System.raw_extern_intern vo_magic_number ".vo" diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index 9163f3c1..1cde66e2 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: g_constr.ml4 9562 2007-01-31 09:00:36Z msozeau $ *) +(* $Id: g_constr.ml4 9976 2007-07-12 11:58:30Z msozeau $ *) open Pcoq open Constr @@ -21,14 +21,14 @@ open Util let constr_kw = [ "forall"; "fun"; "match"; "fix"; "cofix"; "with"; "in"; "for"; - "end"; "as"; "let"; "if"; "then"; "else"; "return"; + "end"; "as"; "let"; "dest"; "if"; "then"; "else"; "return"; "Prop"; "Set"; "Type"; ".("; "_"; ".." ] let _ = List.iter (fun s -> Lexer.add_token("",s)) constr_kw let mk_cast = function (c,(_,None)) -> c - | (c,(_,Some ty)) -> CCast(join_loc (constr_loc c) (constr_loc ty), c, CastConv DEFAULTcast, ty) + | (c,(_,Some ty)) -> CCast(join_loc (constr_loc c) (constr_loc ty), c, CastConv (DEFAULTcast, ty)) let mk_lam = function ([],c) -> c @@ -156,13 +156,15 @@ GEXTEND Gram [ c = binder_constr -> c ] | "100" RIGHTA [ c1 = operconstr; "<:"; c2 = binder_constr -> - CCast(loc,c1, CastConv VMcast,c2) + CCast(loc,c1, CastConv (VMcast,c2)) | c1 = operconstr; "<:"; c2 = SELF -> - CCast(loc,c1, CastConv VMcast,c2) + CCast(loc,c1, CastConv (VMcast,c2)) | c1 = operconstr; ":";c2 = binder_constr -> - CCast(loc,c1, CastConv DEFAULTcast,c2) + CCast(loc,c1, CastConv (DEFAULTcast,c2)) | c1 = operconstr; ":"; c2 = SELF -> - CCast(loc,c1, CastConv DEFAULTcast,c2) ] + CCast(loc,c1, CastConv (DEFAULTcast,c2)) + | c1 = operconstr; ":>" -> + CCast(loc,c1, CastCoerce) ] | "99" RIGHTA [ ] | "90" RIGHTA [ c1 = operconstr; "->"; c2 = binder_constr -> CArrow(loc,c1,c2) @@ -210,6 +212,10 @@ GEXTEND Gram ":="; c1 = operconstr LEVEL "200"; "in"; c2 = operconstr LEVEL "200" -> CLetTuple (loc,List.map snd lb,po,c1,c2) + | "dest"; c1 = operconstr LEVEL "200"; "as"; p=pattern; + "in"; c2 = operconstr LEVEL "200" -> + CCases (loc, None, [(c1, (None, None))], + [loc, [[p]], c2]) | "if"; c=operconstr LEVEL "200"; po = return_type; "then"; b1=operconstr LEVEL "200"; "else"; b2=operconstr LEVEL "200" -> @@ -328,7 +334,7 @@ GEXTEND Gram | "("; id=name; ":="; c=lconstr; ")" -> LocalRawDef (id,c) | "("; id=name; ":"; t=lconstr; ":="; c=lconstr; ")" -> - LocalRawDef (id,CCast (join_loc (constr_loc t) loc,c, CastConv DEFAULTcast,t)) + LocalRawDef (id,CCast (join_loc (constr_loc t) loc,c, CastConv (DEFAULTcast,t))) ] ] ; binder: diff --git a/parsing/g_proofs.ml4 b/parsing/g_proofs.ml4 index 2f515a81..0a48748f 100644 --- a/parsing/g_proofs.ml4 +++ b/parsing/g_proofs.ml4 @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: g_proofs.ml4 9154 2006-09-20 17:18:18Z corbinea $ *) +(* $Id: g_proofs.ml4 9976 2007-07-12 11:58:30Z msozeau $ *) open Pcoq open Pp @@ -118,6 +118,6 @@ GEXTEND Gram ; constr_body: [ [ ":="; c = lconstr -> c - | ":"; t = lconstr; ":="; c = lconstr -> CCast(loc,c, Rawterm.CastConv Term.DEFAULTcast,t) ] ] + | ":"; t = lconstr; ":="; c = lconstr -> CCast(loc,c, Rawterm.CastConv (Term.DEFAULTcast,t)) ] ] ; END diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 9a98df80..6a9388b2 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: g_vernac.ml4 9562 2007-01-31 09:00:36Z msozeau $ *) +(* $Id: g_vernac.ml4 9977 2007-07-12 12:18:46Z msozeau $ *) (*i camlp4deps: "parsing/grammar.cma" i*) open Pp @@ -202,7 +202,7 @@ GEXTEND Gram def_body: [ [ bl = LIST0 binder_let; ":="; red = reduce; c = lconstr -> (match c with - CCast(_,c,k,t) -> DefineBody (bl, red, c, Some t) + CCast(_,c, Rawterm.CastConv (k,t)) -> DefineBody (bl, red, c, Some t) | _ -> DefineBody (bl, red, c, None)) | bl = LIST0 binder_let; ":"; t = lconstr; ":="; red = reduce; c = lconstr -> DefineBody (bl, red, c, Some t) @@ -264,8 +264,8 @@ GEXTEND Gram ; rec_annotation: [ [ "{"; IDENT "struct"; id=IDENT; "}" -> (Some (id_of_string id), CStructRec) - | "{"; IDENT "wf"; rel=constr; id=IDENT; "}" -> (Some (id_of_string id), CWfRec rel) - | "{"; IDENT "measure"; rel=constr; id=IDENT; "}" -> (Some (id_of_string id), CMeasureRec rel) + | "{"; IDENT "wf"; rel=constr; id=OPT IDENT; "}" -> (option_map id_of_string id, CWfRec rel) + | "{"; IDENT "measure"; rel=constr; id=OPT IDENT; "}" -> (option_map id_of_string id, CMeasureRec rel) | -> (None, CStructRec) ] ] ; @@ -304,7 +304,7 @@ GEXTEND Gram t = lconstr; ":="; b = lconstr -> (oc,DefExpr (id,b,Some t)) | id = name; ":="; b = lconstr -> match b with - CCast(_,b,_,t) -> (false,DefExpr(id,b,Some t)) + CCast(_,b, Rawterm.CastConv (_, t)) -> (false,DefExpr(id,b,Some t)) | _ -> (false,DefExpr(id,b,None)) ] ] ; assum_list: diff --git a/parsing/g_xml.ml4 b/parsing/g_xml.ml4 index c13532cc..2f31c0b6 100644 --- a/parsing/g_xml.ml4 +++ b/parsing/g_xml.ml4 @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: g_xml.ml4 9200 2006-10-03 14:11:08Z herbelin $ *) +(* $Id: g_xml.ml4 9976 2007-07-12 11:58:30Z msozeau $ *) open Pp open Util @@ -183,7 +183,7 @@ let rec interp_xml_constr = function let ln,lc,lt = list_split3 (List.map interp_xml_CoFixFunction xl) in RRec (loc, RCoFix (get_xml_noFun al), Array.of_list ln, [||], Array.of_list lc, Array.of_list lt) | XmlTag (loc,"CAST",al,[x1;x2]) -> - RCast (loc, interp_xml_term x1, CastConv DEFAULTcast, interp_xml_type x2) + RCast (loc, interp_xml_term x1, CastConv (DEFAULTcast, interp_xml_type x2)) | XmlTag (loc,"SORT",al,[]) -> RSort (loc, get_xml_sort al) | XmlTag (loc,s,_,_) -> user_err_loc (loc,"", str "Unexpected tag " ++ str s) diff --git a/parsing/ppconstr.ml b/parsing/ppconstr.ml index 349d5df8..275e179e 100644 --- a/parsing/ppconstr.ml +++ b/parsing/ppconstr.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ppconstr.ml 9304 2006-10-28 09:58:16Z herbelin $ *) +(* $Id: ppconstr.ml 9976 2007-07-12 11:58:30Z msozeau $ *) (*i*) open Util @@ -215,7 +215,7 @@ let pr_binder_among_many pr_c = function pr_binder true pr_c (nal,t) | LocalRawDef (na,c) -> let c,topt = match c with - | CCast(_,c,_,t) -> c, t + | CCast(_,c, CastConv (_,t)) -> c, t | _ -> c, CHole dummy_loc in hov 1 (surround (pr_lname na ++ pr_opt_type pr_c topt ++ @@ -566,10 +566,13 @@ let rec pr sep inherited a = | CEvar (_,n) -> str (Evd.string_of_existential n), latom | CPatVar (_,(_,p)) -> str "?" ++ pr_patvar p, latom | CSort (_,s) -> pr_rawsort s, latom - | CCast (_,a,k,b) -> - let s = match k with CastConv VMcast -> "<:" | _ -> ":" in + | CCast (_,a,CastConv (k,b)) -> + let s = match k with VMcast -> "<:" | DEFAULTcast -> ":" in hv 0 (pr mt (lcast,L) a ++ cut () ++ str s ++ pr mt (-lcast,E) b), lcast + | CCast (_,a,CastCoerce) -> + hv 0 (pr mt (lcast,L) a ++ cut () ++ str ":>"), + lcast | CNotation (_,"( _ )",[t]) -> pr (fun()->str"(") (max_int,L) t ++ str")", latom | CNotation (_,s,env) -> pr_notation (pr mt) s env @@ -590,7 +593,7 @@ let pr = pr mt let rec strip_context n iscast t = if n = 0 then - [], if iscast then match t with CCast (_,c,_,_) -> c | _ -> t else t + [], if iscast then match t with CCast (_,c,_) -> c | _ -> t else t else match t with | CLambdaN (loc,(nal,t)::bll,c) -> let n' = List.length nal in @@ -613,7 +616,7 @@ let rec strip_context n iscast t = | CArrow (loc,t,c) -> let bl', c = strip_context (n-1) iscast c in LocalRawAssum ([loc,Anonymous],t) :: bl', c - | CCast (_,c,_,_) -> strip_context n false c + | CCast (_,c,_) -> strip_context n false c | CLetIn (_,na,b,c) -> let bl', c = strip_context (n-1) iscast c in LocalRawDef (na,b) :: bl', c diff --git a/parsing/q_constr.ml4 b/parsing/q_constr.ml4 index 768bc45c..21c851df 100644 --- a/parsing/q_constr.ml4 +++ b/parsing/q_constr.ml4 @@ -73,7 +73,7 @@ EXTEND | "0" [ s = sort -> <:expr< Rawterm.RSort ($dloc$,s) >> | id = ident -> <:expr< Rawterm.RVar ($dloc$,$id$) >> - | "_" -> <:expr< Rawterm.RHole ($dloc$,QuestionMark) >> + | "_" -> <:expr< Rawterm.RHole ($dloc$, QuestionMark False) >> | "?"; id = ident -> <:expr< Rawterm.RPatVar($dloc$,(False,$id$)) >> | "{"; c1 = constr; "}"; "+"; "{"; c2 = constr; "}" -> apply_ref <:expr< coq_sumbool_ref >> [c1;c2] diff --git a/pretyping/cases.mli b/pretyping/cases.mli index 9e902126..30f68083 100644 --- a/pretyping/cases.mli +++ b/pretyping/cases.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: cases.mli 8741 2006-04-26 22:30:32Z herbelin $ i*) +(*i $Id: cases.mli 9976 2007-07-12 11:58:30Z msozeau $ i*) (*i*) open Util @@ -32,10 +32,20 @@ type pattern_matching_error = exception PatternMatchingError of env * pattern_matching_error +val raise_pattern_matching_error : (loc * env * pattern_matching_error) -> 'a + val error_wrong_numarg_constructor_loc : loc -> env -> constructor -> int -> 'a val error_wrong_numarg_inductive_loc : loc -> env -> inductive -> int -> 'a +val error_bad_constructor_loc : loc -> constructor -> inductive -> 'a + +val error_bad_pattern_loc : loc -> constructor -> constr -> 'a + +val error_wrong_predicate_arity_loc : loc -> env -> constr -> constr -> constr -> 'a + +val error_needs_inversion : env -> constr -> types -> 'a + (*s Compilation of pattern-matching. *) module type S = sig diff --git a/pretyping/clenv.ml b/pretyping/clenv.ml index abe31e06..29dbe83d 100644 --- a/pretyping/clenv.ml +++ b/pretyping/clenv.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: clenv.ml 9279 2006-10-25 15:51:24Z herbelin $ *) +(* $Id: clenv.ml 9665 2007-02-21 17:08:10Z herbelin $ *) open Pp open Util @@ -54,7 +54,7 @@ let cl_sigma ce = evars_of ce.env let subst_clenv sub clenv = { templval = map_fl (subst_mps sub) clenv.templval; templtyp = map_fl (subst_mps sub) clenv.templtyp; - env = subst_evar_defs sub clenv.env; + env = subst_evar_defs_light sub clenv.env; templenv = clenv.templenv } let clenv_nf_meta clenv c = nf_meta clenv.env c diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index ff435bfc..4a2e5ee3 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: detyping.ml 9535 2007-01-26 09:26:08Z jforest $ *) +(* $Id: detyping.ml 9976 2007-07-12 11:58:30Z msozeau $ *) open Pp open Util @@ -355,12 +355,15 @@ let detype_sort = function (**********************************************************************) (* Main detyping function *) -let rec detype isgoal avoid env t = +let detype_anonymous = ref (fun loc n -> anomaly "detype: index to an anonymous variable") +let set_detype_anonymous f = detype_anonymous := f + +let rec detype (isgoal:bool) avoid env t = match kind_of_term (collapse_appl t) with | Rel n -> (try match lookup_name_of_rel n env with | Name id -> RVar (dl, id) - | Anonymous -> anomaly "detype: index to an anonymous variable" + | Anonymous -> !detype_anonymous dl n with Not_found -> let s = "_UNBOUND_REL_"^(string_of_int n) in RVar (dl, id_of_string s)) @@ -374,8 +377,7 @@ let rec detype isgoal avoid env t = RVar (dl, id)) | Sort s -> RSort (dl,detype_sort s) | Cast (c1,k,c2) -> - RCast(dl,detype isgoal avoid env c1, CastConv k, - detype isgoal avoid env c2) + RCast(dl,detype isgoal avoid env c1, CastConv (k, detype isgoal avoid env c2)) | Prod (na,ty,c) -> detype_binder isgoal BProd avoid env na ty c | Lambda (na,ty,c) -> detype_binder isgoal BLambda avoid env na ty c | LetIn (na,b,_,c) -> detype_binder isgoal BLetIn avoid env na b c @@ -627,14 +629,18 @@ let rec subst_rawconstr subst raw = let ref',_ = subst_global subst ref in if ref' == ref then raw else RHole (loc,InternalHole) - | RHole (loc, (BinderType _ | QuestionMark | CasesType | + | RHole (loc, (BinderType _ | QuestionMark _ | CasesType | InternalHole | TomatchTypeParameter _)) -> raw - | RCast (loc,r1,k,r2) -> - let r1' = subst_rawconstr subst r1 and r2' = subst_rawconstr subst r2 in - if r1' == r1 && r2' == r2 then raw else - RCast (loc,r1',k,r2') - + | RCast (loc,r1,k) -> + (match k with + CastConv (k,r2) -> + let r1' = subst_rawconstr subst r1 and r2' = subst_rawconstr subst r2 in + if r1' == r1 && r2' == r2 then raw else + RCast (loc,r1', CastConv (k,r2')) + | CastCoerce -> + let r1' = subst_rawconstr subst r1 in + if r1' == r1 then raw else RCast (loc,r1',k)) | RDynamic _ -> raw (* Utilities to transform kernel cases to simple pattern-matching problem *) diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli index bbe2fcc9..7ac7162f 100644 --- a/pretyping/detyping.mli +++ b/pretyping/detyping.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: detyping.mli 8831 2006-05-19 09:29:54Z herbelin $ i*) +(*i $Id: detyping.mli 9976 2007-07-12 11:58:30Z msozeau $ i*) (*i*) open Util @@ -44,7 +44,7 @@ val detype_sort : sorts -> rawsort val lookup_name_as_renamed : env -> constr -> identifier -> int option val lookup_index_as_renamed : env -> constr -> int -> int option - +val set_detype_anonymous : (loc -> int -> rawconstr) -> unit val force_wildcard : unit -> bool val synthetize_type : unit -> bool val force_if : case_info -> bool diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 3c4a23ec..2764633b 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: evarconv.ml 9141 2006-09-15 10:07:01Z herbelin $ *) +(* $Id: evarconv.ml 9665 2007-02-21 17:08:10Z herbelin $ *) open Pp open Util @@ -327,7 +327,7 @@ and evar_eqappr_x env isevars pbty (term1,l1 as appr1) (term2,l2 as appr2) = solve_simple_eqn evar_conv_x env isevars (pbty,ev1,t2) else (* Postpone the use of an heuristic *) - add_conv_pb (pbty,applist(term1,l1),applist(term2,l2)) isevars, + add_conv_pb (pbty,env,applist(term1,l1),applist(term2,l2)) isevars, true | Rigid _, Flexible ev2 -> @@ -342,7 +342,7 @@ and evar_eqappr_x env isevars pbty (term1,l1 as appr1) (term2,l2 as appr2) = solve_simple_eqn evar_conv_x env isevars (pbty,ev2,t1) else (* Postpone the use of an heuristic *) - add_conv_pb (pbty,applist(term1,l1),applist(term2,l2)) isevars, + add_conv_pb (pbty,env,applist(term1,l1),applist(term2,l2)) isevars, true | MaybeFlexible flex1, Rigid _ -> @@ -524,8 +524,7 @@ let first_order_unification env isevars pbty (term1,l1) (term2,l2) = let consider_remaining_unif_problems env isevars = let (isevars,pbs) = get_conv_pbs isevars (fun _ -> true) in List.fold_left - (fun (isevars,b as p) (pbty,t1,t2) -> - (* Pas le bon env pour le problème... *) + (fun (isevars,b as p) (pbty,env,t1,t2) -> if b then first_order_unification env isevars pbty (apprec_nohdbeta env isevars (whd_castappevar (evars_of isevars) t1)) (apprec_nohdbeta env isevars (whd_castappevar (evars_of isevars) t2)) diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml index b545bd38..6896ca69 100644 --- a/pretyping/evarutil.ml +++ b/pretyping/evarutil.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: evarutil.ml 9573 2007-01-31 20:18:18Z notin $ *) +(* $Id: evarutil.ml 9869 2007-05-29 11:07:04Z herbelin $ *) open Util open Pp @@ -424,6 +424,8 @@ let need_restriction k args = not (array_for_all (closedn k) args) * false. The problem is that we won't get the right error message. *) +exception NotClean of constr + let real_clean env isevars ev evi args rhs = let evd = ref isevars in let subst = List.map (fun (x,y) -> (y,mkVar x)) (list_uniquize args) in @@ -434,7 +436,7 @@ let real_clean env isevars ev evi args rhs = else (* Flex/Rel problem: unifiable as a pattern iff Rel in ev scope *) (try List.assoc (mkRel (i-k)) subst - with Not_found -> if rigid then raise Exit else t) + with Not_found -> if rigid then raise (NotClean t) else t) | Evar (ev,args) -> if Evd.is_defined_evar !evd (ev,args) then subs rigid k (existential_value (evars_of !evd) (ev,args)) @@ -460,7 +462,7 @@ let real_clean env isevars ev evi args rhs = or List.exists (fun (id',_,_) -> id=id') (evar_context evi) *) then t - else raise Exit) + else raise (NotClean t)) | _ -> (* Flex/Rigid problem (or assimilated if not normal): we "imitate" *) @@ -470,8 +472,8 @@ let real_clean env isevars ev evi args rhs = let rhs = whd_beta rhs (* heuristic *) in let body = try subs true 0 rhs - with Exit -> - error_not_clean env (evars_of !evd) ev rhs (evar_source ev !evd) in + with NotClean t -> + error_not_clean env (evars_of !evd) ev t (evar_source ev !evd) in (!evd,body) (* [evar_define] solves the problem lhs = rhs when lhs is an uninstantiated @@ -619,7 +621,7 @@ let solve_pattern_eqn env l1 c = * ass. *) -let status_changed lev (pbty,t1,t2) = +let status_changed lev (pbty,_,t1,t2) = try List.mem (head_evar t1) lev or List.mem (head_evar t2) lev with Failure _ -> @@ -678,7 +680,7 @@ let solve_simple_eqn conv_algo env isevars (pbty,(n1,args1 as ev1),t2) = evar_define env ev1 t2 isevars in let (isevars,pbs) = get_conv_pbs isevars (status_changed lsp) in List.fold_left - (fun (isevars,b as p) (pbty,t1,t2) -> + (fun (isevars,b as p) (pbty,env,t1,t2) -> if b then conv_algo env isevars pbty t1 t2 else p) (isevars,true) pbs with e when precatchable_exception e -> diff --git a/pretyping/evd.ml b/pretyping/evd.ml index c68a7a73..69d4352f 100644 --- a/pretyping/evd.ml +++ b/pretyping/evd.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: evd.ml 9573 2007-01-31 20:18:18Z notin $ *) +(* $Id: evd.ml 9976 2007-07-12 11:58:30Z msozeau $ *) open Pp open Util @@ -358,24 +358,23 @@ let metamap_to_list m = type hole_kind = | ImplicitArg of global_reference * (int * identifier option) | BinderType of name - | QuestionMark + | QuestionMark of bool | CasesType | InternalHole | TomatchTypeParameter of inductive * int type conv_pb = Reduction.conv_pb -type evar_constraint = conv_pb * constr * constr +type evar_constraint = conv_pb * Environ.env * constr * constr type evar_defs = { evars : evar_map; conv_pbs : evar_constraint list; history : (existential_key * (loc * hole_kind)) list; metas : clbinding Metamap.t } -let subst_evar_defs sub evd = +let subst_evar_defs_light sub evd = + assert (evd.evars = (Evarmap.empty,UniverseMap.empty)); + assert (evd.conv_pbs = []); { evd with - conv_pbs = - List.map (fun (k,t1,t2) ->(k,subst_mps sub t1,subst_mps sub t2)) - evd.conv_pbs; metas = Metamap.map (map_clb (subst_mps sub)) evd.metas } let create_evar_defs sigma = @@ -552,7 +551,7 @@ let pr_evar_map sigma = let pr_constraints pbs = h 0 - (prlist_with_sep pr_fnl (fun (pbty,t1,t2) -> + (prlist_with_sep pr_fnl (fun (pbty,_,t1,t2) -> print_constr t1 ++ spc() ++ str (match pbty with | Reduction.CONV -> "==" diff --git a/pretyping/evd.mli b/pretyping/evd.mli index e1fc425b..ef6a3d7b 100644 --- a/pretyping/evd.mli +++ b/pretyping/evd.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: evd.mli 9573 2007-01-31 20:18:18Z notin $ i*) +(*i $Id: evd.mli 9976 2007-07-12 11:58:30Z msozeau $ i*) (*i*) open Util @@ -111,8 +111,8 @@ val map_clb : (constr -> constr) -> clbinding -> clbinding (* Unification state *) type evar_defs -(* Substitution is not applied to the [evar_map] *) -val subst_evar_defs : substitution -> evar_defs -> evar_defs +(* Assume empty [evar_map] and [conv_pbs] *) +val subst_evar_defs_light : substitution -> evar_defs -> evar_defs (* create an [evar_defs] with empty meta map: *) val create_evar_defs : evar_map -> evar_defs @@ -123,7 +123,7 @@ val evars_reset_evd : evar_map -> evar_defs -> evar_defs type hole_kind = | ImplicitArg of global_reference * (int * identifier option) | BinderType of name - | QuestionMark + | QuestionMark of bool (* Can it be turned into an obligation ? *) | CasesType | InternalHole | TomatchTypeParameter of inductive * int @@ -138,7 +138,7 @@ val evar_source : existential_key -> evar_defs -> loc * hole_kind (* Unification constraints *) type conv_pb = Reduction.conv_pb -type evar_constraint = conv_pb * constr * constr +type evar_constraint = conv_pb * Environ.env * constr * constr val add_conv_pb : evar_constraint -> evar_defs -> evar_defs val get_conv_pbs : evar_defs -> (evar_constraint -> bool) -> evar_defs * evar_constraint list diff --git a/pretyping/pattern.ml b/pretyping/pattern.ml index eb8a25eb..3060ee03 100644 --- a/pretyping/pattern.ml +++ b/pretyping/pattern.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: pattern.ml 8963 2006-06-19 18:54:49Z barras $ *) +(* $Id: pattern.ml 9976 2007-07-12 11:58:30Z msozeau $ *) open Util open Names @@ -233,7 +233,7 @@ let rec pat_of_raw metas vars = function PSort s | RHole _ -> PMeta None - | RCast (_,c,_,t) -> + | RCast (_,c,_) -> Options.if_verbose Pp.warning "Cast not taken into account in constr pattern"; pat_of_raw metas vars c diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 0b00c82c..0db64a52 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: pretyping.ml 9338 2006-11-03 13:09:53Z herbelin $ *) +(* $Id: pretyping.ml 9976 2007-07-12 11:58:30Z msozeau $ *) open Pp open Util @@ -571,13 +571,13 @@ module Pretyping_F (Coercion : Coercion.S) = struct ((fun vtyc env -> pretype vtyc env isevars lvar),isevars) tycon env (* loc *) (po,tml,eqns) - | RCast(loc,c,k,t) -> + | RCast (loc,c,k) -> let cj = match k with CastCoerce -> let cj = pretype empty_tycon env isevars lvar c in evd_comb1 (Coercion.inh_coerce_to_base loc env) isevars cj - | CastConv k -> + | CastConv (k,t) -> let tj = pretype_type empty_valcon env isevars lvar t in let cj = pretype (mk_tycon tj.utj_val) env isevars lvar c in (* User Casts are for helping pretyping, experimentally not to be kept*) diff --git a/pretyping/rawterm.ml b/pretyping/rawterm.ml index d7e3ac77..aaf9e63d 100644 --- a/pretyping/rawterm.ml +++ b/pretyping/rawterm.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: rawterm.ml 9535 2007-01-26 09:26:08Z jforest $ *) +(* $Id: rawterm.ml 9976 2007-07-12 11:58:30Z msozeau $ *) (*i*) open Util @@ -47,8 +47,8 @@ type 'a bindings = type 'a with_bindings = 'a * 'a bindings -type cast_type = - | CastConv of cast_kind +type 'a cast_type = + | CastConv of cast_kind * 'a | CastCoerce (* Cast to a base type (eg, an underlying inductive type) *) type rawconstr = @@ -68,7 +68,7 @@ type rawconstr = rawconstr array * rawconstr array | RSort of loc * rawsort | RHole of (loc * hole_kind) - | RCast of loc * rawconstr * cast_type * rawconstr + | RCast of loc * rawconstr * rawconstr cast_type | RDynamic of loc * Dyn.t and rawdecl = name * rawconstr option * rawconstr @@ -120,7 +120,7 @@ let map_rawconstr f = function | RRec (loc,fk,idl,bl,tyl,bv) -> RRec (loc,fk,idl,Array.map (List.map (map_rawdecl f)) bl, Array.map f tyl,Array.map f bv) - | RCast (loc,c,k,t) -> RCast (loc,f c,k,f t) + | RCast (loc,c,k) -> RCast (loc,f c, match k with CastConv (k,t) -> CastConv (k, f t) | x -> x) | (RSort _ | RHole _ | RRef _ | REvar _ | RPatVar _ | RDynamic _) as x -> x @@ -190,7 +190,7 @@ let occur_rawconstr id = (na=Name id or not(occur_fix bl)) in occur_fix bl) idl bl tyl bv) - | RCast (loc,c,_,t) -> (occur c) or (occur t) + | RCast (loc,c,k) -> (occur c) or (match k with CastConv (_, t) -> occur t | CastCoerce -> false) | (RSort _ | RHole _ | RRef _ | REvar _ | RPatVar _ | RDynamic _) -> false and occur_pattern (loc,idl,p,c) = not (List.mem id idl) & (occur c) @@ -247,7 +247,8 @@ let free_rawvars = vars bounded1 vs2 bv.(i) in array_fold_left_i vars_fix vs idl - | RCast (loc,c,_,t) -> vars bounded (vars bounded vs c) t + | RCast (loc,c,k) -> let v = vars bounded vs c in + (match k with CastConv (_,t) -> vars bounded v t | _ -> v) | (RSort _ | RHole _ | RRef _ | REvar _ | RPatVar _ | RDynamic _) -> vs and vars_pattern bounded vs (loc,idl,p,c) = @@ -280,7 +281,7 @@ let loc_of_rawconstr = function | RRec (loc,_,_,_,_,_) -> loc | RSort (loc,_) -> loc | RHole (loc,_) -> loc - | RCast (loc,_,_,_) -> loc + | RCast (loc,_,_) -> loc | RDynamic (loc,_) -> loc (**********************************************************************) diff --git a/pretyping/rawterm.mli b/pretyping/rawterm.mli index e5601705..546b36b0 100644 --- a/pretyping/rawterm.mli +++ b/pretyping/rawterm.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: rawterm.mli 9535 2007-01-26 09:26:08Z jforest $ i*) +(*i $Id: rawterm.mli 9976 2007-07-12 11:58:30Z msozeau $ i*) (*i*) open Util @@ -51,8 +51,8 @@ type 'a bindings = type 'a with_bindings = 'a * 'a bindings -type cast_type = - | CastConv of cast_kind +type 'a cast_type = + | CastConv of cast_kind * 'a | CastCoerce (* Cast to a base type (eg, an underlying inductive type) *) type rawconstr = @@ -72,7 +72,7 @@ type rawconstr = rawconstr array * rawconstr array | RSort of loc * rawsort | RHole of (loc * Evd.hole_kind) - | RCast of loc * rawconstr * cast_type * rawconstr + | RCast of loc * rawconstr * rawconstr cast_type | RDynamic of loc * Dyn.t and rawdecl = name * rawconstr option * rawconstr diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 006e14b3..92617820 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: tacred.ml 8793 2006-05-05 17:41:41Z barras $ *) +(* $Id: tacred.ml 9762 2007-04-13 12:46:50Z herbelin $ *) open Pp open Util @@ -365,7 +365,7 @@ let contract_cofix_use_function f (bodynum,(_,names,bodies as typedbodies)) = | Some c -> c in (* match List.nth names j with Name id -> f id | _ -> assert false in*) let subbodies = list_tabulate make_Fi nbodies in - substl subbodies bodies.(bodynum) + substl (List.rev subbodies) bodies.(bodynum) let reduce_mind_case_use_function func env mia = match kind_of_term mia.mconstr with diff --git a/proofs/logic.ml b/proofs/logic.ml index 92225948..0846997e 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: logic.ml 9601 2007-02-06 21:37:59Z herbelin $ *) +(* $Id: logic.ml 9805 2007-04-28 21:28:37Z herbelin $ *) open Pp open Util @@ -582,10 +582,10 @@ let subst_proof_vars = let rec rebind id1 id2 = function | [] -> [Name id2,SectionVar id1] - | (na,_ as x)::l -> - if na = Name id1 then (Name id2,ProofVar)::l else + | (na,k as x)::l -> + if na = Name id1 then (Name id2,k)::l else let l' = rebind id1 id2 l in - if na = Name id2 then (Anonymous,ProofVar)::l' else x::l' + if na = Name id2 then (Anonymous,k)::l' else x::l' let add_proof_var id vl = (Name id,ProofVar)::vl diff --git a/tactics/decl_interp.ml b/tactics/decl_interp.ml index f341580e..87a47200 100644 --- a/tactics/decl_interp.ml +++ b/tactics/decl_interp.ml @@ -346,7 +346,7 @@ let interp_cases info sigma env params (pat:cases_pattern_expr) hyps = (fun (loc,(id,_)) -> RVar (loc,id)) params in let dum_args= - list_tabulate (fun _ -> RHole (dummy_loc,Evd.QuestionMark)) + list_tabulate (fun _ -> RHole (dummy_loc,Evd.QuestionMark false)) oib.Declarations.mind_nrealargs in raw_app(dummy_loc,rind,rparams@rparams_rec@dum_args) in let pat_vars,aliases,patt = interp_pattern env pat in @@ -369,7 +369,7 @@ let interp_cases info sigma env params (pat:cases_pattern_expr) hyps = let term2 = RLetIn(dummy_loc,Anonymous, RCast(dummy_loc,raw_of_pat npatt, - CastConv DEFAULTcast,app_ind),term1) in + CastConv (DEFAULTcast,app_ind)),term1) in let term3=List.fold_right let_in_one_alias aliases term2 in let term4=List.fold_right prod_one_id loc_ids term3 in let term5=List.fold_right prod_one_hyp params term4 in diff --git a/tactics/decl_proof_instr.ml b/tactics/decl_proof_instr.ml index b19d8c04..a34446d8 100644 --- a/tactics/decl_proof_instr.ml +++ b/tactics/decl_proof_instr.ml @@ -886,11 +886,11 @@ let build_per_info etype casee gls = ET_Induction -> mind.mind_nparams_rec | _ -> mind.mind_nparams in let params,real_args = list_chop nparams args in - let abstract_obj body c = + let abstract_obj c body = let typ=pf_type_of gls c in lambda_create env (typ,subst_term c body) in - let pred= List.fold_left abstract_obj - (lambda_create env (ctyp,subst_term casee concl)) real_args in + let pred= List.fold_right abstract_obj + real_args (lambda_create env (ctyp,subst_term casee concl)) in is_dep, {per_casee=casee; per_ctype=ctyp; @@ -1273,7 +1273,7 @@ end*) let rec execute_cases at_top fix_name per_info kont0 stacks tree gls = - match tree with + match tree with Pop t -> let is_rec,nstacks = pop_stacks stacks in if is_rec then @@ -1309,51 +1309,59 @@ let rec execute_cases at_top fix_name per_info kont0 stacks tree gls = kont] gls) end gls | Split(ids,ind,br) -> - let (_,typ,_)=destProd (pf_concl gls) in + let (_,typ,_)= + try destProd (pf_concl gls) with Invalid_argument _ -> + anomaly "Sub-object not found." in let hd,args=decompose_app (special_whd gls typ) in - let _ = assert (ind = destInd hd) in - let nparams = (fst (Global.lookup_inductive ind)).mind_nparams in - let params = list_firstn nparams args in - let constr i =applist (mkConstruct(ind,succ i),params) in - let next_tac is_rec i = function - Some (sub_ids,tree) -> - let br_stacks = - List.filter (fun (id,_) -> Idset.mem id sub_ids) stacks in - let p_stacks = - push_head (constr i) is_rec ids br_stacks in - execute_cases false fix_name per_info kont0 p_stacks tree - | None -> - msgnl (str "Warning : missing case"); - kont0 (mkMeta 1) - in - let id = pf_get_new_id patvar_base gls in - let kont is_rec = - tclTHENSV - (general_case_analysis (mkVar id,NoBindings)) - (Array.mapi (next_tac is_rec) br) in - tclTHEN - (intro_mustbe_force id) - begin - match fix_name with - Anonymous -> kont false - | Name fix_id -> - (fun gls -> - if at_top then - kont false gls - else - match hrec_for id fix_id per_info gls with - None -> kont false gls - | Some c_obj -> - tclTHENLIST - [generalize [c_obj]; - kont true] gls) - end gls + if try ind <> destInd hd with Invalid_argument _ -> true then + (* argument of an inductive family : intro + discard *) + tclTHEN intro + (execute_cases at_top fix_name per_info kont0 stacks tree) gls + else + begin + let nparams = (fst (Global.lookup_inductive ind)).mind_nparams in + let params = list_firstn nparams args in + let constr i =applist (mkConstruct(ind,succ i),params) in + let next_tac is_rec i = function + Some (sub_ids,tree) -> + let br_stacks = + List.filter (fun (id,_) -> Idset.mem id sub_ids) stacks in + let p_stacks = + push_head (constr i) is_rec ids br_stacks in + execute_cases false fix_name per_info kont0 p_stacks tree + | None -> + msgnl (str "Warning : missing case"); + kont0 (mkMeta 1) + in + let id = pf_get_new_id patvar_base gls in + let kont is_rec = + tclTHENSV + (general_case_analysis (mkVar id,NoBindings)) + (Array.mapi (next_tac is_rec) br) in + tclTHEN + (intro_mustbe_force id) + begin + match fix_name with + Anonymous -> kont false + | Name fix_id -> + (fun gls -> + if at_top then + kont false gls + else + match hrec_for id fix_id per_info gls with + None -> kont false gls + | Some c_obj -> + tclTHENLIST + [generalize [c_obj]; + kont true] gls) + end gls + end | End_of_branch (id,nhyps) -> - match List.assoc id stacks with - [None,_,args] -> - let metas = list_tabulate (fun n -> mkMeta (succ n)) nhyps in - kont0 (applist (mkVar id,List.rev_append args metas)) gls - | _ -> anomaly "wrong stack size" + match List.assoc id stacks with + [None,_,args] -> + let metas = list_tabulate (fun n -> mkMeta (succ n)) nhyps in + kont0 (applist (mkVar id,List.rev_append args metas)) gls + | _ -> anomaly "wrong stack size" let end_tac et2 gls = let info = get_its_info gls in diff --git a/tactics/equality.ml b/tactics/equality.ml index 754aec1c..24a7e34e 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: equality.ml 9521 2007-01-23 14:31:21Z notin $ *) +(* $Id: equality.ml 9835 2007-05-17 22:23:03Z jforest $ *) open Pp open Util @@ -93,7 +93,7 @@ let general_rewrite_bindings_clause cls lft2rgt (c,l) gl = (* Original code. In particular, [splay_prod] performs delta-reduction. *) let env = pf_env gl in let sigma = project gl in - let _,t = splay_prod env sigma t in + let _,t = splay_prod env sigma ctype in match match_with_equation t with | None -> if l = NoBindings @@ -313,6 +313,13 @@ let discriminable env sigma t1 t2 = | Inl _ -> true | _ -> false +let injectable env sigma t1 t2 = + match find_positions env sigma t1 t2 with + | Inl _ | Inr [] -> false + | Inr _ -> true + + + (* Once we have found a position, we need to project down to it. If we are discriminating, then we need to produce False on one of the branches of the discriminator, and True on the other one. So the diff --git a/tactics/equality.mli b/tactics/equality.mli index 3d6a08b6..93cf53bd 100644 --- a/tactics/equality.mli +++ b/tactics/equality.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: equality.mli 9195 2006-10-01 09:41:57Z herbelin $ i*) +(*i $Id: equality.mli 9835 2007-05-17 22:23:03Z jforest $ i*) (*i*) open Names @@ -105,6 +105,7 @@ val substHyp : bool -> types -> identifier -> tactic *) val discriminable : env -> evar_map -> constr -> constr -> bool +val injectable : env -> evar_map -> constr -> constr -> bool (* Subst *) diff --git a/tactics/setoid_replace.ml b/tactics/setoid_replace.ml index 2727e669..c14462eb 100644 --- a/tactics/setoid_replace.ml +++ b/tactics/setoid_replace.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: setoid_replace.ml 9331 2006-11-01 09:36:06Z herbelin $ *) +(* $Id: setoid_replace.ml 9853 2007-05-23 14:25:47Z letouzey $ *) open Tacmach open Proof_type @@ -709,9 +709,10 @@ let add_morphism lemma_infos mor_name (m,quantifiers_rev,args,output) = let unify_relation_carrier_with_type env rel t = let raise_error quantifiers_no = errorlabstrm "New Morphism" - (str "One morphism argument or its output has type " ++ pr_lconstr t ++ + (str "One morphism argument or its output has type " ++ + pr_lconstr_env env t ++ str " but the signature requires an argument of type \"" ++ - pr_lconstr rel.rel_a ++ str " " ++ prvect_with_sep pr_spc (fun _ -> str "?") + pr_lconstr_env env rel.rel_a ++ prvect_with_sep mt (fun _ -> str " ?") (Array.make quantifiers_no 0) ++ str "\"") in let args = match kind_of_term t with @@ -757,9 +758,10 @@ let unify_relation_class_carrier_with_type env rel t = rel else errorlabstrm "New Morphism" - (str "One morphism argument or its output has type " ++ pr_lconstr t ++ + (str "One morphism argument or its output has type " ++ + pr_lconstr_env env t ++ str " but the signature requires an argument of type " ++ - pr_lconstr t') + pr_lconstr_env env t') | Leibniz None -> Leibniz (Some t) | Relation rel -> Relation (unify_relation_carrier_with_type env rel t) @@ -961,6 +963,8 @@ let new_named_morphism id m sign = match sign with None -> None | Some (args,out) -> + if args = [] then + error "Morphism signature expects at least one argument."; Some (List.map (fun (variance,ty) -> variance, constr_of ty) args, constr_of out) @@ -1947,7 +1951,7 @@ let setoid_reflexivity gl = (str "The relation " ++ prrelation rel ++ str " is not reflexive.") | Some refl -> apply refl gl with - Optimize -> reflexivity gl + Optimize -> reflexivity_red true gl let setoid_symmetry gl = try @@ -1963,7 +1967,7 @@ let setoid_symmetry gl = (str "The relation " ++ prrelation rel ++ str " is not symmetric.") | Some sym -> apply sym gl with - Optimize -> symmetry gl + Optimize -> symmetry_red true gl let setoid_symmetry_in id gl = let new_hyp = @@ -1998,7 +2002,7 @@ let setoid_transitivity c gl = apply_with_bindings (trans, Rawterm.ExplicitBindings [ dummy_loc, binder, c ]) gl with - Optimize -> transitivity c gl + Optimize -> transitivity_red true c gl ;; Tactics.register_setoid_reflexivity setoid_reflexivity;; diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 29150c27..ac6a396f 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: tacinterp.ml 9551 2007-01-29 15:13:35Z bgregoir $ *) +(* $Id: tacinterp.ml 9976 2007-07-12 11:58:30Z msozeau $ *) open Constrintern open Closure @@ -1195,7 +1195,7 @@ let interp_hyp_location ist gl ((occs,id),hl) = let interp_clause ist gl { onhyps=ol; onconcl=b; concl_occs=occs } = { onhyps=option_map(List.map (interp_hyp_location ist gl)) ol; onconcl=b; - concl_occs=occs } + concl_occs=interp_int_or_var_list ist occs } (* Interpretation of constructions *) @@ -1253,7 +1253,7 @@ open Evd let solvable_by_tactic env evi (ev,args) src = match (!implicit_tactic, src) with - | Some tac, (ImplicitArg _ | QuestionMark) + | Some tac, (ImplicitArg _ | QuestionMark _) when Environ.named_context_of_val evi.evar_hyps = Environ.named_context env -> @@ -1827,6 +1827,8 @@ and interp_genarg ist gl x = (interp_bindings ist gl (out_gen globwit_bindings x)) | List0ArgType ConstrArgType -> interp_genarg_constr_list0 ist gl x | List1ArgType ConstrArgType -> interp_genarg_constr_list1 ist gl x + | List0ArgType VarArgType -> interp_genarg_var_list0 ist gl x + | List1ArgType VarArgType -> interp_genarg_var_list1 ist gl x | List0ArgType _ -> app_list0 (interp_genarg ist gl) x | List1ArgType _ -> app_list1 (interp_genarg ist gl) x | OptArgType _ -> app_opt (interp_genarg ist gl) x @@ -1849,6 +1851,16 @@ and interp_genarg_constr_list1 ist gl x = let lc = pf_interp_constr_list ist gl lc in in_gen (wit_list1 wit_constr) lc +and interp_genarg_var_list0 ist gl x = + let lc = out_gen (wit_list0 globwit_var) x in + let lc = interp_hyp_list ist gl lc in + in_gen (wit_list0 wit_var) lc + +and interp_genarg_var_list1 ist gl x = + let lc = out_gen (wit_list1 globwit_var) x in + let lc = interp_hyp_list ist gl lc in + in_gen (wit_list1 wit_var) lc + (* Interprets the Match expressions *) and interp_match ist g lz constr lmr = let rec apply_match_subterm ist nocc (id,c) csr mt = diff --git a/tactics/tactics.ml b/tactics/tactics.ml index cb98ec18..c863a453 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: tactics.ml 9605 2007-02-07 12:19:19Z notin $ *) +(* $Id: tactics.ml 9853 2007-05-23 14:25:47Z letouzey $ *) open Pp open Util @@ -503,6 +503,20 @@ let cut_in_parallel l = in prec (List.rev l) +let error_uninstantiated_metas t clenv = + let na = meta_name clenv.env (List.hd (Metaset.elements (metavars_of t))) in + let id = match na with Name id -> id | _ -> anomaly "unnamed dependent meta" + in errorlabstrm "" (str "cannot find an instance for " ++ pr_id id) + +let clenv_refine_in id clenv gl = + let new_hyp_typ = clenv_type clenv in + if occur_meta new_hyp_typ then error_uninstantiated_metas new_hyp_typ clenv; + let new_hyp_prf = clenv_value clenv in + tclTHEN + (tclEVARS (evars_of clenv.env)) + (cut_replacing id new_hyp_typ + (fun x gl -> refine_no_check new_hyp_prf gl)) gl + (****************************************************) (* Resolution tactics *) (****************************************************) @@ -575,12 +589,7 @@ let apply_in id lemmas gls = let t' = pf_get_hyp_typ gls id in let innermostclause = mk_clenv_from_n gls (Some 0) (mkVar id,t') in let clause = List.fold_left (apply_in_once gls) innermostclause lemmas in - let new_hyp_prf = clenv_value clause in - let new_hyp_typ = clenv_type clause in - tclTHEN - (tclEVARS (evars_of clause.env)) - (cut_replacing id new_hyp_typ - (fun x gls -> refine_no_check new_hyp_prf gls)) gls + clenv_refine_in id clause gls (* A useful resolution tactic which, if c:A->B, transforms |- C into |- B -> C and |- A @@ -839,15 +848,11 @@ let elimination_in_clause_scheme id elimclause indclause gl = let hyp_typ = pf_type_of gl hyp in let hypclause = mk_clenv_from_n gl (Some 0) (hyp, hyp_typ) in let elimclause'' = clenv_fchain hypmv elimclause' hypclause in - let new_hyp_prf = clenv_value elimclause'' in let new_hyp_typ = clenv_type elimclause'' in if eq_constr hyp_typ new_hyp_typ then errorlabstrm "general_rewrite_in" (str "Nothing to rewrite in " ++ pr_id id); - tclTHEN - (tclEVARS (evars_of elimclause''.env)) - (cut_replacing id new_hyp_typ - (fun x gls -> refine_no_check new_hyp_prf gls)) gl + clenv_refine_in id elimclause'' gl let general_elim_in id = general_elim_clause (elimination_in_clause_scheme id) @@ -2328,10 +2333,18 @@ let dImp cls = let setoid_reflexivity = ref (fun _ -> assert false) let register_setoid_reflexivity f = setoid_reflexivity := f -let reflexivity gl = - match match_with_equation (pf_concl gl) with +let reflexivity_red allowred gl = + (* PL: usual reflexivity don't perform any reduction when searching + for an equality, but we may need to do some when called back from + inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *) + let concl = if not allowred then pf_concl gl + else whd_betadeltaiota (pf_env gl) (project gl) (pf_concl gl) + in + match match_with_equation concl with | None -> !setoid_reflexivity gl - | Some (hdcncl,args) -> one_constructor 1 NoBindings gl + | Some _ -> one_constructor 1 NoBindings gl + +let reflexivity gl = reflexivity_red false gl let intros_reflexivity = (tclTHEN intros reflexivity) @@ -2345,8 +2358,14 @@ let intros_reflexivity = (tclTHEN intros reflexivity) let setoid_symmetry = ref (fun _ -> assert false) let register_setoid_symmetry f = setoid_symmetry := f -let symmetry gl = - match match_with_equation (pf_concl gl) with +let symmetry_red allowred gl = + (* PL: usual symmetry don't perform any reduction when searching + for an equality, but we may need to do some when called back from + inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *) + let concl = if not allowred then pf_concl gl + else whd_betadeltaiota (pf_env gl) (project gl) (pf_concl gl) + in + match match_with_equation concl with | None -> !setoid_symmetry gl | Some (hdcncl,args) -> let hdcncls = string_of_inductive hdcncl in @@ -2360,7 +2379,7 @@ let symmetry gl = | [c1;c2] -> mkApp (hdcncl, [| c2; c1 |]) | _ -> assert false in - tclTHENLAST (cut symc) + tclTHENFIRST (cut symc) (tclTHENLIST [ intro; tclLAST_HYP simplest_case; @@ -2368,6 +2387,8 @@ let symmetry gl = gl end +let symmetry gl = symmetry_red false gl + let setoid_symmetry_in = ref (fun _ _ -> assert false) let register_setoid_symmetry_in f = setoid_symmetry_in := f @@ -2408,8 +2429,14 @@ let intros_symmetry = let setoid_transitivity = ref (fun _ _ -> assert false) let register_setoid_transitivity f = setoid_transitivity := f -let transitivity t gl = - match match_with_equation (pf_concl gl) with +let transitivity_red allowred t gl = + (* PL: usual transitivity don't perform any reduction when searching + for an equality, but we may need to do some when called back from + inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *) + let concl = if not allowred then pf_concl gl + else whd_betadeltaiota (pf_env gl) (project gl) (pf_concl gl) + in + match match_with_equation concl with | None -> !setoid_transitivity t gl | Some (hdcncl,args) -> let hdcncls = string_of_inductive hdcncl in @@ -2436,7 +2463,9 @@ let transitivity t gl = tclLAST_HYP simplest_case; assumption ])) gl end - + +let transitivity t gl = transitivity_red false t gl + let intros_transitivity n = tclTHEN intros (transitivity n) (* tactical to save as name a subproof such that the generalisation of diff --git a/tactics/tactics.mli b/tactics/tactics.mli index aece3231..bb71afb9 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: tactics.mli 9551 2007-01-29 15:13:35Z bgregoir $ i*) +(*i $Id: tactics.mli 9853 2007-05-23 14:25:47Z letouzey $ i*) (*i*) open Names @@ -276,16 +276,19 @@ val simplest_split : tactic (*s Logical connective tactics. *) val register_setoid_reflexivity : tactic -> unit +val reflexivity_red : bool -> tactic val reflexivity : tactic val intros_reflexivity : tactic val register_setoid_symmetry : tactic -> unit +val symmetry_red : bool -> tactic val symmetry : tactic val register_setoid_symmetry_in : (identifier -> tactic) -> unit val symmetry_in : identifier -> tactic val intros_symmetry : clause -> tactic val register_setoid_transitivity : (constr -> tactic) -> unit +val transitivity_red : bool -> constr -> tactic val transitivity : constr -> tactic val intros_transitivity : constr -> tactic diff --git a/test-suite/check b/test-suite/check index 2f6738a0..504e96cc 100755 --- a/test-suite/check +++ b/test-suite/check @@ -108,23 +108,29 @@ test_interactive() { # with exactly two digits after the dot test_complexity() { if [ -f /proc/cpuinfo ]; then - bogomips=`sed -n -e "s/bogomips.*: \([0-9]*\).*/\1/p" /proc/cpuinfo | head -1` - else - bogomips=6120 # assume a i386 3Gz + if grep -q bogomips /proc/cpuinfo; then # i386, ppc + bogomips=`sed -n -e "s/bogomips.*: \([0-9]*\).*/\1/p" /proc/cpuinfo | head -1` + elif grep -q Cpu0Bogo /proc/cpuinfo; then # sparc + bogomips=`sed -n -e "s/Cpu0Bogo.*: \([0-9]*\).*/\1/p" /proc/cpuinfo | head -1` + elif grep -q BogoMIPS /proc/cpuinfo; then # alpha + bogomips=`sed -n -e "s/BogoMIPS.*: \([0-9]*\).*/\1/p" /proc/cpuinfo | head -1` + fi fi - for f in $1/*.v; do - nbtests=`expr $nbtests + 1` - printf " "$f"..." - # compute effective user time (get X seconds, or XX ds, or XXX cs) - res=`$command $f 2>&1 | sed -n -e "s/Finished transaction in .*(\([0-9]\)\.\([0-9]*\)u.*)/\1\2/p" | head -1` - if [ $? != 0 ]; then - echo "Error! (should be accepted)" + if [ "$bogomips" = "" ]; then + echo " cannot run complexity tests (no bogomips found)" + else + for f in $1/*.v; do + nbtests=`expr $nbtests + 1` + printf " "$f"..." + # extract effective user time + res=`$command $f 2>&1 | sed -n -e "s/Finished transaction in .*(\([0-9]*\.[0-9]*\)u.*)/\1/p" | head -1` + if [ $? != 0 ]; then + echo "Error! (should be accepted)" + elif [ "$res" = "" ]; then + echo "Error! (couldn't find a time measure)" else - # express effective time in cenths of seconds - n=`echo -n $res | wc -c` - if [ $n = 2 ]; then res="$res"0; - else if [ $n = 1 ]; then res="$res"00; fi - fi + # express effective time in centiseconds + res=`echo "$res"00 | sed -n -e "s/\([0-9]*\)\.\([0-9][0-9]\).*/\1\2/p"` # find expected time * 100 exp=`sed -n -e "s/(\*.*Expected time < \([0-9]\).\([0-9][0-9]\)s.*\*)/\1\2/p" $f` ok=`expr \( $res \* $bogomips \) "<" \( $exp \* 6120 \)` @@ -135,7 +141,8 @@ test_complexity() { echo "Error! (should run faster)" fi fi - done + done + fi } # Programme principal diff --git a/test-suite/success/Omega0.v b/test-suite/success/Omega0.v index 4614c90d..accaec41 100644 --- a/test-suite/success/Omega0.v +++ b/test-suite/success/Omega0.v @@ -8,16 +8,16 @@ Lemma test_romega_0 : 0<= m <= 1 -> 0<= m' <= 1 -> (0 < m <-> 0 < m') -> m = m'. Proof. intros. -(*omega.*) -Admitted. +omega. +Qed. Lemma test_romega_0b : forall m m', 0<= m <= 1 -> 0<= m' <= 1 -> (0 < m <-> 0 < m') -> m = m'. Proof. intros m m'. -(*omega.*) -Admitted. +omega. +Qed. Lemma test_romega_1 : forall (z z1 z2 : Z), diff --git a/test-suite/success/ROmega.v b/test-suite/success/ROmega.v index 04b666ed..ff1f57df 100644 --- a/test-suite/success/ROmega.v +++ b/test-suite/success/ROmega.v @@ -7,8 +7,8 @@ Lemma lem1 : forall x y : Z, (-5 < x < 5)%Z -> (-5 < y)%Z -> (-5 < x + y + 5)%Z. Proof. intros x y. - (*romega.*) -Admitted. +romega. +Qed. (* Proposed by Pierre Crégut *) @@ -22,8 +22,8 @@ Qed. Lemma lem3 : forall x y : Z, x = y -> (x + x)%Z = (y + y)%Z. Proof. intros. - (*romega.*) -Admitted. +romega. +Qed. (* Proposed by Jean-Christophe Filliâtre: confusion between an Omega *) (* internal variable and a section variable (June 2001) *) @@ -68,7 +68,7 @@ Variable n : nat. Variable ap_n : n <> 0. Let delta := f n ap_n. Lemma lem7 : n = n. - (*romega.*) (*ROMEGA CANT DEAL WITH NAT*) + (*romega. ---> ROMEGA CANT DEAL WITH NAT*) Admitted. End C. @@ -76,7 +76,7 @@ End C. Require Import Omega. Lemma lem8 : forall H : 0 = 0 -> 0 = 0, H = H -> 0 = 0. intros. -(* romega.*) (*ROMEGA CANT DEAL WITH NAT*) +(* romega. ---> ROMEGA CANT DEAL WITH NAT*) Admitted. (* Bug that what caused by the use of intro_using in Omega *) @@ -84,7 +84,7 @@ Require Import Omega. Lemma lem9 : forall p q : nat, ~ (p <= q /\ p < q \/ q <= p /\ p < q) -> p < p \/ p <= p. intros. -(* romega.*)(*ROMEGA CANT DEAL WITH NAT*) +(* romega. ---> ROMEGA CANT DEAL WITH NAT*) Admitted. (* Check that the interpretation of mult on nat enforces its positivity *) diff --git a/test-suite/success/ROmega0.v b/test-suite/success/ROmega0.v index 0efca1e1..86cf49cb 100644 --- a/test-suite/success/ROmega0.v +++ b/test-suite/success/ROmega0.v @@ -8,16 +8,16 @@ Lemma test_romega_0 : 0<= m <= 1 -> 0<= m' <= 1 -> (0 < m <-> 0 < m') -> m = m'. Proof. intros. -(*romega.*) -Admitted. +romega. +Qed. Lemma test_romega_0b : forall m m', 0<= m <= 1 -> 0<= m' <= 1 -> (0 < m <-> 0 < m') -> m = m'. Proof. intros m m'. -(*romega.*) -Admitted. +romega. +Qed. Lemma test_romega_1 : forall (z z1 z2 : Z), @@ -42,8 +42,8 @@ Lemma test_romega_1b : z >= 0. Proof. intros z z1 z2. -(* romega. *) -Admitted. +romega. +Qed. Lemma test_romega_2 : forall a b c:Z, 0<=a-b<=1 -> b-c<=2 -> a-c<=3. @@ -56,8 +56,8 @@ Lemma test_romega_2b : forall a b c:Z, 0<=a-b<=1 -> b-c<=2 -> a-c<=3. Proof. intros a b c. -(*romega.*) -Admitted. +romega. +Qed. Lemma test_romega_3 : forall a b h hl hr ha hb, 0 <= ha - hl <= 1 -> @@ -115,22 +115,22 @@ Qed. Lemma test_romega_6b : forall z, z>=0 -> 0>z+2 -> False. Proof. intros z. -(*romega. *) -Admitted. +romega. +Qed. Lemma test_romega_7 : forall z, 0>=0 /\ z=0 \/ 0<=0 /\ z =0 -> 1 = z+1. Proof. intros. -(*romega.*) -Admitted. +romega. +Qed. Lemma test_romega_7b : forall z, 0>=0 /\ z=0 \/ 0<=0 /\ z =0 -> 1 = z+1. Proof. intros. -(*romega.*) -Admitted. +romega. +Qed. (* Magaud #240 *) @@ -144,6 +144,9 @@ intros x y. romega. Qed. +(* Besson #1298 *) - - +Lemma test_romega9 : forall z z':Z, z<>z' -> z'=z -> False. +intros. +romega. +Qed. diff --git a/test-suite/success/ROmega2.v b/test-suite/success/ROmega2.v index 9d47c9f6..a3be2898 100644 --- a/test-suite/success/ROmega2.v +++ b/test-suite/success/ROmega2.v @@ -4,6 +4,20 @@ Require Import ZArith ROmega. Open Scope Z_scope. + +(* First a simplified version used during debug of romega on Test46 *) +Lemma Test46_simplified : +forall v1 v2 v5 : Z, +0 = v2 + v5 -> +0 < v5 -> +0 < v2 -> +4*v2 <> 5*v1. +intros. +romega. +Qed. + + +(* The complete problem *) Lemma Test46 : forall v1 v2 v3 v4 v5 : Z, ((2 * v4) + (5)) + (8 * v2) <= ((4 * v4) + (3 * v4)) + (5 * v4) -> @@ -23,6 +37,5 @@ forall v1 v2 v3 v4 v5 : Z, ((7 * v1) + (1 * v3)) + ((2 * v3) + (1 * v3)) >= ((6 * v5) + (4)) + ((1) + (9)) -> False. intros. -(*romega.*) -Admitted. - +romega. +Qed. diff --git a/theories/Arith/Compare_dec.v b/theories/Arith/Compare_dec.v index e6dc7c46..b431fd05 100644 --- a/theories/Arith/Compare_dec.v +++ b/theories/Arith/Compare_dec.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Compare_dec.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Compare_dec.v 9941 2007-07-05 12:42:35Z letouzey $ i*) Require Import Le. Require Import Lt. @@ -34,7 +34,7 @@ Defined. Definition le_lt_dec n m : {n <= m} + {m < n}. induction n. auto with arith. - induction m. + destruct m. auto with arith. elim (IHn m); auto with arith. Defined. diff --git a/theories/Arith/Peano_dec.v b/theories/Arith/Peano_dec.v index b17021bc..9ae80d79 100644 --- a/theories/Arith/Peano_dec.v +++ b/theories/Arith/Peano_dec.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: Peano_dec.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: Peano_dec.v 9941 2007-07-05 12:42:35Z letouzey $ i*) Require Import Decidable. @@ -23,7 +23,7 @@ Defined. Theorem eq_nat_dec : forall n m, {n = m} + {n <> m}. Proof. - induction n; induction m; auto. + induction n; destruct m; auto. elim (IHn m); auto. Defined. diff --git a/theories/FSets/FMapAVL.v b/theories/FSets/FMapAVL.v index 786ade0e..4807ed66 100644 --- a/theories/FSets/FMapAVL.v +++ b/theories/FSets/FMapAVL.v @@ -9,7 +9,7 @@ (* Finite map library. *) -(* $Id: FMapAVL.v 8985 2006-06-23 16:12:45Z jforest $ *) +(* $Id: FMapAVL.v 9862 2007-05-25 16:57:06Z letouzey $ *) (** This module implements map using AVL trees. It follows the implementation from Ocaml's standard library. *) @@ -30,7 +30,7 @@ Module Raw (I:Int)(X: OrderedType). Import I. Module II:=MoreInt(I). Import II. -Open Scope Int_scope. +Open Local Scope Int_scope. Module E := X. Module MX := OrderedTypeFacts X. @@ -1229,7 +1229,7 @@ Proof. apply compare_flatten_1. Qed. -Open Scope Z_scope. +Open Local Scope Z_scope. (** termination of [compare_aux] *) @@ -1967,7 +1967,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: Definition flatten_slist (e:enumeration D.t)(He:sorted_e e) := LO.MapS.Build_slist (sorted_flatten_e He). - Open Scope Z_scope. + Open Local Scope Z_scope. Definition compare_aux : forall (e1 e2:enumeration D.t)(He1:sorted_e e1)(He2: sorted_e e2), diff --git a/theories/FSets/FMapPositive.v b/theories/FSets/FMapPositive.v index 911de00e..44724767 100644 --- a/theories/FSets/FMapPositive.v +++ b/theories/FSets/FMapPositive.v @@ -11,7 +11,7 @@ * Institution: LRI, CNRS UMR 8623 - Université Paris Sud * 91405 Orsay, France *) -(* $Id: FMapPositive.v 9178 2006-09-26 11:18:22Z barras $ *) +(* $Id: FMapPositive.v 9862 2007-05-25 16:57:06Z letouzey $ *) Require Import Bool. Require Import ZArith. @@ -20,7 +20,7 @@ Require Import FMapInterface. Set Implicit Arguments. -Open Scope positive_scope. +Open Local Scope positive_scope. (** * An implementation of [FMapInterface.S] for positive keys. *) diff --git a/theories/FSets/FSetAVL.v b/theories/FSets/FSetAVL.v index 5b09945b..d5ce54d9 100644 --- a/theories/FSets/FSetAVL.v +++ b/theories/FSets/FSetAVL.v @@ -12,7 +12,7 @@ * Institution: LRI, CNRS UMR 8623 - Université Paris Sud * 91405 Orsay, France *) -(* $Id: FSetAVL.v 8985 2006-06-23 16:12:45Z jforest $ *) +(* $Id: FSetAVL.v 9862 2007-05-25 16:57:06Z letouzey $ *) (** This module implements sets using AVL trees. It follows the implementation from Ocaml's standard library. *) @@ -28,7 +28,7 @@ Module Raw (I:Int)(X:OrderedType). Import I. Module II:=MoreInt(I). Import II. -Open Scope Int_scope. +Open Local Scope Int_scope. Module E := X. Module MX := OrderedTypeFacts X. @@ -2286,7 +2286,7 @@ Qed. (** termination of [compare_aux] *) -Open Scope Z_scope. +Open Local Scope Z_scope. Fixpoint measure_e_t (s : tree) : Z := match s with | Leaf => 0 diff --git a/theories/FSets/OrderedTypeEx.v b/theories/FSets/OrderedTypeEx.v index 6fa6a85c..28a5705d 100644 --- a/theories/FSets/OrderedTypeEx.v +++ b/theories/FSets/OrderedTypeEx.v @@ -11,7 +11,7 @@ * Institution: LRI, CNRS UMR 8623 - Université Paris Sud * 91405 Orsay, France *) -(* $Id: OrderedTypeEx.v 9066 2006-08-14 10:11:18Z letouzey $ *) +(* $Id: OrderedTypeEx.v 9940 2007-07-05 12:32:47Z letouzey $ *) Require Import OrderedType. Require Import ZArith. @@ -73,7 +73,7 @@ End Nat_as_OT. (** [Z] is an ordered type with respect to the usual order on integers. *) -Open Scope Z_scope. +Open Local Scope Z_scope. Module Z_as_OT <: UsualOrderedType. @@ -103,7 +103,7 @@ End Z_as_OT. (** [positive] is an ordered type with respect to the usual order on natural numbers. *) -Open Scope positive_scope. +Open Local Scope positive_scope. Module Positive_as_OT <: UsualOrderedType. Definition t:=positive. @@ -138,14 +138,14 @@ Module Positive_as_OT <: UsualOrderedType. apply GT; unfold lt. replace Eq with (CompOpp Eq); auto. rewrite <- Pcompare_antisym; rewrite H; auto. - Qed. + Defined. End Positive_as_OT. (** [N] is an ordered type with respect to the usual order on natural numbers. *) -Open Scope positive_scope. +Open Local Scope positive_scope. Module N_as_OT <: UsualOrderedType. Definition t:=N. diff --git a/theories/QArith/QArith_base.v b/theories/QArith/QArith_base.v index 66d16cfe..fc92c678 100644 --- a/theories/QArith/QArith_base.v +++ b/theories/QArith/QArith_base.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: QArith_base.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: QArith_base.v 9932 2007-07-02 14:31:33Z notin $ i*) Require Export ZArith. Require Export ZArithRing. @@ -38,8 +38,8 @@ Notation " 1 " := (1#1) : Q_scope. Definition Qeq (p q : Q) := (Qnum p * QDen q)%Z = (Qnum q * QDen p)%Z. Definition Qle (x y : Q) := (Qnum x * QDen y <= Qnum y * QDen x)%Z. Definition Qlt (x y : Q) := (Qnum x * QDen y < Qnum y * QDen x)%Z. -Notation Qgt := (fun x y : Q => Qlt y x). -Notation Qge := (fun x y : Q => Qle y x). +Notation Qgt := (fun a b : Q => Qlt b a). +Notation Qge := (fun a b : Q => Qle b a). Infix "==" := Qeq (at level 70, no associativity) : Q_scope. Infix "<" := Qlt : Q_scope. diff --git a/theories/ZArith/ZArith_dec.v b/theories/ZArith/ZArith_dec.v index 84249955..7febbf6a 100644 --- a/theories/ZArith/ZArith_dec.v +++ b/theories/ZArith/ZArith_dec.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ZArith_dec.v 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: ZArith_dec.v 9958 2007-07-06 22:47:40Z letouzey $ i*) Require Import Sumbool. @@ -94,7 +94,7 @@ Section decidability. elim Z_lt_ge_dec. intros; left; assumption. intros; right; apply Zge_le; assumption. - Qed. + Defined. Definition Z_le_gt_dec : {x <= y} + {x > y}. Proof. diff --git a/tools/coqdep.ml b/tools/coqdep.ml index 3647152a..89f39b22 100644 --- a/tools/coqdep.ml +++ b/tools/coqdep.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: coqdep.ml 9276 2006-10-25 13:00:22Z barras $ *) +(* $Id: coqdep.ml 9808 2007-04-29 07:15:18Z herbelin $ *) open Printf open Coqdep_lexer @@ -24,6 +24,8 @@ let option_i = ref false let option_sort = ref false let option_slash = ref false +let directories_added = ref false + let suffixe = ref ".vo" let suffixe_spec = ref ".vi" @@ -42,7 +44,7 @@ let file_concat l = (* Files specified on the command line *) let mlAccu = ref ([] : (string * string * dir) list) and mliAccu = ref ([] : (string * string * dir) list) -and vAccu = ref ([] : string list) +and vAccu = ref ([] : (string * string) list) (* Queue operations *) let addQueue q v = q := v :: !q @@ -97,6 +99,16 @@ let safe_assoc verbose file k = List.assoc k !vKnown +let absolute_dir dir = + let current = Sys.getcwd () in + Sys.chdir dir; + let dir' = Sys.getcwd () in + Sys.chdir current; + dir' + +let absolute_file_name basename odir = + let dir = match odir with Some dir -> dir | None -> "." in + absolute_dir dir / basename let file_name = function | (s,None) -> file_concat s @@ -152,9 +164,11 @@ let cut_prefix p s = let ls = String.length s in if ls >= lp && String.sub s 0 lp = p then String.sub s lp (ls - lp) else s -let canonize f = match Sys.os_type with - | "Win32" when not !option_slash -> cut_prefix ".\\" f - | _ -> cut_prefix "./" f +let canonize f = + let f' = absolute_dir (Filename.dirname f) / Filename.basename f in + match List.filter (fun (_,full) -> f' = full) !vAccu with + | (f,_) :: _ -> f + | _ -> f let sort () = let seen = Hashtbl.create 97 in @@ -181,7 +195,7 @@ let sort () = printf "%s%s " file !suffixe end in - List.iter loop !vAccu + List.iter (fun (name,_) -> loop name) !vAccu let traite_fichier_Coq verbose f = try @@ -352,7 +366,7 @@ let mL_dependencies () = let coq_dependencies () = List.iter - (fun name -> + (fun (name,_) -> printf "%s%s: %s.v" name !suffixe name; traite_fichier_Coq true (name ^ ".v"); printf "\n"; @@ -366,7 +380,7 @@ let coq_dependencies () = let declare_dependencies () = List.iter - (fun name -> + (fun (name,_) -> traite_Declare (name^".v"); flush stdout) (List.rev !vAccu) @@ -410,7 +424,7 @@ let all_subdirs root_dir log_dir = let usage () = eprintf - "[ usage: coqdep [-w] [-I dir] [-coqlib dir] [-c] [-i] [-D] <filename>+ ]\n"; + "[ usage: coqdep [-w] [-I dir] [-R dir coqdir] [-coqlib dir] [-c] [-i] [-D] <filename>+ ]\n"; flush stderr; exit 1 @@ -471,7 +485,8 @@ let coqdep () = addQueue mliAccu (basename,".mli",dirname) else if Filename.check_suffix name ".v" then let basename = Filename.chop_suffix name ".v" in - addQueue vAccu (file_name ([basename], dirname)) + let name = file_name ([basename],dirname) in + addQueue vAccu (name, absolute_file_name basename dirname) | _ -> () in let add_known phys_dir log_dir f = @@ -496,6 +511,7 @@ let coqdep () = (fun n -> safe_addQueue clash_v vKnown (n,file)) paths | _ -> () in let add_directory (phys_dir, log_dir) = + directories_added := true; match try (stat phys_dir).st_kind with _ -> S_BLK with | S_DIR -> (let dir = opendir phys_dir in @@ -526,7 +542,7 @@ let coqdep () = | f :: ll -> treat None f; parse ll | [] -> () in - add_directory (".", []); + if not !directories_added then add_directory (".", []); parse (List.tl (Array.to_list Sys.argv)); List.iter (fun (s,_) -> add_coqlib_directory s) diff --git a/tools/coqdoc/output.ml b/tools/coqdoc/output.ml index 84e03d92..28a0cd6d 100644 --- a/tools/coqdoc/output.ml +++ b/tools/coqdoc/output.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: output.ml 9245 2006-10-17 12:53:34Z notin $ i*) +(*i $Id: output.ml 9976 2007-07-12 11:58:30Z msozeau $ i*) open Cdglobals open Index @@ -40,15 +40,14 @@ let is_keyword = "Module"; "Module Type"; "Declare Module"; "Mutual"; "Parameter"; "Parameters"; "Print"; "Proof"; "Qed"; "Record"; "Recursive"; "Remark"; "Require"; "Save"; "Scheme"; - "Section"; "Show"; "Syntactic"; "Syntax"; "Tactic"; "Theorem"; + "Section"; "Show"; "Structure"; "Syntactic"; "Syntax"; "Tactic"; "Theorem"; "Unset"; "Variable"; "Variables"; "Notation"; - (*i (* correctness *) - "array"; "assert"; "begin"; "do"; "done"; "else"; "end"; "if"; - "in"; "invariant"; "let"; "of"; "ref"; "state"; "then"; "variant"; - "while"; i*) - (*i (* coq terms *) - "with"; "Case"; "Cases"; "Prop"; "Set"; "Type"; i*) + (* Program *) + "Program Definition"; "Program Fixpoint"; "Program Lemma"; + "Obligation"; "Obligations"; "Solve"; "using"; "Next Obligation"; "Next"; + (*i (* coq terms *) *) + "match"; "as"; "in"; "return"; "with"; "end"; "let"; "dest"; "fun"; "if"; "then"; "else"; "Prop"; "Set"; "Type"; ":=" ] (*s Current Coq module *) diff --git a/tools/coqdoc/pretty.mll b/tools/coqdoc/pretty.mll index bdb58f86..c63a6a9b 100644 --- a/tools/coqdoc/pretty.mll +++ b/tools/coqdoc/pretty.mll @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: pretty.mll 9204 2006-10-04 13:05:58Z notin $ i*) +(*i $Id: pretty.mll 10017 2007-07-18 13:23:55Z notin $ i*) (*s Utility functions for the scanners *) @@ -212,6 +212,8 @@ let def_token = | "Scheme" | "Inductive" | "CoInductive" + | "Program" space+ "Definition" + | "Program" space+ "Fixpoint" let decl_token = "Hypothesis" @@ -455,11 +457,11 @@ and doc = parse start_inline_coq (); escaped_coq lexbuf; end_inline_coq (); doc lexbuf } | "[[" '\n' space* - { formatted := true; start_code (); + { formatted := true; line_break (); start_inline_coq (); indentation (count_spaces (lexeme lexbuf)); - without_gallina coq lexbuf; - end_code (); formatted := false; - doc lexbuf } + let eol = body_bol lexbuf in + end_inline_coq (); formatted := false; + if eol then doc_bol lexbuf else doc lexbuf} | '*'* "*)" space* '\n' { true } | '*'* "*)" @@ -570,6 +572,8 @@ and body_bol = parse and body = parse | '\n' {line_break(); body_bol lexbuf} + | '\n'+ space* "]]" + { if not !formatted then begin symbol (lexeme lexbuf); body lexbuf end else true } | eof { false } | '.' space* '\n' | '.' space* eof { char '.'; line_break(); true } | '.' space+ { char '.'; char ' '; false } @@ -577,12 +581,14 @@ and body = parse if eol then body_bol lexbuf else body lexbuf } | identifier { let s = lexeme lexbuf in - ident s (lexeme_start lexbuf); body lexbuf } + ident s (lexeme_start lexbuf); + body lexbuf } | token { let s = lexeme lexbuf in symbol s; body lexbuf } | _ { let c = lexeme_char lexbuf 0 in - char c; body lexbuf } + char c; + body lexbuf } and skip_hide = parse | eof | end_hide { () } diff --git a/tools/coqwc.mll b/tools/coqwc.mll index 26b64095..0ce172ea 100644 --- a/tools/coqwc.mll +++ b/tools/coqwc.mll @@ -9,7 +9,7 @@ (* coqwc - counts the lines of spec, proof and comments in Coq sources * Copyright (C) 2003 Jean-Christophe Filliâtre *) -(*i $Id: coqwc.mll 7095 2005-05-31 15:05:23Z filliatr $ i*) +(*i $Id: coqwc.mll 9976 2007-07-12 11:58:30Z msozeau $ i*) (*s {\bf coqwc.} Counts the lines of spec, proof and comments in a Coq source. It assumes the files to be lexically well-formed. *) @@ -97,7 +97,7 @@ let rcs = "\036" rcs_keyword [^ '$']* "\036" let stars = "(*" '*'* "*)" let dot = '.' (' ' | '\t' | '\n' | '\r' | eof) let proof_start = - "Theorem" | "Lemma" | "Fact" | "Remark" | "Goal" | "Correctness" + "Theorem" | "Lemma" | "Fact" | "Remark" | "Goal" | "Correctness" | "Obligation" | "Next" let proof_end = ("Save" | "Qed" | "Defined" | "Abort" | "Admitted") [^'.']* '.' @@ -114,8 +114,10 @@ rule spec = parse { seen_spec := true; spec_to_dot lexbuf; proof lexbuf } | proof_start '\n' { seen_spec := true; newline (); spec_to_dot lexbuf; proof lexbuf } - | "Definition" space + | "Program"? "Definition" space { seen_spec := true; definition lexbuf } + | "Program"? "Fixpoint" space + { seen_spec := true; definition lexbuf } | character | _ { seen_spec := true; spec lexbuf } | eof { () } diff --git a/toplevel/command.ml b/toplevel/command.ml index 9ef782ff..a1860329 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: command.ml 9617 2007-02-07 18:59:26Z herbelin $ *) +(* $Id: command.ml 9976 2007-07-12 11:58:30Z msozeau $ *) open Pp open Util @@ -111,7 +111,7 @@ let constant_entry_of_com (bl,com,comtypopt,opacity,boxed) = | Some comtyp -> (* We use a cast to avoid troubles with evars in comtyp *) (* that can only be resolved knowing com *) - let b = abstract_constr_expr (mkCastC (com, Rawterm.CastConv DEFAULTcast,comtyp)) bl in + let b = abstract_constr_expr (mkCastC (com, Rawterm.CastConv (DEFAULTcast,comtyp))) bl in let (body,typ) = destSubCast (interp_constr sigma env b) in { const_entry_body = body; const_entry_type = Some typ; @@ -699,8 +699,8 @@ let save id const (locality,kind) hook = let kn = declare_constant id (DefinitionEntry const, k) in (Global, ConstRef kn) in Pfedit.delete_current_proof (); - hook l r; - definition_message id + definition_message id; + hook l r let save_named opacity = let id,(const,persistence,hook) = Pfedit.cook_proof () in @@ -736,8 +736,8 @@ let admit () = let kn = declare_constant id (ParameterEntry typ, IsAssumption Conjectural) in Pfedit.delete_current_proof (); - hook Global (ConstRef kn); - assumption_message id + assumption_message id; + hook Global (ConstRef kn) let get_current_context () = try Pfedit.get_current_goal_context () diff --git a/toplevel/command.mli b/toplevel/command.mli index 6f9a55c3..e043f354 100644 --- a/toplevel/command.mli +++ b/toplevel/command.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: command.mli 9110 2006-09-01 12:30:52Z herbelin $ i*) +(*i $Id: command.mli 9976 2007-07-12 11:58:30Z msozeau $ i*) (*i*) open Util @@ -36,6 +36,9 @@ val declare_definition : identifier -> definition_kind -> val syntax_definition : identifier -> constr_expr -> bool -> bool -> unit +val declare_one_assumption : coercion_flag -> assumption_kind -> Term.types -> + Names.variable located -> unit + val declare_assumption : identifier located list -> coercion_flag -> assumption_kind -> local_binder list -> constr_expr -> unit @@ -52,6 +55,8 @@ val build_scheme : (identifier located * bool * reference * rawsort) list -> uni val generalize_constr_expr : constr_expr -> local_binder list -> constr_expr +val abstract_constr_expr : constr_expr -> local_binder list -> constr_expr + val start_proof : identifier -> goal_kind -> constr -> declaration_hook -> unit diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml index dc2cc8cd..1809baa5 100644 --- a/toplevel/himsg.ml +++ b/toplevel/himsg.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: himsg.ml 9528 2007-01-24 09:43:03Z herbelin $ *) +(* $Id: himsg.ml 9976 2007-07-12 11:58:30Z msozeau $ *) open Pp open Util @@ -331,7 +331,7 @@ let explain_occur_check ctx ev rhs = str" with term" ++ brk(1,1) ++ pt let explain_hole_kind env = function - | QuestionMark -> str "a term for this placeholder" + | QuestionMark _ -> str "a term for this placeholder" | CasesType -> str "the type of this pattern-matching problem" | BinderType (Name id) -> @@ -352,9 +352,8 @@ let explain_hole_kind env = function let explain_not_clean ctx ev t k = let ctx = make_all_name_different ctx in - let c = mkRel (Intset.choose (free_rels t)) in let id = Evd.string_of_existential ev in - let var = pr_lconstr_env ctx c in + let var = pr_lconstr_env ctx t in str"Tried to define " ++ explain_hole_kind ctx k ++ str" (" ++ str id ++ str ")" ++ spc() ++ str"with a term using variable " ++ var ++ spc () ++ @@ -381,15 +380,15 @@ let explain_wrong_case_info ctx ind ci = spc () ++ pc -let explain_cannot_unify m n = - let pm = pr_lconstr m in - let pn = pr_lconstr n in +let explain_cannot_unify ctx m n = + let pm = pr_lconstr_env ctx m in + let pn = pr_lconstr_env ctx n in str"Impossible to unify" ++ brk(1,1) ++ pm ++ spc () ++ str"with" ++ brk(1,1) ++ pn let explain_cannot_unify_local env m n subn = - let pm = pr_lconstr m in - let pn = pr_lconstr n in + let pm = pr_lconstr_env env m in + let pn = pr_lconstr_env env n in let psubn = pr_lconstr_env env subn in str"Impossible to unify" ++ brk(1,1) ++ pm ++ spc () ++ str"with" ++ brk(1,1) ++ pn ++ spc() ++ str"as" ++ brk(1,1) ++ @@ -402,9 +401,9 @@ let explain_refiner_cannot_generalize ty = let explain_no_occurrence_found c = str "Found no subterm matching " ++ pr_lconstr c ++ str " in the current goal" -let explain_cannot_unify_binding_type m n = - let pm = pr_lconstr m in - let pn = pr_lconstr n in +let explain_cannot_unify_binding_type ctx m n = + let pm = pr_lconstr_env ctx m in + let pn = pr_lconstr_env ctx n in str "This binding has type" ++ brk(1,1) ++ pm ++ spc () ++ str "which should be unifiable with" ++ brk(1,1) ++ pn @@ -464,11 +463,11 @@ let explain_pretype_error ctx err = explain_unexpected_type ctx actual expected | NotProduct c -> explain_not_product ctx c - | CannotUnify (m,n) -> explain_cannot_unify m n + | CannotUnify (m,n) -> explain_cannot_unify ctx m n | CannotUnifyLocal (e,m,n,sn) -> explain_cannot_unify_local e m n sn | CannotGeneralize ty -> explain_refiner_cannot_generalize ty | NoOccurrenceFound c -> explain_no_occurrence_found c - | CannotUnifyBindingType (m,n) -> explain_cannot_unify_binding_type m n + | CannotUnifyBindingType (m,n) -> explain_cannot_unify_binding_type ctx m n (* Refiner errors *) diff --git a/toplevel/record.ml b/toplevel/record.ml index bf0271d9..ab430d0c 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: record.ml 9082 2006-08-24 17:03:28Z herbelin $ *) +(* $Id: record.ml 9976 2007-07-12 11:58:30Z msozeau $ *) open Pp open Util @@ -36,10 +36,10 @@ let interp_decl sigma env = function | Vernacexpr.DefExpr((_,id),c,t) -> let c = match t with | None -> c - | Some t -> mkCastC (c, Rawterm.CastConv DEFAULTcast,t) + | Some t -> mkCastC (c, Rawterm.CastConv (DEFAULTcast,t)) in let j = interp_constr_judgment Evd.empty env c in - (id,Some j.uj_val, j.uj_type) + (id,Some j.uj_val, refresh_universes j.uj_type) let typecheck_params_and_fields ps fs = let env0 = Global.env () in diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 248e0106..fb719a21 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: vernacentries.ml 9481 2007-01-11 19:17:56Z herbelin $ i*) +(*i $Id: vernacentries.ml 9874 2007-06-04 13:46:11Z soubiran $ i*) (* Concrete syntax of the mathematical vernacular MV V2.6 *) @@ -395,7 +395,7 @@ let vernac_define_module export id binders_ast mty_ast_o mexpr_ast_o = let binders_ast,argsexport = List.fold_right (fun (export,idl,ty) (args,argsexport) -> - (idl,ty)::args, List.map (fun (_,i) -> export,i) idl) binders_ast + (idl,ty)::args, (List.map (fun (_,i) -> export,i)idl)@argsexport) binders_ast ([],[]) in Declaremods.start_module Modintern.interp_modtype export id binders_ast mty_ast_o; diff --git a/toplevel/whelp.ml4 b/toplevel/whelp.ml4 index 042ee5c8..0e17df28 100644 --- a/toplevel/whelp.ml4 +++ b/toplevel/whelp.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: whelp.ml4 7837 2006-01-11 09:47:32Z herbelin $ *) +(* $Id: whelp.ml4 9976 2007-07-12 11:58:30Z msozeau $ *) open Options open Pp @@ -139,11 +139,11 @@ let rec uri_of_constr c = | RLetIn (_,na,b,c) -> url_string "let "; url_of_name na; url_string "\\def "; uri_of_constr b; url_string " in "; uri_of_constr c - | RCast (_,c,_,t) -> + | RCast (_,c, CastConv (_,t)) -> uri_of_constr c; url_string ":"; uri_of_constr t | RRec _ | RIf _ | RLetTuple _ | RCases _ -> error "Whelp does not support pattern-matching and (co-)fixpoint" - | RVar _ | RRef _ | RHole _ | REvar _ | RSort _ -> + | RVar _ | RRef _ | RHole _ | REvar _ | RSort _ | RCast (_,_, CastCoerce) -> anomaly "Written w/o parenthesis" | RPatVar _ | RDynamic _ -> anomaly "Found constructors not supported in constr") () |