diff options
61 files changed, 3352 insertions, 2908 deletions
@@ -1,13 +1,12 @@ kernel/abstraction.cmi: kernel/names.cmi kernel/term.cmi -kernel/closure.cmi: kernel/environ.cmi kernel/evd.cmi kernel/generic.cmi \ - kernel/names.cmi lib/pp.cmi kernel/term.cmi +kernel/closure.cmi: kernel/environ.cmi kernel/evd.cmi kernel/names.cmi \ + lib/pp.cmi kernel/term.cmi kernel/declarations.cmi: kernel/names.cmi kernel/sign.cmi kernel/term.cmi \ kernel/univ.cmi kernel/environ.cmi: kernel/abstraction.cmi kernel/declarations.cmi \ kernel/names.cmi kernel/sign.cmi kernel/term.cmi kernel/univ.cmi kernel/evd.cmi: kernel/environ.cmi kernel/names.cmi kernel/sign.cmi \ kernel/term.cmi -kernel/generic.cmi: kernel/names.cmi lib/util.cmi kernel/indtypes.cmi: kernel/declarations.cmi kernel/environ.cmi \ kernel/names.cmi kernel/sign.cmi kernel/term.cmi kernel/univ.cmi kernel/inductive.cmi: kernel/declarations.cmi kernel/environ.cmi \ @@ -17,15 +16,13 @@ kernel/instantiate.cmi: kernel/environ.cmi kernel/evd.cmi kernel/names.cmi \ kernel/sign.cmi kernel/term.cmi kernel/names.cmi: lib/pp.cmi kernel/reduction.cmi: kernel/closure.cmi kernel/environ.cmi kernel/evd.cmi \ - kernel/generic.cmi kernel/names.cmi kernel/sign.cmi kernel/term.cmi \ - kernel/univ.cmi + kernel/names.cmi kernel/sign.cmi kernel/term.cmi kernel/univ.cmi kernel/safe_typing.cmi: kernel/declarations.cmi kernel/environ.cmi \ kernel/inductive.cmi kernel/names.cmi lib/pp.cmi kernel/sign.cmi \ kernel/term.cmi kernel/typeops.cmi kernel/univ.cmi -kernel/sign.cmi: kernel/generic.cmi kernel/names.cmi kernel/term.cmi +kernel/sign.cmi: kernel/names.cmi kernel/term.cmi kernel/sosub.cmi: kernel/term.cmi -kernel/term.cmi: kernel/generic.cmi kernel/names.cmi lib/pp.cmi \ - kernel/univ.cmi +kernel/term.cmi: kernel/names.cmi lib/pp.cmi kernel/univ.cmi lib/util.cmi kernel/type_errors.cmi: kernel/environ.cmi kernel/evd.cmi kernel/names.cmi \ lib/pp.cmi kernel/sign.cmi kernel/term.cmi kernel/typeops.cmi: kernel/environ.cmi kernel/evd.cmi kernel/inductive.cmi \ @@ -37,7 +34,7 @@ library/declare.cmi: kernel/declarations.cmi kernel/environ.cmi \ library/global.cmi: kernel/declarations.cmi kernel/environ.cmi \ kernel/inductive.cmi kernel/names.cmi kernel/safe_typing.cmi \ kernel/sign.cmi kernel/term.cmi kernel/univ.cmi -library/goptions.cmi: kernel/names.cmi +library/goptions.cmi: kernel/names.cmi lib/pp.cmi library/impargs.cmi: kernel/inductive.cmi kernel/names.cmi kernel/term.cmi library/indrec.cmi: kernel/declarations.cmi kernel/environ.cmi kernel/evd.cmi \ kernel/inductive.cmi kernel/names.cmi kernel/term.cmi @@ -100,9 +97,8 @@ pretyping/pretyping.cmi: kernel/environ.cmi pretyping/evarutil.cmi \ kernel/evd.cmi kernel/names.cmi pretyping/rawterm.cmi kernel/sign.cmi \ kernel/term.cmi pretyping/rawterm.cmi: kernel/names.cmi kernel/sign.cmi kernel/term.cmi -pretyping/recordops.cmi: pretyping/classops.cmi kernel/generic.cmi \ - library/libobject.cmi library/library.cmi kernel/names.cmi \ - kernel/term.cmi +pretyping/recordops.cmi: pretyping/classops.cmi library/libobject.cmi \ + library/library.cmi kernel/names.cmi kernel/term.cmi pretyping/retyping.cmi: kernel/environ.cmi kernel/evd.cmi kernel/names.cmi \ kernel/term.cmi pretyping/syntax_def.cmi: kernel/names.cmi pretyping/rawterm.cmi @@ -141,7 +137,7 @@ tactics/auto.cmi: tactics/btermdn.cmi proofs/clenv.cmi parsing/coqast.cmi \ kernel/names.cmi parsing/pattern.cmi proofs/proof_type.cmi \ pretyping/rawterm.cmi kernel/sign.cmi proofs/tacmach.cmi kernel/term.cmi \ lib/util.cmi -tactics/btermdn.cmi: kernel/generic.cmi parsing/pattern.cmi kernel/term.cmi +tactics/btermdn.cmi: parsing/pattern.cmi kernel/term.cmi tactics/dhyp.cmi: kernel/names.cmi proofs/tacmach.cmi tactics/elim.cmi: kernel/names.cmi proofs/proof_type.cmi proofs/tacmach.cmi \ tactics/tacticals.cmi kernel/term.cmi @@ -156,8 +152,7 @@ tactics/hipattern.cmi: kernel/evd.cmi kernel/names.cmi parsing/pattern.cmi \ proofs/proof_trees.cmi kernel/sign.cmi proofs/stock.cmi kernel/term.cmi \ lib/util.cmi tactics/inv.cmi: parsing/coqast.cmi kernel/names.cmi proofs/tacmach.cmi -tactics/nbtermdn.cmi: tactics/btermdn.cmi kernel/generic.cmi \ - parsing/pattern.cmi kernel/term.cmi +tactics/nbtermdn.cmi: tactics/btermdn.cmi parsing/pattern.cmi kernel/term.cmi tactics/refine.cmi: proofs/tacmach.cmi kernel/term.cmi tactics/tacentries.cmi: proofs/proof_type.cmi proofs/tacmach.cmi tactics/tacticals.cmi: proofs/clenv.cmi parsing/coqast.cmi kernel/names.cmi \ @@ -168,7 +163,7 @@ tactics/tactics.cmi: proofs/clenv.cmi kernel/environ.cmi kernel/evd.cmi \ proofs/tacmach.cmi pretyping/tacred.cmi tactics/tacticals.cmi \ kernel/term.cmi tactics/tauto.cmi: proofs/tacmach.cmi kernel/term.cmi -tactics/termdn.cmi: kernel/generic.cmi parsing/pattern.cmi kernel/term.cmi +tactics/termdn.cmi: parsing/pattern.cmi kernel/term.cmi tactics/wcclausenv.cmi: proofs/clenv.cmi kernel/environ.cmi kernel/evd.cmi \ kernel/names.cmi proofs/proof_type.cmi kernel/sign.cmi proofs/tacmach.cmi \ kernel/term.cmi @@ -197,101 +192,95 @@ config/coq_config.cmx: config/coq_config.cmi dev/db_printers.cmo: kernel/names.cmi lib/pp.cmi dev/db_printers.cmx: kernel/names.cmx lib/pp.cmx dev/top_printers.cmo: parsing/ast.cmi parsing/astterm.cmi proofs/clenv.cmi \ - toplevel/command.cmi kernel/environ.cmi kernel/evd.cmi kernel/generic.cmi \ - kernel/names.cmi lib/pp.cmi parsing/printer.cmi proofs/proof_trees.cmi \ - proofs/refiner.cmi kernel/sign.cmi lib/system.cmi proofs/tacmach.cmi \ - kernel/term.cmi parsing/termast.cmi kernel/univ.cmi \ - toplevel/vernacentries.cmi toplevel/vernacinterp.cmi + toplevel/command.cmi kernel/environ.cmi kernel/evd.cmi kernel/names.cmi \ + lib/pp.cmi parsing/printer.cmi proofs/proof_trees.cmi proofs/refiner.cmi \ + kernel/sign.cmi lib/system.cmi proofs/tacmach.cmi kernel/term.cmi \ + parsing/termast.cmi kernel/univ.cmi toplevel/vernacentries.cmi \ + toplevel/vernacinterp.cmi dev/top_printers.cmx: parsing/ast.cmx parsing/astterm.cmx proofs/clenv.cmx \ - toplevel/command.cmx kernel/environ.cmx kernel/evd.cmx kernel/generic.cmx \ - kernel/names.cmx lib/pp.cmx parsing/printer.cmx proofs/proof_trees.cmx \ - proofs/refiner.cmx kernel/sign.cmx lib/system.cmx proofs/tacmach.cmx \ - kernel/term.cmx parsing/termast.cmx kernel/univ.cmx \ - toplevel/vernacentries.cmx toplevel/vernacinterp.cmx -kernel/abstraction.cmo: kernel/generic.cmi kernel/names.cmi kernel/sosub.cmi \ - kernel/term.cmi lib/util.cmi kernel/abstraction.cmi -kernel/abstraction.cmx: kernel/generic.cmx kernel/names.cmx kernel/sosub.cmx \ - kernel/term.cmx lib/util.cmx kernel/abstraction.cmi + toplevel/command.cmx kernel/environ.cmx kernel/evd.cmx kernel/names.cmx \ + lib/pp.cmx parsing/printer.cmx proofs/proof_trees.cmx proofs/refiner.cmx \ + kernel/sign.cmx lib/system.cmx proofs/tacmach.cmx kernel/term.cmx \ + parsing/termast.cmx kernel/univ.cmx toplevel/vernacentries.cmx \ + toplevel/vernacinterp.cmx +kernel/abstraction.cmo: kernel/names.cmi kernel/sosub.cmi kernel/term.cmi \ + lib/util.cmi kernel/abstraction.cmi +kernel/abstraction.cmx: kernel/names.cmx kernel/sosub.cmx kernel/term.cmx \ + lib/util.cmx kernel/abstraction.cmi kernel/closure.cmo: kernel/declarations.cmi kernel/environ.cmi kernel/evd.cmi \ - kernel/generic.cmi kernel/instantiate.cmi kernel/names.cmi lib/pp.cmi \ - kernel/term.cmi kernel/univ.cmi lib/util.cmi kernel/closure.cmi + kernel/instantiate.cmi kernel/names.cmi lib/pp.cmi kernel/term.cmi \ + kernel/univ.cmi lib/util.cmi kernel/closure.cmi kernel/closure.cmx: kernel/declarations.cmx kernel/environ.cmx kernel/evd.cmx \ - kernel/generic.cmx kernel/instantiate.cmx kernel/names.cmx lib/pp.cmx \ - kernel/term.cmx kernel/univ.cmx lib/util.cmx kernel/closure.cmi -kernel/declarations.cmo: kernel/generic.cmi kernel/names.cmi kernel/sign.cmi \ - kernel/term.cmi kernel/univ.cmi kernel/declarations.cmi -kernel/declarations.cmx: kernel/generic.cmx kernel/names.cmx kernel/sign.cmx \ - kernel/term.cmx kernel/univ.cmx kernel/declarations.cmi + kernel/instantiate.cmx kernel/names.cmx lib/pp.cmx kernel/term.cmx \ + kernel/univ.cmx lib/util.cmx kernel/closure.cmi +kernel/declarations.cmo: kernel/names.cmi kernel/sign.cmi kernel/term.cmi \ + kernel/univ.cmi kernel/declarations.cmi +kernel/declarations.cmx: kernel/names.cmx kernel/sign.cmx kernel/term.cmx \ + kernel/univ.cmx kernel/declarations.cmi kernel/environ.cmo: kernel/abstraction.cmi kernel/declarations.cmi \ - kernel/generic.cmi kernel/names.cmi lib/pp.cmi kernel/sign.cmi \ - kernel/term.cmi kernel/univ.cmi lib/util.cmi kernel/environ.cmi + kernel/names.cmi lib/pp.cmi kernel/sign.cmi kernel/term.cmi \ + kernel/univ.cmi lib/util.cmi kernel/environ.cmi kernel/environ.cmx: kernel/abstraction.cmx kernel/declarations.cmx \ - kernel/generic.cmx kernel/names.cmx lib/pp.cmx kernel/sign.cmx \ - kernel/term.cmx kernel/univ.cmx lib/util.cmx kernel/environ.cmi + kernel/names.cmx lib/pp.cmx kernel/sign.cmx kernel/term.cmx \ + kernel/univ.cmx lib/util.cmx kernel/environ.cmi kernel/evd.cmo: kernel/environ.cmi kernel/names.cmi kernel/sign.cmi \ kernel/term.cmi lib/util.cmi kernel/evd.cmi kernel/evd.cmx: kernel/environ.cmx kernel/names.cmx kernel/sign.cmx \ kernel/term.cmx lib/util.cmx kernel/evd.cmi -kernel/generic.cmo: kernel/names.cmi lib/pp.cmi lib/util.cmi \ - kernel/generic.cmi -kernel/generic.cmx: kernel/names.cmx lib/pp.cmx lib/util.cmx \ - kernel/generic.cmi kernel/indtypes.cmo: kernel/declarations.cmi kernel/environ.cmi \ - kernel/evd.cmi kernel/generic.cmi kernel/inductive.cmi \ - kernel/instantiate.cmi kernel/names.cmi kernel/reduction.cmi \ - kernel/sign.cmi kernel/term.cmi kernel/typeops.cmi lib/util.cmi \ - kernel/indtypes.cmi + kernel/evd.cmi kernel/inductive.cmi kernel/instantiate.cmi \ + kernel/names.cmi kernel/reduction.cmi kernel/sign.cmi kernel/term.cmi \ + kernel/typeops.cmi lib/util.cmi kernel/indtypes.cmi kernel/indtypes.cmx: kernel/declarations.cmx kernel/environ.cmx \ - kernel/evd.cmx kernel/generic.cmx kernel/inductive.cmx \ - kernel/instantiate.cmx kernel/names.cmx kernel/reduction.cmx \ - kernel/sign.cmx kernel/term.cmx kernel/typeops.cmx lib/util.cmx \ - kernel/indtypes.cmi + kernel/evd.cmx kernel/inductive.cmx kernel/instantiate.cmx \ + kernel/names.cmx kernel/reduction.cmx kernel/sign.cmx kernel/term.cmx \ + kernel/typeops.cmx lib/util.cmx kernel/indtypes.cmi kernel/inductive.cmo: kernel/declarations.cmi kernel/environ.cmi \ - kernel/generic.cmi kernel/instantiate.cmi kernel/names.cmi \ - kernel/reduction.cmi kernel/sign.cmi kernel/term.cmi kernel/univ.cmi \ - lib/util.cmi kernel/inductive.cmi + kernel/instantiate.cmi kernel/names.cmi kernel/reduction.cmi \ + kernel/sign.cmi kernel/term.cmi kernel/univ.cmi lib/util.cmi \ + kernel/inductive.cmi kernel/inductive.cmx: kernel/declarations.cmx kernel/environ.cmx \ - kernel/generic.cmx kernel/instantiate.cmx kernel/names.cmx \ - kernel/reduction.cmx kernel/sign.cmx kernel/term.cmx kernel/univ.cmx \ - lib/util.cmx kernel/inductive.cmi + kernel/instantiate.cmx kernel/names.cmx kernel/reduction.cmx \ + kernel/sign.cmx kernel/term.cmx kernel/univ.cmx lib/util.cmx \ + kernel/inductive.cmi kernel/instantiate.cmo: kernel/declarations.cmi kernel/environ.cmi \ - kernel/evd.cmi kernel/generic.cmi kernel/names.cmi lib/pp.cmi \ - kernel/sign.cmi kernel/term.cmi lib/util.cmi kernel/instantiate.cmi + kernel/evd.cmi kernel/names.cmi lib/pp.cmi kernel/sign.cmi \ + kernel/term.cmi lib/util.cmi kernel/instantiate.cmi kernel/instantiate.cmx: kernel/declarations.cmx kernel/environ.cmx \ - kernel/evd.cmx kernel/generic.cmx kernel/names.cmx lib/pp.cmx \ - kernel/sign.cmx kernel/term.cmx lib/util.cmx kernel/instantiate.cmi + kernel/evd.cmx kernel/names.cmx lib/pp.cmx kernel/sign.cmx \ + kernel/term.cmx lib/util.cmx kernel/instantiate.cmi kernel/names.cmo: lib/hashcons.cmi lib/pp.cmi lib/util.cmi kernel/names.cmi kernel/names.cmx: lib/hashcons.cmx lib/pp.cmx lib/util.cmx kernel/names.cmi kernel/reduction.cmo: kernel/closure.cmi kernel/declarations.cmi \ - kernel/environ.cmi kernel/evd.cmi kernel/generic.cmi \ - kernel/instantiate.cmi kernel/names.cmi lib/pp.cmi kernel/sign.cmi \ - kernel/term.cmi kernel/univ.cmi lib/util.cmi kernel/reduction.cmi + kernel/environ.cmi kernel/evd.cmi kernel/instantiate.cmi kernel/names.cmi \ + lib/pp.cmi kernel/sign.cmi kernel/term.cmi kernel/univ.cmi lib/util.cmi \ + kernel/reduction.cmi kernel/reduction.cmx: kernel/closure.cmx kernel/declarations.cmx \ - kernel/environ.cmx kernel/evd.cmx kernel/generic.cmx \ - kernel/instantiate.cmx kernel/names.cmx lib/pp.cmx kernel/sign.cmx \ - kernel/term.cmx kernel/univ.cmx lib/util.cmx kernel/reduction.cmi + kernel/environ.cmx kernel/evd.cmx kernel/instantiate.cmx kernel/names.cmx \ + lib/pp.cmx kernel/sign.cmx kernel/term.cmx kernel/univ.cmx lib/util.cmx \ + kernel/reduction.cmi kernel/safe_typing.cmo: kernel/declarations.cmi kernel/environ.cmi \ - kernel/evd.cmi kernel/generic.cmi kernel/indtypes.cmi \ - kernel/inductive.cmi kernel/names.cmi lib/pp.cmi kernel/reduction.cmi \ - kernel/sign.cmi kernel/term.cmi kernel/type_errors.cmi kernel/typeops.cmi \ - kernel/univ.cmi lib/util.cmi kernel/safe_typing.cmi + kernel/evd.cmi kernel/indtypes.cmi kernel/inductive.cmi kernel/names.cmi \ + lib/pp.cmi kernel/reduction.cmi kernel/sign.cmi kernel/term.cmi \ + kernel/type_errors.cmi kernel/typeops.cmi kernel/univ.cmi lib/util.cmi \ + kernel/safe_typing.cmi kernel/safe_typing.cmx: kernel/declarations.cmx kernel/environ.cmx \ - kernel/evd.cmx kernel/generic.cmx kernel/indtypes.cmx \ - kernel/inductive.cmx kernel/names.cmx lib/pp.cmx kernel/reduction.cmx \ - kernel/sign.cmx kernel/term.cmx kernel/type_errors.cmx kernel/typeops.cmx \ - kernel/univ.cmx lib/util.cmx kernel/safe_typing.cmi -kernel/sign.cmo: kernel/generic.cmi kernel/names.cmi kernel/term.cmi \ - lib/util.cmi kernel/sign.cmi -kernel/sign.cmx: kernel/generic.cmx kernel/names.cmx kernel/term.cmx \ - lib/util.cmx kernel/sign.cmi -kernel/sosub.cmo: kernel/generic.cmi kernel/names.cmi kernel/term.cmi \ - lib/util.cmi kernel/sosub.cmi -kernel/sosub.cmx: kernel/generic.cmx kernel/names.cmx kernel/term.cmx \ - lib/util.cmx kernel/sosub.cmi -kernel/term.cmo: kernel/generic.cmi lib/hashcons.cmi kernel/names.cmi \ - lib/pp.cmi kernel/univ.cmi lib/util.cmi kernel/term.cmi -kernel/term.cmx: kernel/generic.cmx lib/hashcons.cmx kernel/names.cmx \ - lib/pp.cmx kernel/univ.cmx lib/util.cmx kernel/term.cmi + kernel/evd.cmx kernel/indtypes.cmx kernel/inductive.cmx kernel/names.cmx \ + lib/pp.cmx kernel/reduction.cmx kernel/sign.cmx kernel/term.cmx \ + kernel/type_errors.cmx kernel/typeops.cmx kernel/univ.cmx lib/util.cmx \ + kernel/safe_typing.cmi +kernel/sign.cmo: kernel/names.cmi kernel/term.cmi lib/util.cmi \ + kernel/sign.cmi +kernel/sign.cmx: kernel/names.cmx kernel/term.cmx lib/util.cmx \ + kernel/sign.cmi +kernel/sosub.cmo: kernel/names.cmi kernel/term.cmi lib/util.cmi \ + kernel/sosub.cmi +kernel/sosub.cmx: kernel/names.cmx kernel/term.cmx lib/util.cmx \ + kernel/sosub.cmi +kernel/term.cmo: lib/hashcons.cmi kernel/names.cmi lib/pp.cmi kernel/univ.cmi \ + lib/util.cmi kernel/term.cmi +kernel/term.cmx: lib/hashcons.cmx kernel/names.cmx lib/pp.cmx kernel/univ.cmx \ + lib/util.cmx kernel/term.cmi kernel/type_errors.cmo: kernel/environ.cmi kernel/names.cmi lib/pp.cmi \ kernel/reduction.cmi kernel/sign.cmi kernel/term.cmi \ kernel/type_errors.cmi @@ -299,15 +288,13 @@ kernel/type_errors.cmx: kernel/environ.cmx kernel/names.cmx lib/pp.cmx \ kernel/reduction.cmx kernel/sign.cmx kernel/term.cmx \ kernel/type_errors.cmi kernel/typeops.cmo: kernel/declarations.cmi kernel/environ.cmi \ - kernel/generic.cmi kernel/inductive.cmi kernel/instantiate.cmi \ - kernel/names.cmi lib/pp.cmi kernel/reduction.cmi kernel/sign.cmi \ - kernel/term.cmi kernel/type_errors.cmi kernel/univ.cmi lib/util.cmi \ - kernel/typeops.cmi + kernel/inductive.cmi kernel/instantiate.cmi kernel/names.cmi lib/pp.cmi \ + kernel/reduction.cmi kernel/sign.cmi kernel/term.cmi \ + kernel/type_errors.cmi kernel/univ.cmi lib/util.cmi kernel/typeops.cmi kernel/typeops.cmx: kernel/declarations.cmx kernel/environ.cmx \ - kernel/generic.cmx kernel/inductive.cmx kernel/instantiate.cmx \ - kernel/names.cmx lib/pp.cmx kernel/reduction.cmx kernel/sign.cmx \ - kernel/term.cmx kernel/type_errors.cmx kernel/univ.cmx lib/util.cmx \ - kernel/typeops.cmi + kernel/inductive.cmx kernel/instantiate.cmx kernel/names.cmx lib/pp.cmx \ + kernel/reduction.cmx kernel/sign.cmx kernel/term.cmx \ + kernel/type_errors.cmx kernel/univ.cmx lib/util.cmx kernel/typeops.cmi kernel/univ.cmo: kernel/names.cmi lib/pp.cmi lib/util.cmi kernel/univ.cmi kernel/univ.cmx: kernel/names.cmx lib/pp.cmx lib/util.cmx kernel/univ.cmi lib/bij.cmo: lib/gmap.cmi lib/bij.cmi @@ -335,49 +322,45 @@ lib/pp.cmx: lib/pp_control.cmx lib/pp.cmi lib/profile.cmo: lib/system.cmi lib/profile.cmi lib/profile.cmx: lib/system.cmx lib/profile.cmi library/declare.cmo: kernel/declarations.cmi kernel/environ.cmi \ - kernel/evd.cmi kernel/generic.cmi library/global.cmi library/impargs.cmi \ - library/indrec.cmi kernel/inductive.cmi library/lib.cmi \ - library/libobject.cmi kernel/names.cmi library/nametab.cmi \ - lib/options.cmi lib/pp.cmi kernel/reduction.cmi kernel/sign.cmi \ - library/summary.cmi kernel/term.cmi kernel/type_errors.cmi \ - kernel/typeops.cmi lib/util.cmi library/declare.cmi + kernel/evd.cmi library/global.cmi library/impargs.cmi library/indrec.cmi \ + kernel/inductive.cmi library/lib.cmi library/libobject.cmi \ + kernel/names.cmi library/nametab.cmi lib/options.cmi lib/pp.cmi \ + kernel/reduction.cmi kernel/sign.cmi library/summary.cmi kernel/term.cmi \ + kernel/type_errors.cmi kernel/typeops.cmi lib/util.cmi \ + library/declare.cmi library/declare.cmx: kernel/declarations.cmx kernel/environ.cmx \ - kernel/evd.cmx kernel/generic.cmx library/global.cmx library/impargs.cmx \ - library/indrec.cmx kernel/inductive.cmx library/lib.cmx \ - library/libobject.cmx kernel/names.cmx library/nametab.cmx \ - lib/options.cmx lib/pp.cmx kernel/reduction.cmx kernel/sign.cmx \ - library/summary.cmx kernel/term.cmx kernel/type_errors.cmx \ - kernel/typeops.cmx lib/util.cmx library/declare.cmi -library/global.cmo: kernel/environ.cmi kernel/generic.cmi \ - kernel/inductive.cmi kernel/instantiate.cmi kernel/safe_typing.cmi \ - kernel/sign.cmi library/summary.cmi kernel/term.cmi lib/util.cmi \ - library/global.cmi -library/global.cmx: kernel/environ.cmx kernel/generic.cmx \ - kernel/inductive.cmx kernel/instantiate.cmx kernel/safe_typing.cmx \ - kernel/sign.cmx library/summary.cmx kernel/term.cmx lib/util.cmx \ - library/global.cmi + kernel/evd.cmx library/global.cmx library/impargs.cmx library/indrec.cmx \ + kernel/inductive.cmx library/lib.cmx library/libobject.cmx \ + kernel/names.cmx library/nametab.cmx lib/options.cmx lib/pp.cmx \ + kernel/reduction.cmx kernel/sign.cmx library/summary.cmx kernel/term.cmx \ + kernel/type_errors.cmx kernel/typeops.cmx lib/util.cmx \ + library/declare.cmi +library/global.cmo: kernel/environ.cmi kernel/inductive.cmi \ + kernel/instantiate.cmi kernel/safe_typing.cmi kernel/sign.cmi \ + library/summary.cmi kernel/term.cmi lib/util.cmi library/global.cmi +library/global.cmx: kernel/environ.cmx kernel/inductive.cmx \ + kernel/instantiate.cmx kernel/safe_typing.cmx kernel/sign.cmx \ + library/summary.cmx kernel/term.cmx lib/util.cmx library/global.cmi library/goptions.cmo: library/lib.cmi library/libobject.cmi kernel/names.cmi \ lib/pp.cmi library/summary.cmi lib/util.cmi library/goptions.cmi library/goptions.cmx: library/lib.cmx library/libobject.cmx kernel/names.cmx \ lib/pp.cmx library/summary.cmx lib/util.cmx library/goptions.cmi library/impargs.cmo: kernel/declarations.cmi kernel/evd.cmi \ - kernel/generic.cmi library/global.cmi kernel/inductive.cmi \ - kernel/names.cmi kernel/reduction.cmi library/summary.cmi kernel/term.cmi \ + library/global.cmi kernel/inductive.cmi kernel/names.cmi \ + kernel/reduction.cmi library/summary.cmi kernel/term.cmi \ library/impargs.cmi library/impargs.cmx: kernel/declarations.cmx kernel/evd.cmx \ - kernel/generic.cmx library/global.cmx kernel/inductive.cmx \ - kernel/names.cmx kernel/reduction.cmx library/summary.cmx kernel/term.cmx \ + library/global.cmx kernel/inductive.cmx kernel/names.cmx \ + kernel/reduction.cmx library/summary.cmx kernel/term.cmx \ library/impargs.cmi library/indrec.cmo: kernel/declarations.cmi kernel/environ.cmi \ - kernel/generic.cmi kernel/indtypes.cmi kernel/inductive.cmi \ - kernel/instantiate.cmi kernel/names.cmi lib/pp.cmi kernel/reduction.cmi \ - kernel/term.cmi kernel/type_errors.cmi kernel/typeops.cmi lib/util.cmi \ - library/indrec.cmi + kernel/indtypes.cmi kernel/inductive.cmi kernel/instantiate.cmi \ + kernel/names.cmi lib/pp.cmi kernel/reduction.cmi kernel/term.cmi \ + kernel/type_errors.cmi kernel/typeops.cmi lib/util.cmi library/indrec.cmi library/indrec.cmx: kernel/declarations.cmx kernel/environ.cmx \ - kernel/generic.cmx kernel/indtypes.cmx kernel/inductive.cmx \ - kernel/instantiate.cmx kernel/names.cmx lib/pp.cmx kernel/reduction.cmx \ - kernel/term.cmx kernel/type_errors.cmx kernel/typeops.cmx lib/util.cmx \ - library/indrec.cmi + kernel/indtypes.cmx kernel/inductive.cmx kernel/instantiate.cmx \ + kernel/names.cmx lib/pp.cmx kernel/reduction.cmx kernel/term.cmx \ + kernel/type_errors.cmx kernel/typeops.cmx lib/util.cmx library/indrec.cmi library/lib.cmo: library/libobject.cmi kernel/names.cmi library/summary.cmi \ lib/util.cmi library/lib.cmi library/lib.cmx: library/libobject.cmx kernel/names.cmx library/summary.cmx \ @@ -386,26 +369,26 @@ library/libobject.cmo: lib/dyn.cmi kernel/names.cmi lib/util.cmi \ library/libobject.cmi library/libobject.cmx: lib/dyn.cmx kernel/names.cmx lib/util.cmx \ library/libobject.cmi -library/library.cmo: kernel/environ.cmi library/global.cmi library/lib.cmi \ - library/libobject.cmi kernel/names.cmi lib/pp.cmi library/summary.cmi \ - lib/system.cmi lib/util.cmi library/library.cmi -library/library.cmx: kernel/environ.cmx library/global.cmx library/lib.cmx \ - library/libobject.cmx kernel/names.cmx lib/pp.cmx library/summary.cmx \ - lib/system.cmx lib/util.cmx library/library.cmi +library/library.cmo: kernel/environ.cmi library/global.cmi \ + library/goptions.cmi library/lib.cmi library/libobject.cmi \ + kernel/names.cmi lib/pp.cmi library/summary.cmi lib/system.cmi \ + lib/util.cmi library/library.cmi +library/library.cmx: kernel/environ.cmx library/global.cmx \ + library/goptions.cmx library/lib.cmx library/libobject.cmx \ + kernel/names.cmx lib/pp.cmx library/summary.cmx lib/system.cmx \ + lib/util.cmx library/library.cmi library/nametab.cmo: kernel/names.cmi library/summary.cmi library/nametab.cmi library/nametab.cmx: kernel/names.cmx library/summary.cmx library/nametab.cmi library/redinfo.cmo: kernel/declarations.cmi kernel/evd.cmi \ - kernel/generic.cmi library/global.cmi kernel/names.cmi \ - kernel/reduction.cmi library/summary.cmi kernel/term.cmi lib/util.cmi \ - library/redinfo.cmi + library/global.cmi kernel/names.cmi kernel/reduction.cmi \ + library/summary.cmi kernel/term.cmi lib/util.cmi library/redinfo.cmi library/redinfo.cmx: kernel/declarations.cmx kernel/evd.cmx \ - kernel/generic.cmx library/global.cmx kernel/names.cmx \ - kernel/reduction.cmx library/summary.cmx kernel/term.cmx lib/util.cmx \ - library/redinfo.cmi -library/states.cmo: library/lib.cmi library/summary.cmi lib/system.cmi \ - library/states.cmi -library/states.cmx: library/lib.cmx library/summary.cmx lib/system.cmx \ - library/states.cmi + library/global.cmx kernel/names.cmx kernel/reduction.cmx \ + library/summary.cmx kernel/term.cmx lib/util.cmx library/redinfo.cmi +library/states.cmo: library/lib.cmi library/library.cmi library/summary.cmi \ + lib/system.cmi library/states.cmi +library/states.cmx: library/lib.cmx library/library.cmx library/summary.cmx \ + lib/system.cmx library/states.cmi library/summary.cmo: lib/dyn.cmi kernel/names.cmi lib/pp.cmi lib/util.cmi \ library/summary.cmi library/summary.cmx: lib/dyn.cmx kernel/names.cmx lib/pp.cmx lib/util.cmx \ @@ -424,16 +407,16 @@ parsing/ast.cmx: parsing/coqast.cmx lib/dyn.cmx lib/hashcons.cmx \ kernel/names.cmx parsing/pcoq.cmx lib/pp.cmx lib/util.cmx parsing/ast.cmi parsing/astterm.cmo: parsing/ast.cmi parsing/coqast.cmi library/declare.cmi \ kernel/environ.cmi pretyping/evarutil.cmi kernel/evd.cmi \ - kernel/generic.cmi library/global.cmi library/impargs.cmi \ - kernel/names.cmi parsing/pattern.cmi parsing/pcoq.cmi lib/pp.cmi \ + library/global.cmi library/impargs.cmi kernel/names.cmi \ + parsing/pattern.cmi parsing/pcoq.cmi lib/pp.cmi \ pretyping/pretype_errors.cmi pretyping/pretyping.cmi \ pretyping/rawterm.cmi kernel/reduction.cmi pretyping/retyping.cmi \ kernel/sign.cmi pretyping/syntax_def.cmi kernel/term.cmi \ pretyping/typing.cmi kernel/univ.cmi lib/util.cmi parsing/astterm.cmi parsing/astterm.cmx: parsing/ast.cmx parsing/coqast.cmx library/declare.cmx \ kernel/environ.cmx pretyping/evarutil.cmx kernel/evd.cmx \ - kernel/generic.cmx library/global.cmx library/impargs.cmx \ - kernel/names.cmx parsing/pattern.cmx parsing/pcoq.cmx lib/pp.cmx \ + library/global.cmx library/impargs.cmx kernel/names.cmx \ + parsing/pattern.cmx parsing/pcoq.cmx lib/pp.cmx \ pretyping/pretype_errors.cmx pretyping/pretyping.cmx \ pretyping/rawterm.cmx kernel/reduction.cmx pretyping/retyping.cmx \ kernel/sign.cmx pretyping/syntax_def.cmx kernel/term.cmx \ @@ -468,32 +451,28 @@ parsing/g_zsyntax.cmx: parsing/ast.cmx parsing/astterm.cmx parsing/coqast.cmx \ lib/util.cmx parsing/g_zsyntax.cmi parsing/lexer.cmo: lib/util.cmi parsing/lexer.cmi parsing/lexer.cmx: lib/util.cmx parsing/lexer.cmi -parsing/pattern.cmo: kernel/generic.cmi kernel/names.cmi \ - pretyping/rawterm.cmi kernel/reduction.cmi kernel/term.cmi lib/util.cmi \ - parsing/pattern.cmi -parsing/pattern.cmx: kernel/generic.cmx kernel/names.cmx \ - pretyping/rawterm.cmx kernel/reduction.cmx kernel/term.cmx lib/util.cmx \ - parsing/pattern.cmi +parsing/pattern.cmo: kernel/names.cmi pretyping/rawterm.cmi \ + kernel/reduction.cmi kernel/term.cmi lib/util.cmi parsing/pattern.cmi +parsing/pattern.cmx: kernel/names.cmx pretyping/rawterm.cmx \ + kernel/reduction.cmx kernel/term.cmx lib/util.cmx parsing/pattern.cmi parsing/pcoq.cmo: parsing/coqast.cmi parsing/lexer.cmi lib/pp.cmi \ lib/util.cmi parsing/pcoq.cmi parsing/pcoq.cmx: parsing/coqast.cmx parsing/lexer.cmx lib/pp.cmx \ lib/util.cmx parsing/pcoq.cmi parsing/pretty.cmo: pretyping/classops.cmi kernel/declarations.cmi \ - library/declare.cmi kernel/environ.cmi kernel/evd.cmi kernel/generic.cmi \ - library/global.cmi library/impargs.cmi kernel/inductive.cmi \ - kernel/instantiate.cmi library/lib.cmi library/libobject.cmi \ - library/library.cmi kernel/names.cmi library/nametab.cmi lib/pp.cmi \ - parsing/printer.cmi kernel/reduction.cmi kernel/sign.cmi \ - pretyping/syntax_def.cmi kernel/term.cmi kernel/typeops.cmi lib/util.cmi \ - parsing/pretty.cmi + library/declare.cmi kernel/environ.cmi kernel/evd.cmi library/global.cmi \ + library/impargs.cmi kernel/inductive.cmi kernel/instantiate.cmi \ + library/lib.cmi library/libobject.cmi library/library.cmi \ + kernel/names.cmi library/nametab.cmi lib/pp.cmi parsing/printer.cmi \ + kernel/reduction.cmi kernel/sign.cmi pretyping/syntax_def.cmi \ + kernel/term.cmi kernel/typeops.cmi lib/util.cmi parsing/pretty.cmi parsing/pretty.cmx: pretyping/classops.cmx kernel/declarations.cmx \ - library/declare.cmx kernel/environ.cmx kernel/evd.cmx kernel/generic.cmx \ - library/global.cmx library/impargs.cmx kernel/inductive.cmx \ - kernel/instantiate.cmx library/lib.cmx library/libobject.cmx \ - library/library.cmx kernel/names.cmx library/nametab.cmx lib/pp.cmx \ - parsing/printer.cmx kernel/reduction.cmx kernel/sign.cmx \ - pretyping/syntax_def.cmx kernel/term.cmx kernel/typeops.cmx lib/util.cmx \ - parsing/pretty.cmi + library/declare.cmx kernel/environ.cmx kernel/evd.cmx library/global.cmx \ + library/impargs.cmx kernel/inductive.cmx kernel/instantiate.cmx \ + library/lib.cmx library/libobject.cmx library/library.cmx \ + kernel/names.cmx library/nametab.cmx lib/pp.cmx parsing/printer.cmx \ + kernel/reduction.cmx kernel/sign.cmx pretyping/syntax_def.cmx \ + kernel/term.cmx kernel/typeops.cmx lib/util.cmx parsing/pretty.cmi parsing/printer.cmo: parsing/ast.cmi parsing/coqast.cmi library/declare.cmi \ kernel/environ.cmi parsing/esyntax.cmi parsing/extend.cmi \ library/global.cmi kernel/names.cmi library/nametab.cmi lib/options.cmi \ @@ -506,85 +485,83 @@ parsing/printer.cmx: parsing/ast.cmx parsing/coqast.cmx library/declare.cmx \ parsing/termast.cmx lib/util.cmx parsing/printer.cmi parsing/termast.cmo: parsing/ast.cmi pretyping/classops.cmi \ parsing/coqast.cmi library/declare.cmi pretyping/detyping.cmi \ - kernel/environ.cmi kernel/evd.cmi kernel/generic.cmi library/impargs.cmi \ + kernel/environ.cmi kernel/evd.cmi library/impargs.cmi \ kernel/inductive.cmi kernel/names.cmi parsing/pattern.cmi lib/pp.cmi \ pretyping/rawterm.cmi kernel/reduction.cmi kernel/sign.cmi \ kernel/term.cmi kernel/univ.cmi lib/util.cmi parsing/termast.cmi parsing/termast.cmx: parsing/ast.cmx pretyping/classops.cmx \ parsing/coqast.cmx library/declare.cmx pretyping/detyping.cmx \ - kernel/environ.cmx kernel/evd.cmx kernel/generic.cmx library/impargs.cmx \ + kernel/environ.cmx kernel/evd.cmx library/impargs.cmx \ kernel/inductive.cmx kernel/names.cmx parsing/pattern.cmx lib/pp.cmx \ pretyping/rawterm.cmx kernel/reduction.cmx kernel/sign.cmx \ kernel/term.cmx kernel/univ.cmx lib/util.cmx parsing/termast.cmi pretyping/cases.cmo: pretyping/coercion.cmi kernel/declarations.cmi \ kernel/environ.cmi pretyping/evarconv.cmi pretyping/evarutil.cmi \ - kernel/evd.cmi kernel/generic.cmi library/global.cmi kernel/inductive.cmi \ - kernel/names.cmi lib/pp.cmi pretyping/pretype_errors.cmi \ - pretyping/rawterm.cmi kernel/reduction.cmi pretyping/retyping.cmi \ - kernel/sign.cmi kernel/term.cmi kernel/type_errors.cmi kernel/typeops.cmi \ - kernel/univ.cmi lib/util.cmi pretyping/cases.cmi + kernel/evd.cmi library/global.cmi kernel/inductive.cmi kernel/names.cmi \ + lib/pp.cmi pretyping/pretype_errors.cmi pretyping/rawterm.cmi \ + kernel/reduction.cmi pretyping/retyping.cmi kernel/sign.cmi \ + kernel/term.cmi kernel/type_errors.cmi kernel/typeops.cmi kernel/univ.cmi \ + lib/util.cmi pretyping/cases.cmi pretyping/cases.cmx: pretyping/coercion.cmx kernel/declarations.cmx \ kernel/environ.cmx pretyping/evarconv.cmx pretyping/evarutil.cmx \ - kernel/evd.cmx kernel/generic.cmx library/global.cmx kernel/inductive.cmx \ - kernel/names.cmx lib/pp.cmx pretyping/pretype_errors.cmx \ - pretyping/rawterm.cmx kernel/reduction.cmx pretyping/retyping.cmx \ - kernel/sign.cmx kernel/term.cmx kernel/type_errors.cmx kernel/typeops.cmx \ - kernel/univ.cmx lib/util.cmx pretyping/cases.cmi + kernel/evd.cmx library/global.cmx kernel/inductive.cmx kernel/names.cmx \ + lib/pp.cmx pretyping/pretype_errors.cmx pretyping/rawterm.cmx \ + kernel/reduction.cmx pretyping/retyping.cmx kernel/sign.cmx \ + kernel/term.cmx kernel/type_errors.cmx kernel/typeops.cmx kernel/univ.cmx \ + lib/util.cmx pretyping/cases.cmi pretyping/class.cmo: pretyping/classops.cmi kernel/declarations.cmi \ - library/declare.cmi kernel/environ.cmi kernel/evd.cmi kernel/generic.cmi \ - library/global.cmi kernel/inductive.cmi kernel/instantiate.cmi \ - library/lib.cmi kernel/names.cmi lib/pp.cmi pretyping/retyping.cmi \ + library/declare.cmi kernel/environ.cmi kernel/evd.cmi library/global.cmi \ + kernel/inductive.cmi kernel/instantiate.cmi library/lib.cmi \ + kernel/names.cmi lib/pp.cmi pretyping/retyping.cmi kernel/sign.cmi \ kernel/term.cmi pretyping/typing.cmi lib/util.cmi pretyping/class.cmi pretyping/class.cmx: pretyping/classops.cmx kernel/declarations.cmx \ - library/declare.cmx kernel/environ.cmx kernel/evd.cmx kernel/generic.cmx \ - library/global.cmx kernel/inductive.cmx kernel/instantiate.cmx \ - library/lib.cmx kernel/names.cmx lib/pp.cmx pretyping/retyping.cmx \ + library/declare.cmx kernel/environ.cmx kernel/evd.cmx library/global.cmx \ + kernel/inductive.cmx kernel/instantiate.cmx library/lib.cmx \ + kernel/names.cmx lib/pp.cmx pretyping/retyping.cmx kernel/sign.cmx \ kernel/term.cmx pretyping/typing.cmx lib/util.cmx pretyping/class.cmi pretyping/classops.cmo: library/declare.cmi kernel/environ.cmi \ - kernel/generic.cmi library/lib.cmi library/libobject.cmi kernel/names.cmi \ - lib/options.cmi lib/pp.cmi pretyping/rawterm.cmi library/summary.cmi \ - pretyping/tacred.cmi kernel/term.cmi lib/util.cmi pretyping/classops.cmi + library/lib.cmi library/libobject.cmi kernel/names.cmi lib/options.cmi \ + lib/pp.cmi pretyping/rawterm.cmi library/summary.cmi pretyping/tacred.cmi \ + kernel/term.cmi lib/util.cmi pretyping/classops.cmi pretyping/classops.cmx: library/declare.cmx kernel/environ.cmx \ - kernel/generic.cmx library/lib.cmx library/libobject.cmx kernel/names.cmx \ - lib/options.cmx lib/pp.cmx pretyping/rawterm.cmx library/summary.cmx \ - pretyping/tacred.cmx kernel/term.cmx lib/util.cmx pretyping/classops.cmi + library/lib.cmx library/libobject.cmx kernel/names.cmx lib/options.cmx \ + lib/pp.cmx pretyping/rawterm.cmx library/summary.cmx pretyping/tacred.cmx \ + kernel/term.cmx lib/util.cmx pretyping/classops.cmi pretyping/coercion.cmo: pretyping/classops.cmi kernel/environ.cmi \ - pretyping/evarconv.cmi kernel/evd.cmi kernel/generic.cmi kernel/names.cmi \ + pretyping/evarconv.cmi kernel/evd.cmi kernel/names.cmi \ pretyping/pretype_errors.cmi pretyping/recordops.cmi kernel/reduction.cmi \ pretyping/retyping.cmi kernel/term.cmi kernel/typeops.cmi lib/util.cmi \ pretyping/coercion.cmi pretyping/coercion.cmx: pretyping/classops.cmx kernel/environ.cmx \ - pretyping/evarconv.cmx kernel/evd.cmx kernel/generic.cmx kernel/names.cmx \ + pretyping/evarconv.cmx kernel/evd.cmx kernel/names.cmx \ pretyping/pretype_errors.cmx pretyping/recordops.cmx kernel/reduction.cmx \ pretyping/retyping.cmx kernel/term.cmx kernel/typeops.cmx lib/util.cmx \ pretyping/coercion.cmi pretyping/detyping.cmo: kernel/declarations.cmi library/declare.cmi \ - kernel/generic.cmi library/global.cmi library/goptions.cmi \ - library/impargs.cmi kernel/inductive.cmi kernel/names.cmi lib/pp.cmi \ - pretyping/rawterm.cmi kernel/sign.cmi kernel/term.cmi kernel/univ.cmi \ - lib/util.cmi pretyping/detyping.cmi + library/global.cmi library/goptions.cmi library/impargs.cmi \ + kernel/inductive.cmi kernel/names.cmi lib/pp.cmi pretyping/rawterm.cmi \ + kernel/sign.cmi kernel/term.cmi kernel/univ.cmi lib/util.cmi \ + pretyping/detyping.cmi pretyping/detyping.cmx: kernel/declarations.cmx library/declare.cmx \ - kernel/generic.cmx library/global.cmx library/goptions.cmx \ - library/impargs.cmx kernel/inductive.cmx kernel/names.cmx lib/pp.cmx \ - pretyping/rawterm.cmx kernel/sign.cmx kernel/term.cmx kernel/univ.cmx \ - lib/util.cmx pretyping/detyping.cmi + library/global.cmx library/goptions.cmx library/impargs.cmx \ + kernel/inductive.cmx kernel/names.cmx lib/pp.cmx pretyping/rawterm.cmx \ + kernel/sign.cmx kernel/term.cmx kernel/univ.cmx lib/util.cmx \ + pretyping/detyping.cmi pretyping/evarconv.cmo: pretyping/classops.cmi kernel/environ.cmi \ - pretyping/evarutil.cmi kernel/generic.cmi kernel/instantiate.cmi \ - kernel/names.cmi pretyping/recordops.cmi kernel/reduction.cmi \ - pretyping/retyping.cmi kernel/term.cmi pretyping/typing.cmi lib/util.cmi \ - pretyping/evarconv.cmi + pretyping/evarutil.cmi kernel/instantiate.cmi kernel/names.cmi \ + pretyping/recordops.cmi kernel/reduction.cmi pretyping/retyping.cmi \ + kernel/term.cmi pretyping/typing.cmi lib/util.cmi pretyping/evarconv.cmi pretyping/evarconv.cmx: pretyping/classops.cmx kernel/environ.cmx \ - pretyping/evarutil.cmx kernel/generic.cmx kernel/instantiate.cmx \ - kernel/names.cmx pretyping/recordops.cmx kernel/reduction.cmx \ - pretyping/retyping.cmx kernel/term.cmx pretyping/typing.cmx lib/util.cmx \ - pretyping/evarconv.cmi -pretyping/evarutil.cmo: kernel/environ.cmi kernel/evd.cmi kernel/generic.cmi \ - library/indrec.cmi kernel/instantiate.cmi kernel/names.cmi lib/pp.cmi \ + pretyping/evarutil.cmx kernel/instantiate.cmx kernel/names.cmx \ + pretyping/recordops.cmx kernel/reduction.cmx pretyping/retyping.cmx \ + kernel/term.cmx pretyping/typing.cmx lib/util.cmx pretyping/evarconv.cmi +pretyping/evarutil.cmo: kernel/environ.cmi kernel/evd.cmi library/indrec.cmi \ + kernel/instantiate.cmi kernel/names.cmi lib/pp.cmi \ pretyping/pretype_errors.cmi kernel/reduction.cmi kernel/sign.cmi \ kernel/term.cmi kernel/type_errors.cmi kernel/univ.cmi lib/util.cmi \ pretyping/evarutil.cmi -pretyping/evarutil.cmx: kernel/environ.cmx kernel/evd.cmx kernel/generic.cmx \ - library/indrec.cmx kernel/instantiate.cmx kernel/names.cmx lib/pp.cmx \ +pretyping/evarutil.cmx: kernel/environ.cmx kernel/evd.cmx library/indrec.cmx \ + kernel/instantiate.cmx kernel/names.cmx lib/pp.cmx \ pretyping/pretype_errors.cmx kernel/reduction.cmx kernel/sign.cmx \ kernel/term.cmx kernel/type_errors.cmx kernel/univ.cmx lib/util.cmx \ pretyping/evarutil.cmi @@ -596,22 +573,20 @@ pretyping/pretype_errors.cmx: kernel/environ.cmx library/global.cmx \ kernel/type_errors.cmx pretyping/pretype_errors.cmi pretyping/pretyping.cmo: pretyping/cases.cmi pretyping/classops.cmi \ pretyping/coercion.cmi kernel/environ.cmi pretyping/evarconv.cmi \ - pretyping/evarutil.cmi kernel/evd.cmi kernel/generic.cmi \ - library/indrec.cmi kernel/inductive.cmi kernel/instantiate.cmi \ - kernel/names.cmi lib/pp.cmi pretyping/pretype_errors.cmi \ - pretyping/rawterm.cmi pretyping/recordops.cmi kernel/reduction.cmi \ - pretyping/retyping.cmi kernel/sign.cmi kernel/term.cmi \ - kernel/type_errors.cmi kernel/typeops.cmi kernel/univ.cmi lib/util.cmi \ - pretyping/pretyping.cmi + pretyping/evarutil.cmi kernel/evd.cmi library/indrec.cmi \ + kernel/inductive.cmi kernel/instantiate.cmi kernel/names.cmi lib/pp.cmi \ + pretyping/pretype_errors.cmi pretyping/rawterm.cmi \ + pretyping/recordops.cmi kernel/reduction.cmi pretyping/retyping.cmi \ + kernel/sign.cmi kernel/term.cmi kernel/type_errors.cmi kernel/typeops.cmi \ + kernel/univ.cmi lib/util.cmi pretyping/pretyping.cmi pretyping/pretyping.cmx: pretyping/cases.cmx pretyping/classops.cmx \ pretyping/coercion.cmx kernel/environ.cmx pretyping/evarconv.cmx \ - pretyping/evarutil.cmx kernel/evd.cmx kernel/generic.cmx \ - library/indrec.cmx kernel/inductive.cmx kernel/instantiate.cmx \ - kernel/names.cmx lib/pp.cmx pretyping/pretype_errors.cmx \ - pretyping/rawterm.cmx pretyping/recordops.cmx kernel/reduction.cmx \ - pretyping/retyping.cmx kernel/sign.cmx kernel/term.cmx \ - kernel/type_errors.cmx kernel/typeops.cmx kernel/univ.cmx lib/util.cmx \ - pretyping/pretyping.cmi + pretyping/evarutil.cmx kernel/evd.cmx library/indrec.cmx \ + kernel/inductive.cmx kernel/instantiate.cmx kernel/names.cmx lib/pp.cmx \ + pretyping/pretype_errors.cmx pretyping/rawterm.cmx \ + pretyping/recordops.cmx kernel/reduction.cmx pretyping/retyping.cmx \ + kernel/sign.cmx kernel/term.cmx kernel/type_errors.cmx kernel/typeops.cmx \ + kernel/univ.cmx lib/util.cmx pretyping/pretyping.cmi pretyping/rawterm.cmo: kernel/names.cmi kernel/sign.cmi kernel/term.cmi \ lib/util.cmi pretyping/rawterm.cmi pretyping/rawterm.cmx: kernel/names.cmx kernel/sign.cmx kernel/term.cmx \ @@ -624,14 +599,12 @@ pretyping/recordops.cmx: pretyping/classops.cmx library/lib.cmx \ library/libobject.cmx library/library.cmx kernel/names.cmx lib/pp.cmx \ library/summary.cmx kernel/term.cmx kernel/typeops.cmx lib/util.cmx \ pretyping/recordops.cmi -pretyping/retyping.cmo: kernel/environ.cmi kernel/generic.cmi \ - kernel/inductive.cmi kernel/names.cmi kernel/reduction.cmi \ - kernel/term.cmi kernel/typeops.cmi kernel/univ.cmi lib/util.cmi \ - pretyping/retyping.cmi -pretyping/retyping.cmx: kernel/environ.cmx kernel/generic.cmx \ - kernel/inductive.cmx kernel/names.cmx kernel/reduction.cmx \ - kernel/term.cmx kernel/typeops.cmx kernel/univ.cmx lib/util.cmx \ - pretyping/retyping.cmi +pretyping/retyping.cmo: kernel/environ.cmi kernel/inductive.cmi \ + kernel/names.cmi kernel/reduction.cmi kernel/term.cmi kernel/typeops.cmi \ + kernel/univ.cmi lib/util.cmi pretyping/retyping.cmi +pretyping/retyping.cmx: kernel/environ.cmx kernel/inductive.cmx \ + kernel/names.cmx kernel/reduction.cmx kernel/term.cmx kernel/typeops.cmx \ + kernel/univ.cmx lib/util.cmx pretyping/retyping.cmi pretyping/syntax_def.cmo: library/lib.cmi library/libobject.cmi \ kernel/names.cmi library/nametab.cmi pretyping/rawterm.cmi \ library/summary.cmi pretyping/syntax_def.cmi @@ -639,50 +612,52 @@ pretyping/syntax_def.cmx: library/lib.cmx library/libobject.cmx \ kernel/names.cmx library/nametab.cmx pretyping/rawterm.cmx \ library/summary.cmx pretyping/syntax_def.cmi pretyping/tacred.cmo: kernel/closure.cmi library/declare.cmi \ - kernel/environ.cmi kernel/generic.cmi kernel/inductive.cmi \ + kernel/environ.cmi kernel/evd.cmi library/global.cmi kernel/inductive.cmi \ kernel/instantiate.cmi kernel/names.cmi lib/pp.cmi library/redinfo.cmi \ - kernel/reduction.cmi kernel/term.cmi lib/util.cmi pretyping/tacred.cmi + kernel/reduction.cmi pretyping/retyping.cmi kernel/term.cmi lib/util.cmi \ + pretyping/tacred.cmi pretyping/tacred.cmx: kernel/closure.cmx library/declare.cmx \ - kernel/environ.cmx kernel/generic.cmx kernel/inductive.cmx \ + kernel/environ.cmx kernel/evd.cmx library/global.cmx kernel/inductive.cmx \ kernel/instantiate.cmx kernel/names.cmx lib/pp.cmx library/redinfo.cmx \ - kernel/reduction.cmx kernel/term.cmx lib/util.cmx pretyping/tacred.cmi -pretyping/typing.cmo: kernel/environ.cmi kernel/generic.cmi kernel/names.cmi \ + kernel/reduction.cmx pretyping/retyping.cmx kernel/term.cmx lib/util.cmx \ + pretyping/tacred.cmi +pretyping/typing.cmo: kernel/environ.cmi kernel/names.cmi \ kernel/reduction.cmi kernel/term.cmi kernel/type_errors.cmi \ kernel/typeops.cmi lib/util.cmi pretyping/typing.cmi -pretyping/typing.cmx: kernel/environ.cmx kernel/generic.cmx kernel/names.cmx \ +pretyping/typing.cmx: kernel/environ.cmx kernel/names.cmx \ kernel/reduction.cmx kernel/term.cmx kernel/type_errors.cmx \ kernel/typeops.cmx lib/util.cmx pretyping/typing.cmi -proofs/clenv.cmo: kernel/environ.cmi kernel/evd.cmi kernel/generic.cmi \ - kernel/instantiate.cmi proofs/logic.cmi kernel/names.cmi lib/pp.cmi \ - parsing/printer.cmi proofs/proof_type.cmi kernel/reduction.cmi \ - pretyping/retyping.cmi kernel/sign.cmi proofs/tacmach.cmi kernel/term.cmi \ - pretyping/typing.cmi lib/util.cmi proofs/clenv.cmi -proofs/clenv.cmx: kernel/environ.cmx kernel/evd.cmx kernel/generic.cmx \ - kernel/instantiate.cmx proofs/logic.cmx kernel/names.cmx lib/pp.cmx \ - parsing/printer.cmx proofs/proof_type.cmx kernel/reduction.cmx \ - pretyping/retyping.cmx kernel/sign.cmx proofs/tacmach.cmx kernel/term.cmx \ - pretyping/typing.cmx lib/util.cmx proofs/clenv.cmi +proofs/clenv.cmo: kernel/environ.cmi kernel/evd.cmi kernel/instantiate.cmi \ + proofs/logic.cmi kernel/names.cmi lib/pp.cmi parsing/printer.cmi \ + proofs/proof_type.cmi kernel/reduction.cmi pretyping/retyping.cmi \ + kernel/sign.cmi proofs/tacmach.cmi kernel/term.cmi pretyping/typing.cmi \ + lib/util.cmi proofs/clenv.cmi +proofs/clenv.cmx: kernel/environ.cmx kernel/evd.cmx kernel/instantiate.cmx \ + proofs/logic.cmx kernel/names.cmx lib/pp.cmx parsing/printer.cmx \ + proofs/proof_type.cmx kernel/reduction.cmx pretyping/retyping.cmx \ + kernel/sign.cmx proofs/tacmach.cmx kernel/term.cmx pretyping/typing.cmx \ + lib/util.cmx proofs/clenv.cmi proofs/evar_refiner.cmo: parsing/astterm.cmi kernel/environ.cmi \ - kernel/evd.cmi kernel/generic.cmi proofs/logic.cmi kernel/names.cmi \ - lib/pp.cmi proofs/proof_trees.cmi proofs/proof_type.cmi \ - kernel/reduction.cmi proofs/refiner.cmi lib/stamps.cmi kernel/term.cmi \ - pretyping/typing.cmi lib/util.cmi proofs/evar_refiner.cmi + kernel/evd.cmi proofs/logic.cmi kernel/names.cmi lib/pp.cmi \ + proofs/proof_trees.cmi proofs/proof_type.cmi kernel/reduction.cmi \ + proofs/refiner.cmi lib/stamps.cmi kernel/term.cmi pretyping/typing.cmi \ + lib/util.cmi proofs/evar_refiner.cmi proofs/evar_refiner.cmx: parsing/astterm.cmx kernel/environ.cmx \ - kernel/evd.cmx kernel/generic.cmx proofs/logic.cmx kernel/names.cmx \ - lib/pp.cmx proofs/proof_trees.cmx proofs/proof_type.cmx \ - kernel/reduction.cmx proofs/refiner.cmx lib/stamps.cmx kernel/term.cmx \ - pretyping/typing.cmx lib/util.cmx proofs/evar_refiner.cmi + kernel/evd.cmx proofs/logic.cmx kernel/names.cmx lib/pp.cmx \ + proofs/proof_trees.cmx proofs/proof_type.cmx kernel/reduction.cmx \ + proofs/refiner.cmx lib/stamps.cmx kernel/term.cmx pretyping/typing.cmx \ + lib/util.cmx proofs/evar_refiner.cmi proofs/logic.cmo: parsing/coqast.cmi library/declare.cmi kernel/environ.cmi \ - kernel/evd.cmi kernel/generic.cmi kernel/inductive.cmi kernel/names.cmi \ - lib/pp.cmi parsing/printer.cmi proofs/proof_trees.cmi \ - proofs/proof_type.cmi kernel/reduction.cmi pretyping/retyping.cmi \ - kernel/sign.cmi kernel/term.cmi kernel/type_errors.cmi kernel/typeops.cmi \ + kernel/evd.cmi kernel/inductive.cmi kernel/names.cmi lib/pp.cmi \ + parsing/printer.cmi proofs/proof_trees.cmi proofs/proof_type.cmi \ + kernel/reduction.cmi pretyping/retyping.cmi kernel/sign.cmi \ + kernel/term.cmi kernel/type_errors.cmi kernel/typeops.cmi \ pretyping/typing.cmi lib/util.cmi proofs/logic.cmi proofs/logic.cmx: parsing/coqast.cmx library/declare.cmx kernel/environ.cmx \ - kernel/evd.cmx kernel/generic.cmx kernel/inductive.cmx kernel/names.cmx \ - lib/pp.cmx parsing/printer.cmx proofs/proof_trees.cmx \ - proofs/proof_type.cmx kernel/reduction.cmx pretyping/retyping.cmx \ - kernel/sign.cmx kernel/term.cmx kernel/type_errors.cmx kernel/typeops.cmx \ + kernel/evd.cmx kernel/inductive.cmx kernel/names.cmx lib/pp.cmx \ + parsing/printer.cmx proofs/proof_trees.cmx proofs/proof_type.cmx \ + kernel/reduction.cmx pretyping/retyping.cmx kernel/sign.cmx \ + kernel/term.cmx kernel/type_errors.cmx kernel/typeops.cmx \ pretyping/typing.cmx lib/util.cmx proofs/logic.cmi proofs/macros.cmo: parsing/ast.cmi parsing/coqast.cmi library/lib.cmi \ library/libobject.cmi library/library.cmi kernel/names.cmi \ @@ -694,16 +669,14 @@ proofs/macros.cmx: parsing/ast.cmx parsing/coqast.cmx library/lib.cmx \ kernel/term.cmx lib/util.cmx proofs/macros.cmi proofs/pfedit.cmo: parsing/astterm.cmi kernel/declarations.cmi \ library/declare.cmi lib/edit.cmi kernel/environ.cmi kernel/evd.cmi \ - kernel/generic.cmi library/lib.cmi kernel/names.cmi lib/pp.cmi \ - proofs/proof_trees.cmi proofs/proof_type.cmi kernel/sign.cmi \ - proofs/tacmach.cmi kernel/term.cmi pretyping/typing.cmi lib/util.cmi \ - proofs/pfedit.cmi + library/lib.cmi kernel/names.cmi lib/pp.cmi proofs/proof_trees.cmi \ + proofs/proof_type.cmi kernel/sign.cmi proofs/tacmach.cmi kernel/term.cmi \ + pretyping/typing.cmi lib/util.cmi proofs/pfedit.cmi proofs/pfedit.cmx: parsing/astterm.cmx kernel/declarations.cmx \ library/declare.cmx lib/edit.cmx kernel/environ.cmx kernel/evd.cmx \ - kernel/generic.cmx library/lib.cmx kernel/names.cmx lib/pp.cmx \ - proofs/proof_trees.cmx proofs/proof_type.cmx kernel/sign.cmx \ - proofs/tacmach.cmx kernel/term.cmx pretyping/typing.cmx lib/util.cmx \ - proofs/pfedit.cmi + library/lib.cmx kernel/names.cmx lib/pp.cmx proofs/proof_trees.cmx \ + proofs/proof_type.cmx kernel/sign.cmx proofs/tacmach.cmx kernel/term.cmx \ + pretyping/typing.cmx lib/util.cmx proofs/pfedit.cmi proofs/proof_trees.cmo: parsing/ast.cmi pretyping/detyping.cmi \ kernel/environ.cmi kernel/evd.cmi library/global.cmi kernel/names.cmi \ lib/pp.cmi parsing/pretty.cmi parsing/printer.cmi proofs/proof_type.cmi \ @@ -721,307 +694,283 @@ proofs/proof_type.cmx: parsing/coqast.cmx kernel/environ.cmx kernel/evd.cmx \ kernel/names.cmx lib/stamps.cmx pretyping/tacred.cmx kernel/term.cmx \ lib/util.cmx proofs/proof_type.cmi proofs/refiner.cmo: parsing/ast.cmi kernel/environ.cmi kernel/evd.cmi \ - kernel/generic.cmi kernel/instantiate.cmi proofs/logic.cmi lib/pp.cmi \ - parsing/printer.cmi proofs/proof_trees.cmi proofs/proof_type.cmi \ - kernel/reduction.cmi pretyping/retyping.cmi kernel/sign.cmi \ - lib/stamps.cmi kernel/term.cmi kernel/type_errors.cmi lib/util.cmi \ - proofs/refiner.cmi + kernel/instantiate.cmi proofs/logic.cmi lib/pp.cmi parsing/printer.cmi \ + proofs/proof_trees.cmi proofs/proof_type.cmi kernel/reduction.cmi \ + pretyping/retyping.cmi kernel/sign.cmi lib/stamps.cmi kernel/term.cmi \ + kernel/type_errors.cmi lib/util.cmi proofs/refiner.cmi proofs/refiner.cmx: parsing/ast.cmx kernel/environ.cmx kernel/evd.cmx \ - kernel/generic.cmx kernel/instantiate.cmx proofs/logic.cmx lib/pp.cmx \ - parsing/printer.cmx proofs/proof_trees.cmx proofs/proof_type.cmx \ - kernel/reduction.cmx pretyping/retyping.cmx kernel/sign.cmx \ - lib/stamps.cmx kernel/term.cmx kernel/type_errors.cmx lib/util.cmx \ - proofs/refiner.cmi + kernel/instantiate.cmx proofs/logic.cmx lib/pp.cmx parsing/printer.cmx \ + proofs/proof_trees.cmx proofs/proof_type.cmx kernel/reduction.cmx \ + pretyping/retyping.cmx kernel/sign.cmx lib/stamps.cmx kernel/term.cmx \ + kernel/type_errors.cmx lib/util.cmx proofs/refiner.cmi proofs/stock.cmo: lib/bij.cmi lib/gmap.cmi lib/gmapl.cmi library/library.cmi \ kernel/names.cmi lib/pp.cmi lib/util.cmi proofs/stock.cmi proofs/stock.cmx: lib/bij.cmx lib/gmap.cmx lib/gmapl.cmx library/library.cmx \ kernel/names.cmx lib/pp.cmx lib/util.cmx proofs/stock.cmi proofs/tacinterp.cmo: parsing/ast.cmi parsing/astterm.cmi kernel/closure.cmi \ - parsing/coqast.cmi library/declare.cmi kernel/environ.cmi \ - kernel/generic.cmi lib/gmap.cmi library/lib.cmi library/libobject.cmi \ - proofs/logic.cmi proofs/macros.cmi kernel/names.cmi library/nametab.cmi \ - lib/options.cmi parsing/pattern.cmi lib/pp.cmi proofs/proof_type.cmi \ - pretyping/rawterm.cmi kernel/sign.cmi library/summary.cmi \ - proofs/tacmach.cmi pretyping/tacred.cmi kernel/term.cmi \ - pretyping/typing.cmi lib/util.cmi proofs/tacinterp.cmi + parsing/coqast.cmi library/declare.cmi kernel/environ.cmi lib/gmap.cmi \ + library/lib.cmi library/libobject.cmi proofs/logic.cmi proofs/macros.cmi \ + kernel/names.cmi library/nametab.cmi lib/options.cmi parsing/pattern.cmi \ + lib/pp.cmi proofs/proof_type.cmi pretyping/rawterm.cmi kernel/sign.cmi \ + library/summary.cmi proofs/tacmach.cmi pretyping/tacred.cmi \ + kernel/term.cmi pretyping/typing.cmi lib/util.cmi proofs/tacinterp.cmi proofs/tacinterp.cmx: parsing/ast.cmx parsing/astterm.cmx kernel/closure.cmx \ - parsing/coqast.cmx library/declare.cmx kernel/environ.cmx \ - kernel/generic.cmx lib/gmap.cmx library/lib.cmx library/libobject.cmx \ - proofs/logic.cmx proofs/macros.cmx kernel/names.cmx library/nametab.cmx \ - lib/options.cmx parsing/pattern.cmx lib/pp.cmx proofs/proof_type.cmx \ - pretyping/rawterm.cmx kernel/sign.cmx library/summary.cmx \ - proofs/tacmach.cmx pretyping/tacred.cmx kernel/term.cmx \ - pretyping/typing.cmx lib/util.cmx proofs/tacinterp.cmi + parsing/coqast.cmx library/declare.cmx kernel/environ.cmx lib/gmap.cmx \ + library/lib.cmx library/libobject.cmx proofs/logic.cmx proofs/macros.cmx \ + kernel/names.cmx library/nametab.cmx lib/options.cmx parsing/pattern.cmx \ + lib/pp.cmx proofs/proof_type.cmx pretyping/rawterm.cmx kernel/sign.cmx \ + library/summary.cmx proofs/tacmach.cmx pretyping/tacred.cmx \ + kernel/term.cmx pretyping/typing.cmx lib/util.cmx proofs/tacinterp.cmi proofs/tacmach.cmo: parsing/ast.cmi parsing/astterm.cmi library/declare.cmi \ kernel/environ.cmi proofs/evar_refiner.cmi kernel/evd.cmi \ - kernel/generic.cmi kernel/instantiate.cmi proofs/logic.cmi \ - kernel/names.cmi lib/pp.cmi parsing/printer.cmi proofs/proof_trees.cmi \ - proofs/proof_type.cmi kernel/reduction.cmi proofs/refiner.cmi \ - kernel/sign.cmi lib/stamps.cmi pretyping/tacred.cmi kernel/term.cmi \ - pretyping/typing.cmi lib/util.cmi proofs/tacmach.cmi + kernel/instantiate.cmi proofs/logic.cmi kernel/names.cmi lib/pp.cmi \ + parsing/printer.cmi proofs/proof_trees.cmi proofs/proof_type.cmi \ + kernel/reduction.cmi proofs/refiner.cmi kernel/sign.cmi lib/stamps.cmi \ + pretyping/tacred.cmi kernel/term.cmi pretyping/typing.cmi lib/util.cmi \ + proofs/tacmach.cmi proofs/tacmach.cmx: parsing/ast.cmx parsing/astterm.cmx library/declare.cmx \ kernel/environ.cmx proofs/evar_refiner.cmx kernel/evd.cmx \ - kernel/generic.cmx kernel/instantiate.cmx proofs/logic.cmx \ - kernel/names.cmx lib/pp.cmx parsing/printer.cmx proofs/proof_trees.cmx \ - proofs/proof_type.cmx kernel/reduction.cmx proofs/refiner.cmx \ - kernel/sign.cmx lib/stamps.cmx pretyping/tacred.cmx kernel/term.cmx \ - pretyping/typing.cmx lib/util.cmx proofs/tacmach.cmi -scripts/coqc.cmo: config/coq_config.cmi toplevel/usage.cmi -scripts/coqc.cmx: config/coq_config.cmx toplevel/usage.cmx + kernel/instantiate.cmx proofs/logic.cmx kernel/names.cmx lib/pp.cmx \ + parsing/printer.cmx proofs/proof_trees.cmx proofs/proof_type.cmx \ + kernel/reduction.cmx proofs/refiner.cmx kernel/sign.cmx lib/stamps.cmx \ + pretyping/tacred.cmx kernel/term.cmx pretyping/typing.cmx lib/util.cmx \ + proofs/tacmach.cmi scripts/coqmktop.cmo: config/coq_config.cmi scripts/tolink.cmo scripts/coqmktop.cmx: config/coq_config.cmx scripts/tolink.cmx tactics/auto.cmo: parsing/astterm.cmi tactics/btermdn.cmi proofs/clenv.cmi \ parsing/coqast.cmi library/declare.cmi tactics/dhyp.cmi kernel/evd.cmi \ - kernel/generic.cmi library/global.cmi tactics/hiddentac.cmi \ - tactics/hipattern.cmi kernel/inductive.cmi library/lib.cmi \ - library/libobject.cmi library/library.cmi proofs/logic.cmi \ - kernel/names.cmi lib/options.cmi parsing/pattern.cmi proofs/pfedit.cmi \ - lib/pp.cmi parsing/printer.cmi proofs/proof_type.cmi \ - pretyping/rawterm.cmi kernel/reduction.cmi pretyping/retyping.cmi \ - kernel/sign.cmi library/summary.cmi proofs/tacmach.cmi \ - pretyping/tacred.cmi tactics/tacticals.cmi tactics/tactics.cmi \ - kernel/term.cmi pretyping/typing.cmi lib/util.cmi \ + library/global.cmi tactics/hiddentac.cmi tactics/hipattern.cmi \ + kernel/inductive.cmi library/lib.cmi library/libobject.cmi \ + library/library.cmi proofs/logic.cmi kernel/names.cmi lib/options.cmi \ + parsing/pattern.cmi proofs/pfedit.cmi lib/pp.cmi parsing/printer.cmi \ + proofs/proof_type.cmi pretyping/rawterm.cmi kernel/reduction.cmi \ + pretyping/retyping.cmi kernel/sign.cmi library/summary.cmi \ + proofs/tacmach.cmi pretyping/tacred.cmi tactics/tacticals.cmi \ + tactics/tactics.cmi kernel/term.cmi pretyping/typing.cmi lib/util.cmi \ toplevel/vernacinterp.cmi tactics/auto.cmi tactics/auto.cmx: parsing/astterm.cmx tactics/btermdn.cmx proofs/clenv.cmx \ parsing/coqast.cmx library/declare.cmx tactics/dhyp.cmx kernel/evd.cmx \ - kernel/generic.cmx library/global.cmx tactics/hiddentac.cmx \ - tactics/hipattern.cmx kernel/inductive.cmx library/lib.cmx \ - library/libobject.cmx library/library.cmx proofs/logic.cmx \ - kernel/names.cmx lib/options.cmx parsing/pattern.cmx proofs/pfedit.cmx \ - lib/pp.cmx parsing/printer.cmx proofs/proof_type.cmx \ - pretyping/rawterm.cmx kernel/reduction.cmx pretyping/retyping.cmx \ - kernel/sign.cmx library/summary.cmx proofs/tacmach.cmx \ - pretyping/tacred.cmx tactics/tacticals.cmx tactics/tactics.cmx \ - kernel/term.cmx pretyping/typing.cmx lib/util.cmx \ + library/global.cmx tactics/hiddentac.cmx tactics/hipattern.cmx \ + kernel/inductive.cmx library/lib.cmx library/libobject.cmx \ + library/library.cmx proofs/logic.cmx kernel/names.cmx lib/options.cmx \ + parsing/pattern.cmx proofs/pfedit.cmx lib/pp.cmx parsing/printer.cmx \ + proofs/proof_type.cmx pretyping/rawterm.cmx kernel/reduction.cmx \ + pretyping/retyping.cmx kernel/sign.cmx library/summary.cmx \ + proofs/tacmach.cmx pretyping/tacred.cmx tactics/tacticals.cmx \ + tactics/tactics.cmx kernel/term.cmx pretyping/typing.cmx lib/util.cmx \ toplevel/vernacinterp.cmx tactics/auto.cmi tactics/btermdn.cmo: tactics/dn.cmi parsing/pattern.cmi kernel/term.cmi \ tactics/termdn.cmi tactics/btermdn.cmi tactics/btermdn.cmx: tactics/dn.cmx parsing/pattern.cmx kernel/term.cmx \ tactics/termdn.cmx tactics/btermdn.cmi tactics/dhyp.cmo: parsing/ast.cmi parsing/astterm.cmi proofs/clenv.cmi \ - parsing/coqast.cmi kernel/environ.cmi kernel/evd.cmi kernel/generic.cmi \ - library/global.cmi library/lib.cmi library/libobject.cmi \ - library/library.cmi kernel/names.cmi tactics/nbtermdn.cmi \ - parsing/pattern.cmi parsing/pcoq.cmi lib/pp.cmi proofs/proof_type.cmi \ - pretyping/rawterm.cmi kernel/reduction.cmi library/summary.cmi \ - proofs/tacinterp.cmi proofs/tacmach.cmi tactics/tacticals.cmi \ - tactics/tactics.cmi kernel/term.cmi lib/util.cmi \ - toplevel/vernacinterp.cmi tactics/dhyp.cmi + parsing/coqast.cmi kernel/environ.cmi kernel/evd.cmi library/global.cmi \ + library/lib.cmi library/libobject.cmi library/library.cmi \ + kernel/names.cmi tactics/nbtermdn.cmi parsing/pattern.cmi \ + parsing/pcoq.cmi lib/pp.cmi proofs/proof_type.cmi pretyping/rawterm.cmi \ + kernel/reduction.cmi library/summary.cmi proofs/tacinterp.cmi \ + proofs/tacmach.cmi tactics/tacticals.cmi tactics/tactics.cmi \ + kernel/term.cmi lib/util.cmi toplevel/vernacinterp.cmi tactics/dhyp.cmi tactics/dhyp.cmx: parsing/ast.cmx parsing/astterm.cmx proofs/clenv.cmx \ - parsing/coqast.cmx kernel/environ.cmx kernel/evd.cmx kernel/generic.cmx \ - library/global.cmx library/lib.cmx library/libobject.cmx \ - library/library.cmx kernel/names.cmx tactics/nbtermdn.cmx \ - parsing/pattern.cmx parsing/pcoq.cmx lib/pp.cmx proofs/proof_type.cmx \ - pretyping/rawterm.cmx kernel/reduction.cmx library/summary.cmx \ - proofs/tacinterp.cmx proofs/tacmach.cmx tactics/tacticals.cmx \ - tactics/tactics.cmx kernel/term.cmx lib/util.cmx \ - toplevel/vernacinterp.cmx tactics/dhyp.cmi + parsing/coqast.cmx kernel/environ.cmx kernel/evd.cmx library/global.cmx \ + library/lib.cmx library/libobject.cmx library/library.cmx \ + kernel/names.cmx tactics/nbtermdn.cmx parsing/pattern.cmx \ + parsing/pcoq.cmx lib/pp.cmx proofs/proof_type.cmx pretyping/rawterm.cmx \ + kernel/reduction.cmx library/summary.cmx proofs/tacinterp.cmx \ + proofs/tacmach.cmx tactics/tacticals.cmx tactics/tactics.cmx \ + kernel/term.cmx lib/util.cmx toplevel/vernacinterp.cmx tactics/dhyp.cmi tactics/dn.cmo: lib/tlm.cmi tactics/dn.cmi tactics/dn.cmx: lib/tlm.cmx tactics/dn.cmi tactics/eauto.cmo: tactics/auto.cmi proofs/clenv.cmi kernel/evd.cmi \ - kernel/generic.cmi kernel/instantiate.cmi kernel/names.cmi \ - parsing/pattern.cmi lib/pp.cmi proofs/proof_trees.cmi \ - proofs/proof_type.cmi kernel/reduction.cmi kernel/sign.cmi \ - proofs/tacmach.cmi tactics/tacticals.cmi tactics/tactics.cmi \ - kernel/term.cmi lib/util.cmi + kernel/instantiate.cmi kernel/names.cmi parsing/pattern.cmi lib/pp.cmi \ + proofs/proof_trees.cmi proofs/proof_type.cmi kernel/reduction.cmi \ + kernel/sign.cmi proofs/tacmach.cmi tactics/tacticals.cmi \ + tactics/tactics.cmi kernel/term.cmi lib/util.cmi tactics/eauto.cmx: tactics/auto.cmx proofs/clenv.cmx kernel/evd.cmx \ - kernel/generic.cmx kernel/instantiate.cmx kernel/names.cmx \ - parsing/pattern.cmx lib/pp.cmx proofs/proof_trees.cmx \ - proofs/proof_type.cmx kernel/reduction.cmx kernel/sign.cmx \ - proofs/tacmach.cmx tactics/tacticals.cmx tactics/tactics.cmx \ - kernel/term.cmx lib/util.cmx -tactics/elim.cmo: proofs/clenv.cmi kernel/generic.cmi tactics/hiddentac.cmi \ + kernel/instantiate.cmx kernel/names.cmx parsing/pattern.cmx lib/pp.cmx \ + proofs/proof_trees.cmx proofs/proof_type.cmx kernel/reduction.cmx \ + kernel/sign.cmx proofs/tacmach.cmx tactics/tacticals.cmx \ + tactics/tactics.cmx kernel/term.cmx lib/util.cmx +tactics/elim.cmo: proofs/clenv.cmi tactics/hiddentac.cmi \ tactics/hipattern.cmi kernel/inductive.cmi kernel/names.cmi lib/pp.cmi \ proofs/proof_type.cmi kernel/reduction.cmi proofs/tacmach.cmi \ tactics/tacticals.cmi tactics/tactics.cmi kernel/term.cmi lib/util.cmi \ tactics/elim.cmi -tactics/elim.cmx: proofs/clenv.cmx kernel/generic.cmx tactics/hiddentac.cmx \ +tactics/elim.cmx: proofs/clenv.cmx tactics/hiddentac.cmx \ tactics/hipattern.cmx kernel/inductive.cmx kernel/names.cmx lib/pp.cmx \ proofs/proof_type.cmx kernel/reduction.cmx proofs/tacmach.cmx \ tactics/tacticals.cmx tactics/tactics.cmx kernel/term.cmx lib/util.cmx \ tactics/elim.cmi tactics/equality.cmo: parsing/astterm.cmi parsing/coqast.cmi \ - library/declare.cmi kernel/environ.cmi kernel/evd.cmi kernel/generic.cmi \ - library/global.cmi lib/gmapl.cmi tactics/hipattern.cmi \ - kernel/inductive.cmi kernel/instantiate.cmi library/lib.cmi \ - library/libobject.cmi proofs/logic.cmi kernel/names.cmi \ - parsing/pattern.cmi lib/pp.cmi proofs/proof_type.cmi kernel/reduction.cmi \ - pretyping/retyping.cmi library/summary.cmi proofs/tacinterp.cmi \ - proofs/tacmach.cmi pretyping/tacred.cmi tactics/tacticals.cmi \ - tactics/tactics.cmi kernel/term.cmi kernel/typeops.cmi \ - pretyping/typing.cmi kernel/univ.cmi lib/util.cmi \ - toplevel/vernacinterp.cmi tactics/wcclausenv.cmi tactics/equality.cmi + library/declare.cmi kernel/environ.cmi kernel/evd.cmi library/global.cmi \ + lib/gmapl.cmi tactics/hipattern.cmi kernel/inductive.cmi \ + kernel/instantiate.cmi library/lib.cmi library/libobject.cmi \ + proofs/logic.cmi kernel/names.cmi parsing/pattern.cmi lib/pp.cmi \ + proofs/proof_type.cmi kernel/reduction.cmi pretyping/retyping.cmi \ + library/summary.cmi proofs/tacinterp.cmi proofs/tacmach.cmi \ + pretyping/tacred.cmi tactics/tacticals.cmi tactics/tactics.cmi \ + kernel/term.cmi kernel/typeops.cmi pretyping/typing.cmi kernel/univ.cmi \ + lib/util.cmi toplevel/vernacinterp.cmi tactics/wcclausenv.cmi \ + tactics/equality.cmi tactics/equality.cmx: parsing/astterm.cmx parsing/coqast.cmx \ - library/declare.cmx kernel/environ.cmx kernel/evd.cmx kernel/generic.cmx \ - library/global.cmx lib/gmapl.cmx tactics/hipattern.cmx \ - kernel/inductive.cmx kernel/instantiate.cmx library/lib.cmx \ - library/libobject.cmx proofs/logic.cmx kernel/names.cmx \ - parsing/pattern.cmx lib/pp.cmx proofs/proof_type.cmx kernel/reduction.cmx \ - pretyping/retyping.cmx library/summary.cmx proofs/tacinterp.cmx \ - proofs/tacmach.cmx pretyping/tacred.cmx tactics/tacticals.cmx \ - tactics/tactics.cmx kernel/term.cmx kernel/typeops.cmx \ - pretyping/typing.cmx kernel/univ.cmx lib/util.cmx \ - toplevel/vernacinterp.cmx tactics/wcclausenv.cmx tactics/equality.cmi + library/declare.cmx kernel/environ.cmx kernel/evd.cmx library/global.cmx \ + lib/gmapl.cmx tactics/hipattern.cmx kernel/inductive.cmx \ + kernel/instantiate.cmx library/lib.cmx library/libobject.cmx \ + proofs/logic.cmx kernel/names.cmx parsing/pattern.cmx lib/pp.cmx \ + proofs/proof_type.cmx kernel/reduction.cmx pretyping/retyping.cmx \ + library/summary.cmx proofs/tacinterp.cmx proofs/tacmach.cmx \ + pretyping/tacred.cmx tactics/tacticals.cmx tactics/tactics.cmx \ + kernel/term.cmx kernel/typeops.cmx pretyping/typing.cmx kernel/univ.cmx \ + lib/util.cmx toplevel/vernacinterp.cmx tactics/wcclausenv.cmx \ + tactics/equality.cmi tactics/hiddentac.cmo: proofs/proof_type.cmi tactics/tacentries.cmi \ proofs/tacmach.cmi kernel/term.cmi tactics/hiddentac.cmi tactics/hiddentac.cmx: proofs/proof_type.cmx tactics/tacentries.cmx \ proofs/tacmach.cmx kernel/term.cmx tactics/hiddentac.cmi tactics/hipattern.cmo: parsing/astterm.cmi proofs/clenv.cmi \ - library/declare.cmi kernel/environ.cmi kernel/evd.cmi kernel/generic.cmi \ - library/global.cmi kernel/inductive.cmi library/library.cmi \ - kernel/names.cmi parsing/pattern.cmi parsing/pcoq.cmi lib/pp.cmi \ - parsing/printer.cmi proofs/proof_trees.cmi kernel/reduction.cmi \ - kernel/sosub.cmi proofs/stock.cmi kernel/term.cmi lib/util.cmi \ - tactics/hipattern.cmi + library/declare.cmi kernel/environ.cmi kernel/evd.cmi library/global.cmi \ + kernel/inductive.cmi library/library.cmi kernel/names.cmi \ + parsing/pattern.cmi parsing/pcoq.cmi lib/pp.cmi parsing/printer.cmi \ + proofs/proof_trees.cmi kernel/reduction.cmi kernel/sosub.cmi \ + proofs/stock.cmi kernel/term.cmi lib/util.cmi tactics/hipattern.cmi tactics/hipattern.cmx: parsing/astterm.cmx proofs/clenv.cmx \ - library/declare.cmx kernel/environ.cmx kernel/evd.cmx kernel/generic.cmx \ - library/global.cmx kernel/inductive.cmx library/library.cmx \ - kernel/names.cmx parsing/pattern.cmx parsing/pcoq.cmx lib/pp.cmx \ - parsing/printer.cmx proofs/proof_trees.cmx kernel/reduction.cmx \ - kernel/sosub.cmx proofs/stock.cmx kernel/term.cmx lib/util.cmx \ - tactics/hipattern.cmi + library/declare.cmx kernel/environ.cmx kernel/evd.cmx library/global.cmx \ + kernel/inductive.cmx library/library.cmx kernel/names.cmx \ + parsing/pattern.cmx parsing/pcoq.cmx lib/pp.cmx parsing/printer.cmx \ + proofs/proof_trees.cmx kernel/reduction.cmx kernel/sosub.cmx \ + proofs/stock.cmx kernel/term.cmx lib/util.cmx tactics/hipattern.cmi tactics/inv.cmo: tactics/auto.cmi proofs/clenv.cmi tactics/elim.cmi \ - kernel/environ.cmi tactics/equality.cmi kernel/evd.cmi kernel/generic.cmi \ - library/global.cmi kernel/inductive.cmi kernel/names.cmi \ - parsing/pattern.cmi lib/pp.cmi parsing/printer.cmi proofs/proof_type.cmi \ - kernel/reduction.cmi pretyping/retyping.cmi kernel/sign.cmi \ - proofs/tacmach.cmi tactics/tacticals.cmi tactics/tactics.cmi \ - kernel/term.cmi pretyping/typing.cmi lib/util.cmi tactics/wcclausenv.cmi \ - tactics/inv.cmi + kernel/environ.cmi tactics/equality.cmi kernel/evd.cmi library/global.cmi \ + kernel/inductive.cmi kernel/names.cmi parsing/pattern.cmi lib/pp.cmi \ + parsing/printer.cmi proofs/proof_type.cmi kernel/reduction.cmi \ + pretyping/retyping.cmi kernel/sign.cmi proofs/tacmach.cmi \ + tactics/tacticals.cmi tactics/tactics.cmi kernel/term.cmi \ + pretyping/typing.cmi lib/util.cmi tactics/wcclausenv.cmi tactics/inv.cmi tactics/inv.cmx: tactics/auto.cmx proofs/clenv.cmx tactics/elim.cmx \ - kernel/environ.cmx tactics/equality.cmx kernel/evd.cmx kernel/generic.cmx \ - library/global.cmx kernel/inductive.cmx kernel/names.cmx \ - parsing/pattern.cmx lib/pp.cmx parsing/printer.cmx proofs/proof_type.cmx \ - kernel/reduction.cmx pretyping/retyping.cmx kernel/sign.cmx \ - proofs/tacmach.cmx tactics/tacticals.cmx tactics/tactics.cmx \ - kernel/term.cmx pretyping/typing.cmx lib/util.cmx tactics/wcclausenv.cmx \ - tactics/inv.cmi + kernel/environ.cmx tactics/equality.cmx kernel/evd.cmx library/global.cmx \ + kernel/inductive.cmx kernel/names.cmx parsing/pattern.cmx lib/pp.cmx \ + parsing/printer.cmx proofs/proof_type.cmx kernel/reduction.cmx \ + pretyping/retyping.cmx kernel/sign.cmx proofs/tacmach.cmx \ + tactics/tacticals.cmx tactics/tactics.cmx kernel/term.cmx \ + pretyping/typing.cmx lib/util.cmx tactics/wcclausenv.cmx tactics/inv.cmi tactics/leminv.cmo: parsing/astterm.cmi proofs/clenv.cmi \ kernel/declarations.cmi library/declare.cmi kernel/environ.cmi \ - kernel/evd.cmi kernel/generic.cmi library/global.cmi kernel/inductive.cmi \ - tactics/inv.cmi kernel/names.cmi proofs/pfedit.cmi lib/pp.cmi \ - parsing/printer.cmi proofs/proof_trees.cmi proofs/proof_type.cmi \ - kernel/reduction.cmi pretyping/retyping.cmi kernel/sign.cmi \ - proofs/tacmach.cmi tactics/tacticals.cmi tactics/tactics.cmi \ - kernel/term.cmi lib/util.cmi toplevel/vernacinterp.cmi \ - tactics/wcclausenv.cmi + kernel/evd.cmi library/global.cmi kernel/inductive.cmi tactics/inv.cmi \ + kernel/names.cmi proofs/pfedit.cmi lib/pp.cmi parsing/printer.cmi \ + proofs/proof_trees.cmi proofs/proof_type.cmi kernel/reduction.cmi \ + pretyping/retyping.cmi kernel/sign.cmi proofs/tacmach.cmi \ + tactics/tacticals.cmi tactics/tactics.cmi kernel/term.cmi lib/util.cmi \ + toplevel/vernacinterp.cmi tactics/wcclausenv.cmi tactics/leminv.cmx: parsing/astterm.cmx proofs/clenv.cmx \ kernel/declarations.cmx library/declare.cmx kernel/environ.cmx \ - kernel/evd.cmx kernel/generic.cmx library/global.cmx kernel/inductive.cmx \ - tactics/inv.cmx kernel/names.cmx proofs/pfedit.cmx lib/pp.cmx \ - parsing/printer.cmx proofs/proof_trees.cmx proofs/proof_type.cmx \ - kernel/reduction.cmx pretyping/retyping.cmx kernel/sign.cmx \ - proofs/tacmach.cmx tactics/tacticals.cmx tactics/tactics.cmx \ - kernel/term.cmx lib/util.cmx toplevel/vernacinterp.cmx \ - tactics/wcclausenv.cmx -tactics/nbtermdn.cmo: tactics/btermdn.cmi kernel/generic.cmi lib/gmap.cmi \ - library/libobject.cmi library/library.cmi kernel/names.cmi \ - parsing/pattern.cmi kernel/term.cmi tactics/termdn.cmi lib/util.cmi \ - tactics/nbtermdn.cmi -tactics/nbtermdn.cmx: tactics/btermdn.cmx kernel/generic.cmx lib/gmap.cmx \ - library/libobject.cmx library/library.cmx kernel/names.cmx \ - parsing/pattern.cmx kernel/term.cmx tactics/termdn.cmx lib/util.cmx \ - tactics/nbtermdn.cmi + kernel/evd.cmx library/global.cmx kernel/inductive.cmx tactics/inv.cmx \ + kernel/names.cmx proofs/pfedit.cmx lib/pp.cmx parsing/printer.cmx \ + proofs/proof_trees.cmx proofs/proof_type.cmx kernel/reduction.cmx \ + pretyping/retyping.cmx kernel/sign.cmx proofs/tacmach.cmx \ + tactics/tacticals.cmx tactics/tactics.cmx kernel/term.cmx lib/util.cmx \ + toplevel/vernacinterp.cmx tactics/wcclausenv.cmx +tactics/nbtermdn.cmo: tactics/btermdn.cmi lib/gmap.cmi library/libobject.cmi \ + library/library.cmi kernel/names.cmi parsing/pattern.cmi kernel/term.cmi \ + tactics/termdn.cmi lib/util.cmi tactics/nbtermdn.cmi +tactics/nbtermdn.cmx: tactics/btermdn.cmx lib/gmap.cmx library/libobject.cmx \ + library/library.cmx kernel/names.cmx parsing/pattern.cmx kernel/term.cmx \ + tactics/termdn.cmx lib/util.cmx tactics/nbtermdn.cmi tactics/refine.cmo: parsing/astterm.cmi kernel/environ.cmi kernel/evd.cmi \ - kernel/generic.cmi kernel/names.cmi lib/pp.cmi pretyping/pretyping.cmi \ - parsing/printer.cmi proofs/proof_type.cmi kernel/reduction.cmi \ - pretyping/retyping.cmi kernel/sign.cmi proofs/tacmach.cmi \ - tactics/tacticals.cmi tactics/tactics.cmi kernel/term.cmi \ - pretyping/typing.cmi lib/util.cmi tactics/refine.cmi + kernel/names.cmi lib/pp.cmi pretyping/pretyping.cmi parsing/printer.cmi \ + proofs/proof_type.cmi kernel/reduction.cmi pretyping/retyping.cmi \ + kernel/sign.cmi proofs/tacmach.cmi tactics/tacticals.cmi \ + tactics/tactics.cmi kernel/term.cmi pretyping/typing.cmi lib/util.cmi \ + tactics/refine.cmi tactics/refine.cmx: parsing/astterm.cmx kernel/environ.cmx kernel/evd.cmx \ - kernel/generic.cmx kernel/names.cmx lib/pp.cmx pretyping/pretyping.cmx \ - parsing/printer.cmx proofs/proof_type.cmx kernel/reduction.cmx \ - pretyping/retyping.cmx kernel/sign.cmx proofs/tacmach.cmx \ - tactics/tacticals.cmx tactics/tactics.cmx kernel/term.cmx \ - pretyping/typing.cmx lib/util.cmx tactics/refine.cmi + kernel/names.cmx lib/pp.cmx pretyping/pretyping.cmx parsing/printer.cmx \ + proofs/proof_type.cmx kernel/reduction.cmx pretyping/retyping.cmx \ + kernel/sign.cmx proofs/tacmach.cmx tactics/tacticals.cmx \ + tactics/tactics.cmx kernel/term.cmx pretyping/typing.cmx lib/util.cmx \ + tactics/refine.cmi tactics/tacentries.cmo: proofs/proof_trees.cmi proofs/tacmach.cmi \ tactics/tacticals.cmi tactics/tactics.cmi tactics/tacentries.cmi tactics/tacentries.cmx: proofs/proof_trees.cmx proofs/tacmach.cmx \ tactics/tacticals.cmx tactics/tactics.cmx tactics/tacentries.cmi tactics/tacticals.cmo: proofs/clenv.cmi parsing/coqast.cmi \ kernel/declarations.cmi library/declare.cmi kernel/environ.cmi \ - kernel/evd.cmi kernel/generic.cmi library/global.cmi library/indrec.cmi \ - kernel/inductive.cmi kernel/names.cmi parsing/pattern.cmi lib/pp.cmi \ - parsing/pretty.cmi kernel/reduction.cmi kernel/sign.cmi lib/stamps.cmi \ - proofs/tacinterp.cmi proofs/tacmach.cmi kernel/term.cmi \ - parsing/termast.cmi lib/util.cmi tactics/wcclausenv.cmi \ - tactics/tacticals.cmi + kernel/evd.cmi library/global.cmi library/indrec.cmi kernel/inductive.cmi \ + kernel/names.cmi parsing/pattern.cmi lib/pp.cmi parsing/pretty.cmi \ + kernel/reduction.cmi kernel/sign.cmi lib/stamps.cmi proofs/tacinterp.cmi \ + proofs/tacmach.cmi kernel/term.cmi parsing/termast.cmi lib/util.cmi \ + tactics/wcclausenv.cmi tactics/tacticals.cmi tactics/tacticals.cmx: proofs/clenv.cmx parsing/coqast.cmx \ kernel/declarations.cmx library/declare.cmx kernel/environ.cmx \ - kernel/evd.cmx kernel/generic.cmx library/global.cmx library/indrec.cmx \ - kernel/inductive.cmx kernel/names.cmx parsing/pattern.cmx lib/pp.cmx \ - parsing/pretty.cmx kernel/reduction.cmx kernel/sign.cmx lib/stamps.cmx \ - proofs/tacinterp.cmx proofs/tacmach.cmx kernel/term.cmx \ - parsing/termast.cmx lib/util.cmx tactics/wcclausenv.cmx \ - tactics/tacticals.cmi + kernel/evd.cmx library/global.cmx library/indrec.cmx kernel/inductive.cmx \ + kernel/names.cmx parsing/pattern.cmx lib/pp.cmx parsing/pretty.cmx \ + kernel/reduction.cmx kernel/sign.cmx lib/stamps.cmx proofs/tacinterp.cmx \ + proofs/tacmach.cmx kernel/term.cmx parsing/termast.cmx lib/util.cmx \ + tactics/wcclausenv.cmx tactics/tacticals.cmi tactics/tactics.cmo: parsing/ast.cmi parsing/astterm.cmi proofs/clenv.cmi \ - library/declare.cmi kernel/environ.cmi kernel/evd.cmi kernel/generic.cmi \ - library/global.cmi tactics/hipattern.cmi library/indrec.cmi \ - kernel/inductive.cmi proofs/logic.cmi kernel/names.cmi proofs/pfedit.cmi \ - lib/pp.cmi proofs/proof_trees.cmi proofs/proof_type.cmi \ - kernel/reduction.cmi kernel/sign.cmi lib/stamps.cmi proofs/tacinterp.cmi \ - proofs/tacmach.cmi pretyping/tacred.cmi tactics/tacticals.cmi \ - kernel/term.cmi lib/util.cmi tactics/tactics.cmi + library/declare.cmi kernel/environ.cmi kernel/evd.cmi library/global.cmi \ + tactics/hipattern.cmi library/indrec.cmi kernel/inductive.cmi \ + proofs/logic.cmi kernel/names.cmi proofs/pfedit.cmi lib/pp.cmi \ + proofs/proof_trees.cmi proofs/proof_type.cmi kernel/reduction.cmi \ + kernel/sign.cmi lib/stamps.cmi proofs/tacinterp.cmi proofs/tacmach.cmi \ + pretyping/tacred.cmi tactics/tacticals.cmi kernel/term.cmi lib/util.cmi \ + tactics/tactics.cmi tactics/tactics.cmx: parsing/ast.cmx parsing/astterm.cmx proofs/clenv.cmx \ - library/declare.cmx kernel/environ.cmx kernel/evd.cmx kernel/generic.cmx \ - library/global.cmx tactics/hipattern.cmx library/indrec.cmx \ - kernel/inductive.cmx proofs/logic.cmx kernel/names.cmx proofs/pfedit.cmx \ - lib/pp.cmx proofs/proof_trees.cmx proofs/proof_type.cmx \ - kernel/reduction.cmx kernel/sign.cmx lib/stamps.cmx proofs/tacinterp.cmx \ - proofs/tacmach.cmx pretyping/tacred.cmx tactics/tacticals.cmx \ - kernel/term.cmx lib/util.cmx tactics/tactics.cmi + library/declare.cmx kernel/environ.cmx kernel/evd.cmx library/global.cmx \ + tactics/hipattern.cmx library/indrec.cmx kernel/inductive.cmx \ + proofs/logic.cmx kernel/names.cmx proofs/pfedit.cmx lib/pp.cmx \ + proofs/proof_trees.cmx proofs/proof_type.cmx kernel/reduction.cmx \ + kernel/sign.cmx lib/stamps.cmx proofs/tacinterp.cmx proofs/tacmach.cmx \ + pretyping/tacred.cmx tactics/tacticals.cmx kernel/term.cmx lib/util.cmx \ + tactics/tactics.cmi tactics/tauto.cmo: tactics/auto.cmi proofs/clenv.cmi library/declare.cmi \ - kernel/environ.cmi kernel/generic.cmi tactics/hipattern.cmi \ - kernel/names.cmi library/nametab.cmi parsing/pattern.cmi lib/pp.cmi \ - proofs/proof_trees.cmi kernel/reduction.cmi pretyping/retyping.cmi \ - kernel/sign.cmi proofs/tacmach.cmi tactics/tacticals.cmi \ - tactics/tactics.cmi kernel/term.cmi lib/util.cmi tactics/tauto.cmi + kernel/environ.cmi tactics/hipattern.cmi kernel/names.cmi \ + library/nametab.cmi parsing/pattern.cmi lib/pp.cmi proofs/proof_trees.cmi \ + kernel/reduction.cmi pretyping/retyping.cmi kernel/sign.cmi \ + proofs/tacmach.cmi tactics/tacticals.cmi tactics/tactics.cmi \ + kernel/term.cmi lib/util.cmi tactics/tauto.cmi tactics/tauto.cmx: tactics/auto.cmx proofs/clenv.cmx library/declare.cmx \ - kernel/environ.cmx kernel/generic.cmx tactics/hipattern.cmx \ - kernel/names.cmx library/nametab.cmx parsing/pattern.cmx lib/pp.cmx \ - proofs/proof_trees.cmx kernel/reduction.cmx pretyping/retyping.cmx \ - kernel/sign.cmx proofs/tacmach.cmx tactics/tacticals.cmx \ - tactics/tactics.cmx kernel/term.cmx lib/util.cmx tactics/tauto.cmi -tactics/termdn.cmo: tactics/dn.cmi kernel/generic.cmi kernel/names.cmi \ - parsing/pattern.cmi kernel/term.cmi lib/util.cmi tactics/termdn.cmi -tactics/termdn.cmx: tactics/dn.cmx kernel/generic.cmx kernel/names.cmx \ - parsing/pattern.cmx kernel/term.cmx lib/util.cmx tactics/termdn.cmi + kernel/environ.cmx tactics/hipattern.cmx kernel/names.cmx \ + library/nametab.cmx parsing/pattern.cmx lib/pp.cmx proofs/proof_trees.cmx \ + kernel/reduction.cmx pretyping/retyping.cmx kernel/sign.cmx \ + proofs/tacmach.cmx tactics/tacticals.cmx tactics/tactics.cmx \ + kernel/term.cmx lib/util.cmx tactics/tauto.cmi +tactics/termdn.cmo: tactics/dn.cmi kernel/names.cmi parsing/pattern.cmi \ + kernel/term.cmi lib/util.cmi tactics/termdn.cmi +tactics/termdn.cmx: tactics/dn.cmx kernel/names.cmx parsing/pattern.cmx \ + kernel/term.cmx lib/util.cmx tactics/termdn.cmi tactics/wcclausenv.cmo: proofs/clenv.cmi kernel/environ.cmi kernel/evd.cmi \ - kernel/generic.cmi library/global.cmi proofs/logic.cmi kernel/names.cmi \ - lib/pp.cmi proofs/proof_trees.cmi kernel/reduction.cmi \ - pretyping/retyping.cmi kernel/sign.cmi proofs/tacmach.cmi kernel/term.cmi \ - lib/util.cmi tactics/wcclausenv.cmi + library/global.cmi proofs/logic.cmi kernel/names.cmi lib/pp.cmi \ + proofs/proof_trees.cmi kernel/reduction.cmi pretyping/retyping.cmi \ + kernel/sign.cmi proofs/tacmach.cmi kernel/term.cmi lib/util.cmi \ + tactics/wcclausenv.cmi tactics/wcclausenv.cmx: proofs/clenv.cmx kernel/environ.cmx kernel/evd.cmx \ - kernel/generic.cmx library/global.cmx proofs/logic.cmx kernel/names.cmx \ - lib/pp.cmx proofs/proof_trees.cmx kernel/reduction.cmx \ - pretyping/retyping.cmx kernel/sign.cmx proofs/tacmach.cmx kernel/term.cmx \ - lib/util.cmx tactics/wcclausenv.cmi -tools/coqdep_lexer.cmo: config/coq_config.cmi -tools/coqdep_lexer.cmx: config/coq_config.cmx -tools/coqdep.cmo: config/coq_config.cmi tools/coqdep_lexer.cmo -tools/coqdep.cmx: config/coq_config.cmx tools/coqdep_lexer.cmx + library/global.cmx proofs/logic.cmx kernel/names.cmx lib/pp.cmx \ + proofs/proof_trees.cmx kernel/reduction.cmx pretyping/retyping.cmx \ + kernel/sign.cmx proofs/tacmach.cmx kernel/term.cmx lib/util.cmx \ + tactics/wcclausenv.cmi +tools/coqdep.cmo: config/coq_config.cmi +tools/coqdep.cmx: config/coq_config.cmx toplevel/command.cmo: parsing/ast.cmi parsing/astterm.cmi parsing/coqast.cmi \ kernel/declarations.cmi library/declare.cmi kernel/environ.cmi \ - kernel/evd.cmi kernel/generic.cmi library/global.cmi library/indrec.cmi \ - kernel/inductive.cmi library/lib.cmi library/libobject.cmi \ - library/library.cmi proofs/logic.cmi kernel/names.cmi lib/options.cmi \ - proofs/pfedit.cmi lib/pp.cmi kernel/reduction.cmi library/states.cmi \ + kernel/evd.cmi library/global.cmi library/indrec.cmi kernel/inductive.cmi \ + library/lib.cmi library/libobject.cmi library/library.cmi \ + proofs/logic.cmi kernel/names.cmi lib/options.cmi proofs/pfedit.cmi \ + lib/pp.cmi kernel/reduction.cmi library/states.cmi \ pretyping/syntax_def.cmi pretyping/tacred.cmi kernel/term.cmi \ - lib/util.cmi toplevel/command.cmi + kernel/typeops.cmi lib/util.cmi toplevel/command.cmi toplevel/command.cmx: parsing/ast.cmx parsing/astterm.cmx parsing/coqast.cmx \ kernel/declarations.cmx library/declare.cmx kernel/environ.cmx \ - kernel/evd.cmx kernel/generic.cmx library/global.cmx library/indrec.cmx \ - kernel/inductive.cmx library/lib.cmx library/libobject.cmx \ - library/library.cmx proofs/logic.cmx kernel/names.cmx lib/options.cmx \ - proofs/pfedit.cmx lib/pp.cmx kernel/reduction.cmx library/states.cmx \ + kernel/evd.cmx library/global.cmx library/indrec.cmx kernel/inductive.cmx \ + library/lib.cmx library/libobject.cmx library/library.cmx \ + proofs/logic.cmx kernel/names.cmx lib/options.cmx proofs/pfedit.cmx \ + lib/pp.cmx kernel/reduction.cmx library/states.cmx \ pretyping/syntax_def.cmx pretyping/tacred.cmx kernel/term.cmx \ - lib/util.cmx toplevel/command.cmi -toplevel/coqinit.cmo: config/coq_config.cmi toplevel/mltop.cmi \ - lib/options.cmi lib/pp.cmi lib/system.cmi toplevel/toplevel.cmi \ - toplevel/vernac.cmi toplevel/coqinit.cmi -toplevel/coqinit.cmx: config/coq_config.cmx toplevel/mltop.cmi \ - lib/options.cmx lib/pp.cmx lib/system.cmx toplevel/toplevel.cmx \ - toplevel/vernac.cmx toplevel/coqinit.cmi + kernel/typeops.cmx lib/util.cmx toplevel/command.cmi +toplevel/coqinit.cmo: config/coq_config.cmi library/library.cmi \ + toplevel/mltop.cmi lib/options.cmi lib/pp.cmi lib/system.cmi \ + toplevel/toplevel.cmi toplevel/vernac.cmi toplevel/coqinit.cmi +toplevel/coqinit.cmx: config/coq_config.cmx library/library.cmx \ + toplevel/mltop.cmi lib/options.cmx lib/pp.cmx lib/system.cmx \ + toplevel/toplevel.cmx toplevel/vernac.cmx toplevel/coqinit.cmi toplevel/coqtop.cmo: config/coq_config.cmi toplevel/coqinit.cmi \ toplevel/errors.cmi library/lib.cmi library/library.cmi \ toplevel/mltop.cmi lib/options.cmi lib/pp.cmi lib/profile.cmi \ @@ -1034,14 +983,14 @@ toplevel/coqtop.cmx: config/coq_config.cmx toplevel/coqinit.cmx \ toplevel/usage.cmx lib/util.cmx toplevel/vernac.cmx toplevel/coqtop.cmi toplevel/discharge.cmo: pretyping/class.cmi pretyping/classops.cmi \ kernel/declarations.cmi library/declare.cmi kernel/environ.cmi \ - kernel/evd.cmi kernel/generic.cmi library/global.cmi kernel/inductive.cmi \ + kernel/evd.cmi library/global.cmi kernel/inductive.cmi \ kernel/instantiate.cmi library/lib.cmi library/libobject.cmi \ kernel/names.cmi lib/options.cmi lib/pp.cmi pretyping/recordops.cmi \ kernel/reduction.cmi kernel/sign.cmi kernel/term.cmi kernel/typeops.cmi \ lib/util.cmi toplevel/discharge.cmi toplevel/discharge.cmx: pretyping/class.cmx pretyping/classops.cmx \ kernel/declarations.cmx library/declare.cmx kernel/environ.cmx \ - kernel/evd.cmx kernel/generic.cmx library/global.cmx kernel/inductive.cmx \ + kernel/evd.cmx library/global.cmx kernel/inductive.cmx \ kernel/instantiate.cmx library/lib.cmx library/libobject.cmx \ kernel/names.cmx lib/options.cmx lib/pp.cmx pretyping/recordops.cmx \ kernel/reduction.cmx kernel/sign.cmx kernel/term.cmx kernel/typeops.cmx \ @@ -1055,25 +1004,23 @@ toplevel/errors.cmx: parsing/ast.cmx toplevel/himsg.cmx kernel/indtypes.cmx \ proofs/tacmach.cmx kernel/type_errors.cmx lib/util.cmx \ toplevel/errors.cmi toplevel/fhimsg.cmo: kernel/environ.cmi parsing/g_minicoq.cmi \ - kernel/generic.cmi kernel/names.cmi lib/pp.cmi kernel/reduction.cmi \ - kernel/sign.cmi kernel/term.cmi kernel/type_errors.cmi lib/util.cmi \ - toplevel/fhimsg.cmi + kernel/names.cmi lib/pp.cmi kernel/reduction.cmi kernel/sign.cmi \ + kernel/term.cmi kernel/type_errors.cmi lib/util.cmi toplevel/fhimsg.cmi toplevel/fhimsg.cmx: kernel/environ.cmx parsing/g_minicoq.cmi \ - kernel/generic.cmx kernel/names.cmx lib/pp.cmx kernel/reduction.cmx \ - kernel/sign.cmx kernel/term.cmx kernel/type_errors.cmx lib/util.cmx \ - toplevel/fhimsg.cmi -toplevel/himsg.cmo: parsing/ast.cmi kernel/environ.cmi kernel/generic.cmi \ - library/global.cmi kernel/indtypes.cmi kernel/inductive.cmi \ - proofs/logic.cmi kernel/names.cmi lib/options.cmi lib/pp.cmi \ - parsing/pretty.cmi parsing/printer.cmi kernel/reduction.cmi \ - kernel/sign.cmi proofs/tacmach.cmi kernel/term.cmi kernel/type_errors.cmi \ - lib/util.cmi toplevel/himsg.cmi -toplevel/himsg.cmx: parsing/ast.cmx kernel/environ.cmx kernel/generic.cmx \ - library/global.cmx kernel/indtypes.cmx kernel/inductive.cmx \ - proofs/logic.cmx kernel/names.cmx lib/options.cmx lib/pp.cmx \ - parsing/pretty.cmx parsing/printer.cmx kernel/reduction.cmx \ - kernel/sign.cmx proofs/tacmach.cmx kernel/term.cmx kernel/type_errors.cmx \ - lib/util.cmx toplevel/himsg.cmi + kernel/names.cmx lib/pp.cmx kernel/reduction.cmx kernel/sign.cmx \ + kernel/term.cmx kernel/type_errors.cmx lib/util.cmx toplevel/fhimsg.cmi +toplevel/himsg.cmo: parsing/ast.cmi kernel/environ.cmi library/global.cmi \ + kernel/indtypes.cmi kernel/inductive.cmi proofs/logic.cmi \ + kernel/names.cmi lib/options.cmi lib/pp.cmi parsing/pretty.cmi \ + parsing/printer.cmi kernel/reduction.cmi kernel/sign.cmi \ + proofs/tacmach.cmi kernel/term.cmi kernel/type_errors.cmi lib/util.cmi \ + toplevel/himsg.cmi +toplevel/himsg.cmx: parsing/ast.cmx kernel/environ.cmx library/global.cmx \ + kernel/indtypes.cmx kernel/inductive.cmx proofs/logic.cmx \ + kernel/names.cmx lib/options.cmx lib/pp.cmx parsing/pretty.cmx \ + parsing/printer.cmx kernel/reduction.cmx kernel/sign.cmx \ + proofs/tacmach.cmx kernel/term.cmx kernel/type_errors.cmx lib/util.cmx \ + toplevel/himsg.cmi toplevel/metasyntax.cmo: parsing/ast.cmi parsing/coqast.cmi \ parsing/egrammar.cmi parsing/esyntax.cmi parsing/extend.cmi \ library/lib.cmi library/libobject.cmi library/library.cmi \ @@ -1085,13 +1032,13 @@ toplevel/metasyntax.cmx: parsing/ast.cmx parsing/coqast.cmx \ parsing/pcoq.cmx lib/pp.cmx library/summary.cmx lib/util.cmx \ toplevel/metasyntax.cmi toplevel/minicoq.cmo: kernel/declarations.cmi toplevel/fhimsg.cmi \ - parsing/g_minicoq.cmi kernel/generic.cmi kernel/inductive.cmi \ - kernel/names.cmi lib/pp.cmi kernel/safe_typing.cmi kernel/sign.cmi \ - kernel/term.cmi kernel/type_errors.cmi lib/util.cmi + parsing/g_minicoq.cmi kernel/inductive.cmi kernel/names.cmi lib/pp.cmi \ + kernel/safe_typing.cmi kernel/sign.cmi kernel/term.cmi \ + kernel/type_errors.cmi lib/util.cmi toplevel/minicoq.cmx: kernel/declarations.cmx toplevel/fhimsg.cmx \ - parsing/g_minicoq.cmi kernel/generic.cmx kernel/inductive.cmx \ - kernel/names.cmx lib/pp.cmx kernel/safe_typing.cmx kernel/sign.cmx \ - kernel/term.cmx kernel/type_errors.cmx lib/util.cmx + parsing/g_minicoq.cmi kernel/inductive.cmx kernel/names.cmx lib/pp.cmx \ + kernel/safe_typing.cmx kernel/sign.cmx kernel/term.cmx \ + kernel/type_errors.cmx lib/util.cmx toplevel/protectedtoplevel.cmo: toplevel/errors.cmi parsing/pcoq.cmi \ lib/pp.cmi toplevel/vernac.cmi toplevel/vernacinterp.cmi \ toplevel/protectedtoplevel.cmi @@ -1100,14 +1047,14 @@ toplevel/protectedtoplevel.cmx: toplevel/errors.cmx parsing/pcoq.cmx \ toplevel/protectedtoplevel.cmi toplevel/record.cmo: parsing/ast.cmi parsing/astterm.cmi pretyping/class.cmi \ toplevel/command.cmi parsing/coqast.cmi kernel/declarations.cmi \ - library/declare.cmi kernel/environ.cmi kernel/evd.cmi kernel/generic.cmi \ - library/global.cmi kernel/inductive.cmi kernel/names.cmi lib/pp.cmi \ - pretyping/recordops.cmi kernel/term.cmi lib/util.cmi toplevel/record.cmi + library/declare.cmi kernel/environ.cmi kernel/evd.cmi library/global.cmi \ + kernel/inductive.cmi kernel/names.cmi lib/pp.cmi pretyping/recordops.cmi \ + kernel/term.cmi kernel/typeops.cmi lib/util.cmi toplevel/record.cmi toplevel/record.cmx: parsing/ast.cmx parsing/astterm.cmx pretyping/class.cmx \ toplevel/command.cmx parsing/coqast.cmx kernel/declarations.cmx \ - library/declare.cmx kernel/environ.cmx kernel/evd.cmx kernel/generic.cmx \ - library/global.cmx kernel/inductive.cmx kernel/names.cmx lib/pp.cmx \ - pretyping/recordops.cmx kernel/term.cmx lib/util.cmx toplevel/record.cmi + library/declare.cmx kernel/environ.cmx kernel/evd.cmx library/global.cmx \ + kernel/inductive.cmx kernel/names.cmx lib/pp.cmx pretyping/recordops.cmx \ + kernel/term.cmx kernel/typeops.cmx lib/util.cmx toplevel/record.cmi toplevel/toplevel.cmo: parsing/ast.cmi toplevel/errors.cmi toplevel/mltop.cmi \ kernel/names.cmi lib/options.cmi parsing/pcoq.cmi proofs/pfedit.cmi \ lib/pp.cmi toplevel/protectedtoplevel.cmi lib/util.cmi \ @@ -1164,30 +1111,28 @@ toplevel/vernac.cmx: parsing/ast.cmx parsing/coqast.cmx library/library.cmx \ toplevel/vernac.cmi contrib/omega/coq_omega.cmo: parsing/ast.cmi proofs/clenv.cmi \ library/declare.cmi kernel/environ.cmi tactics/equality.cmi \ - kernel/generic.cmi library/global.cmi kernel/inductive.cmi \ - proofs/logic.cmi kernel/names.cmi contrib/omega/omega.cmo lib/pp.cmi \ - parsing/printer.cmi proofs/proof_type.cmi kernel/reduction.cmi \ + kernel/evd.cmi library/global.cmi kernel/inductive.cmi proofs/logic.cmi \ + kernel/names.cmi contrib/omega/omega.cmo lib/pp.cmi parsing/printer.cmi \ + proofs/proof_type.cmi kernel/reduction.cmi pretyping/retyping.cmi \ kernel/sign.cmi proofs/tacmach.cmi tactics/tactics.cmi kernel/term.cmi \ lib/util.cmi contrib/omega/coq_omega.cmx: parsing/ast.cmx proofs/clenv.cmx \ library/declare.cmx kernel/environ.cmx tactics/equality.cmx \ - kernel/generic.cmx library/global.cmx kernel/inductive.cmx \ - proofs/logic.cmx kernel/names.cmx contrib/omega/omega.cmx lib/pp.cmx \ - parsing/printer.cmx proofs/proof_type.cmx kernel/reduction.cmx \ + kernel/evd.cmx library/global.cmx kernel/inductive.cmx proofs/logic.cmx \ + kernel/names.cmx contrib/omega/omega.cmx lib/pp.cmx parsing/printer.cmx \ + proofs/proof_type.cmx kernel/reduction.cmx pretyping/retyping.cmx \ kernel/sign.cmx proofs/tacmach.cmx tactics/tactics.cmx kernel/term.cmx \ lib/util.cmx contrib/omega/omega.cmo: lib/util.cmi contrib/omega/omega.cmx: lib/util.cmx -contrib/ring/quote.cmo: library/declare.cmi kernel/generic.cmi \ - library/global.cmi kernel/instantiate.cmi kernel/names.cmi \ - parsing/pattern.cmi lib/pp.cmi proofs/proof_trees.cmi \ - proofs/proof_type.cmi proofs/tacmach.cmi tactics/tactics.cmi \ - kernel/term.cmi lib/util.cmi -contrib/ring/quote.cmx: library/declare.cmx kernel/generic.cmx \ - library/global.cmx kernel/instantiate.cmx kernel/names.cmx \ - parsing/pattern.cmx lib/pp.cmx proofs/proof_trees.cmx \ - proofs/proof_type.cmx proofs/tacmach.cmx tactics/tactics.cmx \ - kernel/term.cmx lib/util.cmx +contrib/ring/quote.cmo: library/declare.cmi library/global.cmi \ + kernel/instantiate.cmi kernel/names.cmi parsing/pattern.cmi lib/pp.cmi \ + proofs/proof_trees.cmi proofs/proof_type.cmi proofs/tacmach.cmi \ + tactics/tactics.cmi kernel/term.cmi lib/util.cmi +contrib/ring/quote.cmx: library/declare.cmx library/global.cmx \ + kernel/instantiate.cmx kernel/names.cmx parsing/pattern.cmx lib/pp.cmx \ + proofs/proof_trees.cmx proofs/proof_type.cmx proofs/tacmach.cmx \ + tactics/tactics.cmx kernel/term.cmx lib/util.cmx contrib/ring/ring.cmo: parsing/astterm.cmi kernel/closure.cmi \ library/declare.cmi tactics/equality.cmi kernel/evd.cmi \ library/global.cmi tactics/hiddentac.cmi tactics/hipattern.cmi \ @@ -66,7 +66,7 @@ LIB=lib/pp_control.cmo lib/pp.cmo lib/util.cmo \ lib/bstack.cmo lib/edit.cmo lib/stamps.cmo lib/gset.cmo lib/gmap.cmo \ lib/tlm.cmo lib/bij.cmo lib/gmapl.cmo lib/profile.cmo -KERNEL=kernel/names.cmo kernel/generic.cmo kernel/univ.cmo kernel/term.cmo \ +KERNEL=kernel/names.cmo kernel/univ.cmo kernel/term.cmo \ kernel/sign.cmo kernel/declarations.cmo \ kernel/sosub.cmo kernel/abstraction.cmo \ kernel/environ.cmo kernel/evd.cmo kernel/instantiate.cmo \ @@ -75,13 +75,14 @@ KERNEL=kernel/names.cmo kernel/generic.cmo kernel/univ.cmo kernel/term.cmo \ kernel/safe_typing.cmo LIBRARY=library/libobject.cmo library/summary.cmo library/lib.cmo \ - library/global.cmo library/states.cmo library/library.cmo \ + library/goptions.cmo \ + library/global.cmo library/library.cmo library/states.cmo \ library/nametab.cmo library/impargs.cmo library/redinfo.cmo \ - library/indrec.cmo library/declare.cmo library/goptions.cmo + library/indrec.cmo library/declare.cmo PRETYPING=pretyping/rawterm.cmo pretyping/detyping.cmo \ - pretyping/tacred.cmo pretyping/pretype_errors.cmo \ - pretyping/retyping.cmo pretyping/typing.cmo \ + pretyping/retyping.cmo pretyping/tacred.cmo \ + pretyping/pretype_errors.cmo pretyping/typing.cmo \ pretyping/classops.cmo pretyping/class.cmo pretyping/recordops.cmo \ pretyping/evarutil.cmo pretyping/evarconv.cmo \ pretyping/coercion.cmo pretyping/cases.cmo pretyping/pretyping.cmo \ diff --git a/contrib/omega/coq_omega.ml b/contrib/omega/coq_omega.ml index 4375ef2a4..a8ecf4cd1 100644 --- a/contrib/omega/coq_omega.ml +++ b/contrib/omega/coq_omega.ml @@ -14,7 +14,6 @@ open Reduction open Proof_type open Ast open Names -open Generic open Term open Sign open Inductive @@ -83,22 +82,29 @@ let resolve_with_bindings_tac (c,lbind) gl = res_pf kONT clause gl let reduce_to_mind gl t = - let rec elimrec t l = match whd_castapp_stack t [] with - | (DOPN(MutInd (x0,x1),_) as mind,_) -> (mind,prod_it t l) - | (DOPN(Const _,_),_) -> + let rec elimrec t l = + let c, args = whd_castapp_stack t [] in + match kind_of_term c, args with + | (IsMutInd _,_) -> (c,Environ.it_mkProd_or_LetIn t l) + | (IsConst _,_) -> (try let t' = pf_nf_betaiota gl (pf_one_step_reduce gl t) in elimrec t' l with e when catchable_exception e -> errorlabstrm "tactics__reduce_to_mind" [< 'sTR"Not an inductive product" >]) - | (DOPN(MutCase _,_),_) -> + | (IsMutCase _,_) -> (try let t' = pf_nf_betaiota gl (pf_one_step_reduce gl t) in elimrec t' l with e when catchable_exception e -> errorlabstrm "tactics__reduce_to_mind" [< 'sTR"Not an inductive product" >]) - | (DOP2(Cast,c,_),[]) -> elimrec c l - | (DOP2(Prod,ty,DLAM(n,t')),[]) -> elimrec t' ((n,ty)::l) + | (IsCast (c,_),[]) -> elimrec c l + | (IsProd (n,ty,t'),[]) -> + let ty' = Retyping.get_assumption_of (Global.env()) Evd.empty ty in + elimrec t' ((n,None,ty')::l) + | (IsLetIn (n,b,ty,t'),[]) -> + let ty' = Retyping.get_assumption_of (Global.env()) Evd.empty ty in + elimrec t' ((n,Some b,ty')::l) | _ -> error "Not an inductive product" in elimrec t [] @@ -115,7 +121,7 @@ let constructor_tac nconstropt i lbind gl = error "Not the expected number of constructors" | _ -> ()); if i > nconstr then error "Not enough Constructors"; - let c = DOPN(MutConstruct((x0,x1),i),args) in + let c = mkMutConstruct (((x0,x1),i),args) in let resolve_tac = resolve_with_bindings_tac (c,lbind) in (tclTHEN (tclTHEN (change_in_concl redcl) intros) resolve_tac) gl @@ -149,16 +155,7 @@ let hide_constr,find_constr,clear_tables,dump_tables = (fun () -> l := []), (fun () -> !l) -let get_applist = - let rec loop accu = function - | DOPN(AppL,cl) -> - begin match Array.to_list cl with - | h :: l -> loop (l @ accu) h - | [] -> failwith "get_applist" end - | DOP2(Cast,c,t) -> loop accu c - | t -> t,accu - in - loop [] +let get_applist c = whd_stack c [] exception Destruct @@ -175,14 +172,18 @@ type result = | Kimp of constr * constr | Kufo -let destructurate t = - match get_applist t with - | DOPN ((Const _ | MutConstruct _ | MutInd _) as c,_),args -> - Kapp (string_of_id (Global.id_of_global c),args) - | VAR id,[] -> Kvar(string_of_id id) - | DOP2(Prod,typ,DLAM(Anonymous,body)),[] -> Kimp(typ,body) - | DOP2(Prod,_,DLAM(Name _,_)),[] -> - error "Omega: Not a quantifier-free goal" +let destructurate t = + let c, args = get_applist t in + match kind_of_term c, args with + | IsConst (sp,_), args -> + Kapp (string_of_id (Global.id_of_global (Const sp)),args) + | IsMutConstruct (csp,_) , args -> + Kapp (string_of_id (Global.id_of_global (MutConstruct csp)),args) + | IsMutInd (isp,_), args -> + Kapp (string_of_id (Global.id_of_global (MutInd isp)),args) + | IsVar id,[] -> Kvar(string_of_id id) + | IsProd (Anonymous,typ,body), [] -> Kimp(typ,body) + | IsProd (Name _,_,_),[] -> error "Omega: Not a quantifier-free goal" | _ -> Kufo let recognize_number t = @@ -425,58 +426,58 @@ type constr_path = | P_ARG let context operation path (t : constr) = - let rec loop i p0 p1 = - match (p0,p1) with - | (p, (DOP2(Cast,c,t))) -> DOP2(Cast,loop i p c,t) - | ([], t) -> operation i t - | (p, (DLAM(n,t))) -> DLAM(n,loop (i+1) p t) - | ((P_APP n :: p), (DOPN(AppL,v) as t)) -> + let rec loop i p0 t = + match (p0,kind_of_term t) with + | (p, IsCast (c,t)) -> mkCast (loop i p c,t) + | ([], _) -> operation i t + | ((P_APP n :: p), IsAppL _) -> let f,l = get_applist t in let v' = Array.of_list (f::l) in - v'.(n) <- loop i p v'.(n); (DOPN(AppL,v')) - | ((P_BRANCH n :: p), (DOPN(MutCase _,_) as t)) -> - let (_,_,_,v) = destCase t in - v.(n) <- loop i p v.(n); (DOPN(AppL,v)) - | ((P_ARITY :: p), (DOPN(AppL,v))) -> - let v' = Array.copy v in - v'.(0) <- loop i p v.(0); (DOPN(AppL,v')) - | ((P_ARG :: p), (DOPN(AppL,v))) -> - let v' = Array.copy v in - v'.(1) <- loop i p v.(1); (DOPN(AppL,v')) - | (p, (DOPN(Fix(_,n) as f,v))) -> - let v' = Array.copy v in - let l = Array.length v - 1 in - v'.(l) <- loop i (P_BRANCH n :: p) v.(l); (DOPN(f,v')) - | ((P_BRANCH n :: p), (DLAMV(name,v))) -> + v'.(n) <- loop i p v'.(n); (mkAppL v') + | ((P_BRANCH n :: p), IsMutCase (_,_,_,v)) -> + v.(n) <- loop i p v.(n); (mkAppL v) (* Not Mutcase ?? *) + | ((P_ARITY :: p), IsAppL (f,l)) -> + applist (loop i p f,l) + | ((P_ARG :: p), IsAppL (f,a::l)) -> + applist (f,(loop i p a)::l) + | (p, IsFix ((_,n as ln),(tys,lna,v))) -> + let l = Array.length v in let v' = Array.copy v in - v'.(n) <- loop (i+1) p v.(n); DLAMV(name,v') - | ((P_BODY :: p), (DOP2((Prod | Lambda) as k, t,c))) -> - (DOP2(k,t,loop i p c)) - | ((P_TYPE :: p), (DOP2((Prod | Lambda) as k, term,c))) -> - (DOP2(k,loop i p term, c)) - | (p, t) -> + v'.(n) <- loop (i+l) p v.(n); (mkFix (ln,(tys,lna,v'))) + | ((P_BODY :: p), IsProd (n,t,c)) -> + (mkProd (n,t,loop (i+1) p c)) + | ((P_BODY :: p), IsLambda (n,t,c)) -> + (mkLambda (n,t,loop (i+1) p c)) + | ((P_BODY :: p), IsLetIn (n,b,t,c)) -> + (mkLetIn (n,b,t,loop (i+1) p c)) + | ((P_TYPE :: p), IsProd (n,t,c)) -> + (mkProd (n,loop i p t,c)) + | ((P_TYPE :: p), IsLambda (n,t,c)) -> + (mkLambda (n,loop i p t,c)) + | ((P_TYPE :: p), IsLetIn (n,b,t,c)) -> + (mkLetIn (n,b,loop i p t,c)) + | (p, _) -> pPNL [<Printer.prterm t>]; failwith ("abstract_path " ^ string_of_int(List.length p)) in loop 1 path t let occurence path (t : constr) = - let rec loop p0 p1 = match (p0,p1) with - | (p, (DOP2(Cast,c,t))) -> loop p c - | ([], t) -> t - | (p, (DLAM(n,t))) -> loop p t - | ((P_APP n :: p), (DOPN(AppL,v) as t)) -> - let f,l = get_applist t in loop p v.(n) - | ((P_BRANCH n :: p), (DOPN(MutCase _,_) as t)) -> - let (_,_,_,v) = destCase t in loop p v.(n) - | ((P_ARITY :: p), (DOPN(AppL,v))) -> loop p v.(0) - | ((P_ARG :: p), (DOPN(AppL,v))) -> loop p v.(1) - | (p, (DOPN(Fix(_,n) as f,v))) -> - let l = Array.length v - 1 in loop (P_BRANCH n :: p) v.(l) - | ((P_BRANCH n :: p), (DLAMV(name,v))) -> loop p v.(n) - | ((P_BODY :: p), (DOP2((Prod | Lambda) as k, t,c))) -> loop p c - | ((P_TYPE :: p), (DOP2((Prod | Lambda) as k, term,c))) -> loop p term - | (p, t) -> + let rec loop p0 t = match (p0,kind_of_term t) with + | (p, IsCast (c,t)) -> loop p c + | ([], _) -> t + | ((P_APP n :: p), IsAppL (f,l)) -> loop p (List.nth l (n-1)) + | ((P_BRANCH n :: p), IsMutCase (_,_,_,v)) -> loop p v.(n) + | ((P_ARITY :: p), IsAppL (f,_)) -> loop p f + | ((P_ARG :: p), IsAppL (f,a::l)) -> loop p a + | (p, IsFix((_,n) ,(_,_,v))) -> loop p v.(n) + | ((P_BODY :: p), IsProd (n,t,c)) -> loop p c + | ((P_BODY :: p), IsLambda (n,t,c)) -> loop p c + | ((P_BODY :: p), IsLetIn (n,b,t,c)) -> loop p c + | ((P_TYPE :: p), IsProd (n,term,c)) -> loop p term + | ((P_TYPE :: p), IsLambda (n,term,c)) -> loop p term + | ((P_TYPE :: p), IsLetIn (n,b,term,c)) -> loop p term + | (p, _) -> pPNL [<Printer.prterm t>]; failwith ("occurence " ^ string_of_int(List.length p)) in @@ -485,7 +486,7 @@ let occurence path (t : constr) = let abstract_path typ path t = let term_occur = ref (Rel 0) in let abstract = context (fun i t -> term_occur:= t; Rel i) path t in - mkLambda (Name (id_of_string "x")) typ abstract, !term_occur + mkLambda (Name (id_of_string "x"), typ, abstract), !term_occur let focused_simpl path gl = let newc = context (fun i t -> pf_nf gl t) (List.rev path) (pf_concl gl) in @@ -554,12 +555,14 @@ let clever_rewrite_base_poly typ p result theorem gl = let (abstracted,occ) = abstract_path typ (List.rev p) full in let t = applist - ((mkLambda (Name (id_of_string "P")) - (mkArrow typ mkProp) - (mkLambda (Name (id_of_string "H")) - (applist (Rel 1,[result])) - (mkAppL [| Lazy.force coq_eq_ind_r; - typ; result; Rel 2; Rel 1; occ; theorem |]))), + (mkLambda + (Name (id_of_string "P"), + mkArrow typ mkProp, + mkLambda + (Name (id_of_string "H"), + applist (Rel 1,[result]), + mkAppL [| Lazy.force coq_eq_ind_r; + typ; result; Rel 2; Rel 1; occ; theorem |])), [abstracted]) in exact (applist(t,[mkNewMeta()])) gl @@ -1206,8 +1209,10 @@ let replay_history tactic_normalisation = let theorem = mkAppL [| Lazy.force coq_ex; Lazy.force coq_Z; - mkLambda (Name(id_of_string v)) (Lazy.force coq_Z) - (mk_eq (Rel 1) eq1) |] + mkLambda + (Name(id_of_string v), + Lazy.force coq_Z, + mk_eq (Rel 1) eq1) |] in let mm = mk_integer m in let p_initial = [P_APP 2;P_TYPE] in diff --git a/contrib/ring/quote.ml b/contrib/ring/quote.ml index fc1ee306f..8351357e6 100644 --- a/contrib/ring/quote.ml +++ b/contrib/ring/quote.ml @@ -99,7 +99,6 @@ open Pp open Util open Names -open Generic open Term open Instantiate open Pattern diff --git a/dev/changements.txt b/dev/changements.txt index dc9b01b17..e6d44eb45 100644 --- a/dev/changements.txt +++ b/dev/changements.txt @@ -10,6 +10,7 @@ Changements d'organisation / modules : Avm,Mavm,Fmavm,Mhm -> utiliser plutôt Map (et freeze alors gratuit) Mhb -> Bij + Generic est intégré ŕ Term (et un petit peu ŕ Closure) Changements dans les types de données : --------------------------------------- diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 11e621acf..ff592ed94 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -9,7 +9,7 @@ open Sign open Univ open Proof_trees open Environ -open Generic +(*i open Generic i*) open Printer open Refiner open Tacmach @@ -84,13 +84,13 @@ let constr_display csr = | DOPN(a,b) -> "DOPN("^(oper_display a)^",[|"^(Array.fold_right (fun x i -> (term_display x)^(if not(i="") then (";"^i) else "")) b "")^"|])" - | DOPL(a,b) -> - "DOPL("^(oper_display a)^",[|"^(List.fold_right (fun x i -> - (term_display x)^(if not(i="") then (";"^i) else "")) b "")^"|]" | DLAM(a,b) -> "DLAM("^(name_display a)^","^(term_display b)^")" | DLAMV(a,b) -> "DLAMV("^(name_display a)^",[|"^(Array.fold_right (fun x i -> (term_display x)^(if not(i="") then (";"^i) else "")) b "")^"|]" + | CLam(a,b,c) -> "CLam("^(name_display a)^","^(term_display (body_of_type b))^","^(term_display c)^")" + | CPrd(a,b,c) -> "CPrd("^(name_display a)^","^(term_display (body_of_type b))^","^(term_display c)^")" + | CLet(a,b,c,d) -> "CLet("^(name_display a)^","^(term_display b)^","^(term_display (body_of_type c))^","^(term_display d)^")" | VAR a -> "VAR "^(string_of_id a) | Rel a -> "Rel "^(string_of_int a) and oper_display = function diff --git a/kernel/abstraction.ml b/kernel/abstraction.ml index 9df751b46..a6e5937a4 100644 --- a/kernel/abstraction.ml +++ b/kernel/abstraction.ml @@ -3,7 +3,7 @@ open Util open Names -open Generic +(*i open Generic i*) open Term type abstraction_body = { diff --git a/kernel/closure.ml b/kernel/closure.ml index f452a6dfc..948361690 100644 --- a/kernel/closure.ml +++ b/kernel/closure.ml @@ -4,7 +4,6 @@ open Util open Pp open Term -open Generic open Names open Environ open Instantiate @@ -31,6 +30,9 @@ let stop() = (* sets of reduction kinds *) type red_kind = BETA | DELTA of sorts oper | IOTA +(* Hack: we use oper (Const "$LOCAL VAR$") for local variables *) +let local_const_oper = Const (make_path [] (id_of_string "$LOCAL VAR$") CCI) + type reds = { r_beta : bool; r_delta : sorts oper -> bool; (* this is unsafe: exceptions may pop out *) @@ -157,6 +159,58 @@ let infos_under infos = i_tab = infos.i_tab } +(* explicit substitutions of type 'a *) +type 'a subs = + | ESID (* ESID = identity *) + | CONS of 'a * 'a subs (* CONS(t,S) = (S.t) parallel substitution *) + | SHIFT of int * 'a subs (* SHIFT(n,S) = (^n o S) terms in S are relocated *) + (* with n vars *) + | LIFT of int * 'a subs (* LIFT(n,S) = (%n S) stands for ((^n o S).n...1) *) + +(* operations of subs: collapses constructors when possible. + * Needn't be recursive if we always use these functions + *) + +let subs_cons(x,s) = CONS(x,s) + +let subs_liftn n = function + | ESID -> ESID (* the identity lifted is still the identity *) + (* (because (^1.1) --> id) *) + | LIFT (p,lenv) -> LIFT (p+n, lenv) + | lenv -> LIFT (n,lenv) + +let subs_lift a = subs_liftn 1 a + +let subs_shft = function + | (0, s) -> s + | (n, SHIFT (k,s1)) -> SHIFT (k+n, s1) + | (n, s) -> SHIFT (n,s) + +(* Expands de Bruijn k in the explicit substitution subs + * lams accumulates de shifts to perform when retrieving the i-th value + * the rules used are the following: + * + * [id]k --> k + * [S.t]1 --> t + * [S.t]k --> [S](k-1) if k > 1 + * [^n o S] k --> [^n]([S]k) + * [(%n S)] k --> k if k <= n + * [(%n S)] k --> [^n]([S](k-n)) + * + * the result is (Inr k) when the variable is just relocated + *) +let rec exp_rel lams k subs = + match (k,subs) with + | (1, CONS (def,_)) -> Inl(lams,def) + | (_, CONS (_,l)) -> exp_rel lams (pred k) l + | (_, LIFT (n,_)) when k<=n -> Inr(lams+k) + | (_, LIFT (n,l)) -> exp_rel (n+lams) (k-n) l + | (_, SHIFT (n,s)) -> exp_rel (n+lams) k s + | (_, ESID) -> Inr(lams+k) + +let expand_rel k subs = exp_rel 0 k subs + + (**** Call by value reduction ****) (* The type of terms with closure. The meaning of the constructors and @@ -185,7 +239,8 @@ let infos_under infos = type cbv_value = | VAL of int * constr | LAM of name * constr * constr * cbv_value subs - | FIXP of sorts oper * constr array * cbv_value subs * cbv_value list + | FIXP of fixpoint * cbv_value subs * cbv_value list + | COFIXP of cofixpoint * cbv_value subs * cbv_value list | CONSTR of int * (section_path * int) * cbv_value array * cbv_value list (* les vars pourraient etre des constr, @@ -197,8 +252,10 @@ type cbv_value = let rec shift_value n = function | VAL (k,v) -> VAL ((k+n),v) | LAM (x,a,b,s) -> LAM (x,a,b,subs_shft (n,s)) - | FIXP (op,bv,s,args) -> - FIXP (op,bv,subs_shft (n,s), List.map (shift_value n) args) + | FIXP (fix,s,args) -> + FIXP (fix,subs_shft (n,s), List.map (shift_value n) args) + | COFIXP (cofix,s,args) -> + COFIXP (cofix,subs_shft (n,s), List.map (shift_value n) args) | CONSTR (i,spi,vars,args) -> CONSTR (i, spi, Array.map (shift_value n) vars, List.map (shift_value n) args) @@ -210,20 +267,23 @@ let rec shift_value n = function * (S, (fix Fi {F0 := T0 .. Fn-1 := Tn-1})) * -> (S. [S]F0 . [S]F1 ... . [S]Fn-1, Ti) *) -let contract_fixp env fix = - let (bnum, bodies, make_body) = match fix with - | DOPN(Fix(reci,i),bvect) -> - (i, array_last bvect, (fun j -> FIXP(Fix(reci,j), bvect, env, []))) - | DOPN(CoFix i,bvect) -> - (i, array_last bvect, (fun j -> FIXP(CoFix j, bvect, env, []))) - | _ -> anomaly "Closure.contract_fixp: not a (co)fixpoint" - in - let rec subst_bodies_from_i i subs = function - | DLAM(_,t) -> subst_bodies_from_i (i+1) (subs_cons (make_body i, subs)) t - | DLAMV(_,bds) -> (subs_cons (make_body i, subs), bds.(bnum)) - | _ -> anomaly "Closure.contract_fixp: malformed (co)fixpoint" +let contract_fixp env ((reci,i),(_,_,bds as bodies)) = + let make_body j = FIXP(((reci,j),bodies), env, []) in + let n = Array.length bds in + let rec subst_bodies_from_i i subs = + if i=n then subs + else subst_bodies_from_i (i+1) (subs_cons (make_body i, subs)) + in + subst_bodies_from_i 0 env, bds.(i) + +let contract_cofixp env (i,(_,_,bds as bodies)) = + let make_body j = COFIXP((j,bodies), env, []) in + let n = Array.length bds in + let rec subst_bodies_from_i i subs = + if i=n then subs + else subst_bodies_from_i (i+1) (subs_cons (make_body i, subs)) in - subst_bodies_from_i 0 env bodies + subst_bodies_from_i 0 env, bds.(i) (* type of terms with a hole. This hole can appear only under AppL or Case. @@ -274,12 +334,13 @@ let red_allowed flags stack rk = *) let strip_appl head stack = match head with - | FIXP (op,bv,env,app) -> (FIXP(op,bv,env,[]), stack_app app stack) + | FIXP (fix,env,app) -> (FIXP(fix,env,[]), stack_app app stack) + | COFIXP (cofix,env,app) -> (COFIXP(cofix,env,[]), stack_app app stack) | CONSTR (i,spi,vars,app) -> (CONSTR(i,spi,vars,[]), stack_app app stack) | _ -> (head, stack) -(* Invariant: if the result of norm_head is CONSTR or FIXP, it last +(* Invariant: if the result of norm_head is CONSTR or (CO)FIXP, it last * argument is []. * Because we must put all the applied terms in the stack. *) @@ -298,12 +359,18 @@ let rec check_app_constr redfun = function | _ -> false) | (_::l, n) -> check_app_constr redfun (l,(pred n)) -let fixp_reducible redfun flgs op stk = +let fixp_reducible redfun flgs ((reci,i),_) stk = + if red_allowed flgs stk IOTA then + match stk with (* !!! for Acc_rec: reci.(i) = -2 *) + | APP(appl,_) -> reci.(i) >=0 & check_app_constr redfun (appl, reci.(i)) + | _ -> false + else + false + +let cofixp_reducible redfun flgs _ stk = if red_allowed flgs stk IOTA then - match (op,stk) with (* !!! for Acc_rec: reci.(i) = -2 *) - | (Fix (reci,i), APP(appl,_)) -> - (reci.(i) >= 0 & check_app_constr redfun (appl, reci.(i))) - | (CoFix i, (CASE _ | APP(_,CASE _))) -> true + match stk with + | (CASE _ | APP(_,CASE _)) -> true | _ -> false else false @@ -318,65 +385,72 @@ let mindsp_nparams env sp = * constructor, a lambda or a fixp in the head. If not, it is a value * and is completely computed here. The head redexes are NOT reduced: * the function returns the pair of a cbv_value and its stack. * - * Invariant: if the result of norm_head is CONSTR or FIXP, it last + * Invariant: if the result of norm_head is CONSTR or (CO)FIXP, it last * argument is []. Because we must put all the applied terms in the * stack. *) let rec norm_head info env t stack = (* no reduction under binders *) - match t with + match kind_of_term t with (* stack grows (remove casts) *) - | DOPN (AppL,appl) -> (* Applied terms are normalized immediately; + | IsAppL (head,args) -> (* Applied terms are normalized immediately; they could be computed when getting out of the stack *) - (match Array.to_list appl with - | head::args -> - let nargs = List.map (cbv_stack_term info TOP env) args in - norm_head info env head (stack_app nargs stack) - | [] -> anomaly "norm_head : malformed constr AppL [||]") - | DOPN (MutCase _,_) -> - let (ci,p,c,v) = destCase t in - norm_head info env c (CASE(p,v,ci,env,stack)) - | DOP2 (Cast,ct,c) -> norm_head info env ct stack + let nargs = List.map (cbv_stack_term info TOP env) args in + norm_head info env head (stack_app nargs stack) + | IsMutCase (ci,p,c,v) -> norm_head info env c (CASE(p,v,ci,env,stack)) + | IsCast (ct,_) -> norm_head info env ct stack (* constants, axioms * the first pattern is CRUCIAL, n=0 happens very often: * when reducing closed terms, n is always 0 *) - | Rel i -> (match expand_rel i env with + | IsRel i -> (match expand_rel i env with | Inl (0,v) -> reduce_const_body (cbv_norm_more info) v stack | Inl (n,v) -> reduce_const_body (cbv_norm_more info) (shift_value n v) stack | Inr n -> (VAL(0, Rel n), stack)) - | DOPN ((Const _ | Evar _ | Abst _) as op, vars) - when red_allowed info.i_flags stack (DELTA op) -> - let normt = DOPN(op, Array.map (cbv_norm_term info env) vars) in - (match const_value_cache info normt with - | Some body -> reduce_const_body (cbv_norm_more info) body stack - | None -> (VAL(0,normt), stack)) + | IsConst (sp,vars) -> + let normt = mkConst (sp,Array.map (cbv_norm_term info env) vars) in + if red_allowed info.i_flags stack (DELTA (Const sp)) then + match const_value_cache info normt with + | Some body -> reduce_const_body (cbv_norm_more info) body stack + | None -> (VAL(0,normt), stack) + else (VAL(0,normt), stack) + | IsLetIn (x, b, t, c) -> + if red_allowed info.i_flags stack (DELTA local_const_oper) then + let b = cbv_stack_term info TOP env b in + norm_head info (subs_cons (b,env)) c stack + else + let normt = + mkLetIn (x, cbv_norm_term info env b, + cbv_norm_term info env t, + cbv_norm_term info (subs_lift env) c) in + (VAL(0,normt), stack) (* Considérer une coupure commutative ? *) + | IsEvar (n,vars) -> + let normt = mkEvar (n,Array.map (cbv_norm_term info env) vars) in + if red_allowed info.i_flags stack (DELTA (Evar n)) then + match const_value_cache info normt with + | Some body -> reduce_const_body (cbv_norm_more info) body stack + | None -> (VAL(0,normt), stack) + else (VAL(0,normt), stack) (* non-neutral cases *) - | DOP2 (Lambda,a,DLAM(x,b)) -> (LAM(x,a,b,env), stack) - | DOPN ((Fix _ | CoFix _) as op, v) -> (FIXP(op,v,env,[]), stack) - | DOPN (MutConstruct(spi,i),vars) -> + | IsLambda (x,a,b) -> (LAM(x,a,b,env), stack) + | IsFix fix -> (FIXP(fix,env,[]), stack) + | IsCoFix cofix -> (COFIXP(cofix,env,[]), stack) + | IsMutConstruct ((spi,i),vars) -> (CONSTR(i,spi, Array.map (cbv_stack_term info TOP env) vars,[]), stack) (* neutral cases *) - | (VAR _ | DOP0 _) -> (VAL(0, t), stack) - | DOP1 (op, nt) -> (VAL(0, DOP1(op, cbv_norm_term info env nt)), stack) - | DOP2 (op,a,b) -> - (VAL(0, DOP2(op, cbv_norm_term info env a, cbv_norm_term info env b)), - stack) - | DOPN (op,vars) -> - (VAL(0, DOPN(op, Array.map (cbv_norm_term info env) vars)), stack) - | DOPL (op,l) -> - (VAL(0, DOPL(op, List.map (cbv_norm_term info env) l)), stack) - | DLAM (x,t) -> - (VAL(0, DLAM(x, cbv_norm_term info (subs_lift env) t)), stack) - | DLAMV (x,ve) -> - (VAL(0, DLAMV(x, Array.map(cbv_norm_term info (subs_lift env)) ve)), - stack) - + | (IsVar _ | IsSort _ | IsMeta _ | IsXtra _ ) -> (VAL(0, t), stack) + | IsMutInd (sp,vars) -> + (VAL(0, mkMutInd (sp, Array.map (cbv_norm_term info env) vars)), stack) + | IsProd (x,t,c) -> + (VAL(0, mkProd (x, cbv_norm_term info env t, + cbv_norm_term info (subs_lift env) c)), + stack) + | IsAbst (_,_) -> failwith "No longer implemented" (* cbv_stack_term performs weak reduction on constr t under the subs * env, with context stack, i.e. ([env]t stack). First computes weak @@ -392,12 +466,17 @@ and cbv_stack_term info stack env t = let subs = subs_cons (arg,env) in cbv_stack_term info (stack_app args stk) subs b - (* a Fix applied enough, - constructor guard satisfied or Cofix in a Case -> IOTA *) - | (FIXP(op,bv,env,_), stk) - when fixp_reducible (cbv_norm_more info) info.i_flags op stk -> - let (envf,redfix) = contract_fixp env (DOPN(op,bv)) in - cbv_stack_term info stk envf redfix + (* a Fix applied enough -> IOTA *) + | (FIXP(fix,env,_), stk) + when fixp_reducible (cbv_norm_more info) info.i_flags fix stk -> + let (envf,redfix) = contract_fixp env fix in + cbv_stack_term info stk envf redfix + + (* constructor guard satisfied or Cofix in a Case -> IOTA *) + | (COFIXP(cofix,env,_), stk) + when cofixp_reducible (cbv_norm_more info) info.i_flags cofix stk -> + let (envf,redfix) = contract_cofixp env cofix in + cbv_stack_term info stk envf redfix (* constructor in a Case -> IOTA (use red_under because we know there is a Case) *) @@ -414,7 +493,8 @@ and cbv_stack_term info stack env t = (* may be reduced later by application *) | (head, TOP) -> head - | (FIXP(op,bv,env,_), APP(appl,TOP)) -> FIXP(op,bv,env,appl) + | (FIXP(fix,env,_), APP(appl,TOP)) -> FIXP(fix,env,appl) + | (COFIXP(cofix,env,_), APP(appl,TOP)) -> COFIXP(cofix,env,appl) | (CONSTR(n,spi,vars,_), APP(appl,TOP)) -> CONSTR(n,spi,vars,appl) (* definitely a value *) @@ -452,19 +532,28 @@ and cbv_norm_term info env t = (* reduction of a cbv_value to a constr *) and cbv_norm_value info = function (* reduction under binders *) | VAL (n,v) -> lift n v - | LAM (x,a,b,env) -> DOP2(Lambda, cbv_norm_term info env a, - DLAM(x,cbv_norm_term info (subs_lift env) b)) - | FIXP (op,cl,env,args) -> + | LAM (x,a,b,env) -> + mkLambda (x, cbv_norm_term info env a, + cbv_norm_term info (subs_lift env) b) + | FIXP ((lij,(lty,lna,bds)),env,args) -> + applistc + (mkFix (lij, + (Array.map (cbv_norm_term info env) lty, lna, + Array.map (cbv_norm_term info + (subs_liftn (Array.length lty) env)) bds))) + (List.map (cbv_norm_value info) args) + | COFIXP ((j,(lty,lna,bds)),env,args) -> applistc - (DOPN(op, Array.map (cbv_norm_term info env) cl)) + (mkCoFix (j, + (Array.map (cbv_norm_term info env) lty, lna, + Array.map (cbv_norm_term info + (subs_liftn (Array.length lty) env)) bds))) (List.map (cbv_norm_value info) args) | CONSTR (n,spi,vars,args) -> applistc - (DOPN (MutConstruct(spi,n), Array.map (cbv_norm_value info) vars)) + (mkMutConstruct ((spi,n), Array.map (cbv_norm_value info) vars)) (List.map (cbv_norm_value info) args) - - type 'a cbv_infos = (cbv_value, 'a) infos (* constant bodies are normalized at the first expansion *) @@ -499,22 +588,40 @@ let cbv_norm infos constr = * substitution applied to a constr *) -type 'oper freeze = { +type freeze = { mutable norm: bool; - mutable term: 'oper frterm } + mutable term: frterm } -and 'oper frterm = +and frterm = | FRel of int | FVAR of identifier - | FOP0 of 'oper - | FOP1 of 'oper * 'oper freeze - | FOP2 of 'oper * 'oper freeze * 'oper freeze - | FOPN of 'oper * 'oper freeze array - | FOPL of 'oper * 'oper freeze list - | FLAM of name * 'oper freeze * 'oper term * 'oper freeze subs - | FLAMV of name * 'oper freeze array * 'oper term array * 'oper freeze subs - | FLIFT of int * 'oper freeze - | FFROZEN of 'oper term * 'oper freeze subs + | FOP0 of sorts oper + | FOP1 of sorts oper * freeze + | FOP2 of sorts oper * freeze * freeze + | FOPN of sorts oper * freeze array + | FLAM of name * freeze * constr * freeze subs + | FLAMV of name * freeze array * constr array * freeze subs + | FLam of name * type_freeze * freeze * constr * freeze subs + | FPrd of name * type_freeze * freeze * constr * freeze subs + | FLet of name * freeze * type_freeze * freeze * constr * freeze subs + | FLIFT of int * freeze + | FFROZEN of constr * freeze subs + +(* Cas oů typed_type est casté en interne +and type_freeze = freeze * sorts + *) +(* Cas oů typed_type n'est pas casté *) +and type_freeze = freeze +(**) + +(* +let typed_map f t = f (body_of_type t), level_of_type t +let typed_unmap f (t,s) = make_typed (f t) s +*) +(**) +let typed_map f t = f (body_of_type t) +let typed_unmap f t = make_typed_lazy (f t) (fun _ -> assert false) +(**) let frterm_of v = v.term let is_val v = v.norm @@ -579,8 +686,6 @@ let rec traverse_term env t = term = FOP2 (op, traverse_term env a, traverse_term env b)} | DOPN (op,v) -> { norm = false; term = FOPN (op, Array.map (traverse_term env) v) } - | DOPL (op,l) -> - { norm = false; term = FOPL (op, List.map (traverse_term env) l) } | DLAM (x,a) -> { norm = false; term = FLAM (x, traverse_term (subs_lift env) a, a, env) } @@ -588,9 +693,24 @@ let rec traverse_term env t = { norm = (ve=[||]); term = FLAMV (x, Array.map (traverse_term (subs_lift env)) ve, ve, env) } + | CLam (n,t,c) -> + { norm = false; + term = FLam (n, traverse_type env t, traverse_term (subs_lift env) c, + c, env) } + | CPrd (n,t,c) -> + { norm = false; + term = FPrd (n, traverse_type env t, traverse_term (subs_lift env) c, + c, env) } + | CLet (n,b,t,c) -> + { norm = false; + term = FLet (n, traverse_term env b, traverse_type env t, + traverse_term (subs_lift env) c, + c, env) } + +and traverse_type env = typed_map (traverse_term env) (* Back to regular terms: remove all FFROZEN, keep casts (since this - * fun is not dedicated to the Calulus of Constructions). + * fun is not dedicated to the Calculus of Constructions). *) let rec lift_term_of_freeze lfts v = match v.term with @@ -601,10 +721,19 @@ let rec lift_term_of_freeze lfts v = | FOP2 (op,a,b) -> DOP2 (op, lift_term_of_freeze lfts a, lift_term_of_freeze lfts b) | FOPN (op,ve) -> DOPN (op, Array.map (lift_term_of_freeze lfts) ve) - | FOPL (op,l) -> DOPL (op, List.map (lift_term_of_freeze lfts) l) | FLAM (x,a,_,_) -> DLAM (x, lift_term_of_freeze (el_lift lfts) a) | FLAMV (x,ve,_,_) -> DLAMV (x, Array.map (lift_term_of_freeze (el_lift lfts)) ve) + | FLam (n,t,c,_,_) -> + CLam (n, typed_unmap (lift_term_of_freeze lfts) t, + lift_term_of_freeze (el_lift lfts) c) + | FPrd (n,t,c,_,_) -> + CPrd (n, typed_unmap (lift_term_of_freeze lfts) t, + lift_term_of_freeze (el_lift lfts) c) + | FLet (n,b,t,c,_,_) -> + CLet (n, lift_term_of_freeze lfts b, + typed_unmap (lift_term_of_freeze lfts) t, + lift_term_of_freeze (el_lift lfts) c) | FLIFT (k,a) -> lift_term_of_freeze (el_shft k lfts) a | FFROZEN (t,env) -> let unfv = freeze_assign v (traverse_term env t) in @@ -629,30 +758,34 @@ let rec fstrong unfreeze_fun lfts v = | FOP2 (op,a,b) -> DOP2 (op, fstrong unfreeze_fun lfts a, fstrong unfreeze_fun lfts b) | FOPN (op,ve) -> DOPN (op, Array.map (fstrong unfreeze_fun lfts) ve) - | FOPL (op,l) -> DOPL (op, List.map (fstrong unfreeze_fun lfts) l) | FLAM (x,a,_,_) -> DLAM (x, fstrong unfreeze_fun (el_lift lfts) a) | FLAMV (x,ve,_,_) -> DLAMV (x, Array.map (fstrong unfreeze_fun (el_lift lfts)) ve) + | FLam (n,t,c,_,_) -> + CLam (n, typed_unmap (fstrong unfreeze_fun lfts) t, + fstrong unfreeze_fun (el_lift lfts) c) + | FPrd (n,t,c,_,_) -> + CPrd (n, typed_unmap (fstrong unfreeze_fun lfts) t, + fstrong unfreeze_fun (el_lift lfts) c) + | FLet (n,b,t,c,_,_) -> + CLet (n, fstrong unfreeze_fun lfts b, + typed_unmap (fstrong unfreeze_fun lfts) t, + fstrong unfreeze_fun (el_lift lfts) c) | FLIFT (k,a) -> fstrong unfreeze_fun (el_shft k lfts) a | FFROZEN _ -> anomaly "Closure.fstrong" -(* Build a freeze, which represents the substitution of arg in fun_body. +(* Build a freeze, which represents the substitution of arg in t * Used to constract a beta-redex: - * [^depth](FLAM(S,t)) arg -> [(^depth o S).arg]t - * We also deal with FLIFT that would have been inserted between the - * Lambda and FLAM operators. This never happens in practice. + * [^depth](FLam(S,t)) arg -> [(^depth o S).arg]t *) -let rec contract_subst depth fun_body arg = - match fun_body.term with - FLAM(_,_,t,subs) -> freeze (subs_cons (arg, subs_shft (depth,subs))) t - | FLIFT(k,fb) -> contract_subst (depth+k) fb arg - | _ -> anomaly "Closure.contract_subst: malformed function" +let rec contract_subst depth t subs arg = + freeze (subs_cons (arg, subs_shft (depth,subs))) t (* Calculus of Constructions *) -type fconstr = sorts oper freeze +type fconstr = freeze let inject constr = freeze ESID constr @@ -760,6 +893,7 @@ and whnf_frterm info ft = | None -> { norm = array_for_all is_val vars; term = ft.term }) else ft + | FOPN (MutCase ci,cl) -> if red_under info.i_flags IOTA then let c = unfreeze (infos_under info) cl.(1) in @@ -777,8 +911,11 @@ and whnf_frterm info ft = else ft - | FRel _ | FVAR _ | FOP0 _ -> { norm = true; term = ft.term } - | _ -> ft + | FLet (na,b,_,_,t,subs) -> warning "Should be catch in whnf_term"; + contract_subst 0 t subs b + + | FRel _ | FVAR _ | FOP0 _ -> { norm = true; term = ft.term } + | FOPN _ | FOP2 _ | FOP1 _ | FLam _ | FPrd _ | FLAM _ | FLAMV _ -> ft (* Weak head reduction: case of the application (head appl) *) and whnf_apply info head appl = @@ -788,8 +925,8 @@ and whnf_apply info head appl = else let (lft_hd,whd,args) = strip_frterm 0 head [appl] in match whd.term with - | FOP2(Lambda,_,b) when red_under info.i_flags BETA -> - let vbody = contract_subst lft_hd (unfreeze info b) args.(0) in + | FLam (_,_,_,t,subs) when red_under info.i_flags BETA -> + let vbody = contract_subst lft_hd t subs args.(0) in whnf_apply info vbody (array_tl args) | (FOPN(Fix(reci,bnum), tb) as fx) when red_under info.i_flags IOTA @@ -815,21 +952,30 @@ and whnf_term info env t = | DOP0 op -> {norm = true; term = FOP0 op } | DOP1 (op, nt) -> { norm = false; term = FOP1 (op, freeze env nt) } | DOP2 (Cast,ct,c) -> whnf_term info env ct (* remove outer casts *) - | DOP2 (op,a,b) -> (* Lambda Prod *) - { norm = false; term = FOP2 (op, freeze env a, freeze env b) } + | DOP2 (_,_,_) -> assert false (* Lambda|Prod made explicit *) | DOPN ((AppL | Const _ | Evar _ | Abst _ | MutCase _) as op, ve) -> whnf_frterm info { norm = false; term = FOPN (op, freeze_vect env ve) } | DOPN ((MutInd _ | MutConstruct _) as op,v) -> { norm = (v=[||]); term = FOPN (op, freeze_vect env v) } | DOPN (op,v) -> { norm = false; term = FOPN (op, freeze_vect env v) } (* Fix CoFix *) - | DOPL (op,l) -> { norm = false; term = FOPL (op, freeze_list env l) } | DLAM (x,a) -> { norm = false; term = FLAM (x, freeze (subs_lift env) a, a, env) } | DLAMV (x,ve) -> { norm = (ve=[||]); term = FLAMV (x, freeze_vect (subs_lift env) ve, ve, env) } - + | CLam (n,t,c) -> + { norm = false; + term = FLam (n, typed_map (freeze env) t, freeze (subs_lift env) c, + c, env) } + | CPrd (n,t,c) -> + { norm = false; + term = FPrd (n, typed_map (freeze env) t, freeze (subs_lift env) c, + c, env) } + + (* WHNF removes LetIn (see Paula Severi) *) + | CLet (n,b,t,c) -> whnf_term info (subs_cons (freeze env b,env)) c + (* parameterized norm *) let norm_val info v = if !stats then begin diff --git a/kernel/closure.mli b/kernel/closure.mli index 0cba4cb87..940cd2664 100644 --- a/kernel/closure.mli +++ b/kernel/closure.mli @@ -4,7 +4,7 @@ (*i*) open Pp open Names -open Generic +(*i open Generic i*) open Term open Evd open Environ @@ -54,17 +54,29 @@ val betadeltaiota : flags val hnf_flags : flags +(*s Explicit substitutions of type ['a]. [ESID] = identity. + [CONS(t,S)] = $S.t$ i.e. parallel substitution. [SHIFT(n,S)] = + $(\uparrow n~o~S)$ i.e. terms in S are relocated with n vars. + [LIFT(n,S)] = $(\%n~S)$ stands for $((\uparrow n~o~S).n...1)$. *) +type 'a subs = + | ESID + | CONS of 'a * 'a subs + | SHIFT of int * 'a subs + | LIFT of int * 'a subs (*s Call by value functions *) type cbv_value = | VAL of int * constr | LAM of name * constr * constr * cbv_value subs - | FIXP of sorts oper * constr array * cbv_value subs * cbv_value list + | FIXP of fixpoint * cbv_value subs * cbv_value list + | COFIXP of cofixpoint * cbv_value subs * cbv_value list | CONSTR of int * (section_path * int) * cbv_value array * cbv_value list val shift_value : int -> cbv_value -> cbv_value -val contract_fixp : cbv_value subs -> constr -> cbv_value subs * constr +(*i Private ?? +val contract_fixp : cbv_value subs -> fixpoint -> cbv_value subs * constr +i*) type stack = | TOP @@ -78,8 +90,10 @@ val strip_appl : cbv_value -> stack -> cbv_value * stack val red_allowed : flags -> stack -> red_kind -> bool val reduce_const_body : (cbv_value -> cbv_value) -> cbv_value -> stack -> cbv_value * stack +(*i Private ?? val fixp_reducible : - (cbv_value -> cbv_value) -> flags -> sorts oper -> stack -> bool + (cbv_value -> cbv_value) -> flags -> fixpoint -> stack -> bool +i*) (* normalization of a constr: the two functions to know... *) type 'a cbv_infos @@ -99,45 +113,49 @@ val cbv_norm_value : 'a cbv_infos -> cbv_value -> constr (*s Lazy reduction. *) -type 'a freeze +type freeze -type 'a frterm = +type frterm = | FRel of int | FVAR of identifier - | FOP0 of 'a - | FOP1 of 'a * 'a freeze - | FOP2 of 'a * 'a freeze * 'a freeze - | FOPN of 'a * 'a freeze array - | FOPL of 'a * 'a freeze list - | FLAM of name * 'a freeze * 'a term * 'a freeze subs - | FLAMV of name * 'a freeze array * 'a term array * 'a freeze subs - | FLIFT of int * 'a freeze - | FFROZEN of 'a term * 'a freeze subs + | FOP0 of sorts oper + | FOP1 of sorts oper * freeze + | FOP2 of sorts oper * freeze * freeze + | FOPN of sorts oper * freeze array + | FLAM of name * freeze * constr * freeze subs + | FLAMV of name * freeze array * constr array * freeze subs + | FLam of name * type_freeze * freeze * constr * freeze subs + | FPrd of name * type_freeze * freeze * constr * freeze subs + | FLet of name * freeze * type_freeze * freeze * constr * freeze subs + | FLIFT of int * freeze + | FFROZEN of constr * freeze subs -val frterm_of : 'a freeze -> 'a frterm -val is_val : 'a freeze -> bool +and type_freeze = freeze -val lift_frterm : int -> 'a freeze -> 'a freeze -val lift_freeze : int -> 'a freeze -> 'a freeze +val frterm_of : freeze -> frterm +val is_val : freeze -> bool -val freeze : 'a freeze subs -> 'a term -> 'a freeze -val freeze_vect : 'a freeze subs -> 'a term array -> 'a freeze array -val freeze_list : 'a freeze subs -> 'a term list -> 'a freeze list +val lift_frterm : int -> freeze -> freeze +val lift_freeze : int -> freeze -> freeze -val traverse_term : 'a freeze subs -> 'a term -> 'a freeze -val lift_term_of_freeze : lift_spec -> 'a freeze -> 'a term +val freeze : freeze subs -> constr -> freeze +val freeze_vect : freeze subs -> constr array -> freeze array +val freeze_list : freeze subs -> constr list -> freeze list + +val traverse_term : freeze subs -> constr -> freeze +val lift_term_of_freeze : lift_spec -> freeze -> constr (* Back to constr *) -val fstrong : ('a freeze -> 'a freeze) -> lift_spec -> 'a freeze -> 'a term -val term_of_freeze : 'a freeze -> 'a term -val applist_of_freeze : 'a freeze array -> 'a term list +val fstrong : (freeze -> freeze) -> lift_spec -> freeze -> constr +val term_of_freeze : freeze -> constr +val applist_of_freeze : freeze array -> constr list (* contract a substitution *) -val contract_subst : int -> 'a freeze -> 'a freeze -> 'a freeze +val contract_subst : int -> constr -> freeze subs -> freeze -> freeze (* Calculus of Constructions *) -type fconstr = sorts oper freeze +type fconstr = freeze val inject : constr -> fconstr val strip_frterm : @@ -146,7 +164,7 @@ val strip_freeze : fconstr -> int * fconstr * fconstr array (* Auxiliary functions for (co)fixpoint reduction *) -val contract_fix_vect : (fconstr -> fconstr) -> sorts oper frterm -> fconstr +val contract_fix_vect : (fconstr -> fconstr) -> frterm -> fconstr val copy_case : case_info -> fconstr array -> fconstr -> fconstr diff --git a/kernel/declarations.ml b/kernel/declarations.ml index e83e1e509..a5cb164d0 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -3,7 +3,7 @@ open Names open Univ -open Generic +(*i open Generic i*) open Term open Sign diff --git a/kernel/environ.ml b/kernel/environ.ml index 217a7f989..4909e4444 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -6,7 +6,7 @@ open Util open Names open Sign open Univ -open Generic +(*i open Generic i*) open Term open Declarations open Abstraction @@ -229,32 +229,40 @@ let id_of_global env = function assert false let hdchar env c = - let rec hdrec k = function - | DOP2((Prod|Lambda),_,DLAM(_,c)) -> hdrec (k+1) c - | DOP2(Cast,c,_) -> hdrec k c - | DOPN(AppL,cl) -> hdrec k (array_hd cl) - | DOPN(Const _,_) as x -> - let c = lowercase_first_char (basename (path_of_const x)) in + let rec hdrec k c = + match kind_of_term c with + | IsProd (_,_,c) -> hdrec (k+1) c + | IsLambda (_,_,c) -> hdrec (k+1) c + | IsLetIn (_,_,_,c) -> hdrec (k+1) c + | IsCast (c,_) -> hdrec k c + | IsAppL (f,l) -> hdrec k f + | IsConst (sp,_) -> + let c = lowercase_first_char (basename sp) in if c = "?" then "y" else c - | DOPN(Abst _,_) as x -> - lowercase_first_char (basename (path_of_abst x)) - | DOPN(MutInd (sp,i) as x,_) -> + | IsMutInd ((sp,i) as x,_) -> if i=0 then lowercase_first_char (basename sp) else - let na = id_of_global env x in lowercase_first_char na - | DOPN(MutConstruct(sp,i) as x,_) -> - let na = id_of_global env x in String.lowercase(List.hd(explode_id na)) - | VAR id -> lowercase_first_char id - | DOP0(Sort s) -> sort_hdchar s - | Rel n -> + let na = id_of_global env (MutInd x) in lowercase_first_char na + | IsMutConstruct ((sp,i) as x,_) -> + let na = id_of_global env (MutConstruct x) in + String.lowercase(List.hd(explode_id na)) + | IsVar id -> lowercase_first_char id + | IsSort s -> sort_hdchar s + | IsRel n -> (if n<=k then "p" (* the initial term is flexible product/function *) else try match lookup_rel_type (n-k) env with | Name id,_ -> lowercase_first_char id | Anonymous,t -> hdrec 0 (lift (n-k) (body_of_type t)) with Not_found -> "y") - | _ -> "y" + | IsFix ((_,i),(_,ln,_)) -> + let id = match List.nth ln i with Name id -> id | _ -> assert false in + lowercase_first_char id + | IsCoFix (i,(_,ln,_)) -> + let id = match List.nth ln i with Name id -> id | _ -> assert false in + lowercase_first_char id + | IsMeta _|IsXtra _|IsAbst (_, _)|IsEvar _|IsMutCase (_, _, _, _) -> "y" in hdrec 0 c @@ -266,14 +274,14 @@ let named_hd env a = function | Anonymous -> Name (id_of_string (hdchar env a)) | x -> x -let prod_name env (n,a,b) = mkProd (named_hd env a n) a b -let lambda_name env (n,a,b) = mkLambda (named_hd env a n) a b +let prod_name env (n,a,b) = mkProd (named_hd env a n, a, b) +let lambda_name env (n,a,b) = mkLambda (named_hd env a n, a, b) let it_prod_name env = List.fold_left (fun c (n,t) ->prod_name env (n,t,c)) let it_lambda_name env = List.fold_left (fun c (n,t) ->lambda_name env (n,t,c)) -let prod_create env (a,b) = mkProd (named_hd env a Anonymous) a b -let lambda_create env (a,b) = mkLambda (named_hd env a Anonymous) a b +let prod_create env (a,b) = mkProd (named_hd env a Anonymous, a, b) +let lambda_create env (a,b) = mkLambda (named_hd env a Anonymous, a, b) let name_assumption env (na,c,t) = match c with @@ -286,6 +294,7 @@ let lambda_assum_name env b d = mkLambda_or_LetIn (name_assumption env d) b let it_mkProd_or_LetIn_name env = List.fold_left (prod_assum_name env) let it_mkLambda_or_LetIn_name env = List.fold_left (lambda_assum_name env) +let it_mkProd_wo_LetIn = List.fold_left (fun c d -> mkProd_wo_LetIn d c) let it_mkProd_or_LetIn = List.fold_left (fun c d -> mkProd_or_LetIn d c) let it_mkLambda_or_LetIn = List.fold_left (fun c d -> mkLambda_or_LetIn d c) diff --git a/kernel/environ.mli b/kernel/environ.mli index 981be607f..b99410bd3 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -130,6 +130,7 @@ val it_prod_name : env -> constr -> (name * constr) list -> constr val it_mkLambda_or_LetIn_name : env -> constr -> rel_context -> constr val it_mkProd_or_LetIn_name : env -> constr -> rel_context -> constr +val it_mkProd_wo_LetIn : constr -> rel_context -> constr val it_mkLambda_or_LetIn : constr -> rel_context -> constr val it_mkProd_or_LetIn : constr -> rel_context -> constr diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 0536b1f2f..a37e469bd 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -3,7 +3,7 @@ open Util open Names -open Generic +(*i open Generic i*) open Term open Declarations open Inductive @@ -92,14 +92,6 @@ let mind_extract_and_check_params mie = List.iter (fun (_,c,_,_) -> check_params params (extract nparams c)) l; params -let decomp_all_DLAMV_name constr = - let rec decomprec lna = function - | DLAM(na,lc) -> decomprec (na::lna) lc - | DLAMV(na,lc) -> (na::lna,lc) - | _ -> assert false - in - decomprec [] constr - let mind_check_lc params mie = let nparams = List.length params in let check_lc (_,_,_,lc) = @@ -156,6 +148,7 @@ let failwith_non_pos_vect n ntypes v = anomaly "failwith_non_pos_vect: some k in [n;n+ntypes-1] should occur in v" let check_correct_par env nparams ntypes n l largs = + let largs = Array.of_list largs in if Array.length largs < nparams then raise (IllFormedInd (LocalNotEnoughArgs l)); let (lpar,largs') = array_chop nparams largs in @@ -182,40 +175,40 @@ let decomp_par n c = snd (mind_extract_params n c) let listrec_mconstr env ntypes nparams i indlc = (* check the inductive types occur positively in [c] *) let rec check_pos n c = - match whd_betadeltaiota env Evd.empty c with - | DOP2(Prod,b,DLAM(na,d)) -> - if not (noccur_between n ntypes b) then raise (IllFormedInd (LocalNonPos n)); + let x,largs = whd_betadeltaiota_stack env Evd.empty c [] in + match kind_of_term x with + | IsProd (na,b,d) -> + assert (largs = []); + if not (noccur_between n ntypes b) then + raise (IllFormedInd (LocalNonPos n)); check_pos (n+1) d - | x -> - let hd,largs = destApplication (ensure_appl x) in - match hd with - | Rel k -> - if k >= n && k<n+ntypes then begin - check_correct_par env nparams ntypes n (k-n+1) largs; - Mrec(n+ntypes-k-1) - end else if noccur_between n ntypes x then - if (n-nparams) <= k & k <= (n-1) - then Param(n-1-k) - else Norec - else - raise (IllFormedInd (LocalNonPos n)) - | DOPN(MutInd ind_sp,a) -> - if (noccur_between n ntypes x) then Norec - else Imbr(ind_sp,imbr_positive n (ind_sp,a) largs) - | err -> - if noccur_between n ntypes x then Norec - else raise (IllFormedInd (LocalNonPos n)) + | IsRel k -> + if k >= n && k<n+ntypes then begin + check_correct_par env nparams ntypes n (k-n+1) largs; + Mrec(n+ntypes-k-1) + end else if noccur_between n ntypes x then + if (n-nparams) <= k & k <= (n-1) + then Param(n-1-k) + else Norec + else + raise (IllFormedInd (LocalNonPos n)) + | IsMutInd (ind_sp,a) -> + if (noccur_between n ntypes x) then Norec + else Imbr(ind_sp,imbr_positive n (ind_sp,a) largs) + | err -> + if noccur_between n ntypes x then Norec + else raise (IllFormedInd (LocalNonPos n)) and imbr_positive n mi largs = let mispeci = lookup_mind_specif mi env in let auxnpar = mis_nparams mispeci in - let (lpar,auxlargs) = array_chop auxnpar largs in - if not (array_for_all (noccur_between n ntypes) auxlargs) then + let (lpar,auxlargs) = list_chop auxnpar largs in + if not (List.for_all (noccur_between n ntypes) auxlargs) then raise (IllFormedInd (LocalNonPos n)); let auxlc = mis_lc mispeci and auxntyp = mis_ntypes mispeci in if auxntyp <> 1 then raise (IllFormedInd (LocalNonPos n)); - let lrecargs = array_map_to_list (check_weak_pos n) lpar in + let lrecargs = List.map (check_weak_pos n) lpar in (* The abstract imbricated inductive type with parameters substituted *) let auxlcvect = abstract_mind_lc env auxntyp auxnpar auxlc in let newidx = n + auxntyp in @@ -224,8 +217,8 @@ let listrec_mconstr env ntypes nparams i indlc = (* when substituted *) Array.map (function c -> - let c' = hnf_prod_appvect env Evd.empty c - (Array.map (lift auxntyp) lpar) in + let c' = hnf_prod_applist env Evd.empty c + (List.map (lift auxntyp) lpar) in check_construct false newidx c') auxlcvect in @@ -248,15 +241,16 @@ let listrec_mconstr env ntypes nparams i indlc = (* Since Lambda can no longer occur after a product or a MutInd, I have branched the remaining cases on check_pos. HH 28/1/00 *) - and check_weak_pos n c = - match whd_betadeltaiota env Evd.empty c with + and check_weak_pos n c = + let x = whd_betadeltaiota env Evd.empty c in + match kind_of_term x with (* The extra case *) - | DOP2(Lambda,b,DLAM(na,d)) -> + | IsLambda (na,b,d) -> if noccur_between n ntypes b then check_weak_pos (n+1) d else raise (IllFormedInd (LocalNonPos n)) (******************) - | x -> check_pos n x + | _ -> check_pos n x (* check the inductive types occur positively in the products of C, if check_head=true, also check the head corresponds to a constructor of @@ -264,19 +258,20 @@ let listrec_mconstr env ntypes nparams i indlc = and check_construct check_head = let rec check_constr_rec lrec n c = - match whd_betadeltaiota env Evd.empty c with - | DOP2(Prod,b,DLAM(na,d)) -> + let x,largs = whd_betadeltaiota_stack env Evd.empty c [] in + match kind_of_term x with + | IsProd (na,b,d) -> + assert (largs = []); let recarg = check_pos n b in check_constr_rec (recarg::lrec) (n+1) d - | x -> - let hd,largs = destApplication (ensure_appl x) in + | hd -> if check_head then - match hd with - | Rel k when k = n+ntypes-i -> - check_correct_par env nparams ntypes n (k-n+1) largs - | _ -> raise (IllFormedInd LocalNotConstructor) + if hd = IsRel (n+ntypes-i) then + check_correct_par env nparams ntypes n (ntypes-i+1) largs + else + raise (IllFormedInd LocalNotConstructor) else - if not (array_for_all (noccur_between n ntypes) largs) + if not (List.for_all (noccur_between n ntypes) largs) then raise (IllFormedInd (LocalNonPos n)); List.rev lrec in check_constr_rec [] diff --git a/kernel/inductive.ml b/kernel/inductive.ml index 43b756651..db3329a1a 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -4,7 +4,7 @@ open Util open Names open Univ -open Generic +(*i open Generic i*) open Term open Sign open Declarations diff --git a/kernel/instantiate.ml b/kernel/instantiate.ml index 9fb85961f..627f0d45c 100644 --- a/kernel/instantiate.ml +++ b/kernel/instantiate.ml @@ -4,7 +4,7 @@ open Pp open Util open Names -open Generic +(*i open Generic i*) open Term open Sign open Evd diff --git a/kernel/reduction.ml b/kernel/reduction.ml index c4642b933..f0f7945d6 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -4,7 +4,7 @@ open Pp open Util open Names -open Generic +(*i open Generic i*) open Term open Univ open Evd @@ -26,6 +26,17 @@ type 'a stack_reduction_function = 'a contextual_stack_reduction_function type local_stack_reduction_function = constr -> constr list -> constr * constr list +type stack = + | EmptyStack + | ConsStack of constr array * int * stack + +let decomp_stack = function + | EmptyStack -> None + | ConsStack (v, n, s) -> + Some (v.(n), (if n+1 = Array.length v then s else ConsStack (v, n+1, s))) + +let append_stack v s = if Array.length v = 0 then s else ConsStack (v,0,s) + (*************************************) (*** Reduction Functions Operators ***) (*************************************) @@ -49,44 +60,66 @@ let stack_reduction_of_reduction red_fun env sigma x stack = whd_stack t [] let strong whdfun env sigma = - let rec strongrec t = match whdfun env sigma t with + let rec strongrec env t = match whdfun env sigma t with | DOP0 _ as t -> t + | DOP1(oper,c) -> DOP1(oper,strongrec env c) + | DOP2(oper,c1,c2) -> DOP2(oper,strongrec env c1,strongrec env c2) (* Cas ad hoc *) - | DOP1(oper,c) -> DOP1(oper,strongrec c) - (* Faut differencier sinon fait planter kind_of_term *) - | DOP2(Prod|Lambda as oper,c1,DLAM(na,c2)) -> - DOP2(oper,strongrec c1,DLAM(na,strongrec c2)) - | DOP2(oper,c1,c2) -> DOP2(oper,strongrec c1,strongrec c2) - | DOPN(oper,cl) -> DOPN(oper,Array.map strongrec cl) - | DOPL(oper,cl) -> DOPL(oper,List.map strongrec cl) - | DLAM(na,c) -> DLAM(na,strongrec c) - | DLAMV(na,c) -> DLAMV(na,Array.map strongrec c) + | DOPN(Fix _ as oper,cl) -> + let cl' = Array.copy cl in + let l = Array.length cl -1 in + for i=0 to l-1 do cl'.(i) <- strongrec env cl.(i) done; + cl'.(l) <- strongrec_lam env cl.(l); + DOPN(oper, cl') + | DOPN(oper,cl) -> DOPN(oper,Array.map (strongrec env) cl) + | CLam (n,t,c) -> + CLam (n, typed_app (strongrec env) t, strongrec (push_rel_decl (n,t) env) c) + | CPrd (n,t,c) -> + CPrd (n, typed_app (strongrec env) t, strongrec (push_rel_decl (n,t) env) c) + | CLet (n,b,t,c) -> + CLet (n, strongrec env b, typed_app (strongrec env) t, + strongrec (push_rel_def (n,b,t) env) c) | VAR _ as t -> t | Rel _ as t -> t + | DLAM _ | DLAMV _ -> assert false + and strongrec_lam env = function (* Gestion incorrecte de l'env des Fix *) + | DLAM(na,c) -> DLAM(na,strongrec_lam env c) + | DLAMV(na,c) -> DLAMV(na,Array.map (strongrec env) c) + | _ -> assert false in - strongrec + strongrec env let local_strong whdfun = let rec strongrec t = match whdfun t with | DOP0 _ as t -> t - (* Cas ad hoc *) | DOP1(oper,c) -> DOP1(oper,strongrec c) | DOP2(oper,c1,c2) -> DOP2(oper,strongrec c1,strongrec c2) + (* Cas ad hoc *) + | DOPN(Fix _ as oper,cl) -> + let cl' = Array.copy cl in + let l = Array.length cl -1 in + for i=0 to l-1 do cl'.(i) <- strongrec cl.(i) done; + cl'.(l) <- strongrec_lam cl.(l); + DOPN(oper, cl') | DOPN(oper,cl) -> DOPN(oper,Array.map strongrec cl) - | DOPL(oper,cl) -> DOPL(oper,List.map strongrec cl) - | DLAM(na,c) -> DLAM(na,strongrec c) - | DLAMV(na,c) -> DLAMV(na,Array.map strongrec c) + | CLam(n,t,c) -> CLam (n, typed_app strongrec t, strongrec c) + | CPrd(n,t,c) -> CPrd (n, typed_app strongrec t, strongrec c) + | CLet(n,b,t,c) -> CLet (n, strongrec b,typed_app strongrec t, strongrec c) | VAR _ as t -> t | Rel _ as t -> t + | DLAM _ | DLAMV _ -> assert false + and strongrec_lam = function + | DLAM(na,c) -> DLAM(na,strongrec_lam c) + | DLAMV(na,c) -> DLAMV(na,Array.map strongrec c) + | _ -> assert false in strongrec -let rec strong_prodspine redfun env sigma c = - match redfun env sigma c with - | DOP2(Prod,a,DLAM(na,b)) -> - DOP2(Prod,a,DLAM(na,strong_prodspine redfun env sigma b)) - | x -> x - +let rec strong_prodspine redfun c = + let x = redfun c in + match kind_of_term x with + | IsProd (na,a,b) -> mkProd (na,a,strong_prodspine redfun b) + | _ -> x (****************************************************************************) (* Reduction Functions *) @@ -122,17 +155,14 @@ let whd_flags flgs env sigma t = (* Red reduction tactic: reduction to a product *) let red_product env sigma c = let rec redrec x = - match x with - | DOPN(AppL,cl) -> - DOPN(AppL,Array.append [|redrec (array_hd cl)|] (array_tl cl)) - | DOPN(Const _,_) when evaluable_constant env x -> - constant_value env x - | DOPN(Evar ev,args) when Evd.is_defined sigma ev -> + match kind_of_term x with + | IsAppL (f,l) -> applist (redrec f, l) + | IsConst (_,_) when evaluable_constant env x -> constant_value env x + | IsEvar (ev,args) when Evd.is_defined sigma ev -> existential_value sigma (ev,args) - | DOPN(Abst _,_) when evaluable_abst env x -> - abst_value env x - | DOP2(Cast,c,_) -> redrec c - | DOP2(Prod,a,DLAM(x,b)) -> DOP2(Prod, a, DLAM(x, redrec b)) + | IsAbst (_,_) when evaluable_abst env x -> abst_value env x + | IsCast (c,_) -> redrec c + | IsProd (x,a,b) -> mkProd (x, a, redrec b) | _ -> error "Term not reducible" in nf_betaiota env sigma (redrec c) @@ -141,33 +171,26 @@ let red_product env sigma c = * n is the number of the next occurence of name. * ol is the occurence list to find. *) let rec substlin env name n ol c = - match c with - | DOPN(Const sp,_) -> - if sp = name then - if List.hd ol = n then - if evaluable_constant env c then - (n+1, List.tl ol, constant_value env c) - else - errorlabstrm "substlin" - [< print_sp sp; 'sTR " is not a defined constant" >] - else - ((n+1),ol,c) + match kind_of_term c with + | IsConst (sp,_) when sp = name -> + if List.hd ol = n then + if evaluable_constant env c then + (n+1, List.tl ol, constant_value env c) + else + errorlabstrm "substlin" + [< print_sp sp; 'sTR " is not a defined constant" >] else - (n,ol,c) + ((n+1),ol,c) - | DOPN(Abst _,_) -> - if path_of_abst c = name then - if List.hd ol = n then - (n+1, List.tl ol, abst_value env c) - else - (n+1,ol,c) + | IsAbst (_,_) when path_of_abst c = name -> + if List.hd ol = n then + (n+1, List.tl ol, abst_value env c) else - (n,ol,c) + (n+1,ol,c) (* INEFFICIENT: OPTIMIZE *) - | DOPN(AppL,tl) -> - let c1 = array_hd tl and cl = array_tl tl in - Array.fold_left + | IsAppL (c1,cl) -> + List.fold_left (fun (n1,ol1,c1') c2 -> (match ol1 with | [] -> (n1,[],applist(c1',[c2])) @@ -176,24 +199,31 @@ let rec substlin env name n ol c = (n2,ol2,applist(c1',[c2'])))) (substlin env name n ol c1) cl - | DOP2(Lambda,c1,DLAM(na,c2)) -> + | IsLambda (na,c1,c2) -> let (n1,ol1,c1') = substlin env name n ol c1 in (match ol1 with - | [] -> (n1,[],DOP2(Lambda,c1',DLAM(na,c2))) + | [] -> (n1,[],mkLambda (na,c1',c2)) | _ -> let (n2,ol2,c2') = substlin env name n1 ol1 c2 in - (n2,ol2,DOP2(Lambda,c1',DLAM(na,c2')))) + (n2,ol2,mkLambda (na,c1',c2'))) - | DOP2(Prod,c1,DLAM(na,c2)) -> + | IsLetIn (na,c1,t,c2) -> let (n1,ol1,c1') = substlin env name n ol c1 in (match ol1 with - | [] -> (n1,[],DOP2(Prod,c1',DLAM(na,c2))) + | [] -> (n1,[],mkLambda (na,c1',c2)) | _ -> let (n2,ol2,c2') = substlin env name n1 ol1 c2 in - (n2,ol2,DOP2(Prod,c1',DLAM(na,c2')))) + (n2,ol2,mkLambda (na,c1',c2'))) + + | IsProd (na,c1,c2) -> + let (n1,ol1,c1') = substlin env name n ol c1 in + (match ol1 with + | [] -> (n1,[],mkProd (na,c1',c2)) + | _ -> + let (n2,ol2,c2') = substlin env name n1 ol1 c2 in + (n2,ol2,mkProd (na,c1',c2'))) - | DOPN(MutCase _,_) -> - let (ci,p,d,llf) = destCase c in + | IsMutCase (ci,p,d,llf) -> let rec substlist nn oll = function | [] -> (nn,oll,[]) | f::lfe -> @@ -213,23 +243,26 @@ let rec substlin env name n ol c = | [] -> (n2,[],mkMutCaseA ci p' d' llf) | _ -> let (n3,ol3,lf') = substlist n2 ol2 (Array.to_list llf) - in (n3,ol3,mkMutCase ci p' d' lf'))) + in (n3,ol3,mkMutCase (ci, p', d', lf')))) - | DOP2(Cast,c1,c2) -> + | IsCast (c1,c2) -> let (n1,ol1,c1') = substlin env name n ol c1 in (match ol1 with - | [] -> (n1,[],DOP2(Cast,c1',c2)) + | [] -> (n1,[],mkCast (c1',c2)) | _ -> let (n2,ol2,c2') = substlin env name n1 ol1 c2 in - (n2,ol2,DOP2(Cast,c1',c2'))) + (n2,ol2,mkCast (c1',c2'))) - | DOPN(Fix _,_) -> + | IsFix _ -> (warning "do not consider occurrences inside fixpoints"; (n,ol,c)) - | DOPN(CoFix _,_) -> + | IsCoFix _ -> (warning "do not consider occurrences inside cofixpoints"; (n,ol,c)) + + | (IsRel _|IsMeta _|IsVar _|IsXtra _|IsSort _ + |IsAbst (_, _)|IsEvar _|IsConst _ + |IsMutInd _|IsMutConstruct _) -> (n,ol,c) - | _ -> (n,ol,c) let unfold env sigma name = let flag = @@ -275,9 +308,9 @@ let abstract_scheme env (locc,a,ta) t = let na = named_hd env ta Anonymous in if occur_meta ta then error "cannot find a type for the generalisation"; if occur_meta a then - DOP2(Lambda,ta,DLAM(na,t)) + mkLambda (na,ta,t) else - DOP2(Lambda, ta, DLAM(na,subst_term_occ locc a t)) + mkLambda (na, ta,subst_term_occ locc a t) let pattern_occs loccs_trm_typ env sigma c = @@ -293,26 +326,25 @@ let pattern_occs loccs_trm_typ env sigma c = let rec stacklam recfun env t stack = match (stack,t) with - | (h::stacktl, DOP2(Lambda,_,DLAM(_,c))) -> - stacklam recfun (h::env) c stacktl - | _ -> recfun (substl env t) stack + | h::stacktl, CLam (_,_,c) -> stacklam recfun (h::env) c stacktl + | _ -> recfun (substl env t, stack) -let beta_applist (c,l) = stacklam (fun c l -> applist(c,l)) [] c l +let beta_applist (c,l) = stacklam applist [] c l -let whd_beta_stack = - let rec whrec x stack = match x with - | DOP2(Lambda,c1,DLAM(name,c2)) -> +let whd_beta_stack x stack = + let rec whrec (x, stack as s) = match x with + | CLam (name,c1,c2) -> (match stack with | [] -> (x,[]) | a1::rest -> stacklam whrec [a1] c2 rest) - | DOPN(AppL,cl) -> whrec (array_hd cl) (array_app_tl cl stack) - | DOP2(Cast,c,_) -> whrec c stack - | x -> (x,stack) + | DOPN(AppL,cl) -> whrec (array_hd cl, array_app_tl cl stack) + | DOP2(Cast,c,_) -> whrec (c, stack) + | x -> s in - whrec + whrec (x, stack) let whd_beta x = applist (whd_beta_stack x []) @@ -375,103 +407,105 @@ let whd_delta_stack env sigma = let whd_delta env sigma c = applist(whd_delta_stack env sigma c []) -let whd_betadelta_stack env sigma = - let rec whrec x l = - match x with - | DOPN(Const _,_) -> +let whd_betadelta_stack env sigma x l = + let rec whrec (x, l as s) = + match kind_of_term x with + | IsConst _ -> if evaluable_constant env x then - whrec (constant_value env x) l + whrec (constant_value env x, l) else - (x,l) - | DOPN(Evar ev,args) -> + s + | IsEvar (ev,args) -> if Evd.is_defined sigma ev then - whrec (existential_value sigma (ev,args)) l + whrec (existential_value sigma (ev,args), l) else - (x,l) + s +(* | DOPN(Abst _,_) -> if evaluable_abst env x then whrec (abst_value env x) l else (x,l) - | DOP2(Cast,c,_) -> whrec c l - | DOPN(AppL,cl) -> whrec (array_hd cl) (array_app_tl cl l) - | DOP2(Lambda,_,DLAM(_,c)) -> +*) + | IsCast (c,_) -> whrec (c, l) + | IsAppL (f,cl) -> whrec (f, cl@l) + | IsLambda (_,_,c) -> (match l with - | [] -> (x,l) + | [] -> s | (a::m) -> stacklam whrec [a] c m) - | x -> (x,l) + | x -> s in - whrec + whrec (x, l) let whd_betadelta env sigma c = applist(whd_betadelta_stack env sigma c []) -let whd_betaevar_stack env sigma = - let rec whrec x l = - match x with - | DOPN(Evar ev,args) -> +let whd_betaevar_stack env sigma x l = + let rec whrec (x, l as s) = + match kind_of_term x with + | IsEvar (ev,args) -> if Evd.is_defined sigma ev then - whrec (existential_value sigma (ev,args)) l + whrec (existential_value sigma (ev,args), l) else - (x,l) + s +(* | DOPN(Abst _,_) -> if translucent_abst env x then whrec (abst_value env x) l else (x,l) - | DOP2(Cast,c,_) -> whrec c l - | DOPN(AppL,cl) -> whrec (array_hd cl) (array_app_tl cl l) - | DOP2(Lambda,_,DLAM(_,c)) -> +*) + | IsCast (c,_) -> whrec (c, l) + | IsAppL (f,cl) -> whrec (f, cl@l) + | IsLambda (_,_,c) -> (match l with | [] -> (x,l) | (a::m) -> stacklam whrec [a] c m) - | DOPN(Const _,_) -> (x,l) - | x -> (x,l) + | x -> s in - whrec + whrec (x, l) let whd_betaevar env sigma c = applist(whd_betaevar_stack env sigma c []) -let whd_betadeltaeta_stack env sigma = - let rec whrec x stack = - match x with - | DOPN(Const _,_) -> - if evaluable_constant env x then - whrec (constant_value env x) stack +let whd_betadeltaeta_stack env sigma x l = + let rec whrec (x, l as s) = + match kind_of_term x with + | IsConst _ -> + if evaluable_constant env x then + whrec (constant_value env x, l) else - (x,stack) - | DOPN(Evar ev,args) -> + s + | IsEvar (ev,args) -> if Evd.is_defined sigma ev then - whrec (existential_value sigma (ev,args)) stack + whrec (existential_value sigma (ev,args), l) else - (x,stack) + s +(* | DOPN(Abst _,_) -> - if evaluable_abst env x then - whrec (abst_value env x) stack + if evaluable_abst env x then + whrec (abst_value env x) l else - (x,stack) - | DOP2(Cast,c,_) -> whrec c stack - | DOPN(AppL,cl) -> whrec (array_hd cl) (array_app_tl cl stack) - | DOP2(Lambda,_,DLAM(_,c)) -> - (match stack with - | [] -> - (match applist (whrec c []) with - | DOPN(AppL,cl) -> - (match whrec (array_last cl) [] with - | (Rel 1,[]) -> - let napp = (Array.length cl) -1 in - if napp = 0 then (x,stack) else - let lc = Array.sub cl 0 napp in - let u = - if napp = 1 then lc.(0) else DOPN(AppL,lc) - in - if noccurn 1 u then (pop u,[]) else (x,stack) - | _ -> (x,stack)) - | _ -> (x,stack)) + (x,l) +*) + | IsCast (c,_) -> whrec (c, l) + | IsAppL (f,cl) -> whrec (f, cl@l) + | IsLambda (_,_,c) -> + (match l with + | [] -> + (match applist (whrec (c, [])) with + | DOPN(AppL,cl) -> + let napp = (Array.length cl) -1 in + (match whrec (array_last cl, []) with + | (Rel 1,[]) when napp > 0 -> + let lc = Array.sub cl 0 napp in + let u = if napp=1 then lc.(0) else DOPN(AppL,lc) + in if noccurn 1 u then (pop u,[]) else s + | _ -> s) + | _ -> s) | (a::m) -> stacklam whrec [a] c m) - | x -> (x,stack) + | x -> s in - whrec + whrec (x, l) let whd_betadeltaeta env sigma x = applist(whd_betadeltaeta_stack env sigma x []) @@ -540,185 +574,185 @@ let fix_recarg ((recindices,bodynum),_) stack = else None +type fix_reduction_result = NotReducible | Reduced of (constr * constr list) + let reduce_fix whfun fix stack = - let dfix = destFix fix in - match fix_recarg dfix stack with - | None -> (false,(fix,stack)) + match fix_recarg fix stack with + | None -> NotReducible | Some (recargnum,recarg) -> - let (recarg'hd,_ as recarg') = whfun recarg [] in + let (recarg'hd,_ as recarg') = whfun (recarg, []) in let stack' = list_assign stack recargnum (applist recarg') in (match recarg'hd with - | DOPN(MutConstruct _,_) -> - (true,(contract_fix dfix,stack')) - | _ -> (false,(fix,stack'))) + | DOPN(MutConstruct _,_) -> Reduced (contract_fix fix, stack') + | _ -> NotReducible) (* NB : Cette fonction alloue peu c'est l'appel ``let (recarg'hd,_ as recarg') = whfun recarg [] in'' -------------------- qui coute cher dans whd_betadeltaiota *) -let whd_betaiota_stack = - let rec whrec x stack = - match x with - | DOP2(Cast,c,_) -> whrec c stack - | DOPN(AppL,cl) -> whrec (array_hd cl) (array_app_tl cl stack) - | DOP2(Lambda,_,DLAM(_,c)) -> +let whd_betaiota_stack x l = + let rec whrec (x,stack as s) = + match kind_of_term x with + | IsCast (c,_) -> whrec (c, stack) + | IsAppL (f,cl) -> whrec (f, cl@stack) + | IsLambda (_,_,c) -> (match stack with - | [] -> (x,stack) - | (a::m) -> stacklam whrec [a] c m) - | DOPN(MutCase _,_) -> - let (ci,p,d,lf) = destCase x in - let (c,cargs) = whrec d [] in + | [] -> s + | a::m -> stacklam whrec [a] c m) + | IsMutCase (ci,p,d,lf) -> + let (c,cargs) = whrec (d, []) in if reducible_mind_case c then whrec (reduce_mind_case - {mP=p; mconstr=c; mcargs=cargs; mci=ci; mlf=lf}) stack + {mP=p; mconstr=c; mcargs=cargs; mci=ci; mlf=lf}, stack) else (mkMutCaseA ci p (applist(c,cargs)) lf, stack) - | DOPN(Fix _,_) -> - let (reduced,(fix,stack)) = reduce_fix whrec x stack in - if reduced then whrec fix stack else (fix,stack) - | x -> (x,stack) + | IsFix fix -> + (match reduce_fix whrec fix stack with + | Reduced s' -> whrec s' + | NotReducible -> s) + | _ -> s in - whrec + whrec (x, l) let whd_betaiota x = applist (whd_betaiota_stack x []) -let whd_betaiotaevar_stack env sigma = - let rec whrec x stack = - match x with - | DOPN(Evar ev,args) -> +let whd_betaiotaevar_stack env sigma x l = + let rec whrec (x, stack as s) = + match kind_of_term x with + | IsEvar (ev,args) -> if Evd.is_defined sigma ev then - whrec (existential_value sigma (ev,args)) stack + whrec (existential_value sigma (ev,args), stack) else - (x,stack) + s +(* | DOPN(Abst _,_) -> if translucent_abst env x then whrec (abst_value env x) stack else (x,stack) - | DOP2(Cast,c,_) -> whrec c stack - | DOPN(AppL,cl) -> whrec (array_hd cl) (array_app_tl cl stack) - | DOP2(Lambda,_,DLAM(_,c)) -> +*) + | IsCast (c,_) -> whrec (c, stack) + | IsAppL (f,cl) -> whrec (f, cl@stack) + | IsLambda (_,_,c) -> (match stack with - | [] -> (x,stack) + | [] -> s | (a::m) -> stacklam whrec [a] c m) - | DOPN(MutCase _,_) -> - let (ci,p,d,lf) = destCase x in - let (c,cargs) = whrec d [] in + | IsMutCase (ci,p,d,lf) -> + let (c,cargs) = whrec (d, []) in if reducible_mind_case c then whrec (reduce_mind_case - {mP=p; mconstr=c; mcargs=cargs; mci=ci; mlf=lf}) stack + {mP=p; mconstr=c; mcargs=cargs; mci=ci; mlf=lf}, stack) else - (mkMutCaseA ci p (applist(c,cargs)) lf,stack) - | DOPN(Fix _,_) -> - let (reduced,(fix,stack)) = reduce_fix whrec x stack in - if reduced then whrec fix stack else (fix,stack) - | DOPN(Const _,_) -> (x,stack) - | x -> (x,stack) + (mkMutCaseA ci p (applist(c,cargs)) lf, stack) + | IsFix fix -> + (match reduce_fix whrec fix stack with + | Reduced s' -> whrec s' + | NotReducible -> s) + | _ -> s in - whrec + whrec (x, l) let whd_betaiotaevar env sigma x = applist(whd_betaiotaevar_stack env sigma x []) -let whd_betadeltaiota_stack env sigma = - let rec bdi_rec x stack = - match x with - | DOPN(Const _,_) -> +let whd_betadeltaiota_stack env sigma x l = + let rec whrec (x, stack as s) = + match kind_of_term x with + | IsConst _ -> if evaluable_constant env x then - bdi_rec (constant_value env x) stack + whrec (constant_value env x, stack) else - (x,stack) - | DOPN(Evar ev,args) -> + s + | IsEvar (ev,args) -> if Evd.is_defined sigma ev then - bdi_rec (existential_value sigma (ev,args)) stack + whrec (existential_value sigma (ev,args), stack) else - (x,stack) + s +(* | DOPN(Abst _,_) -> if evaluable_abst env x then - bdi_rec (abst_value env x) stack + whrec (abst_value env x) stack else (x,stack) - | DOP2(Cast,c,_) -> bdi_rec c stack - | DOPN(AppL,cl) -> bdi_rec (array_hd cl) (array_app_tl cl stack) - | DOP2(Lambda,_,DLAM(_,c)) -> +*) + | IsCast (c,_) -> whrec (c, stack) + | IsAppL (f,cl) -> whrec (f, cl@stack) + | IsLambda (_,_,c) -> (match stack with - | [] -> (x,[]) - | (a::m) -> stacklam bdi_rec [a] c m) - | DOPN(MutCase _,_) -> - let (ci,p,d,lf) = destCase x in - let (c,cargs) = bdi_rec d [] in + | [] -> s + | (a::m) -> stacklam whrec [a] c m) + | IsMutCase (ci,p,d,lf) -> + let (c,cargs) = whrec (d, []) in if reducible_mind_case c then - bdi_rec (reduce_mind_case - {mP=p; mconstr=c; mcargs=cargs; mci=ci; mlf=lf}) stack + whrec (reduce_mind_case + {mP=p; mconstr=c; mcargs=cargs; mci=ci; mlf=lf}, stack) else - (mkMutCaseA ci p (applist(c,cargs)) lf,stack) - | DOPN(Fix _,_) -> - let (reduced,(fix,stack)) = reduce_fix bdi_rec x stack in - if reduced then bdi_rec fix stack else (fix,stack) - | x -> (x,stack) + (mkMutCaseA ci p (applist(c,cargs)) lf, stack) + | IsFix fix -> + (match reduce_fix whrec fix stack with + | Reduced s' -> whrec s' + | NotReducible -> s) + | _ -> s in - bdi_rec + whrec (x, l) let whd_betadeltaiota env sigma x = applist(whd_betadeltaiota_stack env sigma x []) -let whd_betadeltaiotaeta_stack env sigma = - let rec whrec x stack = - match x with - | DOPN(Const _,_) -> - if evaluable_constant env x then - whrec (constant_value env x) stack +let whd_betadeltaiotaeta_stack env sigma x l = + let rec whrec (x, stack as s) = + match kind_of_term x with + | IsConst _ -> + if evaluable_constant env x then + whrec (constant_value env x, stack) else - (x,stack) - | DOPN(Evar ev,args) -> + s + | IsEvar (ev,args) -> if Evd.is_defined sigma ev then - whrec (existential_value sigma (ev,args)) stack + whrec (existential_value sigma (ev,args), stack) else - (x,stack) + s +(* | DOPN(Abst _,_) -> - if evaluable_abst env x then - whrec (abst_value env x) stack - else + if evaluable_abst env x then + whrec (abst_value env x) stack + else (x,stack) - | DOP2(Cast,c,_) -> whrec c stack - | DOPN(AppL,cl) -> whrec (array_hd cl) (array_app_tl cl stack) - | DOP2(Lambda,_,DLAM(_,c)) -> +*) + | IsCast (c,_) -> whrec (c, stack) + | IsAppL (f,cl) -> whrec (f, cl@stack) + | IsLambda (_,_,c) -> (match stack with | [] -> - (match applist (whrec c []) with - | DOPN(AppL,cl) -> - (match whrec (array_last cl) [] with - | (Rel 1,[]) -> - let napp = (Array.length cl) -1 in - if napp = 0 then - (x,stack) - else - let lc = Array.sub cl 0 napp in - let u = - if napp = 1 then lc.(0) else DOPN(AppL,lc) - in - if noccurn 1 u then (pop u,[]) else (x,stack) - | _ -> (x,stack)) - | _ -> (x,stack)) + (match applist (whrec (c, [])) with + | DOPN(AppL,cl) -> + let napp = (Array.length cl) -1 in + (match whrec (array_last cl, []) with + | (Rel 1,[]) when napp > 0 -> + let lc = Array.sub cl 0 napp in + let u = if napp=1 then lc.(0) else DOPN(AppL,lc) + in if noccurn 1 u then (pop u,[]) else s + | _ -> s) + | _ -> s) | (a::m) -> stacklam whrec [a] c m) - | DOPN(MutCase _,_) -> - let (ci,p,d,lf) = destCase x in - let (c,cargs) = whrec d [] in + | IsMutCase (ci,p,d,lf) -> + let (c,cargs) = whrec (d, []) in if reducible_mind_case c then whrec (reduce_mind_case - {mP=p; mconstr=c; mcargs=cargs; mci=ci; mlf=lf}) stack + {mP=p; mconstr=c; mcargs=cargs; mci=ci; mlf=lf}, stack) else - (mkMutCaseA ci p (applist(c,cargs)) lf,stack) - | DOPN(Fix _,_) -> - let (reduced,(fix,stack)) = reduce_fix whrec x stack in - if reduced then whrec fix stack else (fix,stack) - | x -> (x,stack) + (mkMutCaseA ci p (applist(c,cargs)) lf, stack) + | IsFix fix -> + (match reduce_fix whrec fix stack with + | Reduced s' -> whrec s' + | NotReducible -> s) + | _ -> s in - whrec + whrec (x, l) let whd_betadeltaiotaeta env sigma x = applist(whd_betadeltaiotaeta_stack env sigma x []) @@ -879,19 +913,21 @@ and eqappr cv_pb infos appr1 appr2 = | None -> fun _ -> raise NotConvertible) (* other constructors *) - | (FOP2(Lambda,c1,c2), FOP2(Lambda,c'1,c'2)) -> + | (FLam (_,c1,c2,_,_), FLam (_,c'1,c'2,_,_)) -> bool_and_convert (Array.length v1 = 0 && Array.length v2 = 0) (convert_and (ccnv (pb_equal cv_pb) infos el1 el2 c1 c'1) - (ccnv (pb_equal cv_pb) infos el1 el2 c2 c'2)) + (ccnv (pb_equal cv_pb) infos (el_lift el1) (el_lift el2) c2 c'2)) + + | (FLet _, _) | (_, FLet _) -> anomaly "Normally removed by fhnf" - | (FOP2(Prod,c1,c2), FOP2(Prod,c'1,c'2)) -> + | (FPrd (_,c1,c2,_,_), FPrd (_,c'1,c'2,_,_)) -> bool_and_convert (Array.length v1 = 0 && Array.length v2 = 0) (convert_and (ccnv (pb_equal cv_pb) infos el1 el2 c1 c'1) (* Luo's system *) - (ccnv cv_pb infos el1 el2 c2 c'2)) + (ccnv cv_pb infos (el_lift el1) (el_lift el2) c2 c'2)) (* Inductive types: MutInd MutConstruct MutCase Fix Cofix *) @@ -926,8 +962,8 @@ and eqappr cv_pb infos appr1 appr2 = let fconv cv_pb env sigma t1 t2 = - let t1 = strong (fun _ _ -> strip_outer_cast) env sigma t1 - and t2 = strong (fun _ _ -> strip_outer_cast) env sigma t2 in + let t1 = local_strong strip_outer_cast t1 + and t2 = local_strong strip_outer_cast t2 in if eq_constr t1 t2 then Constraint.empty else @@ -972,9 +1008,11 @@ let plain_instance s c = | DOP1(oper,c) -> DOP1(oper, irec c) | DOP2(oper,c1,c2) -> DOP2(oper, irec c1, irec c2) | DOPN(oper,cl) -> DOPN(oper, Array.map irec cl) - | DOPL(oper,cl) -> DOPL(oper, List.map irec cl) | DLAM(x,c) -> DLAM(x, irec c) | DLAMV(x,v) -> DLAMV(x, Array.map irec v) + | CLam (n,t,c) -> CLam (n, typed_app irec t, irec c) + | CPrd (n,t,c) -> CPrd (n, typed_app irec t, irec c) + | CLet (n,b,t,c) -> CLet (n, irec b, typed_app irec t, irec c) | u -> u in if s = [] then c else irec c @@ -992,7 +1030,7 @@ let instance s c = let hnf_prod_app env sigma t n = match whd_betadeltaiota env sigma t with - | DOP2(Prod,_,DLAM(_,b)) -> subst1 n b + | CPrd (_,_,b) -> subst1 n b | _ -> anomaly "hnf_prod_app: Need a product" let hnf_prod_appvect env sigma t nl = @@ -1003,7 +1041,7 @@ let hnf_prod_applist env sigma t nl = let hnf_lam_app env sigma t n = match whd_betadeltaiota env sigma t with - | DOP2(Lambda,_,DLAM(_,b)) -> subst1 n b + | CLam (_,_,b) -> subst1 n b | _ -> anomaly "hnf_lam_app: Need an abstraction" let hnf_lam_appvect env sigma t nl = @@ -1015,7 +1053,7 @@ let hnf_lam_applist env sigma t nl = let splay_prod env sigma = let rec decrec m c = match whd_betadeltaiota env sigma c with - | DOP2(Prod,a,DLAM(n,c_0)) -> decrec ((n,a)::m) c_0 + | CPrd (n,a,c0) -> decrec ((n,body_of_type a)::m) c0 | t -> m,t in decrec [] @@ -1030,8 +1068,8 @@ let sort_of_arity env c = snd (splay_arity env Evd.empty c) let decomp_n_prod env sigma n = let rec decrec m ln c = if m = 0 then (ln,c) else match whd_betadeltaiota env sigma c with - | DOP2(Prod,a,DLAM(n,c0)) -> - decrec (m-1) (Sign.add_rel_decl (n,outcast_type a) ln) c0 + | CPrd (n,a,c0) -> + decrec (m-1) (Sign.add_rel_decl (n,a) ln) c0 | _ -> error "decomp_n_prod: Not enough products" in decrec n Sign.empty_rel_context @@ -1053,7 +1091,7 @@ with bj=aj if j<>ik and bj=(Rel c) and Bic=Aic[xn..xic-1 <- an..aic-1] let compute_consteval env sigma c = let rec srec n labs c = match whd_betadeltaeta_stack env sigma c [] with - | (DOP2(Lambda,t,DLAM(_,g)),[]) -> srec (n+1) (t::labs) g + | CLam (_,t,g), [] -> srec (n+1) (t::labs) g | (DOPN(Fix((nv,i)),bodies),l) -> if List.length l > n then raise Elimconst @@ -1083,22 +1121,23 @@ let compute_consteval env sigma c = (* One step of approximation *) let rec apprec env sigma c stack = - let (t,stack) = whd_betaiota_stack c stack in - match t with - | DOPN(MutCase _,_) -> - let (ci,p,d,lf) = destCase t in + let (t, stack as s) = whd_betaiota_stack c stack in + match kind_of_term t with + | IsMutCase (ci,p,d,lf) -> let (cr,crargs) = whd_betadeltaiota_stack env sigma d [] in let rslt = mkMutCaseA ci p (applist(cr,crargs)) lf in if reducible_mind_case cr then apprec env sigma rslt stack else - (t,stack) - | DOPN(Fix _,_) -> - let (reduced,(fix,stack)) = - reduce_fix (whd_betadeltaiota_stack env sigma) t stack - in - if reduced then apprec env sigma fix stack else (fix,stack) - | _ -> (t,stack) + s + | IsFix fix -> + (match reduce_fix + (fun (c,l) -> whd_betadeltaiota_stack env sigma c l) + fix stack + with + | Reduced (c,stack) -> apprec env sigma c stack + | NotReducible -> s) + | _ -> s let hnf env sigma c = apprec env sigma c [] @@ -1108,36 +1147,31 @@ let hnf env sigma c = apprec env sigma c [] * Used in Programs. * Added by JCF, 29/1/98. *) -let whd_programs_stack env sigma = - let rec whrec x stack = - match x with - | DOPN(AppL,cl) -> - if occur_meta cl.(1) then - (x,stack) - else - whrec (array_hd cl) (array_app_tl cl stack) - | DOP2(Lambda,_,DLAM(_,c)) -> +let whd_programs_stack env sigma x l = + let rec whrec (x, stack as s) = + match kind_of_term x with + | IsAppL (f,[c]) -> if occur_meta c then s else whrec (f, c::stack) + | IsLambda (_,_,c) -> (match stack with - | [] -> (x,stack) + | [] -> s | (a::m) -> stacklam whrec [a] c m) - | DOPN(MutCase _,_) -> - let (ci,p,d,lf) = destCase x in + | IsMutCase (ci,p,d,lf) -> if occur_meta d then - (x,stack) + s else - let (c,cargs) = whrec d [] in + let (c,cargs) = whrec (d, []) in if reducible_mind_case c then whrec (reduce_mind_case - {mP=p; mconstr=c; mcargs=cargs; mci=ci; mlf=lf}) - stack + {mP=p; mconstr=c; mcargs=cargs; mci=ci; mlf=lf}, stack) else (mkMutCaseA ci p (applist(c,cargs)) lf, stack) - | DOPN(Fix _,_) -> - let (reduced,(fix,stack)) = reduce_fix whrec x stack in - if reduced then whrec fix stack else (fix,stack) - | x -> (x,stack) + | IsFix fix -> + (match reduce_fix whrec fix stack with + | Reduced s' -> whrec s' + | NotReducible -> s) + | _ -> s in - whrec + whrec (x, l) let whd_programs env sigma x = applist (whd_programs_stack env sigma x []) @@ -1145,37 +1179,34 @@ exception IsType let is_arity env sigma = let rec srec c = - match whd_betadeltaiota env sigma c with - | DOP0(Sort _) -> true - | DOP2(Prod,_,DLAM(_,c')) -> srec c' - | DOP2(Lambda,_,DLAM(_,c')) -> srec c' + match kind_of_term (whd_betadeltaiota env sigma c) with + | IsSort _ -> true + | IsProd (_,_,c') -> srec c' + | IsLambda (_,_,c') -> srec c' | _ -> false in srec let info_arity env sigma = let rec srec c = - match whd_betadeltaiota env sigma c with - | DOP0(Sort(Prop Null)) -> false - | DOP0(Sort(Prop Pos)) -> true - | DOP2(Prod,_,DLAM(_,c')) -> srec c' - | DOP2(Lambda,_,DLAM(_,c')) -> srec c' + match kind_of_term (whd_betadeltaiota env sigma c) with + | IsSort (Prop Null) -> false + | IsSort (Prop Pos) -> true + | IsProd (_,_,c') -> srec c' + | IsLambda (_,_,c') -> srec c' | _ -> raise IsType in srec -let is_logic_arity env sigma c = - try (not (info_arity env sigma c)) with IsType -> false - -let is_info_arity env sigma c = +let is_info_arity env sigma c = try (info_arity env sigma c) with IsType -> true - + let is_type_arity env sigma = let rec srec c = - match whd_betadeltaiota env sigma c with - | DOP0(Sort(Type _)) -> true - | DOP2(Prod,_,DLAM(_,c')) -> srec c' - | DOP2(Lambda,_,DLAM(_,c')) -> srec c' + match kind_of_term (whd_betadeltaiota env sigma c) with + | IsSort (Type _) -> true + | IsProd (_,_,c') -> srec c' + | IsLambda (_,_,c') -> srec c' | _ -> false in srec @@ -1186,20 +1217,6 @@ let is_info_type env sigma t = (s <> Prop Null && try info_arity env sigma t.utj_val with IsType -> true) -(* Pour l'extraction -let is_info_cast_type env sigma c = - match c with - | DOP2(Cast,c,t) -> - (try info_arity env sigma t - with IsType -> try info_arity env sigma c with IsType -> true) - | _ -> try info_arity env sigma c with IsType -> true - -let contents_of_cast_type env sigma c = - if is_info_cast_type env sigma c then Pos else Null -*) - -let is_info_sort = is_info_arity - (* calcul des arguments implicites *) (* la seconde liste est ordonne'e *) @@ -1211,31 +1228,36 @@ let ord_add x l = in aux l -let add_free_rels_until depth m acc = - let rec frec depth loc acc = function +let add_free_rels_until bound m acc = + let rec frec depth acc = function | Rel n -> - if (n <= depth) & (n > loc) then (ord_add (depth-n+1) acc) else acc - | DOPN(_,cl) -> Array.fold_left (frec depth loc) acc cl - | DOPL(_,cl) -> List.fold_left (frec depth loc) acc cl - | DOP2(_,c1,c2) -> frec depth loc (frec depth loc acc c1) c2 - | DOP1(_,c) -> frec depth loc acc c - | DLAM(_,c) -> frec (depth+1) (loc+1) acc c - | DLAMV(_,cl) -> Array.fold_left (frec (depth+1) (loc+1)) acc cl + if (n < bound+depth) & (n >= depth) then + Intset.add (bound+depth-n) acc + else + acc + | DOPN(_,cl) -> Array.fold_left (frec depth) acc cl + | DOP2(_,c1,c2) -> frec depth (frec depth acc c1) c2 + | DOP1(_,c) -> frec depth acc c + | DLAM(_,c) -> frec (depth+1) acc c + | DLAMV(_,cl) -> Array.fold_left (frec (depth+1)) acc cl + | CLam (_,t,c) -> frec (depth+1) (frec depth acc (body_of_type t)) c + | CPrd (_,t,c) -> frec (depth+1) (frec depth acc (body_of_type t)) c + | CLet (_,b,t,c) -> frec (depth+1) (frec depth (frec depth acc b) (body_of_type t)) c | VAR _ -> acc | DOP0 _ -> acc in - frec depth 0 acc m + frec 1 acc m (* calcule la liste des arguments implicites *) let poly_args env sigma t = - let rec aux n t = match (whd_betadeltaiota env sigma t) with - | DOP2(Prod,a,DLAM(_,b)) -> add_free_rels_until n a (aux (n+1) b) - | DOP2(Cast,t',_) -> aux n t' - | _ -> [] + let rec aux n t = match kind_of_term (whd_betadeltaiota env sigma t) with + | IsProd (_,a,b) -> add_free_rels_until n a (aux (n+1) b) + | IsCast (t',_) -> aux n t' + | _ -> Intset.empty in - match (strip_outer_cast (whd_betadeltaiota env sigma t)) with - | DOP2(Prod,a,DLAM(_,b)) -> aux 1 b + match kind_of_term (strip_outer_cast (whd_betadeltaiota env sigma t)) with + | IsProd (_,a,b) -> Intset.elements (aux 1 b) | _ -> [] diff --git a/kernel/reduction.mli b/kernel/reduction.mli index bab5f446f..01d42fc07 100644 --- a/kernel/reduction.mli +++ b/kernel/reduction.mli @@ -3,7 +3,7 @@ (*i*) open Names -open Generic +(*i open Generic i*) open Term open Univ open Evd @@ -35,10 +35,10 @@ val under_casts : 'a contextual_reduction_function -> 'a contextual_reduction_function val strong : 'a reduction_function -> 'a reduction_function val local_strong : local_reduction_function -> local_reduction_function -val strong_prodspine : 'a reduction_function -> 'a reduction_function +val strong_prodspine : local_reduction_function -> local_reduction_function val stack_reduction_of_reduction : 'a reduction_function -> 'a stack_reduction_function -val stacklam : (constr -> constr list -> 'a) -> constr list -> constr +val stacklam : (constr * constr list -> 'a) -> constr list -> constr -> constr list -> 'a (*s Generic Optimized Reduction Functions using Closures *) @@ -110,15 +110,14 @@ val reducible_mind_case : constr -> bool val reduce_mind_case : constr miota_args -> constr val is_arity : env -> 'a evar_map -> constr -> bool -val is_info_arity : env -> 'a evar_map -> constr -> bool -val is_info_sort : env -> 'a evar_map -> constr -> bool -val is_logic_arity : env -> 'a evar_map -> constr -> bool -val is_type_arity : env -> 'a evar_map -> constr -> bool val is_info_type : env -> 'a evar_map -> unsafe_type_judgment -> bool +val is_info_arity : env -> 'a evar_map -> constr -> bool (*i Pour l'extraction +val is_type_arity : env -> 'a evar_map -> constr -> bool val is_info_cast_type : env -> 'a evar_map -> constr -> bool val contents_of_cast_type : env -> 'a evar_map -> constr -> contents i*) + val poly_args : env -> 'a evar_map -> constr -> int list val whd_programs : 'a reduction_function @@ -130,9 +129,12 @@ val fold_commands : constr list -> 'a reduction_function val pattern_occs : (int list * constr * constr) list -> 'a reduction_function val compute : 'a reduction_function +(* [reduce_fix] contracts a fix redex if it is actually reducible *) +type fix_reduction_result = NotReducible | Reduced of (constr * constr list) + val fix_recarg : fixpoint -> 'a list -> (int * 'a) option -val reduce_fix : (constr -> 'a list -> constr * constr list) -> constr -> - constr list -> bool * (constr * constr list) +val reduce_fix : (constr * constr list -> constr * constr list) -> fixpoint -> + constr list -> fix_reduction_result (*s Conversion Functions (uses closures, lazy strategy) *) diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index ca5d4a2ec..6b97c63ac 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -5,7 +5,7 @@ open Pp open Util open Names open Univ -open Generic +(*i open Generic i*) open Term open Reduction open Sign @@ -122,6 +122,16 @@ let rec execute mf env cstr = let (j,cst3) = gen_rel env1 Evd.empty name varj j' in let cst = Constraint.union cst1 (Constraint.union cst2 cst3) in (j, cst) + + | IsLetIn (name,c1,c2,c3) -> + let (j1,cst1) = execute mf env c1 in + let (j2,cst2) = execute mf env c2 in + let { uj_val = b; uj_type = t } = cast_rel env Evd.empty j1 j2 in + let (j3,cst3) = execute mf (push_rel_def (name,b,t) env) c3 in + let cst = Constraint.union cst1 (Constraint.union cst2 cst3) in + ({ uj_val = mkLetIn (name, j1.uj_val, j2.uj_val, j3.uj_val) ; + uj_type = typed_app (subst1 j1.uj_val) j3.uj_type }, + cst) | IsCast (c,t) -> let (cj,cst1) = execute mf env c in diff --git a/kernel/sign.ml b/kernel/sign.ml index edee43885..eac5c8cc9 100644 --- a/kernel/sign.ml +++ b/kernel/sign.ml @@ -3,7 +3,7 @@ open Names open Util -open Generic +(*i open Generic i*) open Term (* Signatures *) @@ -98,7 +98,7 @@ let map_rel_context = map let instantiate_sign sign args = let rec instrec = function | ((id,None,_) :: sign, c::args) -> (id,c) :: (instrec (sign,args)) - | ((id,Some c,_) :: _, args) -> (id,c) :: (instrec (sign,args)) + | ((id,Some c,_) :: sign, args) -> (id,c) :: (instrec (sign,args)) | ([],[]) -> [] | ([],_) | (_,[]) -> anomaly "Signature and its instance do not match" @@ -146,26 +146,24 @@ let empty_names_context = [] (* Transforms a product term (x1:T1)..(xn:Tn)T into the pair ([(xn,Tn);...;(x1,T1)],T), where T is not a product *) let decompose_prod_assum = - let rec prodec_rec l = function - | DOP2(Prod,t,DLAM(x,c)) -> - prodec_rec (add_rel_decl (x,outcast_type t) l) c -(* | Letin,t,DLAM(x,c)) -> - prodec_rec (add_rel_def (x,c,outcast_type t) l) c*) - | DOP2(Cast,c,_) -> prodec_rec l c - | c -> l,c + let rec prodec_rec l c = + match kind_of_term c with + | IsProd (x,t,c) -> prodec_rec (add_rel_decl (x,outcast_type t) l) c + | IsLetIn (x,b,t,c) -> prodec_rec (add_rel_def (x,b,outcast_type t) l) c + | IsCast (c,_) -> prodec_rec l c + | _ -> l,c in prodec_rec empty_rel_context (* Transforms a lambda term [x1:T1]..[xn:Tn]T into the pair ([(xn,Tn);...;(x1,T1)],T), where T is not a lambda *) let decompose_lam_assum = - let rec lamdec_rec l = function - | DOP2(Lambda,t,DLAM(x,c)) -> - lamdec_rec (add_rel_decl (x,outcast_type t) l) c -(* | Letin,t,DLAM(x,c)) -> - lamdec_rec (add_rel_def (x,c,outcast_type t) l) c*) - | DOP2(Cast,c,_) -> lamdec_rec l c - | c -> l,c + let rec lamdec_rec l c = + match kind_of_term c with + | IsLambda (x,t,c) -> lamdec_rec (add_rel_decl (x,outcast_type t) l) c + | IsLetIn (x,b,t,c) -> lamdec_rec (add_rel_def (x,b,outcast_type t) l) c + | IsCast (c,_) -> lamdec_rec l c + | _ -> l,c in lamdec_rec empty_rel_context @@ -175,10 +173,12 @@ let decompose_prod_n_assum n = if n < 0 then error "decompose_prod_n: integer parameter must be positive"; let rec prodec_rec l n c = if n=0 then l,c - else match c with - | DOP2(Prod,t,DLAM(x,c)) -> prodec_rec (add_rel_decl (x,outcast_type t) l) (n-1) c - | DOP2(Cast,c,_) -> prodec_rec l n c - | c -> error "decompose_prod_n: not enough products" + else match kind_of_term c with + | IsProd (x,t,c) -> prodec_rec (add_rel_decl(x,outcast_type t) l) (n-1) c + | IsLetIn (x,b,t,c) -> + prodec_rec (add_rel_def (x,b,outcast_type t) l) (n-1) c + | IsCast (c,_) -> prodec_rec l n c + | c -> error "decompose_prod_n: not enough products" in prodec_rec empty_rel_context n @@ -188,10 +188,11 @@ let decompose_lam_n_assum n = if n < 0 then error "decompose_lam_n: integer parameter must be positive"; let rec lamdec_rec l n c = if n=0 then l,c - else match c with - | DOP2(Lambda,t,DLAM(x,c)) -> lamdec_rec (add_rel_decl (x,outcast_type t) l) (n-1) c - | DOP2(Cast,c,_) -> lamdec_rec l n c - | c -> error "decompose_lam_n: not enough abstractions" + else match kind_of_term c with + | IsLambda (x,t,c) -> lamdec_rec (add_rel_decl (x,outcast_type t) l) (n-1) c + | IsLetIn (x,b,t,c) -> + lamdec_rec (add_rel_def (x,b,outcast_type t) l) (n-1) c + | IsCast (c,_) -> lamdec_rec l n c + | c -> error "decompose_lam_n: not enough abstractions" in lamdec_rec empty_rel_context n - diff --git a/kernel/sign.mli b/kernel/sign.mli index 17d9267d9..889c79b4e 100644 --- a/kernel/sign.mli +++ b/kernel/sign.mli @@ -3,7 +3,7 @@ (*i*) open Names -open Generic +(*i open Generic i*) open Term (*i*) diff --git a/kernel/sosub.ml b/kernel/sosub.ml index 904d089d3..7212216ee 100644 --- a/kernel/sosub.ml +++ b/kernel/sosub.ml @@ -3,9 +3,9 @@ open Util open Names -open Generic +(*i open Generic i*) open Term - +(* (* Given a term with variables in it, and second-order substitution, this function will apply the substitution. The special operator "XTRA[$SOAPP]" is used to represent the second-order @@ -100,15 +100,6 @@ let propagate_names = cllist (smap,[]) in (smap',DOPN(op,Array.of_list cl'list)) - | DOPL(op,cl) -> - let cllist = cl in - let (smap',cl'list) = - List.fold_right - (fun c (smap,acc) -> - let (smap',c') = proprec smap c in (smap',c'::acc)) - cllist (smap,[]) - in - (smap',DOPL(op,cl'list)) | DLAM(na,c) -> let (lna', c') = proprec (na::smap) c in (List.tl lna', DLAM(List.hd lna', c')) @@ -163,14 +154,6 @@ let rec soeval t= socontract args lam else DOPN(op,cl') - | DOPL(op,cl) -> - let cl' = List.map soeval cl in - if is_soapp_operator t then - let lam = List.hd cl' - and args = List.tl cl' in - socontract args lam - else - DOPL(op,cl') let rec try_soeval t = match t with @@ -197,15 +180,6 @@ let rec try_soeval t = with (Failure _ | UserError _) -> DOPN(op,cl')) else DOPN(op,cl') - | DOPL(op,cl) -> - let cl' = List.map try_soeval cl in - if is_soapp_operator t then - let lam = List.hd cl' - and args = List.tl cl' in - (try socontract args lam - with (Failure _ | UserError _) -> DOPL(op,cl')) - else - DOPL(op,cl') let soexecute t = let (_,t) = propagate_names [] t in @@ -217,3 +191,7 @@ let try_soexecute t = with (Failure _ | UserError _) -> ([],t) in try_soeval t +*) + +let soexecute a = failwith "No longer implemented" + diff --git a/kernel/sosub.mli b/kernel/sosub.mli index 531b7ee7e..123362527 100644 --- a/kernel/sosub.mli +++ b/kernel/sosub.mli @@ -8,5 +8,7 @@ open Term (* Second-order substitutions. *) val soexecute : constr -> constr +(* val try_soexecute : constr -> constr +*) diff --git a/kernel/term.ml b/kernel/term.ml index f4c074471..40feeaab1 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -6,7 +6,6 @@ open Util open Pp open Names -open Generic open Univ (* Coq abstract syntax with deBruijn variables; 'a is the type of sorts *) @@ -64,14 +63,34 @@ let print_sort = function | Prop Null -> [< 'sTR "Prop" >] | Type _ -> [< 'sTR "Type" >] -type constr = sorts oper term +(********************************************************************) +(* Generic syntax of terms with de Bruijn indexes *) +(********************************************************************) + +type constr = + | DOP0 of sorts oper (* atomic terms *) + | DOP1 of sorts oper * constr (* operator of arity 1 *) + | DOP2 of sorts oper * constr * constr (* operator of arity 2 *) + | DOPN of sorts oper * constr array (* operator of variadic arity *) + | DLAM of name * constr (* deBruijn binder on one term *) + | DLAMV of name * constr array (* deBruijn binder on many terms *) + | CLam of name * constr * constr + | CPrd of name * constr * constr + | CLet of name * constr * constr * constr + | VAR of identifier (* named variable *) + | Rel of int (* variable as deBruijn index *) + +and + (* + typed_type = sorts judge + *) + typed_type = constr type flat_arity = (name * constr) list * sorts type 'a judge = { body : constr; typ : 'a } (* -type typed_type = sorts judge type typed_term = typed_type judge let make_typed t s = { body = t; typ = s } @@ -91,7 +110,6 @@ let outcast_type = function let typed_combine f g t u = { f t.body u.body ; g t.typ u.typ} *) -type typed_type = constr type typed_term = typed_type judge let make_typed t s = t @@ -115,15 +133,281 @@ type rel_declaration = name * constr option * typed_type (****************************************************************************) (*********************) +(* Occurring *) +(*********************) + +exception FreeVar +exception Occur + +(* (closedn n M) raises FreeVar if a variable of height greater than n + occurs in M, returns () otherwise *) + +let closedn = + let rec closed_rec n = function + | Rel(m) -> if m>n then raise FreeVar + | VAR _ -> () + | DOPN(_,cl) -> Array.iter (closed_rec n) cl + | DOP2(_,c1,c2) -> closed_rec n c1; closed_rec n c2 + | DOP1(_,c) -> closed_rec n c + | DLAM(_,c) -> closed_rec (n+1) c + | DLAMV(_,v) -> Array.iter (closed_rec (n+1)) v + | CLam (_,t,c) -> closed_rec n t; closed_rec (n+1) c + | CPrd (_,t,c) -> closed_rec n t; closed_rec (n+1) c + | CLet (_,b,t,c) -> closed_rec n b; closed_rec n t; closed_rec (n+1) c + | _ -> () + in + closed_rec + +(* [closed0 M] is true iff [M] is a (deBruijn) closed term *) + +let closed0 term = + try closedn 0 term; true with FreeVar -> false + +(* returns the list of free debruijn indices in a term *) + +let free_rels m = + let rec frec depth acc = function + | Rel n -> if n >= depth then Intset.add (n-depth+1) acc else acc + | DOPN(_,cl) -> Array.fold_left (frec depth) acc cl + | DOP2(_,c1,c2) -> frec depth (frec depth acc c1) c2 + | DOP1(_,c) -> frec depth acc c + | DLAM(_,c) -> frec (depth+1) acc c + | DLAMV(_,cl) -> Array.fold_left (frec (depth+1)) acc cl + | CLam (_,t,c) -> frec (depth+1) (frec depth acc t) c + | CPrd (_,t,c) -> frec (depth+1) (frec depth acc t) c + | CLet (_,b,t,c) -> frec (depth+1) (frec depth (frec depth acc b) t) c + | VAR _ -> acc + | DOP0 _ -> acc + in + frec 1 Intset.empty m + +(* (noccurn n M) returns true iff (Rel n) does NOT occur in term M *) + +let noccurn n term = + let rec occur_rec n = function + | Rel(m) -> if m = n then raise Occur + | VAR _ -> () + | DOPN(_,cl) -> Array.iter (occur_rec n) cl + | DOP1(_,c) -> occur_rec n c + | DOP2(_,c1,c2) -> occur_rec n c1; occur_rec n c2 + | DLAM(_,c) -> occur_rec (n+1) c + | DLAMV(_,v) -> Array.iter (occur_rec (n+1)) v + | CLam (_,t,c) -> occur_rec n t; occur_rec (n+1) c + | CPrd (_,t,c) -> occur_rec n t; occur_rec (n+1) c + | CLet (_,b,t,c) -> occur_rec n b; occur_rec n t; occur_rec (n+1) c + | _ -> () + in + try occur_rec n term; true with Occur -> false + +(* (noccur_between n m M) returns true iff (Rel p) does NOT occur in term M + for n <= p < n+m *) + +let noccur_between n m term = + let rec occur_rec n = function + | Rel(p) -> if n<=p && p<n+m then raise Occur + | VAR _ -> () + | DOPN(_,cl) -> Array.iter (occur_rec n) cl + | DOP1(_,c) -> occur_rec n c + | DOP2(_,c1,c2) -> occur_rec n c1; occur_rec n c2 + | DLAM(_,c) -> occur_rec (n+1) c + | DLAMV(_,v) -> Array.iter (occur_rec (n+1)) v + | CLam (_,t,c) -> occur_rec n t; occur_rec (n+1) c + | CPrd (_,t,c) -> occur_rec n t; occur_rec (n+1) c + | CLet (_,b,t,c) -> occur_rec n b; occur_rec n t; occur_rec (n+1) c + | _ -> () + in + try occur_rec n term; true with Occur -> false + +(* Checking function for terms containing existential variables. + The function [noccur_with_meta] considers the fact that + each existential variable (as well as each isevar) + in the term appears applied to its local context, + which may contain the CoFix variables. These occurrences of CoFix variables + are not considered *) + +let noccur_with_meta n m term = + let rec occur_rec n = function + | Rel p -> if n<=p & p<n+m then raise Occur + | VAR _ -> () + | DOPN(AppL,cl) -> + (match cl.(0) with + | DOP2 (Cast,DOP0 (Meta _),_) -> () + | DOP0 (Meta _) -> () + | _ -> Array.iter (occur_rec n) cl) + | DOPN(Evar _, _) -> () + | DOPN(op,cl) -> Array.iter (occur_rec n) cl + | DOP0(_) -> () + | DOP1(_,c) -> occur_rec n c + | DOP2(_,c1,c2) -> occur_rec n c1; occur_rec n c2 + | DLAM(_,c) -> occur_rec (n+1) c + | DLAMV(_,v) -> Array.iter (occur_rec (n+1)) v + | CLam (_,t,c) -> occur_rec n t; occur_rec (n+1) c + | CPrd (_,t,c) -> occur_rec n t; occur_rec (n+1) c + | CLet (_,b,t,c) -> occur_rec n b; occur_rec n t; occur_rec (n+1) c + in + try (occur_rec n term; true) with Occur -> false + + +(*********************) +(* Lifting *) +(*********************) + +(* Explicit lifts and basic operations *) +type lift_spec = + | ELID + | ELSHFT of lift_spec * int (* ELSHFT(l,n) == lift of n, then apply lift l *) + | ELLFT of int * lift_spec (* ELLFT(n,l) == apply l to de Bruijn > n *) + (* i.e under n binders *) + +(* compose a relocation of magnitude n *) +let rec el_shft n = function + | ELSHFT(el,k) -> el_shft (k+n) el + | el -> if n = 0 then el else ELSHFT(el,n) + + +(* cross n binders *) +let rec el_liftn n = function + | ELID -> ELID + | ELLFT(k,el) -> el_liftn (n+k) el + | el -> if n=0 then el else ELLFT(n, el) + +let el_lift el = el_liftn 1 el + +(* relocation of de Bruijn n in an explicit lift *) +let rec reloc_rel n = function + | ELID -> n + | ELLFT(k,el) -> + if n <= k then n else (reloc_rel (n-k) el) + k + | ELSHFT(el,k) -> (reloc_rel (n+k) el) + + +(* The generic lifting function *) +let rec exliftn el = function + | Rel i -> Rel(reloc_rel i el) + | DOPN(oper,cl) -> DOPN(oper, Array.map (exliftn el) cl) + | DOP1(oper,c) -> DOP1(oper, exliftn el c) + | DOP2(oper,c1,c2) -> DOP2(oper, exliftn el c1, exliftn el c2) + | DLAM(na,c) -> DLAM(na, exliftn (el_lift el) c) + | DLAMV(na,v) -> DLAMV(na, Array.map (exliftn (el_lift el)) v) + | CLam (n,t,c) -> CLam (n, exliftn el t, exliftn (el_lift el) c) + | CPrd (n,t,c) -> CPrd (n, exliftn el t, exliftn (el_lift el) c) + | CLet (n,b,t,c) -> CLet (n,exliftn el b,exliftn el t,exliftn (el_lift el) c) + | x -> x + +(* Lifting the binding depth across k bindings *) + +let liftn k n = + match el_liftn (pred n) (el_shft k ELID) with + | ELID -> (fun c -> c) + | el -> exliftn el + +let lift k = liftn k 1 + +let pop t = lift (-1) t + +let lift_context n l = + let k = List.length l in + list_map_i (fun i (name,c) -> (name,liftn n (k-i) c)) 0 l + +(*********************) +(* Substituting *) +(*********************) + +(* (subst1 M c) substitutes M for Rel(1) in c + we generalise it to (substl [M1,...,Mn] c) which substitutes in parallel + M1,...,Mn for respectively Rel(1),...,Rel(n) in c *) + +(* 1st : general case *) + +type info = Closed | Open | Unknown +type 'a substituend = { mutable sinfo: info; sit: 'a } + +let rec lift_substituend depth s = + match s.sinfo with + | Closed -> s.sit + | Open -> lift depth s.sit + | Unknown -> + s.sinfo <- if closed0 s.sit then Closed else Open; + lift_substituend depth s + +let make_substituend c = { sinfo=Unknown; sit=c } + +let substn_many lamv n = + let lv = Array.length lamv in + let rec substrec depth = function + | Rel k as x -> + if k<=depth then + x + else if k-depth <= lv then + lift_substituend depth lamv.(k-depth-1) + else + Rel (k-lv) + | VAR id -> VAR id + | DOPN(oper,cl) -> DOPN(oper,Array.map (substrec depth) cl) + | DOP1(oper,c) -> DOP1(oper,substrec depth c) + | DOP2(oper,c1,c2) -> DOP2(oper,substrec depth c1,substrec depth c2) + | DLAM(na,c) -> DLAM(na,substrec (depth+1) c) + | DLAMV(na,v) -> DLAMV(na,Array.map (substrec (depth+1)) v) + | CLam (n,t,c) -> CLam (n, substrec depth t, substrec (depth+1) c) + | CPrd (n,t,c) -> CPrd (n, substrec depth t, substrec (depth+1) c) + | CLet (n,b,t,c) -> CLet (n, substrec depth b, substrec depth t, + substrec (depth+1) c) + | x -> x + in + substrec n + +let substnl laml k = + substn_many (Array.map make_substituend (Array.of_list laml)) k +let substl laml = + substn_many (Array.map make_substituend (Array.of_list laml)) 0 +let subst1 lam = substl [lam] + +(* (thin_val sigma) removes identity substitutions from sigma *) + +let rec thin_val = function + | [] -> [] + | (((id,{sit=VAR id'}) as s)::tl) -> + if id = id' then thin_val tl else s::(thin_val tl) + | h::tl -> h::(thin_val tl) + +(* (replace_vars sigma M) applies substitution sigma to term M *) +let replace_vars var_alist = + let var_alist = + List.map (fun (str,c) -> (str,make_substituend c)) var_alist in + let var_alist = thin_val var_alist in + let rec substrec n = function + | (VAR(x) as c) -> + (try lift_substituend n (List.assoc x var_alist) + with Not_found -> c) + + | DOPN(oper,cl) -> DOPN(oper,Array.map (substrec n) cl) + | DOP1(oper,c) -> DOP1(oper,substrec n c) + | DOP2(oper,c1,c2) -> DOP2(oper,substrec n c1,substrec n c2) + | DLAM(na,c) -> DLAM(na,substrec (n+1) c) + | DLAMV(na,v) -> DLAMV(na,Array.map (substrec (n+1)) v) + | CLam (na,t,c) -> CLam (na, substrec n t, substrec (n+1) c) + | CPrd (na,t,c) -> CPrd (na, substrec n t, substrec (n+1) c) + | CLet (na,b,t,c) -> CLet (na,substrec n b,substrec n t,substrec (n+1) c) + | x -> x + in + if var_alist = [] then (function x -> x) else substrec 0 + +(* (subst_var str t) substitute (VAR str) by (Rel 1) in t *) +let subst_var str = replace_vars [(str, Rel 1)] + +(* (subst_vars [id1;...;idn] t) substitute (VAR idj) by (Rel j) in t *) +let subst_vars vars = + let _,subst = + List.fold_left (fun (n,l) var -> ((n+1),(var,Rel n)::l)) (1,[]) vars + in replace_vars (List.rev subst) + +(*********************) (* Term constructors *) (*********************) (* Constructs a DeBrujin index with number n *) let mkRel n = (Rel n) -(* Constructs an existential variable named "?" *) -let mkExistential = (DOP0 (XTRA "ISEVAR")) - (* Constructs an existential variable named "?n" *) let mkMeta n = DOP0 (Meta n) @@ -155,30 +439,30 @@ let mkImplicit = DOP0 (Sort implicit_sort) (* Constructs the term t1::t2, i.e. the term t1 casted with the type t2 *) (* (that means t2 is declared as the type of t1) *) -let mkCast t1 t2 = +let mkCast (t1,t2) = match t1 with | DOP2(Cast,t,_) -> DOP2(Cast,t,t2) | _ -> (DOP2 (Cast,t1,t2)) (* Constructs the product (x:t1)t2 *) -let mkProd x t1 t2 = (DOP2 (Prod,t1,(DLAM (x,t2)))) -let mkNamedProd id typ c = mkProd (Name id) typ (subst_var id c) -let mkProd_string s t c = mkProd (Name (id_of_string s)) t c +let mkProd (x,t1,t2) = CPrd (x,t1,t2) +let mkNamedProd id typ c = mkProd (Name id, typ, subst_var id c) +let mkProd_string s t c = mkProd (Name (id_of_string s), t, c) (* Constructs the abstraction [x:t1]t2 *) -let mkLambda x t1 t2 = (DOP2 (Lambda,t1,(DLAM (x,t2)))) -let mkNamedLambda id typ c = mkLambda (Name id) typ (subst_var id c) -let mkLambda_string s t c = mkLambda (Name (id_of_string s)) t c +let mkLambda (x,t1,t2) = CLam (x,t1,t2) +let mkNamedLambda id typ c = mkLambda (Name id, typ, subst_var id c) +let mkLambda_string s t c = mkLambda (Name (id_of_string s), t, c) (* Constructs [x=c_1:t]c_2 *) -let mkLetIn x c1 t c2 = failwith "TODO" -let mkNamedLetIn id c1 t c2 = mkLetIn (Name id) c1 t (subst_var id c2) +let mkLetIn (x,c1,t,c2) = CLet (x,c1,t,c2) +let mkNamedLetIn id c1 t c2 = mkLetIn (Name id, c1, t, subst_var id c2) (* Constructs either [(x:t)c] or [[x=b:t]c] *) let mkProd_or_LetIn (na,body,t) c = match body with - | None -> mkProd na t c - | Some b -> mkLetIn na b t c + | None -> mkProd (na, t, c) + | Some b -> mkLetIn (na, b, t, c) let mkNamedProd_or_LetIn (id,body,t) c = match body with @@ -188,8 +472,8 @@ let mkNamedProd_or_LetIn (id,body,t) c = (* Constructs either [[x:t]c] or [[x=b:t]c] *) let mkLambda_or_LetIn (na,body,t) c = match body with - | None -> mkLambda na t c - | Some b -> mkLetIn na b t c + | None -> mkLambda (na, t, c) + | Some b -> mkLetIn (na, b, t, c) let mkNamedLambda_or_LetIn (id,body,t) c = match body with @@ -199,7 +483,7 @@ let mkNamedLambda_or_LetIn (id,body,t) c = (* Constructs either [(x:t)c] or [c] where [x] is replaced by [b] *) let mkProd_wo_LetIn (na,body,t) c = match body with - | None -> mkProd na (body_of_type t) c + | None -> mkProd (na, body_of_type t, c) | Some b -> subst1 b c let mkNamedProd_wo_LetIn (id,body,t) c = @@ -208,7 +492,7 @@ let mkNamedProd_wo_LetIn (id,body,t) c = | Some b -> subst1 b (subst_var id c) (* non-dependent product t1 -> t2 *) -let mkArrow t1 t2 = mkProd Anonymous t1 t2 +let mkArrow t1 t2 = mkProd (Anonymous, t1, t2) (* If lt = [t1; ...; tn], constructs the application (t1 ... tn) *) let mkAppL a = DOPN (AppL, a) @@ -234,7 +518,7 @@ let mkMutInd (ind_sp,l) = DOPN (MutInd ind_sp, l) let mkMutConstruct (cstr_sp,l) = DOPN (MutConstruct cstr_sp,l) (* Constructs the term <p>Case c of c1 | c2 .. | cn end *) -let mkMutCase ci p c ac = +let mkMutCase (ci, p, c, ac) = DOPN (MutCase ci, Array.append [|p;c|] (Array.of_list ac)) let mkMutCaseA ci p c ac = DOPN (MutCase ci, Array.append [|p;c|] ac) @@ -316,7 +600,6 @@ let destMeta = function | (DOP0 (Meta n)) -> n | _ -> invalid_arg "destMeta" -let isMETA = function DOP0(Meta _) -> true | _ -> false (* Destructs a variable *) let destVar = function @@ -416,9 +699,12 @@ let rec strip_all_casts t = | DOP1(oper,c) -> DOP1(oper,strip_all_casts c) | DOP2(oper,c1,c2) -> DOP2(oper,strip_all_casts c1,strip_all_casts c2) | DOPN(oper,cl) -> DOPN(oper,Array.map strip_all_casts cl) - | DOPL(oper,cl) -> DOPL(oper,List.map strip_all_casts cl) | DLAM(na,c) -> DLAM(na,strip_all_casts c) | DLAMV(na,c) -> DLAMV(na,Array.map (under_outer_cast strip_all_casts) c) + | CLam (n,t,c) -> CLam (n, strip_all_casts t, strip_all_casts c) + | CPrd (n,t,c) -> CPrd (n, strip_all_casts t, strip_all_casts c) + | CLet (n,b,t,c) -> CLet (n, strip_all_casts b, strip_all_casts t, + strip_all_casts c) | VAR _ as t -> t | Rel _ as t -> t @@ -430,13 +716,13 @@ let isVar = function VAR _ -> true | _ -> false (* Destructs the product (x:t1)t2 *) let destProd = function - | DOP2 (Prod, t1, (DLAM (x,t2))) -> (x,t1,t2) + | CPrd (x,t1,t2) -> (x,t1,t2) | _ -> invalid_arg "destProd" let rec hd_of_prod prod = match strip_outer_cast prod with - | DOP2(Prod,c,DLAM(n,t')) -> hd_of_prod t' - | t -> t + | CPrd (n,c,t') -> hd_of_prod t' + | t -> t let hd_is_constructor t = let is_constructor = function @@ -449,9 +735,14 @@ let hd_is_constructor t = (* Destructs the abstraction [x:t1]t2 *) let destLambda = function - | DOP2 (Lambda, t1, (DLAM (x,t2))) -> (x,t1,t2) + | CLam (x,t1,t2) -> (x,t1,t2) | _ -> invalid_arg "destLambda" +(* Destructs the let [x:=b:t1]t2 *) +let destLetIn = function + | CLet (x,b,t1,t2) -> (x,b,t1,t2) + | _ -> invalid_arg "destProd" + (* Destructs an application *) let destAppL = function | (DOPN (AppL,a)) -> a @@ -461,8 +752,6 @@ let destApplication = function | (DOPN (AppL,a)) when Array.length a <> 0 -> (a.(0), array_tl a) | _ -> invalid_arg "destApplication" -let isAppL = function DOPN(AppL,_) -> true | _ -> false - let args_app = function | DOPN(AppL,cl) -> if Array.length cl >1 then array_tl cl else [||] | c -> [||] @@ -573,9 +862,9 @@ let destCoFix = function (**********************************************************************) -type binder_kind = BProd | BLambda +type binder_kind = BProd | BLambda | BLetIn -type fix_kind = RFix of (int array * int) | RCofix of int +type fix_kind = RFix of (int array * int) | RCoFix of int type 'ctxt reference = | RConst of section_path * 'ctxt @@ -596,6 +885,12 @@ type cofixpoint = int * (constr array * name list * constr array) (* Term analysis *) (******************) +type hnftype = + | HnfSort of sorts + | HnfProd of name * constr * constr + | HnfAtom of constr + | HnfMutInd of inductive * constr array + type kindOfTerm = | IsRel of int | IsMeta of int @@ -605,6 +900,7 @@ type kindOfTerm = | IsCast of constr * constr | IsProd of name * constr * constr | IsLambda of name * constr * constr + | IsLetIn of name * constr * constr * constr | IsAppL of constr * constr list | IsAbst of section_path * constr array | IsEvar of existential @@ -629,8 +925,9 @@ let kind_of_term c = | DOP0 (Sort s) -> IsSort s | DOP0 (XTRA s) -> IsXtra s | DOP2 (Cast, t1, t2) -> IsCast (t1,t2) - | DOP2 (Prod, t1, (DLAM (x,t2))) -> IsProd (x,t1,t2) - | DOP2 (Lambda, t1, (DLAM (x,t2))) -> IsLambda (x,t1,t2) + | CPrd (x,t1,t2) -> IsProd (x,t1,t2) + | CLam (x,t1,t2) -> IsLambda (x,t1,t2) + | CLet (x,b,t1,t2) -> IsLetIn (x,b,t1,t2) | DOPN (AppL,a) when Array.length a <> 0 -> IsAppL (a.(0), List.tl (Array.to_list a)) | DOPN (Const sp, a) -> IsConst (sp,a) @@ -648,26 +945,31 @@ let kind_of_term c = IsCoFix (i,typedbodies) | _ -> errorlabstrm "Term.kind_of_term" [< 'sTR "ill-formed constr" >] +let isMeta = function DOP0(Meta _) -> true | _ -> false +let isConst = function DOPN(Const _,_) -> true | _ -> false +let isMutConstruct = function DOPN(MutCase _,_) -> true | _ -> false +let isAppL = function DOPN(AppL,_) -> true | _ -> false + (***************************) (* Other term constructors *) (***************************) -let abs_implicit c = mkLambda Anonymous mkImplicit c -let lambda_implicit a = mkLambda (Name(id_of_string"y")) mkImplicit a +let abs_implicit c = mkLambda (Anonymous, mkImplicit, c) +let lambda_implicit a = mkLambda (Name(id_of_string"y"), mkImplicit, a) let lambda_implicit_lift n a = iterate lambda_implicit n (lift n a) (* prod_it b [xn:Tn;..;x1:T1] = (x1:T1)..(xn:Tn)b *) -let prod_it = List.fold_left (fun c (n,t) -> mkProd n t c) +let prod_it = List.fold_left (fun c (n,t) -> mkProd (n, t, c)) (* lam_it b [xn:Tn;..;x1:T1] = [x1:T1]..[xn:Tn]b *) -let lam_it = List.fold_left (fun c (n,t) -> mkLambda n t c) +let lam_it = List.fold_left (fun c (n,t) -> mkLambda (n, t, c)) (* prodn n [xn:Tn;..;x1:T1;Gamma] b = (x1:T1)..(xn:Tn)b *) let prodn n env b = let rec prodrec = function | (0, env, b) -> b - | (n, ((v,t)::l), b) -> prodrec (n-1, l, DOP2(Prod,t,DLAM(v,b))) + | (n, ((v,t)::l), b) -> prodrec (n-1, l, CPrd (v,t,b)) | _ -> assert false in prodrec (n,env,b) @@ -676,7 +978,7 @@ let prodn n env b = let lamn n env b = let rec lamrec = function | (0, env, b) -> b - | (n, ((v,t)::l), b) -> lamrec (n-1, l, DOP2(Lambda,t,DLAM(v,b))) + | (n, ((v,t)::l), b) -> lamrec (n-1, l, CLam (v,t,b)) | _ -> assert false in lamrec (n,env,b) @@ -712,8 +1014,7 @@ let rec to_lambda n prod = prod else match prod with - | DOP2(Prod,ty,DLAM(na,bd)) -> - DOP2(Lambda,ty,DLAM(na, to_lambda (n-1) bd)) + | CPrd(na,ty,bd) -> CLam(na,ty,to_lambda (n-1) bd) | DOP2(Cast,c,_) -> to_lambda n c | _ -> errorlabstrm "to_lambda" [<>] @@ -722,8 +1023,7 @@ let rec to_prod n lam = lam else match lam with - | DOP2(Lambda,ty,DLAM(na,bd)) -> - DOP2(Prod,ty,DLAM(na, to_prod (n-1) bd)) + | CLam(na,ty,bd) -> CPrd(na,ty,to_prod (n-1) bd) | DOP2(Cast,c,_) -> to_prod n c | _ -> errorlabstrm "to_prod" [<>] @@ -733,7 +1033,7 @@ let rec to_prod n lam = let prod_app t n = match strip_outer_cast t with - | DOP2(Prod,_,DLAM(na,b)) -> subst1 n b + | CPrd (_,_,b) -> subst1 n b | _ -> errorlabstrm "prod_app" [< 'sTR"Needed a product, but didn't find one" ; 'fNL >] @@ -753,27 +1053,29 @@ let prod_applist t nL = List.fold_left prod_app t nL (* Transforms a product term (x1:T1)..(xn:Tn)T into the pair ([(xn,Tn);...;(x1,T1)],T), where T is not a product *) let destArity = - let rec prodec_rec l = function - | DOP2(Prod,t,DLAM(x,c)) -> prodec_rec ((x,t)::l) c - | DOP2(Cast,c,_) -> prodec_rec l c - | DOP0(Sort s) -> l,s - | _ -> anomaly "decompose_arity: not an arity" + let rec prodec_rec l c = + match kind_of_term c with + | IsProd (x,t,c) -> prodec_rec ((x,t)::l) c + | IsCast (c,_) -> prodec_rec l c + | IsSort s -> l,s + | _ -> anomaly "decompose_arity: not an arity" in prodec_rec [] -let rec isArity = function - | DOP2(Prod,_,DLAM(_,c)) -> isArity c - | DOP2(Cast,c,_) -> isArity c - | DOP0(Sort _) -> true +let rec isArity c = + match kind_of_term c with + | IsProd (_,_,c) -> isArity c + | IsCast (c,_) -> isArity c + | IsSort _ -> true | _ -> false (* Transforms a product term (x1:T1)..(xn:Tn)T into the pair ([(xn,Tn);...;(x1,T1)],T), where T is not a product *) let decompose_prod = let rec prodec_rec l = function - | DOP2(Prod,t,DLAM(x,c)) -> prodec_rec ((x,t)::l) c - | DOP2(Cast,c,_) -> prodec_rec l c - | c -> l,c + | CPrd(x,t,c) -> prodec_rec ((x,t)::l) c + | DOP2(Cast,c,_) -> prodec_rec l c + | c -> l,c in prodec_rec [] @@ -781,9 +1083,9 @@ let decompose_prod = ([(xn,Tn);...;(x1,T1)],T), where T is not a lambda *) let decompose_lam = let rec lamdec_rec l = function - | DOP2(Lambda,t,DLAM(x,c)) -> lamdec_rec ((x,t)::l) c - | DOP2(Cast,c,_) -> lamdec_rec l c - | c -> l,c + | CLam (x,t,c) -> lamdec_rec ((x,t)::l) c + | DOP2 (Cast,c,_) -> lamdec_rec l c + | c -> l,c in lamdec_rec [] @@ -794,8 +1096,8 @@ let decompose_prod_n n = let rec prodec_rec l n c = if n=0 then l,c else match c with - | DOP2(Prod,t,DLAM(x,c)) -> prodec_rec ((x,t)::l) (n-1) c - | DOP2(Cast,c,_) -> prodec_rec l n c + | CPrd (x,t,c) -> prodec_rec ((x,t)::l) (n-1) c + | DOP2 (Cast,c,_) -> prodec_rec l n c | c -> error "decompose_prod_n: not enough products" in prodec_rec [] n @@ -807,8 +1109,8 @@ let decompose_lam_n n = let rec lamdec_rec l n c = if n=0 then l,c else match c with - | DOP2(Lambda,t,DLAM(x,c)) -> lamdec_rec ((x,t)::l) (n-1) c - | DOP2(Cast,c,_) -> lamdec_rec l n c + | CLam (x,t,c) -> lamdec_rec ((x,t)::l) (n-1) c + | DOP2 (Cast,c,_) -> lamdec_rec l n c | c -> error "decompose_lam_n: not enough abstractions" in lamdec_rec [] n @@ -817,7 +1119,7 @@ let decompose_lam_n n = * gives n (casts are ignored) *) let nb_lam = let rec nbrec n = function - | DOP2(Lambda,_,DLAM(_,c)) -> nbrec (n+1) c + | CLam (_,_,c) -> nbrec (n+1) c | DOP2(Cast,c,_) -> nbrec n c | _ -> n in @@ -826,145 +1128,13 @@ let nb_lam = (* similar to nb_lam, but gives the number of products instead *) let nb_prod = let rec nbrec n = function - | DOP2(Prod,_,DLAM(_,c)) -> nbrec (n+1) c + | CPrd (_,_,c) -> nbrec (n+1) c | DOP2(Cast,c,_) -> nbrec n c | _ -> n in nbrec 0 -(* Trop compliqué... -(********************************************************************) -(* various utility functions for implementing terms with bindings *) -(********************************************************************) - -let extract_lifted (n,x) = lift n x -let insert_lifted x = (0,x) - -(* l is a list of pairs (n:nat,x:constr), env is a stack of (na:name,T:constr) - push_and_lift adds a component to env and lifts l one step *) -let push_and_lift (na,t) env l = - ((na,t)::env, List.map (fun (n,x) -> (n+1,x)) l) - - -(* if T is not (x1:A1)(x2:A2)....(xn:An)T' then (push_and_liftl n env T l) - raises an error else it gives ([x1,A1 ; x2,A2 ; ... ; xn,An]@env,T',l') - where l' is l lifted n steps *) -let push_and_liftl n env t l = - let rec pushrec n t (env,l) = - match (n,t) with - | (0, _) -> (env,t,l) - | (_, DOP2(Prod,t,DLAM(na,b))) -> - pushrec (n-1) b (push_and_lift (na,t) env l) - | (_, DOP2(Cast,t,_)) -> pushrec n t (env,l) - | _ -> error "push_and_liftl" - in - pushrec n t (env,l) - -(* if T is not (x1:A1)(x2:A2)....(xn:An)T' then (push_and_liftl n env T l) - raises an error else it gives ([x1,A1 ; x2,A2 ; ... ; xn,An]@env,T',l') - where l' is l lifted n steps *) -let push_lam_and_liftl n env t l = - let rec pushrec n t (env,l) = - match (n,t) with - | (0, _) -> (env,t,l) - | (_, DOP2(Lambda,t,DLAM(na,b))) -> - pushrec (n-1) b (push_and_lift (na,t) env l) - | (_, DOP2(Cast,t,_)) -> pushrec n t (env,l) - | _ -> error "push_lam_and_liftl" - in - pushrec n t (env,l) - -(* l is a list of pairs (n:nat,x:constr), tlenv is a stack of -(na:name,T:constr), B : constr, na : name -(prod_and_pop ((na,T)::tlenv) B l) gives (tlenv, (na:T)B, l') -where l' is l lifted down one step *) -let prod_and_pop env b l = - match env with - | [] -> error "prod_and_pop" - | (na,t)::tlenv -> - (tlenv,DOP2(Prod,t,DLAM(na,b)), - List.map (function - (0,x) -> (0,lift (-1) x) - | (n,x) -> (n-1,x)) l) - -(* recusively applies prod_and_pop : -if env = [na1:T1 ; na2:T2 ; ... ; nan:Tn]@tlenv -then -(prod_and_popl n env T l) gives (tlenv,(nan:Tn)...(na1:Ta1)T,l') where -l' is l lifted down n steps *) -let prod_and_popl n env t l = - let rec poprec = function - | (0, (env,b,l)) -> (env,b,l) - | (n, ([],_,_)) -> error "prod_and_popl" - | (n, (env,b,l)) -> poprec (n-1, prod_and_pop env b l) - in - poprec (n,(env,t,l)) - -(* similar to prod_and_pop, but gives [na:T]B intead of (na:T)B *) -let lam_and_pop env b l = - match env with - | [] -> error "lam_and_pop" - | (na,t)::tlenv -> - (tlenv,DOP2(Lambda,t,DLAM(na,b)), - List.map (function - (0,x) -> (0,lift (-1) x) - | (n,x) -> (n-1,x)) l) - -(* similar to lamn_and_pop but generates new names whenever the name is - * Anonymous *) -let lam_and_pop_named env body l acc_ids = - match env with - | [] -> error "lam_and_pop" - | (na,t)::tlenv -> - let id = match na with - | Anonymous -> next_ident_away (id_of_string "a") acc_ids - | Name id -> id - in - (tlenv,DOP2(Lambda,t,DLAM((Name id),body)), - List.map (function - | (0,x) -> (0,lift (-1) x) - | (n,x) -> (n-1,x)) l, - (id::acc_ids)) - -(* similar to prod_and_popl but gives [nan:Tan]...[na1:Ta1]B instead of - * (nan:Tan)...(na1:Ta1)B *) -let lam_and_popl n env t l = - let rec poprec = function - | (0, (env,b,l)) -> (env,b,l) - | (n, ([],_,_)) -> error "lam_and_popl" - | (n, (env,b,l)) -> poprec (n-1, lam_and_pop env b l) - in - poprec (n,(env,t,l)) - -(* similar to prod_and_popl but gives [nan:Tan]...[na1:Ta1]B instead of - * but it generates names whenever nai=Anonymous *) - -let lam_and_popl_named n env t l = - let rec poprec = function - | (0, (env,b,l,_)) -> (env,b,l) - | (n, ([],_,_,_)) -> error "lam_and_popl" - | (n, (env,b,l,acc_ids)) -> poprec (n-1, lam_and_pop_named env b l acc_ids) - in - poprec (n,(env,t,l,[])) - -(* [lambda_ize n T endpt] - * will pop off the first [n] products in [T], then stick in [endpt], - * properly lifted, and then push back the products, but as lambda- - * abstractions *) -let lambda_ize n t endpt = - let env = [] - and carry = [insert_lifted endpt] in - let env, endpt = - match push_and_liftl n env t carry with - | (env,_,[endpt]) -> env, endpt - | _ -> anomaly "bud in Term.lamda_ize" - in - let t = extract_lifted endpt in - match lam_and_popl n env t [] with - | (_,t,[]) -> t - | _ -> anomaly "bud in Term.lamda_ize" -*) - +(* Misc *) let sort_hdchar = function | Prop(_) -> "P" | Type(_) -> "T" @@ -1021,17 +1191,65 @@ let rec strip_head_cast = function | DOP2(Cast,c,t) -> strip_head_cast c | c -> c +(* Returns the list of global variables in a term *) + +let global_varsl l constr = + let rec filtrec acc = function + | VAR id -> id::acc + | DOP1(oper,c) -> filtrec acc c + | DOP2(oper,c1,c2) -> filtrec (filtrec acc c1) c2 + | DOPN(oper,cl) -> Array.fold_left filtrec acc cl + | DLAM(_,c) -> filtrec acc c + | DLAMV(_,v) -> Array.fold_left filtrec acc v + | CLam (_,t,c) -> filtrec (filtrec acc t) c + | CPrd (_,t,c) -> filtrec (filtrec acc t) c + | CLet (_,b,t,c) -> filtrec (filtrec (filtrec acc b) t) c + | _ -> acc + in + filtrec l constr + +let global_vars constr = global_varsl [] constr + +let global_vars_set constr = + let rec filtrec acc = function + | VAR id -> Idset.add id acc + | DOP1(oper,c) -> filtrec acc c + | DOP2(oper,c1,c2) -> filtrec (filtrec acc c1) c2 + | DOPN(oper,cl) -> Array.fold_left filtrec acc cl + | DLAM(_,c) -> filtrec acc c + | DLAMV(_,v) -> Array.fold_left filtrec acc v + | CLam (_,t,c) -> filtrec (filtrec acc t) c + | CPrd (_,t,c) -> filtrec (filtrec acc t) c + | CLet (_,b,t,c) -> filtrec (filtrec (filtrec acc b) t) c + | _ -> acc + in + filtrec Idset.empty constr + +(* [Rel (n+m);...;Rel(n+1)] *) + +let rel_vect n m = Array.init m (fun i -> Rel(n+m-i)) + +let rel_list n m = + let rec reln l p = + if p>m then l else reln (Rel(n+p)::l) (p+1) + in + reln [] 1 + +(* Rem: end of import from old module Generic *) + (* Various occurs checks *) let occur_opern s = let rec occur_rec = function | DOPN(oper,cl) -> s=oper or (array_exists occur_rec cl) - | DOPL(oper,cl) -> s=oper or (List.exists occur_rec cl) | VAR _ -> false | DOP1(_,c) -> occur_rec c | DOP2(_,c1,c2) -> (occur_rec c1) or (occur_rec c2) | DLAM(_,c) -> occur_rec c | DLAMV(_,v) -> array_exists occur_rec v + | CLam (_,t,c) -> occur_rec t or occur_rec c + | CPrd (_,t,c) -> occur_rec t or occur_rec c + | CLet (_,b,t,c) -> occur_rec b or occur_rec t or occur_rec c | _ -> false in occur_rec @@ -1044,12 +1262,14 @@ let occur_evar ev = occur_opern (Evar ev) let occur_var s = let rec occur_rec = function | DOPN(_,cl) -> array_exists occur_rec cl - | DOPL(_,cl) -> List.exists occur_rec cl | VAR id -> s=id | DOP1(_,c) -> occur_rec c | DOP2(_,c1,c2) -> (occur_rec c1) or (occur_rec c2) | DLAM(_,c) -> occur_rec c | DLAMV(_,v) -> array_exists occur_rec v + | CLam (_,t,c) -> occur_rec t or occur_rec c + | CPrd (_,t,c) -> occur_rec t or occur_rec c + | CLet (_,b,t,c) -> occur_rec b or occur_rec t or occur_rec c | _ -> false in occur_rec @@ -1068,7 +1288,6 @@ let occur_var s = - if no (sp,_) appears in sigma, then sp is not unfolded. - NOTE : the case of DOPL is not handled... *) let replace_consts const_alist = let rec substrec = function @@ -1090,11 +1309,13 @@ let replace_consts const_alist = | DOP2(oper,c1,c2) -> DOP2(oper,substrec c1,substrec c2) | DLAM(na,c) -> DLAM(na,substrec c) | DLAMV(na,v) -> DLAMV(na,Array.map substrec v) + | CLam (na,t,c) -> CLam (na, substrec t, substrec c) + | CPrd (na,t,c) -> CPrd (na, substrec t, substrec c) + | CLet (na,b,t,c) -> CLet (na, substrec b, substrec t, substrec c) | x -> x in if const_alist = [] then function x -> x else substrec -(* NOTE : the case of DOPL is not handled by whd_castapp_stack *) let whd_castapp_stack = let rec whrec x stack = match x with | DOPN(AppL,cl) -> whrec (array_hd cl) (array_app_tl cl stack) @@ -1129,41 +1350,31 @@ let rec eq_constr_rec m n = | (DLAM(_,c1),DLAM(_,c2)) -> eq_constr_rec c1 c2 | (DLAMV(_,cl1),DLAMV(_,cl2)) -> array_for_all2 eq_constr_rec cl1 cl2 + | CLam(_,t1,c1), CLam(_,t2,c2) -> eq_constr_rec t1 t2 & eq_constr_rec c1 c2 + | CPrd(_,t1,c1), CPrd(_,t2,c2) -> eq_constr_rec t1 t2 & eq_constr_rec c1 c2 + | CLet(_,b1,t1,c1), CLet (_,b2,t2,c2) -> + eq_constr_rec b1 b2 & eq_constr_rec t1 t2 & eq_constr_rec c1 c2 | _ -> false let eq_constr = eq_constr_rec -let rec eq_constr_with_meta_rec m n= - (m == n) or - (m=n) or - (match (strip_head_cast m,strip_head_cast n) with - | (Rel p1,Rel p2) -> p1=p2 - | (DOPN(oper1,cl1),DOPN(oper2,cl2)) -> - oper1=oper2 & array_for_all2 eq_constr_rec cl1 cl2 - | (DOP0 oper1,DOP0 oper2) -> oper1=oper2 - | (DOP1(i,c1),DOP1(j,c2)) -> (i=j) & eq_constr_rec c1 c2 - | (DOP2(i,c1,c1'),DOP2(j,c2,c2')) -> - (i=j) & eq_constr_rec c1 c2 & eq_constr_rec c1' c2' - | (DLAM(_,c1),DLAM(_,c2)) -> eq_constr_rec c1 c2 - | (DLAMV(_,cl1),DLAMV(_,cl2)) -> - array_for_all2 eq_constr_rec cl1 cl2 - | _ -> false) - (* (dependent M N) is true iff M is eq_term with a subterm of N M is appropriately lifted through abstractions of N *) let dependent = let rec deprec m t = - (eq_constr m t) - or (match t with - | VAR _ -> false - | DOP1(_,c) -> deprec m c - | DOP2(_,c,t) -> deprec m c or deprec m t - | DOPN(_,cl) -> array_exists (deprec m) cl - | DOPL(_,cl) -> List.exists (deprec m) cl - | DLAM(_,c) -> deprec (lift 1 m) c - | DLAMV(_,v) -> array_exists (deprec (lift 1 m)) v - | _ -> false) + (eq_constr m t) or + (match t with + | VAR _ -> false + | DOP1(_,c) -> deprec m c + | DOP2(_,c,t) -> deprec m c or deprec m t + | DOPN(_,cl) -> array_exists (deprec m) cl + | DLAM(_,c) -> deprec (lift 1 m) c + | DLAMV(_,v) -> array_exists (deprec (lift 1 m)) v + | CLam (_,t,c) -> deprec m t or deprec (lift 1 m) c + | CPrd (_,t,c) -> deprec m t or deprec (lift 1 m) c + | CLet (_,b,t,c) -> deprec m b or deprec m t or deprec (lift 1 m) c + | _ -> false) in deprec @@ -1173,7 +1384,7 @@ let dependent = let rec eta_reduce_head c = match c with - | DOP2(Lambda,c1,DLAM(_,c')) -> + | CLam (_,c1,c') -> (match eta_reduce_head c' with | DOPN(AppL,cl) -> let lastn = (Array.length cl) - 1 in @@ -1185,7 +1396,7 @@ let rec eta_reduce_head c = if lastn = 1 then cl.(0) else DOPN(AppL,Array.sub cl 0 lastn) in - if (not ((dependent (Rel 1) c'))) + if (not ((dependent (mkRel 1) c'))) then lift (-1) c' else c | _ -> c) @@ -1194,40 +1405,43 @@ let rec eta_reduce_head c = (* alpha-eta conversion : ignore print names and casts *) -let rec eta_eq_constr t1 t2 = - let t1 = eta_reduce_head (strip_head_cast t1) - and t2 = eta_reduce_head (strip_head_cast t2) in - t1=t2 or match (t1,t2) with - | (DOP2(Cast,c1,_),c2) -> eta_eq_constr c1 c2 - | (c1,DOP2(Cast,c2,_)) -> eta_eq_constr c1 c2 +let eta_eq_constr = + let rec aux t1 t2 = + let t1 = eta_reduce_head (strip_head_cast t1) + and t2 = eta_reduce_head (strip_head_cast t2) in + t1=t2 or match (t1,t2) with + | (DOP2(Cast,c1,_),c2) -> aux c1 c2 + | (c1,DOP2(Cast,c2,_)) -> aux c1 c2 | (Rel p1,Rel p2) -> p1=p2 - | (DOPN(oper1,cl1),DOPN(oper2,cl2)) -> - oper1=oper2 & array_for_all2 eta_eq_constr cl1 cl2 - | (DOP0 oper1,DOP0 oper2) -> oper1=oper2 - | (DOP1(i,c1),DOP1(j,c2)) -> (i=j) & eta_eq_constr c1 c2 - | (DOP2(i,c1,c1'),DOP2(j,c2,c2')) -> - (i=j) & eta_eq_constr c1 c2 & eta_eq_constr c1' c2' - | (DLAM(_,c1),DLAM(_,c2)) -> eta_eq_constr c1 c2 - | (DLAMV(_,cl1),DLAMV(_,cl2)) -> array_for_all2 eta_eq_constr cl1 cl2 + | (DOPN(op1,cl1),DOPN(op2,cl2)) -> op1=op2 & array_for_all2 aux cl1 cl2 + | (DOP0 oper1,DOP0 oper2) -> oper1=oper2 + | (DOP1(i,c1),DOP1(j,c2)) -> (i=j) & aux c1 c2 + | (DOP2(i,c1,c1'),DOP2(j,c2,c2')) -> (i=j) & aux c1 c2 & aux c1' c2' + | (DLAM(_,c1),DLAM(_,c2)) -> aux c1 c2 + | (DLAMV(_,cl1),DLAMV(_,cl2)) -> array_for_all2 aux cl1 cl2 + | CLam(_,t1,c1), CLam(_,t2,c2) -> aux t1 t2 & aux c1 c2 + | CPrd(_,t1,c1), CPrd(_,t2,c2) -> aux t1 t2 & aux c1 c2 + | CLet(_,b1,t1,c1), CLet (_,b2,t2,c2) -> aux b1 b2 & aux t1 t2 & aux c1 c2 | _ -> false + in aux -(* This renames bound variablew with fresh and distinct names *) +(* This renames bound variables with fresh and distinct names *) (* in such a way that the printer doe not generate new names *) (* and therefore that printed names are the intern names *) (* In this way, tactics such as Induction works well *) -let rec rename_bound_var l = function - | DOP2(Prod,c1,DLAM(Name(s),c2)) -> - if dependent (Rel 1) c2 then +let rec rename_bound_var l c = + match kind_of_term c with + | IsProd (Name s,c1,c2) -> + if dependent (mkRel 1) c2 then let s' = next_ident_away s (global_vars c2@l) in - DOP2(Prod,c1,DLAM(Name(s'),rename_bound_var (s'::l) c2)) + mkProd (Name s', c1, rename_bound_var (s'::l) c2) else - DOP2(Prod,c1,DLAM(Name(s),rename_bound_var l c2)) - | DOP2(Prod,c1,DLAM(Anonymous,c2)) -> - DOP2(Prod,c1,DLAM(Anonymous,rename_bound_var l c2)) - | DOP2(Cast,c,t) -> DOP2(Cast,rename_bound_var l c,t) - | x -> x + mkProd (Name s, c1, rename_bound_var l c2) + | IsProd (Anonymous,c1,c2) -> mkProd (Anonymous, c1, rename_bound_var l c2) + | IsCast (c,t) -> mkCast (rename_bound_var l c, t) + | x -> c (***************************) (* substitution functions *) @@ -1269,47 +1483,38 @@ let sort_increasing_snd = [subst_term c t] substitutes [(Rel 1)] for all occurrences of (closed) term [c] in a term [t] *) -let subst_term c t = +let subst_term_gen eq_fun c t = let rec substrec k c t = match prefix_application k c t with | Some x -> x | None -> - (if eq_constr t c then Rel(k) else match t with - | DOPN(Const sp,cl) -> t - | DOPN(MutInd (x_0,x_1),cl) -> t - | DOPN(MutConstruct (x_0,x_1),cl) -> t - | DOPN(oper,tl) -> DOPN(oper,Array.map (substrec k c) tl) - | DOP1(i,t) -> DOP1(i,substrec k c t) - | DOP2(oper,c1,c2) -> DOP2(oper,substrec k c c1,substrec k c c2) - | DLAM(na,t) -> DLAM(na,substrec (k+1) (lift 1 c) t) - | DLAMV(na,v) -> DLAMV(na,Array.map (substrec (k+1) (lift 1 c)) v) - | _ -> t) + (if eq_fun t c then Rel(k) else match t with + | DOPN(Const sp,cl) -> t + | DOPN(MutInd (x_0,x_1),cl) -> t + | DOPN(MutConstruct (x_0,x_1),cl) -> t + | DOPN(oper,tl) -> DOPN(oper,Array.map (substrec k c) tl) + | DOP1(i,t) -> DOP1(i,substrec k c t) + | DOP2(oper,c1,c2) -> DOP2(oper,substrec k c c1,substrec k c c2) + | DLAM(na,t) -> DLAM(na,substrec (k+1) (lift 1 c) t) + | DLAMV(na,v) -> DLAMV(na,Array.map (substrec (k+1) (lift 1 c)) v) + | CLam(na,t,c2) -> CLam(na,substrec k c t,substrec (k+1) (lift 1 c) c2) + | CPrd(na,t,c2) -> CPrd(na,substrec k c t,substrec (k+1) (lift 1 c) c2) + | CLet(na,b,t,c2) -> CLet(na,substrec k c b,substrec k c t, + substrec (k+1) (lift 1 c) c2) + | _ -> t) in substrec 1 c t -(* same as subst_term, but modulo eta *) - -let subst_term_eta_eq c t = - let rec substrec k c t = - match prefix_application_eta k c t with - | Some x -> x - | None -> - (if eta_eq_constr t c then Rel(k) else match t with - | DOPN(Const sp,cl) -> t - | DOPN(oper,tl) -> DOPN(oper,Array.map (substrec k c) tl) - | DOP1(i,t) -> DOP1(i,substrec k c t) - | DOP2(oper,c1,c2) -> DOP2(oper,substrec k c c1,substrec k c c2) - | DLAM(na,t) -> DLAM(na,substrec (k+1) (lift 1 c) t) - | DLAMV(na,v)-> DLAMV(na,Array.map (substrec (k+1) (lift 1 c)) v) - | _ -> t) - in - substrec 1 c t +let subst_term = subst_term_gen eq_constr +let subst_term_eta = subst_term_gen eta_eq_constr (* bl : (int,constr) Listmap.t = (int * constr) list *) (* c : constr *) (* for each binding (i,c_i) in bl, substitutes the metavar i by c_i in c *) (* Raises Not_found if c contains a meta that is not in the association list *) +(* Bogué ? Pourquoi pas de lift en passant sous un lieur ?? *) +(* Et puis meta doit fusionner avec Evar *) let rec subst_meta bl c = match c with | DOP0(Meta(i)) -> List.assoc i bl @@ -1317,6 +1522,10 @@ let rec subst_meta bl c = | DOP2(op,c'1, c'2) -> DOP2(op, subst_meta bl c'1, subst_meta bl c'2) | DOPN(op, c') -> DOPN(op, Array.map (subst_meta bl) c') | DLAM(x,c') -> DLAM(x, subst_meta bl c') + | CLam(na,t,c) -> CLam(na,subst_meta bl t,subst_meta bl c) + | CPrd(na,t,c) -> CPrd(na,subst_meta bl t,subst_meta bl c) + | CLet(na,b,t,c) -> CLet(na,subst_meta bl b,subst_meta bl t, + subst_meta bl c) | _ -> c (* Substitute only a list of locations locs, the empty list is @@ -1325,55 +1534,61 @@ let rec subst_meta bl c = that will not be substituted. *) let subst_term_occ_gen locs occ c t = + let pos = ref occ in let except = List.for_all (fun n -> n<0) locs in - let rec substcheck k occ c t = - if except or List.exists (function u -> u>=occ) locs then - substrec k occ c t + let rec substcheck k c t = + if except or List.exists (function u -> u >= !pos) locs then + substrec k c t else - (occ,t) - and substrec k occ c t = + t + and substrec k c t = if eq_constr t c then - if except then - if List.mem (-occ) locs then (occ+1,t) else (occ+1,Rel(k)) - else - if List.mem occ locs then (occ+1,Rel(k)) else (occ+1,t) - else + let r = + if except then + if List.mem (- !pos) locs then t else (Rel k) + else + if List.mem !pos locs then (Rel k) else t + in incr pos; r + else match t with - | DOPN(Const sp,tl) -> occ,t - | DOPN(MutConstruct _,tl) -> occ,t - | DOPN(MutInd _,tl) -> occ,t - | DOPN(i,cl) -> - let (occ',cl') = - Array.fold_left - (fun (nocc',lfd) f -> - let (nocc'',f') = substcheck k nocc' c f in - (nocc'',f'::lfd)) - (occ,[]) cl - in - (occ',DOPN(i,Array.of_list (List.rev cl'))) - | DOP2(i,t1,t2) -> - let (nocc1,t1')=substrec k occ c t1 in - let (nocc2,t2')=substcheck k nocc1 c t2 in - nocc2,DOP2(i,t1',t2') - | DOP1(i,t) -> - let (nocc,t')= substrec k occ c t in - nocc,DOP1(i,t') - | DLAM(n,t) -> - let (occ',t') = substcheck (k+1) occ (lift 1 c) t in - (occ',DLAM(n,t')) - | DLAMV(n,cl) -> - let (occ',cl') = + | DOPN((Const _ | MutConstruct _ | MutInd _), _) -> t + | DOPN(i,cl) -> + let cl' = + Array.fold_left (fun lfd f -> substcheck k c f :: lfd) [] cl + in + DOPN(i,Array.of_list (List.rev cl')) + | DOP2(i,t1,t2) -> + let t1' = substrec k c t1 in + let t2' = substcheck k c t2 in + DOP2(i,t1',t2') + | DOP1(i,t) -> + DOP1(i,substrec k c t) + | DLAM(n,t) -> + DLAM(n,substcheck (k+1) (lift 1 c) t) + | DLAMV(n,cl) -> + let cl' = Array.fold_left - (fun (nocc',lfd) f -> - let (nocc'',f') = - substcheck (k+1) nocc' (lift 1 c) f - in (nocc'',f'::lfd)) - (occ,[]) cl + (fun lfd f -> substcheck (k+1) (lift 1 c) f ::lfd) + [] cl in - (occ',DLAMV(n,Array.of_list (List.rev cl') )) - | _ -> occ,t + DLAMV(n,Array.of_list (List.rev cl')) + | CLam(na,t,c2) -> + let t' = substrec k c t in + let c2' = substcheck (k+1) (lift 1 c) c2 in + CLam(na,t',c2') + | CPrd(na,t,c2) -> + let t' = substrec k c t in + let c2' = substcheck (k+1) (lift 1 c) c2 in + CPrd(na,t',c2') + | CLet(na,b,t,c2) -> + let b' = substrec k c b in + let t' = substrec k c t in + let c2' = substcheck (k+1) (lift 1 c) c2 in + CLet(na,b',t',c2') + | DOP0 _ | VAR _ | Rel _ -> t in - substcheck 1 occ c t + let t' = substcheck 1 c t in + (!pos, t') let subst_term_occ locs c t = if locs = [] then @@ -1406,24 +1621,25 @@ let subst_term_occ_decl locs c (id,bodyopt,typ as d) = (***************************) let rec occur_meta = function - | DOP2(Prod,t,DLAM(_,c)) -> (occur_meta t) or (occur_meta c) - | DOP2(Lambda,t,DLAM(_,c)) -> (occur_meta t) or (occur_meta c) + | CPrd(_,t,c) -> (occur_meta t) or (occur_meta c) + | CLam(_,t,c) -> (occur_meta t) or (occur_meta c) + | CLet(_,b,t,c) -> (occur_meta b) or (occur_meta t) or (occur_meta c) | DOPN(_,cl) -> (array_exists occur_meta cl) | DOP2(Cast,c,t) -> occur_meta c or occur_meta t | DOP0(Meta(_)) -> true | _ -> false -let rel_vect = (Generic.rel_vect : int -> int -> constr array) - let occur_existential = let rec occrec = function | DOPN(Evar _,_) -> true | DOPN(_,cl) -> array_exists occrec cl - | DOPL(_,cl) -> List.exists occrec cl | DOP2(_,c1,c2) -> occrec c1 or occrec c2 | DOP1(_,c) -> occrec c | DLAM(_,c) -> occrec c | DLAMV(_,cl) -> array_exists occrec cl + | CPrd(_,t,c) -> (occrec t) or (occrec c) + | CLam(_,t,c) -> (occrec t) or (occrec c) + | CLet(_,b,t,c) -> (occrec b) or (occrec t) or (occrec c) | _ -> false in occrec @@ -1440,13 +1656,14 @@ let comp_term t1 t2 = | (DOPN(o1,v1), DOPN(o2,v2)) -> (o1==o2) & (Array.length v1 = Array.length v2) & array_for_all2 (==) v1 v2 - | (DOPL(o1,l1), DOPL(o2,l2)) -> - (o1==o2) & (List.length l1 = List.length l2) - & List.for_all2 (==) l1 l2 | (DLAM(x1,t1), DLAM(x2,t2)) -> x1==x2 & t1==t2 | (DLAMV(x1,v1), DLAMV(x2,v2)) -> (x1==x2) & (Array.length v1 = Array.length v2) & array_for_all2 (==) v1 v2 + | CLam(x1,t1,c1), CLam(x2,t2,c2) -> (x1==x2) & (t1==t2) & (c1==c2) + | CPrd(x1,t1,c1), CPrd(x2,t2,c2) -> (x1==x2) & (t1==t2) & (c1==c2) + | CLet(x1,b1,t1,c1), CLet (x2,b2,t2,c2) -> + (x1==x2) & (b1==b2) & (t1==t2) & (c1==c2) | (Rel i, Rel j) -> i=j | (VAR x, VAR y) -> x==y | _ -> false @@ -1457,9 +1674,11 @@ let hash_term (sh_rec,(sh_op,sh_na,sh_id)) t = | DOP1(o,t) -> DOP1(sh_op o, sh_rec t) | DOP2(o,t1,t2) -> DOP2(sh_op o, sh_rec t1, sh_rec t2) | DOPN(o,v) -> DOPN(sh_op o, Array.map sh_rec v) - | DOPL(o,l) -> DOPL(sh_op o, List.map sh_rec l) | DLAM(n,t) -> DLAM(sh_na n, sh_rec t) | DLAMV(n,v) -> DLAMV(sh_na n, Array.map sh_rec v) + | CLam (n,t,c) -> CLam (sh_na n, sh_rec t, sh_rec c) + | CPrd (n,t,c) -> CPrd (sh_na n, sh_rec t, sh_rec c) + | CLet (n,b,t,c) -> CLet (sh_na n, sh_rec b, sh_rec t, sh_rec c) | Rel i -> t | VAR x -> VAR (sh_id x) @@ -1568,204 +1787,138 @@ let is_hd_const=function Some (Const c,Array.of_list (List.tl (Array.to_list t))) |_ -> None) |_ -> None - -(*Gives the occurences number of t in u*) -let rec nb_occ_term t u= - let one_step t=function - | DOP1(_,c) -> nb_occ_term t c - | DOP2(_,c0,c1) -> (nb_occ_term t c0)+(nb_occ_term t c1) - | DOPN(_,a) -> Array.fold_left (fun a x -> a+(nb_occ_term t x)) 0 a - | DOPL(_,l) -> List.fold_left (fun a x -> a+(nb_occ_term t x)) 0 l - | DLAM(_,c) -> nb_occ_term t c - | DLAMV(_,a) -> Array.fold_left (fun a x -> a+(nb_occ_term t x)) 0 a - | _ -> 0 - in - if t=u then - 1 - else - one_step t u - -(*Alpha-conversion*) -let bind_eq=function - | (Anonymous,Anonymous) -> true - | (Name _,Name _) -> true - | _ -> false - - (*Tells if two constrs are equal modulo unification*) -let rec eq_mod_rel l_meta=function - | (t,DOP0(Meta n)) -> - if not(List.mem n (fst (List.split l_meta))) then - Some ([(n,t)]@l_meta) - else if (List.assoc n l_meta)=t then - Some l_meta - else - None - | DOP1(op0,c0), DOP1(op1,c1) -> - if op0=op1 then - eq_mod_rel l_meta (c0,c1) - else - None - | DOP2(op0,t0,c0), DOP2(op1,t1,c1) -> - if op0=op1 then - match (eq_mod_rel l_meta (t0,t1)) with - | None -> None - | Some l -> eq_mod_rel l (c0,c1) - else - None - | DOPN(op0,t0), DOPN(op1,t1) -> - if (op0=op1) & ((Array.length t0)=(Array.length t1)) then - List.fold_left2 - (fun a c1 c2 -> - match a with - | None -> None - | Some l -> eq_mod_rel l (c1,c2)) (Some l_meta) - (Array.to_list t0) (Array.to_list t1) - else - None - | DLAM(n0,t0),DLAM(n1,t1) -> - if (bind_eq (n0,n1)) then - eq_mod_rel l_meta (t0,t1) - else - None - | (t,u) -> - if t=u then Some l_meta else None - -(*Substitutes a list of meta l in t*) -let rec subst_with_lmeta l=function - | DOP0(Meta n) -> List.assoc n l - | DOP1(op,t) -> DOP1(op,subst_with_lmeta l t) - | DOP2(op,t0,t1) -> DOP2(op,subst_with_lmeta l t0,subst_with_lmeta l t1) - | DOPN(op,t) -> DOPN(op,Array.map (subst_with_lmeta l) t) - | DOPL(op,ld) -> DOPL(op,List.map (subst_with_lmeta l) ld) - | DLAM(n,t) -> DLAM(n,subst_with_lmeta l t) - | DLAMV(n,t) -> DLAMV(n,Array.map (subst_with_lmeta l) t) - | t -> t - -(*Carries out the following translation: DOPN(AppL,[|t|]) -> t and - DOPN(AppL,[|DOPN(AppL,t);...;t'|]) -> DOPN(AppL;[|t;...;t'|])*) -let rec appl_elim=function - | DOPN(AppL,t) -> - if (Array.length t)=1 then - appl_elim t.(0) - else - (match t.(0) with - | DOPN(AppL,t') -> - appl_elim (DOPN(AppL,Array.append t' - (Array.of_list - (List.tl (Array.to_list t))))) - |_ -> DOPN(AppL,Array.map appl_elim t)) - | DOP1(op,t) -> DOP1(op,appl_elim t) - | DOP2(op,t0,t1) -> DOP2(op,appl_elim t0,appl_elim t1) - | DOPN(op,t) -> DOPN(op,Array.map appl_elim t) - | DOPL(op,ld) -> DOPL(op,List.map appl_elim ld) - | DLAM(n,t) -> DLAM(n,appl_elim t) - | DLAMV(n,t) -> DLAMV(n,Array.map appl_elim t) - | t -> t - -(*Gives Some(first instance of ceq in cref,occurence number for this - instance) or None if no instance of ceq can be found in cref*) -let sub_term_with_unif cref ceq= - let rec find_match l_meta nb_occ op_ceq t_eq=function - | DOPN(AppL,t) as u -> - (match (t.(0)) with - | DOPN(op,t_op) -> - let t_args=Array.of_list (List.tl (Array.to_list t)) in - if op=op_ceq then - match - (List.fold_left2 - (fun a c0 c1 -> - match a with - | None -> None - | Some l -> eq_mod_rel l (c0,c1)) (Some l_meta) - (Array.to_list t_args) (Array.to_list t_eq)) - with - | None -> - List.fold_left - (fun (l_meta,nb_occ) x -> find_match l_meta nb_occ - op_ceq t_eq x) (l_meta,nb_occ) (Array.to_list - t_args) - | Some l -> (l,nb_occ+1) - else - List.fold_left - (fun (l_meta,nb_occ) x -> find_match l_meta - nb_occ op_ceq t_eq x) - (l_meta,nb_occ) (Array.to_list t) - | VAR _ -> - List.fold_left - (fun (l_meta,nb_occ) x -> find_match l_meta - nb_occ op_ceq t_eq x) - (l_meta,nb_occ) (Array.to_list t) - |_ -> (l_meta,nb_occ)) - | DOP2(_,t,DLAM(_,c)) -> - let (lt,nbt)=find_match l_meta nb_occ op_ceq t_eq t in - find_match lt nbt op_ceq t_eq c - | DOPN(_,t) -> - List.fold_left - (fun (l_meta,nb_occ) x -> find_match l_meta nb_occ op_ceq t_eq x) - (l_meta,nb_occ) (Array.to_list t) - |_ -> (l_meta,nb_occ) - in - match (is_hd_const ceq) with - | None -> - if (occur_meta ceq) then - None - else - let nb_occ=nb_occ_term ceq cref in - if nb_occ=0 then - None - else - Some (ceq,nb_occ) - | Some (head,t_args) -> - let (l,nb)=find_match [] 0 head t_args cref in - if nb=0 then - None - else - Some ((subst_with_lmeta l ceq),nb) + +(* Abstract decomposition of constr to deal with generic functions *) type constr_operator = | OpMeta of int | OpSort of sorts | OpRel of int | OpVar of identifier - | OpCast | OpProd of name | OpLambda of name + | OpCast | OpProd of name | OpLambda of name | OpLetIn of name | OpAppL | OpConst of section_path | OpAbst of section_path | OpEvar of existential_key | OpMutInd of inductive_path | OpMutConstruct of constructor_path | OpMutCase of case_info - | OpRec of fix_kind + | OpRec of fix_kind * name list let splay_constr = function - | Rel n -> OpRel n, [] - | VAR id -> OpVar id, [] - | DOP0 (Meta n) -> OpMeta n, [] - | DOP0 (Sort s) -> OpSort s, [] - | DOP2 (Cast, t1, t2) -> OpCast, [t1;t2] - | DOP2 (Prod, t1, (DLAM (x,t2))) -> OpProd x, [t1;t2] - | DOP2 (Lambda, t1, (DLAM (x,t2))) -> OpLambda x, [t1;t2] - | DOPN (AppL,a) -> OpAppL, Array.to_list a - | DOPN (Const sp, a) -> OpConst sp, Array.to_list a - | DOPN (Evar sp, a) -> OpEvar sp, Array.to_list a - | DOPN (MutInd ind_sp, l) -> OpMutInd ind_sp, Array.to_list l - | DOPN (MutConstruct cstr_sp,l) -> OpMutConstruct cstr_sp, Array.to_list l - | DOPN (MutCase ci,v) -> OpMutCase ci, Array.to_list v - | DOPN ((Fix (f,i),a)) -> OpRec (RFix (f,i)), Array.to_list a - | DOPN ((CoFix i),a) -> OpRec (RCofix i), Array.to_list a + | Rel n -> OpRel n, [||] + | VAR id -> OpVar id, [||] + | DOP0 (Meta n) -> OpMeta n, [||] + | DOP0 (Sort s) -> OpSort s, [||] + | DOP2 (Cast, t1, t2) -> OpCast, [|t1;t2|] + | CPrd (x, t1, t2) -> OpProd x, [|t1;t2|] + | CLam (x, t1, t2) -> OpLambda x, [|t1;t2|] + | CLet (x, b, t1, t2) -> OpLetIn x, [|b;t1;t2|] + | DOPN (AppL,a) -> OpAppL, a + | DOPN (Const sp, a) -> OpConst sp, a + | DOPN (Evar sp, a) -> OpEvar sp, a + | DOPN (MutInd ind_sp, l) -> OpMutInd ind_sp, l + | DOPN (MutConstruct cstr_sp,l) -> OpMutConstruct cstr_sp, l + | DOPN (MutCase ci,v) -> OpMutCase ci, v + | DOPN ((Fix (f,i),a)) as c -> + let (fi,(tl,lna,bl)) = destFix c in + OpRec (RFix fi,lna), Array.append tl bl + | DOPN ((CoFix i),a) as c -> + let (fi,(tl,lna,bl)) = destCoFix c in + OpRec (RCoFix fi,lna), Array.append tl bl | _ -> errorlabstrm "Term.splay_term" [< 'sTR "ill-formed constr" >] let gather_constr = function - | OpRel n, [] -> Rel n - | OpVar id, [] -> VAR id - | OpMeta n, [] -> DOP0 (Meta n) - | OpSort s, [] -> DOP0 (Sort s) - | OpCast, [t1;t2] -> DOP2 (Cast, t1, t2) - | OpProd x, [t1;t2] -> DOP2 (Prod, t1, (DLAM (x,t2))) - | OpLambda x, [t1;t2] -> DOP2 (Lambda, t1, (DLAM (x,t2))) - | OpAppL, a -> DOPN (AppL,Array.of_list a) - | OpConst sp, a -> DOPN (Const sp,Array.of_list a) - | OpEvar sp, a -> DOPN (Evar sp, Array.of_list a) - | OpMutInd ind_sp, l -> DOPN (MutInd ind_sp, Array.of_list l) - | OpMutConstruct cstr_sp, l -> DOPN (MutConstruct cstr_sp,Array.of_list l) - | OpMutCase ci, v -> DOPN (MutCase ci,Array.of_list v) - | OpRec (RFix (f,i)), a -> DOPN ((Fix (f,i),Array.of_list a)) - | OpRec (RCofix i), a -> DOPN ((CoFix i),Array.of_list a) + | OpRel n, [||] -> Rel n + | OpVar id, [||] -> VAR id + | OpMeta n, [||] -> DOP0 (Meta n) + | OpSort s, [||] -> DOP0 (Sort s) + | OpCast, [|t1;t2|] -> DOP2 (Cast, t1, t2) + | OpProd x, [|t1;t2|] -> mkProd (x, t1, t2) + | OpLambda x, [|t1;t2|] -> mkLambda (x, t1, t2) + | OpLetIn x, [|b;t1;t2|] -> mkLetIn (x, b, t1, t2) + | OpAppL, a -> DOPN (AppL, a) + | OpConst sp, a -> DOPN (Const sp, a) + | OpEvar sp, a -> DOPN (Evar sp, a) + | OpMutInd ind_sp, l -> DOPN (MutInd ind_sp, l) + | OpMutConstruct cstr_sp, l -> DOPN (MutConstruct cstr_sp, l) + | OpMutCase ci, v -> DOPN (MutCase ci, v) + | OpRec (RFix fi,lna), a -> + let n = Array.length a / 2 in + mkFix (fi,(Array.sub a 0 n, lna, Array.sub a n n)) + | OpRec (RCoFix i,lna), a -> + let n = Array.length a / 2 in + mkCoFix (i,(Array.sub a 0 n, lna, Array.sub a n n)) | _ -> errorlabstrm "Term.gather_term" [< 'sTR "ill-formed constr" >] + +let rec mycombine l1 l3 = + match (l1, l3) with + ([], []) -> [] + | (a1::l1, a3::l3) -> (a1, None, a3) :: mycombine l1 l3 + | (_, _) -> invalid_arg "mycombine" + +let rec mysplit = function + [] -> ([], []) + | (x, _, z)::l -> let (rx, rz) = mysplit l in (x::rx, z::rz) + +let splay_constr_with_binders = function + | Rel n -> OpRel n, [], [||] + | VAR id -> OpVar id, [], [||] + | DOP0 (Meta n) -> OpMeta n, [], [||] + | DOP0 (Sort s) -> OpSort s, [], [||] + | DOP2 (Cast, t1, t2) -> OpCast, [], [|t1;t2|] + | CPrd (x, t1, t2) -> OpProd x, [x,None,t1], [|t2|] + | CLam (x, t1, t2) -> OpLambda x, [x,None,t1], [|t2|] + | CLet (x, b, t1, t2) -> OpLetIn x, [x,Some b,t1], [|t2|] + | DOPN (AppL,a) -> OpAppL, [], a + | DOPN (Const sp, a) -> OpConst sp, [], a + | DOPN (Evar sp, a) -> OpEvar sp, [], a + | DOPN (MutInd ind_sp, l) -> OpMutInd ind_sp, [], l + | DOPN (MutConstruct cstr_sp,l) -> OpMutConstruct cstr_sp, [], l + | DOPN (MutCase ci,v) -> OpMutCase ci, [], v + | DOPN ((Fix (f,i),a)) as c -> + let (fi,(tl,lna,bl)) = destFix c in + let n = Array.length bl in + let ctxt = mycombine + (List.rev lna) + (Array.to_list (Array.mapi lift tl)) in + OpRec (RFix fi,lna), ctxt, bl + | DOPN ((CoFix i),a) as c -> + let (fi,(tl,lna,bl)) = destCoFix c in + let n = Array.length bl in + let ctxt = mycombine + (List.rev lna) + (Array.to_list (Array.mapi lift tl)) in + OpRec (RCoFix fi,lna), ctxt, bl + | _ -> errorlabstrm "Term.splay_term" [< 'sTR "ill-formed constr" >] + +let gather_constr_with_binders = function + | OpRel n, [], [||] -> Rel n + | OpVar id, [], [||] -> VAR id + | OpMeta n, [], [||] -> DOP0 (Meta n) + | OpSort s, [], [||] -> DOP0 (Sort s) + | OpCast, [], [|t1;t2|] -> DOP2 (Cast, t1, t2) + | OpProd _, [x,None,t1], [|t2|] -> mkProd (x, t1, t2) + | OpLambda _, [x,None,t1], [|t2|] -> mkLambda (x, t1, t2) + | OpLetIn _, [x,Some b,t1], [|t2|] -> mkLetIn (x, b, t1, t2) + | OpAppL, [], a -> DOPN (AppL, a) + | OpConst sp, [], a -> DOPN (Const sp, a) + | OpEvar sp, [], a -> DOPN (Evar sp, a) + | OpMutInd ind_sp, [], l -> DOPN (MutInd ind_sp, l) + | OpMutConstruct cstr_sp, [], l -> DOPN (MutConstruct cstr_sp, l) + | OpMutCase ci, [], v -> DOPN (MutCase ci, v) + | OpRec (RFix fi,lna), ctxt, bl -> + let (lna, tl) = mysplit ctxt in + let tl = Array.mapi (fun i -> lift (-i)) (Array.of_list tl) in + mkFix (fi,(tl, List.rev lna, bl)) + | OpRec (RCoFix i,lna), ctxt, bl -> + let (lna, tl) = mysplit ctxt in + let tl = Array.mapi (fun i -> lift (-i)) (Array.of_list tl) in + mkCoFix (i,(tl, List.rev lna, bl)) + | _ -> errorlabstrm "Term.gather_term" [< 'sTR "ill-formed constr" >] + +let generic_fold_left f acc bl tl = + let acc = + List.fold_left + (fun acc (_,bo,t) -> + match bo with + | None -> f acc t + | Some b -> f (f acc b) t) acc bl in + Array.fold_left f acc tl diff --git a/kernel/term.mli b/kernel/term.mli index cd86af675..0eb1d645d 100644 --- a/kernel/term.mli +++ b/kernel/term.mli @@ -2,11 +2,28 @@ (* $Id$ *) (*i*) +open Util open Pp open Names -open Generic +(*i open Generic i*) (*i*) +(*s The sorts of CCI. *) + +type contents = Pos | Null + +type sorts = + | Prop of contents (* Prop and Set *) + | Type of Univ.universe (* Type *) + +val str_of_contents : contents -> string +val contents_of_str : string -> contents + +val mk_Set : sorts +val mk_Prop : sorts + +val print_sort : sorts -> std_ppcmds + (*s The operators of the Calculus of Inductive Constructions. ['a] is the type of sorts. ([XTRA] is an extra slot, for putting in whatever sort of operator we need for whatever sort of application.) *) @@ -34,34 +51,32 @@ type 'a oper = | CoFix of int | XTRA of string -(*s The sorts of CCI. *) - -type contents = Pos | Null - -val str_of_contents : contents -> string -val contents_of_str : string -> contents - -type sorts = - | Prop of contents (* Prop and Set *) - | Type of Univ.universe (* Type *) - -val mk_Set : sorts -val mk_Prop : sorts - -val print_sort : sorts -> std_ppcmds - (*s The type [constr] of the terms of CCI - is obtained by instanciating the generic terms (type [term], - see \refsec{generic_terms}) on the above operators, themselves instanciated + is obtained by instanciating a generic notion of terms + on the above operators, themselves instanciated on the above sorts. *) -type constr = sorts oper term +(* [VAR] is used for named variables and [Rel] for variables as + de Bruijn indices. *) -type flat_arity = (name * constr) list * sorts +type constr = + | DOP0 of sorts oper + | DOP1 of sorts oper * constr + | DOP2 of sorts oper * constr * constr + | DOPN of sorts oper * constr array + | DLAM of name * constr + | DLAMV of name * constr array + | CLam of name * typed_type * constr + | CPrd of name * typed_type * constr + | CLet of name * constr * typed_type * constr + | VAR of identifier + | Rel of int + +and typed_type -(*type 'a judge = { body : constr; typ : 'a }*) +type flat_arity = (name * constr) list * sorts -type typed_type +(*s Functions about typed_type *) val make_typed : constr -> sorts -> typed_type val make_typed_lazy : constr -> (constr -> sorts) -> typed_type @@ -81,9 +96,9 @@ type var_declaration = identifier * constr option * typed_type type rel_declaration = name * constr option * typed_type (**********************************************************************) -type binder_kind = BProd | BLambda +type binder_kind = BProd | BLambda | BLetIn -type fix_kind = RFix of (int array * int) | RCofix of int +type fix_kind = RFix of (int array * int) | RCoFix of int type 'ctxt reference = | RConst of section_path * 'ctxt @@ -119,6 +134,7 @@ type kindOfTerm = | IsCast of constr * constr | IsProd of name * constr * constr | IsLambda of name * constr * constr + | IsLetIn of name * constr * constr * constr | IsAppL of constr * constr list | IsAbst of section_path * constr array | IsEvar of existential @@ -142,9 +158,6 @@ val kind_of_term : constr -> kindOfTerm (* Constructs a DeBrujin index *) val mkRel : int -> constr -(* Constructs an existential variable named "?" *) -val mkExistential : constr - (* Constructs an existential variable named "?n" *) val mkMeta : int -> constr @@ -172,15 +185,15 @@ val implicit_sort : sorts (* Constructs the term $t_1::t2$, i.e. the term $t_1$ casted with the type $t_2$ (that means t2 is declared as the type of t1). *) -val mkCast : constr -> constr -> constr +val mkCast : constr * constr -> constr (* Constructs the product $(x:t_1)t_2$ *) -val mkProd : name -> constr -> constr -> constr +val mkProd : name * constr * constr -> constr val mkNamedProd : identifier -> constr -> constr -> constr val mkProd_string : string -> constr -> constr -> constr (* Constructs the product $(x:t_1)t_2$ *) -val mkLetIn : name -> constr -> constr -> constr -> constr +val mkLetIn : name * constr * constr * constr -> constr val mkNamedLetIn : identifier -> constr -> constr -> constr -> constr (* Constructs either [(x:t)c] or [[x=b:t]c] *) @@ -199,7 +212,7 @@ val mkNamedProd_wo_LetIn : var_declaration -> constr -> constr val mkArrow : constr -> constr -> constr (* Constructs the abstraction $[x:t_1]t_2$ *) -val mkLambda : name -> constr -> constr -> constr +val mkLambda : name * constr * constr -> constr val mkNamedLambda : identifier -> constr -> constr -> constr (* [mkLambda_string s t c] constructs $[s:t]c$ *) @@ -230,7 +243,7 @@ val mkMutInd : inductive -> constr val mkMutConstruct : constructor -> constr (* Constructs the term <p>Case c of c1 | c2 .. | cn end *) -val mkMutCase : case_info -> constr -> constr -> constr list -> constr +val mkMutCase : case_info * constr * constr * constr list -> constr val mkMutCaseA : case_info -> constr -> constr -> constr array -> constr (* If [recindxs = [|i1,...in|]] @@ -238,7 +251,7 @@ val mkMutCaseA : case_info -> constr -> constr -> constr array -> constr [funnames = [f1,.....fn]] [bodies = [b1,.....bn]] then [ mkFix ((recindxs,i),typarray, funnames, bodies) ] - constructs the $i$th function of the block + constructs the $i$th function of the block (counting from 0) [Fixpoint f1 [ctx1] = b1 with f2 [ctx2] = b2 @@ -282,7 +295,7 @@ val destRel : constr -> int (* Destructs an existential variable *) val destMeta : constr -> int -val isMETA : constr -> bool +val isMeta : constr -> bool (* Destructs a variable *) val destVar : constr -> identifier @@ -330,6 +343,9 @@ val hd_is_constructor : constr -> bool (* Destructs the abstraction $[x:t_1]t_2$ *) val destLambda : constr -> name * constr * constr +(* Destructs the let $[x:=b:t_1]t_2$ *) +val destLetIn : constr -> name * constr * constr * constr + (* Destructs an application *) val destAppL : constr -> constr array val isAppL : constr -> bool @@ -339,6 +355,7 @@ val destApplication : constr -> constr * constr array (* Destructs a constant *) val destConst : constr -> section_path * constr array +val isConst : constr -> bool val path_of_const : constr -> section_path val args_of_const : constr -> constr array @@ -358,6 +375,7 @@ val args_of_mind : constr -> constr array (* Destructs a constructor *) val destMutConstruct : constr -> constructor +val isMutConstruct : constr -> bool val op_of_mconstr : constr -> constructor_path val args_of_mconstr : constr -> constr array @@ -541,6 +559,88 @@ val le_kind_implicit : constr -> constr -> bool val sort_hdchar : sorts -> string +(* Generic functions *) +val free_rels : constr -> Intset.t + +(* [closed0 M] is true iff [M] is a (deBruijn) closed term *) +val closed0 : constr -> bool + +(* [noccurn n M] returns true iff [Rel n] does NOT occur in term [M] *) +val noccurn : int -> constr -> bool + +(* [noccur_between n m M] returns true iff [Rel p] does NOT occur in term [M] + for n <= p < n+m *) +val noccur_between : int -> int -> constr -> bool + +(* Checking function for terms containing existential- or + meta-variables. The function [noccur_with_meta] considers only + meta-variable applied to some terms (intented to be its local + context) (for existential variables, it is necessarily the case) *) +val noccur_with_meta : int -> int -> constr -> bool + +(* [liftn n k c] lifts by [n] indexes above [k] in [c] *) +val liftn : int -> int -> constr -> constr + +(* [lift n c] lifts by [n] the positive indexes in [c] *) +val lift : int -> constr -> constr + +(* [pop c] lifts by -1 the positive indexes in [c] *) +val pop : constr -> constr + +(* [lift_context n ctxt] lifts terms in [ctxt] by [n] preserving + (i.e. not lifting) the internal references between terms of [ctxt]; + more recent terms come first in [ctxt] *) +val lift_context : int -> (name * constr) list -> (name * constr) list + +(* [substnl [a1;...;an] k c] substitutes in parallele [a1],...,[an] + for respectively [Rel(k+1)],...,[Rel(k+n)] in [c]; it relocates + accordingly indexes in [a1],...,[an] *) +val substnl : constr list -> int -> constr -> constr +val substl : constr list -> constr -> constr +val subst1 : constr -> constr -> constr + +(* [global_vars c] returns the list of [id]'s occurring as [VAR id] in [c] *) +val global_vars : constr -> identifier list + +val global_vars_set : constr -> Idset.t +val replace_vars : (identifier * constr) list -> constr -> constr +val subst_var : identifier -> constr -> constr + +(* [subst_vars [id1;...;idn] t] substitute [VAR idj] by [Rel j] in [t] + if two names are identical, the one of least indice is keeped *) +val subst_vars : identifier list -> constr -> constr + +(* [rel_list n m] and [rel_vect n m] compute [[Rel (n+m);...;Rel(n+1)]] *) +val rel_vect : int -> int -> constr array +val rel_list : int -> int -> constr list + +(*i************************************************************************i*) +(*i Pour Closure +(* Explicit substitutions of type ['a]. [ESID] = identity. + [CONS(t,S)] = $S.t$ i.e. parallel substitution. [SHIFT(n,S)] = + $(\uparrow n~o~S)$ i.e. terms in S are relocated with n vars. + [LIFT(n,S)] = $(\%n~S)$ stands for $((\uparrow n~o~S).n...1)$. *) +type 'a subs = + | ESID + | CONS of 'a * 'a subs + | SHIFT of int * 'a subs + | LIFT of int * 'a subs +val subs_cons : 'a * 'a subs -> 'a subs +val subs_liftn : int -> 'a subs -> 'a subs +val subs_lift : 'a subs -> 'a subs +val subs_shft : int * 'a subs -> 'a subs +val expand_rel : int -> 'a subs -> (int * 'a, int) union +i*) +(*s Lifts. [ELSHFT(l,n)] == lift of [n], then apply [lift l]. + [ELLFT(n,l)] == apply [l] to de Bruijn > [n] i.e under n binders. *) +type lift_spec = + | ELID + | ELSHFT of lift_spec * int + | ELLFT of int * lift_spec +val el_shft : int -> lift_spec -> lift_spec +val el_lift : lift_spec -> lift_spec +val reloc_rel: int -> lift_spec -> int +(*i*) (*s Occur check functions. *) @@ -550,7 +650,6 @@ val occur_meta : constr -> bool (*i val max_occur_meta : constr -> int i*) val occur_existential : constr -> bool -val rel_vect : int -> int -> constr array (* [(occur_const (s:section_path) c)] returns [true] if constant [s] occurs in c, [false] otherwise *) @@ -562,7 +661,7 @@ val occur_evar : existential_key -> constr -> bool (* [(occur_var id c)] returns [true] if variable [id] occurs free in c, [false] otherwise *) -val occur_var : identifier -> 'a term -> bool +val occur_var : identifier -> constr -> bool (* [dependent M N] is true iff M is eq\_constr with a subterm of N M is appropriately lifted through abstractions of N *) @@ -579,7 +678,6 @@ val eta_eq_constr : constr -> constr -> bool (*s The following functions substitutes [what] by [Rel 1] in [where] *) val subst_term : what:constr -> where:constr -> constr -val subst_term_eta_eq : what:constr -> where:constr -> constr val subst_term_occ : occs:int list -> what:constr -> where:constr -> constr val subst_term_occ_decl : occs:int list -> what:constr -> where:var_declaration -> var_declaration @@ -598,16 +696,26 @@ type constr_operator = | OpMeta of int | OpSort of sorts | OpRel of int | OpVar of identifier - | OpCast | OpProd of name | OpLambda of name + | OpCast | OpProd of name | OpLambda of name | OpLetIn of name | OpAppL | OpConst of section_path | OpAbst of section_path | OpEvar of existential_key | OpMutInd of inductive_path | OpMutConstruct of constructor_path | OpMutCase of case_info - | OpRec of fix_kind + | OpRec of fix_kind * Names.name list + +val splay_constr : constr -> constr_operator * constr array +val gather_constr : constr_operator * constr array -> constr + +val splay_constr_with_binders : constr -> + constr_operator * (name * constr option * constr) list * constr array +val gather_constr_with_binders : + constr_operator * (name * constr option * constr) list * constr array + -> constr -val splay_constr : constr -> constr_operator * constr list -val gather_constr : constr_operator * constr list -> constr +val generic_fold_left : + ('a -> constr -> 'a) -> 'a -> (name * constr option * constr) list + -> constr array -> 'a (*s Hash-consing functions for constr. *) diff --git a/kernel/type_errors.ml b/kernel/type_errors.ml index 518809392..34dee81c8 100644 --- a/kernel/type_errors.ml +++ b/kernel/type_errors.ml @@ -9,6 +9,24 @@ open Environ (* Type errors. *) +type guard_error = + (* Fixpoints *) + | NotEnoughAbstractionInFixBody + | RecursionNotOnInductiveType + | RecursionOnIllegalTerm + | NotEnoughArgumentsForFixCall + (* CoFixpoints *) + | CodomainNotInductiveType of constr + | NestedRecursiveOccurrences + | UnguardedRecursiveCall of constr + | RecCallInTypeOfAbstraction of constr + | RecCallInNonRecArgOfConstructor of constr + | RecCallInTypeOfDef of constr + | RecCallInCaseFun of constr + | RecCallInCaseArg of constr + | RecCallInCasePred of constr + | NotGuardedForm + type type_error = | UnboundRel of int | NotAType of unsafe_judgment @@ -24,7 +42,7 @@ type type_error = | CantApplyBadType of (int * constr * constr) * unsafe_judgment * unsafe_judgment list | CantApplyNonFunctional of unsafe_judgment * unsafe_judgment list - | IllFormedRecBody of std_ppcmds * name list * int * constr array + | IllFormedRecBody of guard_error * name list * int * constr array | IllTypedRecBody of int * name list * unsafe_judgment array * typed_type array | NotInductive of constr @@ -82,8 +100,8 @@ let error_cant_apply_not_functional k env rator randl = let error_cant_apply_bad_type k env sigma t rator randl = raise(TypeError (k, env_ise sigma env, CantApplyBadType (t,rator,randl))) -let error_ill_formed_rec_body k env str lna i vdefs = - raise (TypeError (k, env, IllFormedRecBody (str,lna,i,vdefs))) +let error_ill_formed_rec_body k env why lna i vdefs = + raise (TypeError (k, env, IllFormedRecBody (why,lna,i,vdefs))) let error_ill_typed_rec_body k env i lna vdefj vargs = raise (TypeError (k, env, IllTypedRecBody (i,lna,vdefj,vargs))) diff --git a/kernel/type_errors.mli b/kernel/type_errors.mli index 20fa410e4..f5e16f3c4 100644 --- a/kernel/type_errors.mli +++ b/kernel/type_errors.mli @@ -11,6 +11,26 @@ open Environ (* Type errors. \label{typeerrors} *) +(*i Rem: NotEnoughAbstractionInFixBody should only occur with "/i" Fix + notation i*) +type guard_error = + (* Fixpoints *) + | NotEnoughAbstractionInFixBody + | RecursionNotOnInductiveType + | RecursionOnIllegalTerm + | NotEnoughArgumentsForFixCall + (* CoFixpoints *) + | CodomainNotInductiveType of constr + | NestedRecursiveOccurrences + | UnguardedRecursiveCall of constr + | RecCallInTypeOfAbstraction of constr + | RecCallInNonRecArgOfConstructor of constr + | RecCallInTypeOfDef of constr + | RecCallInCaseFun of constr + | RecCallInCaseArg of constr + | RecCallInCasePred of constr + | NotGuardedForm + type type_error = | UnboundRel of int | NotAType of unsafe_judgment @@ -26,7 +46,7 @@ type type_error = | CantApplyBadType of (int * constr * constr) * unsafe_judgment * unsafe_judgment list | CantApplyNonFunctional of unsafe_judgment * unsafe_judgment list - | IllFormedRecBody of std_ppcmds * name list * int * constr array + | IllFormedRecBody of guard_error * name list * int * constr array | IllTypedRecBody of int * name list * unsafe_judgment array * typed_type array | NotInductive of constr @@ -80,8 +100,7 @@ val error_cant_apply_bad_type : unsafe_judgment -> unsafe_judgment list -> 'b val error_ill_formed_rec_body : - path_kind -> env -> std_ppcmds - -> name list -> int -> constr array -> 'b + path_kind -> env -> guard_error -> name list -> int -> constr array -> 'b val error_ill_typed_rec_body : path_kind -> env -> int -> name list -> unsafe_judgment array diff --git a/kernel/typeops.ml b/kernel/typeops.ml index 4077d852f..4b22b0b6a 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -5,7 +5,7 @@ open Pp open Util open Names open Univ -open Generic +(*i open Generic i*) open Term open Declarations open Sign @@ -113,17 +113,17 @@ let type_of_existential env sigma c = (* Case. *) let rec mysort_of_arity env sigma c = - match whd_betadeltaiota env sigma c with - | DOP0(Sort(s)) -> s - | DOP2(Prod,_,DLAM(_,c2)) -> mysort_of_arity env sigma c2 + match kind_of_term (whd_betadeltaiota env sigma c) with + | IsSort s -> s + | IsProd(_,_,c2) -> mysort_of_arity env sigma c2 | _ -> invalid_arg "mysort_of_arity" let error_elim_expln env sigma kp ki = - if is_info_sort env sigma kp && not (is_info_sort env sigma ki) then + if is_info_arity env sigma kp && not (is_info_arity env sigma ki) then "non-informative objects may not construct informative ones." else - match (kp,ki) with - | (DOP0(Sort (Type _)), DOP0(Sort (Prop _))) -> + match (kind_of_term kp,kind_of_term ki) with + | IsSort (Type _), IsSort (Prop _) -> "strong elimination on non-small inductive types leads to paradoxes." | _ -> "wrong arity" @@ -131,13 +131,15 @@ exception Arity of (constr * constr * string) option let is_correct_arity env sigma kelim (c,p) indf (pt,t) = let rec srec (pt,t) = - match whd_betadeltaiota env sigma pt, whd_betadeltaiota env sigma t with - | DOP2(Prod,a1,DLAM(_,a2)), DOP2(Prod,a1',DLAM(_,a2')) -> + let pt' = whd_betadeltaiota env sigma pt in + let t' = whd_betadeltaiota env sigma t in + match kind_of_term pt', kind_of_term t' with + | IsProd (_,a1,a2), IsProd (_,a1',a2') -> if is_conv env sigma a1 a1' then srec (a2,a2') else raise (Arity None) - | DOP2(Prod,a1,DLAM(_,a2)), ki -> + | IsProd (_,a1,a2), _ -> let k = whd_betadeltaiota env sigma a2 in let ksort = (match k with DOP0(Sort s) -> s | _ -> raise (Arity None)) in @@ -146,18 +148,18 @@ let is_correct_arity env sigma kelim (c,p) indf (pt,t) = if List.exists (base_sort_cmp CONV ksort) kelim then (true,k) else - raise (Arity (Some(k,ki,error_elim_expln env sigma k ki))) + raise (Arity (Some(k,t',error_elim_expln env sigma k t'))) else raise (Arity None) - | k, DOP2(Prod,_,_) -> + | k, IsProd (_,_,_) -> raise (Arity None) | k, ki -> - let ksort = (match k with DOP0(Sort s) -> s + let ksort = (match k with IsSort s -> s | _ -> raise (Arity None)) in if List.exists (base_sort_cmp CONV ksort) kelim then - false,k + false, pt' else - raise (Arity (Some(k,ki,error_elim_expln env sigma k ki))) + raise (Arity (Some(pt',t',error_elim_expln env sigma pt' t'))) in try srec (pt,t) with Arity kinds -> @@ -274,12 +276,13 @@ let typed_product env name var c = let rcst = ref Constraint.empty in let hacked_sort_of_product s1 s2 = let (s,cst) = sort_of_product s1 s2 (universes env) in (rcst:=cst; s) in - typed_combine (mkProd name) hacked_sort_of_product var c, !rcst + typed_combine (fun c t -> mkProd (name,c,t)) hacked_sort_of_product var c, + !rcst let abs_rel env sigma name var j = let cvar = incast_type var in let typ,cst = typed_product env name var j.uj_type in - { uj_val = mkLambda name cvar j.uj_val; + { uj_val = mkLambda (name, cvar, j.uj_val); uj_type = typ }, cst @@ -292,7 +295,7 @@ let gen_rel env sigma name varj j = let (s',g) = sort_of_product varj.utj_type s (universes env) in let res_type = mkSort s' in let (res_kind,g') = type_of_sort res_type in - { uj_val = mkProd name (incast_type var) j.uj_val; + { uj_val = mkProd (name, incast_type var, j.uj_val); uj_type = make_typed res_type res_kind }, g' | _ -> @@ -321,8 +324,8 @@ let apply_rel_list env sigma nocheck argjl funj = uj_type = typed_app (fun _ -> typ) funj.uj_type }, cst | hj::restjl -> - match whd_betadeltaiota env sigma typ with - | DOP2(Prod,c1,DLAM(_,c2)) -> + match kind_of_term (whd_betadeltaiota env sigma typ) with + | IsProd (_,c1,c2) -> if nocheck then apply_rec (n+1) (subst1 hj.uj_val c2) cst restjl else @@ -342,33 +345,6 @@ let apply_rel_list env sigma nocheck argjl funj = (* Fixpoints. *) -(* Checking function for terms containing existential variables. - The function [noccur_with_meta] considers the fact that - each existential variable (as well as each isevar) - in the term appears applied to its local context, - which may contain the CoFix variables. These occurrences of CoFix variables - are not considered *) - -exception Occur -let noccur_with_meta n m term = - let rec occur_rec n = function - | Rel p -> if n<=p & p<n+m then raise Occur - | VAR _ -> () - | DOPN(AppL,cl) -> - (match strip_outer_cast cl.(0) with - | DOP0 (Meta _) -> () - | _ -> Array.iter (occur_rec n) cl) - | DOPN(Evar _, _) -> () - | DOPN(op,cl) -> Array.iter (occur_rec n) cl - | DOPL(_,cl) -> List.iter (occur_rec n) cl - | DOP0(_) -> () - | DOP1(_,c) -> occur_rec n c - | DOP2(_,c1,c2) -> occur_rec n c1; occur_rec n c2 - | DLAM(_,c) -> occur_rec (n+1) c - | DLAMV(_,v) -> Array.iter (occur_rec (n+1)) v - in - try (occur_rec n term; true) with Occur -> false - (* Check if t is a subterm of Rel n, and gives its specification, assuming lst already gives index of subterms with corresponding specifications of recursive arguments *) @@ -396,17 +372,17 @@ let rec instantiate_recarg sp lrc ra = (* propagate checking for F,incorporating recursive arguments *) let check_term env mind_recvec f = let rec crec n l (lrec,c) = - match (lrec,strip_outer_cast c) with - | (Param(_)::lr,DOP2(Lambda,_,DLAM(_,b))) -> + match lrec, kind_of_term (strip_outer_cast c) with + | (Param(_)::lr, IsLambda (_,_,b)) -> let l' = map_lift_fst l in crec (n+1) l' (lr,b) - | (Norec::lr,DOP2(Lambda,_,DLAM(_,b))) -> + | (Norec::lr, IsLambda (_,_,b)) -> let l' = map_lift_fst l in crec (n+1) l' (lr,b) - | (Mrec(i)::lr,DOP2(Lambda,_,DLAM(_,b))) -> + | (Mrec(i)::lr, IsLambda (_,_,b)) -> let l' = map_lift_fst l in crec (n+1) ((1,mind_recvec.(i))::l') (lr,b) - | (Imbr((sp,i) as ind_sp,lrc)::lr,DOP2(Lambda,_,DLAM(_,b))) -> + | (Imbr((sp,i) as ind_sp,lrc)::lr, IsLambda (_,_,b)) -> let l' = map_lift_fst l in let sprecargs = mis_recargs (lookup_mind_specif (ind_sp,[||]) env) in @@ -414,7 +390,7 @@ let check_term env mind_recvec f = Array.map (List.map (instantiate_recarg sp lrc)) sprecargs.(i) in crec (n+1) ((1,lc)::l') (lr,b) - | _,f_0 -> f n l f_0 + | _,_ -> f n l (strip_outer_cast c) in crec @@ -425,28 +401,28 @@ let is_inst_var env sigma k c = let is_subterm_specif env sigma lcx mind_recvec = let rec crec n lst c = - match whd_betadeltaiota_stack env sigma c [] with - | ((Rel k),_) -> find_sorted_assoc k lst - | (DOPN(MutCase _,_) as x,_) -> - let ( _,_,c,br) = destCase x in - if Array.length br = 0 then - [||] - else - let lcv = - (try - if is_inst_var env sigma n c then lcx else (crec n lst c) - with Not_found -> (Array.create (Array.length br) [])) - in - assert (Array.length br = Array.length lcv); - let stl = - array_map2 - (fun lc a -> - check_term env mind_recvec crec n lst (lc,a)) lcv br - in - stl.(0) + let f,l = whd_betadeltaiota_stack env sigma c [] in + match kind_of_term f with + | IsRel k -> find_sorted_assoc k lst + + | IsMutCase ( _,_,c,br) -> + if Array.length br = 0 then + [||] + else + let lcv = + (try + if is_inst_var env sigma n c then lcx else (crec n lst c) + with Not_found -> (Array.create (Array.length br) [])) + in + assert (Array.length br = Array.length lcv); + let stl = + array_map2 + (fun lc a -> + check_term env mind_recvec crec n lst (lc,a)) lcv br + in + stl.(0) - | (DOPN(Fix(_),la) as mc,l) -> - let ((recindxs,i),(typarray,funnames,bodies)) = destFix mc in + | IsFix ((recindxs,i),(typarray,funnames,bodies)) -> let nbfix = List.length funnames in let decrArg = recindxs.(i) in let theBody = bodies.(i) in @@ -470,12 +446,12 @@ let is_subterm_specif env sigma lcx mind_recvec = in crec (n+nbOfAbst) newlst strippedBody - | (DOP2(Lambda,_,DLAM(_,b)),[]) -> - let lst' = map_lift_fst lst in - crec (n+1) lst' b + | IsLambda (_,_,b) when l=[] -> + let lst' = map_lift_fst lst in + crec (n+1) lst' b (*** Experimental change *************************) - | (DOP0(Meta _),_) -> [||] + | IsMeta _ -> [||] | _ -> raise Not_found in crec @@ -486,26 +462,29 @@ let is_subterm env sigma lcx mind_recvec n lst c = with Not_found -> false +exception FixGuardError of guard_error + (* Auxiliary function: it checks a condition f depending on a deBrujin index for a certain number of abstractions *) -let rec check_subterm_rec_meta env sigma vectn k def = +let rec check_subterm_rec_meta env sigma vectn k def = + (* If k<0, it is a general fixpoint *) (k < 0) or (let nfi = Array.length vectn in (* check fi does not appear in the k+1 first abstractions, gives the type of the k+1-eme abstraction *) let rec check_occur n def = - (match strip_outer_cast def with - | DOP2(Lambda,a,DLAM(_,b)) -> - if noccur_with_meta n nfi a then - if n = k+1 then (a,b) else check_occur (n+1) b - else - error "Bad occurrence of recursive call" - | _ -> error "Not enough abstractions in the definition") in + match kind_of_term (strip_outer_cast def) with + | IsLambda (_,a,b) -> + if noccur_with_meta n nfi a then + if n = k+1 then (a,b) else check_occur (n+1) b + else + anomaly "check_subterm_rec_meta: Bad occurrence of recursive call" + | _ -> raise (FixGuardError NotEnoughAbstractionInFixBody) in let (c,d) = check_occur 1 def in let ((sp,tyi),_ as mind, largs) = - (try find_minductype env sigma c - with Induc -> error "Recursive definition on a non inductive type") in + try find_minductype env sigma c + with Induc -> raise (FixGuardError RecursionNotOnInductiveType) in let mind_recvec = mis_recargs (lookup_mind_specif mind env) in let lcx = mind_recvec.(tyi) in (* n = decreasing argument in the definition; @@ -516,8 +495,9 @@ let rec check_subterm_rec_meta env sigma vectn k def = (* n gives the index of the recursive variable *) (noccur_with_meta (n+k+1) nfi t) or (* no recursive call in the term *) - (match whd_betadeltaiota_stack env sigma t [] with - | (Rel p,l) -> + (let f,l = whd_betadeltaiota_stack env sigma t [] in + match kind_of_term f with + | IsRel p -> if n+k+1 <= p & p < n+k+nfi+1 then (* recursive call *) let glob = nfi+n+k-p in (* the index of the recursive call *) @@ -527,12 +507,12 @@ let rec check_subterm_rec_meta env sigma vectn k def = (la,(z::lrest)) -> if (is_subterm env sigma lcx mind_recvec n lst z) then List.for_all (check_rec_call n lst) (la@lrest) - else error "Recursive call applied to an illegal term" + else raise (FixGuardError RecursionOnIllegalTerm) | _ -> assert false) - else error "Not enough arguments for the recursive call" + else raise (FixGuardError NotEnoughArgumentsForFixCall) else List.for_all (check_rec_call n lst) l - | (DOPN(MutCase _,_) as mc,l) -> - let (ci,p,c_0,lrest) = destCase mc in + + | IsMutCase (ci,p,c_0,lrest) -> let lc = (try if is_inst_var env sigma n c_0 then @@ -563,13 +543,16 @@ let rec check_subterm_rec_meta env sigma vectn k def = Eduardo 7/9/98 *) - | (DOPN(Fix(_),la) as mc,l) -> + | IsFix ((recindxs,i),(typarray,funnames,bodies)) -> (List.for_all (check_rec_call n lst) l) && - let ((recindxs,i),(typarray,funnames,bodies)) = destFix mc in let nbfix = List.length funnames in let decrArg = recindxs.(i) in if (List.length l < (decrArg+1)) then - (array_for_all (check_rec_call n lst) la) + (array_for_all (check_rec_call n lst) typarray) + && + (array_for_all + (check_rec_call (n+nbfix) (map_lift_fst_n nbfix lst)) + bodies) else let theDecrArg = List.nth l decrArg in let recArgsDecrArg = @@ -579,7 +562,11 @@ let rec check_subterm_rec_meta env sigma vectn k def = Array.create 0 [] in if (Array.length recArgsDecrArg)=0 then - array_for_all (check_rec_call n lst) la + (array_for_all (check_rec_call n lst) typarray) + && + (array_for_all + (check_rec_call (n+nbfix) (map_lift_fst_n nbfix lst)) + bodies) else let theBody = bodies.(i) in let (gamma,strippedBody) = @@ -594,29 +581,63 @@ let rec check_subterm_rec_meta env sigma vectn k def = typarray) && (list_for_all_i (fun n -> check_rec_call n lst) n absTypes) & (check_rec_call (n+nbOfAbst) newlst strippedBody)) - - - | (DOP2(_,a,b),l) -> + + | IsCast (a,b) -> (check_rec_call n lst a) && (check_rec_call n lst b) && (List.for_all (check_rec_call n lst) l) - | (DOPN(_,la),l) -> - (array_for_all (check_rec_call n lst) la) && - (List.for_all (check_rec_call n lst) l) + | IsLambda (_,a,b) -> + (check_rec_call n lst a) && + (check_rec_call (n+1) (map_lift_fst lst) b) && + (List.for_all (check_rec_call n lst) l) + + | IsProd (_,a,b) -> + (check_rec_call n lst a) && + (check_rec_call (n+1) (map_lift_fst lst) b) && + (List.for_all (check_rec_call n lst) l) - | (DOP0 (Meta _),l) -> true + | IsLetIn (_,a,b,c) -> + (check_rec_call n lst a) && + (check_rec_call n lst b) && + (check_rec_call (n+1) (map_lift_fst lst) c) && + (List.for_all (check_rec_call n lst) l) - | (DLAM(_,t),l) -> - (check_rec_call (n+1) (map_lift_fst lst) t) && + | IsMutInd (_,la) -> + (array_for_all (check_rec_call n lst) la) && (List.for_all (check_rec_call n lst) l) - | (DLAMV(_,vt),l) -> - (array_for_all (check_rec_call (n+1) (map_lift_fst lst)) vt) && + | IsMutConstruct (_,la) -> + (array_for_all (check_rec_call n lst) la) && (List.for_all (check_rec_call n lst) l) - | (_,l) -> List.for_all (check_rec_call n lst) l - ) + | IsConst (_,la) -> + (array_for_all (check_rec_call n lst) la) && + (List.for_all (check_rec_call n lst) l) + + | IsAppL (f,la) -> + (check_rec_call n lst f) && + (List.for_all (check_rec_call n lst) la) && + (List.for_all (check_rec_call n lst) l) + + | IsCoFix (i,(typarray,funnames,bodies)) -> + let nbfix = Array.length bodies in + (array_for_all (check_rec_call n lst) typarray) && + (List.for_all (check_rec_call n lst) l) && + (array_for_all + (check_rec_call (n+nbfix) (map_lift_fst_n nbfix lst)) + bodies) + + | IsEvar (_,la) -> + (array_for_all (check_rec_call n lst) la) && + (List.for_all (check_rec_call n lst) l) + + | IsMeta _ -> true + + | IsVar _ | IsSort _ -> List.for_all (check_rec_call n lst) l + + | IsXtra _ | IsAbst _ -> List.for_all (check_rec_call n lst) l + ) in check_rec_call 1 [] d) @@ -633,25 +654,30 @@ let check_fix env sigma ((nvect,bodynum),(types,names,bodies)) = or Array.length nvect <> nbfix or Array.length types <> nbfix or List.length names <> nbfix - then error "Ill-formed fix term"; + or bodynum < 0 + or bodynum >= nbfix + then anomaly "Ill-formed fix term"; for i = 0 to nbfix - 1 do try let _ = check_subterm_rec_meta env sigma nvect nvect.(i) bodies.(i) in () - with UserError (s,str) -> - error_ill_formed_rec_body CCI env str (List.rev names) i bodies + with FixGuardError err -> + error_ill_formed_rec_body CCI env err (List.rev names) i bodies done (* Co-fixpoints. *) +exception CoFixGuardError of guard_error + let check_guard_rec_meta env sigma nbfix def deftype = let rec codomain_is_coind c = - match whd_betadeltaiota env sigma (strip_outer_cast c) with - | DOP2(Prod,a,DLAM(_,b)) -> codomain_is_coind b - | b -> - (try find_mcoinductype env sigma b - with - | Induc -> error "The codomain is not a coinductive type" -(* | _ -> error "Type of Cofix function not as expected") ??? *) ) + let b = whd_betadeltaiota env sigma (strip_outer_cast c) in + match kind_of_term b with + | IsProd (_,a,b) -> codomain_is_coind b + | _ -> + try + find_mcoinductype env sigma b + with Induc -> + raise (CoFixGuardError (CodomainNotInductiveType b)) in let (mind, _) = codomain_is_coind deftype in let ((sp,tyi),_) = mind in @@ -671,11 +697,11 @@ let check_guard_rec_meta env sigma nbfix def deftype = if List.for_all (noccur_with_meta n nbfix) l then true else - error "Nested recursive occurrences" + raise (CoFixGuardError NestedRecursiveOccurrences) else - error "Unguarded recursive call" + raise (CoFixGuardError (UnguardedRecursiveCall t)) else - error "check_guard_rec_meta: ???" + error "check_guard_rec_meta: ???" (* ??? *) | (DOPN (MutConstruct(_,i as cstr_sp),l), args) -> let lra =vlra.(i-1) in @@ -710,7 +736,8 @@ let check_guard_rec_meta env sigma nbfix def deftype = | _::lrar -> if (noccur_with_meta n nbfix t) then (process_args_of_constr lr lrar) - else error "Recursive call inside a non-recursive argument of constructor") + else raise (CoFixGuardError + (RecCallInNonRecArgOfConstructor t))) in (process_args_of_constr realargs lra) @@ -718,7 +745,7 @@ let check_guard_rec_meta env sigma nbfix def deftype = if (noccur_with_meta n nbfix a) then check_rec_call alreadygrd (n+1) vlra b else - error "Recursive call in the type of an abstraction" + raise (CoFixGuardError (RecCallInTypeOfAbstraction t)) | (DOPN(CoFix(j),vargs) as cofix,l) -> if (List.for_all (noccur_with_meta n nbfix) l) @@ -730,8 +757,9 @@ let check_guard_rec_meta env sigma nbfix def deftype = && (List.for_all (check_rec_call alreadygrd (n+1) vlra) l) else - error "Recursive call in the type of a declaration" - else error "Unguarded recursive call" + raise (CoFixGuardError (RecCallInTypeOfDef cofix)) + else + raise (CoFixGuardError (UnguardedRecursiveCall cofix)) | (DOPN(MutCase _,_) as mc,l) -> let (_,p,c,vrest) = destCase mc in @@ -740,13 +768,13 @@ let check_guard_rec_meta env sigma nbfix def deftype = if (List.for_all (noccur_with_meta n nbfix) l) then (array_for_all (check_rec_call alreadygrd n vlra) vrest) else - error "Recursive call in the argument of a function defined by cases" + raise (CoFixGuardError (RecCallInCaseFun mc)) else - error "Recursive call in the argument of a case expression" + raise (CoFixGuardError (RecCallInCaseArg mc)) else - error "Recursive call in the type of a Case expression" + raise (CoFixGuardError (RecCallInCasePred mc)) - | _ -> error "Definition not in guarded form" + | _ -> raise (CoFixGuardError NotGuardedForm) in check_rec_call false 1 vlra def @@ -758,11 +786,9 @@ let check_cofix env sigma (bodynum,(types,names,bodies)) = let nbfix = Array.length bodies in for i = 0 to nbfix-1 do try - let _ = - check_guard_rec_meta env sigma nbfix bodies.(i) types.(i) in - () - with UserError (s,str) -> - error_ill_formed_rec_body CCI env str (List.rev names) i bodies + let _ = check_guard_rec_meta env sigma nbfix bodies.(i) types.(i) in () + with CoFixGuardError err -> + error_ill_formed_rec_body CCI env err (List.rev names) i bodies done (* let check_cofix env sigma f = @@ -814,22 +840,28 @@ let type_fixpoint env sigma lna lar vdefj = syntaxic conditions *) let control_only_guard env sigma = - let rec control_rec = function - | Rel(p) -> () - | VAR _ -> () - | DOP0(_) -> () - | DOPN(CoFix(_),cl) as cofix -> - check_cofix env sigma (destCoFix cofix); - Array.iter control_rec cl - | DOPN(Fix(_),cl) as fix -> - check_fix env sigma (destFix fix); - Array.iter control_rec cl - | DOPN(_,cl) -> Array.iter control_rec cl - | DOPL(_,cl) -> List.iter control_rec cl - | DOP1(_,c) -> control_rec c - | DOP2(_,c1,c2) -> control_rec c1; control_rec c2 - | DLAM(_,c) -> control_rec c - | DLAMV(_,v) -> Array.iter control_rec v + let rec control_rec c = match kind_of_term c with + | IsRel _ | IsVar _ -> () + | IsSort _ | IsMeta _ | IsXtra _ -> () + | IsCoFix (_,(tys,_,bds) as cofix) -> + check_cofix env sigma cofix; + Array.iter control_rec tys; + Array.iter control_rec bds; + | IsFix (_,(tys,_,bds) as fix) -> + check_fix env sigma fix; + Array.iter control_rec tys; + Array.iter control_rec bds; + | IsMutCase(_,p,c,b) ->control_rec p;control_rec c;Array.iter control_rec b + | IsMutInd (_,cl) -> Array.iter control_rec cl + | IsMutConstruct (_,cl) -> Array.iter control_rec cl + | IsConst (_,cl) -> Array.iter control_rec cl + | IsEvar (_,cl) -> Array.iter control_rec cl + | IsAbst (_,cl) -> Array.iter control_rec cl + | IsAppL (_,cl) -> List.iter control_rec cl + | IsCast (c1,c2) -> control_rec c1; control_rec c2 + | IsProd (_,c1,c2) -> control_rec c1; control_rec c2 + | IsLambda (_,c1,c2) -> control_rec c1; control_rec c2 + | IsLetIn (_,c1,c2,c3) -> control_rec c1; control_rec c2; control_rec c3 in control_rec diff --git a/library/declare.ml b/library/declare.ml index 404ecda31..9f98f3cb5 100644 --- a/library/declare.ml +++ b/library/declare.ml @@ -4,7 +4,7 @@ open Pp open Util open Names -open Generic +(*i open Generic i*) open Term open Sign open Declarations diff --git a/library/global.ml b/library/global.ml index a37863a78..741d11e75 100644 --- a/library/global.ml +++ b/library/global.ml @@ -2,7 +2,7 @@ (* $Id$ *) open Util -open Generic +(*i open Generic i*) open Term open Instantiate open Sign diff --git a/library/impargs.ml b/library/impargs.ml index bae96bc14..3af4ecbec 100644 --- a/library/impargs.ml +++ b/library/impargs.ml @@ -2,7 +2,7 @@ (* $Id$ *) open Names -open Generic +(*i open Generic i*) open Term open Reduction open Declarations diff --git a/library/indrec.ml b/library/indrec.ml index 42d067d49..c89578735 100644 --- a/library/indrec.ml +++ b/library/indrec.ml @@ -4,7 +4,7 @@ open Pp open Util open Names -open Generic +(*i open Generic i*) open Term open Declarations open Inductive @@ -15,8 +15,7 @@ open Typeops open Type_errors open Indtypes (* pour les erreurs *) -let simple_prod (n,t,c) = mkProd n t c -let make_prod_dep dep env = if dep then prod_name env else simple_prod +let make_prod_dep dep env = if dep then prod_name env else mkProd (*******************************************) (* Building curryfied elimination *) @@ -94,9 +93,10 @@ let type_rec_branch dep env sigma (vargs,depPvect,decP) co t recargs = let st = hnf_prod_appvect env sigma t vargs in let process_pos depK pk = let rec prec i p = - match whd_betadeltaiota_stack env sigma p [] with - | (DOP2(Prod,t,DLAM(n,c))),[] -> make_prod env (n,t,prec (i+1) c) - | (DOPN(MutInd _,_),largs) -> + let p',largs = whd_betadeltaiota_stack env sigma p [] in + match kind_of_term p' with + | IsProd (n,t,c) -> assert (largs=[]); make_prod env (n,t,prec (i+1) c) + | IsMutInd (_,_) -> let (_,realargs) = list_chop nparams largs in let base = applist (lift i pk,realargs) in if depK then @@ -108,8 +108,10 @@ let type_rec_branch dep env sigma (vargs,depPvect,decP) co t recargs = prec 0 in let rec process_constr i c recargs co = - match whd_betadeltaiota_stack env sigma c [] with - | (DOP2(Prod,t,DLAM(n,c_0)),[]) -> + let c', largs = whd_betadeltaiota_stack env sigma c [] in + match kind_of_term c' with + | IsProd (n,t,c_0) -> + assert (largs = []); let (optionpos,rest) = match recargs with | [] -> None,[] @@ -129,7 +131,7 @@ let type_rec_branch dep env sigma (vargs,depPvect,decP) co t recargs = make_prod_dep (dep or dep') env (n,t,mkArrow t_0 (process_constr (i+2) (lift 1 c_0) rest (mkAppList (lift 2 co) [Rel 2])))) - | (DOPN(MutInd(_,tyi),_),largs) -> + | IsMutInd ((_,tyi),_) -> let nP = match depPvect.(tyi) with | Some(_,p) -> lift (i+decP) p | _ -> assert false in @@ -142,14 +144,15 @@ let type_rec_branch dep env sigma (vargs,depPvect,decP) co t recargs = let make_rec_branch_arg env sigma (nparams,fvect,decF) f cstr recargs = let process_pos fk = - let rec prec i p = - (match whd_betadeltaiota_stack env sigma p [] with - | (DOP2(Prod,t,DLAM(n,c))),[] -> lambda_name env (n,t,prec (i+1) c) - | (DOPN(MutInd _,_),largs) -> - let (_,realargs) = list_chop nparams largs - and arg = appvect (Rel (i+1),rel_vect 0 i) in - applist(lift i fk,realargs@[arg]) - | _ -> assert false) + let rec prec i p = + let p',largs = whd_betadeltaiota_stack env sigma p [] in + match kind_of_term p' with + | IsProd (n,t,c) -> lambda_name env (n,t,prec (i+1) c) + | IsMutInd _ -> + let (_,realargs) = list_chop nparams largs + and arg = appvect (Rel (i+1),rel_vect 0 i) in + applist(lift i fk,realargs@[arg]) + | _ -> assert false in prec 0 in @@ -315,10 +318,10 @@ let make_case_gen env = make_case_com None env [rec] by [s] *) let change_sort_arity sort = - let rec drec = function - | (DOP2(Cast,c,t)) -> drec c - | (DOP2(Prod,t,DLAM(n,c))) -> DOP2(Prod,t,DLAM(n,drec c)) - | (DOP0(Sort(_))) -> DOP0(Sort(sort)) + let rec drec a = match kind_of_term a with + | IsCast (c,t) -> drec c + | IsProd (n,t,c) -> mkProd (n, t, drec c) + | IsSort _ -> mkSort sort | _ -> assert false in drec @@ -327,9 +330,9 @@ let instanciate_indrec_scheme sort = let rec drec npar elim = let (n,t,c) = destLambda (strip_outer_cast elim) in if npar = 0 then - mkLambda n (change_sort_arity sort t) c + mkLambda (n, change_sort_arity sort t, c) else - mkLambda n t (drec (npar-1) c) + mkLambda (n, t, drec (npar-1) c) in drec diff --git a/parsing/astterm.ml b/parsing/astterm.ml index 853798dab..5415d819c 100644 --- a/parsing/astterm.ml +++ b/parsing/astterm.ml @@ -5,7 +5,7 @@ open Pp open Util open Names open Sign -open Generic +(*i open Generic i*) open Term open Environ open Evd @@ -278,17 +278,6 @@ let dbize k sigma env allow_soapp lvar = let rec dbrec env = function | Nvar(loc,s) -> fst (dbize_ref k sigma env loc s lvar) - (* - | Slam(_,ona,Node(_,"V$",l)) -> - let na = - (match ona with Some s -> Name (id_of_string s) | _ -> Anonymous) - in DLAMV(na,Array.of_list (List.map (dbrec (Idset.add na env)) l)) - - | Slam(_,ona,t) -> - let na = - (match ona with Some s -> Name (id_of_string s) | _ -> Anonymous) - in DLAM(na, dbrec (Idset.add na env) t) - *) | Node(loc,"FIX", (Nvar (locid,iddef))::ldecl) -> let (lf,ln,lA,lt) = dbize_fix ldecl in let n = @@ -313,13 +302,17 @@ let dbize k sigma env allow_soapp lvar = List.fold_left (fun env fid -> Idset.add fid env) env lf in let defl = Array.of_list (List.map (dbrec ext_env) lt) in let arityl = Array.of_list (List.map (dbrec env) lA) in - RRec (loc,RCofix n, Array.of_list lf, arityl, defl) + RRec (loc,RCoFix n, Array.of_list lf, arityl, defl) - | Node(loc,("PROD"|"LAMBDA" as k), [c1;Slam(_,ona,c2)]) -> + | Node(loc,("PROD"|"LAMBDA"|"LETIN" as k), [c1;Slam(_,ona,c2)]) -> let na,env' = match ona with | Some s -> let id = id_of_string s in Name id, Idset.add id env | _ -> Anonymous, env in - let kind = if k="PROD" then BProd else BLambda in + let kind = match k with + | "PROD" -> BProd + | "LAMBDA" -> BLambda + | "LETIN" -> BLetIn + | _ -> assert false in RBinder(loc, kind, na, dbrec env c1, dbrec env' c2) | Node(_,"PRODLIST", [c1;(Slam _ as c2)]) -> @@ -401,12 +394,12 @@ let dbize k sigma env allow_soapp lvar = | Slam(loc,ona,body) -> let na,env' = match ona with | Some s -> - check_capture s ty body; + if n>0 then check_capture s ty body; let id = id_of_string s in Name id, Idset.add id env | _ -> Anonymous, env in RBinder(loc, oper, na, dbrec env ty, - (iterated_binder oper n ty env' body)) + (iterated_binder oper (n+1) ty env' body)) | body -> dbrec env body and dbize_args env l args = diff --git a/parsing/g_basevernac.ml4 b/parsing/g_basevernac.ml4 index b8534a873..03af08edc 100644 --- a/parsing/g_basevernac.ml4 +++ b/parsing/g_basevernac.ml4 @@ -77,16 +77,19 @@ GEXTEND Gram <:ast< (LocateLibrary $id) >> | IDENT "Locate"; id = identarg; "." -> <:ast< (Locate $id) >> - | IDENT "Print"; IDENT "LoadPath"; "." -> <:ast< (PrintPath) >> + + (* For compatibility (now turned into a table) *) | IDENT "AddPath"; dir = stringarg; "." -> <:ast< (ADDPATH $dir) >> | IDENT "DelPath"; dir = stringarg; "." -> <:ast< (DELPATH $dir) >> + | IDENT "Print"; IDENT "LoadPath"; "." -> <:ast< (PrintPath) >> | IDENT "AddRecPath"; dir = stringarg; "." -> <:ast< (RECADDPATH $dir) >> + | IDENT "Print"; IDENT "Modules"; "." -> <:ast< (PrintModules) >> | IDENT "Print"; "Proof"; id = identarg; "." -> <:ast< (PrintOpaqueId $id) >> -(* Pris en compte dans PrintOption ci-dessous - | IDENT "Print"; id = identarg; "." -> <:ast< (PrintId $id) >> *) +(* Pris en compte dans PrintOption ci-dessous (CADUC) *) + | IDENT "Print"; id = identarg; "." -> <:ast< (PrintId $id) >> | IDENT "Search"; id = identarg; "." -> <:ast< (SEARCH $id) >> | IDENT "Inspect"; n = numarg; "." -> <:ast< (INSPECT $n) >> (* TODO: rapprocher Eval et Check *) @@ -110,7 +113,7 @@ GEXTEND Gram | IDENT "Print"; IDENT "Graph"; "." -> <:ast< (PrintGRAPH) >> | IDENT "Print"; IDENT "Classes"; "." -> <:ast< (PrintCLASSES) >> | IDENT "Print"; IDENT "Coercions"; "." -> <:ast< (PrintCOERCIONS) >> - | IDENT "Print"; IDENT "Path"; c = identarg; d = identarg; "." -> + | IDENT "Print"; IDENT "Coercion"; IDENT "Paths"; c = identarg; d = identarg; "." -> <:ast< (PrintPATH $c $d) >> | IDENT "Time"; v = vernac -> <:ast< (Time $v)>> @@ -138,22 +141,35 @@ GEXTEND Gram <:ast< (SetTableField $table) >> | IDENT "Unset"; table = identarg; "." -> <:ast< (UnsetTableField $table) >> - | IDENT "Print"; table = identarg; field = identarg; "." -> + | IDENT "Print"; IDENT "Table"; + table = identarg; field = identarg; "." -> <:ast< (PrintOption $table $field) >> (* Le cas suivant inclut aussi le "Print id" standard *) - | IDENT "Print"; table = identarg; "." -> + | IDENT "Print"; IDENT "Table"; table = identarg; "." -> <:ast< (PrintOption $table) >> | IDENT "Add"; table = identarg; field = identarg; id = identarg; "." -> <:ast< (AddTableField $table $field $id) >> + | IDENT "Add"; table = identarg; field = identarg; id = stringarg; "." + -> <:ast< (AddTableField $table $field $id) >> | IDENT "Add"; table = identarg; id = identarg; "." -> <:ast< (AddTableField $table $id) >> + | IDENT "Add"; table = identarg; id = stringarg; "." + -> <:ast< (AddTableField $table $id) >> | IDENT "Test"; table = identarg; field = identarg; id = identarg; "." -> <:ast< (MemTableField $table $field $id) >> + | IDENT "Test"; table = identarg; field = identarg; id = stringarg; "." + -> <:ast< (MemTableField $table $field $id) >> | IDENT "Test"; table = identarg; id = identarg; "." -> <:ast< (MemTableField $table $id) >> + | IDENT "Test"; table = identarg; id = stringarg; "." + -> <:ast< (MemTableField $table $id) >> | IDENT "Remove"; table = identarg; field = identarg; id = identarg; "." -> <:ast< (RemoveTableField $table $field $id) >> + | IDENT "Remove"; table = identarg; field = identarg; id = stringarg; "." -> + <:ast< (RemoveTableField $table $field $id) >> | IDENT "Remove"; table = identarg; id = identarg; "." -> + <:ast< (RemoveTableField $table $id) >> + | IDENT "Remove"; table = identarg; id = stringarg; "." -> <:ast< (RemoveTableField $table $id) >> ] ] ; option_value: diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index d685b292a..2a7f5ac8e 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -84,8 +84,9 @@ GEXTEND Gram c = constr; "in"; c1 = constr -> <:ast< (CASE "NOREC" "SYNTH" $c (LAMBDALIST (ISEVAR) ($SLAM $b $c1))) >> - | IDENT "let"; id1 = IDENT ; "="; c = constr; "in"; - c1 = constr -> <:ast< (ABST #Core#let.cci $c [$id1]$c1) >> + | IDENT "let"; id1 = IDENT ; "="; c = constr; "in"; c1 = constr -> + <:ast< (LETIN $c [$id1]$c1) >> +(* <:ast< (ABST #Core#let.cci $c [$id1]$c1) >>*) | IDENT "if"; c1 = constr; IDENT "then"; c2 = constr; IDENT "else"; c3 = constr -> <:ast< ( CASE "NOREC" "SYNTH" $c1 $c2 $c3) >> @@ -141,11 +142,13 @@ GEXTEND Gram [ [ ","; idl = ne_ident_comma_list -> idl | -> [] ] ] ; - vardecls: + vardecls: (* This is interpreted by Pcoq.abstract_binder *) [ [ id = ident; idl = ident_comma_list_tail; c = type_option -> <:ast< (BINDER $c $id ($LIST $idl)) >> + | id = ident; ":="; c = constr -> + <:ast< (LETIN $c $id) >> | id = ident; "="; c = constr -> - <:ast< (ABST #Core#let.cci $c $id) >> ] ] + <:ast< (LETIN $c $id) >> ] ] ; ne_vardecls_list: [ [ id = vardecls; ";"; idl = ne_vardecls_list -> id :: idl diff --git a/parsing/pattern.ml b/parsing/pattern.ml index e3fa611ed..ff747d4e3 100644 --- a/parsing/pattern.ml +++ b/parsing/pattern.ml @@ -2,7 +2,7 @@ (* $Id$ *) open Util -open Generic +(*i open Generic i*) open Names open Term open Reduction @@ -14,7 +14,6 @@ type constr_pattern = | PApp of constr_pattern * constr_pattern array | PSoApp of int * constr_pattern list | PBinder of binder_kind * name * constr_pattern * constr_pattern - | PLet of identifier * constr_pattern * constr_pattern * constr_pattern | PSort of rawsort | PMeta of int option | PCase of constr_pattern option * constr_pattern * constr_pattern array @@ -32,9 +31,6 @@ let rec occur_meta_pattern = function | PCase(Some p,c,br) -> (occur_meta_pattern p) or (occur_meta_pattern c) or (array_exists occur_meta_pattern br) - | PLet(id,a,t,c) -> - (occur_meta_pattern a) or (occur_meta_pattern t) - or (occur_meta_pattern c) | PMeta _ | PSoApp _ -> true | PRel _ | PSort _ -> false @@ -62,10 +58,9 @@ let label_of_ref = function let rec head_pattern_bound t = match t with - | PBinder (BProd,_,_,b) -> head_pattern_bound b + | PBinder ((BProd|BLetIn),_,_,b) -> head_pattern_bound b | PApp (c,args) -> head_pattern_bound c | PCase (p,c,br) -> head_pattern_bound c - | PLet (id,a,t,c) -> head_pattern_bound c | PRef r -> label_of_ref r | PRel _ | PMeta _ | PSoApp _ | PSort _ -> raise BoundPattern | PBinder(BLambda,_,_,_) -> anomaly "head_pattern_bound: not a type" @@ -96,7 +91,7 @@ let head_of_constr_reference = function When we reach a second-order application, we ask that the intersection of the free-rels of the term and the current stack be contained in the arguments of the application, and in that case, we - construct a DLAM with the names on the stack. + construct a LAMBDA with the names on the stack. *) @@ -109,12 +104,12 @@ let constrain ((n : int),(m : constr)) sigma = else (n,m)::sigma -let build_dlam toabstract stk (m : constr) = +let build_lambda toabstract stk (m : constr) = let rec buildrec m p_0 p_1 = match p_0,p_1 with | (_, []) -> m - | (n, (na::tl)) -> + | (n, (na,t)::tl) -> if List.mem n toabstract then - buildrec (DLAM(na,m)) (n+1) tl + buildrec (mkLambda (na,t,m)) (n+1) tl else buildrec (pop m) (n+1) tl in @@ -140,7 +135,7 @@ let matches_core convert pat c = args in let frels = Intset.elements (free_rels cT) in if list_subset frels relargs then - constrain (n,build_dlam relargs stk cT) sigma + constrain (n,build_lambda relargs stk cT) sigma else raise PatternMatchingFailure @@ -176,10 +171,13 @@ let matches_core convert pat c = arg1 (Array.of_list arg2) | PBinder(BProd,na1,c1,d1), IsProd(na2,c2,d2) -> - sorec (na2::stk) (sorec stk sigma c1 c2) d1 d2 + sorec ((na2,c2)::stk) (sorec stk sigma c1 c2) d1 d2 | PBinder(BLambda,na1,c1,d1), IsLambda(na2,c2,d2) -> - sorec (na2::stk) (sorec stk sigma c1 c2) d1 d2 + sorec ((na2,c2)::stk) (sorec stk sigma c1 c2) d1 d2 + + | PBinder(BLetIn,na1,c1,d1), IsLetIn(na2,c2,t2,d2) -> + sorec ((na2,t2)::stk) (sorec stk sigma c1 c2) d1 d2 | PRef (RConst (sp1,ctxt1)), IsConst (sp2,ctxt2) when sp1 = sp2 && eq_context ctxt1 ctxt2 -> sigma @@ -194,7 +192,7 @@ let matches_core convert pat c = array_fold_left2 (sorec stk) (sorec stk sigma a1 a2) br1 br2 - | (PLet _,_) | _,(IsFix _ | IsCoFix _) -> + | _,(IsFix _ | IsCoFix _) -> error "somatch: not implemented" | _ -> raise PatternMatchingFailure @@ -222,45 +220,57 @@ let rec try_matches nocc pat = function (* Tries to match a subterm of [c] with [pat] *) let rec sub_match nocc pat c = - match c with - | DOP2 (Cast,c1,c2) -> + match kind_of_term c with + | IsCast (c1,c2) -> (try authorized_occ nocc ((matches pat c),DOP0 (Meta (-1))) with | PatternMatchingFailure -> let (lm,lc) = try_sub_match nocc pat [c1] in - (lm,DOP2 (Cast,List.hd lc,c2)) + (lm,mkCast (List.hd lc, c2)) | NextOccurrence nocc -> let (lm,lc) = try_sub_match (nocc - 1) pat [c1] in - (lm,DOP2 (Cast,List.hd lc,c2))) - | DOP2 (ne,c1,DLAM (x,c2)) -> + (lm,mkCast (List.hd lc, c2))) + | IsLambda (x,c1,c2) -> (try authorized_occ nocc ((matches pat c),DOP0 (Meta (-1))) with | PatternMatchingFailure -> let (lm,lc) = try_sub_match nocc pat [c1;c2] in - (lm,DOP2 (ne,List.hd lc,DLAM (x,List.nth lc 1))) + (lm,mkLambda (x,List.hd lc,List.nth lc 1)) | NextOccurrence nocc -> let (lm,lc) = try_sub_match (nocc - 1) pat [c1;c2] in - (lm,DOP2 (ne,List.hd lc,DLAM (x,List.nth lc 1)))) - | DOPN (AppL,a) when Array.length a <> 0 -> - let c1 = a.(0) - and lc = List.tl (Array.to_list a) in + (lm,mkLambda (x,List.hd lc,List.nth lc 1))) + | IsProd (x,c1,c2) -> (try authorized_occ nocc ((matches pat c),DOP0 (Meta (-1))) with | PatternMatchingFailure -> - let (lm,le) = try_sub_match nocc pat (c1::lc) in - (lm,DOPN (AppL,Array.of_list le)) + let (lm,lc) = try_sub_match nocc pat [c1;c2] in + (lm,mkProd (x,List.hd lc,List.nth lc 1)) | NextOccurrence nocc -> - let (lm,le) = try_sub_match (nocc - 1) pat (c1::lc) in - (lm,DOPN (AppL,Array.of_list le))) - | DOPN (MutCase ci,v) -> - let hd = v.(0) - and c1 = v.(1) - and lc = Array.to_list (Array.sub v 2 (Array.length v - 2)) in + let (lm,lc) = try_sub_match (nocc - 1) pat [c1;c2] in + (lm,mkProd (x,List.hd lc,List.nth lc 1))) + | IsLetIn (x,c1,t2,c2) -> + (try authorized_occ nocc ((matches pat c),DOP0 (Meta (-1))) with + | PatternMatchingFailure -> + let (lm,lc) = try_sub_match nocc pat [c1;t2;c2] in + (lm,mkLetIn (x,List.hd lc,List.nth lc 1,List.nth lc 2)) + | NextOccurrence nocc -> + let (lm,lc) = try_sub_match (nocc - 1) pat [c1;t2;c2] in + (lm,mkLetIn (x,List.hd lc,List.nth lc 1,List.nth lc 2))) + | IsAppL (c1,lc) -> (try authorized_occ nocc ((matches pat c),DOP0 (Meta (-1))) with | PatternMatchingFailure -> let (lm,le) = try_sub_match nocc pat (c1::lc) in - (lm,DOPN (MutCase ci,Array.of_list (hd::le))) + (lm,mkAppL (Array.of_list le)) | NextOccurrence nocc -> let (lm,le) = try_sub_match (nocc - 1) pat (c1::lc) in - (lm,DOPN (MutCase ci,Array.of_list (hd::le)))) - | c -> + (lm,mkAppL (Array.of_list le))) + | IsMutCase (ci,hd,c1,lc) -> + (try authorized_occ nocc ((matches pat c),DOP0 (Meta (-1))) with + | PatternMatchingFailure -> + let (lm,le) = try_sub_match nocc pat (c1::Array.to_list lc) in + (lm,mkMutCase (ci,hd,List.hd le,List.tl le)) + | NextOccurrence nocc -> + let (lm,le) = try_sub_match (nocc - 1) pat (c1::Array.to_list lc) in + (lm,mkMutCase (ci,hd,List.hd le,List.tl le))) + | IsMutConstruct _ | IsFix _ | IsMutInd _|IsCoFix _ |IsEvar _|IsConst _ + | IsRel _|IsMeta _|IsVar _|IsXtra _|IsSort _|IsAbst (_, _) -> (try authorized_occ nocc ((matches pat c),DOP0 (Meta (-1))) with | PatternMatchingFailure -> raise (NextOccurrence nocc) | NextOccurrence nocc -> raise (NextOccurrence (nocc - 1))) @@ -295,6 +305,8 @@ let rec pattern_of_constr t = | IsSort (Prop c) -> PSort (RProp c) | IsSort (Type _) -> PSort RType | IsCast (c,_) -> pattern_of_constr c + | IsLetIn (na,c,_,b) -> + PBinder (BLetIn,na,pattern_of_constr c,pattern_of_constr b) | IsProd (na,c,b) -> PBinder (BProd,na,pattern_of_constr c,pattern_of_constr b) | IsLambda (na,c,b) -> diff --git a/parsing/pattern.mli b/parsing/pattern.mli index 803e4fffe..5506e070d 100644 --- a/parsing/pattern.mli +++ b/parsing/pattern.mli @@ -14,7 +14,6 @@ type constr_pattern = | PApp of constr_pattern * constr_pattern array | PSoApp of int * constr_pattern list | PBinder of binder_kind * name * constr_pattern * constr_pattern - | PLet of identifier * constr_pattern * constr_pattern * constr_pattern | PSort of Rawterm.rawsort | PMeta of int option | PCase of constr_pattern option * constr_pattern * constr_pattern array diff --git a/parsing/pretty.ml b/parsing/pretty.ml index 28c4cb3a9..123f690a8 100644 --- a/parsing/pretty.ml +++ b/parsing/pretty.ml @@ -4,7 +4,7 @@ open Pp open Util open Names -open Generic +(*i open Generic i*) open Term open Declarations open Inductive @@ -298,10 +298,12 @@ let print_full_context_typ () = print_context false (Lib.contents_after None) assume that the declaration of constructors and eliminations follows the definition of the inductive type *) -let rec head_const c = match strip_outer_cast c with - | DOP2(Prod,_,DLAM(_,c)) -> head_const c - | DOPN(AppL,cl) -> head_const (array_hd cl) - | def -> def +let rec head_const c = match kind_of_term c with + | IsProd (_,_,d) -> head_const d + | IsLetIn (_,_,_,d) -> head_const d + | IsAppL (f,_) -> head_const f + | IsCast (d,_) -> head_const d + | _ -> c let list_filter_vec f vec = let rec frec n lf = @@ -488,11 +490,11 @@ let fprint_judge {uj_val=trm;uj_type=typ} = [< fprterm trm; 'sTR" : " ; fprterm (body_of_type typ) >] let unfold_head_fconst = - let rec unfrec = function - | DOPN(Const _,_) as k -> constant_value (Global.env ()) k - | DOP2(Lambda,t,DLAM(na,b)) -> DOP2(Lambda,t,DLAM(na,unfrec b)) - | DOPN(AppL,v) -> DOPN(AppL,array_cons (unfrec (array_hd v)) (array_tl v)) - | x -> x + let rec unfrec k = match kind_of_term k with + | IsConst _ -> constant_value (Global.env ()) k + | IsLambda (na,t,b) -> mkLambda (na,t,unfrec b) + | IsAppL (f,v) -> applist (unfrec f,v) + | _ -> k in unfrec diff --git a/parsing/termast.ml b/parsing/termast.ml index ff8222e4e..98aed4f56 100644 --- a/parsing/termast.ml +++ b/parsing/termast.ml @@ -5,7 +5,7 @@ open Pp open Util open Univ open Names -open Generic +(*i open Generic i*) open Term open Inductive open Sign @@ -217,6 +217,8 @@ let rec ast_of_raw = function | RBinder (_,BProd,Anonymous,t,c) -> (* Anonymous product are never factorized *) ope("PROD",[ast_of_raw t; slam(None,ast_of_raw c)]) + | RBinder (_,BLetIn,na,t,c) -> + ope("LETIN",[ast_of_raw t; slam(stringopt_of_name na,ast_of_raw c)]) | RBinder (_,bk,na,t,c) -> let (n,a) = factorize_binder 1 bk na (ast_of_raw t) c in let tag = match bk with @@ -226,6 +228,7 @@ let rec ast_of_raw = function (* non dépendant, pour isoler l'implication; peut-ętre un *) (* constructeur ARROW serait-il plus justifié ? *) | BProd -> if n=1 then "PROD" else "PRODLIST" + | BLetIn -> if n=1 then "LETIN" else "LETINLIST" in ope(tag,[ast_of_raw t;a]) @@ -270,7 +273,7 @@ let rec ast_of_raw = function alfi in ope("FIX", alfi.(n)::(Array.to_list listdecl)) - | RCofix n -> + | RCoFix n -> let listdecl = Array.mapi (fun i fi -> @@ -345,9 +348,11 @@ let occur_id env id0 c = | DOPN(_,cl) -> array_exists (occur n) cl | DOP1(_,c) -> occur n c | DOP2(_,c1,c2) -> (occur n c1) or (occur n c2) - | DOPL(_,cl) -> List.exists (occur n) cl | DLAM(_,c) -> occur (n+1) c | DLAMV(_,v) -> array_exists (occur (n+1)) v + | CLam (_,t,c) -> occur n (body_of_type t) or occur (n+1) c + | CPrd (_,t,c) -> occur n (body_of_type t) or occur (n+1) c + | CLet (_,b,t,c) -> occur n b or occur n (body_of_type t) or occur (n+1) c | Rel p -> p>n & (try lookup_name_of_rel (p-n) env = Name id0 @@ -366,33 +371,26 @@ let next_name_not_occuring name l env t = (* Remark: Anonymous var may be dependent in Evar's contexts *) let concrete_name islam l env n c = - if n = Anonymous & not (dependent (Rel 1) c) then + if n = Anonymous & not (dependent (mkRel 1) c) then (None,l) else let fresh_id = next_name_not_occuring n l env c in let idopt = - if islam or dependent (Rel 1) c then (Some fresh_id) else None in + if islam or dependent (mkRel 1) c then (Some fresh_id) else None in (idopt, fresh_id::l) (* Returns the list of global variables and constants in a term *) let global_vars_and_consts t = - let rec collect acc = function - | VAR id -> id::acc - | DOPN (Const sp,cl) -> (basename sp)::(Array.fold_left collect acc cl) - | DOPN (Abst sp,cl) -> (basename sp)::(Array.fold_left collect acc cl) - | DOPN (MutInd ind_sp, cl) as t -> - (basename (path_of_inductive_path ind_sp)) - ::(Array.fold_left collect acc cl) - | DOPN (MutConstruct cstr_sp, cl) as t -> - (basename (path_of_constructor_path cstr_sp)) - ::(Array.fold_left collect acc cl) - | DOPN(_,cl) -> Array.fold_left collect acc cl - | DOP1(_,c) -> collect acc c - | DOP2(_,c1,c2) -> collect (collect acc c1) c2 - | DOPL(_,cl) -> List.fold_left collect acc cl - | DLAM(_,c) -> collect acc c - | DLAMV(_,v) -> Array.fold_left collect acc v - | _ -> acc + let rec collect acc c = + let op, cl = splay_constr c in + let acc' = Array.fold_left collect acc cl in + match op with + | OpVar id -> id::acc' + | OpConst sp -> (basename sp)::acc' + | OpAbst sp -> (basename sp)::acc' + | OpMutInd ind_sp -> (basename (path_of_inductive_path ind_sp))::acc' + | OpMutConstruct csp -> (basename (path_of_constructor_path csp))::acc' + | _ -> acc' in list_uniquize (collect [] t) @@ -403,40 +401,6 @@ let used_of = global_vars_and_consts (* These functions implement a light form of Termenv.mind_specif_of_mind *) (* specially for handle Cases printing; they respect arities but not typing *) -(* -let mind_specif_of_mind_light (sp,tyi) = - let mib = Global.lookup_mind sp in - (mib,mind_nth_type_packet mib tyi) - -let rec remove_indtypes = function - | (1, DLAMV(_,cl)) -> cl - | (n, DLAM (_,c)) -> remove_indtypes (n-1, c) - | _ -> anomaly "remove_indtypes: bad list of constructors" - -let rec remove_params n t = - if n = 0 then - t - else - match t with - | DOP2(Prod,_,DLAM(_,c)) -> remove_params (n-1) c - | DOP2(Cast,c,_) -> remove_params n c - | _ -> anomaly "remove_params : insufficiently quantified" - -let rec get_params = function - | DOP2(Prod,_,DLAM(x,c)) -> x::(get_params c) - | DOP2(Cast,c,_) -> get_params c - | _ -> [] - -let lc_of_lmis (mib,mip) = - let lc = remove_indtypes (mib.mind_ntypes,mip.mind_lc) in - Array.map (remove_params mib.mind_nparams) lc - -let sp_of_spi ((sp,_) as spi) = - let (_,mip) = mind_specif_of_mind_light spi in - let (pa,_,k) = repr_path sp in - make_path pa (mip.mind_typename) k -*) - let bdize_app c al = let impl = match c with @@ -471,13 +435,13 @@ let computable p k = sinon on perd la réciprocité de la synthčse (qui, lui, engendrera un prédicat non dépendant) *) - let rec striprec = function - | (0,DOP2(Lambda,_,DLAM(_,d))) -> false - | (0,d ) -> noccur_between 1 k d - | (n,DOP2(Lambda,_,DLAM(_,d))) -> striprec (n-1,d) - | _ -> false + let rec striprec n c = match n,kind_of_term c with + | (0,IsLambda (_,_,d)) -> false + | (0,_) -> noccur_between 1 k c + | (n,IsLambda (_,_,d)) -> striprec (n-1) d + | _ -> false in - striprec (k,p) + striprec k p let ids_of_var cl = List.map @@ -500,7 +464,7 @@ let old_bdize at_top env t = | (None,avoid') -> slam(None,bdrec avoid' env (pop c))) | DLAMV(na,cl) -> - if not(array_exists (dependent (Rel 1)) cl) then + if not(array_exists (dependent (mkRel 1)) cl) then slam(None,ope("V$",array_map_to_list (fun c -> bdrec avoid env (pop c)) cl)) else @@ -535,6 +499,9 @@ let old_bdize at_top env t = bdrec avoid env c1 else ope("CAST",[bdrec avoid env c1;bdrec avoid env c2]) + | IsLetIn (na,b,_,c) -> + ope("LETIN",[bdrec [] env b; + slam(stringopt_of_name na,bdrec avoid env (pop c))]) | IsProd (Anonymous,ty,c) -> (* Anonymous product are never factorized *) ope("PROD",[bdrec [] env ty; @@ -612,36 +579,38 @@ let old_bdize at_top env t = (fun env id -> add_name (Name id) env) env lfi in let def_avoid = lfi@avoid in let f = List.nth lfi n in - let rec split_lambda binds env avoid = function - | (0, t) -> (binds,bdrec avoid env t) - | (n, DOP2(Cast,t,_)) -> split_lambda binds env avoid (n,t) - | (n, DOP2(Lambda,t,DLAM(na,b))) -> + let rec split_lambda binds env avoid n t = + match (n,kind_of_term t) with + | (0, _) -> (binds,bdrec avoid env t) + | (n, IsCast (t,_)) -> split_lambda binds env avoid n t + | (n, IsLambda (na,t,b)) -> let ast = bdrec avoid env t in let id = next_name_away na avoid in let ast_of_bind = ope("BINDER",[ast;nvar (string_of_id id)]) in let new_env = add_name (Name id) env in split_lambda (ast_of_bind::binds) - new_env (id::avoid) (n-1,b) + new_env (id::avoid) (n-1) b | _ -> error "split_lambda" in - let rec split_product env avoid = function - | (0, t) -> bdrec avoid env t - | (n, DOP2(Cast,t,_)) -> split_product env avoid (n,t) - | (n, DOP2(Prod,t,DLAM(na,b))) -> + let rec split_product env avoid n t = + match (n,kind_of_term t) with + | (0, _) -> bdrec avoid env t + | (n, IsCast (t,_)) -> split_product env avoid n t + | (n, IsProd (na,t,b)) -> let ast = bdrec avoid env t in let id = next_name_away na avoid in let new_env = add_name (Name id) env in - split_product new_env (id::avoid) (n-1,b) + split_product new_env (id::avoid) (n-1) b | _ -> error "split_product" in let listdecl = list_map_i (fun i fi -> let (lparams,ast_of_def) = - split_lambda [] def_env def_avoid (nv.(i)+1,vt.(i)) in + split_lambda [] def_env def_avoid (nv.(i)+1) vt.(i) in let ast_of_typ = - split_product env avoid (nv.(i)+1,cl.(i)) in + split_product env avoid (nv.(i)+1) cl.(i) in ope("FDECL", [nvar (string_of_id fi); ope ("BINDERS",List.rev lparams); @@ -680,7 +649,7 @@ let old_bdize at_top env t = | n, DOP2(Lambda,_,DLAM(x,b)) -> let x'= - if not print_underscore or (dependent (Rel 1) b) then x + if not print_underscore or (dependent (mkRel 1) b) then x else Anonymous in let id = next_name_away x' avoid in let new_env = (add_name (Name id) env) in @@ -769,6 +738,10 @@ let rec ast_of_pattern env = function ope("SOAPP",(ope ("META",[num n])):: (List.map (ast_of_pattern env) args)) + | PBinder (BLetIn,na,b,c) -> + let c' = ast_of_pattern (add_name na env) c in + ope("LETIN",[ast_of_pattern env b;slam(stringopt_of_name na,c')]) + | PBinder (BProd,Anonymous,t,c) -> ope("PROD",[ast_of_pattern env t; slam(None,ast_of_pattern env c)]) | PBinder (bk,na,t,c) -> @@ -782,14 +755,10 @@ let rec ast_of_pattern env = function (* non dépendant, pour isoler l'implication; peut-ętre un *) (* constructeur ARROW serait-il plus justifié ? *) | BProd -> if n=1 then "PROD" else "PRODLIST" + | BLetIn -> anomaly "Should be captured before" in ope(tag,[ast_of_pattern env t;a]) - | PLet (id,a,t,c) -> - let c' = ast_of_pattern (add_name (Name id) env) c in - ope("LET",[ast_of_pattern env a; slam(Some (string_of_id id),c')]) - - | PCase (typopt,tm,bv) -> warning "Old Case syntax"; ope("MUTCASE",(ast_of_patopt env typopt) diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 1d25ba84d..b01b3e283 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -1,7 +1,7 @@ open Util open Names -open Generic +(*i open Generic i*) open Term open Declarations open Inductive @@ -22,7 +22,7 @@ open Evarconv (* This was previously in Indrec but creates existential holes *) let mkExistential isevars env = - new_isevar isevars env (mkCast dummy_sort dummy_sort) CCI + new_isevar isevars env (mkCast (dummy_sort, dummy_sort)) CCI let norec_branch_scheme env isevars cstr = it_mkProd_or_LetIn (mkExistential isevars env) cstr.cs_args @@ -31,14 +31,16 @@ let rec_branch_scheme env isevars ((sp,j),_) recargs cstr = let rec crec (args,recargs) = match args, recargs with | (name,None,c)::rea,(ra::reca) -> - DOP2(Prod,body_of_type c,DLAM(name, - match ra with - | Mrec k when k=j -> - mkArrow (mkExistential isevars env) - (crec (List.rev (lift_rel_context 1 (List.rev rea)),reca)) - | _ -> crec (rea,reca))) - | (name,Some d,c)::rea, reca -> failwith "TODO" -(* mkLetIn (name,d,body_of_type c,crec (rea,reca))) *) + let d = + match ra with + | Mrec k when k=j -> + mkArrow (mkExistential isevars env) + (crec (List.rev (lift_rel_context 1 (List.rev rea)),reca)) + | _ -> crec (rea,reca) in + mkProd (name, body_of_type c, d) + + | (name,Some d,c)::rea, reca -> + mkLetIn (name, d, body_of_type c, crec (rea,reca)) | [],[] -> mkExistential isevars env | _ -> anomaly "rec_branch_scheme" in @@ -58,9 +60,9 @@ let branch_scheme env isevars isrec (IndFamily (mis,params) as indf) = let concl_n env sigma = let rec decrec m c = if m = 0 then c else - match whd_betadeltaiota env sigma c with - | DOP2(Prod,_,DLAM(n,c_0)) -> decrec (m-1) c_0 - | _ -> failwith "Typing.concl_n" + match kind_of_term (whd_betadeltaiota env sigma c) with + | IsProd (n,_,c_0) -> decrec (m-1) c_0 + | _ -> failwith "Typing.concl_n" in decrec @@ -378,9 +380,9 @@ let dependencies_in_rhs nargs eqns = already dependent *) let rec is_dep_on_previous n t = function - | ((_,IsInd _),_)::_ when dependent (Rel n) t -> DepOnPrevious + | ((_,IsInd _),_)::_ when dependent (mkRel n) t -> DepOnPrevious | ((_,NotInd _),(DepOnPrevious,DepInRhs))::_ - when dependent (Rel n) t -> DepOnPrevious + when dependent (mkRel n) t -> DepOnPrevious | _::rest -> is_dep_on_previous (n+1) t rest | [] -> NotDepOnPrevious @@ -513,11 +515,13 @@ let noccur_between_without_evar n m term = | VAR _ -> () | DOPN(Evar _,cl) -> () | DOPN(_,cl) -> Array.iter (occur_rec n) cl - | DOPL(_,cl) -> List.iter (occur_rec n) cl | DOP1(_,c) -> occur_rec n c | DOP2(_,c1,c2) -> occur_rec n c1; occur_rec n c2 | DLAM(_,c) -> occur_rec (n+1) c | DLAMV(_,v) -> Array.iter (occur_rec (n+1)) v + | CLam (_,t,c) -> occur_rec n (body_of_type t); occur_rec (n+1) c + | CPrd (_,t,c) -> occur_rec n (body_of_type t); occur_rec (n+1) c + | CLet (_,b,t,c) -> occur_rec n b; occur_rec n (body_of_type t); occur_rec (n+1) c | _ -> () in try occur_rec n term; true with Occur -> false @@ -645,7 +649,7 @@ let rec weaken_predicate n pred = let rec extract_predicate = function | PrProd ((_,na,t),pred) -> - mkProd na (type_of_tomatch_type t) (extract_predicate pred) + mkProd (na, type_of_tomatch_type t, extract_predicate pred) | PrLetIn ((args,Some c),pred) -> substl (c::(List.rev args)) (extract_predicate pred) | PrLetIn ((args,None),pred) -> substl (List.rev args) (extract_predicate pred) | PrCcl ccl -> ccl @@ -962,9 +966,9 @@ let build_expected_arity env isevars isdep tomatchl = | tm::ltm -> let (ty1,aritysign) = cook n tm in let rec follow n = function - | (na,ty2)::sign -> DOP2(Prod,ty2,DLAM(na,follow (n+1) sign)) + | (na,ty2)::sign -> mkProd (na, ty2, follow (n+1) sign) | _ -> - if isdep then DOP2(Prod,ty1,DLAM(Anonymous,buildrec (n+1) ltm)) + if isdep then mkProd (Anonymous, ty1, buildrec (n+1) ltm) else buildrec n ltm in follow n (List.rev aritysign) in buildrec 0 tomatchl @@ -988,17 +992,18 @@ let build_initial_predicate isdep pred tomatchl = in buildrec 0 pred tomatchl let rec eta_expand0 env sigma n c t = - match whd_betadeltaiota env sigma t with - DOP2(Prod,a,DLAM(na,b)) -> - DOP2(Lambda,a,DLAM(na,eta_expand0 env sigma (n+1) c b)) - | _ -> applist (lift n c, rel_list 0 n) + match kind_of_term (whd_betadeltaiota env sigma t) with + | IsProd (na,a,b) -> mkLambda (na,a,eta_expand0 env sigma (n+1) c b) + | _ -> applist (lift n c, rel_list 0 n) let rec eta_expand env sigma c t = - match whd_betadeltaiota env sigma c, whd_betadeltaiota env sigma t with - | (DOP2(Lambda,ta,DLAM(na,cb)), DOP2(Prod,_,DLAM(_,tb))) -> - DOP2(Lambda,ta,DLAM(na,eta_expand env sigma cb tb)) - | (c, t) -> eta_expand0 env sigma 0 c t + let c' = whd_betadeltaiota env sigma c in + let t' = whd_betadeltaiota env sigma t in + match kind_of_term c', kind_of_term t' with + | IsLambda (na,ta,cb), IsProd (_,_,tb) -> + mkLambda (na,ta,eta_expand env sigma cb tb) + | _, _ -> eta_expand0 env sigma 0 c' t' (* determines wether the multiple case is dependent or not. For that * the predicate given by the user is eta-expanded. If the result diff --git a/pretyping/class.ml b/pretyping/class.ml index 419bd1bf3..5c56ce9b6 100644 --- a/pretyping/class.ml +++ b/pretyping/class.ml @@ -4,7 +4,7 @@ open Util open Pp open Names -open Generic +(*i open Generic i*) open Term open Inductive open Declarations @@ -129,6 +129,7 @@ let constructor_at_head1 t = | IsAppL(f,args) -> let t',_,l,c,_ = aux f in t',args,l,c,List.length args | IsProd (_,_,_) -> t',[],[],CL_FUN,0 + | IsLetIn (_,_,_,c) -> aux c | IsSort _ -> t',[],[],CL_SORT,0 | _ -> raise Not_found in @@ -203,23 +204,15 @@ let get_target t ind = let v2,_,_,cl2,p2 = constructor_at_head1 t in cl2,p2,v2 let prods_of t = - let rec aux acc = function - | DOP2(Prod,c1,DLAM(_,c2)) -> aux (c1::acc) c2 - | (DOP2(Cast,c,_)) -> aux acc c - | t -> t::acc + let rec aux acc d = match kind_of_term d with + | IsProd (_,c1,c2) -> aux (c1::acc) c2 + | IsCast (c,_) -> aux acc c + | _ -> d::acc in aux [] t (* coercion identite' *) -let lams_of t = - let rec aux acc = function - | DOP2(Lambda,c1,DLAM(x,c2)) -> aux ((x,c1)::acc) c2 - | DOP2(Cast,c,_) -> aux acc c - | t -> acc,t - in - aux [] t - let build_id_coercion idf_opt ids = let env = Global.env () in let vs = construct_reference env CCI ids in @@ -234,24 +227,22 @@ let build_id_coercion idf_opt ids = [< 'sTR(string_of_id ids); 'sTR" must be a transparent constant" >] in - let lams,t = lams_of c in - let lams = List.rev lams in + let lams,t = Sign.decompose_lam_assum c in let llams = List.length lams in + let lams = List.rev lams in let val_f = - List.fold_right - (fun (x,t) u -> DOP2(Lambda,t,DLAM(x,u))) - lams - (DOP2(Lambda,(applistc vs (rel_list 0 llams)), - DLAM(Name (id_of_string "x"),Rel 1))) + it_mkLambda_or_LetIn + (mkLambda (Name (id_of_string "x"), + applistc vs (rel_list 0 llams), + Rel 1)) + lams in let typ_f = - List.fold_right - (fun (x,t) c -> DOP2(Prod,t,DLAM(x,c))) + it_mkProd_wo_LetIn + (mkProd (Anonymous, applistc vs (rel_list 0 llams), lift 1 t)) lams - (DOP2(Prod,(applistc vs (rel_list 0 llams)), - DLAM(Anonymous,lift 1 t))) - in - let constr_f = DOP2(Cast,val_f,typ_f) in + in + let constr_f = mkCast (val_f, typ_f) in (* juste pour verification *) let _ = try diff --git a/pretyping/classops.ml b/pretyping/classops.ml index 230c2cb84..4e991a5fd 100755 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -9,7 +9,7 @@ open Environ open Libobject open Declare open Term -open Generic +(*i open Generic i*) open Rawterm (* usage qque peu general: utilise aussi dans record *) @@ -188,14 +188,15 @@ let _ = (* constructor_at_head : constr -> cl_typ * int *) let constructor_at_head t = - let rec aux t' = match t' with - | VAR id -> CL_Var id,0 - | DOPN(Const sp,_) -> CL_SP sp,0 - | DOPN(MutInd ind_sp,_) -> CL_IND ind_sp,0 - | DOP2(Prod,_,DLAM(_,c)) -> CL_FUN,0 - | DOP0(Sort(_)) -> CL_SORT,0 - | DOP2(Cast,c,_) -> aux (collapse_appl c) - | DOPN(AppL,cl) -> let c,_ = aux (array_hd cl) in c,Array.length(cl)-1 + let rec aux t' = match kind_of_term t' with + | IsVar id -> CL_Var id,0 + | IsConst (sp,_) -> CL_SP sp,0 + | IsMutInd (ind_sp,_) -> CL_IND ind_sp,0 + | IsProd (_,_,c) -> CL_FUN,0 + | IsLetIn (_,_,_,c) -> aux c + | IsSort _ -> CL_SORT,0 + | IsCast (c,_) -> aux (collapse_appl c) + | IsAppL (f,args) -> let c,_ = aux f in c, List.length args | _ -> raise Not_found in aux (collapse_appl t) @@ -230,11 +231,11 @@ let fully_applied id p p1 = if p <> p1 then errorlabstrm "fully_applied" [< 'sTR"Wrong number of parameters for ";'sTR(string_of_id id) >] -let rec arity_sort = function - | DOP0(Sort(Prop(_))) -> 0 - | DOP0(Sort(Type(_))) -> 0 - | DOP2(Prod,_,DLAM(_,c)) -> (arity_sort c) +1 - | DOP2(Cast,c,_) -> arity_sort c +let rec arity_sort a = match kind_of_term a with + | IsSort (Prop _ | Type _) -> 0 + | IsProd (_,_,c) -> (arity_sort c) +1 + | IsLetIn (_,_,_,c) -> arity_sort c (* Utile ?? *) + | IsCast (c,_) -> arity_sort c | _ -> raise Not_found let stre_of_cl = function diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 8269a4741..d4a7ef4a6 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -1,7 +1,7 @@ (* $Id$ *) open Util -open Generic +(*i open Generic i*) open Names open Term open Reduction @@ -30,8 +30,8 @@ let apply_coercion_args env argl funj = uj_type= typed_app (fun _ -> typ) funj.uj_type } | h::restl -> (* On devrait pouvoir s'arranger pour qu'on ait pas ŕ faire hnf_constr *) - match whd_betadeltaiota env Evd.empty typ with - | DOP2(Prod,c1,DLAM(_,c2)) -> + match kind_of_term (whd_betadeltaiota env Evd.empty typ) with + | IsProd (_,c1,c2) -> (* Typage garanti par l'appel a app_coercion*) apply_rec (h::acc) (subst1 h c2) restl | _ -> anomaly "apply_coercion_args" @@ -60,8 +60,9 @@ let apply_pcoercion env p hj typ_cl = with _ -> anomaly "apply_pcoercion" let inh_app_fun env isevars j = - match whd_betadeltaiota env !isevars (body_of_type j.uj_type) with - | DOP2(Prod,_,DLAM(_,_)) -> j + let t = whd_betadeltaiota env !isevars (body_of_type j.uj_type) in + match kind_of_term t with + | IsProd (_,_,_) -> j | _ -> (try let t,i1 = class_of1 env !isevars (body_of_type j.uj_type) in @@ -116,13 +117,13 @@ let rec inh_conv_coerce_to_fail env isevars c1 hj = inh_coerce_to_fail env isevars c1 hj with NoCoercion -> (* try ... with _ -> ... is BAD *) (* (match (hnf_constr !isevars t,hnf_constr !isevars c1) with*) - (match (whd_betadeltaiota env !isevars t, - whd_betadeltaiota env !isevars c1) with - | (DOP2(Prod,t1,DLAM(_,t2)),DOP2(Prod,u1,DLAM(name,u2))) -> + (match kind_of_term (whd_betadeltaiota env !isevars t), + kind_of_term (whd_betadeltaiota env !isevars c1) with + | IsProd (_,t1,t2), IsProd (name,u1,u2) -> (* let v' = hnf_constr !isevars v in *) let v' = whd_betadeltaiota env !isevars v in - if (match v' with - | DOP2(Lambda,v1,DLAM(_,v2)) -> + if (match kind_of_term v' with + | IsLambda (_,v1,v2) -> the_conv_x env isevars v1 u1 (* leq v1 u1? *) | _ -> false) then @@ -162,7 +163,7 @@ let inh_conv_coerce_to loc env isevars cj tj = let at = nf_ise1 !isevars (body_of_type tj) in error_actual_type_loc loc env rcj.uj_val (body_of_type rcj.uj_type) at in - { uj_val = (* mkCast *) cj'.uj_val (* (body_of_type tj) *); + { uj_val = cj'.uj_val; uj_type = tj } let inh_apply_rel_list nocheck apploc env isevars argjl funj tycon = @@ -179,8 +180,8 @@ let inh_apply_rel_list nocheck apploc env isevars argjl funj tycon = | None -> resj) | hj::restjl -> - match whd_betadeltaiota env !isevars typ with - | DOP2(Prod,c1,DLAM(_,c2)) -> + match kind_of_term (whd_betadeltaiota env !isevars typ) with + | IsProd (_,c1,c2) -> let hj' = if nocheck then hj diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 90697191a..596310512 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -5,7 +5,7 @@ open Pp open Util open Univ open Names -open Generic +(*i open Generic i*) open Term open Inductive open Sign @@ -44,9 +44,11 @@ let occur_id env_names id0 c = | DOPN(_,cl) -> array_exists (occur n) cl | DOP1(_,c) -> occur n c | DOP2(_,c1,c2) -> (occur n c1) or (occur n c2) - | DOPL(_,cl) -> List.exists (occur n) cl | DLAM(_,c) -> occur (n+1) c | DLAMV(_,v) -> array_exists (occur (n+1)) v + | CLam (_,t,c) -> occur n (body_of_type t) or occur (n+1) c + | CPrd (_,t,c) -> occur n (body_of_type t) or occur (n+1) c + | CLet (_,b,t,c) -> occur n b or occur n (body_of_type t) or occur (n+1) c | Rel p -> p>n & (try lookup_name_of_rel (p-n) env_names = Name id0 @@ -66,32 +68,25 @@ let next_name_not_occuring name l env_names t = (* Remark: Anonymous var may be dependent in Evar's contexts *) let concrete_name l env_names n c = - if n = Anonymous & not (dependent (Rel 1) c) then + if n = Anonymous & not (dependent (mkRel 1) c) then (None,l) else let fresh_id = next_name_not_occuring n l env_names c in - let idopt = if dependent (Rel 1) c then (Some fresh_id) else None in + let idopt = if dependent (mkRel 1) c then (Some fresh_id) else None in (idopt, fresh_id::l) (* Returns the list of global variables and constants in a term *) let global_vars_and_consts t = - let rec collect acc = function - | VAR id -> id::acc - | DOPN (Const sp,cl) -> (basename sp)::(Array.fold_left collect acc cl) - | DOPN (Abst sp,cl) -> (basename sp)::(Array.fold_left collect acc cl) - | DOPN (MutInd ind_sp, cl) as t -> - (basename (path_of_inductive_path ind_sp)) - ::(Array.fold_left collect acc cl) - | DOPN (MutConstruct cstr_sp, cl) as t -> - (basename (path_of_constructor_path cstr_sp)) - ::(Array.fold_left collect acc cl) - | DOPN(_,cl) -> Array.fold_left collect acc cl - | DOP1(_,c) -> collect acc c - | DOP2(_,c1,c2) -> collect (collect acc c1) c2 - | DOPL(_,cl) -> List.fold_left collect acc cl - | DLAM(_,c) -> collect acc c - | DLAMV(_,v) -> Array.fold_left collect acc v - | _ -> acc + let rec collect acc c = + let op, cl = splay_constr c in + let acc' = Array.fold_left collect acc cl in + match op with + | OpVar id -> id::acc' + | OpConst sp -> (basename sp)::acc' + | OpAbst sp -> (basename sp)::acc' + | OpMutInd ind_sp -> (basename (path_of_inductive_path ind_sp))::acc' + | OpMutConstruct csp -> (basename (path_of_constructor_path csp))::acc' + | _ -> acc' in list_uniquize (collect [] t) @@ -156,7 +151,7 @@ module PrintingCasesMake = let check (_,lc) = if not (Test.test lc) then errorlabstrm "check_encode" [< 'sTR Test.error_message >] - let decode (spi,_) = sp_of_spi spi + let printer (spi,_) = [< 'sTR(string_of_path (sp_of_spi spi)) >] let key = Goptions.SecondaryTable ("Printing",Test.field) let title = Test.title let member_message = Test.member_message @@ -194,8 +189,8 @@ module PrintingCasesLet = ^ " are not printed using a `let' form" end) -module PrintingIf = Goptions.MakeTable(PrintingCasesIf) -module PrintingLet = Goptions.MakeTable(PrintingCasesLet) +module PrintingIf = Goptions.MakeIdentTable(PrintingCasesIf) +module PrintingLet = Goptions.MakeIdentTable(PrintingCasesLet) let force_let (lc,(indsp,_,_,_,_)) = PrintingLet.active (indsp,lc) let force_if (lc,(indsp,_,_,_,_)) = PrintingIf.active (indsp,lc) @@ -244,10 +239,10 @@ let computable p k = sinon on perd la réciprocité de la synthčse (qui, lui, engendrera un prédicat non dépendant) *) - let rec striprec = function - | (0,DOP2(Lambda,_,DLAM(_,d))) -> false - | (0,d ) -> noccur_between 1 k d - | (n,DOP2(Lambda,_,DLAM(_,d))) -> striprec (n-1,d) + let rec striprec (n,c) = match n, kind_of_term c with + | (0,IsLambda (_,_,d)) -> false + | (0,_) -> noccur_between 1 k c + | (n,IsLambda (_,_,d)) -> striprec (n-1,d) | _ -> false in striprec (k,p) @@ -262,24 +257,24 @@ let ids_of_var cl = *) let lookup_name_as_renamed ctxt t s = - let rec lookup avoid env_names n = function - DOP2(Prod,t,DLAM(name,c')) -> - (match concrete_name avoid env_names name c' with - (Some id,avoid') -> - if id=s then (Some n) - else lookup avoid' (add_name (Name id) env_names) (n+1) c' - | (None,avoid') -> lookup avoid' env_names (n+1) (pop c')) - | DOP2(Cast,c,_) -> lookup avoid env_names n c - | _ -> None + let rec lookup avoid env_names n c = match kind_of_term c with + | IsProd (name,t,c') -> + (match concrete_name avoid env_names name c' with + (Some id,avoid') -> + if id=s then (Some n) + else lookup avoid' (add_name (Name id) env_names) (n+1) c' + | (None,avoid') -> lookup avoid' env_names (n+1) (pop c')) + | IsCast (c,_) -> lookup avoid env_names n c + | _ -> None in lookup (ids_of_var_context ctxt) empty_names_context 1 t let lookup_index_as_renamed t n = - let rec lookup n d = function - DOP2(Prod,_,DLAM(name,c')) -> + let rec lookup n d c = match kind_of_term c with + | IsProd (name,_,c') -> (match concrete_name [] empty_names_context name c' with (Some _,_) -> lookup n (d+1) c' | (None ,_) -> if n=1 then Some d else lookup (n-1) (d+1) c') - | DOP2(Cast,c,_) -> lookup n d c + | IsCast (c,_) -> lookup n d c | _ -> None in lookup n 1 t @@ -310,6 +305,7 @@ let rec detype avoid env t = RCast(dummy_loc,detype avoid env c1,detype avoid env c2) | IsProd (na,ty,c) -> detype_binder BProd avoid env na ty c | IsLambda (na,ty,c) -> detype_binder BLambda avoid env na ty c + | IsLetIn (na,b,_,c) -> detype_binder BLetIn avoid env na b c | IsAppL (f,args) -> RApp (dummy_loc,detype avoid env f,List.map (detype avoid env) args) | IsConst (sp,cl) -> @@ -356,7 +352,7 @@ let rec detype avoid env t = end | IsFix (nvn,(cl,lfn,vt)) -> detype_fix (RFix nvn) avoid env cl lfn vt - | IsCoFix (n,(cl,lfn,vt)) -> detype_fix (RCofix n) avoid env cl lfn vt) + | IsCoFix (n,(cl,lfn,vt)) -> detype_fix (RCoFix n) avoid env cl lfn vt) and detype_fix fk avoid env cl lfn vt = let lfi = List.map (fun id -> next_name_away id avoid) lfn in @@ -369,34 +365,35 @@ and detype_fix fk avoid env cl lfn vt = and detype_eqn avoid env constr_id construct_nargs branch = let make_pat x avoid env b ids = - if not (force_wildcard ()) or (dependent (Rel 1) b) then + if not (force_wildcard ()) or (dependent (mkRel 1) b) then let id = next_name_away_with_default "x" x avoid in PatVar (dummy_loc,Name id),id::avoid,(add_name (Name id) env),id::ids else PatVar (dummy_loc,Anonymous),avoid,(add_name Anonymous env),ids in - let rec buildrec ids patlist avoid env = function - | 0 , rhs -> - (ids, [PatCstr(dummy_loc, constr_id, List.rev patlist,Anonymous)], - detype avoid env rhs) - - | n, DOP2(Lambda,_,DLAM(x,b)) -> - let pat,new_avoid,new_env,new_ids = make_pat x avoid env b ids in - buildrec new_ids (pat::patlist) new_avoid new_env (n-1,b) - - | n, DOP2(Cast,b,_) -> (* Oui, il y a parfois des cast *) - buildrec ids patlist avoid env (n,b) - - | n, b -> (* eta-expansion : n'arrivera plus lorsque tous les - termes seront construits ŕ partir de la syntaxe Cases *) - (* nommage de la nouvelle variable *) - let new_b = DOPN(AppL,[|lift 1 b; Rel 1|]) in - let pat,new_avoid,new_env,new_ids = - make_pat Anonymous avoid env new_b ids in - buildrec new_ids (pat::patlist) new_avoid new_env (n-1,new_b) + let rec buildrec ids patlist avoid env n b = + if n=0 then + (ids, [PatCstr(dummy_loc, constr_id, List.rev patlist,Anonymous)], + detype avoid env b) + else + match kind_of_term b with + | IsLambda (x,_,b) -> + let pat,new_avoid,new_env,new_ids = make_pat x avoid env b ids in + buildrec new_ids (pat::patlist) new_avoid new_env (n-1) b + + | IsCast (c,_) -> (* Oui, il y a parfois des cast *) + buildrec ids patlist avoid env n c + + | _ -> (* eta-expansion : n'arrivera plus lorsque tous les + termes seront construits ŕ partir de la syntaxe Cases *) + (* nommage de la nouvelle variable *) + let new_b = applist (lift 1 b, [Rel 1]) in + let pat,new_avoid,new_env,new_ids = + make_pat Anonymous avoid env new_b ids in + buildrec new_ids (pat::patlist) new_avoid new_env (n-1) new_b in - buildrec [] [] avoid env (construct_nargs,branch) + buildrec [] [] avoid env construct_nargs branch and detype_binder bk avoid env na ty c = let na',avoid' = match concrete_name avoid env na c with diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 3afc73469..e4e2e48c5 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -3,7 +3,7 @@ open Util open Names -open Generic +(*i open Generic i*) open Term open Reduction open Instantiate @@ -105,10 +105,10 @@ and evar_conv_x env isevars pbty term1 term2 = else evar_eqappr_x env isevars pbty (t1,l1) (t2,l2) -and evar_eqappr_x env isevars pbty appr1 appr2 = +and evar_eqappr_x env isevars pbty (term1,l1 as appr1) (term2,l2 as appr2) = (* Evar must be undefined since we have whd_ised *) - match (appr1,appr2) with - | ((DOPN(Evar sp1,al1) as term1,l1), (DOPN(Evar sp2,al2) as term2,l2)) -> + match (kind_of_term term1, kind_of_term term2) with + | IsEvar (sp1,al1), IsEvar (sp2,al2) -> let f1 () = if List.length l1 > List.length l2 then let (deb1,rest1) = list_chop (List.length l1-List.length l2) l1 in @@ -125,7 +125,7 @@ and evar_eqappr_x env isevars pbty appr1 appr2 = in ise_try isevars [f1; f2] - | ((DOPN(Evar sp1,al1) as term1,l1), (DOPN(Const sp2,al2) as term2,l2)) -> + | IsEvar (sp1,al1), IsConst (sp2,al2) -> let f1 () = (List.length l1 <= List.length l2) & let (deb2,rest2) = list_chop (List.length l2-List.length l1) l2 in @@ -139,7 +139,7 @@ and evar_eqappr_x env isevars pbty appr1 appr2 = in ise_try isevars [f1; f4] - | ((DOPN(Const sp1,al1) as term1,l1), (DOPN(Evar sp2,al2) as term2,l2)) -> + | IsConst (sp1,al1), IsEvar (sp2,al2) -> let f1 () = (List.length l2 <= List.length l1) & let (deb1,rest1) = list_chop (List.length l1-List.length l2) l1 in @@ -154,7 +154,7 @@ and evar_eqappr_x env isevars pbty appr1 appr2 = in ise_try isevars [f1; f4] - | ((DOPN(Const sp1,al1) as term1,l1), (DOPN(Const sp2,al2) as term2,l2)) -> + | IsConst (sp1,al1), IsConst (sp2,al2) -> let f2 () = (sp1 = sp2) & (array_for_all2 (evar_conv_x env isevars CONV) al1 al2) @@ -176,19 +176,19 @@ and evar_eqappr_x env isevars pbty appr1 appr2 = in ise_try isevars [f2; f3; f4] - | ((DOPN(Evar _,_) as term1,l1),(t2,l2)) -> + | IsEvar (_,_), _ -> (List.length l1 <= List.length l2) & let (deb2,rest2) = list_chop (List.length l2-List.length l1) l2 in - solve_pb env isevars(pbty,term1,applist(t2,deb2)) + solve_pb env isevars(pbty,term1,applist(term2,deb2)) & list_for_all2eq (evar_conv_x env isevars CONV) l1 rest2 - | ((t1,l1),(DOPN(Evar _,_) as t2,l2)) -> + | _, IsEvar (_,_) -> (List.length l2 <= List.length l1) & let (deb1,rest1) = list_chop (List.length l1-List.length l2) l1 in - solve_pb env isevars(pbty,applist(t1,deb1),t2) + solve_pb env isevars(pbty,applist(term1,deb1),term2) & list_for_all2eq (evar_conv_x env isevars CONV) rest1 l2 - | ((DOPN(Const _,_) as term1,l1),(t2,l2)) -> + | IsConst (_,_), _ -> let f3 () = (try conv_record env isevars (check_conv_record appr1 appr2) with _ -> false) @@ -199,18 +199,18 @@ and evar_eqappr_x env isevars pbty appr1 appr2 = in ise_try isevars [f3; f4] - | ((t1,l1),(DOPN(Const _,_) as t2,l2)) -> + | _ , IsConst (_,_) -> let f3 () = (try (conv_record env isevars (check_conv_record appr2 appr1)) with _ -> false) and f4 () = - evaluable_constant env t2 & + evaluable_constant env term2 & evar_eqappr_x env isevars pbty - appr1 (evar_apprec env isevars l2 (constant_value env t2)) + appr1 (evar_apprec env isevars l2 (constant_value env term2)) in ise_try isevars [f3; f4] - | ((DOPN(Abst _,_) as term1,l1),(DOPN(Abst _,_) as term2,l2)) -> + | IsAbst (_,_), IsAbst (_,_) -> let f1 () = (term1=term2) & (List.length(l1) = List.length(l2)) & @@ -226,75 +226,89 @@ and evar_eqappr_x env isevars pbty appr1 appr2 = in ise_try isevars [f1; f2] - | ((DOPN(Abst _,_) as term1,l1),_) -> + | IsAbst (_,_), _ -> (evaluable_abst env term1) & evar_eqappr_x env isevars pbty (evar_apprec env isevars l1 (abst_value env term1)) appr2 - | (_,(DOPN(Abst _,_) as term2,l2)) -> + | _, IsAbst (_,_) -> (evaluable_abst env term2) & evar_eqappr_x env isevars pbty appr1 (evar_apprec env isevars l2 (abst_value env term2)) - | ((Rel(n),l1),(Rel(m),l2)) -> + | IsRel n, IsRel m -> n=m & (List.length(l1) = List.length(l2)) & (List.for_all2 (evar_conv_x env isevars CONV) l1 l2) - | ((DOP2(Cast,c,_),l),_) -> evar_eqappr_x env isevars pbty (c,l) appr2 + | IsCast (c1,_), _ -> evar_eqappr_x env isevars pbty (c1,l1) appr2 - | (_,(DOP2(Cast,c,_),l)) -> evar_eqappr_x env isevars pbty appr1 (c,l) + | _, IsCast (c2,_) -> evar_eqappr_x env isevars pbty appr1 (c2,l2) - | ((VAR id1,l1),(VAR id2,l2)) -> + | IsVar id1, IsVar id2 -> (id1=id2 & (List.length l1 = List.length l2) & (List.for_all2 (evar_conv_x env isevars CONV) l1 l2)) - | ((DOP0(Meta(n)),l1),(DOP0(Meta(m)),l2)) -> + | IsMeta n, IsMeta m -> (n=m & (List.length(l1) = List.length(l2)) & (List.for_all2 (evar_conv_x env isevars CONV) l1 l2)) - | ((DOP0(Sort s1),[]),(DOP0(Sort s2),[])) -> base_sort_cmp pbty s1 s2 + | IsSort s1, IsSort s2 when l1=[] & l2=[] -> base_sort_cmp pbty s1 s2 - | ((DOP2(Lambda,c1,DLAM(_,c2)),[]), (DOP2(Lambda,c'1,DLAM(_,c'2)),[])) -> - evar_conv_x env isevars CONV c1 c'1 - & evar_conv_x env isevars CONV c2 c'2 + | IsLambda (_,c1,c'1), IsLambda (_,c2,c'2) when l1=[] & l2=[] -> + evar_conv_x env isevars CONV c1 c2 + & evar_conv_x env isevars CONV c'1 c'2 - | ((DOP2(Prod,c1,DLAM(n,c2)),[]), (DOP2(Prod,c'1,DLAM(_,c'2)),[])) -> - evar_conv_x env isevars CONV c1 c'1 + | IsLetIn (_,b1,_,c'1), IsLetIn (_,b2,_,c'2) -> + let f1 () = + evar_conv_x env isevars CONV b1 b2 + & evar_conv_x env isevars pbty c'1 c'2 + & (List.length l1 = List.length l2) + & (List.for_all2 (evar_conv_x env isevars CONV) l1 l2) + and f2 () = + evar_eqappr_x env isevars pbty (subst1 b1 c'1,l1) (subst1 b2 c'2,l2) + in + ise_try isevars [f1; f2] + + | IsLetIn (_,b1,_,c'1), _ -> (* On fait commuter les args avec le Let *) + evar_eqappr_x env isevars pbty (subst1 b1 c'1,l1) appr2 + + | _, IsLetIn (_,b2,_,c'2) -> + evar_eqappr_x env isevars pbty appr1 (subst1 b2 c'2,l2) + + | IsProd (n,c1,c'1), IsProd (_,c2,c'2) when l1=[] & l2=[] -> + evar_conv_x env isevars CONV c1 c2 & (let d = Retyping.get_assumption_of env !isevars (nf_ise1 !isevars c1) - in evar_conv_x (push_rel_decl (n,d) env) isevars pbty c2 c'2) + in evar_conv_x (push_rel_decl (n,d) env) isevars pbty c'1 c'2) - | ((DOPN(MutInd _ as o1,cl1) as ind1,l'1), - (DOPN(MutInd _ as o2,cl2) as ind2,l'2)) -> - o1=o2 - & array_for_all2 (evar_conv_x env isevars CONV) cl1 cl2 - & list_for_all2eq (evar_conv_x env isevars CONV) l'1 l'2 + | IsMutInd (sp1,cl1), IsMutInd (sp2,cl2) -> + sp1=sp2 + & array_for_all2 (evar_conv_x env isevars CONV) cl1 cl2 + & list_for_all2eq (evar_conv_x env isevars CONV) l1 l2 - | ((DOPN(MutConstruct _ as o1,cl1) as constr1,l1), - (DOPN(MutConstruct _ as o2,cl2) as constr2,l2)) -> - o1=o2 - & array_for_all2 (evar_conv_x env isevars CONV) cl1 cl2 - & list_for_all2eq (evar_conv_x env isevars CONV) l1 l2 - - | ((DOPN(MutCase _,_) as constr1,l'1), - (DOPN(MutCase _,_) as constr2,l'2)) -> - let (_,p1,c1,cl1) = destCase constr1 in - let (_,p2,c2,cl2) = destCase constr2 in + | IsMutConstruct (sp1,cl1), IsMutConstruct (sp2,cl2) -> + sp1=sp2 + & array_for_all2 (evar_conv_x env isevars CONV) cl1 cl2 + & list_for_all2eq (evar_conv_x env isevars CONV) l1 l2 + + | IsMutCase (_,p1,c1,cl1), IsMutCase (_,p2,c2,cl2) -> evar_conv_x env isevars CONV p1 p2 & evar_conv_x env isevars CONV c1 c2 & (array_for_all2 (evar_conv_x env isevars CONV) cl1 cl2) - & (list_for_all2eq (evar_conv_x env isevars CONV) l'1 l'2) + & (list_for_all2eq (evar_conv_x env isevars CONV) l1 l2) - | ((DOPN(Fix _ as o1,cl1),l1),(DOPN(Fix _ as o2,cl2),l2)) -> - o1=o2 & - (array_for_all2 (evar_conv_x env isevars CONV) cl1 cl2) & - (list_for_all2eq (evar_conv_x env isevars CONV) l1 l2) + | IsFix (li1,(tys1,_,bds1)), IsFix (li2,(tys2,_,bds2)) -> + li1=li2 + & (array_for_all2 (evar_conv_x env isevars CONV) tys1 tys2) + & (array_for_all2 (evar_conv_x env isevars CONV) bds1 bds2) + & (list_for_all2eq (evar_conv_x env isevars CONV) l1 l2) - | ((DOPN(CoFix(i1),cl1),l1),(DOPN(CoFix(i2),cl2),l2)) -> - i1=i2 & - (array_for_all2 (evar_conv_x env isevars CONV) cl1 cl2) & - (list_for_all2eq (evar_conv_x env isevars CONV) l1 l2) + | IsCoFix (i1,(tys1,_,bds1)), IsCoFix (i2,(tys2,_,bds2)) -> + i1=i2 + & (array_for_all2 (evar_conv_x env isevars CONV) tys1 tys2) + & (array_for_all2 (evar_conv_x env isevars CONV) bds1 bds2) + & (list_for_all2eq (evar_conv_x env isevars CONV) l1 l2) (*** | (DOP0(Implicit),[]),(DOP0(Implicit),[]) -> true @@ -302,13 +316,16 @@ and evar_eqappr_x env isevars pbty appr1 appr2 = * But b (optional env) is not updated! *) ***) - | (DLAM(_,c1),[]),(DLAM(_,c2),[]) -> - evar_conv_x env isevars pbty c1 c2 + | (IsRel _ | IsVar _ | IsMeta _ | IsXtra _ | IsLambda _), _ -> false + | _, (IsRel _ | IsVar _ | IsMeta _ | IsXtra _ | IsLambda _) -> false + + | (IsMutInd _ | IsMutConstruct _ | IsSort _ | IsProd _), _ -> false + | _, (IsMutInd _ | IsMutConstruct _ | IsSort _ | IsProd _) -> false + + | (IsAppL _ | IsMutCase _ | IsFix _ | IsCoFix _), + (IsAppL _ | IsMutCase _ | IsFix _ | IsCoFix _) -> false - | (DLAMV(_,vc1),[]),(DLAMV(_,vc2),[]) -> - array_for_all2 (evar_conv_x env isevars pbty) vc1 vc2 - | _ -> false and conv_record env isevars (c,bs,(xs,xs1),(us,us1),(ts,ts1),t) = let ks = diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml index 804d635db..2d35fb753 100644 --- a/pretyping/evarutil.ml +++ b/pretyping/evarutil.ml @@ -5,7 +5,7 @@ open Util open Pp open Names open Univ -open Generic +(*i open Generic i*) open Term open Sign open Environ @@ -57,11 +57,15 @@ let new_isevar_sign env sigma typ instance = any type has type Type. May cause some trouble, but not so far... *) let dummy_sort = mkType dummy_univ +let make_instance env = + fold_var_context + (fun env (id, b, _) l -> if b=None then mkVar id :: l else l) + env [] + (* Declaring any type to be in the sort Type shouldn't be harmful since cumulativity now includes Prop and Set in Type. *) let new_type_var env sigma = - let sign = var_context env in - let instance = List.map mkVar (ids_of_var_context sign) in + let instance = make_instance env in let (sigma',c) = new_isevar_sign env sigma dummy_sort instance in (sigma', c) @@ -74,7 +78,7 @@ let split_evar_to_arrow sigma c = let nvar = next_ident_away (id_of_string "x") (ids_of_var_context hyps) in let newenv = push_var_decl (nvar,make_typed dom (Type dummy_univ)) evenv in let (sigma2,rng) = new_type_var newenv sigma1 in - let prod = mkProd (named_hd newenv dom Anonymous) dom (subst_var nvar rng) in + let prod = mkProd (named_hd newenv dom Anonymous, dom, subst_var nvar rng) in let sigma3 = Evd.define sigma2 ev prod in let dsp = num_of_evar dom in let rsp = num_of_evar rng in @@ -109,7 +113,7 @@ let do_restrict_hyps sigma c = in let sign' = List.rev rsign in let env' = change_hyps (fun _ -> sign') env in - let instance = List.map mkVar (ids_of_var_context sign') in + let instance = make_instance env' in let (sigma',nc) = new_isevar_sign env' sigma evd.evar_concl instance in let sigma'' = Evd.define sigma' ev nc in (sigma'', nc) @@ -188,14 +192,34 @@ let real_clean isevars sp args rhs = | DOP1(o,a) -> DOP1(o, subs k a) | DOP2(o,a,b) -> DOP2(o, subs k a, subs k b) | DOPN(o,v) -> restrict_hyps isevars (DOPN(o, Array.map (subs k) v)) - | DOPL(o,l) -> DOPL(o, List.map (subs k) l) | DLAM(n,a) -> DLAM(n, subs (k+1) a) - | DLAMV(n,v) -> DLAMV(n, Array.map (subs (k+1)) v) in + | DLAMV(n,v) -> DLAMV(n, Array.map (subs (k+1)) v) + | CLam (n,t,c) -> CLam (n, typed_app (subs k) t, subs (k+1) c) + | CPrd (n,t,c) -> CPrd (n, typed_app (subs k) t, subs (k+1) c) + | CLet (n,b,t,c) -> CLet (n, subs k b, typed_app (subs k) t, subs (k+1) c) + in let body = subs 0 rhs in (* if not (closed0 body) then error_not_clean CCI empty_env sp body; *) body - +let make_instance_with_rel env = + let n = rel_context_length (rel_context env) in + let vars = + fold_var_context + (fun env (id,b,_) l -> if b=None then mkVar id :: l else l) + env [] in + snd (fold_rel_context + (fun env (_,b,_) (i,l) -> (i-1, if b=None then mkRel i :: l else l)) + env (n+1,vars)) + +let make_subst env args = + snd (fold_var_context + (fun env (id,b,c) (args,l as g) -> + match b, args with + | None, a::rest -> (rest, (id,a)::l) + | Some _, _ -> g + | _ -> anomaly "Instance does not match its signature") + env (List.rev args,[])) (* [new_isevar] declares a new existential in an env env with type typ *) (* Converting the env into the sign of the evar to define *) @@ -203,9 +227,7 @@ let real_clean isevars sp args rhs = let new_isevar isevars env typ k = let subst,env' = push_rels_to_vars env in let typ' = substl subst typ in - let instance = - (List.rev (rel_list 0 (rel_context_length (rel_context env)))) - @(List.map mkVar (ids_of_var_context (var_context env))) in + let instance = make_instance_with_rel env in let (sigma',evar) = new_isevar_sign env' !isevars typ' instance in isevars := sigma'; evar @@ -233,9 +255,8 @@ let evar_define isevars lhs rhs = let args = List.map (function (VAR _ | Rel _) as t -> t | _ -> mkImplicit) (Array.to_list argsv) in let evd = ise_map isevars ev in - let hyps = var_context evd.evar_env in (* the substitution to invert *) - let worklist = List.combine (ids_of_var_context hyps) args in + let worklist = make_subst evd.evar_env args in let body = real_clean isevars ev worklist rhs in ise_define isevars ev body; [ev] @@ -306,30 +327,21 @@ let rec solve_simple_eqn conv_algo isevars ((pbty,t1,t2) as pb) = let has_undefined_isevars isevars c = - let rec hasrec = function - | DOPN(Evar ev,cl) as k -> - if ise_in_dom isevars ev then - if ise_defined isevars k then - hasrec (existential_value !isevars (ev,cl)) - else - failwith "caught" - else - Array.iter hasrec cl - | DOP1(_,c) -> hasrec c - | DOP2(_,c1,c2) -> (hasrec c1; hasrec c2) - | DOPL(_,l) -> List.iter hasrec l - | DOPN(_,cl) -> Array.iter hasrec cl - | DLAM(_,c) -> hasrec c - | DLAMV(_,cl) -> Array.iter hasrec cl - | (VAR _|Rel _|DOP0 _) -> () + let rec hasrec k = match splay_constr k with + | OpEvar ev, cl when ise_in_dom isevars ev -> + if ise_defined isevars k then + hasrec (existential_value !isevars (ev,cl)) + else + failwith "caught" + | _, cl -> Array.iter hasrec cl in (try (hasrec c ; false) with Failure "caught" -> true) let head_is_exist isevars = - let rec hrec = function - | DOPN(Evar _,_) as k -> ise_undefined isevars k - | DOPN(AppL,cl) -> hrec (array_hd cl) - | DOP2(Cast,c,_) -> hrec c + let rec hrec k = match kind_of_term k with + | IsEvar _ -> ise_undefined isevars k + | IsAppL (f,l) -> hrec f + | IsCast (c,_) -> hrec c | _ -> false in hrec @@ -399,15 +411,17 @@ let mk_valcon c = Some c let split_tycon loc env isevars = function | None -> None,None | Some c -> - (match whd_betadeltaiota env !isevars c with - | DOP2(Prod,dom,DLAM(na,rng)) -> - Some dom, Some rng - | t when ise_undefined isevars t -> - let (sigma,dom,rng) = split_evar_to_arrow !isevars t in - isevars := sigma; - Some dom, Some rng + let t = whd_betadeltaiota env !isevars c in + match kind_of_term t with + | IsProd (na,dom,rng) -> Some dom, Some rng | _ -> - Stdpp.raise_with_loc loc (Type_errors.TypeError (CCI,env,Type_errors.NotProduct c))) + if ise_undefined isevars t then + let (sigma,dom,rng) = split_evar_to_arrow !isevars t in + isevars := sigma; + Some dom, Some rng + else + Stdpp.raise_with_loc loc + (Type_errors.TypeError (CCI,env,Type_errors.NotProduct c)) let valcon_of_tycon x = x diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index c2770f196..09dd23065 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -4,7 +4,7 @@ open Pp open Util open Names -open Generic +(*i open Generic i*) open Sign open Evd open Term @@ -27,34 +27,37 @@ open Coercion open Inductive open Instantiate +(* (* Pour le vieux "match" que Program utilise encore, vieille histoire ... *) (* Awful special reduction function which skips abstraction on Xtra in order to be safe for Program ... *) let stacklamxtra recfun = - let rec lamrec sigma p_0 p_1 = match p_0,p_1 with - | (stack, (DOP2(Lambda,DOP1(XTRA "COMMENT",_),DLAM(_,c)) as t)) -> + let rec lamrec sigma s t = match s,kind_of_term t with + | (stack, IsLambda (_,DOP1(XTRA "COMMENT",_),_)) -> recfun stack (substl sigma t) - | ((h::t), (DOP2(Lambda,_,DLAM(_,c)))) -> lamrec (h::sigma) t c - | (stack, t) -> recfun stack (substl sigma t) + | ((h::t), IsLambda (_,_,c)) -> lamrec (h::sigma) t c + | (stack, _) -> recfun stack (substl sigma t) in lamrec let rec whrec x stack = - match x with - | DOP2(Lambda,DOP1(XTRA "COMMENT",c),DLAM(name,t)) -> + match kind_of_term x with + | IsLambda (name, DOP1(XTRA "COMMENT",c),t) -> let t' = applist (whrec t (List.map (lift 1) stack)) in - DOP2(Lambda,DOP1(XTRA "COMMENT",c),DLAM(name,t')),[] - | DOP2(Lambda,c1,DLAM(name,c2)) -> + mkLambda (name,DOP1(XTRA "COMMENT",c),t'),[] + | IsLambda (name,c1,c2) -> (match stack with - | [] -> (DOP2(Lambda,c1,DLAM(name,whd_betaxtra c2)),[]) + | [] -> mkLambda (name,c1,whd_betaxtra c2),[] | a1::rest -> stacklamxtra (fun l x -> whrec x l) [a1] rest c2) - | DOPN(AppL,cl) -> whrec (array_hd cl) (array_app_tl cl stack) - | DOP2(Cast,c,_) -> whrec c stack - | x -> x,stack + | IsAppL (f,args) -> whrec f (args@stack) + | IsCast (c,_) -> whrec c stack + | _ -> x,stack and whd_betaxtra x = applist(whrec x []) +*) +let whd_betaxtra = whd_beta let lift_context n l = let k = List.length l in @@ -111,10 +114,8 @@ let transform_rec loc env sigma (p,c,lf) (indt,pt) = applist (whd_beta_stack (lift (nar+1) p) (rel_list 1 nar))))) lnames in - let fix = DOPN(Fix([|nar|],0), - [|typPfix; - DLAMV(Name(id_of_string "F"),[|deffix|])|]) - in + let fix = mkFix (([|nar|],0), + ([|typPfix|],[Name(id_of_string "F")],[|deffix|])) in applist (fix,realargs@[c]) else let ci = make_default_case_info mispec in @@ -217,31 +218,9 @@ let pretype_ref pretype loc isevars env lvar = function make_judge (mkConst cst) (type_of_constant env !isevars cst) | RAbst sp -> failwith "Pretype: abst doit disparaître" -(* - if sp = let_path then - (match Array.to_list cl with - [m;DLAM(na,b)] -> - let mj = pretype empty_tycon isevars env m in - (try - let mj = inh_ass_of_j isevars env mj in - let mb = body_of_type mj in - let bj = - pretype empty_tycon (push_rel (na,mj) env) isevars b in - {uj_val = DOPN(Abst sp,[|mb;DLAM(na,bj.uj_val)|]); - uj_type = sAPP (DLAM(na,bj.uj_type)) mb; - uj_kind = pop bj.uj_kind } - with UserError _ -> - pretype vtcon isevars env (abst_value cstr)) - | _ -> errorlabstrm "Trad.constr_of_com" [< 'sTR"Malformed ``let''" >]) - else if evaluable_abst cstr then - pretype vtcon isevars env (abst_value cstr) - else error "Cannot typecheck an unevaluable abstraction" -*) + | REVar (sp,ctxt) -> error " Not able to type terms with dependent subgoals" -(* Not able to type goal existential yet - let cstr = mkConst (sp,ctxt_of_ids ids) in - make_judge cstr (type_of_existential env !isevars cstr) -*) + | RInd (ind_sp,ctxt) -> let ind = (ind_sp,Array.map pretype ctxt) in make_judge (mkMutInd ind) (type_of_inductive env !isevars ind) @@ -285,16 +264,6 @@ match cstr with (* Oů teste-t-on que le résultat doit satisfaire tycon ? *) | RHole loc -> if !compter then nbimpl:=!nbimpl+1; -(* OLD - (match vtcon with - (true,(Some v, _)) -> - {uj_val=v.utj_val; uj_type=make_typed (mkSort v.utj_type) (Type Univ.dummy_univ)} - | (false,(None,Some ty)) -> - let c = new_isevar isevars env ty CCI in - {uj_val=c;uj_type=make_typed ty (Type Univ.dummy_univ)} - | (true,(None,None)) -> - let ty = mkCast dummy_sort dummy_sort in -*) (match tycon with | Some ty -> let c = new_isevar isevars env ty CCI in @@ -328,7 +297,7 @@ match cstr with (* Oů teste-t-on que le résultat doit satisfaire tycon ? *) let fix = (vni,(larav,List.rev lfi,Array.map j_val_only vdefj)) in check_fix env !isevars fix; make_judge (mkFix fix) lara.(i) - | RCofix i -> + | RCoFix i -> let cofix = (i,(larav,List.rev lfi,Array.map j_val_only vdefj)) in check_cofix env !isevars cofix; make_judge (mkCoFix cofix) lara.(i)) @@ -365,6 +334,13 @@ match cstr with (* Oů teste-t-on que le résultat doit satisfaire tycon ? *) (try fst (gen_rel env !isevars name assum j') with TypeError _ as e -> Stdpp.raise_with_loc loc e) +| RBinder(loc,BLetIn,name,c1,c2) -> + let j = pretype empty_tycon env isevars lvar lmeta c1 in + let var = (name,j.uj_val,j.uj_type) in + let j' = pretype tycon (push_rel_def var env) isevars lvar lmeta c2 in + { uj_val = mkLetIn (name, j.uj_val, body_of_type j.uj_type, j'.uj_val) ; + uj_type = typed_app (subst1 j.uj_val) j'.uj_type } + | ROldCase (loc,isrec,po,c,lf) -> let cj = pretype empty_tycon env isevars lvar lmeta c in let (IndType (indf,realargs) as indt) = @@ -427,7 +403,7 @@ match cstr with (* Oů teste-t-on que le résultat doit satisfaire tycon ? *) let ci = make_default_case_info mis in mkMutCaseA ci pj.uj_val cj.uj_val (Array.map (fun j-> j.uj_val) lfj) in - let s = destSort (snd (splay_prod env !isevars evalPt)) in + let s = snd (splay_arity env !isevars evalPt) in {uj_val = v; uj_type = make_typed rsty s } diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index fe7830620..10c7cee07 100755 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -11,7 +11,7 @@ open Library open Classops (* open Pp_control -open Generic +(*i open Generic i*) open Initial *) diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli index 5872bd922..0f90afeb5 100755 --- a/pretyping/recordops.mli +++ b/pretyping/recordops.mli @@ -4,7 +4,7 @@ (*i*) open Names open Term -open Generic +(*i open Generic i*) open Classops open Libobject open Library diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index 72a3d3d51..aa499fb63 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -5,7 +5,7 @@ open Util open Term open Inductive open Names -open Generic +(*i open Generic i*) open Reduction open Environ open Typeops @@ -13,15 +13,15 @@ open Typeops type metamap = (int * constr) list let outsort env sigma t = - match whd_betadeltaiota env sigma t with - DOP0(Sort s) -> s + match kind_of_term (whd_betadeltaiota env sigma t) with + | IsSort s -> s | _ -> anomaly "Retyping: found a type of type which is not a sort" let rec subst_type env sigma typ = function - [] -> typ + | [] -> typ | h::rest -> - match whd_betadeltaiota env sigma typ with - DOP2(Prod,c1,DLAM(_,c2)) -> subst_type env sigma (subst1 h c2) rest + match kind_of_term (whd_betadeltaiota env sigma typ) with + IsProd (_,c1,c2) -> subst_type env sigma (subst1 h c2) rest | _ -> anomaly "Non-functional construction" (* Si ft est le type d'un terme f, lequel est appliqué ŕ args, *) @@ -31,16 +31,16 @@ let rec subst_type env sigma typ = function let sort_of_atomic_type env sigma ft args = let rec concl_of_arity ar = - match whd_betadeltaiota env sigma ar with - | DOP2 (Prod, _, DLAM (_, b)) -> concl_of_arity b - | DOP0 (Sort s) -> s + match kind_of_term (whd_betadeltaiota env sigma ar) with + | IsProd (_, _, b) -> concl_of_arity b + | IsSort s -> s | _ -> outsort env sigma (subst_type env sigma ft args) in concl_of_arity ft let typeur sigma metamap = let rec type_of env cstr= match kind_of_term cstr with - IsMeta n -> + | IsMeta n -> (try strip_outer_cast (List.assoc n metamap) with Not_found -> anomaly "type_of: this is not a well-typed term") | IsRel n -> lift n (body_of_type (snd (lookup_rel_type n env))) @@ -65,14 +65,17 @@ let rec type_of env cstr= whd_betadeltaiota env sigma (applist (p,al)) | IsLambda (name,c1,c2) -> let var = make_typed c1 (sort_of env c1) in - mkProd name c1 (type_of (push_rel_decl (name,var) env) c2) + mkProd (name, c1, type_of (push_rel_decl (name,var) env) c2) + | IsLetIn (name,b,c1,c2) -> + let var = make_typed c1 (sort_of env c1) in + subst1 b (type_of (push_rel_def (name,b,var) env) c2) | IsFix ((vn,i),(lar,lfi,vdef)) -> lar.(i) | IsCoFix (i,(lar,lfi,vdef)) -> lar.(i) | IsAppL(f,args)-> strip_outer_cast (subst_type env sigma (type_of env f) args) | IsCast (c,t) -> t | IsSort _ | IsProd (_,_,_) | IsMutInd _ -> mkSort (sort_of env cstr) - | _ -> error "type_of: Unexpected constr" + | IsXtra _ -> error "type_of: Unexpected constr" and sort_of env t = match kind_of_term t with diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index a0fe84ee6..16eebbefb 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -4,7 +4,7 @@ open Pp open Util open Names -open Generic +(*i open Generic i*) open Term open Inductive open Environ @@ -48,8 +48,10 @@ let make_elim_fun f lv n largs = let fi = DOPN(Const(make_path (dirpath sp) id (kind_of_path sp)),args) in list_fold_left_i (fun i c (k,a) -> - DOP2(Lambda,(substl (rev_firstn_liftn (n-k) (-i) la') a), - DLAM(Name(id_of_string"x"),c))) 0 (applistc fi la') lv + mkLambda (Name(id_of_string"x"), + substl (rev_firstn_liftn (n-k) (-i) la') a, + c)) + 0 (applistc fi la') lv (* [f] is convertible to [DOPN(Fix(recindices,bodynum),bodyvect)] make the reduction using this extra information *) @@ -145,120 +147,124 @@ let rec red_elim_const env sigma k largs = | _ -> raise Redelimination and construct_const env sigma c stack = - let rec hnfstack x stack = - match x with - | (DOPN(Const _,_)) as k -> + let rec hnfstack (x, stack as s) = + match kind_of_term x with + | IsConst _ -> (try - let (c',lrest) = red_elim_const env sigma k stack in - hnfstack c' lrest + hnfstack (red_elim_const env sigma x stack) with Redelimination -> - if evaluable_constant env k then - let cval = constant_value env k in + if evaluable_constant env x then + let cval = constant_value env x in (match cval with - | DOPN (CoFix _,_) -> (k,stack) - | _ -> hnfstack cval stack) + | DOPN (CoFix _,_) -> s + | _ -> hnfstack (cval, stack)) else raise Redelimination) +(* | (DOPN(Abst _,_) as a) -> if evaluable_abst env a then hnfstack (abst_value env a) stack else raise Redelimination - | DOP2(Cast,c,_) -> hnfstack c stack - | DOPN(AppL,cl) -> hnfstack (array_hd cl) (array_app_tl cl stack) - | DOP2(Lambda,_,DLAM(_,c)) -> +*) + | IsCast (c,_) -> hnfstack (c, stack) + | IsAppL (f,cl) -> hnfstack (f, cl@stack) + | IsLambda (_,_,c) -> (match stack with | [] -> assert false | c'::rest -> stacklam hnfstack [c'] c rest) - | DOPN(MutCase _,_) as c_0 -> - let (ci,p,c,lf) = destCase c_0 in + | IsMutCase (ci,p,c,lf) -> hnfstack - (special_red_case env (construct_const env sigma) p c ci lf) - stack - | DOPN(MutConstruct _,_) as c_0 -> c_0,stack - | DOPN(CoFix _,_) as c_0 -> c_0,stack - | DOPN(Fix (_) ,_) as fix -> - let (reduced,(fix,stack')) = reduce_fix hnfstack fix stack in - if reduced then hnfstack fix stack' else raise Redelimination + (special_red_case env (construct_const env sigma) p c ci lf, stack) + | IsMutConstruct _ -> s + | IsCoFix _ -> s + | IsFix fix -> + (match reduce_fix hnfstack fix stack with + | Reduced s' -> hnfstack s' + | NotReducible -> raise Redelimination) | _ -> raise Redelimination in - hnfstack c stack + hnfstack (c, stack) (* Hnf reduction tactic: *) let hnf_constr env sigma c = - let rec redrec x largs = - match x with - | DOP2(Lambda,t,DLAM(n,c)) -> + let rec redrec (x, largs as s) = + match kind_of_term x with + | IsLambda (n,t,c) -> (match largs with - | [] -> applist(x,largs) + | [] -> applist s | a::rest -> stacklam redrec [a] c rest) - | DOPN(AppL,cl) -> redrec (array_hd cl) (array_app_tl cl largs) - | DOPN(Const _,_) -> + | IsAppL (f,cl) -> redrec (f, cl@largs) + | IsConst _ -> (try let (c',lrest) = red_elim_const env sigma x largs in - redrec c' lrest + redrec (c', lrest) with Redelimination -> if evaluable_constant env x then let c = constant_value env x in (match c with | DOPN(CoFix _,_) -> applist(x,largs) - | _ -> redrec c largs) + | _ -> redrec (c, largs)) else - applist(x,largs)) + applist s) +(* | DOPN(Abst _,_) -> if evaluable_abst env x then redrec (abst_value env x) largs else - applist(x,largs) - | DOP2(Cast,c,_) -> redrec c largs - | DOPN(MutCase _,_) -> - let (ci,p,c,lf) = destCase x in + applist s +*) + | IsCast (c,_) -> redrec (c, largs) + | IsMutCase (ci,p,c,lf) -> (try redrec (special_red_case env (whd_betadeltaiota_stack env sigma) - p c ci lf) largs + p c ci lf, largs) with Redelimination -> - applist(x,largs)) - | (DOPN(Fix _,_)) -> - let (reduced,(fix,stack)) = - reduce_fix (whd_betadeltaiota_stack env sigma) x largs - in - if reduced then redrec fix stack else applist(x,largs) - | _ -> applist(x,largs) + applist s) + | IsFix fix -> + (match reduce_fix + (fun (c,l) -> whd_betadeltaiota_stack env sigma c l) + fix largs + with + | Reduced s' -> redrec s' + | NotReducible -> applist s) + | _ -> applist s in - redrec c [] + redrec (c, []) (* Simpl reduction tactic: same as simplify, but also reduces elimination constants *) let whd_nf env sigma c = - let rec nf_app c stack = - match c with - | DOP2(Lambda,c1,DLAM(name,c2)) -> + let rec nf_app (c, stack as s) = + match kind_of_term c with + | IsLambda (name,c1,c2) -> (match stack with | [] -> (c,[]) | a1::rest -> stacklam nf_app [a1] c2 rest) - | DOPN(AppL,cl) -> nf_app (array_hd cl) (array_app_tl cl stack) - | DOP2(Cast,c,_) -> nf_app c stack - | DOPN(Const _,_) -> + | IsAppL (f,cl) -> nf_app (f, cl@stack) + | IsCast (c,_) -> nf_app (c, stack) + | IsConst _ -> (try - let (c',lrest) = red_elim_const env sigma c stack in - nf_app c' lrest + nf_app (red_elim_const env sigma c stack) with Redelimination -> - (c,stack)) - | DOPN(MutCase _,_) -> - let (ci,p,d,lf) = destCase c in + s) + | IsMutCase (ci,p,d,lf) -> (try - nf_app (special_red_case env nf_app p d ci lf) stack + nf_app + (special_red_case env (fun c l -> nf_app (c,l)) p d ci lf, + stack) with Redelimination -> - (c,stack)) - | DOPN(Fix _,_) -> - let (reduced,(fix,rest)) = reduce_fix nf_app c stack in - if reduced then nf_app fix rest else (fix,stack) - | _ -> (c,stack) + s) + | IsFix fix -> + (match reduce_fix nf_app fix stack with + | Reduced s' -> nf_app s' + | NotReducible -> s) + | _ -> s in - applist (nf_app c []) + applist (nf_app (c, [])) let nf env sigma c = strong whd_nf env sigma c @@ -286,65 +292,66 @@ let reduction_of_redexp = function (* Used in several tactics. *) -let one_step_reduce env sigma = - let rec redrec largs x = - match x with - | DOP2(Lambda,t,DLAM(n,c)) -> +let one_step_reduce env sigma c = + let rec redrec (x, largs as s) = + match kind_of_term x with + | IsLambda (n,t,c) -> (match largs with | [] -> error "Not reducible 1" | a::rest -> applistc (subst1 a c) rest) - | DOPN(AppL,cl) -> redrec (array_app_tl cl largs) (array_hd cl) - | DOPN(Const _,_) -> + | IsAppL (f,cl) -> redrec (f, cl@largs) + | IsConst _ -> (try let (c',l) = red_elim_const env sigma x largs in applistc c' l with Redelimination -> if evaluable_constant env x then applistc (constant_value env x) largs else error "Not reductible 1") +(* | DOPN(Abst _,_) -> if evaluable_abst env x then applistc (abst_value env x) largs else error "Not reducible 0" - | DOPN(MutCase _,_) -> - let (ci,p,c,lf) = destCase x in +*) + | IsMutCase (ci,p,c,lf) -> (try applistc (special_red_case env (whd_betadeltaiota_stack env sigma) p c ci lf) largs with Redelimination -> error "Not reducible 2") - | DOPN(Fix _,_) -> - let (reduced,(fix,stack)) = - reduce_fix (whd_betadeltaiota_stack env sigma) x largs - in - if reduced then applistc fix stack else error "Not reducible 3" - | DOP2(Cast,c,_) -> redrec largs c + | IsFix fix -> + (match reduce_fix + (fun (x,l) -> whd_betadeltaiota_stack env sigma x l) + fix largs + with + | Reduced s' -> applist s' + | NotReducible -> error "Not reducible 3") + | IsCast (c,_) -> redrec (c,largs) | _ -> error "Not reducible 3" in - redrec [] + redrec (c, []) (* put t as t'=(x1:A1)..(xn:An)B with B an inductive definition of name name return name, B and t' *) let reduce_to_mind env sigma t = let rec elimrec t l = - match whd_castapp_stack t [] with - | (DOPN(MutInd mind,args),_) -> ((mind,args),t,prod_it t l) - | (DOPN(Const _,_),_) -> - (try - let t' = nf_betaiota env sigma (one_step_reduce env sigma t) in - elimrec t' l - with UserError _ -> errorlabstrm "tactics__reduce_to_mind" - [< 'sTR"Not an inductive product : it is a constant." >]) - | (DOPN(MutCase _,_),_) -> + let c, _ = whd_castapp_stack t [] in + match kind_of_term c with + | IsMutInd (mind,args) -> ((mind,args),t,it_mkProd_or_LetIn t l) + | IsConst _ | IsMutCase _ -> (try let t' = nf_betaiota env sigma (one_step_reduce env sigma t) in elimrec t' l with UserError _ -> errorlabstrm "tactics__reduce_to_mind" - [< 'sTR"Not an inductive product:"; 'sPC; - 'sTR"it is a case analysis term" >]) - | (DOP2(Cast,c,_),[]) -> elimrec c l - | (DOP2(Prod,ty,DLAM(n,t')),[]) -> elimrec t' ((n,ty)::l) + [< 'sTR"Not an inductive product." >]) + | IsProd (n,ty,t') -> + let ty' = Retyping.get_assumption_of (Global.env()) Evd.empty ty in + elimrec t' ((n,None,ty')::l) + | IsLetIn (n,b,ty,t') -> + let ty' = Retyping.get_assumption_of (Global.env()) Evd.empty ty in + elimrec t' ((n,Some b,ty')::l) | _ -> error "Not an inductive product" - in + in elimrec t [] let reduce_to_ind env sigma t = diff --git a/pretyping/typing.ml b/pretyping/typing.ml index 0dc0d0a5b..5dfcfdce3 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -3,7 +3,7 @@ open Util open Names -open Generic +(*i open Generic i*) open Term open Environ open Reduction @@ -105,7 +105,15 @@ let rec execute mf env sigma cstr = let j' = execute mf env1 sigma c2 in let (j,_) = gen_rel env1 sigma name varj j' in j - + + | IsLetIn (name,c1,c2,c3) -> + let j1 = execute mf env sigma c1 in + let j2 = execute mf env sigma c2 in + let { uj_val = b; uj_type = t } = cast_rel env sigma j1 j2 in + let j3 = execute mf (push_rel_def (name,b,t) env) sigma c3 in + { uj_val = mkLetIn (name, j1.uj_val, j2.uj_val, j3.uj_val) ; + uj_type = typed_app (subst1 j1.uj_val) j3.uj_type } + | IsCast (c,t) -> let cj = execute mf env sigma c in let tj = execute mf env sigma t in diff --git a/proofs/clenv.ml b/proofs/clenv.ml index 4c2cbf987..ab301c450 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -4,7 +4,7 @@ open Pp open Util open Names -open Generic +(*i open Generic i*) open Term open Sign open Instantiate @@ -35,30 +35,26 @@ type wc = walking_constraints let new_evar_in_sign env = let ids = ids_of_var_context (Environ.var_context env) in let ev = new_evar () in - DOPN(Evar ev, Array.of_list (List.map (fun id -> VAR id) ids)) + mkEvar (ev, Array.of_list (List.map (fun id -> VAR id) ids)) -let rec whd_evar env sigma = function - | DOPN(Evar ev,_) as k -> - if is_defined sigma ev then - whd_evar env sigma (constant_value env k) - else - collapse_appl k - | t -> - collapse_appl t +let rec whd_evar sigma t = match kind_of_term t with + | IsEvar (ev,_ as evc) when is_defined sigma ev -> + whd_evar sigma (existential_value sigma evc) + | _ -> collapse_appl t let applyHead n c wc = let rec apprec n c cty wc = if n = 0 then (wc,c) else - match w_whd_betadeltaiota wc cty with - | DOP2(Prod,c1,DLAM(_,c2)) -> + match kind_of_term (w_whd_betadeltaiota wc cty) with + | IsProd (_,c1,c2) -> let c1ty = w_type_of wc c1 in let evar = new_evar_in_sign (w_env wc) in let (evar_n, _) = destEvar evar in (compose (apprec (n-1) (applist(c,[evar])) (subst1 evar c2)) - (w_Declare evar_n (DOP2(Cast,c1,c1ty)))) + (w_Declare evar_n (c1,c1ty))) wc | _ -> error "Apply_Head_Then" in @@ -82,77 +78,63 @@ let unify_0 mc wc m n = let env = w_env wc and sigma = w_Underlying wc in let rec unirec_rec ((metasubst,evarsubst) as substn) m n = - let cM = whd_evar env sigma m - and cN = whd_evar env sigma n in + let cM = whd_evar sigma m + and cN = whd_evar sigma n in try - match (cM,cN) with - | DOP2(Cast,c,_),t2 -> unirec_rec substn c t2 - | t1,DOP2(Cast,c,_) -> unirec_rec substn t1 c - | DOP0(Meta k),_ -> (k,cN)::metasubst,evarsubst - | cM,DOP0(Meta(k)) -> (k,cM)::metasubst,evarsubst - | DOP2(Lambda,t1,DLAM(_,c1)),DOP2(Lambda,t2,DLAM(_,c2)) -> + match (kind_of_term cM,kind_of_term cN) with + | IsCast (c,_), _ -> unirec_rec substn c cN + | _, IsCast (c,_) -> unirec_rec substn cM c + | IsMeta k, _ -> (k,cN)::metasubst,evarsubst + | _, IsMeta k -> (k,cM)::metasubst,evarsubst + | IsLambda (_,t1,c1), IsLambda (_,t2,c2) -> unirec_rec (unirec_rec substn t1 t2) c1 c2 - | DOP2(Prod,t1,DLAM(_,c1)),DOP2(Prod,t2,DLAM(_,c2)) -> + | IsProd (_,t1,c1), IsProd (_,t2,c2) -> unirec_rec (unirec_rec substn t1 t2) c1 c2 - | DOPN(AppL,cl1),DOPN(AppL,cl2) -> - let len1 = Array.length cl1 - and len2 = Array.length cl2 in + | IsAppL (f1,l1), IsAppL (f2,l2) -> + let len1 = List.length l1 + and len2 = List.length l2 in if len1 = len2 then - array_fold_left2 unirec_rec substn cl1 cl2 + List.fold_left2 unirec_rec (unirec_rec substn f1 f2) l1 l2 else if len1 < len2 then - let extras,restcl2 = array_chop ((len2-len1)+1) cl2 in - array_fold_left2 unirec_rec - (unirec_rec substn (array_hd cl1) (DOPN(AppL,extras))) - (array_tl cl1) restcl2 + let extras,restl2 = list_chop (len2-len1) l2 in + List.fold_left2 unirec_rec + (unirec_rec substn f1 (applist (f2,extras))) + l1 restl2 else - let extras,restcl1 = array_chop ((len1-len2)+1) cl1 in - array_fold_left2 unirec_rec - (unirec_rec substn (DOPN(AppL,extras)) (array_hd cl2)) - restcl1 (array_tl cl2) + let extras,restl1 = list_chop (len1-len2) l1 in + List.fold_left2 unirec_rec + (unirec_rec substn (applist (f1,extras)) f2) + restl1 l2 - | DOPN(MutCase _,_),DOPN(MutCase _,_) -> - let (_,p1,c1,cl1) = destCase cM - and (_,p2,c2,cl2) = destCase cN in - if Array.length cl1 = Array.length cl2 then - array_fold_left2 unirec_rec - (unirec_rec (unirec_rec substn p1 p2) c1 c2) cl1 cl2 - else - error_cannot_unify CCI (m,n) + | IsMutCase (_,p1,c1,cl1), IsMutCase (_,p2,c2,cl2) -> + array_fold_left2 unirec_rec + (unirec_rec (unirec_rec substn p1 p2) c1 c2) cl1 cl2 - | DOPN(MutConstruct _,_),DOPN(MutConstruct _,_) -> + | IsMutConstruct _, IsMutConstruct _ -> if is_conv env sigma cM cN then substn else error_cannot_unify CCI (m,n) - | DOPN(MutInd _,_),DOPN(MutInd _,_) -> + | IsMutInd _, IsMutInd _ -> if is_conv env sigma cM cN then substn else error_cannot_unify CCI (m,n) - | (DOPN(Evar _,_)),(DOPN((Const _ | Evar _),_)) -> + | IsEvar _, _ -> metasubst,((cM,cN)::evarsubst) - | (DOPN((Const _ | Evar _),_)),(DOPN(Evar _,_)) -> + | _, IsEvar _ -> metasubst,((cN,cM)::evarsubst) - | (DOPN(Const _,_)),(DOPN(Const _,_)) -> - if is_conv env sigma cM cN then - substn - else - error_cannot_unify CCI (m,n) - - | (DOPN(Evar _,_)),_ -> - metasubst,((cM,cN)::evarsubst) - | (DOPN(Const _,_)),_ -> + + | IsConst _, _ -> if is_conv env sigma cM cN then substn else error_cannot_unify CCI (m,n) - | _,(DOPN(Evar _,_)) -> - metasubst,((cN,cM)::evarsubst) - | _,(DOPN(Const _,_)) -> + | _, IsConst _ -> if (not (occur_meta cM)) & is_conv env sigma cM cN then substn else @@ -173,19 +155,16 @@ let unify_0 mc wc m n = unirec_rec (mc,[]) m n -let whd_castappevar_stack sigma = - let rec whrec x l = - match x with - | DOPN(Evar ev,args) as c -> - if is_defined sigma ev then - whrec (existential_value sigma (ev,args)) l - else - x,l - | DOP2(Cast,c,_) -> whrec c l - | DOPN(AppL,cl) -> whrec (array_hd cl) (array_app_tl cl l) - | x -> x,l +let whd_castappevar_stack sigma c l = + let rec whrec (c, l as s) = + match kind_of_term c with + | IsEvar (ev,args) when is_defined sigma ev -> + whrec (existential_value sigma (ev,args), l) + | IsCast (c,_) -> whrec (c, l) + | IsAppL (f,args) -> whrec (f, args@l) + | _ -> s in - whrec + whrec (c,l) let whd_castappevar sigma c = applist(whd_castappevar_stack sigma c []) @@ -247,27 +226,29 @@ let rec w_Unify m n mc wc = and w_resrec metas evars wc = match evars with | [] -> (wc,metas) - - | (lhs,(DOP0(Meta k) as rhs))::t -> w_resrec ((k,lhs)::metas) t wc - - | (DOPN(Evar evn,_) as evar,rhs)::t -> - if w_defined_evar wc evn then - let (wc',metas') = w_Unify rhs evar metas wc in - w_resrec metas' t wc' - else - (try - w_resrec metas t (w_Define evn rhs wc) - with ex when catchable_exception ex -> - (match rhs with - | DOPN(AppL,cl) -> - (match cl.(0) with - | DOPN(Const sp,_) -> - let wc' = mimick_evar cl.(0) - ((Array.length cl) - 1) evn wc in - w_resrec metas evars wc' - | _ -> error "w_Unify") - | _ -> error "w_Unify")) - | _ -> anomaly "w_resrec" + + | (lhs,rhs) :: t -> + match kind_of_term rhs with + + | IsMeta k -> w_resrec ((k,lhs)::metas) t wc + + | krhs -> + match kind_of_term lhs with + + | IsEvar (evn,_) -> + if w_defined_evar wc evn then + let (wc',metas') = w_Unify rhs lhs metas wc in + w_resrec metas' t wc' + else + (try + w_resrec metas t (w_Define evn rhs wc) + with ex when catchable_exception ex -> + (match krhs with + | IsAppL (f,cl) when isConst f -> + let wc' = mimick_evar f (List.length cl) evn wc in + w_resrec metas evars wc' + | _ -> error "w_Unify")) + | _ -> anomaly "w_resrec" (* [unifyTerms] et [unify] ne semble pas gérer les Meta, en @@ -284,30 +265,20 @@ let unify m gls = * repetitions and all. *) let collect_metas c = - let rec collrec c acc = - match c with - | DOP0(Meta mv) -> mv::acc - | DOP1(oper,c) -> collrec c acc - | DOP2(oper,c1,c2) -> collrec c1 (collrec c2 acc) - | DOPN(oper,cl) -> Array.fold_right collrec cl acc - | DLAM(_,c) -> collrec c acc - | DLAMV(_,v) -> Array.fold_right collrec v acc - | _ -> acc - in - collrec c [] + let rec collrec acc c = + match splay_constr c with + | OpMeta mv, _ -> mv::acc + | _, cl -> Array.fold_left collrec acc cl + in + List.rev (collrec [] c) let metavars_of c = - let rec collrec c acc = - match c with - | DOP0(Meta mv) -> Intset.add mv acc - | DOP1(oper,c) -> collrec c acc - | DOP2(oper,c1,c2) -> collrec c1 (collrec c2 acc) - | DOPN(oper,cl) -> Array.fold_right collrec cl acc - | DLAM(_,c) -> collrec c acc - | DLAMV(_,v) -> Array.fold_right collrec v acc - | _ -> acc + let rec collrec acc c = + match splay_constr c with + | OpMeta mv, _ -> Intset.add mv acc + | _, cl -> Array.fold_left collrec acc cl in - collrec c Intset.empty + collrec Intset.empty c let mk_freelisted c = { rebus = c; freemetas = metavars_of c } @@ -336,7 +307,7 @@ let mentions clenv mv0 = let mk_clenv wc cty = let mv = new_meta () in let cty_fls = mk_freelisted cty in - { templval = mk_freelisted(DOP0(Meta mv)); + { templval = mk_freelisted (mkMeta mv); templtyp = cty_fls; namenv = Intmap.empty; env = Intmap.add mv (Cltyp cty_fls) Intmap.empty ; @@ -344,12 +315,12 @@ let mk_clenv wc cty = let clenv_environments bound c = let rec clrec (ne,e,metas) n c = - match n,c with - | (0, hd) -> (ne,e,List.rev metas,hd) - | (n, (DOP2(Cast,c,_))) -> clrec (ne,e,metas) n c - | (n, (DOP2(Prod,c1,DLAM(na,c2)))) -> + match n, kind_of_term c with + | (0, _) -> (ne, e, List.rev metas, c) + | (n, IsCast (c,_)) -> clrec (ne,e,metas) n c + | (n, IsProd (na,c1,c2)) -> let mv = new_meta () in - let dep = dependent (Rel 1) c2 in + let dep = dependent (mkRel 1) c2 in let ne' = if dep then match na with @@ -365,18 +336,15 @@ let clenv_environments bound c = ne in let e' = Intmap.add mv (Cltyp (mk_freelisted c1)) e in - clrec (ne',e',DOP0(Meta mv)::metas) (n-1) - (if dep then (subst1 (DOP0(Meta mv)) c2) else c2) - | (n, hd) -> (ne,e,List.rev metas,hd) + clrec (ne',e', (mkMeta mv)::metas) (n-1) + (if dep then (subst1 (mkMeta mv) c2) else c2) + | (n, _) -> (ne, e, List.rev metas, c) in clrec (Intmap.empty,Intmap.empty,[]) bound c let mk_clenv_from wc (c,cty) = let (namenv,env,args,concl) = clenv_environments (-1) cty in - { templval = - mk_freelisted (match args with - | [] -> c - | _ -> DOPN(AppL,Array.of_list (c::args))); + { templval = mk_freelisted (match args with [] -> c | _ -> applist (c,args)); templtyp = mk_freelisted concl; namenv = namenv; env = env; @@ -433,12 +401,12 @@ let clenv_val_of clenv mv = let rec valrec mv = try (match Intmap.find mv clenv.env with - | Cltyp _ -> DOP0(Meta mv) + | Cltyp _ -> mkMeta mv | Clval(b,_) -> instance (List.map (fun mv' -> (mv',valrec mv')) (Intset.elements b.freemetas)) b.rebus) with Not_found -> - DOP0(Meta mv) + mkMeta mv in valrec mv @@ -461,16 +429,10 @@ let clenv_instance_term clenv c = let clenv_cast_meta clenv = let rec crec u = - match u with - | DOPN((AppL|MutCase _),_) -> crec_hd u - | DOP2(Cast,DOP0(Meta _),_) -> u - | DOPN(c,cl) -> DOPN(c,Array.map crec cl) - | DOPL(c,cl) -> DOPL(c,List.map crec cl) - | DOP1(c,t) -> DOP1(c,crec t) - | DOP2(c,t1,t2) -> DOP2(c,crec t1,crec t2) - | DLAM(n,c) -> DLAM(n,crec c) - | DLAMV(n,cl) -> DLAMV(n,Array.map crec cl) - | x -> x + match splay_constr u with + | (OpAppL | OpMutCase _), _ -> crec_hd u + | OpCast , [|c;_|] when isMeta c -> u + | op, cl -> gather_constr (op, Array.map crec cl) and crec_hd u = match kind_of_term (strip_outer_cast u) with @@ -479,7 +441,7 @@ let clenv_cast_meta clenv = match Intmap.find mv clenv.env with | Cltyp b -> let b' = clenv_instance clenv b in - if occur_meta b' then u else mkCast u b' + if occur_meta b' then u else mkCast (u, b') | Clval(_) -> u with Not_found -> u) @@ -569,30 +531,35 @@ let clenv_instance_type_of ce c = let clenv_merge with_types = let rec clenv_resrec metas evars clenv = match (evars,metas) with - | ([],[]) -> clenv - - | ((lhs,(DOP0(Meta k) as rhs))::t,metas) -> - clenv_resrec ((k,lhs)::metas) t clenv - - | ((DOPN(Evar evn,_) as evar,rhs)::t,metas) -> - if w_defined_const clenv.hook evar then - let (metas',evars') = unify_0 [] clenv.hook rhs evar in - clenv_resrec (metas'@metas) (evars'@t) clenv - else - (try - clenv_resrec metas t (clenv_wtactic (w_Define evn rhs) clenv) - with ex when catchable_exception ex -> - (match rhs with - | DOPN(AppL,cl) -> - (match cl.(0) with - | (DOPN(Const _,_) | DOPN(MutConstruct _,_)) -> - clenv_resrec metas evars - (clenv_wtactic (mimick_evar cl.(0) - ((Array.length cl) - 1) evn) - clenv) - | _ -> error "w_Unify") - | _ -> error "w_Unify")) - | ([],(mv,n)::t) -> + | ([], []) -> clenv + + | ((lhs,rhs)::t, metas) -> + (match kind_of_term rhs with + + | IsMeta k -> clenv_resrec ((k,lhs)::metas) t clenv + + | krhs -> + (match kind_of_term lhs with + + | IsEvar (evn,_) -> + if w_defined_evar clenv.hook evn then + let (metas',evars') = unify_0 [] clenv.hook rhs lhs in + clenv_resrec (metas'@metas) (evars'@t) clenv + else + (try + clenv_resrec metas t + (clenv_wtactic (w_Define evn rhs) clenv) + with ex when catchable_exception ex -> + (match krhs with + | IsAppL (f,cl) when isConst f or isMutConstruct f -> + clenv_resrec metas evars + (clenv_wtactic (mimick_evar f (List.length cl) evn) + clenv) + | _ -> error "w_Unify")) + + | _ -> anomaly "clenv_resrec")) + + | ([], (mv,n)::t) -> if clenv_defined clenv mv then let (metas',evars') = unify_0 [] clenv.hook (clenv_value clenv mv).rebus n in @@ -606,8 +573,6 @@ let clenv_merge with_types = else ([],[]) in clenv_resrec (mc@t) ec (clenv_assign mv n clenv) - | _ -> anomaly "clenv_resrec" - in clenv_resrec (* [clenv_unify M N clenv] @@ -707,39 +672,34 @@ let clenv_refine_cast kONT clenv gls = try to find a subterm of cl which matches op, if op is just a Meta FAIL because we cannot find a binding *) -let constrain_clenv_to_subterm clause = function - | (DOP0(Meta(_)) as op),_ -> error "Match_subterm" - | op,cl -> - let rec matchrec cl = - let cl = strip_outer_cast cl in - (try - if closed0 cl - then clenv_unify op cl clause,cl - else error "Bound 1" - with ex when catchable_exception ex -> - (match telescope_appl cl with - | DOPN(AppL,tl) -> - if Array.length tl = 2 then - let c1 = tl.(0) and c2 = tl.(1) in - (try - matchrec c1 - with ex when catchable_exception ex -> - matchrec c2) - else - error "Match_subterm" - | DOP2(Prod,t,DLAM(_,c)) -> - (try - matchrec t - with ex when catchable_exception ex -> - matchrec c) - | DOP2(Lambda,t,DLAM(_,c)) -> - (try - matchrec t - with ex when catchable_exception ex -> - matchrec c) - | _ -> error "Match_subterm")) - in - matchrec cl +let constrain_clenv_to_subterm clause (op,cl) = + let rec matchrec cl = + let cl = strip_outer_cast cl in + (try + if closed0 cl + then clenv_unify op cl clause,cl + else error "Bound 1" + with ex when catchable_exception ex -> + (match kind_of_term (telescope_appl cl) with + | IsAppL (c1,[c2]) -> + (try + matchrec c1 + with ex when catchable_exception ex -> + matchrec c2) + | IsProd (_,t,c) -> + (try + matchrec t + with ex when catchable_exception ex -> + matchrec c) + | IsLambda (_,t,c) -> + (try + matchrec t + with ex when catchable_exception ex -> + matchrec c) + | _ -> error "Match_subterm")) + in + if isMeta op then error "Match_subterm"; + matchrec cl (* Possibly gives K-terms in case the operator does not contain a meta : BUG ?? *) @@ -822,7 +782,7 @@ let clenv_constrain_missing_args mlist clause = let occlist = clenv_missing clause (clenv_template clause, (clenv_template_type clause)) in if List.length occlist = List.length mlist then - List.fold_left2 (fun clenv occ m -> clenv_unify (DOP0(Meta occ)) m clenv) + List.fold_left2 (fun clenv occ m -> clenv_unify (mkMeta occ) m clenv) clause occlist mlist else error ("Not the right number of missing arguments (expected " @@ -835,7 +795,7 @@ let clenv_constrain_dep_args mlist clause = let occlist = clenv_dependent clause (clenv_template clause, (clenv_template_type clause)) in if List.length occlist = List.length mlist then - List.fold_left2 (fun clenv occ m -> clenv_unify (DOP0(Meta occ)) m clenv) + List.fold_left2 (fun clenv occ m -> clenv_unify (mkMeta occ) m clenv) clause occlist mlist else error ("Not the right number of missing arguments (expected " @@ -848,7 +808,7 @@ let clenv_constrain_dep_args_of mv mlist clause = let occlist = clenv_dependent clause (clenv_value clause mv, clenv_type clause mv) in if List.length occlist = List.length mlist then - List.fold_left2 (fun clenv occ m -> clenv_unify (DOP0(Meta occ)) m clenv) + List.fold_left2 (fun clenv occ m -> clenv_unify (mkMeta occ) m clenv) clause occlist mlist else error ("clenv_constrain_dep_args_of: Not the right number " ^ @@ -913,7 +873,7 @@ let clenv_pose_dependent_evars clenv = let (evar_n,_) = destEvar evar in let tY = clenv_instance_type clenv mv in let tYty = w_type_of clenv.hook tY in - let clenv' = clenv_wtactic (w_Declare evar_n (DOP2(Cast,tY,tYty))) + let clenv' = clenv_wtactic (w_Declare evar_n (tY,tYty)) clenv in clenv_assign mv evar clenv') clenv @@ -968,13 +928,14 @@ let secondOrderAbstraction allow_K gl p oplist clause = let (clause',cllist) = constrain_clenv_using_subterm_list allow_K clause oplist (pf_concl gl) in let typp = clenv_instance_type clause' p in - clenv_unify (DOP0(Meta p)) + clenv_unify (mkMeta p) (abstract_list_all (pf_env gl) (project gl) typp (pf_concl gl) cllist) clause' let clenv_so_resolver allow_K clause gl = - match whd_castapp_stack (clenv_instance_template_type clause) [] with - | (DOP0(Meta(p)),oplist) -> + let c, oplist = whd_castapp_stack (clenv_instance_template_type clause) [] in + match kind_of_term c with + | IsMeta p -> let clause' = secondOrderAbstraction allow_K gl p oplist clause in clenv_fo_resolver clause' gl | _ -> error "clenv_so_resolver" @@ -991,9 +952,10 @@ let clenv_so_resolver allow_K clause gl = Meta(1) had meta-variables in it. *) let clenv_unique_resolver allow_K clenv gls = - match (whd_castapp_stack (clenv_instance_template_type clenv) [], - whd_castapp_stack (pf_concl gls) []) with - | ((DOP0(Meta _) as pathd,_),(DOP2(Lambda,_,_) as glhd,_)) -> + let pathd,_ = whd_castapp_stack (clenv_instance_template_type clenv) [] in + let glhd,_ = whd_castapp_stack (pf_concl gls) [] in + match kind_of_term pathd, kind_of_term glhd with + | IsMeta _, IsLambda _ -> (try clenv_typed_fo_resolver clenv gls with ex when catchable_exception ex -> @@ -1002,7 +964,7 @@ let clenv_unique_resolver allow_K clenv gls = with ex when catchable_exception ex -> error "Cannot solve a second-order unification problem") - | ((DOP0(Meta _),_),_) -> + | IsMeta _, _ -> (try clenv_so_resolver allow_K clenv gls with ex when catchable_exception ex -> diff --git a/proofs/evar_refiner.ml b/proofs/evar_refiner.ml index abfe2305d..5cb4689ae 100644 --- a/proofs/evar_refiner.ml +++ b/proofs/evar_refiner.ml @@ -5,7 +5,7 @@ open Pp open Util open Stamps open Names -open Generic +(*i open Generic i*) open Term open Environ open Evd @@ -120,11 +120,8 @@ let w_hyps wc = var_context (get_env (ids_it wc)) let w_ORELSE wt1 wt2 wc = try wt1 wc with e when catchable_exception e -> wt2 wc -let w_Declare sp c (wc : walking_constraints) = - begin match c with - | DOP2(Cast,_,_) -> () - | _ -> error "Cannot declare an un-casted evar" - end; +let w_Declare sp (ty,s) (wc : walking_constraints) = + let c = mkCast (ty,s) in let _ = w_type_of wc c in let access = get_focus (ids_it wc) and env = get_env (ids_it wc)in @@ -134,20 +131,15 @@ let w_Declare sp c (wc : walking_constraints) = let w_Declare_At sp sp' c = w_Focusing sp (w_Declare sp' c) let evars_of sigma constr = - let rec filtrec acc = function - | DOP0 oper -> acc - | VAR _ -> acc - | DOP1(oper,c) -> filtrec acc c - | DOP2(oper,c1,c2) -> filtrec (filtrec acc c1) c2 - | DOPN(Evar ev,cl) -> - let newacc = (Array.fold_left filtrec acc cl) in - if Evd.in_dom (ts_it sigma).decls ev - then Intset.add ev newacc else newacc - | DOPN(oper,cl) -> Array.fold_left filtrec acc cl - | DOPL(oper,cl) -> List.fold_left filtrec acc cl - | DLAM(_,c) -> filtrec acc c - | DLAMV(_,v) -> Array.fold_left filtrec acc v - | _ -> acc + let rec filtrec acc c = + match splay_constr c with + | OpEvar ev, cl -> + if Evd.in_dom (ts_it sigma).decls ev then + Intset.add ev (Array.fold_left filtrec acc cl) + else + Array.fold_left filtrec acc cl + | _, cl -> + Array.fold_left filtrec acc cl in filtrec Intset.empty constr @@ -155,7 +147,7 @@ let w_Define sp c wc = let spdecl = Evd.map (w_Underlying wc) sp in let cty = try - ctxt_type_of (ids_it (w_Focus sp wc)) (DOP2(Cast,c,spdecl.evar_concl)) + ctxt_type_of (ids_it (w_Focus sp wc)) (mkCast (c,spdecl.evar_concl)) with Not_found -> error "Instantiation contains unlegal variables" in diff --git a/proofs/evar_refiner.mli b/proofs/evar_refiner.mli index ef72c9d35..70416a363 100644 --- a/proofs/evar_refiner.mli +++ b/proofs/evar_refiner.mli @@ -33,8 +33,8 @@ val walking : w_tactic -> tactic val w_Focusing_THEN : evar -> 'a result_w_tactic -> ('a -> w_tactic) -> w_tactic -val w_Declare : evar -> constr -> w_tactic -val w_Declare_At : evar -> evar -> constr -> w_tactic +val w_Declare : evar -> constr * constr -> w_tactic +val w_Declare_At : evar -> evar -> constr * constr -> w_tactic val w_Define : evar -> constr -> w_tactic val w_Underlying : walking_constraints -> evar_declarations diff --git a/proofs/logic.ml b/proofs/logic.ml index 8c577f9bc..a92276cc8 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -5,7 +5,7 @@ open Pp open Util open Names open Evd -open Generic +(*i open Generic i*) open Term open Sign open Environ @@ -56,27 +56,25 @@ let conv_leq_goal env sigma arg ty conclty = let rec mk_refgoals sigma goal goalacc conclty trm = let env = goal.evar_env in - match trm with - | DOP0(Meta mv) -> + match kind_of_term trm with + | IsMeta mv -> if occur_meta conclty then error "Cannot refine to conclusions with meta-variables"; let ctxt = out_some goal.evar_info in (mk_goal ctxt env (nf_betaiota env sigma conclty))::goalacc, conclty - | DOP2(Cast,t,ty) -> + | IsCast (t,ty) -> let _ = type_of env sigma ty in conv_leq_goal env sigma trm ty conclty; mk_refgoals sigma goal goalacc ty t - | DOPN(AppL,cl) -> - let (acc',hdty) = mk_hdgoals sigma goal goalacc (array_hd cl) in - let (acc'',conclty') = - mk_arggoals sigma goal acc' hdty (array_list_of_tl cl) in + | IsAppL (f,l) -> + let (acc',hdty) = mk_hdgoals sigma goal goalacc f in + let (acc'',conclty') = mk_arggoals sigma goal acc' hdty l in let _ = conv_leq_goal env sigma trm conclty' conclty in (acc'',conclty') - | DOPN(MutCase _,_) as mc -> - let (_,p,c,lf) = destCase mc in + | IsMutCase (_,p,c,lf) -> let (acc',lbrty,conclty') = mk_casegoals sigma goal goalacc p c in let acc'' = array_fold_left2 @@ -86,10 +84,10 @@ let rec mk_refgoals sigma goal goalacc conclty trm = let _ = conv_leq_goal env sigma trm conclty' conclty in (acc'',conclty') - | t -> - if occur_meta t then raise (RefinerError (OccurMeta t)); - let t'ty = type_of env sigma t in - conv_leq_goal env sigma t t'ty conclty; + | _ -> + if occur_meta trm then raise (RefinerError (OccurMeta trm)); + let t'ty = type_of env sigma trm in + conv_leq_goal env sigma trm t'ty conclty; (goalacc,t'ty) (* Same as mkREFGOALS but without knowing te type of the term. Therefore, @@ -97,18 +95,17 @@ let rec mk_refgoals sigma goal goalacc conclty trm = and mk_hdgoals sigma goal goalacc trm = let env = goal.evar_env in - match trm with - | DOP2(Cast,DOP0(Meta mv),ty) -> + match kind_of_term trm with + | IsCast (c,ty) when isMeta c -> let _ = type_of env sigma ty in let ctxt = out_some goal.evar_info in (mk_goal ctxt env (nf_betaiota env sigma ty))::goalacc,ty - - | DOPN(AppL,cl) -> - let (acc',hdty) = mk_hdgoals sigma goal goalacc (array_hd cl) in - mk_arggoals sigma goal acc' hdty (array_list_of_tl cl) - - | DOPN(MutCase _,_) as mc -> - let (_,p,c,lf) = destCase mc in + + | IsAppL (f,l) -> + let (acc',hdty) = mk_hdgoals sigma goal goalacc f in + mk_arggoals sigma goal acc' hdty l + + | IsMutCase (_,p,c,lf) -> let (acc',lbrty,conclty') = mk_casegoals sigma goal goalacc p c in let acc'' = array_fold_left2 @@ -117,17 +114,19 @@ and mk_hdgoals sigma goal goalacc trm = in (acc'',conclty') - | t -> goalacc, type_of env sigma t + | _ -> goalacc, type_of env sigma trm and mk_arggoals sigma goal goalacc funty = function | [] -> goalacc,funty - | harg::tlargs -> - let env = goal.evar_env in - (match whd_betadeltaiota env sigma funty with - | DOP2(Prod,c1,DLAM(_,b)) -> - let (acc',hargty) = mk_refgoals sigma goal goalacc c1 harg in - mk_arggoals sigma goal acc' (subst1 harg b) tlargs - | t -> raise (RefinerError (CannotApply (t,harg)))) + | harg::tlargs as allargs -> + let t = whd_betadeltaiota goal.evar_env sigma funty in + match kind_of_term t with + | IsProd (_,c1,b) -> + let (acc',hargty) = mk_refgoals sigma goal goalacc c1 harg in + mk_arggoals sigma goal acc' (subst1 harg b) tlargs + | IsLetIn (_,c1,_,b) -> + mk_arggoals sigma goal goalacc (subst1 c1 b) allargs + | _ -> raise (RefinerError (CannotApply (t,harg))) and mk_casegoals sigma goal goalacc p c = let env = goal.evar_env in @@ -144,28 +143,24 @@ and mk_casegoals sigma goal goalacc p c = varaibles only in Application and Case *) let collect_meta_variables c = - let rec collrec acc = function - | DOP0(Meta mv) -> mv::acc - | DOP2(Cast,c,_) -> collrec acc c - | DOPN(AppL,cl) -> Array.fold_left collrec acc cl - | DOPN(MutCase _,_) as mc -> - let (_,p,c,lf) = destCase mc in - Array.fold_left collrec (collrec (collrec acc p) c) lf + let rec collrec acc c = match splay_constr c with + | OpMeta mv, _ -> mv::acc + | OpCast, [|c;_|] -> collrec acc c + | (OpAppL | OpMutCase _), cl -> Array.fold_left collrec acc cl | _ -> acc in List.rev(collrec [] c) let new_meta_variables = - let rec newrec = function - | DOP0(Meta _) -> DOP0(Meta (new_meta())) - | DOP2(Cast,c,t) -> DOP2(Cast, newrec c, t) - | DOPN(AppL,cl) -> DOPN(AppL, Array.map newrec cl) - | DOPN(MutCase _,_) as mc -> - let (ci,p,c,lf) = destCase mc in - mkMutCaseA ci (newrec p) (newrec c) (Array.map newrec lf) - | x -> x + let rec newrec x = match kind_of_term x with + | IsMeta _ -> mkMeta (new_meta()) + | IsCast (c,t) -> mkCast (newrec c, t) + | IsAppL (f,cl) -> applist (newrec f, List.map newrec cl) + | IsMutCase (ci,p,c,lf) -> + mkMutCaseA ci (newrec p) (newrec c) (Array.map newrec lf) + | _ -> x in - newrec + newrec let error_use_instantiate () = errorlabstrm "Logic.prim_refiner" @@ -299,13 +294,20 @@ let prim_refiner r sigma goal = | { name = Intro; newids = [id] } -> if !check && mem_var_context id sign then error "New variable is already declared"; - (match strip_outer_cast cl with - | DOP2(Prod,c1,DLAM(_,b)) -> + (match kind_of_term (strip_outer_cast cl) with + | IsProd (_,c1,b) -> if occur_meta c1 then error_use_instantiate(); let a = get_assumption_of env sigma c1 and v = VAR id in let sg = mk_goal info (push_var_decl (id,a) env) (subst1 v b) in [sg] + | IsLetIn (_,c1,t1,b) -> + if occur_meta c1 or occur_meta t1 then error_use_instantiate(); + let a = get_assumption_of env sigma t1 + and v = VAR id in + let sg = + mk_goal info (push_var_def (id,c1,a) env) (subst1 v b) in + [sg] | _ -> if !check then error "Introduction needs a product" else anomaly "Intro: expects a product") @@ -313,27 +315,41 @@ let prim_refiner r sigma goal = | { name = Intro_after; newids = [id]; hypspecs = [whereid] } -> if !check && mem_var_context id sign then error "New variable is already declared"; - (match strip_outer_cast cl with - | DOP2(Prod,c1,DLAM(_,b)) -> + (match kind_of_term (strip_outer_cast cl) with + | IsProd (_,c1,b) -> if occur_meta c1 then error_use_instantiate(); let a = get_assumption_of env sigma c1 and v = VAR id in let env' = insert_after_hyp env whereid (id,None,a) in let sg = mk_goal info env' (subst1 v b) in [sg] + | IsLetIn (_,c1,t1,b) -> + if occur_meta c1 or occur_meta t1 then error_use_instantiate(); + let a = get_assumption_of env sigma t1 + and v = VAR id in + let env' = insert_after_hyp env whereid (id,Some c1,a) in + let sg = mk_goal info env' (subst1 v b) in + [sg] | _ -> if !check then error "Introduction needs a product" else anomaly "Intro_after: expects a product") | { name = Intro_replacing; newids = []; hypspecs = [id] } -> - (match strip_outer_cast cl with - | DOP2(Prod,c1,DLAM(_,b)) -> + (match kind_of_term (strip_outer_cast cl) with + | IsProd (_,c1,b) -> if occur_meta c1 then error_use_instantiate(); let a = get_assumption_of env sigma c1 and v = VAR id in let env' = replace_hyp env id (id,None,a) in let sg = mk_goal info env' (subst1 v b) in [sg] + | IsLetIn (_,c1,t1,b) -> + if occur_meta c1 then error_use_instantiate(); + let a = get_assumption_of env sigma t1 + and v = VAR id in + let env' = replace_hyp env id (id,Some c1,a) in + let sg = mk_goal info env' (subst1 v b) in + [sg] | _ -> if !check then error "Introduction needs a product" else anomaly "Intro_replacing: expects a product") @@ -341,13 +357,13 @@ let prim_refiner r sigma goal = | { name = Fix; hypspecs = []; terms = []; newids = [f]; params = [Num(_,n)] } -> let rec check_ind k cl = - match whd_castapp cl with - | DOP2(Prod,c1,DLAM(_,b)) -> + match kind_of_term (whd_castapp cl) with + | IsProd (_,c1,b) -> if k = 1 then - (try - let _ = find_minductype env sigma c1 in () - with Induc -> - error "cannot do a fixpoint on a non inductive type") + try + let _ = find_minductype env sigma c1 in () + with Induc -> + error "cannot do a fixpoint on a non inductive type" else check_ind (k-1) b | _ -> error "not enough products" @@ -361,13 +377,13 @@ let prim_refiner r sigma goal = | { name = Fix; hypspecs = []; terms = lar; newids = lf; params = ln } -> let rec check_ind k cl = - match whd_castapp cl with - | DOP2(Prod,c1,DLAM(_,b)) -> + match kind_of_term (whd_castapp cl) with + | IsProd (_,c1,b) -> if k = 1 then - (try - fst (find_minductype env sigma c1) - with Induc -> - error "cannot do a fixpoint on a non inductive type") + try + fst (find_minductype env sigma c1) + with Induc -> + error "cannot do a fixpoint on a non inductive type" else check_ind (k-1) b | _ -> error "not enough products" @@ -392,14 +408,15 @@ let prim_refiner r sigma goal = | { name = Cofix; hypspecs = []; terms = lar; newids = lf; params = [] } -> let rec check_is_coind cl = - match (whd_betadeltaiota env sigma (whd_castapp cl)) with - | DOP2(Prod,c1,DLAM(_,b)) -> check_is_coind b - | b -> - (try - let _ = find_mcoinductype env sigma b in () - with Induc -> - error ("All methods must construct elements " ^ - "in coinductive types")) + let b = whd_betadeltaiota env sigma (whd_castapp cl) in + match kind_of_term b with + | IsProd (_,c1,b) -> check_is_coind b + | _ -> + try + let _ = find_mcoinductype env sigma b in () + with Induc -> + error ("All methods must construct elements " ^ + "in coinductive types") in List.iter check_is_coind (cl::lar); let rec mk_env env = function @@ -416,17 +433,6 @@ let prim_refiner r sigma goal = in mk_env env (cl::lar,lf) -(* let rec mk_sign sign = function - | (ar::lar'),(f::lf') -> - if (mem_sign sign f) then - error "name already used in the environment"; - let a = get_assumption_of env sigma ar in - mk_sign (add_var_decl (f,a) sign) (lar',lf') - | ([],[]) -> List.map (mk_goal info env) (cl::lar) - | _ -> error "not the right number of arguments" - in - mk_sign sign (cl::lar,lf)*) - | { name = Refine; terms = [c] } -> let c = new_meta_variables c in let (sgl,cl') = mk_refgoals sigma goal [] cl c in @@ -436,7 +442,7 @@ let prim_refiner r sigma goal = | { name = Convert_concl; terms = [cl'] } -> let cl'ty = type_of env sigma cl' in if is_conv_leq env sigma cl' cl then - let sg = mk_goal info env (DOP2(Cast,cl',cl'ty)) in + let sg = mk_goal info env (mkCast (cl',cl'ty)) in [sg] else error "convert-concl rule passed non-converting term" @@ -468,30 +474,31 @@ let prim_extractor subfun vl pft = let cl = pft.goal.evar_concl in match pft with | { ref = Some (Prim { name = Intro; newids = [id] }, [spf]) } -> - (match strip_outer_cast cl with - | DOP2(Prod,ty,b) -> + (match kind_of_term (strip_outer_cast cl) with + | IsProd (_,ty,_) -> let cty = subst_vars vl ty in - DOP2(Lambda,cty, DLAM(Name id,subfun (id::vl) spf)) + mkLambda (Name id, cty, subfun (id::vl) spf) | _ -> error "incomplete proof!") | { ref = Some (Prim { name = Intro_after; newids = [id]}, [spf]) } -> - (match strip_outer_cast cl with - | DOP2(Prod,ty,b) -> + (match kind_of_term (strip_outer_cast cl) with + | IsProd (_,ty,_) -> let cty = subst_vars vl ty in - DOP2(Lambda,cty, DLAM(Name id,subfun (id::vl) spf)) + mkLambda (Name id, cty, subfun (id::vl) spf) | _ -> error "incomplete proof!") | {ref=Some(Prim{name=Intro_replacing;hypspecs=[id]},[spf]) } -> - (match strip_outer_cast cl with - | DOP2(Prod,ty,b) -> + (match kind_of_term (strip_outer_cast cl) with + | IsProd (_,ty,_) -> let cty = subst_vars vl ty in - DOP2(Lambda,cty,DLAM(Name id,subfun (id::vl) spf)) + mkLambda (Name id, cty, subfun (id::vl) spf) | _ -> error "incomplete proof!") | {ref=Some(Prim{name=Fix;newids=[f];params=[Num(_,n)]},[spf]) } -> let cty = subst_vars vl cl in let na = Name f in - DOPN(Term.Fix([|n-1|],0),[| cty ; DLAMV(na,[|subfun (f::vl) spf|])|]) + mkFix (([|n-1|],0),([|cty|], [na], [|subfun (f::vl) spf|])) + | {ref=Some(Prim{name=Fix;newids=lf;terms=lar;params=ln},spfl) } -> let lcty = List.map (subst_vars vl) (cl::lar) in let vn = diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 6bea1e819..c660b35ef 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -5,7 +5,7 @@ open Pp open Util open Names open Sign -open Generic +(*i open Generic i*) open Term open Declarations open Environ diff --git a/proofs/refiner.ml b/proofs/refiner.ml index 333287b3e..badf6bc7a 100644 --- a/proofs/refiner.ml +++ b/proofs/refiner.ml @@ -4,7 +4,7 @@ open Pp open Util open Stamps -open Generic +(*i open Generic i*) open Term open Sign open Evd @@ -271,7 +271,7 @@ let extract_open_proof sigma pf = let ass = Retyping.get_assumption_of goal.evar_env sigma abs_concl in let mv = new_meta() in open_obligations := (mv,ass):: !open_obligations; - applist(DOP0(Meta mv),List.map (fun (n,_) -> Rel n) sorted_rels) + applist (mkMeta mv, List.map (fun (n,_) -> mkRel n) sorted_rels) | _ -> anomaly "Bug : a case has been forgotten in proof_extractor" in diff --git a/proofs/tacinterp.ml b/proofs/tacinterp.ml index 1feb14508..28eaa7ad4 100644 --- a/proofs/tacinterp.ml +++ b/proofs/tacinterp.ml @@ -3,7 +3,7 @@ open Astterm open Closure -open Generic +(*i open Generic i*) open Libobject open Pattern open Pp diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index 1488b06de..e8d4be64e 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -4,7 +4,7 @@ open Util open Stamps open Names -open Generic +(*i open Generic i*) open Sign open Term open Instantiate @@ -104,7 +104,7 @@ let pf_reduce_to_ind = pf_reduce reduce_to_ind let hnf_type_of gls = compose (pf_whd_betadeltaiota gls) (pf_type_of gls) let pf_check_type gls c1 c2 = - let casted = mkCast c1 c2 in pf_type_of gls casted + let casted = mkCast (c1, c2) in pf_type_of gls casted (************************************) (* Tactics handling a list of goals *) diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index bf2b0a3ba..e6130c3f6 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -191,8 +191,8 @@ val walking_THEN : 'a result_w_tactic -> ('a -> tactic) -> tactic val walking : w_tactic -> tactic val w_Focusing_THEN : int -> 'a result_w_tactic -> ('a -> w_tactic) -> w_tactic -val w_Declare : int -> constr -> w_tactic -val w_Declare_At : int -> int -> constr -> w_tactic +val w_Declare : int -> constr * constr -> w_tactic +val w_Declare_At : int -> int -> constr * constr -> w_tactic val w_Define : int -> constr -> w_tactic val w_Underlying : walking_constraints -> evar_declarations val w_env : walking_constraints -> env diff --git a/syntax/PPConstr.v b/syntax/PPConstr.v index ad74cd462..25f8a2c7f 100755 --- a/syntax/PPConstr.v +++ b/syntax/PPConstr.v @@ -129,6 +129,7 @@ Syntax constr | lambdal_cons [(LAMLBOX $pbi $c (IDS ($LIST $ids)) [$id]$body)] -> [(LAMLBOX $pbi $c (IDS ($LIST $ids) $id) $body)] + | letin [<<[$x = $A] $B>>] -> [ [ <hov 0> "[" $x ":=" $A "]" [0 1] $B:E ] ] | pi [<<($x : $A)$B>>] -> [(PRODBOX (BINDERS) <<($x : $A)$B>>)] | prodlist [(PRODLIST $c $b)] |