diff options
| author |  barras <barras@85f007b7-540e-0410-9357-904b9bb8a0f7> | 2001-11-05 16:48:30 +0000 |
|---|---|---|
| committer | barras <barras@85f007b7-540e-0410-9357-904b9bb8a0f7> | 2001-11-05 16:48:30 +0000 |
| commit | b91f60aab99980b604dc379b4ca62f152315c841 (patch) | |
| tree | cd1948fc5156988dd74d94ef4abb3e4ac77e3de8 | |
| parent | 2ff72589e5c90a25b315922b5ba2d7c11698adef (diff) | |
GROS COMMIT:
- reduction du noyau (variables existentielles, fonctions auxiliaires
pour inventer des noms, etc. deplacees hors de kernel/)
- changement de noms de constructeurs des constr (suppression de "Is" et
"Mut")
git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/coq/trunk@2158 85f007b7-540e-0410-9357-904b9bb8a0f7
196 files changed, 9172 insertions, 8695 deletions
@@ -1,65 +1,62 @@ -kernel/closure.cmi: kernel/environ.cmi kernel/esubst.cmi kernel/evd.cmi \ - kernel/names.cmi lib/pp.cmi kernel/term.cmi +kernel/closure.cmi: kernel/environ.cmi kernel/esubst.cmi kernel/names.cmi \ + lib/pp.cmi kernel/term.cmi kernel/cooking.cmi: kernel/declarations.cmi kernel/environ.cmi \ kernel/names.cmi kernel/term.cmi kernel/univ.cmi kernel/declarations.cmi: kernel/names.cmi kernel/sign.cmi kernel/term.cmi \ kernel/univ.cmi -kernel/environ.cmi: kernel/declarations.cmi kernel/names.cmi lib/pp.cmi \ - kernel/sign.cmi kernel/term.cmi kernel/univ.cmi +kernel/environ.cmi: kernel/declarations.cmi kernel/names.cmi kernel/sign.cmi \ + kernel/term.cmi kernel/univ.cmi kernel/esubst.cmi: lib/util.cmi -kernel/evd.cmi: kernel/names.cmi kernel/sign.cmi kernel/term.cmi kernel/indtypes.cmi: kernel/declarations.cmi kernel/environ.cmi \ - kernel/names.cmi kernel/sign.cmi kernel/term.cmi kernel/univ.cmi + kernel/names.cmi kernel/term.cmi kernel/typeops.cmi kernel/univ.cmi kernel/inductive.cmi: kernel/declarations.cmi kernel/environ.cmi \ - kernel/evd.cmi kernel/names.cmi kernel/sign.cmi kernel/term.cmi \ - kernel/univ.cmi -kernel/instantiate.cmi: kernel/environ.cmi kernel/evd.cmi kernel/names.cmi \ - kernel/sign.cmi kernel/term.cmi + kernel/names.cmi kernel/term.cmi kernel/univ.cmi kernel/names.cmi: lib/pp.cmi lib/predicate.cmi -kernel/reduction.cmi: kernel/closure.cmi kernel/environ.cmi kernel/evd.cmi \ - kernel/names.cmi kernel/sign.cmi kernel/term.cmi kernel/univ.cmi +kernel/reduction.cmi: kernel/environ.cmi kernel/sign.cmi kernel/term.cmi \ + kernel/univ.cmi kernel/safe_typing.cmi: kernel/cooking.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/environ.cmi kernel/indtypes.cmi kernel/names.cmi kernel/term.cmi \ + kernel/univ.cmi kernel/sign.cmi: kernel/names.cmi kernel/term.cmi -kernel/term.cmi: kernel/names.cmi lib/pp.cmi kernel/univ.cmi lib/util.cmi -kernel/type_errors.cmi: kernel/environ.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 \ - kernel/names.cmi kernel/sign.cmi kernel/term.cmi kernel/univ.cmi +kernel/term.cmi: kernel/names.cmi kernel/univ.cmi +kernel/type_errors.cmi: kernel/environ.cmi kernel/names.cmi kernel/sign.cmi \ + kernel/term.cmi +kernel/typeops.cmi: kernel/environ.cmi kernel/inductive.cmi kernel/names.cmi \ + kernel/sign.cmi kernel/term.cmi kernel/univ.cmi kernel/univ.cmi: kernel/names.cmi lib/pp.cmi lib/pp.cmi: lib/pp_control.cmi -lib/system.cmi: lib/pp.cmi -lib/util.cmi: lib/pp.cmi library/declare.cmi: kernel/cooking.cmi kernel/declarations.cmi \ - kernel/environ.cmi kernel/inductive.cmi library/libobject.cmi \ - library/library.cmi kernel/names.cmi library/nametab.cmi kernel/sign.cmi \ - kernel/term.cmi kernel/univ.cmi + kernel/environ.cmi kernel/indtypes.cmi library/libobject.cmi \ + library/library.cmi kernel/names.cmi library/nametab.cmi \ + kernel/safe_typing.cmi kernel/sign.cmi kernel/term.cmi kernel/univ.cmi library/global.cmi: kernel/cooking.cmi kernel/declarations.cmi \ - kernel/environ.cmi kernel/inductive.cmi kernel/names.cmi \ - library/nametab.cmi kernel/safe_typing.cmi kernel/sign.cmi \ - kernel/term.cmi kernel/univ.cmi -library/goptions.cmi: kernel/names.cmi lib/pp.cmi kernel/term.cmi -library/impargs.cmi: kernel/environ.cmi kernel/evd.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 + kernel/environ.cmi kernel/indtypes.cmi kernel/names.cmi \ + kernel/safe_typing.cmi kernel/sign.cmi kernel/term.cmi kernel/univ.cmi +library/goptions.cmi: kernel/names.cmi library/nametab.cmi lib/pp.cmi \ + kernel/term.cmi +library/impargs.cmi: kernel/environ.cmi kernel/inductive.cmi kernel/names.cmi \ + library/nametab.cmi kernel/term.cmi library/lib.cmi: library/libobject.cmi kernel/names.cmi library/summary.cmi library/libobject.cmi: kernel/names.cmi library/library.cmi: library/lib.cmi library/libobject.cmi kernel/names.cmi \ library/nametab.cmi lib/pp.cmi lib/system.cmi -library/nametab.cmi: kernel/names.cmi lib/pp.cmi lib/util.cmi +library/nameops.cmi: kernel/environ.cmi kernel/names.cmi kernel/term.cmi +library/nametab.cmi: kernel/environ.cmi kernel/names.cmi lib/pp.cmi \ + lib/util.cmi library/opaque.cmi: kernel/closure.cmi kernel/environ.cmi kernel/names.cmi \ kernel/safe_typing.cmi library/summary.cmi: kernel/names.cmi +lib/system.cmi: lib/pp.cmi +lib/util.cmi: lib/pp.cmi parsing/ast.cmi: parsing/coqast.cmi lib/dyn.cmi kernel/names.cmi \ parsing/pcoq.cmi lib/pp.cmi -parsing/astterm.cmi: parsing/coqast.cmi kernel/environ.cmi kernel/evd.cmi \ +parsing/astterm.cmi: parsing/coqast.cmi kernel/environ.cmi pretyping/evd.cmi \ library/impargs.cmi kernel/names.cmi library/nametab.cmi \ pretyping/pattern.cmi pretyping/rawterm.cmi kernel/sign.cmi \ kernel/term.cmi parsing/coqast.cmi: lib/dyn.cmi kernel/names.cmi -parsing/coqlib.cmi: kernel/names.cmi pretyping/pattern.cmi kernel/term.cmi +parsing/coqlib.cmi: kernel/names.cmi library/nametab.cmi \ + pretyping/pattern.cmi kernel/term.cmi parsing/egrammar.cmi: parsing/ast.cmi parsing/coqast.cmi parsing/extend.cmi \ parsing/pcoq.cmi parsing/esyntax.cmi: parsing/ast.cmi parsing/coqast.cmi parsing/extend.cmi \ @@ -72,100 +69,121 @@ parsing/g_zsyntax.cmi: parsing/coqast.cmi parsing/pcoq.cmi: parsing/coqast.cmi parsing/prettyp.cmi: pretyping/classops.cmi kernel/environ.cmi \ kernel/inductive.cmi library/lib.cmi kernel/names.cmi library/nametab.cmi \ - lib/pp.cmi kernel/reduction.cmi kernel/safe_typing.cmi kernel/sign.cmi \ - kernel/term.cmi + lib/pp.cmi pretyping/reductionops.cmi kernel/safe_typing.cmi \ + kernel/sign.cmi kernel/term.cmi pretyping/termops.cmi parsing/printer.cmi: parsing/coqast.cmi kernel/environ.cmi kernel/names.cmi \ - pretyping/pattern.cmi lib/pp.cmi pretyping/rawterm.cmi kernel/sign.cmi \ - kernel/term.cmi -parsing/search.cmi: kernel/environ.cmi kernel/names.cmi pretyping/pattern.cmi \ - lib/pp.cmi kernel/term.cmi + library/nametab.cmi pretyping/pattern.cmi lib/pp.cmi \ + pretyping/rawterm.cmi kernel/sign.cmi kernel/term.cmi \ + pretyping/termops.cmi +parsing/search.cmi: kernel/environ.cmi kernel/names.cmi library/nametab.cmi \ + pretyping/pattern.cmi lib/pp.cmi kernel/term.cmi parsing/termast.cmi: parsing/coqast.cmi kernel/environ.cmi kernel/names.cmi \ library/nametab.cmi pretyping/pattern.cmi pretyping/rawterm.cmi \ - kernel/sign.cmi kernel/term.cmi -pretyping/cases.cmi: kernel/environ.cmi pretyping/evarutil.cmi kernel/evd.cmi \ - kernel/inductive.cmi kernel/names.cmi pretyping/rawterm.cmi \ - kernel/term.cmi + kernel/sign.cmi kernel/term.cmi pretyping/termops.cmi +pretyping/cases.cmi: kernel/environ.cmi pretyping/evarutil.cmi \ + pretyping/evd.cmi pretyping/inductiveops.cmi kernel/names.cmi \ + pretyping/rawterm.cmi kernel/term.cmi pretyping/cbv.cmi: kernel/closure.cmi kernel/environ.cmi kernel/esubst.cmi \ - kernel/evd.cmi kernel/names.cmi lib/pp.cmi kernel/term.cmi -pretyping/classops.cmi: library/declare.cmi kernel/environ.cmi kernel/evd.cmi \ - library/libobject.cmi kernel/names.cmi lib/pp.cmi kernel/term.cmi + pretyping/evd.cmi kernel/names.cmi lib/pp.cmi kernel/term.cmi +pretyping/classops.cmi: library/declare.cmi kernel/environ.cmi \ + pretyping/evd.cmi library/libobject.cmi kernel/names.cmi \ + library/nametab.cmi lib/pp.cmi kernel/term.cmi pretyping/coercion.cmi: kernel/environ.cmi pretyping/evarutil.cmi \ - kernel/evd.cmi pretyping/rawterm.cmi kernel/sign.cmi kernel/term.cmi + pretyping/evd.cmi pretyping/rawterm.cmi kernel/sign.cmi kernel/term.cmi pretyping/detyping.cmi: kernel/environ.cmi kernel/names.cmi \ - pretyping/rawterm.cmi kernel/sign.cmi kernel/term.cmi + pretyping/rawterm.cmi kernel/sign.cmi kernel/term.cmi \ + pretyping/termops.cmi pretyping/evarconv.cmi: kernel/environ.cmi pretyping/evarutil.cmi \ - kernel/reduction.cmi kernel/sign.cmi kernel/term.cmi -pretyping/evarutil.cmi: kernel/environ.cmi kernel/evd.cmi kernel/names.cmi \ - pretyping/rawterm.cmi kernel/reduction.cmi kernel/sign.cmi \ + pretyping/reductionops.cmi kernel/sign.cmi kernel/term.cmi +pretyping/evarutil.cmi: kernel/environ.cmi pretyping/evd.cmi kernel/names.cmi \ + pretyping/rawterm.cmi pretyping/reductionops.cmi kernel/sign.cmi \ + kernel/term.cmi +pretyping/evd.cmi: kernel/names.cmi kernel/sign.cmi kernel/term.cmi +pretyping/indrec.cmi: kernel/declarations.cmi kernel/environ.cmi \ + pretyping/evd.cmi pretyping/inductiveops.cmi kernel/names.cmi \ kernel/term.cmi +pretyping/inductiveops.cmi: kernel/declarations.cmi kernel/environ.cmi \ + pretyping/evd.cmi kernel/names.cmi kernel/sign.cmi kernel/term.cmi +pretyping/instantiate.cmi: kernel/environ.cmi pretyping/evd.cmi \ + kernel/names.cmi kernel/sign.cmi kernel/term.cmi pretyping/multcase.cmi: kernel/environ.cmi pretyping/evarutil.cmi \ - kernel/evd.cmi kernel/names.cmi pretyping/rawterm.cmi kernel/term.cmi -pretyping/pattern.cmi: kernel/environ.cmi kernel/evd.cmi kernel/names.cmi \ + pretyping/evd.cmi kernel/names.cmi pretyping/rawterm.cmi kernel/term.cmi +pretyping/pattern.cmi: kernel/environ.cmi pretyping/evd.cmi kernel/names.cmi \ + library/nametab.cmi pretyping/rawterm.cmi kernel/sign.cmi kernel/term.cmi +pretyping/pretype_errors.cmi: kernel/environ.cmi pretyping/evd.cmi \ + pretyping/inductiveops.cmi kernel/names.cmi lib/pp.cmi \ pretyping/rawterm.cmi kernel/sign.cmi kernel/term.cmi -pretyping/pretype_errors.cmi: kernel/environ.cmi kernel/evd.cmi \ - kernel/inductive.cmi kernel/names.cmi lib/pp.cmi pretyping/rawterm.cmi \ - kernel/sign.cmi kernel/term.cmi pretyping/pretyping.cmi: lib/dyn.cmi kernel/environ.cmi \ - pretyping/evarutil.cmi kernel/evd.cmi kernel/names.cmi \ + pretyping/evarutil.cmi pretyping/evd.cmi kernel/names.cmi \ pretyping/rawterm.cmi kernel/sign.cmi kernel/term.cmi -pretyping/rawterm.cmi: lib/dyn.cmi kernel/names.cmi kernel/sign.cmi \ - kernel/term.cmi kernel/univ.cmi +pretyping/rawterm.cmi: lib/dyn.cmi kernel/names.cmi library/nametab.cmi \ + kernel/sign.cmi kernel/term.cmi kernel/univ.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 \ + library/library.cmi kernel/names.cmi library/nametab.cmi kernel/term.cmi +pretyping/reductionops.cmi: kernel/closure.cmi kernel/environ.cmi \ + pretyping/evd.cmi kernel/names.cmi kernel/sign.cmi kernel/term.cmi \ + kernel/univ.cmi +pretyping/retyping.cmi: kernel/environ.cmi pretyping/evd.cmi kernel/names.cmi \ kernel/term.cmi pretyping/syntax_def.cmi: kernel/names.cmi library/nametab.cmi \ pretyping/rawterm.cmi -pretyping/tacred.cmi: kernel/closure.cmi kernel/environ.cmi kernel/evd.cmi \ - kernel/names.cmi kernel/reduction.cmi kernel/term.cmi -pretyping/typing.cmi: kernel/environ.cmi kernel/evd.cmi kernel/term.cmi -proofs/clenv.cmi: kernel/environ.cmi proofs/evar_refiner.cmi kernel/evd.cmi \ - kernel/names.cmi lib/pp.cmi proofs/proof_type.cmi kernel/reduction.cmi \ - proofs/tacmach.cmi kernel/term.cmi lib/util.cmi -proofs/evar_refiner.cmi: parsing/coqast.cmi kernel/environ.cmi kernel/evd.cmi \ - kernel/names.cmi proofs/proof_trees.cmi proofs/proof_type.cmi \ - proofs/refiner.cmi kernel/sign.cmi kernel/term.cmi -proofs/logic.cmi: kernel/environ.cmi kernel/evd.cmi kernel/names.cmi \ +pretyping/tacred.cmi: kernel/closure.cmi kernel/environ.cmi pretyping/evd.cmi \ + kernel/names.cmi pretyping/reductionops.cmi kernel/term.cmi +pretyping/termops.cmi: kernel/environ.cmi kernel/names.cmi \ + library/nametab.cmi lib/pp.cmi kernel/sign.cmi kernel/term.cmi \ + lib/util.cmi +pretyping/typing.cmi: kernel/environ.cmi pretyping/evd.cmi kernel/term.cmi +proofs/clenv.cmi: kernel/environ.cmi proofs/evar_refiner.cmi \ + pretyping/evd.cmi kernel/names.cmi lib/pp.cmi proofs/proof_type.cmi \ + pretyping/reductionops.cmi proofs/tacmach.cmi kernel/term.cmi \ + lib/util.cmi +proofs/evar_refiner.cmi: parsing/coqast.cmi kernel/environ.cmi \ + pretyping/evd.cmi kernel/names.cmi proofs/proof_trees.cmi \ + proofs/proof_type.cmi proofs/refiner.cmi kernel/sign.cmi kernel/term.cmi +proofs/logic.cmi: kernel/environ.cmi pretyping/evd.cmi kernel/names.cmi \ lib/pp.cmi proofs/proof_type.cmi kernel/sign.cmi kernel/term.cmi -proofs/pfedit.cmi: parsing/coqast.cmi kernel/declarations.cmi \ - library/declare.cmi kernel/environ.cmi kernel/names.cmi lib/pp.cmi \ - proofs/proof_type.cmi kernel/sign.cmi proofs/tacmach.cmi kernel/term.cmi -proofs/proof_trees.cmi: parsing/coqast.cmi kernel/environ.cmi kernel/evd.cmi \ - kernel/names.cmi lib/pp.cmi proofs/proof_type.cmi kernel/sign.cmi \ - lib/stamps.cmi kernel/term.cmi lib/util.cmi -proofs/proof_type.cmi: parsing/coqast.cmi kernel/environ.cmi kernel/evd.cmi \ - kernel/names.cmi library/nametab.cmi pretyping/pretyping.cmi \ - lib/stamps.cmi pretyping/tacred.cmi kernel/term.cmi lib/util.cmi +proofs/pfedit.cmi: parsing/coqast.cmi library/declare.cmi kernel/environ.cmi \ + kernel/names.cmi lib/pp.cmi proofs/proof_type.cmi kernel/safe_typing.cmi \ + kernel/sign.cmi proofs/tacmach.cmi kernel/term.cmi +proofs/proof_trees.cmi: parsing/coqast.cmi kernel/environ.cmi \ + pretyping/evd.cmi kernel/names.cmi lib/pp.cmi proofs/proof_type.cmi \ + kernel/sign.cmi lib/stamps.cmi kernel/term.cmi lib/util.cmi +proofs/proof_type.cmi: parsing/coqast.cmi kernel/environ.cmi \ + pretyping/evd.cmi kernel/names.cmi library/nametab.cmi \ + pretyping/pretyping.cmi lib/stamps.cmi pretyping/tacred.cmi \ + kernel/term.cmi lib/util.cmi proofs/refiner.cmi: lib/pp.cmi proofs/proof_trees.cmi proofs/proof_type.cmi \ kernel/sign.cmi kernel/term.cmi proofs/tacinterp.cmi: parsing/coqast.cmi lib/dyn.cmi kernel/environ.cmi \ kernel/names.cmi lib/pp.cmi proofs/proof_type.cmi proofs/tacmach.cmi \ proofs/tactic_debug.cmi kernel/term.cmi proofs/tacmach.cmi: kernel/closure.cmi parsing/coqast.cmi kernel/environ.cmi \ - kernel/evd.cmi kernel/names.cmi lib/pp.cmi pretyping/pretyping.cmi \ + pretyping/evd.cmi kernel/names.cmi lib/pp.cmi pretyping/pretyping.cmi \ proofs/proof_trees.cmi proofs/proof_type.cmi kernel/reduction.cmi \ proofs/refiner.cmi kernel/sign.cmi pretyping/tacred.cmi kernel/term.cmi proofs/tactic_debug.cmi: parsing/coqast.cmi kernel/environ.cmi \ proofs/proof_type.cmi kernel/term.cmi tactics/auto.cmi: tactics/btermdn.cmi proofs/clenv.cmi parsing/coqast.cmi \ - kernel/environ.cmi kernel/evd.cmi kernel/names.cmi pretyping/pattern.cmi \ - lib/pp.cmi proofs/proof_type.cmi pretyping/rawterm.cmi kernel/sign.cmi \ - proofs/tacmach.cmi kernel/term.cmi lib/util.cmi + kernel/environ.cmi pretyping/evd.cmi kernel/names.cmi library/nametab.cmi \ + pretyping/pattern.cmi lib/pp.cmi proofs/proof_type.cmi \ + pretyping/rawterm.cmi kernel/sign.cmi proofs/tacmach.cmi kernel/term.cmi \ + lib/util.cmi tactics/autorewrite.cmi: parsing/coqast.cmi proofs/tacmach.cmi \ kernel/term.cmi tactics/btermdn.cmi: pretyping/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 -tactics/equality.cmi: parsing/coqast.cmi kernel/environ.cmi kernel/evd.cmi \ +tactics/equality.cmi: parsing/coqast.cmi kernel/environ.cmi pretyping/evd.cmi \ tactics/hipattern.cmi kernel/names.cmi pretyping/pattern.cmi \ proofs/proof_type.cmi kernel/sign.cmi proofs/tacmach.cmi \ tactics/tacticals.cmi tactics/tactics.cmi kernel/term.cmi \ tactics/wcclausenv.cmi tactics/hiddentac.cmi: kernel/names.cmi proofs/proof_type.cmi \ tactics/tacentries.cmi proofs/tacmach.cmi kernel/term.cmi -tactics/hipattern.cmi: kernel/evd.cmi kernel/names.cmi pretyping/pattern.cmi \ - proofs/proof_trees.cmi kernel/sign.cmi kernel/term.cmi lib/util.cmi +tactics/hipattern.cmi: pretyping/evd.cmi kernel/names.cmi \ + pretyping/pattern.cmi proofs/proof_trees.cmi kernel/sign.cmi \ + kernel/term.cmi lib/util.cmi tactics/inv.cmi: kernel/names.cmi proofs/tacmach.cmi kernel/term.cmi tactics/nbtermdn.cmi: tactics/btermdn.cmi pretyping/pattern.cmi \ kernel/term.cmi @@ -177,17 +195,18 @@ tactics/tacticals.cmi: proofs/clenv.cmi parsing/coqast.cmi kernel/names.cmi \ pretyping/pattern.cmi proofs/proof_type.cmi kernel/reduction.cmi \ kernel/sign.cmi proofs/tacmach.cmi kernel/term.cmi tactics/wcclausenv.cmi tactics/tactics.cmi: proofs/clenv.cmi kernel/closure.cmi kernel/environ.cmi \ - proofs/evar_refiner.cmi kernel/evd.cmi kernel/names.cmi \ - proofs/proof_type.cmi kernel/reduction.cmi proofs/tacmach.cmi \ - pretyping/tacred.cmi tactics/tacticals.cmi kernel/term.cmi + proofs/evar_refiner.cmi pretyping/evd.cmi kernel/names.cmi \ + library/nametab.cmi proofs/proof_type.cmi kernel/reduction.cmi \ + proofs/tacmach.cmi pretyping/tacred.cmi tactics/tacticals.cmi \ + kernel/term.cmi tactics/termdn.cmi: pretyping/pattern.cmi kernel/term.cmi tactics/wcclausenv.cmi: proofs/clenv.cmi kernel/environ.cmi \ - proofs/evar_refiner.cmi kernel/evd.cmi kernel/names.cmi \ + proofs/evar_refiner.cmi pretyping/evd.cmi kernel/names.cmi \ proofs/proof_type.cmi kernel/sign.cmi proofs/tacmach.cmi kernel/term.cmi toplevel/class.cmi: pretyping/classops.cmi library/declare.cmi \ - kernel/names.cmi kernel/term.cmi -toplevel/command.cmi: parsing/coqast.cmi kernel/declarations.cmi \ - library/declare.cmi kernel/environ.cmi library/library.cmi \ + kernel/names.cmi library/nametab.cmi kernel/term.cmi +toplevel/command.cmi: parsing/coqast.cmi library/declare.cmi \ + kernel/environ.cmi kernel/indtypes.cmi library/library.cmi \ kernel/names.cmi library/nametab.cmi proofs/proof_type.cmi \ pretyping/tacred.cmi kernel/term.cmi toplevel/coqinit.cmi: kernel/names.cmi @@ -203,22 +222,22 @@ toplevel/mltop.cmi: library/libobject.cmi kernel/names.cmi toplevel/protectedtoplevel.cmi: lib/pp.cmi toplevel/record.cmi: parsing/coqast.cmi kernel/names.cmi kernel/sign.cmi \ kernel/term.cmi -toplevel/recordobj.cmi: kernel/names.cmi +toplevel/recordobj.cmi: library/nametab.cmi toplevel/searchisos.cmi: library/libobject.cmi kernel/names.cmi \ kernel/term.cmi toplevel/toplevel.cmi: parsing/pcoq.cmi lib/pp.cmi -toplevel/vernac.cmi: parsing/coqast.cmi parsing/pcoq.cmi toplevel/vernacentries.cmi: kernel/environ.cmi kernel/names.cmi \ proofs/proof_type.cmi kernel/term.cmi toplevel/vernacinterp.cmi toplevel/vernacinterp.cmi: parsing/coqast.cmi lib/dyn.cmi kernel/names.cmi \ library/nametab.cmi proofs/proof_type.cmi +toplevel/vernac.cmi: parsing/coqast.cmi parsing/pcoq.cmi contrib/correctness/past.cmi: parsing/coqast.cmi kernel/names.cmi \ contrib/correctness/ptype.cmi kernel/term.cmi -contrib/correctness/pcic.cmi: contrib/correctness/past.cmi \ - pretyping/rawterm.cmi contrib/correctness/pcicenv.cmi: kernel/names.cmi \ contrib/correctness/penv.cmi contrib/correctness/prename.cmi \ kernel/sign.cmi kernel/term.cmi +contrib/correctness/pcic.cmi: contrib/correctness/past.cmi \ + pretyping/rawterm.cmi contrib/correctness/pdb.cmi: kernel/names.cmi contrib/correctness/past.cmi \ contrib/correctness/ptype.cmi contrib/correctness/peffect.cmi: kernel/names.cmi lib/pp.cmi @@ -257,17 +276,20 @@ contrib/correctness/pwp.cmi: contrib/correctness/peffect.cmi \ contrib/correctness/penv.cmi contrib/correctness/prename.cmi \ kernel/term.cmi contrib/extraction/common.cmi: contrib/extraction/miniml.cmi \ - contrib/extraction/mlutil.cmi kernel/names.cmi + contrib/extraction/mlutil.cmi kernel/names.cmi library/nametab.cmi contrib/extraction/extraction.cmi: kernel/environ.cmi \ - contrib/extraction/miniml.cmi kernel/names.cmi kernel/term.cmi + contrib/extraction/miniml.cmi kernel/names.cmi library/nametab.cmi \ + kernel/term.cmi contrib/extraction/haskell.cmi: contrib/extraction/miniml.cmi \ - kernel/names.cmi lib/pp.cmi -contrib/extraction/miniml.cmi: kernel/names.cmi lib/pp.cmi kernel/term.cmi + kernel/names.cmi library/nametab.cmi lib/pp.cmi +contrib/extraction/miniml.cmi: kernel/names.cmi library/nametab.cmi \ + lib/pp.cmi kernel/term.cmi contrib/extraction/mlutil.cmi: contrib/extraction/miniml.cmi kernel/names.cmi \ - kernel/term.cmi + library/nametab.cmi kernel/term.cmi contrib/extraction/ocaml.cmi: contrib/extraction/miniml.cmi kernel/names.cmi \ - lib/pp.cmi kernel/term.cmi -contrib/extraction/table.cmi: kernel/names.cmi toplevel/vernacinterp.cmi + library/nametab.cmi lib/pp.cmi kernel/term.cmi +contrib/extraction/table.cmi: kernel/names.cmi library/nametab.cmi \ + toplevel/vernacinterp.cmi contrib/interface/dad.cmi: contrib/interface/ctast.cmo proofs/proof_type.cmi \ proofs/tacmach.cmi contrib/interface/debug_tac.cmi: parsing/coqast.cmi proofs/proof_type.cmi \ @@ -277,14 +299,15 @@ contrib/interface/pbp.cmi: contrib/interface/ctast.cmo proofs/proof_type.cmi \ proofs/tacmach.cmi contrib/interface/showproof.cmi: contrib/interface/ascent.cmi \ parsing/astterm.cmi proofs/clenv.cmi parsing/coqast.cmi \ - kernel/declarations.cmi kernel/environ.cmi kernel/evd.cmi \ + kernel/declarations.cmi kernel/environ.cmi pretyping/evd.cmi \ kernel/inductive.cmi kernel/names.cmi proofs/pfedit.cmi lib/pp.cmi \ parsing/printer.cmi proofs/proof_trees.cmi proofs/proof_type.cmi \ kernel/reduction.cmi contrib/interface/showproof_ct.cmo kernel/sign.cmi \ lib/stamps.cmi kernel/term.cmi contrib/interface/translate.cmi \ pretyping/typing.cmi lib/util.cmi toplevel/vernacinterp.cmi contrib/interface/translate.cmi: contrib/interface/ascent.cmi \ - kernel/environ.cmi kernel/evd.cmi proofs/proof_type.cmi kernel/term.cmi + kernel/environ.cmi pretyping/evd.cmi proofs/proof_type.cmi \ + kernel/term.cmi contrib/interface/vtp.cmi: contrib/interface/ascent.cmi contrib/interface/xlate.cmi: contrib/interface/ascent.cmi \ contrib/interface/ctast.cmo @@ -294,85 +317,73 @@ 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 proofs/clenv.cmi kernel/environ.cmi \ - toplevel/errors.cmi kernel/evd.cmi kernel/names.cmi library/nametab.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/errors.cmi pretyping/evd.cmi library/nameops.cmi \ + kernel/names.cmi library/nametab.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 \ + pretyping/termops.cmi kernel/univ.cmi dev/top_printers.cmx: parsing/ast.cmx proofs/clenv.cmx kernel/environ.cmx \ - toplevel/errors.cmx kernel/evd.cmx kernel/names.cmx library/nametab.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 -kernel/closure.cmo: kernel/environ.cmi kernel/esubst.cmi kernel/evd.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/environ.cmx kernel/esubst.cmx kernel/evd.cmx \ - kernel/instantiate.cmx kernel/names.cmx lib/pp.cmx kernel/term.cmx \ - kernel/univ.cmx lib/util.cmx kernel/closure.cmi -kernel/cooking.cmo: kernel/declarations.cmi kernel/environ.cmi kernel/evd.cmi \ - kernel/instantiate.cmi kernel/names.cmi lib/pp.cmi kernel/reduction.cmi \ - kernel/sign.cmi kernel/term.cmi lib/util.cmi kernel/cooking.cmi -kernel/cooking.cmx: kernel/declarations.cmx kernel/environ.cmx kernel/evd.cmx \ - kernel/instantiate.cmx kernel/names.cmx lib/pp.cmx kernel/reduction.cmx \ - kernel/sign.cmx kernel/term.cmx lib/util.cmx kernel/cooking.cmi + toplevel/errors.cmx pretyping/evd.cmx library/nameops.cmx \ + kernel/names.cmx library/nametab.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 \ + pretyping/termops.cmx kernel/univ.cmx +kernel/closure.cmo: kernel/environ.cmi kernel/esubst.cmi kernel/names.cmi \ + lib/pp.cmi kernel/term.cmi kernel/univ.cmi lib/util.cmi \ + kernel/closure.cmi +kernel/closure.cmx: kernel/environ.cmx kernel/esubst.cmx kernel/names.cmx \ + lib/pp.cmx kernel/term.cmx kernel/univ.cmx lib/util.cmx \ + kernel/closure.cmi +kernel/cooking.cmo: kernel/declarations.cmi kernel/environ.cmi \ + kernel/names.cmi lib/pp.cmi kernel/reduction.cmi kernel/sign.cmi \ + kernel/term.cmi lib/util.cmi kernel/cooking.cmi +kernel/cooking.cmx: kernel/declarations.cmx kernel/environ.cmx \ + kernel/names.cmx lib/pp.cmx kernel/reduction.cmx kernel/sign.cmx \ + kernel/term.cmx lib/util.cmx kernel/cooking.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/declarations.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/declarations.cmx kernel/names.cmx lib/pp.cmx \ - kernel/sign.cmx kernel/term.cmx kernel/univ.cmx lib/util.cmx \ - kernel/environ.cmi +kernel/environ.cmo: kernel/declarations.cmi kernel/names.cmi kernel/sign.cmi \ + kernel/term.cmi kernel/univ.cmi lib/util.cmi kernel/environ.cmi +kernel/environ.cmx: kernel/declarations.cmx kernel/names.cmx kernel/sign.cmx \ + kernel/term.cmx kernel/univ.cmx lib/util.cmx kernel/environ.cmi kernel/esubst.cmo: lib/util.cmi kernel/esubst.cmi kernel/esubst.cmx: lib/util.cmx kernel/esubst.cmi -kernel/evd.cmo: kernel/names.cmi kernel/sign.cmi kernel/term.cmi lib/util.cmi \ - kernel/evd.cmi -kernel/evd.cmx: kernel/names.cmx kernel/sign.cmx kernel/term.cmx lib/util.cmx \ - kernel/evd.cmi kernel/indtypes.cmo: kernel/declarations.cmi kernel/environ.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/inductive.cmi kernel/names.cmi kernel/reduction.cmi \ + kernel/sign.cmi kernel/term.cmi kernel/typeops.cmi kernel/univ.cmi \ + lib/util.cmi kernel/indtypes.cmi kernel/indtypes.cmx: kernel/declarations.cmx kernel/environ.cmx \ - 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.cmx kernel/names.cmx kernel/reduction.cmx \ + kernel/sign.cmx kernel/term.cmx kernel/typeops.cmx kernel/univ.cmx \ + lib/util.cmx kernel/indtypes.cmi kernel/inductive.cmo: kernel/declarations.cmi kernel/environ.cmi \ kernel/names.cmi kernel/reduction.cmi kernel/sign.cmi kernel/term.cmi \ - kernel/univ.cmi lib/util.cmi kernel/inductive.cmi + kernel/type_errors.cmi kernel/univ.cmi lib/util.cmi kernel/inductive.cmi kernel/inductive.cmx: kernel/declarations.cmx kernel/environ.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/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/names.cmx lib/pp.cmx kernel/sign.cmx \ - kernel/term.cmx lib/util.cmx kernel/instantiate.cmi + kernel/type_errors.cmx kernel/univ.cmx lib/util.cmx kernel/inductive.cmi kernel/names.cmo: lib/hashcons.cmi lib/pp.cmi lib/predicate.cmi lib/util.cmi \ kernel/names.cmi kernel/names.cmx: lib/hashcons.cmx lib/pp.cmx lib/predicate.cmx lib/util.cmx \ kernel/names.cmi kernel/reduction.cmo: kernel/closure.cmi kernel/declarations.cmi \ - kernel/environ.cmi kernel/esubst.cmi kernel/evd.cmi \ - kernel/instantiate.cmi kernel/names.cmi lib/pp.cmi kernel/sign.cmi \ + kernel/environ.cmi kernel/esubst.cmi kernel/names.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/esubst.cmx kernel/evd.cmx \ - kernel/instantiate.cmx kernel/names.cmx lib/pp.cmx kernel/sign.cmx \ + kernel/environ.cmx kernel/esubst.cmx kernel/names.cmx kernel/sign.cmx \ kernel/term.cmx kernel/univ.cmx lib/util.cmx kernel/reduction.cmi kernel/safe_typing.cmo: kernel/cooking.cmi kernel/declarations.cmi \ - kernel/environ.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/environ.cmi kernel/indtypes.cmi kernel/inductive.cmi \ + kernel/names.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/cooking.cmx kernel/declarations.cmx \ - kernel/environ.cmx 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/environ.cmx kernel/indtypes.cmx kernel/inductive.cmx \ + kernel/names.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 \ @@ -381,20 +392,20 @@ kernel/term.cmo: kernel/esubst.cmi lib/hashcons.cmi kernel/names.cmi \ lib/pp.cmi kernel/univ.cmi lib/util.cmi kernel/term.cmi kernel/term.cmx: kernel/esubst.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/type_errors.cmo: kernel/environ.cmi kernel/names.cmi \ kernel/reduction.cmi kernel/sign.cmi kernel/term.cmi \ kernel/type_errors.cmi -kernel/type_errors.cmx: kernel/environ.cmx kernel/names.cmx lib/pp.cmx \ +kernel/type_errors.cmx: kernel/environ.cmx kernel/names.cmx \ kernel/reduction.cmx kernel/sign.cmx kernel/term.cmx \ kernel/type_errors.cmi kernel/typeops.cmo: kernel/declarations.cmi kernel/environ.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/names.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/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/names.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: lib/hashcons.cmi kernel/names.cmi lib/pp.cmi lib/util.cmi \ kernel/univ.cmi kernel/univ.cmx: lib/hashcons.cmx kernel/names.cmx lib/pp.cmx lib/util.cmx \ @@ -409,103 +420,89 @@ lib/edit.cmo: lib/bstack.cmi lib/pp.cmi lib/util.cmi lib/edit.cmi lib/edit.cmx: lib/bstack.cmx lib/pp.cmx lib/util.cmx lib/edit.cmi lib/explore.cmo: lib/explore.cmi lib/explore.cmx: lib/explore.cmi -lib/gmap.cmo: lib/gmap.cmi -lib/gmap.cmx: lib/gmap.cmi lib/gmapl.cmo: lib/gmap.cmi lib/util.cmi lib/gmapl.cmi lib/gmapl.cmx: lib/gmap.cmx lib/util.cmx lib/gmapl.cmi +lib/gmap.cmo: lib/gmap.cmi +lib/gmap.cmx: lib/gmap.cmi lib/gset.cmo: lib/gset.cmi lib/gset.cmx: lib/gset.cmi lib/hashcons.cmo: lib/hashcons.cmi lib/hashcons.cmx: lib/hashcons.cmi lib/options.cmo: lib/util.cmi lib/options.cmi lib/options.cmx: lib/util.cmx lib/options.cmi -lib/pp.cmo: lib/pp_control.cmi lib/pp.cmi -lib/pp.cmx: lib/pp_control.cmx lib/pp.cmi lib/pp_control.cmo: lib/pp_control.cmi lib/pp_control.cmx: lib/pp_control.cmi +lib/pp.cmo: lib/pp_control.cmi lib/pp.cmi +lib/pp.cmx: lib/pp_control.cmx lib/pp.cmi lib/predicate.cmo: lib/predicate.cmi lib/predicate.cmx: lib/predicate.cmi lib/profile.cmo: lib/profile.cmi lib/profile.cmx: lib/profile.cmi -lib/stamps.cmo: lib/stamps.cmi -lib/stamps.cmx: lib/stamps.cmi -lib/system.cmo: config/coq_config.cmi lib/pp.cmi lib/util.cmi lib/system.cmi -lib/system.cmx: config/coq_config.cmx lib/pp.cmx lib/util.cmx lib/system.cmi -lib/tlm.cmo: lib/gmap.cmi lib/gset.cmi lib/tlm.cmi -lib/tlm.cmx: lib/gmap.cmx lib/gset.cmx lib/tlm.cmi -lib/util.cmo: lib/pp.cmi lib/util.cmi -lib/util.cmx: lib/pp.cmx lib/util.cmi library/declare.cmo: kernel/cooking.cmi kernel/declarations.cmi \ - kernel/environ.cmi kernel/evd.cmi library/global.cmi library/impargs.cmi \ - library/indrec.cmi kernel/inductive.cmi library/lib.cmi \ - library/libobject.cmi library/library.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 kernel/univ.cmi lib/util.cmi \ - library/declare.cmi + kernel/environ.cmi library/global.cmi library/impargs.cmi \ + kernel/indtypes.cmi kernel/inductive.cmi library/lib.cmi \ + library/libobject.cmi library/library.cmi library/nameops.cmi \ + kernel/names.cmi library/nametab.cmi lib/pp.cmi kernel/reduction.cmi \ + kernel/safe_typing.cmi kernel/sign.cmi library/summary.cmi \ + kernel/term.cmi kernel/type_errors.cmi kernel/typeops.cmi kernel/univ.cmi \ + lib/util.cmi library/declare.cmi library/declare.cmx: kernel/cooking.cmx kernel/declarations.cmx \ - kernel/environ.cmx kernel/evd.cmx library/global.cmx library/impargs.cmx \ - library/indrec.cmx kernel/inductive.cmx library/lib.cmx \ - library/libobject.cmx library/library.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 kernel/univ.cmx lib/util.cmx \ - library/declare.cmi -library/global.cmo: kernel/environ.cmi kernel/inductive.cmi \ - kernel/instantiate.cmi kernel/names.cmi library/nametab.cmi \ + kernel/environ.cmx library/global.cmx library/impargs.cmx \ + kernel/indtypes.cmx kernel/inductive.cmx library/lib.cmx \ + library/libobject.cmx library/library.cmx library/nameops.cmx \ + kernel/names.cmx library/nametab.cmx lib/pp.cmx kernel/reduction.cmx \ + kernel/safe_typing.cmx kernel/sign.cmx library/summary.cmx \ + kernel/term.cmx kernel/type_errors.cmx kernel/typeops.cmx kernel/univ.cmx \ + lib/util.cmx library/declare.cmi +library/global.cmo: kernel/environ.cmi kernel/inductive.cmi kernel/names.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/names.cmx library/nametab.cmx \ +library/global.cmx: kernel/environ.cmx kernel/inductive.cmx kernel/names.cmx \ kernel/safe_typing.cmx kernel/sign.cmx library/summary.cmx \ kernel/term.cmx lib/util.cmx library/global.cmi library/goptions.cmo: library/global.cmi library/lib.cmi \ - library/libobject.cmi kernel/names.cmi lib/pp.cmi library/summary.cmi \ - kernel/term.cmi lib/util.cmi library/goptions.cmi + library/libobject.cmi kernel/names.cmi library/nametab.cmi lib/pp.cmi \ + library/summary.cmi kernel/term.cmi lib/util.cmi library/goptions.cmi library/goptions.cmx: library/global.cmx library/lib.cmx \ - library/libobject.cmx kernel/names.cmx lib/pp.cmx library/summary.cmx \ - kernel/term.cmx lib/util.cmx library/goptions.cmi + library/libobject.cmx kernel/names.cmx library/nametab.cmx lib/pp.cmx \ + library/summary.cmx kernel/term.cmx lib/util.cmx library/goptions.cmi library/impargs.cmo: kernel/declarations.cmi kernel/environ.cmi \ - kernel/evd.cmi library/global.cmi kernel/inductive.cmi library/lib.cmi \ - library/libobject.cmi kernel/names.cmi kernel/reduction.cmi \ - library/summary.cmi kernel/term.cmi kernel/typeops.cmi lib/util.cmi \ + library/global.cmi kernel/inductive.cmi library/lib.cmi \ + library/libobject.cmi kernel/names.cmi library/nametab.cmi \ + kernel/reduction.cmi library/summary.cmi kernel/term.cmi lib/util.cmi \ library/impargs.cmi library/impargs.cmx: kernel/declarations.cmx kernel/environ.cmx \ - kernel/evd.cmx library/global.cmx kernel/inductive.cmx library/lib.cmx \ - library/libobject.cmx kernel/names.cmx kernel/reduction.cmx \ - library/summary.cmx kernel/term.cmx kernel/typeops.cmx lib/util.cmx \ + library/global.cmx kernel/inductive.cmx library/lib.cmx \ + library/libobject.cmx kernel/names.cmx library/nametab.cmx \ + kernel/reduction.cmx library/summary.cmx kernel/term.cmx lib/util.cmx \ library/impargs.cmi -library/indrec.cmo: kernel/declarations.cmi kernel/environ.cmi \ - kernel/indtypes.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/typeops.cmi lib/util.cmi \ - library/indrec.cmi -library/indrec.cmx: kernel/declarations.cmx kernel/environ.cmx \ - kernel/indtypes.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/typeops.cmx lib/util.cmx \ - library/indrec.cmi -library/lib.cmo: library/libobject.cmi kernel/names.cmi library/nametab.cmi \ - lib/pp.cmi library/summary.cmi kernel/univ.cmi lib/util.cmi \ - library/lib.cmi -library/lib.cmx: library/libobject.cmx kernel/names.cmx library/nametab.cmx \ - lib/pp.cmx library/summary.cmx kernel/univ.cmx lib/util.cmx \ - library/lib.cmi +library/lib.cmo: library/libobject.cmi library/nameops.cmi kernel/names.cmi \ + library/nametab.cmi lib/pp.cmi library/summary.cmi kernel/univ.cmi \ + lib/util.cmi library/lib.cmi +library/lib.cmx: library/libobject.cmx library/nameops.cmx kernel/names.cmx \ + library/nametab.cmx lib/pp.cmx library/summary.cmx kernel/univ.cmx \ + lib/util.cmx library/lib.cmi 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 library/nametab.cmi \ - lib/options.cmi lib/pp.cmi library/summary.cmi lib/system.cmi \ - lib/util.cmi library/library.cmi + library/libobject.cmi library/nameops.cmi kernel/names.cmi \ + library/nametab.cmi lib/options.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 library/nametab.cmx \ - lib/options.cmx lib/pp.cmx library/summary.cmx lib/system.cmx \ - lib/util.cmx library/library.cmi -library/nametab.cmo: kernel/names.cmi lib/pp.cmi library/summary.cmi \ + library/libobject.cmx library/nameops.cmx kernel/names.cmx \ + library/nametab.cmx lib/options.cmx lib/pp.cmx library/summary.cmx \ + lib/system.cmx lib/util.cmx library/library.cmi +library/nameops.cmo: kernel/declarations.cmi kernel/environ.cmi \ + kernel/names.cmi kernel/term.cmi lib/util.cmi library/nameops.cmi +library/nameops.cmx: kernel/declarations.cmx kernel/environ.cmx \ + kernel/names.cmx kernel/term.cmx lib/util.cmx library/nameops.cmi +library/nametab.cmo: kernel/declarations.cmi kernel/environ.cmi \ + library/nameops.cmi kernel/names.cmi lib/pp.cmi library/summary.cmi \ lib/util.cmi library/nametab.cmi -library/nametab.cmx: kernel/names.cmx lib/pp.cmx library/summary.cmx \ +library/nametab.cmx: kernel/declarations.cmx kernel/environ.cmx \ + library/nameops.cmx kernel/names.cmx lib/pp.cmx library/summary.cmx \ lib/util.cmx library/nametab.cmi library/opaque.cmo: kernel/closure.cmi kernel/declarations.cmi \ kernel/environ.cmi library/global.cmi kernel/names.cmi \ @@ -521,26 +518,36 @@ 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 \ library/summary.cmi +lib/stamps.cmo: lib/stamps.cmi +lib/stamps.cmx: lib/stamps.cmi +lib/system.cmo: config/coq_config.cmi lib/pp.cmi lib/util.cmi lib/system.cmi +lib/system.cmx: config/coq_config.cmx lib/pp.cmx lib/util.cmx lib/system.cmi +lib/tlm.cmo: lib/gmap.cmi lib/gset.cmi lib/tlm.cmi +lib/tlm.cmx: lib/gmap.cmx lib/gset.cmx lib/tlm.cmi +lib/util.cmo: lib/pp.cmi lib/util.cmi +lib/util.cmx: lib/pp.cmx lib/util.cmi parsing/ast.cmo: parsing/coqast.cmi lib/dyn.cmi kernel/names.cmi \ parsing/pcoq.cmi lib/pp.cmi lib/util.cmi parsing/ast.cmi parsing/ast.cmx: parsing/coqast.cmx lib/dyn.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 \ - lib/dyn.cmi kernel/environ.cmi pretyping/evarutil.cmi kernel/evd.cmi \ - library/global.cmi library/impargs.cmi kernel/names.cmi \ - library/nametab.cmi lib/options.cmi pretyping/pattern.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 \ - parsing/termast.cmi pretyping/typing.cmi lib/util.cmi parsing/astterm.cmi + lib/dyn.cmi kernel/environ.cmi pretyping/evarutil.cmi pretyping/evd.cmi \ + library/global.cmi library/impargs.cmi library/nameops.cmi \ + kernel/names.cmi library/nametab.cmi lib/options.cmi \ + pretyping/pattern.cmi lib/pp.cmi pretyping/pretype_errors.cmi \ + pretyping/pretyping.cmi pretyping/rawterm.cmi pretyping/reductionops.cmi \ + pretyping/retyping.cmi kernel/sign.cmi pretyping/syntax_def.cmi \ + kernel/term.cmi parsing/termast.cmi pretyping/termops.cmi \ + pretyping/typing.cmi lib/util.cmi parsing/astterm.cmi parsing/astterm.cmx: parsing/ast.cmx parsing/coqast.cmx library/declare.cmx \ - lib/dyn.cmx kernel/environ.cmx pretyping/evarutil.cmx kernel/evd.cmx \ - library/global.cmx library/impargs.cmx kernel/names.cmx \ - library/nametab.cmx lib/options.cmx pretyping/pattern.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 \ - parsing/termast.cmx pretyping/typing.cmx lib/util.cmx parsing/astterm.cmi + lib/dyn.cmx kernel/environ.cmx pretyping/evarutil.cmx pretyping/evd.cmx \ + library/global.cmx library/impargs.cmx library/nameops.cmx \ + kernel/names.cmx library/nametab.cmx lib/options.cmx \ + pretyping/pattern.cmx lib/pp.cmx pretyping/pretype_errors.cmx \ + pretyping/pretyping.cmx pretyping/rawterm.cmx pretyping/reductionops.cmx \ + pretyping/retyping.cmx kernel/sign.cmx pretyping/syntax_def.cmx \ + kernel/term.cmx parsing/termast.cmx pretyping/termops.cmx \ + pretyping/typing.cmx lib/util.cmx parsing/astterm.cmi parsing/coqast.cmo: lib/dyn.cmi lib/hashcons.cmi kernel/names.cmi \ parsing/coqast.cmi parsing/coqast.cmx: lib/dyn.cmx lib/hashcons.cmx kernel/names.cmx \ @@ -622,315 +629,411 @@ parsing/pcoq.cmo: parsing/coqast.cmi parsing/lexer.cmi lib/pp.cmi \ parsing/pcoq.cmx: parsing/coqast.cmx parsing/lexer.cmx lib/pp.cmx \ lib/util.cmx parsing/pcoq.cmi parsing/prettyp.cmo: pretyping/classops.cmi kernel/declarations.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 kernel/names.cmi \ + library/declare.cmi kernel/environ.cmi pretyping/evd.cmi \ + library/global.cmi library/impargs.cmi kernel/inductive.cmi \ + pretyping/inductiveops.cmi pretyping/instantiate.cmi library/lib.cmi \ + library/libobject.cmi library/nameops.cmi kernel/names.cmi \ library/nametab.cmi lib/pp.cmi parsing/printer.cmi kernel/reduction.cmi \ kernel/safe_typing.cmi kernel/sign.cmi pretyping/syntax_def.cmi \ - kernel/term.cmi kernel/typeops.cmi lib/util.cmi parsing/prettyp.cmi + kernel/term.cmi pretyping/termops.cmi lib/util.cmi parsing/prettyp.cmi parsing/prettyp.cmx: pretyping/classops.cmx kernel/declarations.cmx \ - 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 kernel/names.cmx \ + library/declare.cmx kernel/environ.cmx pretyping/evd.cmx \ + library/global.cmx library/impargs.cmx kernel/inductive.cmx \ + pretyping/inductiveops.cmx pretyping/instantiate.cmx library/lib.cmx \ + library/libobject.cmx library/nameops.cmx kernel/names.cmx \ library/nametab.cmx lib/pp.cmx parsing/printer.cmx kernel/reduction.cmx \ kernel/safe_typing.cmx kernel/sign.cmx pretyping/syntax_def.cmx \ - kernel/term.cmx kernel/typeops.cmx lib/util.cmx parsing/prettyp.cmi + kernel/term.cmx pretyping/termops.cmx lib/util.cmx parsing/prettyp.cmi parsing/printer.cmo: parsing/ast.cmi parsing/coqast.cmi library/declare.cmi \ lib/dyn.cmi kernel/environ.cmi parsing/esyntax.cmi parsing/extend.cmi \ - library/global.cmi kernel/names.cmi lib/options.cmi pretyping/pattern.cmi \ - lib/pp.cmi kernel/sign.cmi kernel/term.cmi parsing/termast.cmi \ - lib/util.cmi parsing/printer.cmi + library/global.cmi kernel/names.cmi library/nametab.cmi lib/options.cmi \ + pretyping/pattern.cmi lib/pp.cmi kernel/sign.cmi kernel/term.cmi \ + parsing/termast.cmi pretyping/termops.cmi lib/util.cmi \ + parsing/printer.cmi parsing/printer.cmx: parsing/ast.cmx parsing/coqast.cmx library/declare.cmx \ lib/dyn.cmx kernel/environ.cmx parsing/esyntax.cmx parsing/extend.cmx \ - library/global.cmx kernel/names.cmx lib/options.cmx pretyping/pattern.cmx \ - lib/pp.cmx kernel/sign.cmx kernel/term.cmx parsing/termast.cmx \ - lib/util.cmx parsing/printer.cmi + library/global.cmx kernel/names.cmx library/nametab.cmx lib/options.cmx \ + pretyping/pattern.cmx lib/pp.cmx kernel/sign.cmx kernel/term.cmx \ + parsing/termast.cmx pretyping/termops.cmx lib/util.cmx \ + parsing/printer.cmi parsing/q_coqast.cmo: parsing/coqast.cmi kernel/names.cmi parsing/pcoq.cmi parsing/q_coqast.cmx: parsing/coqast.cmx kernel/names.cmx parsing/pcoq.cmx parsing/search.cmo: parsing/astterm.cmi parsing/coqast.cmi parsing/coqlib.cmi \ kernel/declarations.cmi library/declare.cmi kernel/environ.cmi \ - kernel/evd.cmi library/global.cmi library/libobject.cmi \ - library/library.cmi kernel/names.cmi pretyping/pattern.cmi lib/pp.cmi \ + pretyping/evd.cmi library/global.cmi library/libobject.cmi \ + library/library.cmi library/nameops.cmi kernel/names.cmi \ + library/nametab.cmi pretyping/pattern.cmi lib/pp.cmi \ pretyping/pretyping.cmi parsing/printer.cmi pretyping/rawterm.cmi \ pretyping/retyping.cmi kernel/term.cmi pretyping/typing.cmi lib/util.cmi \ parsing/search.cmi parsing/search.cmx: parsing/astterm.cmx parsing/coqast.cmx parsing/coqlib.cmx \ kernel/declarations.cmx library/declare.cmx kernel/environ.cmx \ - kernel/evd.cmx library/global.cmx library/libobject.cmx \ - library/library.cmx kernel/names.cmx pretyping/pattern.cmx lib/pp.cmx \ + pretyping/evd.cmx library/global.cmx library/libobject.cmx \ + library/library.cmx library/nameops.cmx kernel/names.cmx \ + library/nametab.cmx pretyping/pattern.cmx lib/pp.cmx \ pretyping/pretyping.cmx parsing/printer.cmx pretyping/rawterm.cmx \ pretyping/retyping.cmx kernel/term.cmx pretyping/typing.cmx lib/util.cmx \ parsing/search.cmi parsing/termast.cmo: parsing/ast.cmi pretyping/classops.cmi \ parsing/coqast.cmi library/declare.cmi pretyping/detyping.cmi \ kernel/environ.cmi library/impargs.cmi kernel/inductive.cmi \ - kernel/names.cmi library/nametab.cmi pretyping/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 + library/nameops.cmi kernel/names.cmi library/nametab.cmi \ + pretyping/pattern.cmi lib/pp.cmi pretyping/rawterm.cmi \ + pretyping/reductionops.cmi kernel/sign.cmi kernel/term.cmi \ + pretyping/termops.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 library/impargs.cmx kernel/inductive.cmx \ - kernel/names.cmx library/nametab.cmx pretyping/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 + library/nameops.cmx kernel/names.cmx library/nametab.cmx \ + pretyping/pattern.cmx lib/pp.cmx pretyping/rawterm.cmx \ + pretyping/reductionops.cmx kernel/sign.cmx kernel/term.cmx \ + pretyping/termops.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 \ - 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 lib/util.cmi \ - pretyping/cases.cmi + library/global.cmi kernel/inductive.cmi pretyping/inductiveops.cmi \ + library/nameops.cmi kernel/names.cmi lib/pp.cmi \ + pretyping/pretype_errors.cmi pretyping/rawterm.cmi \ + pretyping/reductionops.cmi pretyping/retyping.cmi kernel/sign.cmi \ + kernel/term.cmi pretyping/termops.cmi kernel/type_errors.cmi \ + kernel/typeops.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 \ - 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 lib/util.cmx \ - pretyping/cases.cmi + library/global.cmx kernel/inductive.cmx pretyping/inductiveops.cmx \ + library/nameops.cmx kernel/names.cmx lib/pp.cmx \ + pretyping/pretype_errors.cmx pretyping/rawterm.cmx \ + pretyping/reductionops.cmx pretyping/retyping.cmx kernel/sign.cmx \ + kernel/term.cmx pretyping/termops.cmx kernel/type_errors.cmx \ + kernel/typeops.cmx lib/util.cmx pretyping/cases.cmi pretyping/cbv.cmo: kernel/closure.cmi kernel/declarations.cmi \ - kernel/environ.cmi kernel/esubst.cmi kernel/evd.cmi \ - kernel/instantiate.cmi kernel/names.cmi lib/pp.cmi kernel/term.cmi \ + kernel/environ.cmi kernel/esubst.cmi pretyping/evd.cmi \ + pretyping/instantiate.cmi kernel/names.cmi lib/pp.cmi kernel/term.cmi \ kernel/univ.cmi lib/util.cmi pretyping/cbv.cmi pretyping/cbv.cmx: kernel/closure.cmx kernel/declarations.cmx \ - kernel/environ.cmx kernel/esubst.cmx kernel/evd.cmx \ - kernel/instantiate.cmx kernel/names.cmx lib/pp.cmx kernel/term.cmx \ + kernel/environ.cmx kernel/esubst.cmx pretyping/evd.cmx \ + pretyping/instantiate.cmx kernel/names.cmx lib/pp.cmx kernel/term.cmx \ kernel/univ.cmx lib/util.cmx pretyping/cbv.cmi pretyping/classops.cmo: library/declare.cmi kernel/environ.cmi \ library/global.cmi library/lib.cmi library/libobject.cmi \ - library/library.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/library.cmi kernel/names.cmi library/nametab.cmi lib/options.cmi \ + lib/pp.cmi pretyping/rawterm.cmi library/summary.cmi pretyping/tacred.cmi \ + kernel/term.cmi pretyping/termops.cmi lib/util.cmi pretyping/classops.cmi pretyping/classops.cmx: library/declare.cmx kernel/environ.cmx \ library/global.cmx library/lib.cmx library/libobject.cmx \ - library/library.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/library.cmx kernel/names.cmx library/nametab.cmx lib/options.cmx \ + lib/pp.cmx pretyping/rawterm.cmx library/summary.cmx pretyping/tacred.cmx \ + kernel/term.cmx pretyping/termops.cmx lib/util.cmx pretyping/classops.cmi pretyping/coercion.cmo: pretyping/classops.cmi kernel/environ.cmi \ - pretyping/evarconv.cmi pretyping/evarutil.cmi kernel/evd.cmi \ + pretyping/evarconv.cmi pretyping/evarutil.cmi pretyping/evd.cmi \ kernel/names.cmi pretyping/pretype_errors.cmi pretyping/rawterm.cmi \ - pretyping/recordops.cmi kernel/reduction.cmi pretyping/retyping.cmi \ + pretyping/recordops.cmi pretyping/reductionops.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 pretyping/evarutil.cmx kernel/evd.cmx \ + pretyping/evarconv.cmx pretyping/evarutil.cmx pretyping/evd.cmx \ kernel/names.cmx pretyping/pretype_errors.cmx pretyping/rawterm.cmx \ - pretyping/recordops.cmx kernel/reduction.cmx pretyping/retyping.cmx \ + pretyping/recordops.cmx pretyping/reductionops.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/environ.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 \ + library/impargs.cmi kernel/inductive.cmi library/nameops.cmi \ + kernel/names.cmi library/nametab.cmi lib/pp.cmi pretyping/rawterm.cmi \ + kernel/sign.cmi kernel/term.cmi pretyping/termops.cmi kernel/univ.cmi \ lib/util.cmi pretyping/detyping.cmi pretyping/detyping.cmx: kernel/declarations.cmx library/declare.cmx \ kernel/environ.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 \ + library/impargs.cmx kernel/inductive.cmx library/nameops.cmx \ + kernel/names.cmx library/nametab.cmx lib/pp.cmx pretyping/rawterm.cmx \ + kernel/sign.cmx kernel/term.cmx pretyping/termops.cmx kernel/univ.cmx \ lib/util.cmx pretyping/detyping.cmi pretyping/evarconv.cmo: pretyping/classops.cmi kernel/closure.cmi \ library/declare.cmi kernel/environ.cmi pretyping/evarutil.cmi \ - kernel/evd.cmi kernel/instantiate.cmi kernel/names.cmi \ - pretyping/recordops.cmi kernel/reduction.cmi kernel/term.cmi \ + pretyping/evd.cmi pretyping/instantiate.cmi kernel/names.cmi \ + pretyping/recordops.cmi pretyping/reductionops.cmi kernel/term.cmi \ pretyping/typing.cmi lib/util.cmi pretyping/evarconv.cmi pretyping/evarconv.cmx: pretyping/classops.cmx kernel/closure.cmx \ library/declare.cmx kernel/environ.cmx pretyping/evarutil.cmx \ - kernel/evd.cmx kernel/instantiate.cmx kernel/names.cmx \ - pretyping/recordops.cmx kernel/reduction.cmx kernel/term.cmx \ + pretyping/evd.cmx pretyping/instantiate.cmx kernel/names.cmx \ + pretyping/recordops.cmx pretyping/reductionops.cmx kernel/term.cmx \ pretyping/typing.cmx lib/util.cmx pretyping/evarconv.cmi -pretyping/evarutil.cmo: kernel/environ.cmi kernel/evd.cmi library/global.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/typeops.cmi kernel/univ.cmi lib/util.cmi \ - pretyping/evarutil.cmi -pretyping/evarutil.cmx: kernel/environ.cmx kernel/evd.cmx library/global.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/typeops.cmx kernel/univ.cmx lib/util.cmx \ - pretyping/evarutil.cmi +pretyping/evarutil.cmo: kernel/environ.cmi pretyping/evd.cmi \ + library/global.cmi pretyping/indrec.cmi pretyping/instantiate.cmi \ + library/nameops.cmi kernel/names.cmi lib/pp.cmi \ + pretyping/pretype_errors.cmi pretyping/reductionops.cmi kernel/sign.cmi \ + kernel/term.cmi pretyping/termops.cmi kernel/typeops.cmi kernel/univ.cmi \ + lib/util.cmi pretyping/evarutil.cmi +pretyping/evarutil.cmx: kernel/environ.cmx pretyping/evd.cmx \ + library/global.cmx pretyping/indrec.cmx pretyping/instantiate.cmx \ + library/nameops.cmx kernel/names.cmx lib/pp.cmx \ + pretyping/pretype_errors.cmx pretyping/reductionops.cmx kernel/sign.cmx \ + kernel/term.cmx pretyping/termops.cmx kernel/typeops.cmx kernel/univ.cmx \ + lib/util.cmx pretyping/evarutil.cmi +pretyping/evd.cmo: kernel/names.cmi kernel/sign.cmi kernel/term.cmi \ + lib/util.cmi pretyping/evd.cmi +pretyping/evd.cmx: kernel/names.cmx kernel/sign.cmx kernel/term.cmx \ + lib/util.cmx pretyping/evd.cmi +pretyping/indrec.cmo: kernel/declarations.cmi library/declare.cmi \ + kernel/environ.cmi pretyping/evd.cmi library/global.cmi \ + kernel/indtypes.cmi kernel/inductive.cmi pretyping/inductiveops.cmi \ + pretyping/instantiate.cmi library/nameops.cmi kernel/names.cmi \ + library/nametab.cmi lib/options.cmi lib/pp.cmi pretyping/reductionops.cmi \ + kernel/safe_typing.cmi kernel/term.cmi pretyping/termops.cmi \ + kernel/type_errors.cmi kernel/typeops.cmi lib/util.cmi \ + pretyping/indrec.cmi +pretyping/indrec.cmx: kernel/declarations.cmx library/declare.cmx \ + kernel/environ.cmx pretyping/evd.cmx library/global.cmx \ + kernel/indtypes.cmx kernel/inductive.cmx pretyping/inductiveops.cmx \ + pretyping/instantiate.cmx library/nameops.cmx kernel/names.cmx \ + library/nametab.cmx lib/options.cmx lib/pp.cmx pretyping/reductionops.cmx \ + kernel/safe_typing.cmx kernel/term.cmx pretyping/termops.cmx \ + kernel/type_errors.cmx kernel/typeops.cmx lib/util.cmx \ + pretyping/indrec.cmi +pretyping/inductiveops.cmo: kernel/declarations.cmi kernel/environ.cmi \ + pretyping/evd.cmi kernel/inductive.cmi kernel/names.cmi \ + pretyping/reductionops.cmi kernel/sign.cmi kernel/term.cmi \ + pretyping/termops.cmi kernel/univ.cmi lib/util.cmi \ + pretyping/inductiveops.cmi +pretyping/inductiveops.cmx: kernel/declarations.cmx kernel/environ.cmx \ + pretyping/evd.cmx kernel/inductive.cmx kernel/names.cmx \ + pretyping/reductionops.cmx kernel/sign.cmx kernel/term.cmx \ + pretyping/termops.cmx kernel/univ.cmx lib/util.cmx \ + pretyping/inductiveops.cmi +pretyping/instantiate.cmo: kernel/declarations.cmi kernel/environ.cmi \ + pretyping/evd.cmi kernel/names.cmi lib/pp.cmi kernel/sign.cmi \ + kernel/term.cmi lib/util.cmi pretyping/instantiate.cmi +pretyping/instantiate.cmx: kernel/declarations.cmx kernel/environ.cmx \ + pretyping/evd.cmx kernel/names.cmx lib/pp.cmx kernel/sign.cmx \ + kernel/term.cmx lib/util.cmx pretyping/instantiate.cmi pretyping/pattern.cmo: library/declare.cmi kernel/environ.cmi \ - kernel/names.cmi pretyping/rawterm.cmi kernel/reduction.cmi \ - kernel/term.cmi lib/util.cmi pretyping/pattern.cmi + library/nameops.cmi kernel/names.cmi library/nametab.cmi \ + pretyping/rawterm.cmi pretyping/reductionops.cmi kernel/term.cmi \ + pretyping/termops.cmi lib/util.cmi pretyping/pattern.cmi pretyping/pattern.cmx: library/declare.cmx kernel/environ.cmx \ - kernel/names.cmx pretyping/rawterm.cmx kernel/reduction.cmx \ - kernel/term.cmx lib/util.cmx pretyping/pattern.cmi -pretyping/pretype_errors.cmo: kernel/environ.cmi kernel/evd.cmi \ - kernel/inductive.cmi kernel/instantiate.cmi kernel/names.cmi \ - pretyping/rawterm.cmi kernel/reduction.cmi kernel/sign.cmi \ - kernel/term.cmi kernel/type_errors.cmi lib/util.cmi \ + library/nameops.cmx kernel/names.cmx library/nametab.cmx \ + pretyping/rawterm.cmx pretyping/reductionops.cmx kernel/term.cmx \ + pretyping/termops.cmx lib/util.cmx pretyping/pattern.cmi +pretyping/pretype_errors.cmo: kernel/environ.cmi pretyping/evd.cmi \ + pretyping/inductiveops.cmi kernel/names.cmi pretyping/rawterm.cmi \ + kernel/reduction.cmi pretyping/reductionops.cmi kernel/sign.cmi \ + kernel/term.cmi pretyping/termops.cmi kernel/type_errors.cmi lib/util.cmi \ pretyping/pretype_errors.cmi -pretyping/pretype_errors.cmx: kernel/environ.cmx kernel/evd.cmx \ - kernel/inductive.cmx kernel/instantiate.cmx kernel/names.cmx \ - pretyping/rawterm.cmx kernel/reduction.cmx kernel/sign.cmx \ - kernel/term.cmx kernel/type_errors.cmx lib/util.cmx \ +pretyping/pretype_errors.cmx: kernel/environ.cmx pretyping/evd.cmx \ + pretyping/inductiveops.cmx kernel/names.cmx pretyping/rawterm.cmx \ + kernel/reduction.cmx pretyping/reductionops.cmx kernel/sign.cmx \ + kernel/term.cmx pretyping/termops.cmx kernel/type_errors.cmx lib/util.cmx \ pretyping/pretype_errors.cmi pretyping/pretyping.cmo: pretyping/cases.cmi pretyping/classops.cmi \ - pretyping/coercion.cmi library/declare.cmi lib/dyn.cmi kernel/environ.cmi \ - pretyping/evarconv.cmi pretyping/evarutil.cmi kernel/evd.cmi \ - library/indrec.cmi kernel/inductive.cmi kernel/instantiate.cmi \ + pretyping/coercion.cmi kernel/declarations.cmi library/declare.cmi \ + lib/dyn.cmi kernel/environ.cmi pretyping/evarconv.cmi \ + pretyping/evarutil.cmi pretyping/evd.cmi pretyping/indrec.cmi \ + kernel/inductive.cmi pretyping/inductiveops.cmi pretyping/instantiate.cmi \ kernel/names.cmi lib/pp.cmi pretyping/pretype_errors.cmi \ - pretyping/rawterm.cmi pretyping/recordops.cmi kernel/reduction.cmi \ + pretyping/rawterm.cmi pretyping/recordops.cmi pretyping/reductionops.cmi \ pretyping/retyping.cmi kernel/sign.cmi kernel/term.cmi \ - kernel/type_errors.cmi kernel/typeops.cmi lib/util.cmi \ - pretyping/pretyping.cmi + pretyping/termops.cmi kernel/type_errors.cmi kernel/typeops.cmi \ + lib/util.cmi pretyping/pretyping.cmi pretyping/pretyping.cmx: pretyping/cases.cmx pretyping/classops.cmx \ - pretyping/coercion.cmx library/declare.cmx lib/dyn.cmx kernel/environ.cmx \ - pretyping/evarconv.cmx pretyping/evarutil.cmx kernel/evd.cmx \ - library/indrec.cmx kernel/inductive.cmx kernel/instantiate.cmx \ + pretyping/coercion.cmx kernel/declarations.cmx library/declare.cmx \ + lib/dyn.cmx kernel/environ.cmx pretyping/evarconv.cmx \ + pretyping/evarutil.cmx pretyping/evd.cmx pretyping/indrec.cmx \ + kernel/inductive.cmx pretyping/inductiveops.cmx pretyping/instantiate.cmx \ kernel/names.cmx lib/pp.cmx pretyping/pretype_errors.cmx \ - pretyping/rawterm.cmx pretyping/recordops.cmx kernel/reduction.cmx \ + pretyping/rawterm.cmx pretyping/recordops.cmx pretyping/reductionops.cmx \ pretyping/retyping.cmx kernel/sign.cmx kernel/term.cmx \ - kernel/type_errors.cmx kernel/typeops.cmx lib/util.cmx \ - pretyping/pretyping.cmi -pretyping/rawterm.cmo: lib/dyn.cmi kernel/names.cmi kernel/sign.cmi \ - kernel/term.cmi kernel/univ.cmi lib/util.cmi pretyping/rawterm.cmi -pretyping/rawterm.cmx: lib/dyn.cmx kernel/names.cmx kernel/sign.cmx \ - kernel/term.cmx kernel/univ.cmx lib/util.cmx pretyping/rawterm.cmi + pretyping/termops.cmx kernel/type_errors.cmx kernel/typeops.cmx \ + lib/util.cmx pretyping/pretyping.cmi +pretyping/rawterm.cmo: lib/dyn.cmi kernel/names.cmi library/nametab.cmi \ + kernel/sign.cmi kernel/term.cmi kernel/univ.cmi lib/util.cmi \ + pretyping/rawterm.cmi +pretyping/rawterm.cmx: lib/dyn.cmx kernel/names.cmx library/nametab.cmx \ + kernel/sign.cmx kernel/term.cmx kernel/univ.cmx lib/util.cmx \ + pretyping/rawterm.cmi pretyping/recordops.cmo: pretyping/classops.cmi library/lib.cmi \ - library/libobject.cmi library/library.cmi kernel/names.cmi lib/pp.cmi \ - library/summary.cmi kernel/term.cmi kernel/typeops.cmi lib/util.cmi \ + library/libobject.cmi library/library.cmi kernel/names.cmi \ + library/nametab.cmi lib/pp.cmi library/summary.cmi kernel/term.cmi \ + pretyping/termops.cmi kernel/typeops.cmi lib/util.cmi \ pretyping/recordops.cmi 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 \ + library/libobject.cmx library/library.cmx kernel/names.cmx \ + library/nametab.cmx lib/pp.cmx library/summary.cmx kernel/term.cmx \ + pretyping/termops.cmx kernel/typeops.cmx lib/util.cmx \ pretyping/recordops.cmi -pretyping/retyping.cmo: kernel/environ.cmi kernel/inductive.cmi \ - kernel/names.cmi kernel/reduction.cmi kernel/term.cmi kernel/typeops.cmi \ +pretyping/reductionops.cmo: kernel/closure.cmi kernel/declarations.cmi \ + kernel/environ.cmi kernel/esubst.cmi pretyping/evd.cmi \ + pretyping/instantiate.cmi kernel/names.cmi lib/pp.cmi kernel/sign.cmi \ + kernel/term.cmi pretyping/termops.cmi kernel/univ.cmi lib/util.cmi \ + pretyping/reductionops.cmi +pretyping/reductionops.cmx: kernel/closure.cmx kernel/declarations.cmx \ + kernel/environ.cmx kernel/esubst.cmx pretyping/evd.cmx \ + pretyping/instantiate.cmx kernel/names.cmx lib/pp.cmx kernel/sign.cmx \ + kernel/term.cmx pretyping/termops.cmx kernel/univ.cmx lib/util.cmx \ + pretyping/reductionops.cmi +pretyping/retyping.cmo: kernel/declarations.cmi kernel/environ.cmi \ + kernel/inductive.cmi pretyping/instantiate.cmi kernel/names.cmi \ + pretyping/reductionops.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 \ +pretyping/retyping.cmx: kernel/declarations.cmx kernel/environ.cmx \ + kernel/inductive.cmx pretyping/instantiate.cmx kernel/names.cmx \ + pretyping/reductionops.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 lib/pp.cmi pretyping/rawterm.cmi \ - library/summary.cmi lib/util.cmi pretyping/syntax_def.cmi + library/nameops.cmi kernel/names.cmi library/nametab.cmi lib/pp.cmi \ + pretyping/rawterm.cmi library/summary.cmi lib/util.cmi \ + pretyping/syntax_def.cmi pretyping/syntax_def.cmx: library/lib.cmx library/libobject.cmx \ - kernel/names.cmx library/nametab.cmx lib/pp.cmx pretyping/rawterm.cmx \ - library/summary.cmx lib/util.cmx pretyping/syntax_def.cmi + library/nameops.cmx kernel/names.cmx library/nametab.cmx lib/pp.cmx \ + pretyping/rawterm.cmx library/summary.cmx lib/util.cmx \ + pretyping/syntax_def.cmi pretyping/tacred.cmo: pretyping/cbv.cmi kernel/closure.cmi kernel/environ.cmi \ - kernel/evd.cmi kernel/inductive.cmi kernel/instantiate.cmi \ - kernel/names.cmi library/opaque.cmi lib/pp.cmi kernel/reduction.cmi \ - library/summary.cmi kernel/term.cmi lib/util.cmi pretyping/tacred.cmi + pretyping/evd.cmi kernel/inductive.cmi pretyping/instantiate.cmi \ + library/nameops.cmi kernel/names.cmi library/opaque.cmi lib/pp.cmi \ + pretyping/reductionops.cmi library/summary.cmi kernel/term.cmi \ + pretyping/termops.cmi lib/util.cmi pretyping/tacred.cmi pretyping/tacred.cmx: pretyping/cbv.cmx kernel/closure.cmx kernel/environ.cmx \ - kernel/evd.cmx kernel/inductive.cmx kernel/instantiate.cmx \ - kernel/names.cmx library/opaque.cmx lib/pp.cmx kernel/reduction.cmx \ - library/summary.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 \ + pretyping/evd.cmx kernel/inductive.cmx pretyping/instantiate.cmx \ + library/nameops.cmx kernel/names.cmx library/opaque.cmx lib/pp.cmx \ + pretyping/reductionops.cmx library/summary.cmx kernel/term.cmx \ + pretyping/termops.cmx lib/util.cmx pretyping/tacred.cmi +pretyping/termops.cmo: kernel/environ.cmi library/global.cmi \ + library/nameops.cmi kernel/names.cmi library/nametab.cmi lib/pp.cmi \ + kernel/sign.cmi kernel/term.cmi kernel/univ.cmi lib/util.cmi \ + pretyping/termops.cmi +pretyping/termops.cmx: kernel/environ.cmx library/global.cmx \ + library/nameops.cmx kernel/names.cmx library/nametab.cmx lib/pp.cmx \ + kernel/sign.cmx kernel/term.cmx kernel/univ.cmx lib/util.cmx \ + pretyping/termops.cmi +pretyping/typing.cmo: kernel/environ.cmi kernel/inductive.cmi \ + pretyping/instantiate.cmi kernel/names.cmi pretyping/pretype_errors.cmi \ + pretyping/reductionops.cmi kernel/term.cmi kernel/type_errors.cmi \ kernel/typeops.cmi lib/util.cmi pretyping/typing.cmi -pretyping/typing.cmx: kernel/environ.cmx kernel/names.cmx \ - kernel/reduction.cmx kernel/term.cmx kernel/type_errors.cmx \ +pretyping/typing.cmx: kernel/environ.cmx kernel/inductive.cmx \ + pretyping/instantiate.cmx kernel/names.cmx pretyping/pretype_errors.cmx \ + pretyping/reductionops.cmx kernel/term.cmx kernel/type_errors.cmx \ kernel/typeops.cmx lib/util.cmx pretyping/typing.cmi proofs/clenv.cmo: kernel/environ.cmi proofs/evar_refiner.cmi \ - pretyping/evarutil.cmi kernel/evd.cmi kernel/instantiate.cmi \ + pretyping/evarutil.cmi pretyping/evd.cmi pretyping/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/proof_type.cmi pretyping/reductionops.cmi pretyping/retyping.cmi \ + kernel/sign.cmi proofs/tacmach.cmi kernel/term.cmi pretyping/termops.cmi \ + pretyping/typing.cmi lib/util.cmi proofs/clenv.cmi proofs/clenv.cmx: kernel/environ.cmx proofs/evar_refiner.cmx \ - pretyping/evarutil.cmx kernel/evd.cmx kernel/instantiate.cmx \ + pretyping/evarutil.cmx pretyping/evd.cmx pretyping/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/proof_type.cmx pretyping/reductionops.cmx pretyping/retyping.cmx \ + kernel/sign.cmx proofs/tacmach.cmx kernel/term.cmx pretyping/termops.cmx \ + pretyping/typing.cmx lib/util.cmx proofs/clenv.cmi proofs/evar_refiner.cmo: parsing/astterm.cmi kernel/environ.cmi \ - pretyping/evarutil.cmi kernel/evd.cmi library/global.cmi \ - kernel/instantiate.cmi proofs/logic.cmi kernel/names.cmi lib/options.cmi \ - lib/pp.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/evar_refiner.cmi + pretyping/evarutil.cmi pretyping/evd.cmi library/global.cmi \ + pretyping/instantiate.cmi proofs/logic.cmi kernel/names.cmi \ + lib/options.cmi lib/pp.cmi proofs/proof_trees.cmi proofs/proof_type.cmi \ + pretyping/reductionops.cmi proofs/refiner.cmi kernel/sign.cmi \ + lib/stamps.cmi pretyping/tacred.cmi kernel/term.cmi pretyping/typing.cmi \ + lib/util.cmi proofs/evar_refiner.cmi proofs/evar_refiner.cmx: parsing/astterm.cmx kernel/environ.cmx \ - pretyping/evarutil.cmx kernel/evd.cmx library/global.cmx \ - kernel/instantiate.cmx proofs/logic.cmx kernel/names.cmx lib/options.cmx \ - lib/pp.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/evar_refiner.cmi + pretyping/evarutil.cmx pretyping/evd.cmx library/global.cmx \ + pretyping/instantiate.cmx proofs/logic.cmx kernel/names.cmx \ + lib/options.cmx lib/pp.cmx proofs/proof_trees.cmx proofs/proof_type.cmx \ + pretyping/reductionops.cmx proofs/refiner.cmx kernel/sign.cmx \ + lib/stamps.cmx pretyping/tacred.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 \ - pretyping/evarutil.cmi kernel/evd.cmi library/global.cmi \ - kernel/inductive.cmi kernel/names.cmi library/nametab.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 + pretyping/evarutil.cmi pretyping/evd.cmi library/global.cmi \ + kernel/inductive.cmi pretyping/inductiveops.cmi kernel/names.cmi \ + library/nametab.cmi lib/pp.cmi parsing/printer.cmi proofs/proof_trees.cmi \ + proofs/proof_type.cmi pretyping/reductionops.cmi pretyping/retyping.cmi \ + kernel/sign.cmi kernel/term.cmi pretyping/termops.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 \ - pretyping/evarutil.cmx kernel/evd.cmx library/global.cmx \ - kernel/inductive.cmx kernel/names.cmx library/nametab.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 + pretyping/evarutil.cmx pretyping/evd.cmx library/global.cmx \ + kernel/inductive.cmx pretyping/inductiveops.cmx kernel/names.cmx \ + library/nametab.cmx lib/pp.cmx parsing/printer.cmx proofs/proof_trees.cmx \ + proofs/proof_type.cmx pretyping/reductionops.cmx pretyping/retyping.cmx \ + kernel/sign.cmx kernel/term.cmx pretyping/termops.cmx \ + kernel/type_errors.cmx kernel/typeops.cmx pretyping/typing.cmx \ + lib/util.cmx proofs/logic.cmi proofs/pfedit.cmo: parsing/astterm.cmi kernel/declarations.cmi \ - library/declare.cmi lib/edit.cmi kernel/environ.cmi kernel/evd.cmi \ + library/declare.cmi lib/edit.cmi kernel/environ.cmi pretyping/evd.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/proof_type.cmi kernel/safe_typing.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 \ + library/declare.cmx lib/edit.cmx kernel/environ.cmx pretyping/evd.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 + proofs/proof_type.cmx kernel/safe_typing.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 kernel/closure.cmi \ pretyping/detyping.cmi kernel/environ.cmi pretyping/evarutil.cmi \ - kernel/evd.cmi library/global.cmi kernel/names.cmi lib/pp.cmi \ - parsing/printer.cmi proofs/proof_type.cmi kernel/sign.cmi lib/stamps.cmi \ - pretyping/tacred.cmi kernel/term.cmi parsing/termast.cmi \ - pretyping/typing.cmi lib/util.cmi proofs/proof_trees.cmi + pretyping/evd.cmi library/global.cmi kernel/names.cmi library/nametab.cmi \ + lib/pp.cmi parsing/printer.cmi proofs/proof_type.cmi kernel/sign.cmi \ + lib/stamps.cmi pretyping/tacred.cmi kernel/term.cmi parsing/termast.cmi \ + pretyping/termops.cmi pretyping/typing.cmi lib/util.cmi \ + proofs/proof_trees.cmi proofs/proof_trees.cmx: parsing/ast.cmx kernel/closure.cmx \ pretyping/detyping.cmx kernel/environ.cmx pretyping/evarutil.cmx \ - kernel/evd.cmx library/global.cmx kernel/names.cmx lib/pp.cmx \ - parsing/printer.cmx proofs/proof_type.cmx kernel/sign.cmx lib/stamps.cmx \ - pretyping/tacred.cmx kernel/term.cmx parsing/termast.cmx \ - pretyping/typing.cmx lib/util.cmx proofs/proof_trees.cmi -proofs/proof_type.cmo: parsing/coqast.cmi kernel/environ.cmi kernel/evd.cmi \ - kernel/names.cmi library/nametab.cmi pretyping/pretyping.cmi \ - lib/stamps.cmi pretyping/tacred.cmi kernel/term.cmi lib/util.cmi \ - proofs/proof_type.cmi -proofs/proof_type.cmx: parsing/coqast.cmx kernel/environ.cmx kernel/evd.cmx \ - kernel/names.cmx library/nametab.cmx pretyping/pretyping.cmx \ - lib/stamps.cmx pretyping/tacred.cmx kernel/term.cmx lib/util.cmx \ - proofs/proof_type.cmi + pretyping/evd.cmx library/global.cmx kernel/names.cmx library/nametab.cmx \ + lib/pp.cmx parsing/printer.cmx proofs/proof_type.cmx kernel/sign.cmx \ + lib/stamps.cmx pretyping/tacred.cmx kernel/term.cmx parsing/termast.cmx \ + pretyping/termops.cmx pretyping/typing.cmx lib/util.cmx \ + proofs/proof_trees.cmi +proofs/proof_type.cmo: parsing/coqast.cmi kernel/environ.cmi \ + pretyping/evd.cmi kernel/names.cmi library/nametab.cmi \ + pretyping/pretyping.cmi lib/stamps.cmi pretyping/tacred.cmi \ + kernel/term.cmi lib/util.cmi proofs/proof_type.cmi +proofs/proof_type.cmx: parsing/coqast.cmx kernel/environ.cmx \ + pretyping/evd.cmx kernel/names.cmx library/nametab.cmx \ + pretyping/pretyping.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 pretyping/evarutil.cmi \ - kernel/evd.cmi library/global.cmi kernel/instantiate.cmi proofs/logic.cmi \ - lib/pp.cmi parsing/printer.cmi proofs/proof_trees.cmi \ - proofs/proof_type.cmi kernel/reduction.cmi kernel/sign.cmi lib/stamps.cmi \ - kernel/term.cmi kernel/type_errors.cmi lib/util.cmi proofs/refiner.cmi + pretyping/evd.cmi library/global.cmi pretyping/instantiate.cmi \ + proofs/logic.cmi lib/pp.cmi parsing/printer.cmi proofs/proof_trees.cmi \ + proofs/proof_type.cmi pretyping/reductionops.cmi kernel/sign.cmi \ + lib/stamps.cmi kernel/term.cmi pretyping/termops.cmi \ + kernel/type_errors.cmi lib/util.cmi proofs/refiner.cmi proofs/refiner.cmx: parsing/ast.cmx kernel/environ.cmx pretyping/evarutil.cmx \ - kernel/evd.cmx library/global.cmx kernel/instantiate.cmx proofs/logic.cmx \ - lib/pp.cmx parsing/printer.cmx proofs/proof_trees.cmx \ - proofs/proof_type.cmx kernel/reduction.cmx kernel/sign.cmx lib/stamps.cmx \ - kernel/term.cmx kernel/type_errors.cmx lib/util.cmx proofs/refiner.cmi + pretyping/evd.cmx library/global.cmx pretyping/instantiate.cmx \ + proofs/logic.cmx lib/pp.cmx parsing/printer.cmx proofs/proof_trees.cmx \ + proofs/proof_type.cmx pretyping/reductionops.cmx kernel/sign.cmx \ + lib/stamps.cmx kernel/term.cmx pretyping/termops.cmx \ + kernel/type_errors.cmx lib/util.cmx proofs/refiner.cmi proofs/tacinterp.cmo: parsing/ast.cmi parsing/astterm.cmi kernel/closure.cmi \ parsing/coqast.cmi kernel/declarations.cmi library/declare.cmi \ - lib/dyn.cmi kernel/environ.cmi kernel/evd.cmi library/global.cmi \ - lib/gmap.cmi library/lib.cmi library/libobject.cmi kernel/names.cmi \ - library/nametab.cmi library/opaque.cmi lib/options.cmi \ + lib/dyn.cmi kernel/environ.cmi pretyping/evd.cmi library/global.cmi \ + lib/gmap.cmi library/lib.cmi library/libobject.cmi library/nameops.cmi \ + kernel/names.cmi library/nametab.cmi library/opaque.cmi lib/options.cmi \ pretyping/pattern.cmi proofs/pfedit.cmi lib/pp.cmi \ pretyping/pretyping.cmi proofs/proof_type.cmi pretyping/rawterm.cmi \ - kernel/sign.cmi library/summary.cmi proofs/tacmach.cmi \ - pretyping/tacred.cmi proofs/tactic_debug.cmi kernel/term.cmi \ - pretyping/typing.cmi lib/util.cmi proofs/tacinterp.cmi + kernel/safe_typing.cmi kernel/sign.cmi library/summary.cmi \ + proofs/tacmach.cmi pretyping/tacred.cmi proofs/tactic_debug.cmi \ + kernel/term.cmi pretyping/termops.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 kernel/declarations.cmx library/declare.cmx \ - lib/dyn.cmx kernel/environ.cmx kernel/evd.cmx library/global.cmx \ - lib/gmap.cmx library/lib.cmx library/libobject.cmx kernel/names.cmx \ - library/nametab.cmx library/opaque.cmx lib/options.cmx \ + lib/dyn.cmx kernel/environ.cmx pretyping/evd.cmx library/global.cmx \ + lib/gmap.cmx library/lib.cmx library/libobject.cmx library/nameops.cmx \ + kernel/names.cmx library/nametab.cmx library/opaque.cmx lib/options.cmx \ pretyping/pattern.cmx proofs/pfedit.cmx lib/pp.cmx \ pretyping/pretyping.cmx proofs/proof_type.cmx pretyping/rawterm.cmx \ - kernel/sign.cmx library/summary.cmx proofs/tacmach.cmx \ - pretyping/tacred.cmx proofs/tactic_debug.cmx kernel/term.cmx \ - pretyping/typing.cmx lib/util.cmx proofs/tacinterp.cmi + kernel/safe_typing.cmx kernel/sign.cmx library/summary.cmx \ + proofs/tacmach.cmx pretyping/tacred.cmx proofs/tactic_debug.cmx \ + kernel/term.cmx pretyping/termops.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 pretyping/evarutil.cmi \ - kernel/evd.cmi library/global.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 + pretyping/evd.cmi library/global.cmi pretyping/instantiate.cmi \ + proofs/logic.cmi kernel/names.cmi lib/pp.cmi parsing/printer.cmi \ + proofs/proof_trees.cmi proofs/proof_type.cmi pretyping/reductionops.cmi \ + proofs/refiner.cmi kernel/sign.cmi lib/stamps.cmi pretyping/tacred.cmi \ + kernel/term.cmi pretyping/termops.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 pretyping/evarutil.cmx \ - kernel/evd.cmx library/global.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 + pretyping/evd.cmx library/global.cmx pretyping/instantiate.cmx \ + proofs/logic.cmx kernel/names.cmx lib/pp.cmx parsing/printer.cmx \ + proofs/proof_trees.cmx proofs/proof_type.cmx pretyping/reductionops.cmx \ + proofs/refiner.cmx kernel/sign.cmx lib/stamps.cmx pretyping/tacred.cmx \ + kernel/term.cmx pretyping/termops.cmx pretyping/typing.cmx lib/util.cmx \ + proofs/tacmach.cmi proofs/tactic_debug.cmo: parsing/ast.cmi lib/pp.cmi parsing/printer.cmi \ proofs/proof_trees.cmi proofs/tacmach.cmi proofs/tactic_debug.cmi proofs/tactic_debug.cmx: parsing/ast.cmx lib/pp.cmx parsing/printer.cmx \ @@ -940,28 +1043,30 @@ scripts/coqc.cmx: config/coq_config.cmx toplevel/usage.cmx 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 \ - proofs/evar_refiner.cmi kernel/evd.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 library/nametab.cmi lib/options.cmi \ - pretyping/pattern.cmi proofs/pfedit.cmi lib/pp.cmi parsing/printer.cmi \ - proofs/proof_type.cmi pretyping/rawterm.cmi kernel/reduction.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 \ + parsing/coqast.cmi kernel/declarations.cmi library/declare.cmi \ + tactics/dhyp.cmi proofs/evar_refiner.cmi pretyping/evd.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 library/nameops.cmi kernel/names.cmi \ + library/nametab.cmi lib/options.cmi pretyping/pattern.cmi \ + proofs/pfedit.cmi lib/pp.cmi parsing/printer.cmi proofs/proof_type.cmi \ + pretyping/rawterm.cmi kernel/reduction.cmi kernel/sign.cmi \ + library/summary.cmi proofs/tacmach.cmi pretyping/tacred.cmi \ + tactics/tacticals.cmi tactics/tactics.cmi kernel/term.cmi \ + pretyping/termops.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 \ - proofs/evar_refiner.cmx kernel/evd.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 library/nametab.cmx lib/options.cmx \ - pretyping/pattern.cmx proofs/pfedit.cmx lib/pp.cmx parsing/printer.cmx \ - proofs/proof_type.cmx pretyping/rawterm.cmx kernel/reduction.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 \ + parsing/coqast.cmx kernel/declarations.cmx library/declare.cmx \ + tactics/dhyp.cmx proofs/evar_refiner.cmx pretyping/evd.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 library/nameops.cmx kernel/names.cmx \ + library/nametab.cmx lib/options.cmx pretyping/pattern.cmx \ + proofs/pfedit.cmx lib/pp.cmx parsing/printer.cmx proofs/proof_type.cmx \ + pretyping/rawterm.cmx kernel/reduction.cmx kernel/sign.cmx \ + library/summary.cmx proofs/tacmach.cmx pretyping/tacred.cmx \ + tactics/tacticals.cmx tactics/tactics.cmx kernel/term.cmx \ + pretyping/termops.cmx pretyping/typing.cmx lib/util.cmx \ toplevel/vernacinterp.cmx tactics/auto.cmi tactics/autorewrite.cmo: parsing/ast.cmi toplevel/command.cmi \ parsing/coqast.cmi tactics/equality.cmi tactics/hipattern.cmi \ @@ -982,124 +1087,138 @@ tactics/btermdn.cmo: tactics/dn.cmi pretyping/pattern.cmi kernel/term.cmi \ tactics/btermdn.cmx: tactics/dn.cmx pretyping/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 library/global.cmi \ - library/lib.cmi library/libobject.cmi library/library.cmi \ - kernel/names.cmi tactics/nbtermdn.cmi pretyping/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 pretyping/evd.cmi \ + library/global.cmi library/lib.cmi library/libobject.cmi \ + library/library.cmi kernel/names.cmi tactics/nbtermdn.cmi \ + pretyping/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 library/global.cmx \ - library/lib.cmx library/libobject.cmx library/library.cmx \ - kernel/names.cmx tactics/nbtermdn.cmx pretyping/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 pretyping/evd.cmx \ + library/global.cmx library/lib.cmx library/libobject.cmx \ + library/library.cmx kernel/names.cmx tactics/nbtermdn.cmx \ + pretyping/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 proofs/evar_refiner.cmi \ - pretyping/evarutil.cmi kernel/evd.cmi lib/explore.cmi proofs/logic.cmi \ + pretyping/evarutil.cmi pretyping/evd.cmi lib/explore.cmi proofs/logic.cmi \ kernel/names.cmi pretyping/pattern.cmi lib/pp.cmi proofs/proof_trees.cmi \ - proofs/proof_type.cmi kernel/reduction.cmi parsing/search.cmi \ - kernel/sign.cmi proofs/tacmach.cmi tactics/tacticals.cmi \ - tactics/tactics.cmi kernel/term.cmi lib/util.cmi + proofs/proof_type.cmi kernel/reduction.cmi kernel/sign.cmi \ + proofs/tacmach.cmi tactics/tacticals.cmi tactics/tactics.cmi \ + kernel/term.cmi pretyping/termops.cmi lib/util.cmi tactics/eauto.cmx: tactics/auto.cmx proofs/clenv.cmx proofs/evar_refiner.cmx \ - pretyping/evarutil.cmx kernel/evd.cmx lib/explore.cmx proofs/logic.cmx \ + pretyping/evarutil.cmx pretyping/evd.cmx lib/explore.cmx proofs/logic.cmx \ kernel/names.cmx pretyping/pattern.cmx lib/pp.cmx proofs/proof_trees.cmx \ - proofs/proof_type.cmx kernel/reduction.cmx parsing/search.cmx \ - kernel/sign.cmx proofs/tacmach.cmx tactics/tacticals.cmx \ - tactics/tactics.cmx kernel/term.cmx lib/util.cmx + proofs/proof_type.cmx kernel/reduction.cmx kernel/sign.cmx \ + proofs/tacmach.cmx tactics/tacticals.cmx tactics/tactics.cmx \ + kernel/term.cmx pretyping/termops.cmx lib/util.cmx tactics/elim.cmo: proofs/clenv.cmi library/declare.cmi kernel/environ.cmi \ - tactics/hiddentac.cmi tactics/hipattern.cmi kernel/inductive.cmi \ + tactics/hiddentac.cmi tactics/hipattern.cmi pretyping/inductiveops.cmi \ kernel/names.cmi library/nametab.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/tactics.cmi kernel/term.cmi pretyping/termops.cmi lib/util.cmi \ + tactics/elim.cmi tactics/elim.cmx: proofs/clenv.cmx library/declare.cmx kernel/environ.cmx \ - tactics/hiddentac.cmx tactics/hipattern.cmx kernel/inductive.cmx \ + tactics/hiddentac.cmx tactics/hipattern.cmx pretyping/inductiveops.cmx \ kernel/names.cmx library/nametab.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/tactics.cmx kernel/term.cmx pretyping/termops.cmx lib/util.cmx \ + tactics/elim.cmi tactics/eqdecide.cmo: tactics/auto.cmi parsing/coqlib.cmi \ - tactics/equality.cmi library/global.cmi tactics/hiddentac.cmi \ - tactics/hipattern.cmi kernel/names.cmi pretyping/pattern.cmi \ - proofs/proof_trees.cmi proofs/proof_type.cmi proofs/tacmach.cmi \ - tactics/tacticals.cmi tactics/tactics.cmi kernel/term.cmi lib/util.cmi + kernel/declarations.cmi tactics/equality.cmi library/global.cmi \ + tactics/hiddentac.cmi tactics/hipattern.cmi library/nameops.cmi \ + kernel/names.cmi pretyping/pattern.cmi proofs/proof_trees.cmi \ + proofs/proof_type.cmi proofs/tacmach.cmi tactics/tacticals.cmi \ + tactics/tactics.cmi kernel/term.cmi lib/util.cmi tactics/eqdecide.cmx: tactics/auto.cmx parsing/coqlib.cmx \ - tactics/equality.cmx library/global.cmx tactics/hiddentac.cmx \ - tactics/hipattern.cmx kernel/names.cmx pretyping/pattern.cmx \ - proofs/proof_trees.cmx proofs/proof_type.cmx proofs/tacmach.cmx \ - tactics/tacticals.cmx tactics/tactics.cmx kernel/term.cmx lib/util.cmx + kernel/declarations.cmx tactics/equality.cmx library/global.cmx \ + tactics/hiddentac.cmx tactics/hipattern.cmx library/nameops.cmx \ + kernel/names.cmx pretyping/pattern.cmx proofs/proof_trees.cmx \ + proofs/proof_type.cmx proofs/tacmach.cmx tactics/tacticals.cmx \ + tactics/tactics.cmx kernel/term.cmx lib/util.cmx tactics/equality.cmo: parsing/astterm.cmi proofs/clenv.cmi parsing/coqast.cmi \ - parsing/coqlib.cmi library/declare.cmi kernel/environ.cmi \ - proofs/evar_refiner.cmi pretyping/evarutil.cmi kernel/evd.cmi \ + parsing/coqlib.cmi kernel/declarations.cmi kernel/environ.cmi \ + proofs/evar_refiner.cmi pretyping/evarutil.cmi pretyping/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 \ - pretyping/pattern.cmi lib/pp.cmi proofs/proof_type.cmi \ - kernel/reduction.cmi pretyping/retyping.cmi tactics/setoid_replace.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 \ + pretyping/indrec.cmi kernel/inductive.cmi pretyping/inductiveops.cmi \ + pretyping/instantiate.cmi library/lib.cmi library/libobject.cmi \ + proofs/logic.cmi kernel/names.cmi pretyping/pattern.cmi lib/pp.cmi \ + proofs/proof_type.cmi pretyping/reductionops.cmi pretyping/retyping.cmi \ + tactics/setoid_replace.cmi proofs/tacinterp.cmi proofs/tacmach.cmi \ + pretyping/tacred.cmi tactics/tacticals.cmi tactics/tactics.cmi \ + kernel/term.cmi pretyping/termops.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 proofs/clenv.cmx parsing/coqast.cmx \ - parsing/coqlib.cmx library/declare.cmx kernel/environ.cmx \ - proofs/evar_refiner.cmx pretyping/evarutil.cmx kernel/evd.cmx \ + parsing/coqlib.cmx kernel/declarations.cmx kernel/environ.cmx \ + proofs/evar_refiner.cmx pretyping/evarutil.cmx pretyping/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 \ - pretyping/pattern.cmx lib/pp.cmx proofs/proof_type.cmx \ - kernel/reduction.cmx pretyping/retyping.cmx tactics/setoid_replace.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 \ + pretyping/indrec.cmx kernel/inductive.cmx pretyping/inductiveops.cmx \ + pretyping/instantiate.cmx library/lib.cmx library/libobject.cmx \ + proofs/logic.cmx kernel/names.cmx pretyping/pattern.cmx lib/pp.cmx \ + proofs/proof_type.cmx pretyping/reductionops.cmx pretyping/retyping.cmx \ + tactics/setoid_replace.cmx proofs/tacinterp.cmx proofs/tacmach.cmx \ + pretyping/tacred.cmx tactics/tacticals.cmx tactics/tactics.cmx \ + kernel/term.cmx pretyping/termops.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: proofs/clenv.cmi parsing/coqlib.cmi kernel/environ.cmi \ - kernel/evd.cmi library/global.cmi kernel/inductive.cmi kernel/names.cmi \ - pretyping/pattern.cmi lib/pp.cmi proofs/proof_trees.cmi \ - kernel/reduction.cmi kernel/term.cmi lib/util.cmi tactics/hipattern.cmi -tactics/hipattern.cmx: proofs/clenv.cmx parsing/coqlib.cmx kernel/environ.cmx \ - kernel/evd.cmx library/global.cmx kernel/inductive.cmx kernel/names.cmx \ - pretyping/pattern.cmx lib/pp.cmx proofs/proof_trees.cmx \ - kernel/reduction.cmx kernel/term.cmx lib/util.cmx tactics/hipattern.cmi +tactics/hipattern.cmo: proofs/clenv.cmi parsing/coqlib.cmi \ + kernel/declarations.cmi kernel/environ.cmi pretyping/evd.cmi \ + library/global.cmi pretyping/inductiveops.cmi library/nameops.cmi \ + kernel/names.cmi pretyping/pattern.cmi lib/pp.cmi proofs/proof_trees.cmi \ + pretyping/reductionops.cmi kernel/term.cmi pretyping/termops.cmi \ + lib/util.cmi tactics/hipattern.cmi +tactics/hipattern.cmx: proofs/clenv.cmx parsing/coqlib.cmx \ + kernel/declarations.cmx kernel/environ.cmx pretyping/evd.cmx \ + library/global.cmx pretyping/inductiveops.cmx library/nameops.cmx \ + kernel/names.cmx pretyping/pattern.cmx lib/pp.cmx proofs/proof_trees.cmx \ + pretyping/reductionops.cmx kernel/term.cmx pretyping/termops.cmx \ + lib/util.cmx tactics/hipattern.cmi tactics/inv.cmo: tactics/auto.cmi proofs/clenv.cmi parsing/coqlib.cmi \ tactics/elim.cmi kernel/environ.cmi tactics/equality.cmi \ - proofs/evar_refiner.cmi library/global.cmi kernel/inductive.cmi \ + proofs/evar_refiner.cmi library/global.cmi pretyping/inductiveops.cmi \ kernel/names.cmi pretyping/pattern.cmi lib/pp.cmi parsing/printer.cmi \ - proofs/proof_type.cmi kernel/reduction.cmi pretyping/retyping.cmi \ + proofs/proof_type.cmi pretyping/reductionops.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/tactics.cmi kernel/term.cmi pretyping/termops.cmi \ + pretyping/typing.cmi lib/util.cmi tactics/wcclausenv.cmi tactics/inv.cmi tactics/inv.cmx: tactics/auto.cmx proofs/clenv.cmx parsing/coqlib.cmx \ tactics/elim.cmx kernel/environ.cmx tactics/equality.cmx \ - proofs/evar_refiner.cmx library/global.cmx kernel/inductive.cmx \ + proofs/evar_refiner.cmx library/global.cmx pretyping/inductiveops.cmx \ kernel/names.cmx pretyping/pattern.cmx lib/pp.cmx parsing/printer.cmx \ - proofs/proof_type.cmx kernel/reduction.cmx pretyping/retyping.cmx \ + proofs/proof_type.cmx pretyping/reductionops.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/tactics.cmx kernel/term.cmx pretyping/termops.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 \ - proofs/evar_refiner.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 kernel/sign.cmi \ - proofs/tacmach.cmi tactics/tacticals.cmi tactics/tactics.cmi \ - kernel/term.cmi lib/util.cmi toplevel/vernacinterp.cmi \ + proofs/evar_refiner.cmi pretyping/evd.cmi library/global.cmi \ + pretyping/inductiveops.cmi tactics/inv.cmi library/nameops.cmi \ + kernel/names.cmi proofs/pfedit.cmi lib/pp.cmi parsing/printer.cmi \ + proofs/proof_trees.cmi proofs/proof_type.cmi pretyping/reductionops.cmi \ + kernel/safe_typing.cmi kernel/sign.cmi proofs/tacmach.cmi \ + tactics/tacticals.cmi tactics/tactics.cmi kernel/term.cmi \ + pretyping/termops.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 \ - proofs/evar_refiner.cmx 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 kernel/sign.cmx \ - proofs/tacmach.cmx tactics/tacticals.cmx tactics/tactics.cmx \ - kernel/term.cmx lib/util.cmx toplevel/vernacinterp.cmx \ + proofs/evar_refiner.cmx pretyping/evd.cmx library/global.cmx \ + pretyping/inductiveops.cmx tactics/inv.cmx library/nameops.cmx \ + kernel/names.cmx proofs/pfedit.cmx lib/pp.cmx parsing/printer.cmx \ + proofs/proof_trees.cmx proofs/proof_type.cmx pretyping/reductionops.cmx \ + kernel/safe_typing.cmx kernel/sign.cmx proofs/tacmach.cmx \ + tactics/tacticals.cmx tactics/tactics.cmx kernel/term.cmx \ + pretyping/termops.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 pretyping/pattern.cmi \ @@ -1108,35 +1227,37 @@ tactics/nbtermdn.cmx: tactics/btermdn.cmx lib/gmap.cmx library/libobject.cmx \ library/library.cmx kernel/names.cmx pretyping/pattern.cmx \ kernel/term.cmx tactics/termdn.cmx lib/util.cmx tactics/nbtermdn.cmi tactics/refine.cmo: parsing/astterm.cmi proofs/clenv.cmi kernel/environ.cmi \ - kernel/evd.cmi kernel/names.cmi lib/pp.cmi parsing/printer.cmi \ + pretyping/evd.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 tactics/tacticals.cmi \ - tactics/tactics.cmi kernel/term.cmi pretyping/typing.cmi lib/util.cmi \ - tactics/refine.cmi + tactics/tactics.cmi kernel/term.cmi pretyping/termops.cmi \ + pretyping/typing.cmi lib/util.cmi tactics/refine.cmi tactics/refine.cmx: parsing/astterm.cmx proofs/clenv.cmx kernel/environ.cmx \ - kernel/evd.cmx kernel/names.cmx lib/pp.cmx parsing/printer.cmx \ + pretyping/evd.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 tactics/tacticals.cmx \ - tactics/tactics.cmx kernel/term.cmx pretyping/typing.cmx lib/util.cmx \ - tactics/refine.cmi + tactics/tactics.cmx kernel/term.cmx pretyping/termops.cmx \ + pretyping/typing.cmx lib/util.cmx tactics/refine.cmi tactics/setoid_replace.cmo: parsing/astterm.cmi tactics/auto.cmi \ - toplevel/command.cmi kernel/declarations.cmi library/declare.cmi \ - kernel/environ.cmi kernel/evd.cmi library/global.cmi lib/gmap.cmi \ - library/lib.cmi library/libobject.cmi kernel/names.cmi \ + toplevel/command.cmi library/declare.cmi kernel/environ.cmi \ + pretyping/evd.cmi library/global.cmi lib/gmap.cmi library/lib.cmi \ + library/libobject.cmi library/nameops.cmi kernel/names.cmi \ library/nametab.cmi lib/options.cmi proofs/pfedit.cmi lib/pp.cmi \ - parsing/printer.cmi proofs/proof_type.cmi kernel/reduction.cmi \ - library/summary.cmi proofs/tacmach.cmi tactics/tactics.cmi \ - kernel/term.cmi parsing/termast.cmi pretyping/typing.cmi lib/util.cmi \ + parsing/printer.cmi proofs/proof_type.cmi pretyping/reductionops.cmi \ + kernel/safe_typing.cmi library/summary.cmi proofs/tacmach.cmi \ + tactics/tactics.cmi kernel/term.cmi parsing/termast.cmi \ + pretyping/termops.cmi pretyping/typing.cmi lib/util.cmi \ toplevel/vernacentries.cmi toplevel/vernacinterp.cmi \ tactics/setoid_replace.cmi tactics/setoid_replace.cmx: parsing/astterm.cmx tactics/auto.cmx \ - toplevel/command.cmx kernel/declarations.cmx library/declare.cmx \ - kernel/environ.cmx kernel/evd.cmx library/global.cmx lib/gmap.cmx \ - library/lib.cmx library/libobject.cmx kernel/names.cmx \ + toplevel/command.cmx library/declare.cmx kernel/environ.cmx \ + pretyping/evd.cmx library/global.cmx lib/gmap.cmx library/lib.cmx \ + library/libobject.cmx library/nameops.cmx kernel/names.cmx \ library/nametab.cmx lib/options.cmx proofs/pfedit.cmx lib/pp.cmx \ - parsing/printer.cmx proofs/proof_type.cmx kernel/reduction.cmx \ - library/summary.cmx proofs/tacmach.cmx tactics/tactics.cmx \ - kernel/term.cmx parsing/termast.cmx pretyping/typing.cmx lib/util.cmx \ + parsing/printer.cmx proofs/proof_type.cmx pretyping/reductionops.cmx \ + kernel/safe_typing.cmx library/summary.cmx proofs/tacmach.cmx \ + tactics/tactics.cmx kernel/term.cmx parsing/termast.cmx \ + pretyping/termops.cmx pretyping/typing.cmx lib/util.cmx \ toplevel/vernacentries.cmx toplevel/vernacinterp.cmx \ tactics/setoid_replace.cmi tactics/tacentries.cmo: proofs/proof_trees.cmi proofs/tacmach.cmi \ @@ -1145,132 +1266,150 @@ 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 \ - proofs/evar_refiner.cmi library/global.cmi library/indrec.cmi \ + proofs/evar_refiner.cmi library/global.cmi pretyping/indrec.cmi \ kernel/inductive.cmi kernel/names.cmi pretyping/pattern.cmi lib/pp.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 + proofs/tacmach.cmi kernel/term.cmi parsing/termast.cmi \ + pretyping/termops.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 \ - proofs/evar_refiner.cmx library/global.cmx library/indrec.cmx \ + proofs/evar_refiner.cmx library/global.cmx pretyping/indrec.cmx \ kernel/inductive.cmx kernel/names.cmx pretyping/pattern.cmx lib/pp.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 + proofs/tacmach.cmx kernel/term.cmx parsing/termast.cmx \ + pretyping/termops.cmx lib/util.cmx tactics/wcclausenv.cmx \ + tactics/tacticals.cmi tactics/tactics.cmo: parsing/astterm.cmi proofs/clenv.cmi kernel/closure.cmi \ parsing/coqlib.cmi kernel/declarations.cmi library/declare.cmi \ - kernel/environ.cmi proofs/evar_refiner.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 + kernel/environ.cmi proofs/evar_refiner.cmi pretyping/evd.cmi \ + library/global.cmi tactics/hipattern.cmi pretyping/indrec.cmi \ + kernel/inductive.cmi pretyping/inductiveops.cmi proofs/logic.cmi \ + library/nameops.cmi kernel/names.cmi library/nametab.cmi \ + proofs/pfedit.cmi lib/pp.cmi proofs/proof_trees.cmi proofs/proof_type.cmi \ + pretyping/reductionops.cmi kernel/sign.cmi lib/stamps.cmi \ + proofs/tacinterp.cmi proofs/tacmach.cmi pretyping/tacred.cmi \ + tactics/tacticals.cmi kernel/term.cmi pretyping/termops.cmi lib/util.cmi \ + tactics/tactics.cmi tactics/tactics.cmx: parsing/astterm.cmx proofs/clenv.cmx kernel/closure.cmx \ parsing/coqlib.cmx kernel/declarations.cmx library/declare.cmx \ - kernel/environ.cmx proofs/evar_refiner.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 + kernel/environ.cmx proofs/evar_refiner.cmx pretyping/evd.cmx \ + library/global.cmx tactics/hipattern.cmx pretyping/indrec.cmx \ + kernel/inductive.cmx pretyping/inductiveops.cmx proofs/logic.cmx \ + library/nameops.cmx kernel/names.cmx library/nametab.cmx \ + proofs/pfedit.cmx lib/pp.cmx proofs/proof_trees.cmx proofs/proof_type.cmx \ + pretyping/reductionops.cmx kernel/sign.cmx lib/stamps.cmx \ + proofs/tacinterp.cmx proofs/tacmach.cmx pretyping/tacred.cmx \ + tactics/tacticals.cmx kernel/term.cmx pretyping/termops.cmx lib/util.cmx \ + tactics/tactics.cmi tactics/tauto.cmo: parsing/ast.cmi parsing/coqast.cmi tactics/hipattern.cmi \ kernel/names.cmi lib/pp.cmi proofs/proof_type.cmi proofs/tacinterp.cmi \ proofs/tacmach.cmi tactics/tacticals.cmi tactics/tactics.cmi lib/util.cmi tactics/tauto.cmx: parsing/ast.cmx parsing/coqast.cmx tactics/hipattern.cmx \ kernel/names.cmx lib/pp.cmx proofs/proof_type.cmx proofs/tacinterp.cmx \ proofs/tacmach.cmx tactics/tacticals.cmx tactics/tactics.cmx lib/util.cmx -tactics/termdn.cmo: tactics/dn.cmi kernel/names.cmi pretyping/pattern.cmi \ - pretyping/rawterm.cmi kernel/term.cmi lib/util.cmi tactics/termdn.cmi -tactics/termdn.cmx: tactics/dn.cmx kernel/names.cmx pretyping/pattern.cmx \ - pretyping/rawterm.cmx kernel/term.cmx lib/util.cmx tactics/termdn.cmi +tactics/termdn.cmo: tactics/dn.cmi library/nameops.cmi kernel/names.cmi \ + library/nametab.cmi pretyping/pattern.cmi pretyping/rawterm.cmi \ + kernel/term.cmi lib/util.cmi tactics/termdn.cmi +tactics/termdn.cmx: tactics/dn.cmx library/nameops.cmx kernel/names.cmx \ + library/nametab.cmx pretyping/pattern.cmx pretyping/rawterm.cmx \ + kernel/term.cmx lib/util.cmx tactics/termdn.cmi tactics/wcclausenv.cmo: proofs/clenv.cmi kernel/environ.cmi \ - proofs/evar_refiner.cmi kernel/evd.cmi library/global.cmi \ - proofs/logic.cmi kernel/names.cmi lib/pp.cmi proofs/proof_trees.cmi \ - kernel/reduction.cmi kernel/sign.cmi proofs/tacmach.cmi kernel/term.cmi \ - lib/util.cmi tactics/wcclausenv.cmi + proofs/evar_refiner.cmi pretyping/evd.cmi library/global.cmi \ + proofs/logic.cmi library/nameops.cmi kernel/names.cmi lib/pp.cmi \ + proofs/proof_trees.cmi pretyping/reductionops.cmi kernel/sign.cmi \ + proofs/tacmach.cmi kernel/term.cmi pretyping/termops.cmi lib/util.cmi \ + tactics/wcclausenv.cmi tactics/wcclausenv.cmx: proofs/clenv.cmx kernel/environ.cmx \ - proofs/evar_refiner.cmx kernel/evd.cmx library/global.cmx \ - proofs/logic.cmx kernel/names.cmx lib/pp.cmx proofs/proof_trees.cmx \ - kernel/reduction.cmx kernel/sign.cmx proofs/tacmach.cmx kernel/term.cmx \ - lib/util.cmx tactics/wcclausenv.cmi -tools/coq_vo2xml.cmo: config/coq_config.cmi toplevel/usage.cmi -tools/coq_vo2xml.cmx: config/coq_config.cmx toplevel/usage.cmx -tools/coqdep.cmo: config/coq_config.cmi tools/coqdep_lexer.cmo -tools/coqdep.cmx: config/coq_config.cmx tools/coqdep_lexer.cmx + proofs/evar_refiner.cmx pretyping/evd.cmx library/global.cmx \ + proofs/logic.cmx library/nameops.cmx kernel/names.cmx lib/pp.cmx \ + proofs/proof_trees.cmx pretyping/reductionops.cmx kernel/sign.cmx \ + proofs/tacmach.cmx kernel/term.cmx pretyping/termops.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 +tools/coq_vo2xml.cmo: config/coq_config.cmi toplevel/usage.cmi +tools/coq_vo2xml.cmx: config/coq_config.cmx toplevel/usage.cmx tools/gallina.cmo: tools/gallina_lexer.cmo tools/gallina.cmx: tools/gallina_lexer.cmx toplevel/class.cmo: pretyping/classops.cmi kernel/declarations.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 parsing/printer.cmi kernel/reduction.cmi \ - pretyping/retyping.cmi kernel/sign.cmi kernel/term.cmi \ - pretyping/typing.cmi lib/util.cmi toplevel/class.cmi + library/declare.cmi kernel/environ.cmi pretyping/evd.cmi \ + library/global.cmi kernel/inductive.cmi library/lib.cmi \ + library/nameops.cmi kernel/names.cmi library/nametab.cmi lib/pp.cmi \ + parsing/printer.cmi pretyping/reductionops.cmi pretyping/retyping.cmi \ + kernel/safe_typing.cmi kernel/sign.cmi kernel/term.cmi \ + pretyping/termops.cmi pretyping/typing.cmi lib/util.cmi \ + toplevel/class.cmi toplevel/class.cmx: pretyping/classops.cmx kernel/declarations.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 parsing/printer.cmx kernel/reduction.cmx \ - pretyping/retyping.cmx kernel/sign.cmx kernel/term.cmx \ - pretyping/typing.cmx lib/util.cmx toplevel/class.cmi + library/declare.cmx kernel/environ.cmx pretyping/evd.cmx \ + library/global.cmx kernel/inductive.cmx library/lib.cmx \ + library/nameops.cmx kernel/names.cmx library/nametab.cmx lib/pp.cmx \ + parsing/printer.cmx pretyping/reductionops.cmx pretyping/retyping.cmx \ + kernel/safe_typing.cmx kernel/sign.cmx kernel/term.cmx \ + pretyping/termops.cmx pretyping/typing.cmx lib/util.cmx \ + toplevel/class.cmi toplevel/command.cmo: parsing/ast.cmi parsing/astterm.cmi parsing/coqast.cmi \ kernel/declarations.cmi library/declare.cmi kernel/environ.cmi \ - kernel/evd.cmi library/global.cmi library/impargs.cmi library/indrec.cmi \ - kernel/inductive.cmi library/lib.cmi library/libobject.cmi \ - library/library.cmi proofs/logic.cmi kernel/names.cmi library/nametab.cmi \ + pretyping/evd.cmi library/global.cmi library/impargs.cmi \ + pretyping/indrec.cmi kernel/indtypes.cmi kernel/inductive.cmi \ + library/lib.cmi library/libobject.cmi library/library.cmi \ + proofs/logic.cmi library/nameops.cmi kernel/names.cmi library/nametab.cmi \ lib/options.cmi proofs/pfedit.cmi lib/pp.cmi parsing/printer.cmi \ proofs/proof_type.cmi kernel/reduction.cmi kernel/safe_typing.cmi \ library/states.cmi pretyping/syntax_def.cmi proofs/tacmach.cmi \ - pretyping/tacred.cmi kernel/term.cmi lib/util.cmi toplevel/command.cmi + pretyping/tacred.cmi kernel/term.cmi pretyping/termops.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 library/global.cmx library/impargs.cmx library/indrec.cmx \ - kernel/inductive.cmx library/lib.cmx library/libobject.cmx \ - library/library.cmx proofs/logic.cmx kernel/names.cmx library/nametab.cmx \ + pretyping/evd.cmx library/global.cmx library/impargs.cmx \ + pretyping/indrec.cmx kernel/indtypes.cmx kernel/inductive.cmx \ + library/lib.cmx library/libobject.cmx library/library.cmx \ + proofs/logic.cmx library/nameops.cmx kernel/names.cmx library/nametab.cmx \ lib/options.cmx proofs/pfedit.cmx lib/pp.cmx parsing/printer.cmx \ proofs/proof_type.cmx kernel/reduction.cmx kernel/safe_typing.cmx \ library/states.cmx pretyping/syntax_def.cmx proofs/tacmach.cmx \ - pretyping/tacred.cmx kernel/term.cmx lib/util.cmx toplevel/command.cmi + pretyping/tacred.cmx kernel/term.cmx pretyping/termops.cmx \ + kernel/typeops.cmx lib/util.cmx toplevel/command.cmi toplevel/coqinit.cmo: config/coq_config.cmi toplevel/mltop.cmi \ - kernel/names.cmi library/nametab.cmi lib/options.cmi lib/pp.cmi \ + library/nameops.cmi kernel/names.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.cmx \ - kernel/names.cmx library/nametab.cmx lib/options.cmx lib/pp.cmx \ + library/nameops.cmx kernel/names.cmx 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 kernel/names.cmi library/nametab.cmi lib/options.cmi \ - lib/pp.cmi lib/profile.cmi library/states.cmi lib/system.cmi \ - toplevel/toplevel.cmi toplevel/usage.cmi lib/util.cmi toplevel/vernac.cmi \ - toplevel/coqtop.cmi + toplevel/mltop.cmi library/nameops.cmi kernel/names.cmi \ + library/nametab.cmi lib/options.cmi lib/pp.cmi lib/profile.cmi \ + library/states.cmi lib/system.cmi toplevel/toplevel.cmi \ + toplevel/usage.cmi lib/util.cmi toplevel/vernac.cmi toplevel/coqtop.cmi toplevel/coqtop.cmx: config/coq_config.cmx toplevel/coqinit.cmx \ toplevel/errors.cmx library/lib.cmx library/library.cmx \ - toplevel/mltop.cmx kernel/names.cmx library/nametab.cmx lib/options.cmx \ - lib/pp.cmx lib/profile.cmx library/states.cmx lib/system.cmx \ - toplevel/toplevel.cmx toplevel/usage.cmx lib/util.cmx toplevel/vernac.cmx \ - toplevel/coqtop.cmi + toplevel/mltop.cmx library/nameops.cmx kernel/names.cmx \ + library/nametab.cmx lib/options.cmx lib/pp.cmx lib/profile.cmx \ + library/states.cmx lib/system.cmx toplevel/toplevel.cmx \ + toplevel/usage.cmx lib/util.cmx toplevel/vernac.cmx toplevel/coqtop.cmi toplevel/discharge.cmo: toplevel/class.cmi pretyping/classops.cmi \ kernel/cooking.cmi kernel/declarations.cmi library/declare.cmi \ kernel/environ.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/options.cmi lib/pp.cmi toplevel/recordobj.cmi \ - pretyping/recordops.cmi kernel/reduction.cmi kernel/sign.cmi \ - library/summary.cmi kernel/term.cmi kernel/typeops.cmi kernel/univ.cmi \ - lib/util.cmi toplevel/discharge.cmi + kernel/indtypes.cmi kernel/inductive.cmi pretyping/instantiate.cmi \ + library/lib.cmi library/libobject.cmi library/library.cmi \ + library/nameops.cmi kernel/names.cmi library/nametab.cmi lib/options.cmi \ + lib/pp.cmi toplevel/recordobj.cmi pretyping/recordops.cmi \ + kernel/reduction.cmi kernel/sign.cmi library/summary.cmi kernel/term.cmi \ + kernel/typeops.cmi kernel/univ.cmi lib/util.cmi toplevel/discharge.cmi toplevel/discharge.cmx: toplevel/class.cmx pretyping/classops.cmx \ kernel/cooking.cmx kernel/declarations.cmx library/declare.cmx \ kernel/environ.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/options.cmx lib/pp.cmx toplevel/recordobj.cmx \ - pretyping/recordops.cmx kernel/reduction.cmx kernel/sign.cmx \ - library/summary.cmx kernel/term.cmx kernel/typeops.cmx kernel/univ.cmx \ - lib/util.cmx toplevel/discharge.cmi + kernel/indtypes.cmx kernel/inductive.cmx pretyping/instantiate.cmx \ + library/lib.cmx library/libobject.cmx library/library.cmx \ + library/nameops.cmx kernel/names.cmx library/nametab.cmx lib/options.cmx \ + lib/pp.cmx toplevel/recordobj.cmx pretyping/recordops.cmx \ + kernel/reduction.cmx kernel/sign.cmx library/summary.cmx kernel/term.cmx \ + kernel/typeops.cmx kernel/univ.cmx lib/util.cmx toplevel/discharge.cmi toplevel/errors.cmo: parsing/ast.cmi pretyping/cases.cmi toplevel/himsg.cmi \ kernel/indtypes.cmi parsing/lexer.cmi proofs/logic.cmi \ library/nametab.cmi lib/options.cmi lib/pp.cmi \ @@ -1291,14 +1430,14 @@ toplevel/himsg.cmo: parsing/ast.cmi pretyping/cases.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 \ pretyping/pretype_errors.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 + kernel/sign.cmi proofs/tacmach.cmi kernel/term.cmi pretyping/termops.cmi \ + kernel/type_errors.cmi lib/util.cmi toplevel/himsg.cmi toplevel/himsg.cmx: parsing/ast.cmx pretyping/cases.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 \ pretyping/pretype_errors.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/sign.cmx proofs/tacmach.cmx kernel/term.cmx pretyping/termops.cmx \ + kernel/type_errors.cmx lib/util.cmx toplevel/himsg.cmi toplevel/line_oriented_parser.cmo: toplevel/line_oriented_parser.cmi toplevel/line_oriented_parser.cmx: toplevel/line_oriented_parser.cmi toplevel/metasyntax.cmo: parsing/ast.cmi parsing/astterm.cmi \ @@ -1337,23 +1476,31 @@ toplevel/protectedtoplevel.cmx: toplevel/errors.cmx \ toplevel/protectedtoplevel.cmi toplevel/record.cmo: parsing/ast.cmi parsing/astterm.cmi toplevel/class.cmi \ toplevel/command.cmi parsing/coqast.cmi kernel/declarations.cmi \ - library/declare.cmi kernel/environ.cmi kernel/evd.cmi library/global.cmi \ - toplevel/himsg.cmi kernel/inductive.cmi kernel/names.cmi lib/pp.cmi \ - pretyping/recordops.cmi kernel/term.cmi kernel/type_errors.cmi \ - lib/util.cmi toplevel/record.cmi + library/declare.cmi kernel/environ.cmi pretyping/evd.cmi \ + library/global.cmi toplevel/himsg.cmi kernel/indtypes.cmi \ + kernel/inductive.cmi pretyping/inductiveops.cmi kernel/names.cmi \ + library/nametab.cmi lib/pp.cmi pretyping/recordops.cmi \ + kernel/safe_typing.cmi kernel/term.cmi pretyping/termops.cmi \ + kernel/type_errors.cmi kernel/typeops.cmi lib/util.cmi \ + toplevel/record.cmi toplevel/record.cmx: parsing/ast.cmx parsing/astterm.cmx toplevel/class.cmx \ toplevel/command.cmx parsing/coqast.cmx kernel/declarations.cmx \ - library/declare.cmx kernel/environ.cmx kernel/evd.cmx library/global.cmx \ - toplevel/himsg.cmx kernel/inductive.cmx kernel/names.cmx lib/pp.cmx \ - pretyping/recordops.cmx kernel/term.cmx kernel/type_errors.cmx \ - lib/util.cmx toplevel/record.cmi + library/declare.cmx kernel/environ.cmx pretyping/evd.cmx \ + library/global.cmx toplevel/himsg.cmx kernel/indtypes.cmx \ + kernel/inductive.cmx pretyping/inductiveops.cmx kernel/names.cmx \ + library/nametab.cmx lib/pp.cmx pretyping/recordops.cmx \ + kernel/safe_typing.cmx kernel/term.cmx pretyping/termops.cmx \ + kernel/type_errors.cmx kernel/typeops.cmx lib/util.cmx \ + toplevel/record.cmi toplevel/recordobj.cmo: pretyping/classops.cmi library/declare.cmi \ - library/global.cmi kernel/instantiate.cmi library/lib.cmi \ - kernel/names.cmi lib/pp.cmi pretyping/recordops.cmi kernel/term.cmi \ + kernel/environ.cmi library/global.cmi pretyping/instantiate.cmi \ + library/lib.cmi kernel/names.cmi library/nametab.cmi lib/pp.cmi \ + pretyping/recordops.cmi kernel/term.cmi pretyping/termops.cmi \ lib/util.cmi toplevel/recordobj.cmi toplevel/recordobj.cmx: pretyping/classops.cmx library/declare.cmx \ - library/global.cmx kernel/instantiate.cmx library/lib.cmx \ - kernel/names.cmx lib/pp.cmx pretyping/recordops.cmx kernel/term.cmx \ + kernel/environ.cmx library/global.cmx pretyping/instantiate.cmx \ + library/lib.cmx kernel/names.cmx library/nametab.cmx lib/pp.cmx \ + pretyping/recordops.cmx kernel/term.cmx pretyping/termops.cmx \ lib/util.cmx toplevel/recordobj.cmi toplevel/toplevel.cmo: parsing/ast.cmi toplevel/errors.cmi library/lib.cmi \ toplevel/mltop.cmi kernel/names.cmi lib/options.cmi parsing/pcoq.cmi \ @@ -1365,21 +1512,14 @@ toplevel/toplevel.cmx: parsing/ast.cmx toplevel/errors.cmx library/lib.cmx \ toplevel/vernac.cmx toplevel/vernacinterp.cmx toplevel/toplevel.cmi toplevel/usage.cmo: config/coq_config.cmi toplevel/usage.cmi toplevel/usage.cmx: config/coq_config.cmx toplevel/usage.cmi -toplevel/vernac.cmo: parsing/ast.cmi parsing/coqast.cmi library/lib.cmi \ - library/library.cmi kernel/names.cmi lib/options.cmi parsing/pcoq.cmi \ - lib/pp.cmi library/states.cmi lib/system.cmi lib/util.cmi \ - toplevel/vernacinterp.cmi toplevel/vernac.cmi -toplevel/vernac.cmx: parsing/ast.cmx parsing/coqast.cmx library/lib.cmx \ - library/library.cmx kernel/names.cmx lib/options.cmx parsing/pcoq.cmx \ - lib/pp.cmx library/states.cmx lib/system.cmx lib/util.cmx \ - toplevel/vernacinterp.cmx toplevel/vernac.cmi toplevel/vernacentries.cmo: parsing/ast.cmi parsing/astterm.cmi \ toplevel/class.cmi pretyping/classops.cmi toplevel/command.cmi \ parsing/coqast.cmi kernel/declarations.cmi library/declare.cmi \ toplevel/discharge.cmi kernel/environ.cmi pretyping/evarutil.cmi \ - kernel/evd.cmi parsing/extend.cmi library/global.cmi library/goptions.cmi \ - library/impargs.cmi library/lib.cmi library/library.cmi \ - toplevel/metasyntax.cmi toplevel/mltop.cmi kernel/names.cmi \ + pretyping/evd.cmi parsing/extend.cmi library/global.cmi \ + library/goptions.cmi library/impargs.cmi pretyping/inductiveops.cmi \ + library/lib.cmi library/library.cmi toplevel/metasyntax.cmi \ + toplevel/mltop.cmi library/nameops.cmi kernel/names.cmi \ library/nametab.cmi library/opaque.cmi lib/options.cmi proofs/pfedit.cmi \ lib/pp.cmi lib/pp_control.cmi parsing/prettyp.cmi parsing/printer.cmi \ proofs/proof_trees.cmi proofs/proof_type.cmi toplevel/record.cmi \ @@ -1387,15 +1527,17 @@ toplevel/vernacentries.cmo: parsing/ast.cmi parsing/astterm.cmi \ parsing/search.cmi library/states.cmi pretyping/syntax_def.cmi \ lib/system.cmi proofs/tacinterp.cmi proofs/tacmach.cmi \ pretyping/tacred.cmi proofs/tactic_debug.cmi tactics/tactics.cmi \ - kernel/term.cmi parsing/termast.cmi kernel/typeops.cmi kernel/univ.cmi \ - lib/util.cmi toplevel/vernacinterp.cmi toplevel/vernacentries.cmi + kernel/term.cmi parsing/termast.cmi pretyping/termops.cmi \ + kernel/typeops.cmi kernel/univ.cmi lib/util.cmi toplevel/vernacinterp.cmi \ + toplevel/vernacentries.cmi toplevel/vernacentries.cmx: parsing/ast.cmx parsing/astterm.cmx \ toplevel/class.cmx pretyping/classops.cmx toplevel/command.cmx \ parsing/coqast.cmx kernel/declarations.cmx library/declare.cmx \ toplevel/discharge.cmx kernel/environ.cmx pretyping/evarutil.cmx \ - kernel/evd.cmx parsing/extend.cmx library/global.cmx library/goptions.cmx \ - library/impargs.cmx library/lib.cmx library/library.cmx \ - toplevel/metasyntax.cmx toplevel/mltop.cmx kernel/names.cmx \ + pretyping/evd.cmx parsing/extend.cmx library/global.cmx \ + library/goptions.cmx library/impargs.cmx pretyping/inductiveops.cmx \ + library/lib.cmx library/library.cmx toplevel/metasyntax.cmx \ + toplevel/mltop.cmx library/nameops.cmx kernel/names.cmx \ library/nametab.cmx library/opaque.cmx lib/options.cmx proofs/pfedit.cmx \ lib/pp.cmx lib/pp_control.cmx parsing/prettyp.cmx parsing/printer.cmx \ proofs/proof_trees.cmx proofs/proof_type.cmx toplevel/record.cmx \ @@ -1403,8 +1545,9 @@ toplevel/vernacentries.cmx: parsing/ast.cmx parsing/astterm.cmx \ parsing/search.cmx library/states.cmx pretyping/syntax_def.cmx \ lib/system.cmx proofs/tacinterp.cmx proofs/tacmach.cmx \ pretyping/tacred.cmx proofs/tactic_debug.cmx tactics/tactics.cmx \ - kernel/term.cmx parsing/termast.cmx kernel/typeops.cmx kernel/univ.cmx \ - lib/util.cmx toplevel/vernacinterp.cmx toplevel/vernacentries.cmi + kernel/term.cmx parsing/termast.cmx pretyping/termops.cmx \ + kernel/typeops.cmx kernel/univ.cmx lib/util.cmx toplevel/vernacinterp.cmx \ + toplevel/vernacentries.cmi toplevel/vernacinterp.cmo: parsing/ast.cmi parsing/astterm.cmi \ toplevel/command.cmi parsing/coqast.cmi lib/dyn.cmi toplevel/himsg.cmi \ kernel/names.cmi library/nametab.cmi lib/options.cmi lib/pp.cmi \ @@ -1415,16 +1558,14 @@ toplevel/vernacinterp.cmx: parsing/ast.cmx parsing/astterm.cmx \ kernel/names.cmx library/nametab.cmx lib/options.cmx lib/pp.cmx \ proofs/proof_type.cmx proofs/tacinterp.cmx lib/util.cmx \ toplevel/vernacinterp.cmi -contrib/correctness/pcic.cmo: parsing/ast.cmi kernel/declarations.cmi \ - library/declare.cmi pretyping/detyping.cmi kernel/names.cmi \ - library/nametab.cmi contrib/correctness/past.cmi \ - contrib/correctness/pmisc.cmi pretyping/rawterm.cmi toplevel/record.cmi \ - kernel/sign.cmi kernel/term.cmi lib/util.cmi contrib/correctness/pcic.cmi -contrib/correctness/pcic.cmx: parsing/ast.cmx kernel/declarations.cmx \ - library/declare.cmx pretyping/detyping.cmx kernel/names.cmx \ - library/nametab.cmx contrib/correctness/past.cmi \ - contrib/correctness/pmisc.cmx pretyping/rawterm.cmx toplevel/record.cmx \ - kernel/sign.cmx kernel/term.cmx lib/util.cmx contrib/correctness/pcic.cmi +toplevel/vernac.cmo: parsing/ast.cmi parsing/coqast.cmi library/lib.cmi \ + library/library.cmi library/nameops.cmi kernel/names.cmi lib/options.cmi \ + parsing/pcoq.cmi lib/pp.cmi library/states.cmi lib/system.cmi \ + lib/util.cmi toplevel/vernacinterp.cmi toplevel/vernac.cmi +toplevel/vernac.cmx: parsing/ast.cmx parsing/coqast.cmx library/lib.cmx \ + library/library.cmx library/nameops.cmx kernel/names.cmx lib/options.cmx \ + parsing/pcoq.cmx lib/pp.cmx library/states.cmx lib/system.cmx \ + lib/util.cmx toplevel/vernacinterp.cmx toplevel/vernac.cmi contrib/correctness/pcicenv.cmo: library/global.cmi kernel/names.cmi \ contrib/correctness/past.cmi contrib/correctness/penv.cmi \ contrib/correctness/pmisc.cmi contrib/correctness/pmonad.cmi \ @@ -1437,16 +1578,28 @@ contrib/correctness/pcicenv.cmx: library/global.cmx kernel/names.cmx \ contrib/correctness/prename.cmx contrib/correctness/ptype.cmi \ contrib/correctness/putil.cmx kernel/sign.cmx kernel/term.cmx \ kernel/univ.cmx contrib/correctness/pcicenv.cmi +contrib/correctness/pcic.cmo: parsing/ast.cmi kernel/declarations.cmi \ + library/declare.cmi pretyping/detyping.cmi kernel/indtypes.cmi \ + kernel/names.cmi library/nametab.cmi contrib/correctness/past.cmi \ + contrib/correctness/pmisc.cmi pretyping/rawterm.cmi toplevel/record.cmi \ + kernel/sign.cmi kernel/term.cmi pretyping/termops.cmi kernel/typeops.cmi \ + lib/util.cmi contrib/correctness/pcic.cmi +contrib/correctness/pcic.cmx: parsing/ast.cmx kernel/declarations.cmx \ + library/declare.cmx pretyping/detyping.cmx kernel/indtypes.cmx \ + kernel/names.cmx library/nametab.cmx contrib/correctness/past.cmi \ + contrib/correctness/pmisc.cmx pretyping/rawterm.cmx toplevel/record.cmx \ + kernel/sign.cmx kernel/term.cmx pretyping/termops.cmx kernel/typeops.cmx \ + lib/util.cmx contrib/correctness/pcic.cmi contrib/correctness/pdb.cmo: library/declare.cmi library/global.cmi \ kernel/names.cmi library/nametab.cmi contrib/correctness/past.cmi \ contrib/correctness/peffect.cmi contrib/correctness/penv.cmi \ contrib/correctness/perror.cmi contrib/correctness/ptype.cmi \ - kernel/sign.cmi kernel/term.cmi contrib/correctness/pdb.cmi + kernel/term.cmi pretyping/termops.cmi contrib/correctness/pdb.cmi contrib/correctness/pdb.cmx: library/declare.cmx library/global.cmx \ kernel/names.cmx library/nametab.cmx contrib/correctness/past.cmi \ contrib/correctness/peffect.cmx contrib/correctness/penv.cmx \ contrib/correctness/perror.cmx contrib/correctness/ptype.cmi \ - kernel/sign.cmx kernel/term.cmx contrib/correctness/pdb.cmi + kernel/term.cmx pretyping/termops.cmx contrib/correctness/pdb.cmi contrib/correctness/peffect.cmo: toplevel/himsg.cmi kernel/names.cmi \ contrib/correctness/pmisc.cmi lib/pp.cmi lib/util.cmi \ contrib/correctness/peffect.cmi @@ -1465,17 +1618,17 @@ contrib/correctness/penv.cmx: toplevel/himsg.cmx library/lib.cmx \ contrib/correctness/perror.cmx contrib/correctness/pmisc.cmx lib/pp.cmx \ contrib/correctness/ptype.cmi library/summary.cmx kernel/term.cmx \ contrib/correctness/penv.cmi -contrib/correctness/perror.cmo: library/declare.cmi kernel/evd.cmi \ +contrib/correctness/perror.cmo: library/declare.cmi pretyping/evd.cmi \ library/global.cmi toplevel/himsg.cmi kernel/names.cmi \ contrib/correctness/past.cmi contrib/correctness/peffect.cmi lib/pp.cmi \ - contrib/correctness/ptype.cmi kernel/reduction.cmi kernel/term.cmi \ + contrib/correctness/ptype.cmi pretyping/reductionops.cmi kernel/term.cmi \ lib/util.cmi contrib/correctness/perror.cmi -contrib/correctness/perror.cmx: library/declare.cmx kernel/evd.cmx \ +contrib/correctness/perror.cmx: library/declare.cmx pretyping/evd.cmx \ library/global.cmx toplevel/himsg.cmx kernel/names.cmx \ contrib/correctness/past.cmi contrib/correctness/peffect.cmx lib/pp.cmx \ - contrib/correctness/ptype.cmi kernel/reduction.cmx kernel/term.cmx \ + contrib/correctness/ptype.cmi pretyping/reductionops.cmx kernel/term.cmx \ lib/util.cmx contrib/correctness/perror.cmi -contrib/correctness/pextract.cmo: parsing/ast.cmi kernel/evd.cmi \ +contrib/correctness/pextract.cmo: parsing/ast.cmi pretyping/evd.cmi \ toplevel/himsg.cmi library/library.cmi kernel/names.cmi \ library/nametab.cmi contrib/extraction/ocaml.cmi \ contrib/correctness/past.cmi contrib/correctness/pcicenv.cmi \ @@ -1483,7 +1636,7 @@ contrib/correctness/pextract.cmo: parsing/ast.cmi kernel/evd.cmi \ contrib/correctness/ptype.cmi contrib/correctness/putil.cmi \ kernel/reduction.cmi lib/system.cmi kernel/term.cmi lib/util.cmi \ toplevel/vernacinterp.cmi contrib/correctness/pextract.cmi -contrib/correctness/pextract.cmx: parsing/ast.cmx kernel/evd.cmx \ +contrib/correctness/pextract.cmx: parsing/ast.cmx pretyping/evd.cmx \ toplevel/himsg.cmx library/library.cmx kernel/names.cmx \ library/nametab.cmx contrib/extraction/ocaml.cmx \ contrib/correctness/past.cmi contrib/correctness/pcicenv.cmx \ @@ -1492,12 +1645,14 @@ contrib/correctness/pextract.cmx: parsing/ast.cmx kernel/evd.cmx \ kernel/reduction.cmx lib/system.cmx kernel/term.cmx lib/util.cmx \ toplevel/vernacinterp.cmx contrib/correctness/pextract.cmi contrib/correctness/pmisc.cmo: parsing/coqast.cmi library/declare.cmi \ - pretyping/evarutil.cmi library/global.cmi kernel/names.cmi lib/pp.cmi \ - kernel/term.cmi lib/util.cmi contrib/correctness/pmisc.cmi + pretyping/evarutil.cmi library/global.cmi library/nameops.cmi \ + kernel/names.cmi lib/pp.cmi kernel/term.cmi lib/util.cmi \ + contrib/correctness/pmisc.cmi contrib/correctness/pmisc.cmx: parsing/coqast.cmx library/declare.cmx \ - pretyping/evarutil.cmx library/global.cmx kernel/names.cmx lib/pp.cmx \ - kernel/term.cmx lib/util.cmx contrib/correctness/pmisc.cmi -contrib/correctness/pmlize.cmo: parsing/coqlib.cmi kernel/evd.cmi \ + pretyping/evarutil.cmx library/global.cmx library/nameops.cmx \ + kernel/names.cmx lib/pp.cmx kernel/term.cmx lib/util.cmx \ + contrib/correctness/pmisc.cmi +contrib/correctness/pmlize.cmo: parsing/coqlib.cmi pretyping/evd.cmi \ library/global.cmi kernel/names.cmi contrib/correctness/past.cmi \ pretyping/pattern.cmi contrib/correctness/pcicenv.cmi \ contrib/correctness/peffect.cmi contrib/correctness/penv.cmi \ @@ -1506,7 +1661,7 @@ contrib/correctness/pmlize.cmo: parsing/coqlib.cmi kernel/evd.cmi \ contrib/correctness/ptyping.cmi contrib/correctness/putil.cmi \ kernel/term.cmi parsing/termast.cmi pretyping/typing.cmi lib/util.cmi \ contrib/correctness/pmlize.cmi -contrib/correctness/pmlize.cmx: parsing/coqlib.cmx kernel/evd.cmx \ +contrib/correctness/pmlize.cmx: parsing/coqlib.cmx pretyping/evd.cmx \ library/global.cmx kernel/names.cmx contrib/correctness/past.cmi \ pretyping/pattern.cmx contrib/correctness/pcicenv.cmx \ contrib/correctness/peffect.cmx contrib/correctness/penv.cmx \ @@ -1527,12 +1682,12 @@ contrib/correctness/pmonad.cmx: kernel/names.cmx contrib/correctness/past.cmi \ contrib/correctness/prename.cmx contrib/correctness/ptype.cmi \ contrib/correctness/putil.cmx kernel/term.cmx parsing/termast.cmx \ lib/util.cmx contrib/correctness/pmonad.cmi -contrib/correctness/pred.cmo: kernel/evd.cmi library/global.cmi \ +contrib/correctness/pred.cmo: pretyping/evd.cmi library/global.cmi \ contrib/correctness/past.cmi contrib/correctness/pmisc.cmi lib/pp.cmi \ - kernel/reduction.cmi kernel/term.cmi contrib/correctness/pred.cmi -contrib/correctness/pred.cmx: kernel/evd.cmx library/global.cmx \ + pretyping/reductionops.cmi kernel/term.cmi contrib/correctness/pred.cmi +contrib/correctness/pred.cmx: pretyping/evd.cmx library/global.cmx \ contrib/correctness/past.cmi contrib/correctness/pmisc.cmx lib/pp.cmx \ - kernel/reduction.cmx kernel/term.cmx contrib/correctness/pred.cmi + pretyping/reductionops.cmx kernel/term.cmx contrib/correctness/pred.cmi contrib/correctness/prename.cmo: toplevel/himsg.cmi kernel/names.cmi \ contrib/correctness/pmisc.cmi lib/pp.cmi lib/util.cmi \ contrib/correctness/prename.cmi @@ -1540,7 +1695,7 @@ contrib/correctness/prename.cmx: toplevel/himsg.cmx kernel/names.cmx \ contrib/correctness/pmisc.cmx lib/pp.cmx lib/util.cmx \ contrib/correctness/prename.cmi contrib/correctness/psyntax.cmo: parsing/ast.cmi parsing/astterm.cmi \ - parsing/coqast.cmi library/declare.cmi lib/dyn.cmi kernel/evd.cmi \ + parsing/coqast.cmi library/declare.cmi lib/dyn.cmi pretyping/evd.cmi \ parsing/g_zsyntax.cmi library/global.cmi toplevel/himsg.cmi \ kernel/names.cmi lib/options.cmi contrib/correctness/past.cmi \ contrib/correctness/pcicenv.cmi parsing/pcoq.cmi \ @@ -1554,7 +1709,7 @@ contrib/correctness/psyntax.cmo: parsing/ast.cmi parsing/astterm.cmi \ toplevel/vernacentries.cmi toplevel/vernacinterp.cmi \ contrib/correctness/psyntax.cmi contrib/correctness/psyntax.cmx: parsing/ast.cmx parsing/astterm.cmx \ - parsing/coqast.cmx library/declare.cmx lib/dyn.cmx kernel/evd.cmx \ + parsing/coqast.cmx library/declare.cmx lib/dyn.cmx pretyping/evd.cmx \ parsing/g_zsyntax.cmx library/global.cmx toplevel/himsg.cmx \ kernel/names.cmx lib/options.cmx contrib/correctness/past.cmi \ contrib/correctness/pcicenv.cmx parsing/pcoq.cmx \ @@ -1567,8 +1722,8 @@ contrib/correctness/psyntax.cmx: parsing/ast.cmx parsing/astterm.cmx \ parsing/termast.cmx lib/util.cmx toplevel/vernac.cmx \ toplevel/vernacentries.cmx toplevel/vernacinterp.cmx \ contrib/correctness/psyntax.cmi -contrib/correctness/ptactic.cmo: library/declare.cmi kernel/environ.cmi \ - tactics/equality.cmi kernel/evd.cmi library/global.cmi kernel/names.cmi \ +contrib/correctness/ptactic.cmo: library/declare.cmi tactics/equality.cmi \ + pretyping/evd.cmi library/global.cmi kernel/names.cmi library/nametab.cmi \ lib/options.cmi contrib/correctness/past.cmi pretyping/pattern.cmi \ contrib/correctness/pcic.cmi contrib/correctness/pdb.cmi \ contrib/correctness/peffect.cmi contrib/correctness/penv.cmi \ @@ -1579,11 +1734,11 @@ contrib/correctness/ptactic.cmo: library/declare.cmi kernel/environ.cmi \ parsing/printer.cmi contrib/correctness/ptyping.cmi \ contrib/correctness/putil.cmi contrib/correctness/pwp.cmi \ kernel/reduction.cmi tactics/refine.cmi proofs/tacmach.cmi \ - tactics/tacticals.cmi tactics/tactics.cmi kernel/term.cmi lib/util.cmi \ - toplevel/vernacentries.cmi toplevel/vernacinterp.cmi \ - contrib/correctness/ptactic.cmi -contrib/correctness/ptactic.cmx: library/declare.cmx kernel/environ.cmx \ - tactics/equality.cmx kernel/evd.cmx library/global.cmx kernel/names.cmx \ + tactics/tacticals.cmi tactics/tactics.cmi kernel/term.cmi \ + pretyping/termops.cmi lib/util.cmi toplevel/vernacentries.cmi \ + toplevel/vernacinterp.cmi contrib/correctness/ptactic.cmi +contrib/correctness/ptactic.cmx: library/declare.cmx tactics/equality.cmx \ + pretyping/evd.cmx library/global.cmx kernel/names.cmx library/nametab.cmx \ lib/options.cmx contrib/correctness/past.cmi pretyping/pattern.cmx \ contrib/correctness/pcic.cmx contrib/correctness/pdb.cmx \ contrib/correctness/peffect.cmx contrib/correctness/penv.cmx \ @@ -1594,123 +1749,131 @@ contrib/correctness/ptactic.cmx: library/declare.cmx kernel/environ.cmx \ parsing/printer.cmx contrib/correctness/ptyping.cmx \ contrib/correctness/putil.cmx contrib/correctness/pwp.cmx \ kernel/reduction.cmx tactics/refine.cmx proofs/tacmach.cmx \ - tactics/tacticals.cmx tactics/tactics.cmx kernel/term.cmx lib/util.cmx \ - toplevel/vernacentries.cmx toplevel/vernacinterp.cmx \ - contrib/correctness/ptactic.cmi + tactics/tacticals.cmx tactics/tactics.cmx kernel/term.cmx \ + pretyping/termops.cmx lib/util.cmx toplevel/vernacentries.cmx \ + toplevel/vernacinterp.cmx contrib/correctness/ptactic.cmi contrib/correctness/ptyping.cmo: parsing/ast.cmi parsing/astterm.cmi \ - kernel/environ.cmi kernel/evd.cmi library/global.cmi toplevel/himsg.cmi \ - kernel/names.cmi contrib/correctness/past.cmi \ + kernel/environ.cmi pretyping/evd.cmi library/global.cmi \ + toplevel/himsg.cmi kernel/names.cmi contrib/correctness/past.cmi \ contrib/correctness/pcicenv.cmi contrib/correctness/peffect.cmi \ contrib/correctness/penv.cmi contrib/correctness/perror.cmi \ contrib/correctness/pmisc.cmi contrib/correctness/pmonad.cmi lib/pp.cmi \ contrib/correctness/prename.cmi proofs/proof_trees.cmi \ contrib/correctness/ptype.cmi contrib/correctness/putil.cmi \ - kernel/reduction.cmi kernel/term.cmi pretyping/typing.cmi lib/util.cmi \ - contrib/correctness/ptyping.cmi + pretyping/reductionops.cmi kernel/term.cmi pretyping/termops.cmi \ + pretyping/typing.cmi lib/util.cmi contrib/correctness/ptyping.cmi contrib/correctness/ptyping.cmx: parsing/ast.cmx parsing/astterm.cmx \ - kernel/environ.cmx kernel/evd.cmx library/global.cmx toplevel/himsg.cmx \ - kernel/names.cmx contrib/correctness/past.cmi \ + kernel/environ.cmx pretyping/evd.cmx library/global.cmx \ + toplevel/himsg.cmx kernel/names.cmx contrib/correctness/past.cmi \ contrib/correctness/pcicenv.cmx contrib/correctness/peffect.cmx \ contrib/correctness/penv.cmx contrib/correctness/perror.cmx \ contrib/correctness/pmisc.cmx contrib/correctness/pmonad.cmx lib/pp.cmx \ contrib/correctness/prename.cmx proofs/proof_trees.cmx \ contrib/correctness/ptype.cmi contrib/correctness/putil.cmx \ - kernel/reduction.cmx kernel/term.cmx pretyping/typing.cmx lib/util.cmx \ - contrib/correctness/ptyping.cmi + pretyping/reductionops.cmx kernel/term.cmx pretyping/termops.cmx \ + pretyping/typing.cmx lib/util.cmx contrib/correctness/ptyping.cmi contrib/correctness/putil.cmo: parsing/coqlib.cmi kernel/environ.cmi \ library/global.cmi kernel/names.cmi contrib/correctness/past.cmi \ pretyping/pattern.cmi contrib/correctness/peffect.cmi \ contrib/correctness/penv.cmi contrib/correctness/pmisc.cmi lib/pp.cmi \ contrib/correctness/prename.cmi parsing/printer.cmi \ - contrib/correctness/ptype.cmi kernel/term.cmi lib/util.cmi \ - contrib/correctness/putil.cmi + contrib/correctness/ptype.cmi kernel/term.cmi pretyping/termops.cmi \ + lib/util.cmi contrib/correctness/putil.cmi contrib/correctness/putil.cmx: parsing/coqlib.cmx kernel/environ.cmx \ library/global.cmx kernel/names.cmx contrib/correctness/past.cmi \ pretyping/pattern.cmx contrib/correctness/peffect.cmx \ contrib/correctness/penv.cmx contrib/correctness/pmisc.cmx lib/pp.cmx \ contrib/correctness/prename.cmx parsing/printer.cmx \ - contrib/correctness/ptype.cmi kernel/term.cmx lib/util.cmx \ - contrib/correctness/putil.cmi -contrib/correctness/pwp.cmo: kernel/environ.cmi kernel/evd.cmi \ - library/global.cmi kernel/names.cmi contrib/correctness/past.cmi \ + contrib/correctness/ptype.cmi kernel/term.cmx pretyping/termops.cmx \ + lib/util.cmx contrib/correctness/putil.cmi +contrib/correctness/pwp.cmo: kernel/environ.cmi library/global.cmi \ + kernel/names.cmi library/nametab.cmi contrib/correctness/past.cmi \ contrib/correctness/peffect.cmi contrib/correctness/penv.cmi \ contrib/correctness/perror.cmi contrib/correctness/pmisc.cmi \ contrib/correctness/pmonad.cmi contrib/correctness/prename.cmi \ contrib/correctness/ptype.cmi contrib/correctness/ptyping.cmi \ - contrib/correctness/putil.cmi kernel/reduction.cmi kernel/term.cmi \ + contrib/correctness/putil.cmi kernel/reduction.cmi \ + pretyping/reductionops.cmi kernel/term.cmi pretyping/termops.cmi \ lib/util.cmi contrib/correctness/pwp.cmi -contrib/correctness/pwp.cmx: kernel/environ.cmx kernel/evd.cmx \ - library/global.cmx kernel/names.cmx contrib/correctness/past.cmi \ +contrib/correctness/pwp.cmx: kernel/environ.cmx library/global.cmx \ + kernel/names.cmx library/nametab.cmx contrib/correctness/past.cmi \ contrib/correctness/peffect.cmx contrib/correctness/penv.cmx \ contrib/correctness/perror.cmx contrib/correctness/pmisc.cmx \ contrib/correctness/pmonad.cmx contrib/correctness/prename.cmx \ contrib/correctness/ptype.cmi contrib/correctness/ptyping.cmx \ - contrib/correctness/putil.cmx kernel/reduction.cmx kernel/term.cmx \ + contrib/correctness/putil.cmx kernel/reduction.cmx \ + pretyping/reductionops.cmx kernel/term.cmx pretyping/termops.cmx \ lib/util.cmx contrib/correctness/pwp.cmi -contrib/extraction/common.cmo: kernel/environ.cmi library/global.cmi \ +contrib/extraction/common.cmo: library/global.cmi \ contrib/extraction/haskell.cmi contrib/extraction/miniml.cmi \ - contrib/extraction/mlutil.cmi kernel/names.cmi \ - contrib/extraction/ocaml.cmi lib/pp.cmi lib/pp_control.cmi \ - parsing/printer.cmi contrib/extraction/table.cmi \ - contrib/extraction/common.cmi -contrib/extraction/common.cmx: kernel/environ.cmx library/global.cmx \ + contrib/extraction/mlutil.cmi library/nameops.cmi kernel/names.cmi \ + library/nametab.cmi contrib/extraction/ocaml.cmi lib/pp.cmi \ + lib/pp_control.cmi parsing/printer.cmi contrib/extraction/table.cmi \ + pretyping/termops.cmi contrib/extraction/common.cmi +contrib/extraction/common.cmx: library/global.cmx \ contrib/extraction/haskell.cmx contrib/extraction/miniml.cmi \ - contrib/extraction/mlutil.cmx kernel/names.cmx \ - contrib/extraction/ocaml.cmx lib/pp.cmx lib/pp_control.cmx \ - parsing/printer.cmx contrib/extraction/table.cmx \ - contrib/extraction/common.cmi + contrib/extraction/mlutil.cmx library/nameops.cmx kernel/names.cmx \ + library/nametab.cmx contrib/extraction/ocaml.cmx lib/pp.cmx \ + lib/pp_control.cmx parsing/printer.cmx contrib/extraction/table.cmx \ + pretyping/termops.cmx contrib/extraction/common.cmi contrib/extraction/extract_env.cmo: parsing/astterm.cmi \ - contrib/extraction/common.cmi kernel/evd.cmi \ + contrib/extraction/common.cmi pretyping/evd.cmi \ contrib/extraction/extraction.cmi library/global.cmi library/lib.cmi \ library/libobject.cmi library/library.cmi contrib/extraction/miniml.cmi \ contrib/extraction/mlutil.cmi kernel/names.cmi library/nametab.cmi \ lib/pp.cmi contrib/extraction/table.cmi kernel/term.cmi lib/util.cmi \ toplevel/vernacinterp.cmi contrib/extraction/extract_env.cmi contrib/extraction/extract_env.cmx: parsing/astterm.cmx \ - contrib/extraction/common.cmx kernel/evd.cmx \ + contrib/extraction/common.cmx pretyping/evd.cmx \ contrib/extraction/extraction.cmx library/global.cmx library/lib.cmx \ library/libobject.cmx library/library.cmx contrib/extraction/miniml.cmi \ contrib/extraction/mlutil.cmx kernel/names.cmx library/nametab.cmx \ lib/pp.cmx contrib/extraction/table.cmx kernel/term.cmx lib/util.cmx \ toplevel/vernacinterp.cmx contrib/extraction/extract_env.cmi contrib/extraction/extraction.cmo: kernel/closure.cmi kernel/declarations.cmi \ - kernel/environ.cmi kernel/evd.cmi library/global.cmi lib/gmap.cmi \ - kernel/inductive.cmi kernel/instantiate.cmi contrib/extraction/miniml.cmi \ - contrib/extraction/mlutil.cmi kernel/names.cmi lib/pp.cmi \ - kernel/reduction.cmi pretyping/retyping.cmi library/summary.cmi \ - contrib/extraction/table.cmi kernel/term.cmi lib/util.cmi \ - contrib/extraction/extraction.cmi + kernel/environ.cmi pretyping/evd.cmi library/global.cmi lib/gmap.cmi \ + kernel/inductive.cmi pretyping/instantiate.cmi \ + contrib/extraction/miniml.cmi contrib/extraction/mlutil.cmi \ + library/nameops.cmi kernel/names.cmi library/nametab.cmi lib/pp.cmi \ + pretyping/reductionops.cmi pretyping/retyping.cmi library/summary.cmi \ + contrib/extraction/table.cmi kernel/term.cmi pretyping/termops.cmi \ + lib/util.cmi contrib/extraction/extraction.cmi contrib/extraction/extraction.cmx: kernel/closure.cmx kernel/declarations.cmx \ - kernel/environ.cmx kernel/evd.cmx library/global.cmx lib/gmap.cmx \ - kernel/inductive.cmx kernel/instantiate.cmx contrib/extraction/miniml.cmi \ - contrib/extraction/mlutil.cmx kernel/names.cmx lib/pp.cmx \ - kernel/reduction.cmx pretyping/retyping.cmx library/summary.cmx \ - contrib/extraction/table.cmx kernel/term.cmx lib/util.cmx \ - contrib/extraction/extraction.cmi + kernel/environ.cmx pretyping/evd.cmx library/global.cmx lib/gmap.cmx \ + kernel/inductive.cmx pretyping/instantiate.cmx \ + contrib/extraction/miniml.cmi contrib/extraction/mlutil.cmx \ + library/nameops.cmx kernel/names.cmx library/nametab.cmx lib/pp.cmx \ + pretyping/reductionops.cmx pretyping/retyping.cmx library/summary.cmx \ + contrib/extraction/table.cmx kernel/term.cmx pretyping/termops.cmx \ + lib/util.cmx contrib/extraction/extraction.cmi contrib/extraction/haskell.cmo: contrib/extraction/miniml.cmi \ - contrib/extraction/mlutil.cmi kernel/names.cmi \ - contrib/extraction/ocaml.cmi lib/options.cmi lib/pp.cmi kernel/term.cmi \ - lib/util.cmi contrib/extraction/haskell.cmi + contrib/extraction/mlutil.cmi library/nameops.cmi kernel/names.cmi \ + library/nametab.cmi contrib/extraction/ocaml.cmi lib/options.cmi \ + lib/pp.cmi kernel/term.cmi lib/util.cmi contrib/extraction/haskell.cmi contrib/extraction/haskell.cmx: contrib/extraction/miniml.cmi \ - contrib/extraction/mlutil.cmx kernel/names.cmx \ - contrib/extraction/ocaml.cmx lib/options.cmx lib/pp.cmx kernel/term.cmx \ - lib/util.cmx contrib/extraction/haskell.cmi + contrib/extraction/mlutil.cmx library/nameops.cmx kernel/names.cmx \ + library/nametab.cmx contrib/extraction/ocaml.cmx lib/options.cmx \ + lib/pp.cmx kernel/term.cmx lib/util.cmx contrib/extraction/haskell.cmi contrib/extraction/mlutil.cmo: kernel/declarations.cmi \ - contrib/extraction/miniml.cmi kernel/names.cmi lib/options.cmi lib/pp.cmi \ - parsing/printer.cmi contrib/extraction/table.cmi kernel/term.cmi \ - lib/util.cmi contrib/extraction/mlutil.cmi + contrib/extraction/miniml.cmi kernel/names.cmi library/nametab.cmi \ + lib/options.cmi lib/pp.cmi parsing/printer.cmi \ + contrib/extraction/table.cmi kernel/term.cmi lib/util.cmi \ + contrib/extraction/mlutil.cmi contrib/extraction/mlutil.cmx: kernel/declarations.cmx \ - contrib/extraction/miniml.cmi kernel/names.cmx lib/options.cmx lib/pp.cmx \ - parsing/printer.cmx contrib/extraction/table.cmx kernel/term.cmx \ - lib/util.cmx contrib/extraction/mlutil.cmi + contrib/extraction/miniml.cmi kernel/names.cmx library/nametab.cmx \ + lib/options.cmx lib/pp.cmx parsing/printer.cmx \ + contrib/extraction/table.cmx kernel/term.cmx lib/util.cmx \ + contrib/extraction/mlutil.cmi contrib/extraction/ocaml.cmo: contrib/extraction/miniml.cmi \ - contrib/extraction/mlutil.cmi kernel/names.cmi lib/options.cmi lib/pp.cmi \ - parsing/printer.cmi contrib/extraction/table.cmi kernel/term.cmi \ - lib/util.cmi contrib/extraction/ocaml.cmi + contrib/extraction/mlutil.cmi library/nameops.cmi kernel/names.cmi \ + library/nametab.cmi lib/options.cmi lib/pp.cmi parsing/printer.cmi \ + contrib/extraction/table.cmi kernel/term.cmi lib/util.cmi \ + contrib/extraction/ocaml.cmi contrib/extraction/ocaml.cmx: contrib/extraction/miniml.cmi \ - contrib/extraction/mlutil.cmx kernel/names.cmx lib/options.cmx lib/pp.cmx \ - parsing/printer.cmx contrib/extraction/table.cmx kernel/term.cmx \ - lib/util.cmx contrib/extraction/ocaml.cmi + contrib/extraction/mlutil.cmx library/nameops.cmx kernel/names.cmx \ + library/nametab.cmx lib/options.cmx lib/pp.cmx parsing/printer.cmx \ + contrib/extraction/table.cmx kernel/term.cmx lib/util.cmx \ + contrib/extraction/ocaml.cmi contrib/extraction/table.cmo: kernel/declarations.cmi library/global.cmi \ library/goptions.cmi library/lib.cmi library/libobject.cmi \ kernel/names.cmi library/nametab.cmi lib/pp.cmi parsing/printer.cmi \ @@ -1722,24 +1885,24 @@ contrib/extraction/table.cmx: kernel/declarations.cmx library/global.cmx \ library/summary.cmx kernel/term.cmx lib/util.cmx \ toplevel/vernacinterp.cmx contrib/extraction/table.cmi contrib/field/field.cmo: parsing/astterm.cmi parsing/coqast.cmi \ - library/declare.cmi kernel/evd.cmi library/global.cmi library/lib.cmi \ + library/declare.cmi pretyping/evd.cmi library/global.cmi library/lib.cmi \ library/libobject.cmi kernel/names.cmi library/nametab.cmi \ proofs/proof_type.cmi contrib/ring/quote.cmo contrib/ring/ring.cmo \ library/summary.cmi proofs/tacinterp.cmi proofs/tacmach.cmi \ kernel/term.cmi lib/util.cmi toplevel/vernacinterp.cmi contrib/field/field.cmx: parsing/astterm.cmx parsing/coqast.cmx \ - library/declare.cmx kernel/evd.cmx library/global.cmx library/lib.cmx \ + library/declare.cmx pretyping/evd.cmx library/global.cmx library/lib.cmx \ library/libobject.cmx kernel/names.cmx library/nametab.cmx \ proofs/proof_type.cmx contrib/ring/quote.cmx contrib/ring/ring.cmx \ library/summary.cmx proofs/tacinterp.cmx proofs/tacmach.cmx \ kernel/term.cmx lib/util.cmx toplevel/vernacinterp.cmx contrib/fourier/fourierR.cmo: parsing/astterm.cmi proofs/clenv.cmi \ - tactics/equality.cmi kernel/evd.cmi contrib/fourier/fourier.cmo \ + tactics/equality.cmi pretyping/evd.cmi contrib/fourier/fourier.cmo \ library/global.cmi kernel/names.cmi parsing/pcoq.cmi \ contrib/ring/ring.cmo proofs/tacmach.cmi tactics/tactics.cmi \ kernel/term.cmi contrib/fourier/fourierR.cmx: parsing/astterm.cmx proofs/clenv.cmx \ - tactics/equality.cmx kernel/evd.cmx contrib/fourier/fourier.cmx \ + tactics/equality.cmx pretyping/evd.cmx contrib/fourier/fourier.cmx \ library/global.cmx kernel/names.cmx parsing/pcoq.cmx \ contrib/ring/ring.cmx proofs/tacmach.cmx tactics/tactics.cmx \ kernel/term.cmx @@ -1747,60 +1910,60 @@ contrib/interface/centaur.cmo: contrib/interface/ascent.cmi parsing/ast.cmi \ parsing/astterm.cmi pretyping/classops.cmi toplevel/command.cmi \ parsing/coqast.cmi contrib/interface/ctast.cmo contrib/interface/dad.cmi \ contrib/interface/debug_tac.cmi kernel/declarations.cmi \ - library/declare.cmi kernel/environ.cmi toplevel/errors.cmi kernel/evd.cmi \ - library/global.cmi contrib/interface/history.cmi library/lib.cmi \ - library/libobject.cmi library/library.cmi \ + library/declare.cmi kernel/environ.cmi toplevel/errors.cmi \ + pretyping/evd.cmi library/global.cmi contrib/interface/history.cmi \ + library/lib.cmi library/libobject.cmi library/library.cmi \ toplevel/line_oriented_parser.cmi toplevel/mltop.cmi \ - contrib/interface/name_to_ast.cmi kernel/names.cmi library/nametab.cmi \ - contrib/interface/pbp.cmi proofs/pfedit.cmi lib/pp.cmi \ - pretyping/pretyping.cmi parsing/printer.cmi proofs/proof_trees.cmi \ - proofs/proof_type.cmi toplevel/protectedtoplevel.cmi \ - pretyping/rawterm.cmi kernel/reduction.cmi parsing/search.cmi \ - contrib/interface/showproof.cmi contrib/interface/showproof_ct.cmo \ - proofs/tacinterp.cmi proofs/tacmach.cmi pretyping/tacred.cmi \ - kernel/term.cmi parsing/termast.cmi contrib/interface/translate.cmi \ - lib/util.cmi toplevel/vernac.cmi toplevel/vernacentries.cmi \ - toplevel/vernacinterp.cmi contrib/interface/vtp.cmi \ - contrib/interface/xlate.cmi + contrib/interface/name_to_ast.cmi library/nameops.cmi kernel/names.cmi \ + library/nametab.cmi contrib/interface/pbp.cmi proofs/pfedit.cmi \ + lib/pp.cmi pretyping/pretyping.cmi parsing/printer.cmi \ + proofs/proof_trees.cmi proofs/proof_type.cmi \ + toplevel/protectedtoplevel.cmi pretyping/rawterm.cmi kernel/reduction.cmi \ + parsing/search.cmi contrib/interface/showproof.cmi \ + contrib/interface/showproof_ct.cmo proofs/tacinterp.cmi \ + proofs/tacmach.cmi pretyping/tacred.cmi kernel/term.cmi \ + parsing/termast.cmi contrib/interface/translate.cmi lib/util.cmi \ + toplevel/vernac.cmi toplevel/vernacentries.cmi toplevel/vernacinterp.cmi \ + contrib/interface/vtp.cmi contrib/interface/xlate.cmi contrib/interface/centaur.cmx: contrib/interface/ascent.cmi parsing/ast.cmx \ parsing/astterm.cmx pretyping/classops.cmx toplevel/command.cmx \ parsing/coqast.cmx contrib/interface/ctast.cmx contrib/interface/dad.cmx \ contrib/interface/debug_tac.cmx kernel/declarations.cmx \ - library/declare.cmx kernel/environ.cmx toplevel/errors.cmx kernel/evd.cmx \ - library/global.cmx contrib/interface/history.cmx library/lib.cmx \ - library/libobject.cmx library/library.cmx \ + library/declare.cmx kernel/environ.cmx toplevel/errors.cmx \ + pretyping/evd.cmx library/global.cmx contrib/interface/history.cmx \ + library/lib.cmx library/libobject.cmx library/library.cmx \ toplevel/line_oriented_parser.cmx toplevel/mltop.cmx \ - contrib/interface/name_to_ast.cmx kernel/names.cmx library/nametab.cmx \ - contrib/interface/pbp.cmx proofs/pfedit.cmx lib/pp.cmx \ - pretyping/pretyping.cmx parsing/printer.cmx proofs/proof_trees.cmx \ - proofs/proof_type.cmx toplevel/protectedtoplevel.cmx \ - pretyping/rawterm.cmx kernel/reduction.cmx parsing/search.cmx \ - contrib/interface/showproof.cmx contrib/interface/showproof_ct.cmx \ - proofs/tacinterp.cmx proofs/tacmach.cmx pretyping/tacred.cmx \ - kernel/term.cmx parsing/termast.cmx contrib/interface/translate.cmx \ - lib/util.cmx toplevel/vernac.cmx toplevel/vernacentries.cmx \ - toplevel/vernacinterp.cmx contrib/interface/vtp.cmx \ - contrib/interface/xlate.cmx + contrib/interface/name_to_ast.cmx library/nameops.cmx kernel/names.cmx \ + library/nametab.cmx contrib/interface/pbp.cmx proofs/pfedit.cmx \ + lib/pp.cmx pretyping/pretyping.cmx parsing/printer.cmx \ + proofs/proof_trees.cmx proofs/proof_type.cmx \ + toplevel/protectedtoplevel.cmx pretyping/rawterm.cmx kernel/reduction.cmx \ + parsing/search.cmx contrib/interface/showproof.cmx \ + contrib/interface/showproof_ct.cmx proofs/tacinterp.cmx \ + proofs/tacmach.cmx pretyping/tacred.cmx kernel/term.cmx \ + parsing/termast.cmx contrib/interface/translate.cmx lib/util.cmx \ + toplevel/vernac.cmx toplevel/vernacentries.cmx toplevel/vernacinterp.cmx \ + contrib/interface/vtp.cmx contrib/interface/xlate.cmx contrib/interface/ctast.cmo: parsing/ast.cmi parsing/coqast.cmi lib/dyn.cmi \ kernel/names.cmi contrib/interface/ctast.cmx: parsing/ast.cmx parsing/coqast.cmx lib/dyn.cmx \ kernel/names.cmx contrib/interface/dad.cmo: parsing/astterm.cmi contrib/interface/ctast.cmo \ - kernel/environ.cmi kernel/evd.cmi library/global.cmi kernel/names.cmi \ - contrib/interface/paths.cmi pretyping/pattern.cmi lib/pp.cmi \ - proofs/proof_trees.cmi proofs/proof_type.cmi pretyping/rawterm.cmi \ - kernel/reduction.cmi proofs/tacmach.cmi tactics/tacticals.cmi \ - tactics/tactics.cmi kernel/term.cmi parsing/termast.cmi \ - pretyping/typing.cmi lib/util.cmi toplevel/vernacinterp.cmi \ - contrib/interface/dad.cmi + kernel/environ.cmi pretyping/evd.cmi library/global.cmi kernel/names.cmi \ + library/nametab.cmi contrib/interface/paths.cmi pretyping/pattern.cmi \ + lib/pp.cmi proofs/proof_trees.cmi proofs/proof_type.cmi \ + pretyping/rawterm.cmi kernel/reduction.cmi proofs/tacmach.cmi \ + tactics/tacticals.cmi tactics/tactics.cmi kernel/term.cmi \ + parsing/termast.cmi pretyping/typing.cmi lib/util.cmi \ + toplevel/vernacinterp.cmi contrib/interface/dad.cmi contrib/interface/dad.cmx: parsing/astterm.cmx contrib/interface/ctast.cmx \ - kernel/environ.cmx kernel/evd.cmx library/global.cmx kernel/names.cmx \ - contrib/interface/paths.cmx pretyping/pattern.cmx lib/pp.cmx \ - proofs/proof_trees.cmx proofs/proof_type.cmx pretyping/rawterm.cmx \ - kernel/reduction.cmx proofs/tacmach.cmx tactics/tacticals.cmx \ - tactics/tactics.cmx kernel/term.cmx parsing/termast.cmx \ - pretyping/typing.cmx lib/util.cmx toplevel/vernacinterp.cmx \ - contrib/interface/dad.cmi + kernel/environ.cmx pretyping/evd.cmx library/global.cmx kernel/names.cmx \ + library/nametab.cmx contrib/interface/paths.cmx pretyping/pattern.cmx \ + lib/pp.cmx proofs/proof_trees.cmx proofs/proof_type.cmx \ + pretyping/rawterm.cmx kernel/reduction.cmx proofs/tacmach.cmx \ + tactics/tacticals.cmx tactics/tactics.cmx kernel/term.cmx \ + parsing/termast.cmx pretyping/typing.cmx lib/util.cmx \ + toplevel/vernacinterp.cmx contrib/interface/dad.cmi contrib/interface/debug_tac.cmo: parsing/ast.cmi parsing/coqast.cmi \ toplevel/errors.cmi lib/pp.cmi parsing/printer.cmi proofs/proof_trees.cmi \ proofs/proof_type.cmi proofs/tacinterp.cmi proofs/tacmach.cmi \ @@ -1819,31 +1982,31 @@ contrib/interface/name_to_ast.cmo: parsing/ast.cmi pretyping/classops.cmi \ parsing/coqast.cmi kernel/declarations.cmi library/declare.cmi \ kernel/environ.cmi library/global.cmi library/impargs.cmi \ kernel/inductive.cmi library/lib.cmi library/libobject.cmi \ - kernel/names.cmi library/nametab.cmi lib/pp.cmi parsing/prettyp.cmi \ - kernel/reduction.cmi kernel/sign.cmi pretyping/syntax_def.cmi \ - kernel/term.cmi parsing/termast.cmi lib/util.cmi \ + library/nameops.cmi kernel/names.cmi library/nametab.cmi lib/pp.cmi \ + parsing/prettyp.cmi kernel/reduction.cmi kernel/sign.cmi \ + pretyping/syntax_def.cmi kernel/term.cmi parsing/termast.cmi lib/util.cmi \ contrib/interface/name_to_ast.cmi contrib/interface/name_to_ast.cmx: parsing/ast.cmx pretyping/classops.cmx \ parsing/coqast.cmx kernel/declarations.cmx library/declare.cmx \ kernel/environ.cmx library/global.cmx library/impargs.cmx \ kernel/inductive.cmx library/lib.cmx library/libobject.cmx \ - kernel/names.cmx library/nametab.cmx lib/pp.cmx parsing/prettyp.cmx \ - kernel/reduction.cmx kernel/sign.cmx pretyping/syntax_def.cmx \ - kernel/term.cmx parsing/termast.cmx lib/util.cmx \ + library/nameops.cmx kernel/names.cmx library/nametab.cmx lib/pp.cmx \ + parsing/prettyp.cmx kernel/reduction.cmx kernel/sign.cmx \ + pretyping/syntax_def.cmx kernel/term.cmx parsing/termast.cmx lib/util.cmx \ contrib/interface/name_to_ast.cmi contrib/interface/parse.cmo: contrib/interface/ascent.cmi \ config/coq_config.cmi contrib/interface/ctast.cmo toplevel/errors.cmi \ parsing/esyntax.cmi library/libobject.cmi library/library.cmi \ contrib/interface/line_parser.cmi toplevel/metasyntax.cmi \ - kernel/names.cmi library/nametab.cmi parsing/pcoq.cmi lib/pp.cmi \ - lib/system.cmi lib/util.cmi contrib/interface/vtp.cmi \ + library/nameops.cmi kernel/names.cmi library/nametab.cmi parsing/pcoq.cmi \ + lib/pp.cmi lib/system.cmi lib/util.cmi contrib/interface/vtp.cmi \ contrib/interface/xlate.cmi contrib/interface/parse.cmx: contrib/interface/ascent.cmi \ config/coq_config.cmx contrib/interface/ctast.cmx toplevel/errors.cmx \ parsing/esyntax.cmx library/libobject.cmx library/library.cmx \ contrib/interface/line_parser.cmx toplevel/metasyntax.cmx \ - kernel/names.cmx library/nametab.cmx parsing/pcoq.cmx lib/pp.cmx \ - lib/system.cmx lib/util.cmx contrib/interface/vtp.cmx \ + library/nameops.cmx kernel/names.cmx library/nametab.cmx parsing/pcoq.cmx \ + lib/pp.cmx lib/system.cmx lib/util.cmx contrib/interface/vtp.cmx \ contrib/interface/xlate.cmx contrib/interface/paths.cmo: contrib/interface/paths.cmi contrib/interface/paths.cmx: contrib/interface/paths.cmi @@ -1863,110 +2026,118 @@ contrib/interface/pbp.cmx: parsing/coqlib.cmx contrib/interface/ctast.cmx \ kernel/reduction.cmx proofs/tacinterp.cmx proofs/tacmach.cmx \ tactics/tacticals.cmx tactics/tactics.cmx kernel/term.cmx \ pretyping/typing.cmx lib/util.cmx contrib/interface/pbp.cmi +contrib/interface/showproof_ct.cmo: contrib/interface/ascent.cmi \ + parsing/esyntax.cmi library/global.cmi toplevel/metasyntax.cmi lib/pp.cmi \ + parsing/printer.cmi contrib/interface/translate.cmi \ + contrib/interface/vtp.cmi contrib/interface/xlate.cmi +contrib/interface/showproof_ct.cmx: contrib/interface/ascent.cmi \ + parsing/esyntax.cmx library/global.cmx toplevel/metasyntax.cmx lib/pp.cmx \ + parsing/printer.cmx contrib/interface/translate.cmx \ + contrib/interface/vtp.cmx contrib/interface/xlate.cmx contrib/interface/showproof.cmo: parsing/ast.cmi parsing/astterm.cmi \ proofs/clenv.cmi parsing/coqast.cmi kernel/declarations.cmi \ - kernel/environ.cmi kernel/evd.cmi library/global.cmi kernel/inductive.cmi \ + kernel/environ.cmi pretyping/evd.cmi library/global.cmi \ + kernel/inductive.cmi pretyping/inductiveops.cmi library/nameops.cmi \ kernel/names.cmi proofs/pfedit.cmi lib/pp.cmi parsing/printer.cmi \ - proofs/proof_trees.cmi proofs/proof_type.cmi kernel/reduction.cmi \ + proofs/proof_trees.cmi proofs/proof_type.cmi pretyping/reductionops.cmi \ contrib/interface/showproof_ct.cmo kernel/sign.cmi lib/stamps.cmi \ proofs/tacmach.cmi kernel/term.cmi parsing/termast.cmi \ - contrib/interface/translate.cmi pretyping/typing.cmi lib/util.cmi \ - toplevel/vernacinterp.cmi contrib/interface/showproof.cmi + pretyping/termops.cmi contrib/interface/translate.cmi \ + pretyping/typing.cmi lib/util.cmi toplevel/vernacinterp.cmi \ + contrib/interface/showproof.cmi contrib/interface/showproof.cmx: parsing/ast.cmx parsing/astterm.cmx \ proofs/clenv.cmx parsing/coqast.cmx kernel/declarations.cmx \ - kernel/environ.cmx kernel/evd.cmx library/global.cmx kernel/inductive.cmx \ + kernel/environ.cmx pretyping/evd.cmx library/global.cmx \ + kernel/inductive.cmx pretyping/inductiveops.cmx library/nameops.cmx \ kernel/names.cmx proofs/pfedit.cmx lib/pp.cmx parsing/printer.cmx \ - proofs/proof_trees.cmx proofs/proof_type.cmx kernel/reduction.cmx \ + proofs/proof_trees.cmx proofs/proof_type.cmx pretyping/reductionops.cmx \ contrib/interface/showproof_ct.cmx kernel/sign.cmx lib/stamps.cmx \ proofs/tacmach.cmx kernel/term.cmx parsing/termast.cmx \ - contrib/interface/translate.cmx pretyping/typing.cmx lib/util.cmx \ - toplevel/vernacinterp.cmx contrib/interface/showproof.cmi -contrib/interface/showproof_ct.cmo: contrib/interface/ascent.cmi \ - parsing/esyntax.cmi library/global.cmi toplevel/metasyntax.cmi lib/pp.cmi \ - parsing/printer.cmi contrib/interface/translate.cmi \ - contrib/interface/vtp.cmi contrib/interface/xlate.cmi -contrib/interface/showproof_ct.cmx: contrib/interface/ascent.cmi \ - parsing/esyntax.cmx library/global.cmx toplevel/metasyntax.cmx lib/pp.cmx \ - parsing/printer.cmx contrib/interface/translate.cmx \ - contrib/interface/vtp.cmx contrib/interface/xlate.cmx + pretyping/termops.cmx contrib/interface/translate.cmx \ + pretyping/typing.cmx lib/util.cmx toplevel/vernacinterp.cmx \ + contrib/interface/showproof.cmi contrib/interface/translate.cmo: contrib/interface/ascent.cmi parsing/ast.cmi \ contrib/interface/ctast.cmo kernel/environ.cmi pretyping/evarutil.cmi \ - kernel/evd.cmi library/libobject.cmi library/library.cmi kernel/names.cmi \ - proofs/pfedit.cmi lib/pp.cmi proofs/proof_type.cmi kernel/sign.cmi \ - proofs/tacmach.cmi kernel/term.cmi parsing/termast.cmi lib/util.cmi \ - toplevel/vernacinterp.cmi contrib/interface/vtp.cmi \ + pretyping/evd.cmi library/libobject.cmi library/library.cmi \ + kernel/names.cmi proofs/pfedit.cmi lib/pp.cmi proofs/proof_type.cmi \ + kernel/sign.cmi proofs/tacmach.cmi kernel/term.cmi parsing/termast.cmi \ + lib/util.cmi toplevel/vernacinterp.cmi contrib/interface/vtp.cmi \ contrib/interface/xlate.cmi contrib/interface/translate.cmi contrib/interface/translate.cmx: contrib/interface/ascent.cmi parsing/ast.cmx \ contrib/interface/ctast.cmx kernel/environ.cmx pretyping/evarutil.cmx \ - kernel/evd.cmx library/libobject.cmx library/library.cmx kernel/names.cmx \ - proofs/pfedit.cmx lib/pp.cmx proofs/proof_type.cmx kernel/sign.cmx \ - proofs/tacmach.cmx kernel/term.cmx parsing/termast.cmx lib/util.cmx \ - toplevel/vernacinterp.cmx contrib/interface/vtp.cmx \ + pretyping/evd.cmx library/libobject.cmx library/library.cmx \ + kernel/names.cmx proofs/pfedit.cmx lib/pp.cmx proofs/proof_type.cmx \ + kernel/sign.cmx proofs/tacmach.cmx kernel/term.cmx parsing/termast.cmx \ + lib/util.cmx toplevel/vernacinterp.cmx contrib/interface/vtp.cmx \ contrib/interface/xlate.cmx contrib/interface/translate.cmi contrib/interface/vtp.cmo: contrib/interface/ascent.cmi \ contrib/interface/vtp.cmi contrib/interface/vtp.cmx: contrib/interface/ascent.cmi \ contrib/interface/vtp.cmi contrib/interface/xlate.cmo: contrib/interface/ascent.cmi parsing/ast.cmi \ - contrib/interface/ctast.cmo kernel/names.cmi lib/util.cmi \ - contrib/interface/xlate.cmi + contrib/interface/ctast.cmo library/nameops.cmi kernel/names.cmi \ + lib/util.cmi contrib/interface/xlate.cmi contrib/interface/xlate.cmx: contrib/interface/ascent.cmi parsing/ast.cmx \ - contrib/interface/ctast.cmx kernel/names.cmx lib/util.cmx \ - contrib/interface/xlate.cmi + contrib/interface/ctast.cmx library/nameops.cmx kernel/names.cmx \ + lib/util.cmx contrib/interface/xlate.cmi contrib/omega/coq_omega.cmo: parsing/ast.cmi proofs/clenv.cmi \ - kernel/closure.cmi parsing/coqlib.cmi library/declare.cmi \ - kernel/environ.cmi tactics/equality.cmi proofs/evar_refiner.cmi \ - library/global.cmi kernel/inductive.cmi proofs/logic.cmi kernel/names.cmi \ - library/nametab.cmi contrib/omega/omega.cmo lib/pp.cmi \ - parsing/printer.cmi proofs/proof_type.cmi kernel/reduction.cmi \ - kernel/sign.cmi proofs/tacmach.cmi tactics/tactics.cmi kernel/term.cmi \ - lib/util.cmi + kernel/closure.cmi parsing/coqlib.cmi kernel/declarations.cmi \ + library/declare.cmi kernel/environ.cmi tactics/equality.cmi \ + proofs/evar_refiner.cmi library/global.cmi kernel/inductive.cmi \ + proofs/logic.cmi library/nameops.cmi kernel/names.cmi library/nametab.cmi \ + contrib/omega/omega.cmo lib/pp.cmi parsing/printer.cmi \ + proofs/proof_type.cmi kernel/reduction.cmi kernel/sign.cmi \ + proofs/tacmach.cmi tactics/tactics.cmi kernel/term.cmi \ + pretyping/termops.cmi lib/util.cmi contrib/omega/coq_omega.cmx: parsing/ast.cmx proofs/clenv.cmx \ - kernel/closure.cmx parsing/coqlib.cmx library/declare.cmx \ - kernel/environ.cmx tactics/equality.cmx proofs/evar_refiner.cmx \ - library/global.cmx kernel/inductive.cmx proofs/logic.cmx kernel/names.cmx \ - library/nametab.cmx contrib/omega/omega.cmx lib/pp.cmx \ - parsing/printer.cmx proofs/proof_type.cmx kernel/reduction.cmx \ - kernel/sign.cmx proofs/tacmach.cmx tactics/tactics.cmx kernel/term.cmx \ - lib/util.cmx + kernel/closure.cmx parsing/coqlib.cmx kernel/declarations.cmx \ + library/declare.cmx kernel/environ.cmx tactics/equality.cmx \ + proofs/evar_refiner.cmx library/global.cmx kernel/inductive.cmx \ + proofs/logic.cmx library/nameops.cmx kernel/names.cmx library/nametab.cmx \ + contrib/omega/omega.cmx lib/pp.cmx parsing/printer.cmx \ + proofs/proof_type.cmx kernel/reduction.cmx kernel/sign.cmx \ + proofs/tacmach.cmx tactics/tactics.cmx kernel/term.cmx \ + pretyping/termops.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 library/global.cmi \ - kernel/instantiate.cmi kernel/names.cmi library/nametab.cmi \ - pretyping/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 library/nametab.cmx \ - pretyping/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 kernel/environ.cmi \ + library/global.cmi pretyping/instantiate.cmi kernel/names.cmi \ + library/nametab.cmi pretyping/pattern.cmi lib/pp.cmi \ + proofs/proof_trees.cmi proofs/proof_type.cmi proofs/tacmach.cmi \ + tactics/tactics.cmi kernel/term.cmi pretyping/termops.cmi lib/util.cmi +contrib/ring/quote.cmx: library/declare.cmx kernel/environ.cmx \ + library/global.cmx pretyping/instantiate.cmx kernel/names.cmx \ + library/nametab.cmx pretyping/pattern.cmx lib/pp.cmx \ + proofs/proof_trees.cmx proofs/proof_type.cmx proofs/tacmach.cmx \ + tactics/tactics.cmx kernel/term.cmx pretyping/termops.cmx lib/util.cmx contrib/ring/ring.cmo: parsing/astterm.cmi kernel/closure.cmi \ parsing/coqlib.cmi library/declare.cmi tactics/equality.cmi \ - kernel/evd.cmi library/global.cmi tactics/hiddentac.cmi \ + pretyping/evd.cmi library/global.cmi tactics/hiddentac.cmi \ tactics/hipattern.cmi library/lib.cmi library/libobject.cmi \ - kernel/names.cmi library/nametab.cmi lib/options.cmi \ + library/nameops.cmi kernel/names.cmi library/nametab.cmi lib/options.cmi \ pretyping/pattern.cmi lib/pp.cmi parsing/printer.cmi \ proofs/proof_trees.cmi proofs/proof_type.cmi contrib/ring/quote.cmo \ - kernel/reduction.cmi tactics/setoid_replace.cmi library/summary.cmi \ + pretyping/reductionops.cmi tactics/setoid_replace.cmi library/summary.cmi \ proofs/tacmach.cmi pretyping/tacred.cmi tactics/tactics.cmi \ kernel/term.cmi pretyping/typing.cmi lib/util.cmi \ toplevel/vernacinterp.cmi contrib/ring/ring.cmx: parsing/astterm.cmx kernel/closure.cmx \ parsing/coqlib.cmx library/declare.cmx tactics/equality.cmx \ - kernel/evd.cmx library/global.cmx tactics/hiddentac.cmx \ + pretyping/evd.cmx library/global.cmx tactics/hiddentac.cmx \ tactics/hipattern.cmx library/lib.cmx library/libobject.cmx \ - kernel/names.cmx library/nametab.cmx lib/options.cmx \ + library/nameops.cmx kernel/names.cmx library/nametab.cmx lib/options.cmx \ pretyping/pattern.cmx lib/pp.cmx parsing/printer.cmx \ proofs/proof_trees.cmx proofs/proof_type.cmx contrib/ring/quote.cmx \ - kernel/reduction.cmx tactics/setoid_replace.cmx library/summary.cmx \ + pretyping/reductionops.cmx tactics/setoid_replace.cmx library/summary.cmx \ proofs/tacmach.cmx pretyping/tacred.cmx tactics/tactics.cmx \ kernel/term.cmx pretyping/typing.cmx lib/util.cmx \ toplevel/vernacinterp.cmx contrib/romega/const_omega.cmo: library/declare.cmi library/global.cmi \ - kernel/names.cmi kernel/reduction.cmi kernel/term.cmi lib/util.cmi + kernel/names.cmi library/nametab.cmi kernel/term.cmi \ + pretyping/termops.cmi lib/util.cmi contrib/romega/const_omega.cmx: library/declare.cmx library/global.cmx \ - kernel/names.cmx kernel/reduction.cmx kernel/term.cmx lib/util.cmx + kernel/names.cmx library/nametab.cmx kernel/term.cmx \ + pretyping/termops.cmx lib/util.cmx contrib/romega/refl_omega.cmo: parsing/ast.cmi tactics/auto.cmi \ proofs/clenv.cmi contrib/romega/const_omega.cmo \ contrib/omega/coq_omega.cmo kernel/environ.cmi kernel/inductive.cmi \ @@ -1981,26 +2152,28 @@ contrib/romega/refl_omega.cmx: parsing/ast.cmx tactics/auto.cmx \ parsing/printer.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 -contrib/xml/xml.cmo: contrib/xml/xml.cmi -contrib/xml/xml.cmx: contrib/xml/xml.cmi contrib/xml/xmlcommand.cmo: kernel/declarations.cmi library/declare.cmi \ - kernel/environ.cmi kernel/evd.cmi library/global.cmi library/lib.cmi \ - library/libobject.cmi library/library.cmi kernel/names.cmi \ - library/nametab.cmi proofs/pfedit.cmi proofs/proof_trees.cmi \ - kernel/reduction.cmi pretyping/retyping.cmi kernel/safe_typing.cmi \ - kernel/sign.cmi lib/system.cmi proofs/tacmach.cmi kernel/term.cmi \ - lib/util.cmi contrib/xml/xml.cmi contrib/xml/xmlcommand.cmi + kernel/environ.cmi pretyping/evd.cmi library/global.cmi library/lib.cmi \ + library/libobject.cmi library/library.cmi library/nameops.cmi \ + kernel/names.cmi library/nametab.cmi proofs/pfedit.cmi \ + proofs/proof_trees.cmi kernel/reduction.cmi pretyping/retyping.cmi \ + kernel/safe_typing.cmi kernel/sign.cmi lib/system.cmi proofs/tacmach.cmi \ + kernel/term.cmi lib/util.cmi contrib/xml/xml.cmi \ + contrib/xml/xmlcommand.cmi contrib/xml/xmlcommand.cmx: kernel/declarations.cmx library/declare.cmx \ - kernel/environ.cmx kernel/evd.cmx library/global.cmx library/lib.cmx \ - library/libobject.cmx library/library.cmx kernel/names.cmx \ - library/nametab.cmx proofs/pfedit.cmx proofs/proof_trees.cmx \ - kernel/reduction.cmx pretyping/retyping.cmx kernel/safe_typing.cmx \ - kernel/sign.cmx lib/system.cmx proofs/tacmach.cmx kernel/term.cmx \ - lib/util.cmx contrib/xml/xml.cmx contrib/xml/xmlcommand.cmi + kernel/environ.cmx pretyping/evd.cmx library/global.cmx library/lib.cmx \ + library/libobject.cmx library/library.cmx library/nameops.cmx \ + kernel/names.cmx library/nametab.cmx proofs/pfedit.cmx \ + proofs/proof_trees.cmx kernel/reduction.cmx pretyping/retyping.cmx \ + kernel/safe_typing.cmx kernel/sign.cmx lib/system.cmx proofs/tacmach.cmx \ + kernel/term.cmx lib/util.cmx contrib/xml/xml.cmx \ + contrib/xml/xmlcommand.cmi contrib/xml/xmlentries.cmo: lib/util.cmi toplevel/vernacinterp.cmi \ contrib/xml/xmlcommand.cmi contrib/xml/xmlentries.cmx: lib/util.cmx toplevel/vernacinterp.cmx \ contrib/xml/xmlcommand.cmx +contrib/xml/xml.cmo: contrib/xml/xml.cmi +contrib/xml/xml.cmx: contrib/xml/xml.cmi tactics/tauto.cmo: parsing/grammar.cma kernel/names.cmo parsing/ast.cmo parsing/g_tactic.cmo parsing/g_ltac.cmo parsing/g_constr.cmo contrib/correctness/psyntax.cmo: parsing/grammar.cma contrib/field/field.cmo: parsing/grammar.cma kernel/names.cmo parsing/ast.cmo parsing/g_tactic.cmo parsing/g_ltac.cmo parsing/g_constr.cmo @@ -76,21 +76,24 @@ LIBREP=lib/pp_control.cmo lib/pp.cmo lib/util.cmo \ KERNEL=kernel/names.cmo kernel/univ.cmo \ kernel/esubst.cmo kernel/term.cmo kernel/sign.cmo \ - kernel/declarations.cmo kernel/environ.cmo kernel/evd.cmo \ - kernel/instantiate.cmo kernel/closure.cmo kernel/reduction.cmo \ - kernel/inductive.cmo kernel/type_errors.cmo kernel/typeops.cmo \ + kernel/declarations.cmo kernel/environ.cmo kernel/closure.cmo \ + kernel/reduction.cmo \ + kernel/type_errors.cmo kernel/inductive.cmo kernel/typeops.cmo \ kernel/indtypes.cmo kernel/cooking.cmo kernel/safe_typing.cmo -LIBRARY=library/libobject.cmo library/summary.cmo library/nametab.cmo \ - library/lib.cmo library/global.cmo \ +LIBRARY=library/nameops.cmo library/libobject.cmo library/summary.cmo \ + library/nametab.cmo library/lib.cmo library/global.cmo \ library/goptions.cmo library/opaque.cmo \ library/library.cmo library/states.cmo \ - library/impargs.cmo library/indrec.cmo library/declare.cmo + library/impargs.cmo library/declare.cmo -PRETYPING=pretyping/rawterm.cmo pretyping/detyping.cmo \ - pretyping/retyping.cmo pretyping/cbv.cmo pretyping/tacred.cmo \ +PRETYPING=pretyping/termops.cmo \ + pretyping/evd.cmo pretyping/instantiate.cmo \ + pretyping/reductionops.cmo pretyping/inductiveops.cmo \ + pretyping/rawterm.cmo pretyping/detyping.cmo pretyping/retyping.cmo \ + pretyping/cbv.cmo pretyping/tacred.cmo \ pretyping/pretype_errors.cmo pretyping/typing.cmo \ - pretyping/classops.cmo pretyping/recordops.cmo \ + pretyping/classops.cmo pretyping/recordops.cmo pretyping/indrec.cmo \ pretyping/evarutil.cmo pretyping/evarconv.cmo \ pretyping/coercion.cmo pretyping/cases.cmo pretyping/pretyping.cmo \ pretyping/syntax_def.cmo pretyping/pattern.cmo @@ -147,34 +150,38 @@ INTERFACE=contrib/interface/vtp.cmo \ contrib/interface/showproof_ct.cmo contrib/interface/showproof.cmo \ contrib/interface/centaur.cmo -PARSERREQUIRES=lib/pp_control.cmo lib/pp.cmo \ +PARSERREQUIRES=config/coq_config.cmo lib/pp_control.cmo lib/pp.cmo \ lib/util.cmo lib/dyn.cmo lib/gmap.cmo lib/gmapl.cmo \ lib/predicate.cmo lib/hashcons.cmo lib/profile.cmo \ - library/libobject.cmo library/summary.cmo kernel/names.cmo \ + lib/system.cmo lib/bstack.cmo lib/edit.cmo lib/options.cmo \ + kernel/names.cmo kernel/univ.cmo kernel/esubst.cmo \ + kernel/term.cmo kernel/sign.cmo kernel/environ.cmo \ + kernel/closure.cmo kernel/reduction.cmo \ + kernel/type_errors.cmo kernel/inductive.cmo kernel/typeops.cmo \ + kernel/indtypes.cmo kernel/cooking.cmo kernel/safe_typing.cmo \ + library/nameops.cmo library/libobject.cmo library/summary.cmo \ + library/nametab.cmo library/lib.cmo \ + library/global.cmo library/opaque.cmo \ + library/library.cmo lib/options.cmo library/impargs.cmo \ + pretyping/evd.cmo pretyping/instantiate.cmo \ + pretyping/termops.cmo \ + pretyping/reductionops.cmo pretyping/retyping.cmo library/declare.cmo \ + pretyping/cbv.cmo pretyping/tacred.cmo pretyping/classops.cmo \ + pretyping/rawterm.cmo \ + pretyping/pattern.cmo pretyping/pretype_errors.cmo \ + pretyping/evarutil.cmo pretyping/recordops.cmo pretyping/evarconv.cmo \ + pretyping/coercion.cmo pretyping/inductiveops.cmo pretyping/cases.cmo \ + pretyping/indrec.cmo \ + pretyping/pretyping.cmo pretyping/syntax_def.cmo \ parsing/lexer.cmo parsing/coqast.cmo \ parsing/pcoq.cmo parsing/ast.cmo \ parsing/g_prim.cmo parsing/g_basevernac.cmo \ parsing/g_vernac.cmo parsing/g_proofs.cmo parsing/g_tactic.cmo \ parsing/g_ltac.cmo parsing/g_constr.cmo parsing/g_cases.cmo \ - parsing/extend.cmo config/coq_config.cmo\ - lib/system.cmo lib/bstack.cmo lib/edit.cmo \ - library/nametab.cmo kernel/univ.cmo library/lib.cmo kernel/esubst.cmo \ - kernel/term.cmo kernel/declarations.cmo lib/options.cmo \ - kernel/sign.cmo kernel/environ.cmo kernel/evd.cmo \ - kernel/instantiate.cmo kernel/closure.cmo kernel/reduction.cmo \ - kernel/inductive.cmo kernel/type_errors.cmo kernel/typeops.cmo \ - kernel/indtypes.cmo kernel/cooking.cmo kernel/safe_typing.cmo \ - library/global.cmo library/opaque.cmo \ - library/library.cmo lib/options.cmo library/indrec.cmo \ - library/impargs.cmo pretyping/retyping.cmo library/declare.cmo \ - pretyping/cbv.cmo pretyping/tacred.cmo pretyping/classops.cmo \ - pretyping/rawterm.cmo \ + parsing/extend.cmo \ parsing/coqlib.cmo library/goptions.cmo pretyping/detyping.cmo \ parsing/termast.cmo \ - pretyping/pattern.cmo pretyping/pretype_errors.cmo \ - pretyping/evarutil.cmo pretyping/recordops.cmo pretyping/evarconv.cmo \ - pretyping/coercion.cmo pretyping/cases.cmo \ - pretyping/pretyping.cmo pretyping/syntax_def.cmo parsing/astterm.cmo \ + parsing/astterm.cmo \ parsing/egrammar.cmo parsing/esyntax.cmo toplevel/metasyntax.cmo \ parsing/printer.cmo lib/stamps.cmo pretyping/typing.cmo \ proofs/proof_trees.cmo proofs/logic.cmo proofs/refiner.cmo \ diff --git a/contrib/correctness/past.mli b/contrib/correctness/past.mli index 7696c6698..9919ee993 100644 --- a/contrib/correctness/past.mli +++ b/contrib/correctness/past.mli @@ -48,7 +48,7 @@ type ('a, 'b) t = { } and ('a, 'b) t_desc = - | Var of variable + | Variable of variable | Acc of variable | Aff of variable * ('a, 'b) t | TabAcc of bool * variable * ('a, 'b) t @@ -58,10 +58,10 @@ and ('a, 'b) t_desc = (('a, 'b) t, 'b) block | If of ('a, 'b) t * ('a, 'b) t * ('a, 'b) t | Lam of 'b Ptype.ml_type_v Ptype.binder list * ('a, 'b) t - | App of ('a, 'b) t * ('a, 'b) arg list + | Apply of ('a, 'b) t * ('a, 'b) arg list | SApp of ('a, 'b) t_desc list * ('a, 'b) t list | LetRef of variable * ('a, 'b) t * ('a, 'b) t - | LetIn of variable * ('a, 'b) t * ('a, 'b) t + | Let of variable * ('a, 'b) t * ('a, 'b) t | LetRec of variable * 'b Ptype.ml_type_v Ptype.binder list * 'b Ptype.ml_type_v * ('b * 'b) * ('a, 'b) t | PPoint of string * ('a, 'b) t_desc diff --git a/contrib/correctness/pcic.ml b/contrib/correctness/pcic.ml index d13be7720..be8f14203 100644 --- a/contrib/correctness/pcic.ml +++ b/contrib/correctness/pcic.ml @@ -12,9 +12,13 @@ open Names open Term +open Termops +open Nametab open Declarations +open Indtypes open Sign open Rawterm +open Typeops open Pmisc open Past @@ -30,7 +34,7 @@ let make_hole c = mkCast (isevar, c) * If necessary, tuples are generated ``on the fly''. *) let tuple_exists id = - try let _ = Nametab.sp_of_id CCI id in true with Not_found -> false + try let _ = Nametab.sp_of_id id in true with Not_found -> false let ast_set = Ast.ope ("SET", []) @@ -73,8 +77,10 @@ let sig_n n = (List.rev_map (fun id -> (id, LocalAssum mkSet)) lT) in let lc = - let app_sig = mkAppA (Array.init (n+2) (fun i -> mkRel (2*n+3-i))) in - let app_p = mkAppA (Array.init (n+1) (fun i -> mkRel (n+1-i))) in + let app_sig = mkApp(mkRel (2*n+3), + Array.init (n+1) (fun i -> mkRel (2*n+2-i))) in + let app_p = mkApp(mkRel (n+1), + Array.init n (fun i -> mkRel (n-i))) in let c = mkArrow app_p app_sig in List.fold_right (fun id c -> mkProd (Name id, mkRel (n+1), c)) lx c in @@ -118,13 +124,13 @@ let tuple_ref dep n = let name = Printf.sprintf "exist_%d" n in let id = id_of_string name in if not (tuple_exists id) then ignore (sig_n n); - Nametab.sp_of_id CCI id + Nametab.sp_of_id id end else begin let name = Printf.sprintf "Build_tuple_%d" n in let id = id_of_string name in if not (tuple_exists id) then tuple_n n; - Nametab.sp_of_id CCI id + Nametab.sp_of_id id end (* Binders. *) diff --git a/contrib/correctness/pcicenv.ml b/contrib/correctness/pcicenv.ml index c1b4b0fa3..4663b3e37 100644 --- a/contrib/correctness/pcicenv.ml +++ b/contrib/correctness/pcicenv.ml @@ -24,14 +24,17 @@ open Past (* VERY UGLY!! find some work around *) let modify_sign id t s = - let t' = lookup_id_type id s in - map_named_context (fun t'' -> if t'' == t' then t else t'') s + fold_named_context + (fun ((x,b,ty) as d) sign -> + if x=id then add_named_decl (x,b,t) sign else add_named_decl d sign) + s empty_named_context let add_sign (id,t) s = - if mem_named_context id s then + try + let _ = lookup_named id s in modify_sign id t s - else - add_named_assum (id,t) s + with Not_found -> + add_named_decl (id,None,t) s let cast_set c = mkCast (c, mkSet) diff --git a/contrib/correctness/pdb.ml b/contrib/correctness/pdb.ml index a0651e90c..142ba63c9 100644 --- a/contrib/correctness/pdb.ml +++ b/contrib/correctness/pdb.ml @@ -12,6 +12,8 @@ open Names open Term +open Termops +open Nametab open Ptype open Past @@ -90,7 +92,7 @@ let rec db_binders ((tids,pids,refs) as idl) = function let rec db_pattern = function | (PatVar id) as t -> (try - (match Nametab.sp_of_id CCI id with + (match Nametab.sp_of_id id with | ConstructRef (x,y) -> [], PatConstruct (id,(x,y)) | _ -> [id],t) with Not_found -> [id],t) @@ -115,7 +117,7 @@ let rec db_pattern = function let db_prog e = (* tids = type identifiers, ids = variables, refs = references and arrays *) let rec db_desc ((tids,ids,refs) as idl) = function - | (Var x) as t -> + | (Variable x) as t -> (match lookup_var ids (Some e.loc) x with None -> t | Some c -> Expression c) @@ -145,14 +147,14 @@ let db_prog e = | Lam (bl,e) -> let idl',bl' = db_binders idl bl in Lam(bl', db idl' e) - | App (e1,l) -> - App (db idl e1, List.map (db_arg idl) l) + | Apply (e1,l) -> + Apply (db idl e1, List.map (db_arg idl) l) | SApp (dl,l) -> SApp (dl, List.map (db idl) l) | LetRef (x,e1,e2) -> LetRef (x, db idl e1, db (tids,ids,x::refs) e2) - | LetIn (x,e1,e2) -> - LetIn (x, db idl e1, db (tids,x::ids,refs) e2) + | Let (x,e1,e2) -> + Let (x, db idl e1, db (tids,x::ids,refs) e2) | LetRec (f,bl,v,var,e) -> let (tids',ids',refs'),bl' = db_binders idl bl in @@ -166,7 +168,7 @@ let db_prog e = | PPoint (s,d) -> PPoint (s, db_desc idl d) and db_arg ((tids,_,refs) as idl) = function - | Term ({ desc = Var id } as t) -> + | Term ({ desc = Variable id } as t) -> if List.mem id refs then Refarg id else Term (db idl t) | Term t -> Term (db idl t) | Type v as ty -> check_type_v refs v; ty @@ -178,7 +180,7 @@ let db_prog e = loc = e.loc; info = e.info } in - let ids = Sign.ids_of_named_context (Global.named_context ()) in + let ids = Termops.ids_of_named_context (Global.named_context ()) in (* TODO: separer X:Set et x:V:Set virer le reste (axiomes, etc.) *) let vars,refs = all_vars (), all_refs () in diff --git a/contrib/correctness/penv.ml b/contrib/correctness/penv.ml index 466905962..feee251ff 100644 --- a/contrib/correctness/penv.ml +++ b/contrib/correctness/penv.ml @@ -128,7 +128,7 @@ let add_global id v p = if is_mutable v then id else id_of_string ("prog_" ^ (string_of_id id)) in - Lib.add_leaf id' OBJ (inProg (id,TypeV v,p)) + Lib.add_leaf id' (inProg (id,TypeV v,p)) end let add_global_set id = @@ -136,7 +136,7 @@ let add_global_set id = let _ = Env.find id !env in Perror.clash id None with - Not_found -> Lib.add_leaf id OBJ (inProg (id,Set,None)) + Not_found -> Lib.add_leaf id (inProg (id,Set,None)) let is_global id = try diff --git a/contrib/correctness/perror.ml b/contrib/correctness/perror.ml index 1eb44d5bc..452e1b581 100644 --- a/contrib/correctness/perror.ml +++ b/contrib/correctness/perror.ml @@ -66,7 +66,7 @@ let is_constant_type s = function TypePure c -> let id = id_of_string s in let c' = Declare.global_reference id in - Reduction.is_conv (Global.env()) Evd.empty c c' + Reductionops.is_conv (Global.env()) Evd.empty c c' | _ -> false let check_for_index_type loc v = diff --git a/contrib/correctness/pmisc.ml b/contrib/correctness/pmisc.ml index ad7779036..6d04befe2 100644 --- a/contrib/correctness/pmisc.ml +++ b/contrib/correctness/pmisc.ml @@ -13,10 +13,9 @@ open Pp open Coqast open Names +open Nameops open Term -module SpSet = Set.Make(struct type t = section_path let compare = sp_ord end) - (* debug *) let debug = ref false @@ -144,11 +143,12 @@ let real_subst_in_constr = replace_vars let coq_constant d s = make_path - (make_dirpath (List.map id_of_string ("Coq" :: d))) (id_of_string s) CCI + (make_dirpath (List.rev (List.map id_of_string ("Coq"::d)))) + (id_of_string s) let bool_sp = coq_constant ["Init"; "Datatypes"] "bool" -let coq_true = mkMutConstruct ((bool_sp,0),1) -let coq_false = mkMutConstruct ((bool_sp,0),2) +let coq_true = mkConstruct ((bool_sp,0),1) +let coq_false = mkConstruct ((bool_sp,0),2) let constant s = let id = id_of_string s in diff --git a/contrib/correctness/pmisc.mli b/contrib/correctness/pmisc.mli index a4359b6d8..3dbae5cd0 100644 --- a/contrib/correctness/pmisc.mli +++ b/contrib/correctness/pmisc.mli @@ -13,8 +13,6 @@ open Names open Term -module SpSet : Set.S with type elt = section_path - (* Some misc. functions *) val reraise_with_loc : Coqast.loc -> ('a -> 'b) -> 'a -> 'b diff --git a/contrib/correctness/pmlize.ml b/contrib/correctness/pmlize.ml index 8fa2fa58e..aa8131003 100644 --- a/contrib/correctness/pmlize.ml +++ b/contrib/correctness/pmlize.ml @@ -58,7 +58,7 @@ and trad_desc ren env ct d = let ty = trad_ml_type_v ren env tt in make_tuple [ CC_expr c',ty ] qt ren env (current_date ren) - | Var id -> + | Variable id -> if is_mutable_in_env env id then invalid_arg "Mlise.trad_desc" else if is_local env id then @@ -170,7 +170,7 @@ and trad_desc ren env ct d = let te = trans ren' e in CC_lam (bl', te) - | SApp ([Var id; Expression q1; Expression q2], [e1; e2]) + | SApp ([Variable id; Expression q1; Expression q2], [e1; e2]) when id = connective_and or id = connective_or -> let c = constant (string_of_id id) in let te1 = trad ren e1 @@ -179,7 +179,7 @@ and trad_desc ren env ct d = and q2' = apply_post ren env (current_date ren) (anonymous q2) in CC_app (CC_expr c, [CC_expr q1'.a_value; CC_expr q2'.a_value; te1; te2]) - | SApp ([Var id; Expression q], [e]) when id = connective_not -> + | SApp ([Variable id; Expression q], [e]) when id = connective_not -> let c = constant (string_of_id id) in let te = trad ren e in let q' = apply_post ren env (current_date ren) (anonymous q) in @@ -188,7 +188,7 @@ and trad_desc ren env ct d = | SApp _ -> invalid_arg "mlise.trad (SApp)" - | App (f, args) -> + | Apply (f, args) -> let trad_arg (ren,args) = function | Term a -> let ((_,tya),efa,_,_) as ca = a.info.kappa in @@ -239,7 +239,7 @@ and trad_desc ren env ct d = in t - | LetIn (x, e1, e2) -> + | Let (x, e1, e2) -> let (_,v1),ef1,p1,q1 = e1.info.kappa in let te1 = trad ren e1 in let tv1 = trad_ml_type_v ren env v1 in diff --git a/contrib/correctness/pred.ml b/contrib/correctness/pred.ml index 053131567..6a9c41a72 100644 --- a/contrib/correctness/pred.ml +++ b/contrib/correctness/pred.ml @@ -88,7 +88,7 @@ let rec red = function (* How to reduce uncomplete proof terms when they have become constr *) open Term -open Reduction +open Reductionops (* Il ne faut pas reduire de redexe (beta/iota) qui impliquerait * la substitution d'une métavariable. diff --git a/contrib/correctness/psyntax.ml4 b/contrib/correctness/psyntax.ml4 index 70596779d..b85a50790 100644 --- a/contrib/correctness/psyntax.ml4 +++ b/contrib/correctness/psyntax.ml4 @@ -115,15 +115,16 @@ let isevar = Expression isevar let bin_op op loc e1 e2 = without_effect loc - (App (without_effect loc (Expression (constant op)), [ Term e1; Term e2 ])) + (Apply (without_effect loc (Expression (constant op)), + [ Term e1; Term e2 ])) let un_op op loc e = without_effect loc - (App (without_effect loc (Expression (constant op)), [Term e])) + (Apply (without_effect loc (Expression (constant op)), [Term e])) let bool_bin op loc a1 a2 = let w = without_effect loc in - let d = SApp ( [Var op], [a1; a2]) in + let d = SApp ( [Variable op], [a1; a2]) in w d let bool_or loc = bool_bin connective_or loc @@ -131,7 +132,7 @@ let bool_and loc = bool_bin connective_and loc let bool_not loc a = let w = without_effect loc in - let d = SApp ( [Var connective_not ], [a]) in + let d = SApp ( [Variable connective_not ], [a]) in w d let ast_zwf_zero loc = @@ -147,9 +148,9 @@ let bdize c = Termast.ast_of_constr true env c let rec coqast_of_program loc = function - | Var id -> let s = string_of_id id in <:ast< ($VAR $s) >> + | Variable id -> let s = string_of_id id in <:ast< ($VAR $s) >> | Acc id -> let s = string_of_id id in <:ast< ($VAR $s) >> - | App (f,l) -> + | Apply (f,l) -> let f = coqast_of_program f.loc f.desc in let args = List.map (function Term t -> coqast_of_program t.loc t.desc @@ -178,8 +179,8 @@ let ast_plus_un loc ast = let make_ast_for loc i v1 v2 inv block = let f = for_name() in let id_i = id_of_string i in - let var_i = without_effect loc (Var id_i) in - let var_f = without_effect loc (Var f) in + let var_i = without_effect loc (Variable id_i) in + let var_f = without_effect loc (Variable f) in let succ_v2 = let a_v2 = coqast_of_program v2.loc v2.desc in ast_plus_un loc a_v2 in @@ -190,7 +191,7 @@ let make_ast_for loc i v1 v2 inv block = let br_f = let un = without_effect loc (Expression (constr_of_int "1")) in let succ_i = bin_op "Zplus" loc var_i un in - let f_succ_i = without_effect loc (App (var_f, [Term succ_i])) in + let f_succ_i = without_effect loc (Apply (var_f, [Term succ_i])) in without_effect loc (Seq (block @ [Statement f_succ_i])) in let inv' = @@ -205,14 +206,14 @@ let make_ast_for loc i v1 v2 inv block = let typez = ast_constant loc "Z" in [(id_of_string i, BindType (TypePure typez))] in - let fv1 = without_effect loc (App (var_f, [Term v1])) in + let fv1 = without_effect loc (Apply (var_f, [Term v1])) in let v = TypePure (ast_constant loc "unit") in let var = let zminus = ast_constant loc "Zminus" in let a = <:ast< (APPLIST $zminus $succ_v2 ($VAR $i)) >> in (a, ast_zwf_zero loc) in - LetIn (f, without_effect loc (LetRec (f,bl,v,var,e1)), fv1) + Let (f, without_effect loc (LetRec (f,bl,v,var,e1)), fv1) let mk_prog loc p pre post = { desc = p.desc; @@ -376,7 +377,7 @@ GEXTEND Gram ; ast7: [ [ v = variable -> - Var v + Variable v | n = INT -> Expression (constr_of_int n) | "!"; v = variable -> @@ -408,7 +409,7 @@ GEXTEND Gram "in"; p2 = program -> LetRef (v, p1, p2) | IDENT "let"; v = variable; "="; p1 = program; "in"; p2 = program -> - LetIn (v, p1, p2) + Let (v, p1, p2) | IDENT "begin"; b = block; "end" -> Seq b | IDENT "fun"; bl = binders; "->"; p = program -> @@ -421,7 +422,7 @@ GEXTEND Gram bl = binders; ":"; v = type_v; "{"; IDENT "variant"; var = variant; "}"; "="; p = program; "in"; p2 = program -> - LetIn (f, without_effect loc (LetRec (f,bl,v,var,p)), p2) + Let (f, without_effect loc (LetRec (f,bl,v,var,p)), p2) | "@"; s = STRING; p = program -> Debug (s,p) @@ -433,7 +434,7 @@ GEXTEND Gram Pp.warning "Some annotations are lost"; p.desc | _ -> - App(p,args) + Apply(p,args) ] ] ; arg: diff --git a/contrib/correctness/ptactic.ml b/contrib/correctness/ptactic.ml index d4c3494a8..011c3c7e8 100644 --- a/contrib/correctness/ptactic.ml +++ b/contrib/correctness/ptactic.ml @@ -95,6 +95,7 @@ open Tacmach open Tactics open Tacticals open Equality +open Nametab let nat = IndRef (coq_constant ["Init";"Datatypes"] "nat", 0) let lt = ConstRef (coq_constant ["Init";"Peano"] "lt") @@ -136,7 +137,7 @@ let (loop_ids : tactic) = fun gl -> match pf_matches gl eq_pattern (body_of_type a) with | [_; _,varphi; _] when isVar varphi -> let phi = destVar varphi in - if Environ.occur_var env phi concl then + if Termops.occur_var env phi concl then tclTHEN (rewriteLR (mkVar id)) (arec al) gl else arec al gl @@ -200,11 +201,11 @@ let (automatic : tactic) = let reduce_open_constr (em,c) = let existential_map_of_constr = let rec collect em c = match kind_of_term c with - | IsCast (c',t) -> + | Cast (c',t) -> (match kind_of_term c' with - | IsEvar ev -> (ev,t) :: em + | Evar ev -> (ev,t) :: em | _ -> fold_constr collect em c) - | IsEvar _ -> + | Evar _ -> assert false (* all existentials should be casted *) | _ -> fold_constr collect em c diff --git a/contrib/correctness/ptyping.ml b/contrib/correctness/ptyping.ml index de5d2da7d..2e95f840f 100644 --- a/contrib/correctness/ptyping.ml +++ b/contrib/correctness/ptyping.ml @@ -14,6 +14,7 @@ open Pp open Util open Names open Term +open Termops open Environ open Astterm open Himsg @@ -50,11 +51,11 @@ let typed_var ren env (phi,r) = let rec convert = function | (TypePure c1, TypePure c2) -> - Reduction.is_conv (Global.env ()) Evd.empty c1 c2 + Reductionops.is_conv (Global.env ()) Evd.empty c1 c2 | (Ref v1, Ref v2) -> convert (v1,v2) | (Array (s1,v1), Array (s2,v2)) -> - (Reduction.is_conv (Global.env ()) Evd.empty s1 s2) && (convert (v1,v2)) + (Reductionops.is_conv (Global.env ()) Evd.empty s1 s2) && (convert (v1,v2)) | (v1,v2) -> v1 = v2 let effect_app ren env f args = @@ -132,15 +133,16 @@ and is_pure_type_c = function | _ -> false let rec is_pure_desc ren env = function - Var id -> not (is_in_env env id) or (is_pure_type_v (type_in_env env id)) + Variable id -> + not (is_in_env env id) or (is_pure_type_v (type_in_env env id)) | Expression c -> (c = isevar) or (is_pure_cci (type_of_expression ren env c)) | Acc _ -> true | TabAcc (_,_,p) -> is_pure ren env p - | App (p,args) -> + | Apply (p,args) -> is_pure ren env p & List.for_all (is_pure_arg ren env) args | SApp _ | Aff _ | TabAff _ | Seq _ | While _ | If _ - | Lam _ | LetRef _ | LetIn _ | LetRec _ -> false + | Lam _ | LetRef _ | Let _ | LetRec _ -> false | Debug (_,p) -> is_pure ren env p | PPoint (_,d) -> is_pure_desc ren env d and is_pure ren env p = @@ -304,7 +306,7 @@ and cic_binders env ren = function let states_expression ren env expr = let rec effect pl = function - | Var id -> + | Variable id -> (if is_global id then constant (string_of_id id) else mkVar id), pl, Peffect.bottom | Expression c -> c, pl, Peffect.bottom @@ -314,7 +316,7 @@ let states_expression ren env expr = let pre = Pmonad.make_pre_access ren env id c in Pmonad.make_raw_access ren env (id,id) c, (anonymous_pre true pre)::pl, Peffect.add_read id ef - | App (p,args) -> + | Apply (p,args) -> let a,pl,e = effect pl p.desc in let args,pl,e = List.fold_right @@ -373,10 +375,10 @@ let rec states_desc ren env loc = function | Acc _ -> failwith "Ptyping.states: term is supposed not to be pure" - | Var id -> + | Variable id -> let v = type_in_env env id in let ef = Peffect.bottom in - Var id, (v,ef) + Variable id, (v,ef) | Aff (x, e1) -> Perror.check_for_reference loc x (type_in_env env x); @@ -437,20 +439,20 @@ let rec states_desc ren env loc = function Lam(bl',s_e), (v,ef) (* Connectives AND and OR *) - | SApp ([Var id], [e1;e2]) -> + | SApp ([Variable id], [e1;e2]) -> let s_e1 = states ren env e1 and s_e2 = states ren env e2 in let (_,ef1,_,_) = s_e1.info.kappa and (_,ef2,_,_) = s_e2.info.kappa in let ef = Peffect.union ef1 ef2 in - SApp ([Var id], [s_e1; s_e2]), + SApp ([Variable id], [s_e1; s_e2]), (TypePure (constant "bool"), ef) (* Connective NOT *) - | SApp ([Var id], [e]) -> + | SApp ([Variable id], [e]) -> let s_e = states ren env e in let (_,ef,_,_) = s_e.info.kappa in - SApp ([Var id], [s_e]), + SApp ([Variable id], [s_e]), (TypePure (constant "bool"), ef) | SApp _ -> invalid_arg "Ptyping.states (SApp)" @@ -463,7 +465,7 @@ let rec states_desc ren env loc = function donc si on l'applique ŕ r justement, elle ne modifiera que r mais le séquencement ne sera pas correct. *) - | App (f, args) -> + | Apply (f, args) -> let s_f = states ren env f in let _,eff,_,_ = s_f.info.kappa in let s_args = List.map (states_arg ren env) args in @@ -477,7 +479,7 @@ let rec states_desc ren env loc = function let ef = Peffect.compose (List.fold_left Peffect.compose eff ef_args) efapp in - App (s_f, s_args), (tapp, ef) + Apply (s_f, s_args), (tapp, ef) | LetRef (x, e1, e2) -> let s_e1 = states ren env e1 in @@ -490,7 +492,7 @@ let rec states_desc ren env loc = function let ef = Peffect.compose ef1 (Peffect.remove ef2 x) in LetRef (x, s_e1, s_e2), (v2,ef) - | LetIn (x, e1, e2) -> + | Let (x, e1, e2) -> let s_e1 = states ren env e1 in let (_,v1),ef1,_,_ = s_e1.info.kappa in Perror.check_for_not_mutable e1.loc v1; @@ -498,7 +500,7 @@ let rec states_desc ren env loc = function let s_e2 = states ren env' e2 in let (_,v2),ef2,_,_ = s_e2.info.kappa in let ef = Peffect.compose ef1 ef2 in - LetIn (x, s_e1, s_e2), (v2,ef) + Let (x, s_e1, s_e2), (v2,ef) | If (b, e1, e2) -> let s_b = states ren env b in diff --git a/contrib/correctness/putil.ml b/contrib/correctness/putil.ml index 73d1778ac..fecd577d7 100644 --- a/contrib/correctness/putil.ml +++ b/contrib/correctness/putil.ml @@ -13,6 +13,7 @@ open Util open Names open Term +open Termops open Pattern open Environ @@ -196,15 +197,15 @@ let dest_sig c = match matches (Coqlib.build_coq_sig_pattern ()) c with (* TODO: faire un test plus serieux sur le type des objets Coq *) let rec is_pure_cci c = match kind_of_term c with - | IsCast (c,_) -> is_pure_cci c - | IsProd(_,_,c') -> is_pure_cci c' - | IsRel _ | IsMutInd _ | IsConst _ -> true (* heu... *) - | IsApp _ -> not (is_matching (Coqlib.build_coq_sig_pattern ()) c) + | Cast (c,_) -> is_pure_cci c + | Prod(_,_,c') -> is_pure_cci c' + | Rel _ | Ind _ | Const _ -> true (* heu... *) + | App _ -> not (is_matching (Coqlib.build_coq_sig_pattern ()) c) | _ -> Util.error "CCI term not acceptable in programs" let rec v_of_constr c = match kind_of_term c with - | IsCast (c,_) -> v_of_constr c - | IsProd _ -> + | Cast (c,_) -> v_of_constr c + | Prod _ -> let revbl,t2 = Term.decompose_prod c in let bl = List.map @@ -213,7 +214,7 @@ let rec v_of_constr c = match kind_of_term c with in let vars = List.rev (List.map (fun (id,_) -> mkVar id) bl) in Arrow (bl, c_of_constr (substl vars t2)) - | IsMutInd _ | IsConst _ | IsApp _ -> + | Ind _ | Const _ | App _ -> TypePure c | _ -> failwith "v_of_constr: TODO" diff --git a/contrib/correctness/pwp.ml b/contrib/correctness/pwp.ml index 1381bdf92..adaafbc68 100644 --- a/contrib/correctness/pwp.ml +++ b/contrib/correctness/pwp.ml @@ -13,7 +13,9 @@ open Util open Names open Term +open Termops open Environ +open Nametab open Pmisc open Ptype @@ -79,7 +81,7 @@ let post_if_none env q = function * post-condition *) let annotation_candidate = function - | { desc = If _ | LetIn _ | LetRef _ ; post = None } -> true + | { desc = If _ | Let _ | LetRef _ ; post = None } -> true | _ -> false (* [extract_pre p] erase the pre-condition of p and returns it *) @@ -111,7 +113,8 @@ let create_bool_post c = let is_bool = function | TypePure c -> (match kind_of_term (strip_outer_cast c) with - | IsMutInd op -> Global.string_of_global (IndRef op) = "bool" + | Ind op -> + string_of_id (id_of_global (Global.env()) (IndRef op)) = "bool" | _ -> false) | _ -> false @@ -145,8 +148,8 @@ let normalize_boolean ren env b = let decomp_boolean = function | Some { a_value = q } -> - Reduction.whd_betaiota (Term.applist (q, [constant "true"])), - Reduction.whd_betaiota (Term.applist (q, [constant "false"])) + Reductionops.whd_betaiota (Term.applist (q, [constant "true"])), + Reductionops.whd_betaiota (Term.applist (q, [constant "false"])) | _ -> invalid_arg "Ptyping.decomp_boolean" (* top point of a program *) @@ -213,8 +216,8 @@ let rec propagate_desc ren info d = TabAff (false, x, propagate ren e1', propagate ren e2) | TabAff (ch,x,e1,e2) -> TabAff (ch, x, propagate ren e1, propagate ren e2) - | App (f,l) -> - App (propagate ren f, List.map (propagate_arg ren) l) + | Apply (f,l) -> + Apply (propagate ren f, List.map (propagate_arg ren) l) | SApp (f,l) -> let l = List.map (fun e -> normalize_boolean ren env (propagate ren e)) l @@ -236,16 +239,16 @@ let rec propagate_desc ren info d = let ren' = push_date ren top in PPoint (top, LetRef (x, propagate ren' e1, propagate ren' (post_if_none_up env top q e2))) - | LetIn (x,e1,e2) -> + | Let (x,e1,e2) -> let top = label_name() in let ren' = push_date ren top in - PPoint (top, LetIn (x, propagate ren' e1, + PPoint (top, Let (x, propagate ren' e1, propagate ren' (post_if_none_up env top q e2))) | LetRec (f,bl,v,var,e) -> LetRec (f, bl, v, var, propagate ren e) | PPoint (s,d) -> PPoint (s, propagate_desc ren info d) - | Debug _ | Var _ + | Debug _ | Variable _ | Acc _ | Expression _ as d -> d @@ -253,7 +256,7 @@ let rec propagate_desc ren info d = and propagate ren p = let env = p.info.env in let p = match p.desc with - | App (f,l) -> + | Apply (f,l) -> let _,(_,so,ok),(_,_,_,qapp) = effect_app ren env f l in if ok then let q = option_app (named_app (real_subst_in_constr so)) qapp in @@ -284,7 +287,7 @@ and propagate ren p = let q = option_app (named_app abstract_unit) q in post_if_none env q p - | SApp ([Var id], [e1;e2]) + | SApp ([Variable id], [e1;e2]) when id = connective_and or id = connective_or -> let (_,_,_,q1) = e1.info.kappa and (_,_,_,q2) = e2.info.kappa in @@ -293,24 +296,26 @@ and propagate ren p = let q = let conn = if id = connective_and then "spec_and" else "spec_or" in let c = Term.applist (constant conn, [r1; s1; r2; s2]) in - let c = Reduction.whd_betadeltaiota (Global.env()) Evd.empty c in + let c = Reduction.whd_betadeltaiota (Global.env()) c in create_bool_post c in let d = - SApp ([Var id; Expression (out_post q1); Expression (out_post q2)], + SApp ([Variable id; + Expression (out_post q1); + Expression (out_post q2)], [e1; e2] ) in post_if_none env q (change_desc p d) - | SApp ([Var id], [e1]) when id = connective_not -> + | SApp ([Variable id], [e1]) when id = connective_not -> let (_,_,_,q1) = e1.info.kappa in let (r1,s1) = decomp_boolean q1 in let q = let c = Term.applist (constant "spec_not", [r1; s1]) in - let c = Reduction.whd_betadeltaiota (Global.env ()) Evd.empty c in + let c = Reduction.whd_betadeltaiota (Global.env ()) c in create_bool_post c in - let d = SApp ([Var id; Expression (out_post q1)], [ e1 ]) in + let d = SApp ([Variable id; Expression (out_post q1)], [ e1 ]) in post_if_none env q (change_desc p d) | _ -> p diff --git a/contrib/extraction/common.ml b/contrib/extraction/common.ml index fd7c3da03..65cc52fe8 100644 --- a/contrib/extraction/common.ml +++ b/contrib/extraction/common.ml @@ -10,13 +10,13 @@ open Pp open Names +open Nameops open Miniml open Table open Mlutil open Ocaml open Nametab - (*s Modules considerations *) let current_module = ref None @@ -53,7 +53,7 @@ let cache r f = module ToplevelParams = struct let toplevel = true let globals () = Idset.empty - let rename_global r = Names.id_of_string (Global.string_of_global r) + let rename_global r = Termops.id_of_global (Global.env()) r let pp_type_global = Printer.pr_global let pp_global = Printer.pr_global end @@ -74,13 +74,13 @@ module MonoParams = struct let rename_type_global r = cache r (fun r -> - let id = Environ.id_of_global (Global.env()) r in + let id = Termops.id_of_global (Global.env()) r in rename_global_id (lowercase_id id)) let rename_global r = cache r (fun r -> - let id = Environ.id_of_global (Global.env()) r in + let id = Termops.id_of_global (Global.env()) r in match r with | ConstructRef _ -> rename_global_id (uppercase_id id) | _ -> rename_global_id (lowercase_id id)) @@ -118,13 +118,13 @@ module ModularParams = struct let rename_type_global r = cache r (fun r -> - let id = Environ.id_of_global (Global.env()) r in + let id = Termops.id_of_global (Global.env()) r in rename_global_id r id (lowercase_id id) "coq_") let rename_global r = cache r (fun r -> - let id = Environ.id_of_global (Global.env()) r in + let id = Termops.id_of_global (Global.env()) r in match r with | ConstructRef _ -> rename_global_id r id (uppercase_id id) "Coq_" | _ -> rename_global_id r id (lowercase_id id) "coq_") diff --git a/contrib/extraction/common.mli b/contrib/extraction/common.mli index 823388f4b..122075c87 100644 --- a/contrib/extraction/common.mli +++ b/contrib/extraction/common.mli @@ -11,6 +11,7 @@ open Miniml open Mlutil open Names +open Nametab module ToplevelPp : Mlpp diff --git a/contrib/extraction/extract_env.ml b/contrib/extraction/extract_env.ml index da5d0d9c1..9ca23646f 100644 --- a/contrib/extraction/extract_env.ml +++ b/contrib/extraction/extract_env.ml @@ -17,6 +17,7 @@ open Extraction open Miniml open Table open Mlutil +open Nametab open Vernacinterp open Common @@ -164,9 +165,9 @@ let _ = let c = Astterm.interp_constr Evd.empty (Global.env()) ast in match kind_of_term c with (* If it is a global reference, then output the declaration *) - | IsConst sp -> extract_reference (ConstRef sp) - | IsMutInd ind -> extract_reference (IndRef ind) - | IsMutConstruct cs -> extract_reference (ConstructRef cs) + | Const sp -> extract_reference (ConstRef sp) + | Ind ind -> extract_reference (IndRef ind) + | Construct cs -> extract_reference (ConstructRef cs) (* Otherwise, output the ML type or expression *) | _ -> match extract_constr (Global.env()) [] c with diff --git a/contrib/extraction/extraction.ml b/contrib/extraction/extraction.ml index 5e7fadd8e..2fef10de1 100644 --- a/contrib/extraction/extraction.ml +++ b/contrib/extraction/extraction.ml @@ -11,10 +11,12 @@ open Pp open Util open Names +open Nameops open Term +open Termops open Declarations open Environ -open Reduction +open Reductionops open Inductive open Instantiate open Miniml @@ -22,6 +24,7 @@ open Table open Mlutil open Closure open Summary +open Nametab (*s Extraction results. *) @@ -110,7 +113,7 @@ let whd_betaiotalet = clos_norm_flags (UNIFORM, mkflags [fBETA;fIOTA;fZETA]) let is_axiom sp = (Global.lookup_constant sp).const_body = None -type lamprod = Lam | Prod +type lamprod = Lam | Product let flexible_name = id_of_string "flex" @@ -141,19 +144,19 @@ let rec list_of_ml_arrows = function let rec get_arity env c = match kind_of_term (whd_betadeltaiota env none c) with - | IsProd (x,t,c0) -> get_arity (push_rel_assum (x,t) env) c0 - | IsCast (t,_) -> get_arity env t - | IsSort s -> Some (family_of_sort s) + | Prod (x,t,c0) -> get_arity (push_rel (x,None,t) env) c0 + | Cast (t,_) -> get_arity env t + | Sort s -> Some (family_of_sort s) | _ -> None (* idem, but goes through [Lambda] as well. Cf. [find_conclusion]. *) let rec get_lam_arity env c = match kind_of_term (whd_betadeltaiota env none c) with - | IsLambda (x,t,c0) -> get_lam_arity (push_rel_assum (x,t) env) c0 - | IsProd (x,t,c0) -> get_lam_arity (push_rel_assum (x,t) env) c0 - | IsCast (t,_) -> get_lam_arity env t - | IsSort s -> Some (family_of_sort s) + | Lambda (x,t,c0) -> get_lam_arity (push_rel (x,None,t) env) c0 + | Prod (x,t,c0) -> get_lam_arity (push_rel (x,None,t) env) c0 + | Cast (t,_) -> get_lam_arity env t + | Sort s -> Some (family_of_sort s) | _ -> None (*s Detection of non-informative parts. *) @@ -193,7 +196,8 @@ type binders = (name * constr) list let rec lbinders_fold f acc env = function | [] -> acc | (n,t) as b :: l -> - f n t (v_of_t env t) (lbinders_fold f acc (push_rel_assum b env) l) + f n t (v_of_t env t) + (lbinders_fold f acc (push_rel_assum b env) l) (* [sign_of_arity] transforms an arity into a signature. It is used for example with the types of inductive definitions, which are known @@ -340,32 +344,31 @@ and extract_type_rec env c vl args = and extract_type_rec_info env c vl args = match (kind_of_term (whd_betaiotalet env none c)) with - | IsSort _ -> + | Sort _ -> assert (args = []); (* A sort can't be applied. *) Tarity - | IsProd (n,t,d) -> + | Prod (n,t,d) -> assert (args = []); (* A product can't be applied. *) - extract_prod_lam env (n,t,d) vl Prod - | IsLambda (n,t,d) -> + extract_prod_lam env (n,t,d) vl Product + | Lambda (n,t,d) -> assert (args = []); (* [c] is now in head normal form. *) extract_prod_lam env (n,t,d) vl Lam - | IsApp (d, args') -> + | App (d, args') -> (* We just accumulate the arguments. *) extract_type_rec_info env d vl (Array.to_list args' @ args) - | IsRel n -> - (match lookup_rel_value n env with - | Some t -> + | Rel n -> + (match lookup_rel n env with + | (_,Some t,_) -> extract_type_rec_info env (lift n t) vl args - | None -> - let id = id_of_name (fst (lookup_rel_type n env)) in - Tmltype (Tvar id, [], vl)) - | IsConst sp when args = [] && is_ml_extraction (ConstRef sp) -> + | (id,_,_) -> + Tmltype (Tvar (id_of_name id), [], vl)) + | Const sp when args = [] && is_ml_extraction (ConstRef sp) -> Tmltype (Tglob (ConstRef sp), [], vl) - | IsConst sp when is_axiom sp -> + | Const sp when is_axiom sp -> let id = next_ident_away (basename sp) vl in Tmltype (Tvar id, [], id :: vl) - | IsConst sp -> - let t = constant_type env none sp in + | Const sp -> + let t = constant_type env sp in if is_arity env none t then (match extract_constant sp with | Emltype (Miniml.Tarity,_,_) -> Tarity @@ -378,19 +381,19 @@ and extract_type_rec_info env c vl args = (* which type is not an arity: we reduce this constant. *) let cvalue = constant_value env sp in extract_type_rec_info env (applist (cvalue, args)) vl [] - | IsMutInd spi -> + | Ind spi -> (match extract_inductive spi with |Iml (si,vli) -> extract_type_app env (IndRef spi,si,vli) vl args |Iprop -> assert false (* Cf. initial tests *)) - | IsMutCase _ | IsFix _ | IsCoFix _ -> + | Case _ | Fix _ | CoFix _ -> let id = next_ident_away flexible_name vl in Tmltype (Tvar id, [], id :: vl) (* Type without counterpart in ML: we generate a new flexible type variable. *) - | IsCast (c, _) -> + | Cast (c, _) -> extract_type_rec_info env c vl args - | IsVar _ -> section_message () + | Var _ -> section_message () | _ -> assert false @@ -412,12 +415,12 @@ and extract_prod_lam env (n,t,d) vl flag = (match extract_type_rec_info env' d vl [] with | Tmltype (mld, sign, vl') -> Tmltype (mld, tag::sign, vl') | et -> et) - | (Logic, NotArity), Prod -> + | (Logic, NotArity), Product -> (match extract_type_rec_info env' d vl [] with | Tmltype (mld, sign, vl') -> Tmltype (Tarr (Miniml.Tprop, mld), tag::sign, vl') | et -> et) - | (Info, NotArity), Prod -> + | (Info, NotArity), Product -> (* It is important to treat [d] first and [t] in second. *) (* This ensures that the end of [vl] correspond to external binders. *) (match extract_type_rec_info env' d vl [] with @@ -499,7 +502,7 @@ and extract_term_info env ctx c = and extract_term_info_with_type env ctx c t = match kind_of_term c with - | IsLambda (n, t, d) -> + | Lambda (n, t, d) -> let v = v_of_t env t in let env' = push_rel_assum (n,t) env in let ctx' = (snd v = NotArity) :: ctx in @@ -509,9 +512,9 @@ and extract_term_info_with_type env ctx c t = | _,Arity -> d' | Logic,NotArity -> MLlam (prop_name, d') | Info,NotArity -> MLlam (id_of_name n, d')) - | IsLetIn (n, c1, t1, c2) -> + | LetIn (n, c1, t1, c2) -> let v = v_of_t env t1 in - let env' = push_rel_def (n,c1,t1) env in + let env' = push_rel (n,Some c1,t1) env in (match v with | (Info, NotArity) -> let c1' = extract_term_info_with_type env ctx c1 t1 in @@ -520,25 +523,25 @@ and extract_term_info_with_type env ctx c t = MLletin (id_of_name n,c1',c2') | _ -> extract_term_info env' (false :: ctx) c2) - | IsRel n -> + | Rel n -> MLrel (renum_db ctx n) - | IsConst sp -> + | Const sp -> MLglob (ConstRef sp) - | IsApp (f,a) -> + | App (f,a) -> extract_app env ctx f a - | IsMutConstruct cp -> + | Construct cp -> abstract_constructor cp - | IsMutCase ((_,(ip,_,_,_,_)),_,c,br) -> + | Case ({ci_ind=ip},_,c,br) -> extract_case env ctx ip c br - | IsFix ((_,i),recd) -> + | Fix ((_,i),recd) -> extract_fix env ctx i recd - | IsCoFix (i,recd) -> + | CoFix (i,recd) -> extract_fix env ctx i recd - | IsCast (c, _) -> + | Cast (c, _) -> extract_term_info_with_type env ctx c t - | IsMutInd _ | IsProd _ | IsSort _ | IsMeta _ | IsEvar _ -> + | Ind _ | Prod _ | Sort _ | Meta _ | Evar _ -> assert false - | IsVar _ -> section_message () + | Var _ -> section_message () (* Abstraction of an inductive constructor: @@ -581,8 +584,8 @@ and abstract_constructor cp = (* Extraction of a case *) and extract_case env ctx ip c br = - let mis = Global.lookup_mind_specif ip in - let ni = Array.map List.length (mis_recarg mis) in + let (mib,mip) = Global.lookup_inductive ip in + let ni = Array.map List.length (mip.mind_listrec) in (* [ni]: number of arguments without parameters in each branch *) (* [br]: bodies of each branch (in functional form) *) let extract_branch j b = @@ -596,7 +599,7 @@ and extract_case env ctx ip c br = let ctx' = List.fold_left (fun l v -> (v = default)::l) ctx s in (* Some pathological cases need an [extract_constr] here rather *) (* than an [extract_term]. See exemples in [test_extraction.v] *) - let env' = push_rels_assum rb env in + let env' = push_rel_context (List.map (fun (x,t) -> (x,None,t)) rb) env in let e' = mlterm_of_constr (extract_constr env' ctx' e) in let ids = List.fold_right @@ -757,13 +760,13 @@ and extract_constructor (((sp,_),_) as c) = constructor which has one informative argument. This dummy case will be simplified. *) -and is_singleton_inductive (sp,_) = - let mib = Global.lookup_mind sp in +and is_singleton_inductive ind = + let (mib,mip) = Global.lookup_inductive ind in (mib.mind_ntypes = 1) && - let mis = build_mis (sp,0) mib in - (mis_nconstr mis = 1) && - match extract_constructor ((sp,0),1) with - | Cml ([mlt],_,_)-> (try parse_ml_type sp mlt; true with Found_sp -> false) + (Array.length mip.mind_consnames = 1) && + match extract_constructor (ind,1) with + | Cml ([mlt],_,_)-> + (try parse_ml_type (fst ind) mlt; true with Found_sp -> false) | _ -> false and is_singleton_constructor ((sp,i),_) = @@ -774,15 +777,15 @@ and signature_of_constructor cp = match extract_constructor cp with | Cml (_,s,n) -> (s,n) and extract_mib sp = - if not (Gmap.mem (sp,0) !inductive_extraction_table) then begin - let mib = Global.lookup_mind sp in + let ind = (sp,0) in + if not (Gmap.mem ind !inductive_extraction_table) then begin + let (mib,mip) = Global.lookup_inductive ind in let genv = Global.env () in (* Everything concerning parameters. We do that first, since they are common to all the [mib]. *) - let mis = build_mis (sp,0) mib in - let nb = mis_nparams mis in - let rb = mis_params_ctxt mis in - let env = push_rels rb genv in + let nb = mip.mind_nparams in + let rb = mip.mind_params_ctxt in + let env = push_rel_context rb genv in let lb = List.rev_map (fun (n,s,t)->(n,t)) rb in let nbtokeep = lbinders_fold @@ -793,11 +796,11 @@ and extract_mib sp = let vl0 = iterate_for 0 (mib.mind_ntypes - 1) (fun i vl -> let ip = (sp,i) in - let mis = build_mis ip mib in - if (mis_sort mis) = (Prop Null) then begin + let (mib,mip) = Global.lookup_inductive ip in + if mip.mind_sort = (Prop Null) then begin add_inductive_extraction ip Iprop; vl end else begin - let arity = mis_nf_arity mis in + let arity = mip.mind_nf_arity in let vla = List.rev (vl_of_arity genv arity) in add_inductive_extraction ip (Iml (sign_of_arity genv arity, vla)); @@ -812,16 +815,16 @@ and extract_mib sp = iterate_for 0 (mib.mind_ntypes - 1) (fun i vl -> let ip = (sp,i) in - let mis = build_mis ip mib in - if mis_sort mis = Prop Null then begin - for j = 1 to mis_nconstr mis do + let (mib,mip) = Global.lookup_inductive ip in + if mip.mind_sort = Prop Null then begin + for j = 1 to Array.length mip.mind_consnames do add_constructor_extraction (ip,j) Cprop done; vl end else - iterate_for 1 (mis_nconstr mis) + iterate_for 1 (Array.length mip.mind_consnames) (fun j vl -> - let t = mis_constructor_type j mis in + let t = type_of_constructor genv (ip,j) in let t = snd (decompose_prod_n nb t) in match extract_type_rec_info env t vl [] with | Tarity | Tprop -> assert false @@ -836,7 +839,6 @@ and extract_mib sp = (* Third pass: we update the type variables list in the inductives table *) for i = 0 to mib.mind_ntypes-1 do let ip = (sp,i) in - let mis = build_mis ip mib in match lookup_inductive_extraction ip with | Iprop -> () | Iml (s,l) -> add_inductive_extraction ip (Iml (s,vl@l)); @@ -844,8 +846,7 @@ and extract_mib sp = (* Fourth pass: we update also in the constructors table *) for i = 0 to mib.mind_ntypes-1 do let ip = (sp,i) in - let mis = build_mis ip mib in - for j = 1 to mis_nconstr mis do + for j = 1 to Array.length mib.mind_packets.(i).mind_consnames do let cp = (ip,j) in match lookup_constructor_extraction cp with | Cprop -> () @@ -884,14 +885,14 @@ and extract_inductive_declaration sp = iterate_for (1 - mib.mind_ntypes) 0 (fun i acc -> let ip = (sp,-i) in - let mis = build_mis ip mib in + let nc = Array.length mib.mind_packets.(-i).mind_consnames in match lookup_inductive_extraction ip with | Iprop -> acc | Iml (_,vl) -> - (List.rev vl, IndRef ip, one_ind ip (mis_nconstr mis)) :: acc) + (List.rev vl, IndRef ip, one_ind ip nc) :: acc) [] in - Dtype (l, not (mind_type_finite mib 0)) + Dtype (l, not mib.mind_finite) (*s Extraction of a global reference i.e. a constant or an inductive. *) diff --git a/contrib/extraction/extraction.mli b/contrib/extraction/extraction.mli index e75e39fe6..afc6efd6f 100644 --- a/contrib/extraction/extraction.mli +++ b/contrib/extraction/extraction.mli @@ -14,6 +14,7 @@ open Names open Term open Miniml open Environ +open Nametab (*s Result of an extraction. *) diff --git a/contrib/extraction/haskell.ml b/contrib/extraction/haskell.ml index cb1ac038d..f59a282ca 100644 --- a/contrib/extraction/haskell.ml +++ b/contrib/extraction/haskell.ml @@ -13,11 +13,13 @@ open Pp open Util open Names +open Nameops open Term open Miniml open Mlutil open Options open Ocaml +open Nametab (*s Haskell renaming issues. *) diff --git a/contrib/extraction/haskell.mli b/contrib/extraction/haskell.mli index e1a7f0cd0..beed696d4 100644 --- a/contrib/extraction/haskell.mli +++ b/contrib/extraction/haskell.mli @@ -10,6 +10,7 @@ open Pp open Names +open Nametab open Miniml val keywords : Idset.t diff --git a/contrib/extraction/miniml.mli b/contrib/extraction/miniml.mli index 125bf7865..a022d67d8 100644 --- a/contrib/extraction/miniml.mli +++ b/contrib/extraction/miniml.mli @@ -13,6 +13,7 @@ open Pp open Names open Term +open Nametab (*s ML type expressions. *) diff --git a/contrib/extraction/mlutil.ml b/contrib/extraction/mlutil.ml index 2f3a67b6e..00da8e84b 100644 --- a/contrib/extraction/mlutil.ml +++ b/contrib/extraction/mlutil.ml @@ -14,6 +14,7 @@ open Term open Declarations open Util open Miniml +open Nametab open Table open Options @@ -603,4 +604,3 @@ let rec optimize prm = function | (Dtype _ | Dabbrev _ | Dcustom _) as d :: l -> d :: (optimize prm l) - diff --git a/contrib/extraction/mlutil.mli b/contrib/extraction/mlutil.mli index 3771151b4..327ef5b94 100644 --- a/contrib/extraction/mlutil.mli +++ b/contrib/extraction/mlutil.mli @@ -11,6 +11,7 @@ open Names open Term open Miniml +open Nametab (*s Special identifiers. [prop_name] is to be used for propositions and will be printed as [_] in concrete (Caml) code. *) diff --git a/contrib/extraction/ocaml.ml b/contrib/extraction/ocaml.ml index 4470e00ac..185bbe0a7 100644 --- a/contrib/extraction/ocaml.ml +++ b/contrib/extraction/ocaml.ml @@ -13,11 +13,13 @@ open Pp open Util open Names +open Nameops open Term open Miniml open Table open Mlutil open Options +open Nametab let current_module = ref None diff --git a/contrib/extraction/ocaml.mli b/contrib/extraction/ocaml.mli index b982adcdc..e9faa1a0a 100644 --- a/contrib/extraction/ocaml.mli +++ b/contrib/extraction/ocaml.mli @@ -14,6 +14,7 @@ open Pp open Miniml open Names open Term +open Nametab val current_module : identifier option ref diff --git a/contrib/extraction/table.ml b/contrib/extraction/table.ml index 7953f1182..f1f00d1e3 100644 --- a/contrib/extraction/table.ml +++ b/contrib/extraction/table.ml @@ -18,7 +18,7 @@ open Util open Pp open Term open Declarations - +open Nametab (*s AutoInline parameter *) diff --git a/contrib/extraction/table.mli b/contrib/extraction/table.mli index 2a0a3092b..ff47bcede 100644 --- a/contrib/extraction/table.mli +++ b/contrib/extraction/table.mli @@ -10,6 +10,7 @@ open Vernacinterp open Names +open Nametab (*s AutoInline parameter *) diff --git a/contrib/field/Field_Tactic.v b/contrib/field/Field_Tactic.v index 5bc4e4433..00f0cbe89 100644 --- a/contrib/field/Field_Tactic.v +++ b/contrib/field/Field_Tactic.v @@ -177,8 +177,8 @@ Tactic Definition Multiply mul := [Intro; Let id = GrepMult In Apply (mult_eq ?1 ?3 ?4 mul ?2 id)(*; - Cbv Beta Delta -[interp_ExprA] Zeta Evar Iota*) - |Cbv Beta Delta -[not] Zeta Evar Iota; + Cbv Beta Delta -[interp_ExprA] Zeta Iota*) + |Cbv Beta Delta -[not] Zeta Iota; Let AmultT = Eval Compute in (Amult ?1) And AoneT = Eval Compute in (Aone ?1) In (Match Context With diff --git a/contrib/field/field.ml4 b/contrib/field/field.ml4 index 90e87c9df..5727f1fd7 100644 --- a/contrib/field/field.ml4 +++ b/contrib/field/field.ml4 @@ -23,7 +23,8 @@ let constr_of com = Astterm.interp_constr Evd.empty (Global.env()) com (* Construction of constants *) let constant dir s = - let dir = make_dirpath (List.map id_of_string ("Coq"::"field"::dir)) in + let dir = make_dirpath + (List.map id_of_string (List.rev ("Coq"::"field"::dir))) in let id = id_of_string s in try Declare.global_reference_in_absolute_module dir id diff --git a/contrib/fourier/fourierR.ml b/contrib/fourier/fourierR.ml index 652a96910..b3e141822 100644 --- a/contrib/fourier/fourierR.ml +++ b/contrib/fourier/fourierR.ml @@ -75,18 +75,18 @@ let pf_parse_constr gl s = let rec string_of_constr c = match kind_of_term c with - IsCast (c,t) -> string_of_constr c - |IsConst c -> string_of_path c - |IsVar(c) -> string_of_id c + Cast (c,t) -> string_of_constr c + |Const c -> string_of_path c + |Var(c) -> string_of_id c | _ -> "not_of_constant" ;; let rec rational_of_constr c = match kind_of_term c with - | IsCast (c,t) -> (rational_of_constr c) - | IsApp (c,args) -> + | Cast (c,t) -> (rational_of_constr c) + | App (c,args) -> (match kind_of_term c with - IsConst c -> + Const c -> (match (string_of_path c) with "Coq.Reals.Rdefinitions.Ropp" -> rop (rational_of_constr args.(0)) @@ -106,7 +106,7 @@ let rec rational_of_constr c = (rational_of_constr args.(1)) | _ -> failwith "not a rational") | _ -> failwith "not a rational") - | IsConst c -> + | Const c -> (match (string_of_path c) with "Coq.Reals.Rdefinitions.R1" -> r1 |"Coq.Reals.Rdefinitions.R0" -> r0 @@ -117,10 +117,10 @@ let rec rational_of_constr c = let rec flin_of_constr c = try( match kind_of_term c with - | IsCast (c,t) -> (flin_of_constr c) - | IsApp (c,args) -> + | Cast (c,t) -> (flin_of_constr c) + | App (c,args) -> (match kind_of_term c with - IsConst c -> + Const c -> (match (string_of_path c) with "Coq.Reals.Rdefinitions.Ropp" -> flin_emult (rop r1) (flin_of_constr args.(0)) @@ -152,7 +152,7 @@ let rec flin_of_constr c = (rinv b))) |_->assert false) |_ -> assert false) - | IsConst c -> + | Const c -> (match (string_of_path c) with "Coq.Reals.Rdefinitions.R1" -> flin_one () |"Coq.Reals.Rdefinitions.R0" -> flin_zero () @@ -183,11 +183,11 @@ type hineq={hname:constr; (* le nom de l'hypothčse *) *) let ineq1_of_constr (h,t) = match (kind_of_term t) with - IsApp (f,args) -> + App (f,args) -> let t1= args.(0) in let t2= args.(1) in (match kind_of_term f with - IsConst c -> + Const c -> (match (string_of_path c) with "Coq.Reals.Rdefinitions.Rlt" -> [{hname=h; htype="Rlt"; @@ -218,13 +218,13 @@ let ineq1_of_constr (h,t) = (flin_of_constr t1); hstrict=false}] |_->assert false) - | IsMutInd (sp,i) -> + | Ind (sp,i) -> (match (string_of_path sp) with "Coq.Init.Logic_Type.eqT" -> let t0= args.(0) in let t1= args.(1) in let t2= args.(2) in (match (kind_of_term t0) with - IsConst c -> + Const c -> (match (string_of_path c) with "Coq.Reals.Rdefinitions.R"-> [{hname=h; @@ -370,7 +370,7 @@ let tac_use h = match h.htype with let is_ineq (h,t) = match (kind_of_term t) with - IsApp (f,args) -> + App (f,args) -> (match (string_of_constr f) with "Coq.Reals.Rdefinitions.Rlt" -> true |"Coq.Reals.Rdefinitions.Rgt" -> true @@ -399,7 +399,7 @@ let rec fourier gl= et le but ŕ prouver devient False *) try (let tac = match (kind_of_term goal) with - IsApp (f,args) -> + App (f,args) -> (match (string_of_constr f) with "Coq.Reals.Rdefinitions.Rlt" -> (tclTHEN diff --git a/contrib/interface/ascent.mli b/contrib/interface/ascent.mli index 3dff01937..3b9d742e2 100644 --- a/contrib/interface/ascent.mli +++ b/contrib/interface/ascent.mli @@ -8,7 +8,7 @@ and ct_AST = CT_coerce_ID_OR_INT_to_AST of ct_ID_OR_INT | CT_coerce_ID_OR_STRING_to_AST of ct_ID_OR_STRING | CT_astnode of ct_ID * ct_AST_LIST - | CT_astpath of ct_ID_LIST * ct_ID + | CT_astpath of ct_ID_LIST | CT_astslam of ct_ID_OPT * ct_AST and ct_AST_LIST = CT_ast_list of ct_AST list diff --git a/contrib/interface/centaur.ml b/contrib/interface/centaur.ml index 2f864b13e..bba7396b0 100644 --- a/contrib/interface/centaur.ml +++ b/contrib/interface/centaur.ml @@ -1,6 +1,7 @@ (*Toplevel loop for the communication between Coq and Centaur *) open Names;; +open Nameops open Util;; open Ast;; open Term;; @@ -243,8 +244,10 @@ let filter_by_module_from_varg_list (l:vernac_arg list) = let add_search (global_reference:global_reference) assumptions cstr = try - let id_string = string_of_qualid (Global.qualid_of_global global_reference) in - let ast = + let env = Global.env() in + let id_string = + string_of_qualid (Nametab.qualid_of_global env global_reference) in + let ast = try CT_premise (CT_ident id_string, translate_constr assumptions cstr) with Not_found -> @@ -303,11 +306,13 @@ and ntyp = nf_betaiota typ in (* The following function is copied from globpr in env/printer.ml *) let globcv = function | Node(_,"MUTIND", (Path(_,sp))::(Num(_,tyi))::_) -> - convert_qualid - (Global.qualid_of_global (IndRef(sp,tyi))) + let env = Global.env() in + convert_qualid + (Nametab.qualid_of_global env (IndRef(sp,tyi))) | Node(_,"MUTCONSTRUCT",(Path(_,sp))::(Num(_,tyi))::(Num(_,i))::_) -> - convert_qualid - (Global.qualid_of_global (ConstructRef ((sp, tyi), i))) + let env = Global.env() in + convert_qualid + (Nametab.qualid_of_global env (ConstructRef ((sp, tyi), i))) | _ -> failwith "globcv : unexpected value";; let pbp_tac_pcoq = @@ -389,7 +394,7 @@ let inspect n = sp, Lib.Leaf lobj -> (match sp, object_tag lobj with _, "VARIABLE" -> - let ((_, _, v), _) = get_variable sp in + let ((_, _, v), _) = get_variable (basename sp) in add_search2 (Nametab.locate (qualid_of_sp sp)) v | sp, ("CONSTANT"|"PARAMETER") -> let {const_type=typ} = Global.lookup_constant sp in diff --git a/contrib/interface/ctast.ml b/contrib/interface/ctast.ml index 5b97716fc..b356f5b28 100644 --- a/contrib/interface/ctast.ml +++ b/contrib/interface/ctast.ml @@ -11,15 +11,15 @@ type t = | Num of loc * int | Id of loc * string | Str of loc * string - | Path of loc * string list* string + | Path of loc * string list | Dynamic of loc * Dyn.t -let section_path sl k = +let section_path sl = match List.rev sl with | s::pa -> make_path (make_dirpath (List.rev (List.map id_of_string pa))) - (id_of_string s) (kind_of_string k) + (id_of_string s) | [] -> invalid_arg "section_path" let is_meta s = String.length s > 0 && s.[0] == '$' @@ -40,7 +40,7 @@ let rec ct_to_ast = function | Num (loc,a) -> Coqast.Num (loc,a) | Id (loc,a) -> Coqast.Id (loc,a) | Str (loc,a) -> Coqast.Str (loc,a) - | Path (loc,sl,k) -> Coqast.Path (loc,section_path sl k) + | Path (loc,sl) -> Coqast.Path (loc,section_path sl) | Dynamic (loc,a) -> Coqast.Dynamic (loc,a) let rec ast_to_ct = function @@ -55,8 +55,9 @@ let rec ast_to_ct = function | Coqast.Id (loc,a) -> Id (loc,a) | Coqast.Str (loc,a) -> Str (loc,a) | Coqast.Path (loc,a) -> - let (sl,bn,pk) = repr_path a in - Path(loc, (List.map string_of_id (repr_dirpath sl)) @ [string_of_id bn],(* Bidon *) "CCI") + let (sl,bn) = repr_path a in + Path(loc, (List.map string_of_id + (List.rev (repr_dirpath sl))) @ [string_of_id bn]) | Coqast.Dynamic (loc,a) -> Dynamic (loc,a) let loc = function @@ -66,7 +67,7 @@ let loc = function | Num (loc,_) -> loc | Id (loc,_) -> loc | Str (loc,_) -> loc - | Path (loc,_,_) -> loc + | Path (loc,_) -> loc | Dynamic (loc,_) -> loc let str s = Str(Ast.dummy_loc,s) diff --git a/contrib/interface/dad.ml b/contrib/interface/dad.ml index f84fe33ef..7f2ea95a4 100644 --- a/contrib/interface/dad.ml +++ b/contrib/interface/dad.ml @@ -15,6 +15,7 @@ open Ctast;; open Termast;; open Astterm;; open Vernacinterp;; +open Nametab open Proof_type;; open Proof_trees;; @@ -51,7 +52,7 @@ let zz = (0,0);; let rec get_subterm (depth:int) (path: int list) (constr:constr) = match depth, path, kind_of_term constr with 0, l, c -> (constr,l) - | n, 2::a::tl, IsApp(func,arr) -> + | n, 2::a::tl, App(func,arr) -> get_subterm (n - 2) tl arr.(a-1) | _,l,_ -> failwith (int_list_to_string "wrong path or wrong form of term" diff --git a/contrib/interface/name_to_ast.ml b/contrib/interface/name_to_ast.ml index e4523121c..8d3fd79c0 100644 --- a/contrib/interface/name_to_ast.ml +++ b/contrib/interface/name_to_ast.ml @@ -1,6 +1,7 @@ open Sign;; open Classops;; open Names;; +open Nameops open Coqast;; open Ast;; open Termast;; @@ -15,6 +16,7 @@ open Inductive;; open Util;; open Pp;; open Declare;; +open Nametab (* This function converts the parameter binders of an inductive definition, @@ -86,8 +88,8 @@ let convert_qualid qid = let d, id = Nametab.repr_qualid qid in match repr_dirpath d with [] -> nvar id - | d -> ope("QUALID", List.fold_right (fun s l -> (nvar s)::l) d - [nvar id]);; + | d -> ope("QUALID", List.fold_left (fun l s -> (nvar s)::l) + [nvar id] d);; (* This function converts constructors for an inductive definition to a Coqast.t. It is obtained directly from print_constructors in pretty.ml *) @@ -106,9 +108,9 @@ let convert_constructors envpar names types = let convert_one_inductive sp tyi = let (ref, params, arity, cstrnames, cstrtypes) = build_inductive sp tyi in let env = Global.env () in - let envpar = push_rels params env in + let envpar = push_rel_context params env in ope("VERNACARGLIST", - [convert_qualid (Global.qualid_of_global(IndRef (sp, tyi))); + [convert_qualid (Nametab.qualid_of_global env (IndRef (sp, tyi))); ope("CONSTR", [ast_of_constr true envpar arity]); ope("BINDERLIST", convert_env(List.rev params)); convert_constructors envpar cstrnames cstrtypes]);; @@ -123,7 +125,7 @@ let mutual_to_ast_list sp mib = Array.fold_right (fun mi (n,l) -> (n+1, (convert_one_inductive sp n)::l)) mipv (0, []) in (ope("MUTUALINDUCTIVE", - [str (if (mipv.(0)).mind_finite then "Inductive" else "CoInductive"); + [str (if mib.mind_finite then "Inductive" else "CoInductive"); ope("VERNACARGLIST", ast_list)]):: (implicit_args_to_ast_list sp mipv));; @@ -157,17 +159,14 @@ let make_definition_ast name c typ implicits = (* This function is inspired by print_constant *) let constant_to_ast_list sp = let cb = Global.lookup_constant sp in - if kind_of_path sp = CCI then - let c = cb.const_body in - let typ = cb.const_type in - let l = constant_implicits_list sp in - (match c with - None -> - make_variable_ast (basename sp) typ l - | Some c1 -> - make_definition_ast (basename sp) c1 typ l) - else - errorlabstrm "print" [< 'sTR "printing of FW terms not implemented" >];; + let c = cb.const_body in + let typ = cb.const_type in + let l = constant_implicits_list sp in + (match c with + None -> + make_variable_ast (basename sp) typ l + | Some c1 -> + make_definition_ast (basename sp) c1 typ l) let variable_to_ast_list sp = let ((id, c, v), _) = get_variable sp in @@ -182,18 +181,14 @@ let variable_to_ast_list sp = let inductive_to_ast_list sp = let mib = Global.lookup_mind sp in - if kind_of_path sp = CCI then - mutual_to_ast_list sp mib - else - errorlabstrm "print" - [< 'sTR "printing of FW not implemented" >];; + mutual_to_ast_list sp mib (* this function is inspired by print_leaf_entry from pretty.ml *) let leaf_entry_to_ast_list (sp,lobj) = let tag = object_tag lobj in match (sp,tag) with - | (_, "VARIABLE") -> variable_to_ast_list sp + | (_, "VARIABLE") -> variable_to_ast_list (basename sp) | (_, ("CONSTANT"|"PARAMETER")) -> constant_to_ast_list sp | (_, "INDUCTIVE") -> inductive_to_ast_list sp | (_, s) -> @@ -228,8 +223,8 @@ let name_to_ast (qid:Nametab.qualid) = with Not_found -> try (* Var locale de but, pas var de section... donc pas d'implicits *) let dir,name = Nametab.repr_qualid qid in - if dir <> make_dirpath [] then raise Not_found; - let (c,typ) = Global.lookup_named name in + if (repr_dirpath dir) <> [] then raise Not_found; + let (_,c,typ) = Global.lookup_named name in (match c with None -> make_variable_ast name typ [] | Some c1 -> make_definition_ast name c1 typ []) diff --git a/contrib/interface/parse.ml b/contrib/interface/parse.ml index 42daf3c19..6b2e38873 100644 --- a/contrib/interface/parse.ml +++ b/contrib/interface/parse.ml @@ -292,14 +292,9 @@ let parse_file_action reqid file_name = (* This function is taken from Mltop.add_path *) let add_path dir coq_dirpath = -(* - if coq_dirpath = Names.make_dirpath [] then - anomaly "add_path: empty path in library"; -*) if exists_dir dir then begin - Library.add_load_path_entry (dir,coq_dirpath); - Nametab.push_library_root coq_dirpath + Library.add_load_path_entry (dir,coq_dirpath) end else wARNING [< 'sTR ("Cannot open " ^ dir) >] @@ -309,18 +304,15 @@ let convert_string d = with _ -> failwith "caught" let add_rec_path dir coq_dirpath = -(* - if coq_dirpath = Names.make_dirpath [] then anomaly "add_path: empty path in library"; -*) let dirs = all_subdirs dir in let prefix = Names.repr_dirpath coq_dirpath in if dirs <> [] then let convert_dirs (lp,cp) = - (lp,Names.make_dirpath (prefix@(List.map convert_string cp))) in + (lp, + Names.make_dirpath ((List.map convert_string (List.rev cp))@prefix)) in let dirs = map_succeed convert_dirs dirs in begin - List.iter Library.add_load_path_entry dirs; - Nametab.push_library_root coq_dirpath + List.iter Library.add_load_path_entry dirs end else wARNING [< 'sTR ("Cannot open " ^ dir) >];; @@ -380,9 +372,9 @@ Libobject.relax true; else (mSGNL [< 'sTR "could not find the value of COQDIR" >]; exit 1) in begin - add_rec_path (Filename.concat coqdir "theories") (Names.make_dirpath [Nametab.coq_root]); - add_path (Filename.concat coqdir "tactics") (Names.make_dirpath [Nametab.coq_root]); - add_rec_path (Filename.concat coqdir "contrib") (Names.make_dirpath [Nametab.coq_root]); + add_rec_path (Filename.concat coqdir "theories") (Names.make_dirpath [Nameops.coq_root]); + add_path (Filename.concat coqdir "tactics") (Names.make_dirpath [Nameops.coq_root]); + add_rec_path (Filename.concat coqdir "contrib") (Names.make_dirpath [Nameops.coq_root]); List.iter (fun a -> mSGNL [< 'sTR a >]) (get_load_path()) end; (try diff --git a/contrib/interface/pbp.ml b/contrib/interface/pbp.ml index 4ece713f5..13e307a47 100644 --- a/contrib/interface/pbp.ml +++ b/contrib/interface/pbp.ml @@ -75,7 +75,7 @@ let make_final_cmd f optname clear_names constr path = add_clear_names_if_necessary (f optname constr path) clear_names;; let (rem_cast:pbp_rule) = function - (a,c,cf,o, IsCast(f,_), p, func) -> + (a,c,cf,o, Cast(f,_), p, func) -> Some(func a c cf o (kind_of_term f) p) | _ -> None;; @@ -84,7 +84,7 @@ let (forall_intro: pbp_rule) = function clear_names, clear_flag, None, - IsProd(Name x, _, body), + Prod(Name x, _, body), (2::path), f) -> let x' = next_global_ident_away x avoid in @@ -95,7 +95,7 @@ let (forall_intro: pbp_rule) = function let (imply_intro2: pbp_rule) = function avoid, clear_names, - clear_flag, None, IsProd(Anonymous, _, body), 2::path, f -> + clear_flag, None, Prod(Anonymous, _, body), 2::path, f -> let h' = next_global_ident_away (id_of_string "H") avoid in Some(Node(zz, "TACTICLIST", [make_named_intro (string_of_id h'); @@ -105,7 +105,7 @@ let (imply_intro2: pbp_rule) = function let (imply_intro1: pbp_rule) = function avoid, clear_names, - clear_flag, None, IsProd(Anonymous, prem, body), 1::path, f -> + clear_flag, None, Prod(Anonymous, prem, body), 1::path, f -> let h' = next_global_ident_away (id_of_string "H") avoid in let str_h' = (string_of_id h') in Some(Node(zz, "TACTICLIST", @@ -117,7 +117,7 @@ let (imply_intro1: pbp_rule) = function let (forall_elim: pbp_rule) = function avoid, clear_names, clear_flag, - Some h, IsProd(Name x, _, body), 2::path, f -> + Some h, Prod(Name x, _, body), 2::path, f -> let h' = next_global_ident_away (id_of_string "H") avoid in let clear_names' = if clear_flag then h::clear_names else clear_names in let str_h' = (string_of_id h') in @@ -135,7 +135,7 @@ let (forall_elim: pbp_rule) = function let (imply_elim1: pbp_rule) = function avoid, clear_names, clear_flag, - Some h, IsProd(Anonymous, prem, body), 1::path, f -> + Some h, Prod(Anonymous, prem, body), 1::path, f -> let clear_names' = if clear_flag then h::clear_names else clear_names in let h' = next_global_ident_away (id_of_string "H") avoid in let str_h' = (string_of_id h') in @@ -156,7 +156,7 @@ let (imply_elim1: pbp_rule) = function let (imply_elim2: pbp_rule) = function avoid, clear_names, clear_flag, - Some h, IsProd(Anonymous, prem, body), 2::path, f -> + Some h, Prod(Anonymous, prem, body), 2::path, f -> let clear_names' = if clear_flag then h::clear_names else clear_names in let h' = next_global_ident_away (id_of_string "H") avoid in let str_h' = (string_of_id h') in @@ -176,7 +176,8 @@ let (imply_elim2: pbp_rule) = function | _ -> None;; let reference dir s = - let dir = make_dirpath (List.map id_of_string ("Coq"::"Init"::[dir])) in + let dir = make_dirpath + (List.map id_of_string (List.rev ("Coq"::"Init"::[dir]))) in let id = id_of_string s in try Nametab.locate_in_absolute_module dir id @@ -204,7 +205,7 @@ let is_matching_local a b = is_matching (pattern_of_constr a) b;; let (and_intro: pbp_rule) = function avoid, clear_names, clear_flag, - None, IsApp(and_oper, [|c1; c2|]), 2::a::path, f + None, App(and_oper, [|c1; c2|]), 2::a::path, f -> if ((is_matching_local (andconstr()) and_oper) or (is_matching_local (prodconstr ()) and_oper)) & (a = 1 or a = 2) then @@ -229,12 +230,12 @@ let (and_intro: pbp_rule) = function let (ex_intro: pbp_rule) = function avoid, clear_names, clear_flag, None, - IsApp(oper, [| c1; c2|]), 2::2::2::path, f + App(oper, [| c1; c2|]), 2::2::2::path, f when (is_matching_local (exconstr ()) oper) or (is_matching_local (exTconstr ()) oper) or (is_matching_local (sigconstr ()) oper) or (is_matching_local (sigTconstr ()) oper) -> (match kind_of_term c2 with - IsLambda(Name x, _, body) -> + Lambda(Name x, _, body) -> Some(Node(zz, "Split", [Node(zz, "BINDINGS", [Node(zz, "BINDING", @@ -250,7 +251,7 @@ let (ex_intro: pbp_rule) = function let (or_intro: pbp_rule) = function avoid, clear_names, clear_flag, None, - IsApp(or_oper, [|c1; c2 |]), 2::a::path, f -> + App(or_oper, [|c1; c2 |]), 2::a::path, f -> if ((is_matching_local (orconstr ()) or_oper) or (is_matching_local (sumboolconstr ()) or_oper) or (is_matching_local (sumconstr ()) or_oper)) @@ -270,7 +271,7 @@ let dummy_id = id_of_string "Dummy";; let (not_intro: pbp_rule) = function avoid, clear_names, clear_flag, None, - IsApp(not_oper, [|c1|]), 2::1::path, f -> + App(not_oper, [|c1|]), 2::1::path, f -> if(is_matching_local (notconstr ()) not_oper) or (is_matching_local (notTconstr ()) not_oper) then let h' = next_global_ident_away (id_of_string "H") avoid in @@ -336,11 +337,11 @@ let rec down_prods: (types, constr) kind_of_term * (int list) * int -> string list * (int list) * int * (types, constr) kind_of_term * (int list) = function - IsProd(Name x, _, body), 2::path, k -> + Prod(Name x, _, body), 2::path, k -> let res_sl, res_il, res_i, res_cstr, res_p = down_prods (kind_of_term body, path, k+1) in (string_of_id x)::res_sl, (k::res_il), res_i, res_cstr, res_p - | IsProd(Anonymous, _, body), 2::path, k -> + | Prod(Anonymous, _, body), 2::path, k -> let res_sl, res_il, res_i, res_cstr, res_p = down_prods (kind_of_term body, path, k+1) in res_sl, res_il, res_i+1, res_cstr, res_p @@ -361,14 +362,14 @@ let (check_apply: (types, constr) kind_of_term -> (int list) -> bool) = | [] -> [] | p::tl -> if n = p then tl else p::(delete n tl) in let rec check_rec l = function - | IsApp(f, array) -> + | App(f, array) -> Array.fold_left (fun l c -> check_rec l (kind_of_term c)) (check_rec l (kind_of_term f)) array - | IsConst _ -> l - | IsMutInd _ -> l - | IsMutConstruct _ -> l - | IsVar _ -> l - | IsRel p -> + | Const _ -> l + | Ind _ -> l + | Construct _ -> l + | Var _ -> l + | Rel p -> let result = delete p l in if result = [] then raise (Pbp_internal []) @@ -399,7 +400,7 @@ let (head_tactic_patt: pbp_rule) = function avoid, clear_names, clear_flag, Some h, cstr, path, f -> (match down_prods (cstr, path, 0) with | (str_list, _, nprems, - IsApp(oper,[|c1|]), 2::1::path) + App(oper,[|c1|]), 2::1::path) when (is_matching_local (notconstr ()) oper) or (is_matching_local (notTconstr ()) oper) -> @@ -407,7 +408,7 @@ let (head_tactic_patt: pbp_rule) = function [elim_with_bindings h str_list; f avoid clear_names false None (kind_of_term c1) path])) | (str_list, _, nprems, - IsApp(oper, [|c1; c2|]), 2::a::path) + App(oper, [|c1; c2|]), 2::a::path) when ((is_matching_local (andconstr()) oper) or (is_matching_local (prodconstr()) oper)) & (a = 1 or a = 2) -> let h1 = next_global_ident_away (id_of_string "H") avoid in @@ -431,18 +432,18 @@ let (head_tactic_patt: pbp_rule) = function cont_tac::(auxiliary_goals clear_names clear_flag h nprems))])) - | (str_list, _, nprems, IsApp(oper,[|c1; c2|]), 2::a::path) + | (str_list, _, nprems, App(oper,[|c1; c2|]), 2::a::path) when ((is_matching_local (exconstr ()) oper) or (is_matching_local (exTconstr ()) oper) or (is_matching_local (sigconstr ()) oper) or (is_matching_local (sigTconstr()) oper)) & a = 2 -> (match (kind_of_term c2),path with - IsLambda(Name x, _,body), (2::path) -> + Lambda(Name x, _,body), (2::path) -> Some(Node(zz,"TACTICLIST", [elim_with_bindings h str_list; let x' = next_global_ident_away x avoid in let cont_body = - IsProd(Name x', c1, + Prod(Name x', c1, mkProd(Anonymous, body, mkVar(dummy_id))) in let cont_tac @@ -456,7 +457,7 @@ let (head_tactic_patt: pbp_rule) = function clear_names clear_flag h nprems))])) | _ -> None) - | (str_list, _, nprems, IsApp(oper,[|c1; c2|]), 2::a::path) + | (str_list, _, nprems, App(oper,[|c1; c2|]), 2::a::path) when ((is_matching_local (orconstr ()) oper) or (is_matching_local (sumboolconstr ()) oper) or (is_matching_local (sumconstr ()) oper)) & @@ -491,7 +492,7 @@ let (head_tactic_patt: pbp_rule) = function false "dummy" nprems))])) | (str_list, int_list, nprems, c, []) when (check_apply c (mk_db_indices int_list nprems)) & - (match c with IsProd(_,_,_) -> false + (match c with Prod(_,_,_) -> false | _ -> true) & (List.length int_list) + nprems > 0 -> Some(add_clear_names_if_necessary diff --git a/contrib/interface/showproof.ml b/contrib/interface/showproof.ml index 50aebb917..e4d4647f1 100644 --- a/contrib/interface/showproof.ml +++ b/contrib/interface/showproof.ml @@ -5,19 +5,22 @@ open Coqast;; open Environ open Evd open Names +open Nameops open Stamps open Term +open Termops open Util open Proof_type open Coqast open Pfedit open Translate open Term -open Reduction +open Reductionops open Clenv open Astterm open Typing open Inductive +open Inductiveops open Vernacinterp open Declarations open Showproof_ct @@ -205,7 +208,7 @@ let fill_unproved nt l = let new_sign osign sign = let res=ref [] in List.iter (fun (id,c,ty) -> - try (let ty1= (lookup_id_type id osign) in + try (let (_,_,ty1)= (lookup_named id osign) in ()) with Not_found -> res:=(id,c,ty)::(!res)) sign; @@ -215,7 +218,7 @@ let new_sign osign sign = let old_sign osign sign = let res=ref [] in List.iter (fun (id,c,ty) -> - try (let ty1= (lookup_id_type id osign) in + try (let (_,_,ty1) = (lookup_named id osign) in if ty1 = ty then res:=(id,c,ty)::(!res)) with Not_found -> ()) sign; @@ -711,7 +714,7 @@ let sort_of_type t ts = match ts with Prop(Null) -> Nformula |_ -> (match (kind_of_term t) with - IsProd(_,_,_) -> Nfunction + Prod(_,_,_) -> Nfunction |_ -> Ntype) ;; @@ -722,22 +725,22 @@ let adrel (x,t) e = let rec nsortrec vl x = match (kind_of_term x) with - IsProd(n,t,c)-> + Prod(n,t,c)-> let vl = (adrel (n,t) vl) in nsortrec vl c - | IsLambda(n,t,c) -> + | Lambda(n,t,c) -> let vl = (adrel (n,t) vl) in nsortrec vl c - | IsApp(f,args) -> nsortrec vl f - | IsSort(Prop(Null)) -> Prop(Null) - | IsSort(c) -> c - | IsMutInd(ind) -> - let dmi = lookup_mind_specif ind vl in - (mis_sort dmi) - | IsMutConstruct(c) -> - nsortrec vl (mkMutInd (inductive_of_constructor c)) - | IsMutCase(_,x,t,a) + | App(f,args) -> nsortrec vl f + | Sort(Prop(Null)) -> Prop(Null) + | Sort(c) -> c + | Ind(ind) -> + let (mib,mip) = lookup_mind_specif vl ind in + mip.mind_sort + | Construct(c) -> + nsortrec vl (mkInd (inductive_of_constructor c)) + | Case(_,x,t,a) -> nsortrec vl x - | IsCast(x,t)-> nsortrec vl t - | IsConst c -> nsortrec vl (lookup_constant c vl).const_type + | Cast(x,t)-> nsortrec vl t + | Const c -> nsortrec vl (lookup_constant c vl).const_type | _ -> nsortrec vl (type_of vl Evd.empty x) ;; let nsort x = @@ -1056,7 +1059,7 @@ let first_name_hyp_of_ntree {t_goal={newhyp=lh}}= let rec find_type x t= match (kind_of_term (strip_outer_cast t)) with - IsProd(y,ty,t) -> + Prod(y,ty,t) -> (match y with Name y -> if x=(string_of_id y) then ty @@ -1071,9 +1074,9 @@ Traitement des égalités (* let is_equality e = match (kind_of_term e) with - IsAppL args -> + AppL args -> (match (kind_of_term args.(0)) with - IsConst (c,_) -> + Const (c,_) -> (match (string_of_sp c) with "Equal" -> true | "eq" -> true @@ -1088,14 +1091,14 @@ let is_equality e = let is_equality e = let e= (strip_outer_cast e) in match (kind_of_term e) with - IsApp (f,args) -> (Array.length args) >= 3 + App (f,args) -> (Array.length args) >= 3 | _ -> false ;; let terms_of_equality e = let e= (strip_outer_cast e) in match (kind_of_term e) with - IsApp (f,args) -> (args.(1) , args.(2)) + App (f,args) -> (args.(1) , args.(2)) | _ -> assert false ;; @@ -1404,22 +1407,24 @@ and whd_betadeltaiota x = whd_betaiotaevar (Global.env()) Evd.empty x and type_of_ast s c = type_of (Global.env()) Evd.empty (constr_of_ast c) and prod_head t = match (kind_of_term (strip_outer_cast t)) with - IsProd(_,_,c) -> prod_head c -(* |IsApp(f,a) -> f *) + Prod(_,_,c) -> prod_head c +(* |App(f,a) -> f *) | _ -> t and string_of_sp sp = string_of_id (basename sp) -and constr_of_mind dmi i = (string_of_id (mis_consnames dmi).(i-1)) -and arity_of_constr_of_mind indf i = - (get_constructors indf).(i-1).cs_nargs +and constr_of_mind mip i = + (string_of_id mip.mind_consnames.(i-1)) +and arity_of_constr_of_mind env indf i = + (get_constructors env indf).(i-1).cs_nargs and gLOB ge = Global.env_of_context ge (* (Global.env()) *) and natural_case ig lh g gs ge arg1 ltree with_intros = let env= (gLOB ge) in let targ1 = prod_head (type_of env Evd.empty arg1) in let IndType (indf,targ) = find_rectype env Evd.empty targ1 in - let ncti= Array.length(get_constructors indf) in - let IndFamily(dmi,_) = indf in - let ti =(string_of_id (mis_typename dmi)) in + let ncti= Array.length(get_constructors env indf) in + let (ind,_) = indf in + let (mib,mip) = lookup_mind_specif env ind in + let ti =(string_of_id mip.mind_typename) in let type_arg= targ1 (* List.nth targ (mis_index dmi)*) in if ncti<>1 (* Zéro ou Plusieurs constructeurs *) @@ -1436,9 +1441,9 @@ and natural_case ig lh g gs ge arg1 ltree with_intros = (let ci=ref 0 in (prli (fun treearg -> ci:=!ci+1; - let nci=(constr_of_mind dmi !ci) in + let nci=(constr_of_mind mip !ci) in let aci=if with_intros - then (arity_of_constr_of_mind indf !ci) + then (arity_of_constr_of_mind env indf !ci) else 0 in let ici= (!ci) in sph[ (natural_ntree @@ -1464,10 +1469,10 @@ and natural_case ig lh g gs ge arg1 ltree with_intros = (show_goal2 lh ig g gs ""); de_A_on_a arg1; (let treearg=List.hd ltree in - let nci=(constr_of_mind dmi 1) in + let nci=(constr_of_mind mip 1) in let aci= if with_intros - then (arity_of_constr_of_mind indf 1) + then (arity_of_constr_of_mind env indf 1) else 0 in let ici= 1 in sph[ (natural_ntree @@ -1493,21 +1498,25 @@ and natural_case ig lh g gs ge arg1 ltree with_intros = *) and prod_list_var t = match (kind_of_term (strip_outer_cast t)) with - IsProd(_,t,c) -> t::(prod_list_var c) + Prod(_,t,c) -> t::(prod_list_var c) |_ -> [] and hd_is_mind t ti = - try (let IndType (indf,targ) = find_rectype (Global.env()) Evd.empty t in - let ncti= Array.length(get_constructors indf) in - let IndFamily(dmi,_) = indf in - (string_of_id (mis_typename dmi)) = ti) + try (let env = Global.env() in + let IndType (indf,targ) = find_rectype env Evd.empty t in + let ncti= Array.length(get_constructors env indf) in + let (ind,_) = indf in + let (mib,mip) = lookup_mind_specif env ind in + (string_of_id mip.mind_typename) = ti) with _ -> false and mind_ind_info_hyp_constr indf c = - let IndFamily(dmi,_) = indf in - let p= mis_nparams dmi in - let a=arity_of_constr_of_mind indf c in - let lp=ref (get_constructors indf).(c).cs_args in + let env = Global.env() in + let (ind,_) = indf in + let (mib,mip) = lookup_mind_specif env ind in + let p = mip.mind_nparams in + let a = arity_of_constr_of_mind env indf c in + let lp=ref (get_constructors env indf).(c).cs_args in let lr=ref [] in - let ti = (string_of_id (mis_typename dmi)) in + let ti = (string_of_id mip.mind_typename) in for i=1 to a do match !lp with ((_,_,t)::lp1)-> @@ -1530,9 +1539,10 @@ and natural_elim ig lh g gs ge arg1 ltree with_intros= let env= (gLOB ge) in let targ1 = prod_head (type_of env Evd.empty arg1) in let IndType (indf,targ) = find_rectype env Evd.empty targ1 in - let ncti= Array.length(get_constructors indf) in - let IndFamily(dmi,_) = indf in - let ti =(string_of_id (mis_typename dmi)) in + let ncti= Array.length(get_constructors env indf) in + let (ind,_) = indf in + let (mib,mip) = lookup_mind_specif env ind in + let ti =(string_of_id mip.mind_typename) in let type_arg=targ1 (* List.nth targ (mis_index dmi) *) in spv [ (natural_lhyp lh ig.ihsg); @@ -1543,8 +1553,8 @@ and natural_elim ig lh g gs ge arg1 ltree with_intros= (let ci=ref 0 in (prli (fun treearg -> ci:=!ci+1; - let nci=(constr_of_mind dmi !ci) in - let aci=(arity_of_constr_of_mind indf !ci) in + let nci=(constr_of_mind mip !ci) in + let aci=(arity_of_constr_of_mind env indf !ci) in let hci= if with_intros then mind_ind_info_hyp_constr indf !ci @@ -1575,13 +1585,14 @@ and natural_induction ig lh g gs ge arg1 ltree with_intros= let env = (gLOB (g_env (List.hd ltree))) in let arg1=dbize env arg1 in let arg2 = match (kind_of_term arg1) with - IsVar(arg2) -> arg2 + Var(arg2) -> arg2 | _ -> assert false in let targ1 = prod_head (type_of env Evd.empty arg1) in let IndType (indf,targ) = find_rectype env Evd.empty targ1 in - let ncti= Array.length(get_constructors indf) in - let IndFamily(dmi,_) = indf in - let ti =(string_of_id (mis_typename dmi)) in + let ncti= Array.length(get_constructors env indf) in + let (ind,_) = indf in + let (mib,mip) = lookup_mind_specif env ind in + let ti =(string_of_id mip.mind_typename) in let type_arg= targ1(*List.nth targ (mis_index dmi)*) in let lh1= hyps (List.hd ltree) in (* la liste des hyp jusqu'a n *) @@ -1604,8 +1615,8 @@ and natural_induction ig lh g gs ge arg1 ltree with_intros= (let ci=ref 0 in (prli (fun treearg -> ci:=!ci+1; - let nci=(constr_of_mind dmi !ci) in - let aci=(arity_of_constr_of_mind indf !ci) in + let nci=(constr_of_mind mip !ci) in + let aci=(arity_of_constr_of_mind env indf !ci) in let hci= if with_intros then mind_ind_info_hyp_constr indf !ci diff --git a/contrib/interface/vtp.ml b/contrib/interface/vtp.ml index e35b9d3bc..778220322 100644 --- a/contrib/interface/vtp.ml +++ b/contrib/interface/vtp.ml @@ -26,10 +26,9 @@ and fAST = function fID x1; fAST_LIST x2; fNODE "astnode" 2 -| CT_astpath(x1, x2) -> +| CT_astpath(x1) -> fID_LIST x1; - fID x2; - fNODE "astpath" 2 + fNODE "astpath" 1 | CT_astslam(x1, x2) -> fID_OPT x1; fAST x2; diff --git a/contrib/interface/xlate.ml b/contrib/interface/xlate.ml index ccaa08f50..c7552847f 100644 --- a/contrib/interface/xlate.ml +++ b/contrib/interface/xlate.ml @@ -381,18 +381,18 @@ let xlate_op the_node opn a b = *) "CONST" -> (match a, b with - | ((Path (_, sl, kind)) :: []), [] -> + | ((Path (_, sl)) :: []), [] -> CT_coerce_ID_to_FORMULA(CT_ident - (Names.string_of_id (Names.basename (section_path sl kind)))) - | ((Path (_, sl, kind)) :: []), tl -> + (Names.string_of_id (Nameops.basename (section_path sl)))) + | ((Path (_, sl)) :: []), tl -> CT_coerce_ID_to_FORMULA(CT_ident - (Names.string_of_id(Names.basename (section_path sl kind)))) + (Names.string_of_id(Nameops.basename (section_path sl)))) | _, _ -> xlate_error "xlate_op : CONST") | (** string_of_path needs to be investigated. *) "MUTIND" -> (match a, b with - | [Path(_, sl, kind); Num(_, tyi)], [] -> + | [Path(_, sl); Num(_, tyi)], [] -> if !in_coq_ref then match special_case_qualid () (!xlate_mut_stuff (Node((0,0),"MUTIND", a))) with @@ -401,8 +401,7 @@ let xlate_op the_node opn a b = else CT_coerce_ID_to_FORMULA( CT_ident(Names.string_of_id - (Names.basename - (section_path sl kind)))) + (Nameops.basename (section_path sl)))) | _, _ -> xlate_error "xlate_op : MUTIND") | "MUTCASE" | "CASE" -> @@ -417,7 +416,7 @@ let xlate_op the_node opn a b = *) "MUTCONSTRUCT" -> (match a, b with - | [Path(_, sl, kind);Num(_, tyi);Num(_, n)], cl -> + | [Path(_, sl);Num(_, tyi);Num(_, n)], cl -> if !in_coq_ref then match special_case_qualid () @@ -425,7 +424,7 @@ let xlate_op the_node opn a b = | Some(Rform x) -> x | _ -> assert false else - let name = Names.string_of_path (section_path sl kind) in + let name = Names.string_of_path (section_path sl) in (* This is rather a patch to cope with the fact that identifier names have disappeared from the vo files for grammar rules *) let type_desc = (try Some (Hashtbl.find type_table name) with @@ -1512,9 +1511,9 @@ let xlate_ast = CT_coerce_ID_OR_STRING_to_AST (CT_coerce_STRING_to_ID_OR_STRING (CT_string s)) | Dynamic(_,_) -> failwith "Dynamics not treated in xlate_ast" - | Path (_, sl, s) -> + | Path (_, sl) -> CT_astpath - (CT_id_list (List.map (function s -> CT_ident s) sl), CT_ident s) in + (CT_id_list (List.map (function s -> CT_ident s) sl)) in xlate_ast_aux;; let get_require_flags impexp spec = diff --git a/contrib/omega/coq_omega.ml b/contrib/omega/coq_omega.ml index d12f868ac..8e1d90489 100644 --- a/contrib/omega/coq_omega.ml +++ b/contrib/omega/coq_omega.ml @@ -21,7 +21,10 @@ open Reduction open Proof_type open Ast open Names +open Nameops open Term +open Termops +open Declarations open Environ open Sign open Inductive @@ -30,6 +33,7 @@ open Evar_refiner open Tactics open Clenv open Logic +open Nametab open Omega (* Added by JCF, 09/03/98 *) @@ -97,24 +101,24 @@ let reduce_to_mind gl t = let rec elimrec t l = let c, args = whd_stack t in match kind_of_term c, args with - | (IsMutInd ind,_) -> (ind,Environ.it_mkProd_or_LetIn t l) - | (IsConst _,_) -> + | (Ind ind,_) -> (ind,Environ.it_mkProd_or_LetIn t l) + | (Const _,_) -> (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" >]) - | (IsMutCase _,_) -> + | (Case _,_) -> (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" >]) - | (IsCast (c,_),[]) -> elimrec c l - | (IsProd (n,ty,t'),[]) -> + | (Cast (c,_),[]) -> elimrec c l + | (Prod (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'),[]) -> + | (LetIn (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" @@ -127,7 +131,8 @@ let reduce_to_mind = pf_reduce_to_quantified_ind let constructor_tac nconstropt i lbind gl = let cl = pf_concl gl in let (mind, redcl) = reduce_to_mind gl cl in - let nconstr = Global.mind_nconstr mind + let (mib,mip) = Global.lookup_inductive mind in + let nconstr = Array.length mip.mind_consnames and sigma = project gl in (match nconstropt with | Some expnconstr -> @@ -135,7 +140,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 = mkMutConstruct (ith_constructor_of_inductive mind i) in + let c = mkConstruct (ith_constructor_of_inductive mind i) in let resolve_tac = resolve_with_bindings_tac (c,lbind) in (tclTHEN (tclTHEN (change_in_concl redcl) intros) resolve_tac) gl @@ -169,7 +174,7 @@ let hide_constr,find_constr,clear_tables,dump_tables = (fun () -> l := []), (fun () -> !l) -let get_applist = whd_stack +let get_applist = decompose_app exception Destruct @@ -177,12 +182,12 @@ let dest_const_apply t = let f,args = get_applist t in let ref = match kind_of_term f with - | IsConst sp -> ConstRef sp - | IsMutConstruct csp -> ConstructRef csp - | IsMutInd isp -> IndRef isp + | Const sp -> ConstRef sp + | Construct csp -> ConstructRef csp + | Ind isp -> IndRef isp | _ -> raise Destruct in - basename (Global.sp_of_global ref), args + id_of_global (Global.env()) ref, args type result = | Kvar of string @@ -192,17 +197,17 @@ type result = let destructurate t = let c, args = get_applist t in + let env = Global.env() in match kind_of_term c, args with - | IsConst sp, args -> - Kapp (string_of_id (basename (Global.sp_of_global (ConstRef sp))),args) - | IsMutConstruct csp , args -> - Kapp (string_of_id (basename (Global.sp_of_global (ConstructRef csp))), - args) - | IsMutInd isp, args -> - Kapp (string_of_id (basename (Global.sp_of_global (IndRef 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" + | Const sp, args -> + Kapp (string_of_id (id_of_global env (ConstRef sp)),args) + | Construct csp , args -> + Kapp (string_of_id (id_of_global env(ConstructRef csp)), args) + | Ind isp, args -> + Kapp (string_of_id (id_of_global env (IndRef isp)),args) + | Var id,[] -> Kvar(string_of_id id) + | Prod (Anonymous,typ,body), [] -> Kimp(typ,body) + | Prod (Name _,_,_),[] -> error "Omega: Not a quantifier-free goal" | _ -> Kufo let recognize_number t = @@ -225,7 +230,7 @@ let recognize_number t = This is the right way to access to Coq constants in tactics ML code *) let constant dir s = - let dir = make_dirpath (List.map id_of_string ("Coq"::dir)) in + let dir = make_dirpath (List.map id_of_string (List.rev ("Coq"::dir))) in let id = id_of_string s in try Declare.global_reference_in_absolute_module dir id @@ -389,7 +394,7 @@ let coq_imp_simp = lazy (logic_constant ["Decidable"] "imp_simp") (* Section paths for unfold *) open Closure let make_coq_path dir s = - let dir = make_dirpath (List.map id_of_string ("Coq"::dir)) in + let dir = make_dirpath (List.map id_of_string (List.rev ("Coq"::dir))) in let id = id_of_string s in let ref = try Nametab.locate_in_absolute_module dir id @@ -441,7 +446,7 @@ type constr_path = (* Abstraction and product *) | P_BODY | P_TYPE - (* Mutcase *) + (* Case *) | P_BRANCH of int | P_ARITY | P_ARG @@ -449,37 +454,37 @@ type constr_path = let context operation path (t : constr) = let rec loop i p0 t = match (p0,kind_of_term t) with - | (p, IsCast (c,t)) -> mkCast (loop i p c,t) + | (p, Cast (c,t)) -> mkCast (loop i p c,t) | ([], _) -> operation i t - | ((P_APP n :: p), IsApp (f,v)) -> + | ((P_APP n :: p), App (f,v)) -> (* let f,l = get_applist t in NECESSAIRE ?? let v' = Array.of_list (f::l) in *) let v' = Array.copy v in v'.(n-1) <- loop i p v'.(n-1); mkApp (f, v') - | ((P_BRANCH n :: p), IsMutCase (ci,q,c,v)) -> + | ((P_BRANCH n :: p), Case (ci,q,c,v)) -> (* avant, y avait mkApp... anyway, BRANCH seems nowhere used *) let v' = Array.copy v in - v'.(n) <- loop i p v'.(n); (mkMutCase (ci,q,c,v')) - | ((P_ARITY :: p), IsApp (f,l)) -> + v'.(n) <- loop i p v'.(n); (mkCase (ci,q,c,v')) + | ((P_ARITY :: p), App (f,l)) -> appvect (loop i p f,l) - | ((P_ARG :: p), IsApp (f,v)) -> + | ((P_ARG :: p), App (f,v)) -> let v' = Array.copy v in v'.(0) <- loop i p v'.(0); mkApp (f,v') - | (p, IsFix ((_,n as ln),(tys,lna,v))) -> + | (p, Fix ((_,n as ln),(tys,lna,v))) -> let l = Array.length v in let v' = Array.copy v in v'.(n) <- loop (i+l) p v.(n); (mkFix (ln,(tys,lna,v'))) - | ((P_BODY :: p), IsProd (n,t,c)) -> + | ((P_BODY :: p), Prod (n,t,c)) -> (mkProd (n,t,loop (i+1) p c)) - | ((P_BODY :: p), IsLambda (n,t,c)) -> + | ((P_BODY :: p), Lambda (n,t,c)) -> (mkLambda (n,t,loop (i+1) p c)) - | ((P_BODY :: p), IsLetIn (n,b,t,c)) -> + | ((P_BODY :: p), LetIn (n,b,t,c)) -> (mkLetIn (n,b,t,loop (i+1) p c)) - | ((P_TYPE :: p), IsProd (n,t,c)) -> + | ((P_TYPE :: p), Prod (n,t,c)) -> (mkProd (n,loop i p t,c)) - | ((P_TYPE :: p), IsLambda (n,t,c)) -> + | ((P_TYPE :: p), Lambda (n,t,c)) -> (mkLambda (n,loop i p t,c)) - | ((P_TYPE :: p), IsLetIn (n,b,t,c)) -> + | ((P_TYPE :: p), LetIn (n,b,t,c)) -> (mkLetIn (n,b,loop i p t,c)) | (p, _) -> pPNL [<Printer.prterm t>]; @@ -489,19 +494,19 @@ let context operation path (t : constr) = let occurence path (t : constr) = let rec loop p0 t = match (p0,kind_of_term t) with - | (p, IsCast (c,t)) -> loop p c + | (p, Cast (c,t)) -> loop p c | ([], _) -> t - | ((P_APP n :: p), IsApp (f,v)) -> loop p v.(n-1) - | ((P_BRANCH n :: p), IsMutCase (_,_,_,v)) -> loop p v.(n) - | ((P_ARITY :: p), IsApp (f,_)) -> loop p f - | ((P_ARG :: p), IsApp (f,v)) -> loop p v.(0) - | (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_APP n :: p), App (f,v)) -> loop p v.(n-1) + | ((P_BRANCH n :: p), Case (_,_,_,v)) -> loop p v.(n) + | ((P_ARITY :: p), App (f,_)) -> loop p f + | ((P_ARG :: p), App (f,v)) -> loop p v.(0) + | (p, Fix((_,n) ,(_,_,v))) -> loop p v.(n) + | ((P_BODY :: p), Prod (n,t,c)) -> loop p c + | ((P_BODY :: p), Lambda (n,t,c)) -> loop p c + | ((P_BODY :: p), LetIn (n,b,t,c)) -> loop p c + | ((P_TYPE :: p), Prod (n,term,c)) -> loop p term + | ((P_TYPE :: p), Lambda (n,term,c)) -> loop p term + | ((P_TYPE :: p), LetIn (n,b,term,c)) -> loop p term | (p, _) -> pPNL [<Printer.prterm t>]; failwith ("occurence " ^ string_of_int(List.length p)) diff --git a/contrib/ring/quote.ml b/contrib/ring/quote.ml index b87ec5861..10c05ec0e 100644 --- a/contrib/ring/quote.ml +++ b/contrib/ring/quote.ml @@ -120,7 +120,8 @@ open Proof_type the constants are loaded in the environment *) let constant dir s = - let dir = make_dirpath (List.map id_of_string ("Coq"::"ring"::dir)) in + let dir = make_dirpath + (List.map id_of_string (List.rev ("Coq"::"ring"::dir))) in let id = id_of_string s in try Declare.global_reference_in_absolute_module dir id @@ -200,9 +201,9 @@ let decomp_term c = kind_of_term (strip_outer_cast c) let compute_lhs typ i nargsi = match kind_of_term typ with - | IsMutInd(sp,0) -> + | Ind(sp,0) -> let argsi = Array.init nargsi (fun j -> mkMeta (nargsi - j)) in - mkApp (mkMutConstruct ((sp,0),i+1), argsi) + mkApp (mkConstruct ((sp,0),i+1), argsi) | _ -> i_can't_do_that () (*s This function builds the pattern from the RHS. Recursive calls are @@ -211,11 +212,11 @@ let compute_lhs typ i nargsi = let compute_rhs bodyi index_of_f = let rec aux c = match decomp_term c with - | IsApp (j, args) when j = mkRel (index_of_f) (* recursive call *) -> + | App (j, args) when j = mkRel (index_of_f) (* recursive call *) -> let i = destRel (array_last args) in mkMeta i - | IsApp (f,args) -> + | App (f,args) -> mkApp (f, Array.map aux args) - | IsCast (c,t) -> aux c + | Cast (c,t) -> aux c | _ -> c in pattern_of_constr (aux bodyi) @@ -224,13 +225,13 @@ let compute_rhs bodyi index_of_f = let compute_ivs gl f cs = let cst = try destConst f with _ -> i_can't_do_that () in - let body = constant_value (Global.env()) cst in + let body = Environ.constant_value (Global.env()) cst in match decomp_term body with - | IsFix(([| len |], 0), ([| name |], [| typ |], [| body2 |])) -> + | Fix(([| len |], 0), ([| name |], [| typ |], [| body2 |])) -> let (args3, body3) = decompose_lam body2 in let nargs3 = List.length args3 in begin match decomp_term body3 with - | IsMutCase(_,p,c,lci) -> (* <p> Case c of c1 ... cn end *) + | Case(_,p,c,lci) -> (* <p> Case c of c1 ... cn end *) let n_lhs_rhs = ref [] and v_lhs = ref (None : constr option) and c_lhs = ref (None : constr option) in @@ -246,7 +247,7 @@ let compute_ivs gl f cs = c_lhs := Some (compute_lhs (snd (List.hd args3)) i nargsi) (* Then we test if the RHS is the RHS for variables *) - else begin match decomp_app bodyi with + else begin match decompose_app bodyi with | vmf, [_; _; a3; a4 ] when isRel a3 & isRel a4 & pf_conv_x gl vmf @@ -267,7 +268,7 @@ let compute_ivs gl f cs = (* The Cases predicate is a lambda; we assume no dependency *) let p = match kind_of_term p with - | IsLambda (_,_,p) -> pop p + | Lambda (_,_,p) -> pop p | _ -> p in @@ -300,8 +301,8 @@ binary search trees (see file \texttt{Quote.v}) *) let rec closed_under cset t = (ConstrSet.mem t cset) or (match (kind_of_term t) with - | IsCast(c,_) -> closed_under cset c - | IsApp(f,l) -> closed_under cset f & array_for_all (closed_under cset) l + | Cast(c,_) -> closed_under cset c + | App(f,l) -> closed_under cset f & array_for_all (closed_under cset) l | _ -> false) (*s [btree_of_array [| c1; c2; c3; c4; c5 |]] builds the complete @@ -362,8 +363,8 @@ let path_of_int n = let rec subterm gl (t : constr) (t' : constr) = (pf_conv_x gl t t') or (match (kind_of_term t) with - | IsApp (f,args) -> array_exists (fun t -> subterm gl t t') args - | IsCast(t,_) -> (subterm gl t t') + | App (f,args) -> array_exists (fun t -> subterm gl t t') args + | Cast(t,_) -> (subterm gl t t') | _ -> false) (*s We want to sort the list according to reverse subterm order. *) @@ -398,26 +399,26 @@ let quote_terms ivs lc gl= begin try let s1 = matches rhs c in let s2 = List.map (fun (i,c_i) -> (i,aux c_i)) s1 in - Term.subst_meta s2 lhs + Termops.subst_meta s2 lhs with PatternMatchingFailure -> auxl tail end | [] -> begin match ivs.variable_lhs with | None -> begin match ivs.constant_lhs with - | Some c_lhs -> Term.subst_meta [1, c] c_lhs + | Some c_lhs -> Termops.subst_meta [1, c] c_lhs | None -> anomaly "invalid inversion scheme for quote" end | Some var_lhs -> begin match ivs.constant_lhs with | Some c_lhs when closed_under ivs.constants c -> - Term.subst_meta [1, c] c_lhs + Termops.subst_meta [1, c] c_lhs | _ -> begin try Hashtbl.find varhash c with Not_found -> let newvar = - Term.subst_meta [1, (path_of_int !counter)] + Termops.subst_meta [1, (path_of_int !counter)] var_lhs in begin incr counter; diff --git a/contrib/ring/ring.ml b/contrib/ring/ring.ml index 720c5a862..1043ecbdb 100644 --- a/contrib/ring/ring.ml +++ b/contrib/ring/ring.ml @@ -15,7 +15,8 @@ open Util open Options open Term open Names -open Reduction +open Nameops +open Reductionops open Tacmach open Proof_type open Proof_trees @@ -28,13 +29,14 @@ open Tacred open Tactics open Pattern open Hiddentac +open Nametab open Quote let mt_evd = Evd.empty let constr_of com = Astterm.interp_constr mt_evd (Global.env()) com let constant dir s = - let dir = make_dirpath (List.map id_of_string ("Coq"::dir)) in + let dir = make_dirpath (List.map id_of_string (List.rev ("Coq"::dir))) in let id = id_of_string s in try Declare.global_reference_in_absolute_module dir id @@ -138,6 +140,7 @@ val build_coq_eqT : constr delayed val build_coq_sym_eqT : constr delayed *) +let mkLApp(fc,v) = mkApp(Lazy.force fc, v) (*********** Useful types and functions ************) @@ -226,30 +229,31 @@ let unbox = function let add_theory want_ring want_abstract want_setoid a aequiv asetth amorph aplus amult aone azero aopp aeq t cset = if theories_map_mem a then errorlabstrm "Add Semi Ring" - [< 'sTR "A (Semi-)(Setoid-)Ring Structure is already declared for "; prterm a >]; + [< 'sTR "A (Semi-)(Setoid-)Ring Structure is already declared for "; + prterm a >]; let env = Global.env () in if (want_ring & want_setoid & (not (is_conv env Evd.empty (Typing.type_of env Evd.empty t) - (mkApp (Lazy.force coq_Setoid_Ring_Theory, + (mkLApp (coq_Setoid_Ring_Theory, [| a; (unbox aequiv); aplus; amult; aone; azero; (unbox aopp); aeq|])))) & (not (is_conv env Evd.empty (Typing.type_of env Evd.empty (unbox asetth)) - (mkApp ((Lazy.force coq_Setoid_Theory), [| a; (unbox aequiv) |]))))) then + (mkLApp (coq_Setoid_Theory, [| a; (unbox aequiv) |]))))) then errorlabstrm "addring" [< 'sTR "Not a valid Setoid-Ring theory" >]; if (not want_ring & want_setoid & (not (is_conv env Evd.empty (Typing.type_of env Evd.empty t) - (mkApp (Lazy.force coq_Semi_Setoid_Ring_Theory, + (mkLApp (coq_Semi_Setoid_Ring_Theory, [| a; (unbox aequiv); aplus; amult; aone; azero; aeq|])))) & (not (is_conv env Evd.empty (Typing.type_of env Evd.empty (unbox asetth)) - (mkApp ((Lazy.force coq_Setoid_Theory), [| a; (unbox aequiv) |]))))) then + (mkLApp (coq_Setoid_Theory, [| a; (unbox aequiv) |]))))) then errorlabstrm "addring" [< 'sTR "Not a valid Semi-Setoid-Ring theory" >]; if (want_ring & not want_setoid & not (is_conv env Evd.empty (Typing.type_of env Evd.empty t) - (mkApp (Lazy.force coq_Ring_Theory, + (mkLApp (coq_Ring_Theory, [| a; aplus; amult; aone; azero; (unbox aopp); aeq |])))) then errorlabstrm "addring" [< 'sTR "Not a valid Ring theory" >]; if (not want_ring & not want_setoid & not (is_conv env Evd.empty (Typing.type_of env Evd.empty t) - (mkApp (Lazy.force coq_Semi_Ring_Theory, + (mkLApp (coq_Semi_Ring_Theory, [| a; aplus; amult; aone; azero; aeq |])))) then errorlabstrm "addring" [< 'sTR "Not a valid Semi-Ring theory" >]; Lib.add_anonymous_leaf @@ -437,17 +441,17 @@ let build_spolynom gl th lc = and builds the varmap with side-effects *) let rec aux c = match (kind_of_term (strip_outer_cast c)) with - | IsApp (binop,[|c1; c2|]) when pf_conv_x gl binop th.th_plus -> - mkAppA [| Lazy.force coq_SPplus; th.th_a; aux c1; aux c2 |] - | IsApp (binop,[|c1; c2|]) when pf_conv_x gl binop th.th_mult -> - mkAppA [| Lazy.force coq_SPmult; th.th_a; aux c1; aux c2 |] + | App (binop,[|c1; c2|]) when pf_conv_x gl binop th.th_plus -> + mkLApp(coq_SPplus, [|th.th_a; aux c1; aux c2 |]) + | App (binop,[|c1; c2|]) when pf_conv_x gl binop th.th_mult -> + mkLApp(coq_SPmult, [|th.th_a; aux c1; aux c2 |]) | _ when closed_under th.th_closed c -> - mkAppA [| Lazy.force coq_SPconst; th.th_a; c |] + mkLApp(coq_SPconst, [|th.th_a; c |]) | _ -> try Hashtbl.find varhash c with Not_found -> - let newvar = mkAppA [| Lazy.force coq_SPvar; th.th_a; - (path_of_int !counter) |] in + let newvar = + mkLApp(coq_SPvar, [|th.th_a; (path_of_int !counter) |]) in begin incr counter; varlist := c :: !varlist; @@ -459,18 +463,18 @@ let build_spolynom gl th lc = let v = btree_of_array (Array.of_list (List.rev !varlist)) th.th_a in List.map (fun p -> - (mkAppA [| Lazy.force coq_interp_sp; th.th_a; th.th_plus; th.th_mult; - th.th_zero; v; p |], - mkAppA [| Lazy.force coq_interp_cs; th.th_a; th.th_plus; th.th_mult; - th.th_one; th.th_zero; v; + (mkLApp (coq_interp_sp, + [|th.th_a; th.th_plus; th.th_mult; th.th_zero; v; p |]), + mkLApp (coq_interp_cs, + [|th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v; pf_reduce cbv_betadeltaiota gl - (mkAppA [| Lazy.force coq_spolynomial_simplify; - th.th_a; th.th_plus; th.th_mult; + (mkLApp (coq_spolynomial_simplify, + [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; - th.th_eq; p|]) |], - mkAppA [| Lazy.force coq_spolynomial_simplify_ok; - th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; - th.th_eq; v; th.th_t; p |])) + th.th_eq; p|])) |]), + mkLApp (coq_spolynomial_simplify_ok, + [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; + th.th_eq; v; th.th_t; p |]))) lp (* @@ -491,25 +495,26 @@ let build_polynom gl th lc = let counter = ref 1 in (* number of variables created + 1 *) let rec aux c = match (kind_of_term (strip_outer_cast c)) with - | IsApp (binop, [|c1; c2|]) when pf_conv_x gl binop th.th_plus -> - mkAppA [| Lazy.force coq_Pplus; th.th_a; aux c1; aux c2 |] - | IsApp (binop, [|c1; c2|]) when pf_conv_x gl binop th.th_mult -> - mkAppA [| Lazy.force coq_Pmult; th.th_a; aux c1; aux c2 |] + | App (binop, [|c1; c2|]) when pf_conv_x gl binop th.th_plus -> + mkLApp(coq_Pplus, [|th.th_a; aux c1; aux c2 |]) + | App (binop, [|c1; c2|]) when pf_conv_x gl binop th.th_mult -> + mkLApp(coq_Pmult, [|th.th_a; aux c1; aux c2 |]) (* The special case of Zminus *) - | IsApp (binop, [|c1; c2|]) - when pf_conv_x gl c (mkAppA [| th.th_plus; c1; - mkAppA [| (unbox th.th_opp); c2 |] |]) -> - mkAppA [| Lazy.force coq_Pplus; th.th_a; aux c1; - mkAppA [| Lazy.force coq_Popp; th.th_a; aux c2 |] |] - | IsApp (unop, [|c1|]) when pf_conv_x gl unop (unbox th.th_opp) -> - mkAppA [| Lazy.force coq_Popp; th.th_a; aux c1 |] + | App (binop, [|c1; c2|]) + when pf_conv_x gl c + (mkApp (th.th_plus, [|c1; mkApp(unbox th.th_opp, [|c2|])|])) -> + mkLApp(coq_Pplus, + [|th.th_a; aux c1; + mkLApp(coq_Popp, [|th.th_a; aux c2|]) |]) + | App (unop, [|c1|]) when pf_conv_x gl unop (unbox th.th_opp) -> + mkLApp(coq_Popp, [|th.th_a; aux c1|]) | _ when closed_under th.th_closed c -> - mkAppA [| Lazy.force coq_Pconst; th.th_a; c |] + mkLApp(coq_Pconst, [|th.th_a; c |]) | _ -> try Hashtbl.find varhash c with Not_found -> - let newvar = mkAppA [| Lazy.force coq_Pvar; th.th_a; - (path_of_int !counter) |] in + let newvar = + mkLApp(coq_Pvar, [|th.th_a; (path_of_int !counter) |]) in begin incr counter; varlist := c :: !varlist; @@ -521,18 +526,18 @@ let build_polynom gl th lc = let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in List.map (fun p -> - (mkAppA [| Lazy.force coq_interp_p; - th.th_a; th.th_plus; th.th_mult; th.th_zero; (unbox th.th_opp); - v; p |], - mkAppA [| Lazy.force coq_interp_cs; - th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v; + (mkLApp(coq_interp_p, + [| th.th_a; th.th_plus; th.th_mult; th.th_zero; + (unbox th.th_opp); v; p |])), + mkLApp(coq_interp_cs, + [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v; pf_reduce cbv_betadeltaiota gl - (mkAppA [| Lazy.force coq_polynomial_simplify; - th.th_a; th.th_plus; th.th_mult; + (mkLApp(coq_polynomial_simplify, + [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; - (unbox th.th_opp); th.th_eq; p |]) |], - mkAppA [| Lazy.force coq_polynomial_simplify_ok; - th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; + (unbox th.th_opp); th.th_eq; p |])) |]), + mkLApp(coq_polynomial_simplify_ok, + [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; (unbox th.th_opp); th.th_eq; v; th.th_t; p |])) lp @@ -556,17 +561,16 @@ let build_aspolynom gl th lc = and builds the varmap with side-effects *) let rec aux c = match (kind_of_term (strip_outer_cast c)) with - | IsApp (binop, [|c1; c2|]) when pf_conv_x gl binop th.th_plus -> - mkAppA [| Lazy.force coq_ASPplus; aux c1; aux c2 |] - | IsApp (binop, [|c1; c2|]) when pf_conv_x gl binop th.th_mult -> - mkAppA [| Lazy.force coq_ASPmult; aux c1; aux c2 |] + | App (binop, [|c1; c2|]) when pf_conv_x gl binop th.th_plus -> + mkLApp(coq_ASPplus, [| aux c1; aux c2 |]) + | App (binop, [|c1; c2|]) when pf_conv_x gl binop th.th_mult -> + mkLApp(coq_ASPmult, [| aux c1; aux c2 |]) | _ when pf_conv_x gl c th.th_zero -> Lazy.force coq_ASP0 | _ when pf_conv_x gl c th.th_one -> Lazy.force coq_ASP1 | _ -> try Hashtbl.find varhash c with Not_found -> - let newvar = mkAppA [| Lazy.force coq_ASPvar; - (path_of_int !counter) |] in + let newvar = mkLApp(coq_ASPvar, [|(path_of_int !counter) |]) in begin incr counter; varlist := c :: !varlist; @@ -578,15 +582,17 @@ let build_aspolynom gl th lc = let v = btree_of_array (Array.of_list (List.rev !varlist)) th.th_a in List.map (fun p -> - (mkAppA [| Lazy.force coq_interp_asp; th.th_a; th.th_plus; th.th_mult; - th.th_one; th.th_zero; v; p |], - mkAppA [| Lazy.force coq_interp_acs; th.th_a; th.th_plus; th.th_mult; + (mkLApp(coq_interp_asp, + [| th.th_a; th.th_plus; th.th_mult; + th.th_one; th.th_zero; v; p |]), + mkLApp(coq_interp_acs, + [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v; pf_reduce cbv_betadeltaiota gl - (mkAppA [| Lazy.force coq_aspolynomial_normalize; p|]) |], - mkAppA [| Lazy.force coq_spolynomial_simplify_ok; - th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; - th.th_eq; v; th.th_t; p |])) + (mkLApp(coq_aspolynomial_normalize,[|p|])) |]), + mkLApp(coq_spolynomial_simplify_ok, + [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; + th.th_eq; v; th.th_t; p |]))) lp (* @@ -607,25 +613,25 @@ let build_apolynom gl th lc = let counter = ref 1 in (* number of variables created + 1 *) let rec aux c = match (kind_of_term (strip_outer_cast c)) with - | IsApp (binop, [|c1; c2|]) when pf_conv_x gl binop th.th_plus -> - mkAppA [| Lazy.force coq_APplus; aux c1; aux c2 |] - | IsApp (binop, [|c1; c2|]) when pf_conv_x gl binop th.th_mult -> - mkAppA [| Lazy.force coq_APmult; aux c1; aux c2 |] + | App (binop, [|c1; c2|]) when pf_conv_x gl binop th.th_plus -> + mkLApp(coq_APplus, [| aux c1; aux c2 |]) + | App (binop, [|c1; c2|]) when pf_conv_x gl binop th.th_mult -> + mkLApp(coq_APmult, [| aux c1; aux c2 |]) (* The special case of Zminus *) - | IsApp (binop, [|c1; c2|]) - when pf_conv_x gl c (mkAppA [| th.th_plus; c1; - mkAppA [|(unbox th.th_opp); c2 |] |]) -> - mkAppA [| Lazy.force coq_APplus; aux c1; - mkAppA [| Lazy.force coq_APopp; aux c2 |] |] - | IsApp (unop, [|c1|]) when pf_conv_x gl unop (unbox th.th_opp) -> - mkAppA [| Lazy.force coq_APopp; aux c1 |] + | App (binop, [|c1; c2|]) + when pf_conv_x gl c + (mkApp(th.th_plus, [|c1; mkApp(unbox th.th_opp,[|c2|]) |])) -> + mkLApp(coq_APplus, + [|aux c1; mkLApp(coq_APopp,[|aux c2|]) |]) + | App (unop, [|c1|]) when pf_conv_x gl unop (unbox th.th_opp) -> + mkLApp(coq_APopp, [| aux c1 |]) | _ when pf_conv_x gl c th.th_zero -> Lazy.force coq_AP0 | _ when pf_conv_x gl c th.th_one -> Lazy.force coq_AP1 | _ -> try Hashtbl.find varhash c with Not_found -> - let newvar = mkAppA [| Lazy.force coq_APvar; - (path_of_int !counter) |] in + let newvar = + mkLApp(coq_APvar, [| path_of_int !counter |]) in begin incr counter; varlist := c :: !varlist; @@ -637,17 +643,17 @@ let build_apolynom gl th lc = let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in List.map (fun p -> - (mkAppA [| Lazy.force coq_interp_ap; - th.th_a; th.th_plus; th.th_mult; th.th_one; - th.th_zero; (unbox th.th_opp); v; p |], - mkAppA [| Lazy.force coq_interp_sacs; - th.th_a; th.th_plus; th.th_mult; + (mkLApp(coq_interp_ap, + [| th.th_a; th.th_plus; th.th_mult; th.th_one; + th.th_zero; (unbox th.th_opp); v; p |]), + mkLApp(coq_interp_sacs, + [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; (unbox th.th_opp); v; pf_reduce cbv_betadeltaiota gl - (mkAppA [| Lazy.force coq_apolynomial_normalize; p |]) |], - mkAppA [| Lazy.force coq_apolynomial_normalize_ok; - th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; - (unbox th.th_opp); th.th_eq; v; th.th_t; p |])) + (mkLApp(coq_apolynomial_normalize, [|p|])) |]), + mkLApp(coq_apolynomial_normalize_ok, + [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; + (unbox th.th_opp); th.th_eq; v; th.th_t; p |]))) lp (* @@ -668,25 +674,26 @@ let build_setpolynom gl th lc = let counter = ref 1 in (* number of variables created + 1 *) let rec aux c = match (kind_of_term (strip_outer_cast c)) with - | IsApp (binop, [|c1; c2|]) when pf_conv_x gl binop th.th_plus -> - mkAppA [| Lazy.force coq_SetPplus; th.th_a; aux c1; aux c2 |] - | IsApp (binop, [|c1; c2|]) when pf_conv_x gl binop th.th_mult -> - mkAppA [| Lazy.force coq_SetPmult; th.th_a; aux c1; aux c2 |] + | App (binop, [|c1; c2|]) when pf_conv_x gl binop th.th_plus -> + mkLApp(coq_SetPplus, [|th.th_a; aux c1; aux c2 |]) + | App (binop, [|c1; c2|]) when pf_conv_x gl binop th.th_mult -> + mkLApp(coq_SetPmult, [|th.th_a; aux c1; aux c2 |]) (* The special case of Zminus *) - | IsApp (binop, [|c1; c2|]) - when pf_conv_x gl c (mkAppA [| th.th_plus; c1; - mkAppA [|(unbox th.th_opp); c2 |] |]) -> - mkAppA [| Lazy.force coq_SetPplus; th.th_a; aux c1; - mkAppA [| Lazy.force coq_SetPopp; th.th_a; aux c2 |] |] - | IsApp (unop, [|c1|]) when pf_conv_x gl unop (unbox th.th_opp) -> - mkAppA [| Lazy.force coq_SetPopp; th.th_a; aux c1 |] + | App (binop, [|c1; c2|]) + when pf_conv_x gl c + (mkApp(th.th_plus, [|c1; mkApp(unbox th.th_opp,[|c2|])|])) -> + mkLApp(coq_SetPplus, + [| th.th_a; aux c1; + mkLApp(coq_SetPopp, [|th.th_a; aux c2|]) |]) + | App (unop, [|c1|]) when pf_conv_x gl unop (unbox th.th_opp) -> + mkLApp(coq_SetPopp, [| th.th_a; aux c1 |]) | _ when closed_under th.th_closed c -> - mkAppA [| Lazy.force coq_SetPconst; th.th_a; c |] + mkLApp(coq_SetPconst, [| th.th_a; c |]) | _ -> try Hashtbl.find varhash c with Not_found -> - let newvar = mkAppA [| Lazy.force coq_SetPvar; th.th_a; - (path_of_int !counter) |] in + let newvar = + mkLApp(coq_SetPvar, [| th.th_a; path_of_int !counter |]) in begin incr counter; varlist := c :: !varlist; @@ -698,21 +705,22 @@ let build_setpolynom gl th lc = let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in List.map (fun p -> - (mkAppA [| Lazy.force coq_interp_setp; - th.th_a; th.th_plus; th.th_mult; th.th_zero; (unbox th.th_opp); - v; p |], - mkAppA [| Lazy.force coq_interp_setcs; - th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v; + (mkLApp(coq_interp_setp, + [| th.th_a; th.th_plus; th.th_mult; th.th_zero; + (unbox th.th_opp); v; p |]), + mkLApp(coq_interp_setcs, + [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v; pf_reduce cbv_betadeltaiota gl - (mkAppA [| Lazy.force coq_setpolynomial_simplify; - th.th_a; th.th_plus; th.th_mult; + (mkLApp(coq_setpolynomial_simplify, + [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; - (unbox th.th_opp); th.th_eq; p |]) |], - mkAppA [| Lazy.force coq_setpolynomial_simplify_ok; - th.th_a; (unbox th.th_equiv); th.th_plus; th.th_mult; th.th_one; - th.th_zero;(unbox th.th_opp); th.th_eq; v; th.th_t; (unbox th.th_setoid_th); + (unbox th.th_opp); th.th_eq; p |])) |]), + mkLApp(coq_setpolynomial_simplify_ok, + [| th.th_a; (unbox th.th_equiv); th.th_plus; + th.th_mult; th.th_one; th.th_zero;(unbox th.th_opp); + th.th_eq; v; th.th_t; (unbox th.th_setoid_th); (unbox th.th_morph).plusm; (unbox th.th_morph).multm; - (unbox th.th_morph).oppm; p |])) + (unbox th.th_morph).oppm; p |]))) lp (* @@ -733,17 +741,17 @@ let build_setspolynom gl th lc = let counter = ref 1 in (* number of variables created + 1 *) let rec aux c = match (kind_of_term (strip_outer_cast c)) with - | IsApp (binop, [|c1; c2|]) when pf_conv_x gl binop th.th_plus -> - mkAppA [| Lazy.force coq_SetSPplus; th.th_a; aux c1; aux c2 |] - | IsApp (binop, [|c1; c2|]) when pf_conv_x gl binop th.th_mult -> - mkAppA [| Lazy.force coq_SetSPmult; th.th_a; aux c1; aux c2 |] + | App (binop, [|c1; c2|]) when pf_conv_x gl binop th.th_plus -> + mkLApp(coq_SetSPplus, [|th.th_a; aux c1; aux c2 |]) + | App (binop, [|c1; c2|]) when pf_conv_x gl binop th.th_mult -> + mkLApp(coq_SetSPmult, [| th.th_a; aux c1; aux c2 |]) | _ when closed_under th.th_closed c -> - mkAppA [| Lazy.force coq_SetSPconst; th.th_a; c |] + mkLApp(coq_SetSPconst, [| th.th_a; c |]) | _ -> try Hashtbl.find varhash c with Not_found -> - let newvar = mkAppA [| Lazy.force coq_SetSPvar; th.th_a; - (path_of_int !counter) |] in + let newvar = + mkLApp(coq_SetSPvar, [|th.th_a; path_of_int !counter |]) in begin incr counter; varlist := c :: !varlist; @@ -755,20 +763,21 @@ let build_setspolynom gl th lc = let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in List.map (fun p -> - (mkAppA [| Lazy.force coq_interp_setsp; - th.th_a; th.th_plus; th.th_mult; th.th_zero; - v; p |], - mkAppA [| Lazy.force coq_interp_setcs; - th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v; + (mkLApp(coq_interp_setsp, + [| th.th_a; th.th_plus; th.th_mult; th.th_zero; v; p |]), + mkLApp(coq_interp_setcs, + [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v; pf_reduce cbv_betadeltaiota gl - (mkAppA [| Lazy.force coq_setspolynomial_simplify; - th.th_a; th.th_plus; th.th_mult; + (mkLApp(coq_setspolynomial_simplify, + [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; - th.th_eq; p |]) |], - mkAppA [| Lazy.force coq_setspolynomial_simplify_ok; - th.th_a; (unbox th.th_equiv); th.th_plus; th.th_mult; th.th_one; - th.th_zero; th.th_eq; v; th.th_t; (unbox th.th_setoid_th); - (unbox th.th_morph).plusm; (unbox th.th_morph).multm; p |])) + th.th_eq; p |])) |]), + mkLApp(coq_setspolynomial_simplify_ok, + [| th.th_a; (unbox th.th_equiv); th.th_plus; + th.th_mult; th.th_one; th.th_zero; th.th_eq; v; + th.th_t; (unbox th.th_setoid_th); + (unbox th.th_morph).plusm; + (unbox th.th_morph).multm; p |]))) lp module SectionPathSet = @@ -806,12 +815,12 @@ let constants_to_unfold = open RedFlags let polynom_unfold_tac = let flags = - (UNIFORM, mkflags(fBETA::fIOTA::fEVAR::(List.map fCONST constants_to_unfold))) in + (UNIFORM, mkflags(fBETA::fIOTA::(List.map fCONST constants_to_unfold))) in reduct_in_concl (cbv_norm_flags flags) let polynom_unfold_tac_in_term gl = let flags = - (UNIFORM,mkflags(fBETA::fIOTA::fEVAR::fZETA::(List.map fCONST constants_to_unfold))) + (UNIFORM,mkflags(fBETA::fIOTA::fZETA::(List.map fCONST constants_to_unfold))) in cbv_norm_flags flags (pf_env gl) (project gl) @@ -854,10 +863,10 @@ let raw_polynom th op lc gl = (tclORELSE (tclORELSE (h_exact c'i_eq_c''i) - (h_exact (mkAppA - [| (Lazy.force coq_seq_sym); - th.th_a; (unbox th.th_equiv); (unbox th.th_setoid_th); - c'''i; ci; c'i_eq_c''i |]))) + (h_exact (mkLApp(coq_seq_sym, + [| th.th_a; (unbox th.th_equiv); + (unbox th.th_setoid_th); + c'''i; ci; c'i_eq_c''i |])))) (tclTHENS (Setoid_replace.setoid_replace ci c'''i None) [ tac; @@ -866,12 +875,11 @@ let raw_polynom th op lc gl = (tclORELSE (tclORELSE (h_exact c'i_eq_c''i) - (h_exact (mkAppA - [| build_coq_sym_eqT (); - th.th_a; c'''i; ci; c'i_eq_c''i |]))) + (h_exact (mkApp(build_coq_sym_eqT (), + [|th.th_a; c'''i; ci; c'i_eq_c''i |])))) (tclTHENS (elim_type - (mkAppA [| build_coq_eqT (); th.th_a; c'''i; ci |])) + (mkApp(build_coq_eqT (), [|th.th_a; c'''i; ci |]))) [ tac; h_exact c'i_eq_c''i ])) ) @@ -885,16 +893,16 @@ let guess_eq_tac th = polynom_unfold_tac (tclREPEAT (tclORELSE - (apply (mkAppA [| build_coq_f_equal2 (); - th.th_a; th.th_a; th.th_a; - th.th_plus |])) - (apply (mkAppA [| build_coq_f_equal2 (); - th.th_a; th.th_a; th.th_a; - th.th_mult |])))))) + (apply (mkApp(build_coq_f_equal2 (), + [| th.th_a; th.th_a; th.th_a; + th.th_plus |]))) + (apply (mkApp(build_coq_f_equal2 (), + [| th.th_a; th.th_a; th.th_a; + th.th_mult |]))))))) let guess_equiv_tac th = - (tclORELSE (apply (mkAppA [|(Lazy.force coq_seq_refl); - th.th_a; (unbox th.th_equiv); - (unbox th.th_setoid_th)|])) + (tclORELSE (apply (mkLApp(coq_seq_refl, + [| th.th_a; (unbox th.th_equiv); + (unbox th.th_setoid_th)|]))) (tclTHEN polynom_unfold_tac (tclREPEAT @@ -903,9 +911,9 @@ let guess_equiv_tac th = (apply (unbox th.th_morph).multm))))) let match_with_equiv c = match (kind_of_term c) with - | IsApp (e,a) -> + | App (e,a) -> if (List.mem e (Setoid_replace.equiv_list ())) - then Some (decomp_app c) + then Some (decompose_app c) else None | _ -> None diff --git a/contrib/romega/const_omega.ml b/contrib/romega/const_omega.ml index c64038323..76a6bdf52 100644 --- a/contrib/romega/const_omega.ml +++ b/contrib/romega/const_omega.ml @@ -16,37 +16,38 @@ type result = | Kufo;; let destructurate t = - let c, args = Reduction.whd_stack t in + let c, args = Term.decompose_app t in + let env = Global.env() in match Term.kind_of_term c, args with - | Term.IsConst sp, args -> + | Term.Const sp, args -> Kapp (Names.string_of_id - (Names.basename (Global.sp_of_global (Names.ConstRef sp))), - args) - | Term.IsMutConstruct csp , args -> + (Termops.id_of_global env (Nametab.ConstRef sp)), + args) + | Term.Construct csp , args -> Kapp (Names.string_of_id - (Names.basename (Global.sp_of_global(Names.ConstructRef csp))), + (Termops.id_of_global env (Nametab.ConstructRef csp)), args) - | Term.IsMutInd isp, args -> + | Term.Ind isp, args -> Kapp (Names.string_of_id - (Names.basename (Global.sp_of_global (Names.IndRef isp))),args) - | Term.IsVar id,[] -> Kvar(Names.string_of_id id) - | Term.IsProd (Names.Anonymous,typ,body), [] -> Kimp(typ,body) - | Term.IsProd (Names.Name _,_,_),[] -> + (Termops.id_of_global env (Nametab.IndRef isp)),args) + | Term.Var id,[] -> Kvar(Names.string_of_id id) + | Term.Prod (Names.Anonymous,typ,body), [] -> Kimp(typ,body) + | Term.Prod (Names.Name _,_,_),[] -> Util.error "Omega: Not a quantifier-free goal" | _ -> Kufo exception Destruct let dest_const_apply t = - let f,args = Reduction.whd_stack t in + let f,args = Term.decompose_app t in let ref = match Term.kind_of_term f with - | Term.IsConst sp -> Names.ConstRef sp - | Term.IsMutConstruct csp -> Names.ConstructRef csp - | Term.IsMutInd isp -> Names.IndRef isp + | Term.Const sp -> Nametab.ConstRef sp + | Term.Construct csp -> Nametab.ConstructRef csp + | Term.Ind isp -> Nametab.IndRef isp | _ -> raise Destruct in - Names.basename (Global.sp_of_global ref), args + Termops.id_of_global (Global.env()) ref, args let recognize_number t = let rec loop t = @@ -64,8 +65,9 @@ let recognize_number t = let constant dir s = try Declare.global_absolute_reference - (Names.make_path (Names.make_dirpath (List.map Names.id_of_string dir)) - (Names.id_of_string s) Names.CCI) + (Names.make_path + (Names.make_dirpath (List.map Names.id_of_string (List.rev dir))) + (Names.id_of_string s)) with e -> print_endline (String.concat "." dir); print_endline s; raise e diff --git a/contrib/xml/xmlcommand.ml b/contrib/xml/xmlcommand.ml index f2de55314..79348a704 100644 --- a/contrib/xml/xmlcommand.ml +++ b/contrib/xml/xmlcommand.ml @@ -64,11 +64,11 @@ let extract_nparams pack = let module S = Sign in let {D.mind_nparams=nparams0} = pack.(0) in - let arity0 = D.mind_user_arity pack.(0) in + let arity0 = pack.(0).D.mind_user_arity in let params0, _ = S.decompose_prod_n_assum nparams0 arity0 in for i = 1 to Array.length pack - 1 do let {D.mind_nparams=nparamsi} = pack.(i) in - let arityi = D.mind_user_arity pack.(i) in + let arityi = pack.(i).D.mind_user_arity in let paramsi, _ = S.decompose_prod_n_assum nparamsi arityi in if params0 <> paramsi then U.error "Cannot convert a block of inductive definitions with parameters specific to each inductive to a block of mutual inductive definitions with parameters global to the whole block" done; @@ -99,9 +99,10 @@ let could_have_namesakes o sp = (* namesake = omonimo in italian *) (* section path is sp *) let uri_of_path sp tag = let module N = Names in + let module No = Nameops in let ext_of_sp sp = ext_of_tag tag in - let dir0 = N.extend_dirpath (N.dirpath sp) (N.basename sp) in - let dir = List.map N.string_of_id (N.repr_dirpath dir0) in + let dir0 = No.extend_dirpath (No.dirpath sp) (No.basename sp) in + let dir = List.map N.string_of_id (List.rev (N.repr_dirpath dir0)) in "cic:/" ^ (String.concat "/" dir) ^ "." ^ (ext_of_sp sp) ;; @@ -193,10 +194,12 @@ let add_to_pvars x = let v = match x with Definition (v, bod, typ) -> - cumenv := E.push_named_def (Names.id_of_string v, bod, typ) !cumenv ; + cumenv := + E.push_named_decl (Names.id_of_string v, Some bod, typ) !cumenv ; v | Assumption (v, typ) -> - cumenv := E.push_named_assum (Names.id_of_string v, typ) !cumenv ; + cumenv := + E.push_named_decl (Names.id_of_string v, None, typ) !cumenv ; v in match !pvars with @@ -305,18 +308,18 @@ let print_term inner_types l env csr = (* kind_of_term helps doing pattern matching hiding the lower level of *) (* coq coding of terms (the one of the logical framework) *) match T.kind_of_term cstr with - T.IsRel n -> + T.Rel n -> let id = match List.nth l (n - 1) with N.Name id -> id - | N.Anonymous -> N.make_ident "_" None + | N.Anonymous -> Nameops.make_ident "_" None in X.xml_empty "REL" (add_sort_attribute false ["value",(string_of_int n) ; "binder",(N.string_of_id id) ; "id", next_id]) - | T.IsVar id -> + | T.Var id -> let depth = match get_depth_of_var (N.string_of_id id) with None -> "?" (* when printing via Show XML Proof or Print XML id *) @@ -328,33 +331,33 @@ let print_term inner_types l env csr = (add_sort_attribute false ["relUri",depth ^ "," ^ (N.string_of_id id) ; "id", next_id]) - | T.IsMeta n -> + | T.Meta n -> X.xml_empty "META" (add_sort_attribute false ["no",(string_of_int n) ; "id", next_id]) - | T.IsSort s -> + | T.Sort s -> X.xml_empty "SORT" ["value",(string_of_sort s) ; "id", next_id] - | T.IsCast (t1,t2) -> + | T.Cast (t1,t2) -> X.xml_nempty "CAST" (add_sort_attribute false ["id", next_id]) (force [< X.xml_nempty "term" [] (term_display idradix false l env t1) ; X.xml_nempty "type" [] (term_display idradix false l env t2) >] ) - | T.IsLetIn (nid,s,t,d)-> - let nid' = N.next_name_away nid (names_to_ids l) in + | T.LetIn (nid,s,t,d)-> + let nid' = Nameops.next_name_away nid (names_to_ids l) in X.xml_nempty "LETIN" (add_sort_attribute true ["id", next_id]) (force [< X.xml_nempty "term" [] (term_display idradix false l env s) ; X.xml_nempty "letintarget" ["binder",(N.string_of_id nid')] (term_display idradix false ((N.Name nid')::l) - (E.push_rel_def (N.Name nid', s, t) env) + (E.push_rel (N.Name nid', Some s, t) env) d ) >] ) - | T.IsProd (N.Name _ as nid, t1, t2) -> - let nid' = N.next_name_away nid (names_to_ids l) in + | T.Prod (N.Name _ as nid, t1, t2) -> + let nid' = Nameops.next_name_away nid (names_to_ids l) in X.xml_nempty "PROD" (add_type_attribute ["id", next_id]) (force [< X.xml_nempty "source" [] (term_display idradix false l env t1) ; @@ -365,49 +368,49 @@ let print_term inner_types l env csr = else ["binder",(N.string_of_id nid')]) (term_display idradix false ((N.Name nid')::l) - (E.push_rel_assum (N.Name nid', t1) env) + (E.push_rel (N.Name nid', None, t1) env) t2 ) >] ) - | T.IsProd (N.Anonymous as nid, t1, t2) -> + | T.Prod (N.Anonymous as nid, t1, t2) -> X.xml_nempty "PROD" (add_type_attribute ["id", next_id]) (force [< X.xml_nempty "source" [] (term_display idradix false l env t1) ; X.xml_nempty "target" [] (term_display idradix false (nid::l) - (E.push_rel_assum (nid, t1) env) + (E.push_rel (nid, None, t1) env) t2 ) >] ) - | T.IsLambda (N.Name _ as nid, t1, t2) -> - let nid' = N.next_name_away nid (names_to_ids l) in + | T.Lambda (N.Name _ as nid, t1, t2) -> + let nid' = Nameops.next_name_away nid (names_to_ids l) in X.xml_nempty "LAMBDA" (add_sort_attribute (not in_lambda) ["id",next_id]) (force [< X.xml_nempty "source" [] (term_display idradix false l env t1) ; X.xml_nempty "target" ["binder",(N.string_of_id nid')] (term_display idradix true ((N.Name nid')::l) - (E.push_rel_assum (N.Name nid', t1) env) + (E.push_rel (N.Name nid', None, t1) env) t2 ) >] ) - | T.IsLambda (N.Anonymous as nid, t1, t2) -> + | T.Lambda (N.Anonymous as nid, t1, t2) -> X.xml_nempty "LAMBDA" (add_sort_attribute (not in_lambda) ["id", next_id]) (force [< X.xml_nempty "source" [] (term_display idradix false l env t1) ; X.xml_nempty "target" [] (term_display idradix true (nid::l) - (E.push_rel_assum (nid, t1) env) + (E.push_rel (nid, None, t1) env) t2 ) >] ) - | T.IsApp (h,t) -> + | T.App (h,t) -> X.xml_nempty "APPLY" (add_sort_attribute true ["id", next_id]) (force [< (term_display idradix false l env h) ; @@ -415,23 +418,23 @@ let print_term inner_types l env csr = (fun x i -> [< (term_display idradix false l env x); i >]) t [<>]) >] ) - | T.IsConst sp -> + | T.Const sp -> X.xml_empty "CONST" (add_sort_attribute false ["uri",(uri_of_path sp Constant) ; "id", next_id]) - | T.IsMutInd (sp,i) -> + | T.Ind (sp,i) -> X.xml_empty "MUTIND" ["uri",(uri_of_path sp Inductive) ; "noType",(string_of_int i) ; "id", next_id] - | T.IsMutConstruct ((sp,i),j) -> + | T.Construct ((sp,i),j) -> X.xml_empty "MUTCONSTRUCT" (add_sort_attribute false ["uri",(uri_of_path sp Inductive) ; "noType",(string_of_int i) ; "noConstr",(string_of_int j) ; "id", next_id]) - | T.IsMutCase ((_,((sp,i),_,_,_,_)),ty,term,a) -> + | T.Case ({T.ci_ind=(sp,i)},ty,term,a) -> let (uri, typeno) = (uri_of_path sp Inductive),i in X.xml_nempty "MUTCASE" (add_sort_attribute true @@ -448,7 +451,7 @@ let print_term inner_types l env csr = ) a [<>] >] ) - | T.IsFix ((ai,i),((f,t,b) as rec_decl)) -> + | T.Fix ((ai,i),((f,t,b) as rec_decl)) -> X.xml_nempty "FIX" (add_sort_attribute true ["noFun", (string_of_int i) ; "id",next_id]) (force @@ -472,7 +475,7 @@ let print_term inner_types l env csr = [<>] >] ) - | T.IsCoFix (i,((f,t,b) as rec_decl)) -> + | T.CoFix (i,((f,t,b) as rec_decl)) -> X.xml_nempty "COFIX" (add_sort_attribute true ["noFun", (string_of_int i) ; "id",next_id]) (force @@ -494,7 +497,7 @@ let print_term inner_types l env csr = (Array.mapi (fun j x -> (x,t.(j),b.(j)) ) f ) [<>] >] ) - | T.IsEvar _ -> + | T.Evar _ -> Util.anomaly "Evar node in a term!!!" in (*CSC: ad l vanno andrebbero aggiunti i nomi da non *) @@ -590,7 +593,7 @@ let print_variable id body typ env inner_types = (* of mutual inductive definitions) *) (* returns a stream of XML tokens suitable to be pretty printed via Xml.pp *) (* Used only by print_mutual_inductive *) -let print_mutual_inductive_packet inner_types names env p = +let print_mutual_inductive_packet inner_types names env finite p = let module D = Declarations in let module N = Names in let module T = Term in @@ -598,8 +601,7 @@ let print_mutual_inductive_packet inner_types names env p = let {D.mind_consnames=consnames ; D.mind_typename=typename ; D.mind_nf_lc=lc ; - D.mind_nf_arity=arity ; - D.mind_finite=finite} = p + D.mind_nf_arity=arity} = p in [< X.xml_nempty "InductiveType" ["name",(N.string_of_id typename) ; @@ -628,7 +630,7 @@ let print_mutual_inductive_packet inner_types names env p = (* and nparams is the number of "parameters" in the arity of the *) (* mutual inductive types *) (* returns a stream of XML tokens suitable to be pretty printed via Xml.pp *) -let print_mutual_inductive packs fv hyps env inner_types = +let print_mutual_inductive finite packs fv hyps env inner_types = let module D = Declarations in let module E = Environ in let module X = Xml in @@ -642,7 +644,7 @@ let print_mutual_inductive packs fv hyps env inner_types = let env = List.fold_right (fun {D.mind_typename=typename ; D.mind_nf_arity=arity} env -> - E.push_rel_assum (N.Name typename, arity) env) + E.push_rel (N.Name typename, None, arity) env) (Array.to_list packs) env in @@ -655,7 +657,8 @@ let print_mutual_inductive packs fv hyps env inner_types = "params",(string_of_pvars fv hyps)] [< (Array.fold_right (fun x i -> - [< print_mutual_inductive_packet inner_types names env x ; i >] + [< print_mutual_inductive_packet + inner_types names env finite x ; i >] ) packs [< >] ) >] @@ -664,7 +667,7 @@ let print_mutual_inductive packs fv hyps env inner_types = let string_list_of_named_context_list = List.map - (function (n,_,_) -> Names.string_of_id (Names.basename n)) + (function (n,_,_) -> Names.string_of_id n) ;; let types_filename_of_filename = @@ -700,24 +703,25 @@ let pp_cmds_of_inner_types inner_types target_uri = (* Note: it is printed only (and directly) the most cooked available *) (* form of the definition (all the parameters are *) (* lambda-abstracted, but the object can still refer to variables) *) -let print sp fn = +let print qid fn = let module D = Declarations in let module G = Global in let module N = Names in let module Nt = Nametab in let module T = Term in let module X = Xml in - let (_,id) = Nt.repr_qualid sp in - let glob_ref = Nametab.locate sp in + let (_,id) = Nt.repr_qualid qid in + let glob_ref = Nametab.locate qid in let env = (Safe_typing.env_of_safe_env (G.safe_env ())) in reset_ids () ; let inner_types = ref [] in let sp,tag,pp_cmds = match glob_ref with - N.VarRef sp -> - let (body,typ) = G.lookup_named id in + Nt.VarRef id -> + let sp = Declare.find_section_variable id in + let (_,body,typ) = G.lookup_named id in sp,Variable,print_variable id body (T.body_of_type typ) env inner_types - | N.ConstRef sp -> + | Nt.ConstRef sp -> let {D.const_body=val0 ; D.const_type = typ ; D.const_hyps = hyps} = G.lookup_constant sp in let hyps = string_list_of_named_context_list hyps in @@ -728,12 +732,14 @@ let print sp fn = None -> print_axiom id typ [] hyps env inner_types | Some c -> print_definition id c typ [] hyps env inner_types end - | N.IndRef (sp,_) -> - let {D.mind_packets=packs ; D.mind_hyps=hyps} = G.lookup_mind sp in + | Nt.IndRef (sp,_) -> + let {D.mind_packets=packs ; + D.mind_hyps=hyps; + D.mind_finite=finite} = G.lookup_mind sp in let hyps = string_list_of_named_context_list hyps in sp,Inductive, - print_mutual_inductive packs [] hyps env inner_types - | N.ConstructRef _ -> + print_mutual_inductive finite packs [] hyps env inner_types + | Nt.ConstructRef _ -> Util.anomaly ("print: this should not happen") in Xml.pp pp_cmds fn ; @@ -795,11 +801,12 @@ let mkfilename dn sp ext = let module L = Library in let module S = System in let module N = Names in + let module No = Nameops in match dn with None -> None | Some basedir -> - let dir0 = N.extend_dirpath (N.dirpath sp) (N.basename sp) in - let dir = List.map N.string_of_id (N.repr_dirpath dir0) in + let dir0 = No.extend_dirpath (No.dirpath sp) (No.basename sp) in + let dir = List.map N.string_of_id (List.rev (N.repr_dirpath dir0)) in Some (basedir ^ join_dirs basedir dir ^ "." ^ ext) ;; @@ -844,13 +851,14 @@ let print_object lobj id sp dn fv env = | "INDUCTIVE" -> let {D.mind_packets=packs ; - D.mind_hyps = hyps + D.mind_hyps = hyps; + D.mind_finite = finite } = G.lookup_mind sp in let hyps = string_list_of_named_context_list hyps in - print_mutual_inductive packs fv hyps env inner_types + print_mutual_inductive finite packs fv hyps env inner_types | "VARIABLE" -> - let (_,(varentry,_)) = Declare.out_variable lobj in + let (_,(_,varentry,_)) = Declare.out_variable lobj in begin match varentry with Declare.SectionLocalDef body -> @@ -883,7 +891,7 @@ let rec print_library_segment state bprintleaf dn = List.iter (function (sp, node) -> print_if_verbose ("Print_library_segment: " ^ Names.string_of_path sp ^ "\n") ; - print_node node (Names.basename sp) sp bprintleaf dn ; + print_node node (Nameops.basename sp) sp bprintleaf dn ; print_if_verbose "\n" ) (List.rev state) (* print_node node id section_path bprintleaf directory_name *) @@ -921,10 +929,10 @@ with _ -> print_if_verbose ("EXCEPTION RAISED!!!\n"); end end | L.OpenedSection (dir,_) -> - let id = snd (Names.split_dirpath dir) in + let id = snd (Nameops.split_dirpath dir) in print_if_verbose ("OpenDir " ^ Names.string_of_id id ^ "\n") | L.ClosedSection (_,dir,state) -> - let id = snd (Names.split_dirpath dir) in + let id = snd (Nameops.split_dirpath dir) in print_if_verbose("ClosedDir " ^ Names.string_of_id id ^ "\n") ; if bprintleaf then begin @@ -992,13 +1000,14 @@ let printModule qid dn = let printSection id dn = let module L = Library in let module N = Names in + let module No = Nameops in let module X = Xml in - let sp = Lib.make_path id N.OBJ in + let sp = Lib.make_path id in let ls = let rec find_closed_section = function [] -> raise Not_found - | (_,Lib.ClosedSection (_,dir,ls))::_ when snd (N.split_dirpath dir) = id + | (_,Lib.ClosedSection (_,dir,ls))::_ when snd (No.split_dirpath dir) = id -> ls | _::t -> find_closed_section t in diff --git a/dev/top_printers.ml b/dev/top_printers.ml index cf35caf0c..d3dbb6b51 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -12,6 +12,7 @@ open System open Pp open Ast open Names +open Nameops open Sign open Univ open Proof_trees @@ -20,6 +21,7 @@ open Printer open Refiner open Tacmach open Term +open Termops open Clenv open Errors @@ -85,37 +87,37 @@ let cnt = ref 0 let constr_display csr = let rec term_display c = match kind_of_term c with - | IsRel n -> "Rel("^(string_of_int n)^")" - | IsMeta n -> "Meta("^(string_of_int n)^")" - | IsVar id -> "Var("^(string_of_id id)^")" - | IsSort s -> "Sort("^(sort_display s)^")" - | IsCast (c,t) -> "Cast("^(term_display c)^","^(term_display t)^")" - | IsProd (na,t,c) -> + | Rel n -> "Rel("^(string_of_int n)^")" + | Meta n -> "Meta("^(string_of_int n)^")" + | Var id -> "Var("^(string_of_id id)^")" + | Sort s -> "Sort("^(sort_display s)^")" + | Cast (c,t) -> "Cast("^(term_display c)^","^(term_display t)^")" + | Prod (na,t,c) -> "Prod("^(name_display na)^","^(term_display t)^","^(term_display c)^")\n" - | IsLambda (na,t,c) -> + | Lambda (na,t,c) -> "Lambda("^(name_display na)^","^(term_display t)^","^(term_display c)^")\n" - | IsLetIn (na,b,t,c) -> + | LetIn (na,b,t,c) -> "LetIn("^(name_display na)^","^(term_display b)^"," ^(term_display t)^","^(term_display c)^")" - | IsApp (c,l) -> "App("^(term_display c)^","^(array_display l)^")\n" - | IsEvar (e,l) -> "Evar("^(string_of_int e)^","^(array_display l)^")" - | IsConst c -> "Const("^(string_of_path c)^")" - | IsMutInd (sp,i) -> + | App (c,l) -> "App("^(term_display c)^","^(array_display l)^")\n" + | Evar (e,l) -> "Evar("^(string_of_int e)^","^(array_display l)^")" + | Const c -> "Const("^(string_of_path c)^")" + | Ind (sp,i) -> "MutInd("^(string_of_path sp)^","^(string_of_int i)^")" - | IsMutConstruct ((sp,i),j) -> + | Construct ((sp,i),j) -> "MutConstruct(("^(string_of_path sp)^","^(string_of_int i)^")," ^(string_of_int j)^")" - | IsMutCase (ci,p,c,bl) -> + | Case (ci,p,c,bl) -> "MutCase(<abs>,"^(term_display p)^","^(term_display c)^"," ^(array_display bl)^")" - | IsFix ((t,i),(lna,tl,bl)) -> + | Fix ((t,i),(lna,tl,bl)) -> "Fix(([|"^(Array.fold_right (fun x i -> (string_of_int x)^(if not(i="") then (";"^i) else "")) t "")^"|],"^(string_of_int i)^")," ^(array_display tl)^"," ^(Array.fold_right (fun x i -> (name_display x)^(if not(i="") then (";"^i) else "")) lna "")^"," ^(array_display bl)^")" - | IsCoFix(i,(lna,tl,bl)) -> + | CoFix(i,(lna,tl,bl)) -> "CoFix("^(string_of_int i)^")," ^(array_display tl)^"," ^(Array.fold_right (fun x i -> (name_display x)^(if not(i="") @@ -146,53 +148,53 @@ open Format;; let print_pure_constr csr = let rec term_display c = match kind_of_term c with - | IsRel n -> print_string "#"; print_int n - | IsMeta n -> print_string "Meta("; print_int n; print_string ")" - | IsVar id -> print_string (string_of_id id) - | IsSort s -> sort_display s - | IsCast (c,t) -> open_hovbox 1; + | Rel n -> print_string "#"; print_int n + | Meta n -> print_string "Meta("; print_int n; print_string ")" + | Var id -> print_string (string_of_id id) + | Sort s -> sort_display s + | Cast (c,t) -> open_hovbox 1; print_string "("; (term_display c); print_cut(); print_string "::"; (term_display t); print_string ")"; close_box() - | IsProd (Name(id),t,c) -> + | Prod (Name(id),t,c) -> open_hovbox 1; print_string"("; print_string (string_of_id id); print_string ":"; box_display t; print_string ")"; print_cut(); box_display c; close_box() - | IsProd (Anonymous,t,c) -> + | Prod (Anonymous,t,c) -> print_string"("; box_display t; print_cut(); print_string "->"; box_display c; print_string ")"; - | IsLambda (na,t,c) -> + | Lambda (na,t,c) -> print_string "["; name_display na; print_string ":"; box_display t; print_string "]"; print_cut(); box_display c; - | IsLetIn (na,b,t,c) -> + | LetIn (na,b,t,c) -> print_string "["; name_display na; print_string "="; box_display b; print_cut(); print_string ":"; box_display t; print_string "]"; print_cut(); box_display c; - | IsApp (c,l) -> + | App (c,l) -> print_string "("; box_display c; Array.iter (fun x -> print_space (); box_display x) l; print_string ")" - | IsEvar (e,l) -> print_string "Evar#"; print_int e; print_string "{"; + | Evar (e,l) -> print_string "Evar#"; print_int e; print_string "{"; Array.iter (fun x -> print_space (); box_display x) l; print_string"}" - | IsConst c -> print_string "Cons("; + | Const c -> print_string "Cons("; sp_display c; print_string ")" - | IsMutInd (sp,i) -> + | Ind (sp,i) -> print_string "Ind("; sp_display sp; print_string ","; print_int i; print_string ")" - | IsMutConstruct ((sp,i),j) -> + | Construct ((sp,i),j) -> print_string "Constr("; sp_display sp; print_string ","; print_int i; print_string ","; print_int j; print_string ")" - | IsMutCase (ci,p,c,bl) -> + | Case (ci,p,c,bl) -> open_vbox 0; print_string "<"; box_display p; print_string ">"; print_cut(); print_string "Case"; @@ -203,7 +205,7 @@ let print_pure_constr csr = print_cut(); print_string "end"; close_box() - | IsFix ((t,i),(lna,tl,bl)) -> + | Fix ((t,i),(lna,tl,bl)) -> print_string "Fix("; print_int i; print_string ")"; print_cut(); open_vbox 0; @@ -217,7 +219,7 @@ let print_pure_constr csr = print_cut() done in print_string"{"; print_fix(); print_string"}" - | IsCoFix(i,(lna,tl,bl)) -> + | CoFix(i,(lna,tl,bl)) -> print_string "CoFix("; print_int i; print_string ")"; print_cut(); open_vbox 0; @@ -244,7 +246,7 @@ let print_pure_constr csr = | Anonymous -> print_string "_" (* Remove the top names for library and Scratch to avoid long names *) and sp_display sp = let ls = - match List.map string_of_id (repr_dirpath (dirpath sp)) with + match List.rev (List.map string_of_id (repr_dirpath (dirpath sp))) with ("Scratch"::l)-> l | ("Coq"::_::l) -> l | l -> l diff --git a/kernel/closure.ml b/kernel/closure.ml index 283b60e28..4bb9c941f 100644 --- a/kernel/closure.ml +++ b/kernel/closure.ml @@ -13,9 +13,7 @@ open Pp open Term open Names open Environ -open Instantiate open Univ -open Evd open Esubst @@ -67,7 +65,6 @@ module type RedFlagsSig = sig type reds type red_kind val fBETA : red_kind - val fEVAR : red_kind val fDELTA : red_kind val fIOTA : red_kind val fZETA : red_kind @@ -96,11 +93,10 @@ module RedFlags = (struct r_evar : bool; r_iota : bool } - type red_kind = BETA | DELTA | EVAR | IOTA | ZETA + type red_kind = BETA | DELTA | IOTA | ZETA | CONST of constant | VAR of identifier let fBETA = BETA let fDELTA = DELTA - let fEVAR = EVAR let fIOTA = IOTA let fZETA = ZETA let fCONST sp = CONST sp @@ -120,7 +116,6 @@ module RedFlags = (struct let (l1,l2) = red.r_const in { red with r_const = l1, Sppred.add sp l2 } | IOTA -> { red with r_iota = true } - | EVAR -> { red with r_evar = true } | ZETA -> { red with r_zeta = true } | VAR id -> let (l1,l2) = red.r_const in @@ -133,7 +128,6 @@ module RedFlags = (struct let (l1,l2) = red.r_const in { red with r_const = l1, Sppred.remove sp l2 } | IOTA -> { red with r_iota = false } - | EVAR -> { red with r_evar = false } | ZETA -> { red with r_zeta = false } | VAR id -> let (l1,l2) = red.r_const in @@ -155,7 +149,6 @@ module RedFlags = (struct let c = Idpred.mem id l in incr_cnt c delta | ZETA -> incr_cnt red.r_zeta zeta - | EVAR -> incr_cnt red.r_zeta evar | IOTA -> incr_cnt red.r_iota iota | DELTA -> (* Used for Rel/Var defined in context *) incr_cnt red.r_delta delta @@ -174,7 +167,8 @@ end : RedFlagsSig) open RedFlags -let betadeltaiota_red = mkflags [fBETA;fDELTA;fZETA;fEVAR;fIOTA] +let betadeltaiota_red = mkflags [fBETA;fDELTA;fZETA;fIOTA] +let betadeltaiotanolet_red = mkflags [fBETA;fDELTA;fIOTA] let betaiota_red = mkflags [fBETA;fIOTA] let beta_red = mkflags [fBETA] let betaiotazeta_red = mkflags [fBETA;fIOTA;fZETA] @@ -248,7 +242,7 @@ let unfold_red sp = a LetIn expression is Letin reduction *) type red_kind = - BETA | DELTA | ZETA | EVAR | IOTA + BETA | DELTA | ZETA | IOTA | CONST of constant_path list | CONSTBUT of constant_path list | VAR of identifier | VARBUT of identifier @@ -270,7 +264,6 @@ let rec red_add red = function { red with r_const = true, list_union cl l1, l2; r_zeta = true; r_evar = true }) | IOTA -> { red with r_iota = true } - | EVAR -> { red with r_evar = true } | ZETA -> { red with r_zeta = true } | VAR id -> (match red.r_const with @@ -331,6 +324,7 @@ let no_flag = (UNIFORM,no_red) let beta = (UNIFORM,beta_red) let betaiota = (UNIFORM,betaiota_red) let betadeltaiota = (UNIFORM,betadeltaiota_red) +let betadeltaiotanolet = (UNIFORM,betadeltaiotanolet_red) let hnf_flags = (SIMPL,betaiotazeta_red) let unfold_flags sp = (UNIFORM, unfold_red sp) @@ -362,7 +356,6 @@ let red_under (md,r) rk = * mapped to constr. 'a infos implements a cache for constants and * abstractions, storing a representation (of type 'a) of the body of * this constant or abstraction. - * * i_evc is the set of constraints for existential variables * * i_tab is the cache table of the results * * i_repr is the function to get the representation from the current * state of the cache and the body of the constant. The result @@ -379,20 +372,19 @@ let red_under (md,r) rk = * instantiations (cbv or lazy) are. *) -type 'a table_key = - | ConstBinding of constant - | EvarBinding of existential - | VarBinding of identifier - | FarRelBinding of int +type table_key = + | ConstKey of constant + | VarKey of identifier + | FarRelKey of int + (* FarRel: index in the rel_context part of _initial_ environment *) -type ('a, 'b) infos = { +type 'a infos = { i_flags : flags; - i_repr : ('a, 'b) infos -> constr -> 'a; + i_repr : 'a infos -> constr -> 'a; i_env : env; - i_evc : 'b evar_map; i_rels : int * (int * constr) list; i_vars : (identifier * constr) list; - i_tab : ('a table_key, 'a) Hashtbl.t } + i_tab : (table_key, 'a) Hashtbl.t } let info_flags info = info.i_flags @@ -403,18 +395,16 @@ let ref_value_cache info ref = try let body = match ref with - | FarRelBinding n -> + | FarRelKey n -> let (s,l) = info.i_rels in lift n (List.assoc (s-n) l) - | VarBinding id -> List.assoc id info.i_vars - | EvarBinding evc -> existential_value info.i_evc evc - | ConstBinding cst -> constant_value info.i_env cst + | VarKey id -> List.assoc id info.i_vars + | ConstKey cst -> constant_value info.i_env cst in let v = info.i_repr info body in Hashtbl.add info.i_tab ref v; Some v with | Not_found (* List.assoc *) - | NotInstantiatedEvar (* Evar *) | NotEvaluableConst _ (* Const *) -> None @@ -438,11 +428,10 @@ let defined_rels flags env = env (0,[]) (* else (0,[])*) -let create mk_cl flgs env sigma = +let create mk_cl flgs env = { i_flags = flgs; i_repr = mk_cl; i_env = env; - i_evc = sigma; i_rels = defined_rels flgs env; i_vars = defined_vars flgs env; i_tab = Hashtbl.create 17 } @@ -549,7 +538,7 @@ let rec stack_nth s p = match s with (* Lazy reduction: the one used in kernel operations *) (* type of shared terms. fconstr and frterm are mutually recursive. - * Clone of the Generic.term structure, but completely mutable, and + * Clone of the constr structure, but completely mutable, and * annotated with booleans (true when we noticed that the term is * normal and neutral) FLIFT is a delayed shift; allows sharing * between 2 lifted copies of a given term FCLOS is a delayed @@ -565,7 +554,7 @@ and fterm = | FRel of int | FAtom of constr | FCast of fconstr * fconstr - | FFlex of freference + | FFlex of table_key | FInd of inductive | FConstruct of constructor | FApp of fconstr * fconstr array @@ -577,17 +566,11 @@ and fterm = | FLambda of name * fconstr * fconstr * constr * fconstr subs | FProd of name * fconstr * fconstr * constr * fconstr subs | FLetIn of name * fconstr * fconstr * fconstr * constr * fconstr subs + | FEvar of existential_key * fconstr array | FLIFT of int * fconstr | FCLOS of constr * fconstr subs | FLOCKED -and freference = - (* only vars as args of FConst ... exploited for caching *) - | FConst of constant - | FEvar of existential_key * fconstr array - | FVar of identifier - | FFarRel of int (* index in the rel_context part of _initial_ environment *) - let fterm_of v = v.term let set_whnf v = if v.norm = Red then v.norm <- Whnf let set_cstr v = if v.norm = Red then v.norm <- Cstr @@ -646,19 +629,22 @@ let clos_rel e i = | Inl(n,mt) -> lift_fconstr n mt | Inr(k,None) -> {norm=Red; term= FRel k} | Inr(k,Some p) -> - lift_fconstr (k-p) {norm=Norm;term=FFlex(FFarRel p)} + lift_fconstr (k-p) {norm=Norm;term=FFlex(FarRelKey p)} (* Optimization: do not enclose variables in a closure. Makes variable access much faster *) -let mk_clos e t = +let rec mk_clos e t = match kind_of_term t with - | IsRel i -> clos_rel e i - | IsVar x -> { norm = Red; term = FFlex (FVar x) } - | IsMeta _ | IsSort _ -> { norm = Norm; term = FAtom t } - | (IsMutInd _|IsMutConstruct _|IsFix _|IsCoFix _ - |IsLambda _|IsProd _) -> + | Rel i -> clos_rel e i + | Var x -> { norm = Red; term = FFlex (VarKey x) } + | Meta _ | Sort _ -> { norm = Norm; term = FAtom t } + | Ind sp -> { norm = Norm; term = FInd sp } + | Construct sp -> { norm = Cstr; term = FConstruct sp } + | Evar (ev,args) -> + { norm = Cstr; term = FEvar (ev,Array.map (mk_clos e) args) } + | (Fix _|CoFix _|Lambda _|Prod _) -> {norm = Cstr; term = FCLOS(t,e)} - | (IsApp _|IsMutCase _|IsCast _|IsConst _|IsEvar _|IsLetIn _) -> + | (App _|Case _|Cast _|Const _|LetIn _) -> {norm = Red; term = FCLOS(t,e)} let mk_clos_vect env v = Array.map (mk_clos env) v @@ -669,55 +655,46 @@ let mk_clos_vect env v = Array.map (mk_clos env) v Could be used insted of mk_clos. *) let mk_clos_deep clos_fun env t = match kind_of_term t with - | IsRel i -> clos_rel env i - | (IsVar _|IsMeta _ | IsSort _) -> mk_clos env t - | IsCast (a,b) -> + | (Rel _|Ind _|Construct _|Var _|Meta _ | Sort _|Evar _) -> + mk_clos env t + | Cast (a,b) -> { norm = Red; term = FCast (clos_fun env a, clos_fun env b)} - | IsApp (f,v) -> + | App (f,v) -> { norm = Red; term = FApp (clos_fun env f, Array.map (clos_fun env) v) } - | IsMutInd sp -> - { norm = Norm; term = FInd sp } - | IsMutConstruct sp -> - { norm = Norm; term = FConstruct sp } - | IsConst sp -> + | Const sp -> { norm = Red; - term = FFlex (FConst sp) } - | IsEvar (n,v) -> - { norm = Red; - term = FFlex (FEvar (n, Array.map (clos_fun env) v)) } - - | IsMutCase (ci,p,c,v) -> + term = FFlex (ConstKey sp) } + | Case (ci,p,c,v) -> { norm = Red; term = FCases (ci, clos_fun env p, clos_fun env c, Array.map (clos_fun env) v) } - | IsFix (op,(lna,tys,bds)) -> + | Fix (op,(lna,tys,bds)) -> let env' = subs_liftn (Array.length bds) env in { norm = Cstr; term = FFix (op,(lna, Array.map (clos_fun env) tys, Array.map (clos_fun env') bds), bds, env) } - | IsCoFix (op,(lna,tys,bds)) -> + | CoFix (op,(lna,tys,bds)) -> let env' = subs_liftn (Array.length bds) env in { norm = Cstr; term = FCoFix (op,(lna, Array.map (clos_fun env) tys, Array.map (clos_fun env') bds), bds, env) } - - | IsLambda (n,t,c) -> + | Lambda (n,t,c) -> { norm = Cstr; term = FLambda (n, clos_fun env t, clos_fun (subs_lift env) c, c, env) } - | IsProd (n,t,c) -> + | Prod (n,t,c) -> { norm = Cstr; term = FProd (n, clos_fun env t, clos_fun (subs_lift env) c, c, env) } - | IsLetIn (n,b,t,c) -> + | LetIn (n,b,t,c) -> { norm = Red; term = FLetIn (n, clos_fun env b, clos_fun env t, clos_fun (subs_lift env) c, @@ -727,24 +704,22 @@ let mk_clos_deep clos_fun env t = let rec to_constr constr_fun lfts v = match v.term with | FRel i -> mkRel (reloc_rel i lfts) - | FFlex (FFarRel p) -> mkRel (reloc_rel p lfts) - | FFlex (FVar x) -> mkVar x + | FFlex (FarRelKey p) -> mkRel (reloc_rel p lfts) + | FFlex (VarKey x) -> mkVar x | FAtom c -> (match kind_of_term c with - | IsSort s -> mkSort s - | IsMeta m -> mkMeta m + | Sort s -> mkSort s + | Meta m -> mkMeta m | _ -> assert false) | FCast (a,b) -> mkCast (constr_fun lfts a, constr_fun lfts b) - | FFlex (FConst op) -> mkConst op - | FFlex (FEvar (n,args)) -> - mkEvar (n, Array.map (constr_fun lfts) args) - | FInd op -> mkMutInd op - | FConstruct op -> mkMutConstruct op + | FFlex (ConstKey op) -> mkConst op + | FInd op -> mkInd op + | FConstruct op -> mkConstruct op | FCases (ci,p,c,ve) -> - mkMutCase (ci, constr_fun lfts p, - constr_fun lfts c, - Array.map (constr_fun lfts) ve) + mkCase (ci, constr_fun lfts p, + constr_fun lfts c, + Array.map (constr_fun lfts) ve) | FFix (op,(lna,tys,bds),_,_) -> let lfts' = el_liftn (Array.length bds) lfts in mkFix (op, (lna, Array.map (constr_fun lfts) tys, @@ -766,6 +741,7 @@ let rec to_constr constr_fun lfts v = mkLetIn (n, constr_fun lfts b, constr_fun lfts t, constr_fun (el_lift lfts) c) + | FEvar (ev,args) -> mkEvar(ev,Array.map (constr_fun lfts) args) | FLIFT (k,a) -> to_constr constr_fun (el_shft k lfts) a | FCLOS (t,env) -> let fr = mk_clos_deep mk_clos env t in @@ -952,23 +928,23 @@ let rec knh m stk = | (None, stk') -> (m,stk')) | FCast(t,_) -> knh t stk (* cases where knh stops *) - | (FFlex _|FLetIn _) -> (m, stk) - | (FRel _|FAtom _) -> (set_norm m; (m, stk)) - | (FLambda _|FConstruct _|FCoFix _|FInd _|FProd _) -> + | (FFlex _|FLetIn _|FInd _|FConstruct _|FEvar _) -> (m, stk) + | (FRel _|FAtom _|FInd _) -> (set_norm m; (m, stk)) + | (FLambda _|FCoFix _|FProd _) -> (set_whnf m; (m, stk)) (* The same for pure terms *) and knht e t stk = match kind_of_term t with - | IsApp(a,b) -> + | App(a,b) -> knht e a (append_stack (mk_clos_vect e b) stk) - | IsMutCase(ci,p,t,br) -> + | Case(ci,p,t,br) -> knht e t (Zcase(ci, mk_clos e p, mk_clos_vect e br)::stk) - | IsFix _ -> knh (mk_clos_deep mk_clos e t) stk - | IsCast(a,b) -> knht e a stk - | IsRel n -> knh (clos_rel e n) stk - | (IsLambda _|IsProd _|IsMutConstruct _|IsCoFix _|IsMutInd _| - IsLetIn _|IsConst _|IsVar _|IsEvar _|IsMeta _|IsSort _) -> + | Fix _ -> knh (mk_clos_deep mk_clos e t) stk + | Cast(a,b) -> knht e a stk + | Rel n -> knh (clos_rel e n) stk + | (Lambda _|Prod _|Construct _|CoFix _|Ind _| + LetIn _|Const _|Var _|Evar _|Meta _|Sort _) -> (mk_clos_deep mk_clos e t, stk) @@ -981,30 +957,23 @@ let rec knr info m stk = (match get_arg m stk with (Some(depth,arg),s) -> knit info (subs_shift_cons(depth,e,arg)) f s | (None,s) -> (m,s)) - | FFlex(FConst sp) when can_red info stk (fCONST sp) -> - (match ref_value_cache info (ConstBinding sp) with + | FFlex(ConstKey sp) when can_red info stk (fCONST sp) -> + (match ref_value_cache info (ConstKey sp) with Some v -> kni info v stk | None -> (set_norm m; (m,stk))) - | FFlex(FEvar (n,args)) when can_red info stk fEVAR -> -(* In the case of evars, if it is not defined, then we do not set the - flag to Norm, because it may be instantiated later on *) - let evar = (n, Array.map term_of_fconstr args) in - (match ref_value_cache info (EvarBinding evar) with - Some v -> kni info v stk - | None -> (m,stk)) - | FFlex(FVar id) when can_red info stk (fVAR id) -> - (match ref_value_cache info (VarBinding id) with + | FFlex(VarKey id) when can_red info stk (fVAR id) -> + (match ref_value_cache info (VarKey id) with Some v -> kni info v stk | None -> (set_norm m; (m,stk))) - | FFlex(FFarRel k) when can_red info stk fDELTA -> - (match ref_value_cache info (FarRelBinding k) with + | FFlex(FarRelKey k) when can_red info stk fDELTA -> + (match ref_value_cache info (FarRelKey k) with Some v -> kni info v stk | None -> (set_norm m; (m,stk))) | FConstruct(ind,c) when can_red info stk fIOTA -> (match strip_update_shift_app m stk with - (depth, args, Zcase(((*cn*) npar,_),_,br)::s) -> - assert (npar>=0); - let rargs = drop_parameters depth npar args in + (depth, args, Zcase(ci,_,br)::s) -> + assert (ci.ci_npar>=0); + let rargs = drop_parameters depth ci.ci_npar args in kni info br.(c-1) (rargs@s) | (_, cargs, Zfix(fx,par)::s) -> let rarg = fapp_stack(m,cargs) in @@ -1014,7 +983,7 @@ let rec knr info m stk = | (_,args,s) -> (m,args@s)) | FCoFix _ when can_red info stk fIOTA -> (match strip_update_shift_app m stk with - (_, args, ((Zcase((cn,_),_,br)::_) as stk')) -> + (_, args, ((Zcase _::_) as stk')) -> let efx = contract_fix_vect m.term in kni info efx (args@stk') | (_,args,s) -> (m,args@s)) @@ -1060,8 +1029,7 @@ and down_then_up info m stk = | FCoFix(n,(na,ftys,fbds),bds,e) -> FCoFix(n,(na, Array.map (kl info) ftys, Array.map (kl info) fbds),bds,e) - | FFlex(FEvar(i,args)) -> - FFlex(FEvar(i, Array.map (kl info) args)) + | FEvar(i,args) -> FEvar(i, Array.map (kl info) args) | t -> t in {norm=Norm;term=nt} in (* Precondition: m.norm = Norm *) @@ -1081,18 +1049,12 @@ let norm_val info v = let inject = mk_clos (ESID 0) (* cache of constants: the body is computed only when needed. *) -type 'a clos_infos = (fconstr, 'a) infos - -let create_clos_infos flgs env sigma = - create (fun _ -> inject) flgs env sigma - -let unfold_reference info = function - | FConst op -> ref_value_cache info (ConstBinding op) - | FEvar (n,v) -> - let evar = (n, Array.map (norm_val info) v) in - ref_value_cache info (EvarBinding evar) - | FVar id -> ref_value_cache info (VarBinding id) - | FFarRel p -> ref_value_cache info (FarRelBinding p) +type clos_infos = fconstr infos + +let create_clos_infos flgs env = + create (fun _ -> inject) flgs env + +let unfold_reference = ref_value_cache (* Head normal form. *) diff --git a/kernel/closure.mli b/kernel/closure.mli index 16de949af..4abd866c3 100644 --- a/kernel/closure.mli +++ b/kernel/closure.mli @@ -12,7 +12,6 @@ open Pp open Names open Term -open Evd open Environ open Esubst (*i*) @@ -48,7 +47,6 @@ module type RedFlagsSig = sig of Constbut/Varbut should be unfolded (there may be several such Constbut/Varbut *) val fBETA : red_kind - val fEVAR : red_kind val fDELTA : red_kind val fIOTA : red_kind val fZETA : red_kind @@ -84,6 +82,7 @@ val beta_red : reds val betaiota_red : reds val betadeltaiota_red : reds val betaiotazeta_red : reds +val betadeltaiotanolet_red : reds (*s Reduction function specification. *) @@ -105,25 +104,24 @@ val no_flag : flags val beta : flags val betaiota : flags val betadeltaiota : flags +val betadeltaiotanolet : flags val hnf_flags : flags val unfold_flags : evaluable_global_reference -> flags (***********************************************************************) -type 'a table_key = - | ConstBinding of constant - | EvarBinding of existential - | VarBinding of identifier - | FarRelBinding of int +type table_key = + | ConstKey of constant + | VarKey of identifier + | FarRelKey of int + (* FarRel: index in the rel_context part of _initial_ environment *) -type ('a,'b) infos -val ref_value_cache: ('a,'b) infos -> 'a table_key -> 'a option -val info_flags: ('a,'b) infos -> flags -val infos_under: ('a,'b) infos -> ('a,'b) infos -val create: - (('a,'b) infos -> constr -> 'a) -> - flags -> env -> 'b evar_map -> ('a,'b) infos +type 'a infos +val ref_value_cache: 'a infos -> table_key -> 'a option +val info_flags: 'a infos -> flags +val infos_under: 'a infos -> 'a infos +val create: ('a infos -> constr -> 'a) -> flags -> env -> 'a infos (***********************************************************************) (*s A [stack] is a context of arguments, arguments are pushed by @@ -165,7 +163,7 @@ type fterm = | FRel of int | FAtom of constr | FCast of fconstr * fconstr - | FFlex of freference + | FFlex of table_key | FInd of inductive | FConstruct of constructor | FApp of fconstr * fconstr array @@ -177,16 +175,11 @@ type fterm = | FLambda of name * fconstr * fconstr * constr * fconstr subs | FProd of name * fconstr * fconstr * constr * fconstr subs | FLetIn of name * fconstr * fconstr * fconstr * constr * fconstr subs + | FEvar of existential_key * fconstr array | FLIFT of int * fconstr | FCLOS of constr * fconstr subs | FLOCKED -and freference = - | FConst of constant - | FEvar of existential_key * fconstr array - | FVar of identifier - | FFarRel of int - (* To lazy reduce a constr, create a ['a clos_infos] with [create_cbv_infos], inject the term to reduce with [inject]; then use @@ -197,28 +190,28 @@ val fterm_of : fconstr -> fterm val term_of_fconstr : fconstr -> constr (* Global and local constant cache *) -type 'a clos_infos -val create_clos_infos : flags -> env -> 'a evar_map -> 'a clos_infos +type clos_infos +val create_clos_infos : flags -> env -> clos_infos (* Reduction function *) (* [norm_val] is for strong normalization *) -val norm_val : 'a clos_infos -> fconstr -> constr +val norm_val : clos_infos -> fconstr -> constr (* [whd_val] is for weak head normalization *) -val whd_val : 'a clos_infos -> fconstr -> constr +val whd_val : clos_infos -> fconstr -> constr (* Conversion auxiliary functions to do step by step normalisation *) (* [fhnf] and [fnf_apply] are for weak head normalization but staying in [fconstr] world to perform step by step weak head normalization *) -val fhnf: 'a clos_infos -> fconstr -> int * fconstr * fconstr stack -val fhnf_apply : 'a clos_infos -> +val fhnf: clos_infos -> fconstr -> int * fconstr * fconstr stack +val fhnf_apply : clos_infos -> int -> fconstr -> fconstr stack -> int * fconstr * fconstr stack (* [unfold_reference] unfolds references in a [fconstr] *) -val unfold_reference : 'a clos_infos -> freference -> fconstr option +val unfold_reference : clos_infos -> table_key -> fconstr option (***********************************************************************) (*i This is for lazy debug *) @@ -232,9 +225,9 @@ val mk_clos_deep : (fconstr subs -> constr -> fconstr) -> fconstr subs -> constr -> fconstr -val knr: 'a clos_infos -> fconstr -> fconstr stack -> +val knr: clos_infos -> fconstr -> fconstr stack -> fconstr * fconstr stack -val kl: 'a clos_infos -> fconstr -> fconstr +val kl: clos_infos -> fconstr -> fconstr val to_constr : (lift -> fconstr -> constr) -> lift -> fconstr -> constr diff --git a/kernel/cooking.ml b/kernel/cooking.ml index 79420e040..4fb1663d0 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -14,7 +14,6 @@ open Names open Term open Sign open Declarations -open Instantiate open Environ open Reduction @@ -47,61 +46,59 @@ let failure () = let modify_opers replfun (constl,indl,cstrl) = let rec substrec c = - let op, cl = splay_constr c in - let cl' = Array.map substrec cl in - match op with - | OpMutCase (n,(spi,a,b,c,d) as oper) -> + let c' = map_constr substrec c in + match kind_of_term c' with + | Case (ci,p,t,br) -> (try - match List.assoc spi indl with - | DO_ABSTRACT (spi',abs_vars) -> - let n' = Array.length abs_vars + n in - gather_constr (OpMutCase (n',(spi',a,b,c,d)),cl') + match List.assoc ci.ci_ind indl with + | DO_ABSTRACT (ind,abs_vars) -> + let n' = Array.length abs_vars + ci.ci_npar in + let ci' = { ci with + ci_ind = ind; + ci_npar = n' } in + mkCase (ci',p,t,br) | _ -> raise Not_found with - | Not_found -> gather_constr (op,cl')) + | Not_found -> c') - | OpMutInd spi -> - assert (Array.length cl=0); + | Ind spi -> (try (match List.assoc spi indl with | NOT_OCCUR -> failure () | DO_ABSTRACT (oper',abs_vars) -> - mkApp (mkMutInd oper', abs_vars) + mkApp (mkInd oper', abs_vars) | DO_REPLACE _ -> assert false) with - | Not_found -> mkMutInd spi) + | Not_found -> c') - | OpMutConstruct spi -> - assert (Array.length cl=0); + | Construct spi -> (try (match List.assoc spi cstrl with | NOT_OCCUR -> failure () | DO_ABSTRACT (oper',abs_vars) -> - mkApp (mkMutConstruct oper', abs_vars) + mkApp (mkConstruct oper', abs_vars) | DO_REPLACE _ -> assert false) with - | Not_found -> mkMutConstruct spi) + | Not_found -> c') - | OpConst sp -> - assert (Array.length cl=0); + | Const sp -> (try (match List.assoc sp constl with | NOT_OCCUR -> failure () | DO_ABSTRACT (oper',abs_vars) -> mkApp (mkConst oper', abs_vars) - | DO_REPLACE cb -> substrec (replfun sp cb cl')) + | DO_REPLACE cb -> substrec (replfun (sp,cb))) with - | Not_found -> mkConst sp) + | Not_found -> c') - | _ -> gather_constr (op, cl') + | _ -> c' in if (constl,indl,cstrl) = ([],[],[]) then fun x -> x else substrec let expmod_constr modlist c = - let sigma = Evd.empty in let simpfun = if modlist = ([],[],[]) then fun x -> x else nf_betaiota in - let expfun sp cb args = + let expfun (sp,cb) = if cb.const_opaque then errorlabstrm "expmod_constr" [< 'sTR"Cannot unfold the value of "; @@ -110,14 +107,12 @@ let expmod_constr modlist c = 'sTR"and then require that theorems which use them"; 'sPC; 'sTR"be transparent" >]; match cb.const_body with - | Some body -> - instantiate_constr cb.const_hyps body (Array.to_list args) + | Some body -> body | None -> assert false in - let c' = - modify_opers expfun modlist c in + let c' = modify_opers expfun modlist c in match kind_of_term c' with - | IsCast (val_0,typ) -> mkCast (simpfun val_0,simpfun typ) + | Cast (value,typ) -> mkCast (simpfun value,simpfun typ) | _ -> simpfun c' let expmod_type modlist c = @@ -141,7 +136,13 @@ let cook_constant env r = let cb = r.d_from in let typ = expmod_type r.d_modlist cb.const_type in let body = option_app (expmod_constr r.d_modlist) cb.const_body in - let hyps = List.map (fun (sp,c,t) -> (basename sp,c,t)) cb.const_hyps in - let hyps = map_named_context (expmod_constr r.d_modlist) hyps in + let hyps = + Sign.fold_named_context + (fun d ctxt -> + Sign.add_named_decl + (map_named_declaration (expmod_constr r.d_modlist) d) + ctxt) + cb.const_hyps + empty_named_context in let body,typ = abstract_constant r.d_abstract hyps (body,typ) in (body, typ, cb.const_constraints, cb.const_opaque) diff --git a/kernel/declarations.ml b/kernel/declarations.ml index 47f65d4a3..a9b8737bb 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -6,99 +6,61 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id$ *) +(*i $Id$ i*) +(*i*) open Names open Univ open Term open Sign +(*i*) -(* Constant entries *) +(* This module defines the types of global declarations. This includes + global constants/axioms and mutual inductive definitions *) + +(*s Constants (internal representation) (Definition/Axiom) *) type constant_body = { - const_kind : path_kind; + const_hyps : section_context; (* New: younger hyp at top *) const_body : constr option; const_type : types; - const_hyps : section_context; const_constraints : constraints; const_opaque : bool } -let is_defined cb = - match cb.const_body with Some _ -> true | _ -> false - -let is_opaque cb = cb.const_opaque - -(*s Global and local constant declaration. *) - -type constant_entry = { - const_entry_body : constr; - const_entry_type : constr option; - const_entry_opaque : bool } - -type local_entry = - | LocalDef of constr - | LocalAssum of constr - -(* Inductive entries *) +(*s Inductive types (internal representation with redundant + information). *) type recarg = | Param of int | Norec | Mrec of int - | Imbr of inductive * recarg list + | Imbr of inductive * (recarg list) + +(* [mind_typename] is the name of the inductive; [mind_arity] is + the arity generalized over global parameters; [mind_lc] is the list + of types of constructors generalized over global parameters and + relative to the global context enriched with the arities of the + inductives *) type one_inductive_body = { - mind_consnames : identifier array; mind_typename : identifier; - mind_nf_lc : types array; + mind_nparams : int; + mind_params_ctxt : rel_context; + mind_nrealargs : int; mind_nf_arity : types; - (* lc and arity as given by user if not in nf; useful e.g. for Ensemble.v *) - mind_user_lc : types array option; - mind_user_arity : types option; + mind_user_arity : types; mind_sort : sorts; - mind_nrealargs : int; mind_kelim : sorts_family list; + mind_consnames : identifier array; + mind_nf_lc : types array; (* constrs and arity with pre-expanded ccl *) + mind_user_lc : types array; mind_listrec : (recarg list) array; - mind_finite : bool; - mind_nparams : int; - mind_params_ctxt : rel_context } + } type mutual_inductive_body = { - mind_kind : path_kind; + mind_finite : bool; mind_ntypes : int; mind_hyps : section_context; mind_packets : one_inductive_body array; mind_constraints : constraints; mind_singl : constr option } - -let mind_type_finite mib i = mib.mind_packets.(i).mind_finite - -let mind_user_lc mip = match mip.mind_user_lc with - | None -> mip.mind_nf_lc - | Some lc -> lc - -let mind_user_arity mip = match mip.mind_user_arity with - | None -> mip.mind_nf_arity - | Some a -> a - -(*s Declaration. *) - -type one_inductive_entry = { - mind_entry_nparams : int; - mind_entry_params : (identifier * local_entry) list; - mind_entry_typename : identifier; - mind_entry_arity : constr; - mind_entry_consnames : identifier list; - mind_entry_lc : constr list } - -type mutual_inductive_entry = { - mind_entry_finite : bool; - mind_entry_inds : one_inductive_entry list } - -let mind_nth_type_packet mib n = mib.mind_packets.(n) - -let mind_arities_context mib = - Array.to_list - (Array.map (* No need to lift, arities contain no de Bruijn *) - (fun mip -> (Name mip.mind_typename, None, mind_user_arity mip)) - mib.mind_packets) diff --git a/kernel/declarations.mli b/kernel/declarations.mli index 735f6f141..a9b8737bb 100644 --- a/kernel/declarations.mli +++ b/kernel/declarations.mli @@ -21,27 +21,14 @@ open Sign (*s Constants (internal representation) (Definition/Axiom) *) type constant_body = { - const_kind : path_kind; + const_hyps : section_context; (* New: younger hyp at top *) const_body : constr option; const_type : types; - const_hyps : section_context; (* New: younger hyp at top *) const_constraints : constraints; const_opaque : bool } -val is_defined : constant_body -> bool - -(*s Global and local constant declaration. *) - -type constant_entry = { - const_entry_body : constr; - const_entry_type : constr option; - const_entry_opaque : bool } - -type local_entry = - | LocalDef of constr - | LocalAssum of constr - -(*s Inductive types (internal representation). *) +(*s Inductive types (internal representation with redundant + information). *) type recarg = | Param of int @@ -56,56 +43,24 @@ type recarg = inductives *) type one_inductive_body = { - mind_consnames : identifier array; mind_typename : identifier; - mind_nf_lc : types array; (* constrs and arity with pre-expanded ccl *) + mind_nparams : int; + mind_params_ctxt : rel_context; + mind_nrealargs : int; mind_nf_arity : types; - mind_user_lc : types array option; - mind_user_arity : types option; + mind_user_arity : types; mind_sort : sorts; - mind_nrealargs : int; mind_kelim : sorts_family list; + mind_consnames : identifier array; + mind_nf_lc : types array; (* constrs and arity with pre-expanded ccl *) + mind_user_lc : types array; mind_listrec : (recarg list) array; - mind_finite : bool; - mind_nparams : int; - mind_params_ctxt : rel_context } + } type mutual_inductive_body = { - mind_kind : path_kind; + mind_finite : bool; mind_ntypes : int; mind_hyps : section_context; mind_packets : one_inductive_body array; mind_constraints : constraints; mind_singl : constr option } - -val mind_type_finite : mutual_inductive_body -> int -> bool -val mind_user_lc : one_inductive_body -> types array -val mind_user_arity : one_inductive_body -> types -val mind_nth_type_packet : mutual_inductive_body -> int -> one_inductive_body - -val mind_arities_context : mutual_inductive_body -> rel_declaration list - -(*s Declaration of inductive types. *) - -(* Assume the following definition in concrete syntax: -\begin{verbatim} -Inductive I1 [x1:X1;...;xn:Xn] : A1 := c11 : T11 | ... | c1n1 : T1n1 -... -with Ip [x1:X1;...;xn:Xn] : Ap := cp1 : Tp1 | ... | cpnp : Tpnp. -\end{verbatim} -then, in $i^{th}$ block, [mind_entry_params] is [[xn:Xn;...;x1:X1]]; -[mind_entry_arity] is [Ai], defined in context [[[x1:X1;...;xn:Xn]]; -[mind_entry_lc] is [Ti1;...;Tini], defined in context [[A'1;...;A'p;x1:X1;...;xn:Xn]] where [A'i] is [Ai] generalized over [[x1:X1;...;xn:Xn]]. -*) - -type one_inductive_entry = { - mind_entry_nparams : int; - mind_entry_params : (identifier * local_entry) list; - mind_entry_typename : identifier; - mind_entry_arity : constr; - mind_entry_consnames : identifier list; - mind_entry_lc : constr list } - -type mutual_inductive_entry = { - mind_entry_finite : bool; - mind_entry_inds : one_inductive_entry list } diff --git a/kernel/environ.ml b/kernel/environ.ml index 98f54337f..757fa34b0 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -8,7 +8,6 @@ (* $Id$ *) -open Pp open Util open Names open Sign @@ -30,64 +29,55 @@ type globals = { env_locals : (global * section_path) list; env_imports : compilation_unit_name list } -type context = { - env_named_context : named_context; - env_rel_context : rel_context } - type env = { - env_context : context; - env_globals : globals; - env_universes : universes } - -let empty_context = { - env_named_context = empty_named_context; - env_rel_context = empty_rel_context } + env_globals : globals; + env_named_context : named_context; + env_rel_context : rel_context; + env_universes : universes } let empty_env = { - env_context = empty_context; env_globals = { env_constants = Spmap.empty; env_inductives = Spmap.empty; env_locals = []; env_imports = [] }; + env_named_context = empty_named_context; + env_rel_context = empty_rel_context; env_universes = initial_universes } let universes env = env.env_universes -let context env = env.env_context -let named_context env = env.env_context.env_named_context -let rel_context env = env.env_context.env_rel_context +let named_context env = env.env_named_context +let rel_context env = env.env_rel_context (* Construction functions. *) -let map_context f env = - let context = env.env_context in - { env with - env_context = { - context with - env_named_context = map_named_context f context.env_named_context ; - env_rel_context = map_rel_context f context.env_rel_context } } - let named_context_app f env = { env with - env_context = { env.env_context with - env_named_context = f env.env_context.env_named_context } } - -let change_hyps = named_context_app + env_named_context = f env.env_named_context } let push_named_decl d = named_context_app (add_named_decl d) -let push_named_def def = named_context_app (add_named_def def) -let push_named_assum decl = named_context_app (add_named_assum decl) +let push_named_assum (id,ty) = push_named_decl (id,None,ty) let pop_named_decl id = named_context_app (pop_named_decl id) let rel_context_app f env = { env with - env_context = { env.env_context with - env_rel_context = f env.env_context.env_rel_context } } + env_rel_context = f env.env_rel_context } let reset_context env = { env with - env_context = { env_named_context = empty_named_context; - env_rel_context = empty_rel_context} } + env_named_context = empty_named_context; + env_rel_context = empty_rel_context } + +let reset_with_named_context ctxt env = + { env with + env_named_context = ctxt; + env_rel_context = empty_rel_context } + +let reset_rel_context env = + { env with + env_rel_context = empty_rel_context } + + let fold_named_context f env a = snd (Sign.fold_named_context @@ -97,33 +87,9 @@ let fold_named_context f env a = let fold_named_context_reverse f a env = Sign.fold_named_context_reverse f a (named_context env) -let process_named_context f env = - Sign.fold_named_context - (fun d env -> f env d) (named_context env) (reset_context env) - -let process_named_context_both_sides f env = - fold_named_context_both_sides f (named_context env) (reset_context env) - let push_rel d = rel_context_app (add_rel_decl d) -let push_rel_def def = rel_context_app (add_rel_def def) -let push_rel_assum decl = rel_context_app (add_rel_assum decl) -let push_rels ctxt = rel_context_app (concat_rel_context ctxt) -let push_rels_assum decl env = - rel_context_app (List.fold_right add_rel_assum decl) env - - -let push_rel_context_to_named_context env = - let sign0 = env.env_context.env_named_context in - let (subst,_,sign) = - List.fold_right - (fun (na,c,t) (subst,avoid,sign) -> - let na = if na = Anonymous then Name(id_of_string"_") else na in - let id = next_name_away na avoid in - ((mkVar id)::subst,id::avoid, - add_named_decl (id,option_app (substl subst) c,type_app (substl subst) t) - sign)) - env.env_context.env_rel_context ([],ids_of_named_context sign0,sign0) - in subst, (named_context_app (fun _ -> sign) env) +let push_rel_context ctxt = fold_rel_context push_rel ctxt +let push_rel_assum (id,ty) = push_rel (id,None,ty) let push_rec_types (lna,typarray,_) env = let ctxt = @@ -131,40 +97,11 @@ let push_rec_types (lna,typarray,_) env = Array.fold_left (fun e assum -> push_rel_assum assum e) env ctxt -let push_named_rec_types (lna,typarray,_) env = - let ctxt = - array_map2_i - (fun i na t -> - match na with - | Name id -> (id, type_app (lift i) t) - | Anonymous -> anomaly "Fix declarations must be named") - lna typarray in - Array.fold_left - (fun e assum -> push_named_assum assum e) env ctxt - -let reset_rel_context env = - { env with - env_context = { env_named_context = env.env_context.env_named_context; - env_rel_context = empty_rel_context} } - let fold_rel_context f env a = snd (List.fold_right (fun d (env,e) -> (push_rel d env, f env d e)) (rel_context env) (reset_rel_context env,a)) -let process_rel_context f env = - List.fold_right (fun d env -> f env d) - (rel_context env) (reset_rel_context env) - -let instantiate_named_context = instantiate_sign - -let ids_of_context env = - (ids_of_rel_context env.env_context.env_rel_context) - @ (ids_of_named_context env.env_context.env_named_context) - -let names_of_rel_context env = - names_of_rel_context env.env_context.env_rel_context - let set_universes g env = if env.env_universes == g then env else { env with env_universes = g } @@ -193,20 +130,12 @@ let add_mind sp mib env = { env with env_globals = new_globals } (* Access functions. *) - -let lookup_named_type id env = - lookup_id_type id env.env_context.env_named_context - -let lookup_named_value id env = - lookup_id_value id env.env_context.env_named_context -let lookup_named id env = lookup_id id env.env_context.env_named_context +let lookup_rel n env = + Sign.lookup_rel n env.env_rel_context -let lookup_rel_type n env = - Sign.lookup_rel_type n env.env_context.env_rel_context - -let lookup_rel_value n env = - Sign.lookup_rel_value n env.env_context.env_rel_context +let lookup_named id env = + Sign.lookup_named id env.env_named_context let lookup_constant sp env = Spmap.find sp env.env_globals.env_constants @@ -214,15 +143,14 @@ let lookup_constant sp env = let lookup_mind sp env = Spmap.find sp env.env_globals.env_inductives - (* Lookup of section variables *) let lookup_constant_variables c env = let cmap = lookup_constant c env in - Sign.instance_from_section_context cmap.const_hyps + Sign.instance_from_named_context cmap.const_hyps let lookup_inductive_variables (sp,i) env = let mis = lookup_mind sp env in - Sign.instance_from_section_context mis.mind_hyps + Sign.instance_from_named_context mis.mind_hyps let lookup_constructor_variables (ind,_) env = lookup_inductive_variables ind env @@ -231,28 +159,18 @@ let lookup_constructor_variables (ind,_) env = let vars_of_global env constr = match kind_of_term constr with - IsVar id -> [id] - | IsConst sp -> + Var id -> [id] + | Const sp -> List.map destVar (Array.to_list (lookup_constant_variables sp env)) - | IsMutInd ind -> + | Ind ind -> List.map destVar (Array.to_list (lookup_inductive_variables ind env)) - | IsMutConstruct cstr -> + | Construct cstr -> List.map destVar (Array.to_list (lookup_constructor_variables cstr env)) | _ -> [] -let rec global_varsl env l constr = - let l = vars_of_global env constr @ l in - fold_constr (global_varsl env) l constr - -let global_vars env = global_varsl env [] - -let global_vars_decl env = function - | (_, None, t) -> global_vars env t - | (_, Some c, t) -> (global_vars env c)@(global_vars env t) - let global_vars_set env constr = let rec filtrec acc c = let vl = vars_of_global env c in @@ -261,32 +179,12 @@ let global_vars_set env constr = in filtrec Idset.empty constr - -exception Occur - -let occur_in_global env id constr = - let vars = vars_of_global env constr in - if List.mem id vars then raise Occur - -let occur_var env s c = - let rec occur_rec c = - occur_in_global env s c; - iter_constr occur_rec c - in - try occur_rec c; false with Occur -> true - -let occur_var_in_decl env hyp (_,c,typ) = - match c with - | None -> occur_var env hyp (body_of_type typ) - | Some body -> - occur_var env hyp (body_of_type typ) || - occur_var env hyp body - -(* [keep_hyps sign ids] keeps the part of the signature [sign] which +(* [keep_hyps env ids] keeps the part of the section context of [env] which contains the variables of the set [ids], and recursively the variables contained in the types of the needed variables. *) -let rec keep_hyps env needed = function +let keep_hyps env needed = + let rec keep_rec needed = function | (id,copt,t as d) ::sign when Idset.mem id needed -> let globc = match copt with @@ -295,170 +193,63 @@ let rec keep_hyps env needed = function let needed' = Idset.union (global_vars_set env (body_of_type t)) (Idset.union globc needed) in - d :: (keep_hyps env needed' sign) - | _::sign -> keep_hyps env needed sign - | [] -> [] - -(* 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 env 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 env c2@l) in - let env' = push_rel (Name s',None,c1) env in - mkProd (Name s', c1, rename_bound_var env' (s'::l) c2) - else - let env' = push_rel (Name s,None,c1) env in - mkProd (Name s, c1, rename_bound_var env' l c2) - | IsProd (Anonymous,c1,c2) -> - let env' = push_rel (Anonymous,None,c1) env in - mkProd (Anonymous, c1, rename_bound_var env' l c2) - | IsCast (c,t) -> mkCast (rename_bound_var env l c, t) - | x -> c - -(* First character of a constr *) - -let lowercase_first_char id = String.lowercase (first_char id) - -(* id_of_global gives the name of the given sort oper *) -let sp_of_global env = function - | VarRef sp -> sp - | ConstRef sp -> sp - | IndRef (sp,tyi) -> - (* Does not work with extracted inductive types when the first - inductive is logic : if tyi=0 then basename sp else *) - let mib = lookup_mind sp env in - let mip = mind_nth_type_packet mib tyi in - make_path (dirpath sp) mip.mind_typename CCI - | ConstructRef ((sp,tyi),i) -> - let mib = lookup_mind sp env in - let mip = mind_nth_type_packet mib tyi in - assert (i <= Array.length mip.mind_consnames && i > 0); - make_path (dirpath sp) mip.mind_consnames.(i-1) CCI - -let id_of_global env ref = basename (sp_of_global env ref) - -let hdchar env c = - 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 - | IsApp (f,l) -> hdrec k f - | IsConst sp -> - let c = lowercase_first_char (basename sp) in - if c = "?" then "y" else c - | IsMutInd ((sp,i) as x) -> - if i=0 then - lowercase_first_char (basename sp) - else - lowercase_first_char (id_of_global env (IndRef x)) - | IsMutConstruct ((sp,i) as x) -> - lowercase_first_char (id_of_global env (ConstructRef x)) - | 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") - | IsFix ((_,i),(lna,_,_)) -> - let id = match lna.(i) with Name id -> id | _ -> assert false in - lowercase_first_char id - | IsCoFix (i,(lna,_,_)) -> - let id = match lna.(i) with Name id -> id | _ -> assert false in - lowercase_first_char id - | IsMeta _|IsEvar _|IsMutCase (_, _, _, _) -> "y" - in - hdrec 0 c - -let id_of_name_using_hdchar env a = function - | Anonymous -> id_of_string (hdchar env a) - | Name id -> id - -let named_hd env a = function - | Anonymous -> Name (id_of_string (hdchar env a)) - | x -> x - -let named_hd_type env a = named_hd env (body_of_type a) - -let prod_name env (n,a,b) = mkProd (named_hd_type env a n, a, b) -let lambda_name env (n,a,b) = mkLambda (named_hd_type env a n, a, b) - -let prod_create env (a,b) = mkProd (named_hd_type env a Anonymous, a, b) -let lambda_create env (a,b) = mkLambda (named_hd_type env a Anonymous, a, b) - -let name_assumption env (na,c,t) = - match c with - | None -> (named_hd_type env t na, None, t) - | Some body -> (named_hd env body na, c, t) - -let mkProd_or_LetIn_name env b d = mkProd_or_LetIn (name_assumption env d) b -let mkLambda_or_LetIn_name env b d = mkLambda_or_LetIn (name_assumption env d)b - -let name_context env hyps = - snd - (List.fold_left - (fun (env,hyps) d -> - let d' = name_assumption env d in (push_rel d' env, d' :: hyps)) - (env,[]) (List.rev hyps)) - -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) + d :: (keep_rec needed' sign) + | _::sign -> keep_rec needed sign + | [] -> [] in + keep_rec needed (named_context env) -let it_mkProd_or_LetIn_name env b hyps = - it_mkProd_or_LetIn b (name_context env hyps) - -let it_mkLambda_or_LetIn_name env b hyps = - it_mkLambda_or_LetIn b (name_context env hyps) - -let it_mkNamedProd_or_LetIn = it_named_context_quantifier mkNamedProd_or_LetIn -let it_mkNamedLambda_or_LetIn = it_named_context_quantifier mkNamedLambda_or_LetIn - -let it_mkNamedProd_wo_LetIn = it_named_context_quantifier mkNamedProd_wo_LetIn - -let make_all_name_different env = - let avoid = ref (ids_of_named_context (named_context env)) in - process_rel_context - (fun newenv (na,c,t) -> - let id = next_name_away na !avoid in - avoid := id::!avoid; - push_rel (Name id,c,t) newenv) - env (* Constants *) -let defined_constant env sp = is_defined (lookup_constant sp env) - +let defined_constant env sp = + match (lookup_constant sp env).const_body with + Some _ -> true + | None -> false + let opaque_constant env sp = (lookup_constant sp env).const_opaque (* A global const is evaluable if it is defined and not opaque *) let evaluable_constant env sp = - try - defined_constant env sp && not (opaque_constant env sp) + try defined_constant env sp with Not_found -> false (* A local const is evaluable if it is defined and not opaque *) let evaluable_named_decl env id = try - lookup_named_value id env <> None + match lookup_named id env with + (_,Some _,_) -> true + | _ -> false with Not_found -> false let evaluable_rel_decl env n = - try - lookup_rel_value n env <> None + try + match lookup_rel n env with + (_,Some _,_) -> true + | _ -> false with Not_found -> false +(* constant_type gives the type of a constant *) +let constant_type env sp = + let cb = lookup_constant sp env in + cb.const_type + +type const_evaluation_result = NoBody | Opaque + +exception NotEvaluableConst of const_evaluation_result + +let constant_value env sp = + let cb = lookup_constant sp env in + if cb.const_opaque then raise (NotEvaluableConst Opaque); + match cb.const_body with + | Some body -> body + | None -> raise (NotEvaluableConst NoBody) + +let constant_opt_value env cst = + try Some (constant_value env cst) + with NotEvaluableConst _ -> None + (*s Modules (i.e. compiled environments). *) type compiled_env = { @@ -498,8 +289,7 @@ let import_constraints g sp cst = try merge_constraints cst g with UniverseInconsistency -> - errorlabstrm "import_constraints" - [< 'sTR "Universe Inconsistency during import of"; 'sPC; pr_sp sp >] + error "import_constraints: Universe Inconsistency during import" let import cenv env = check_imports env cenv.cenv_needed; @@ -526,16 +316,14 @@ type unsafe_judgment = { uj_val : constr; uj_type : types } +let make_judge v tj = + { uj_val = v; + uj_type = tj } + +let j_val j = j.uj_val +let j_type j = body_of_type j.uj_type + type unsafe_type_judgment = { utj_val : constr; utj_type : sorts } -(*s Memory use of an environment. *) - -open Printf - -let mem env = - let glb = env.env_globals in - h 0 [< 'sTR (sprintf "%dk (cst = %dk / ind = %dk / unv = %dk)" - (size_kb env) (size_kb glb.env_constants) - (size_kb glb.env_inductives) (size_kb env.env_universes)) >] diff --git a/kernel/environ.mli b/kernel/environ.mli index 761f196c0..83915157a 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -21,173 +21,92 @@ open Sign informations added in environments, and that is why we speak here of ``unsafe'' environments. *) -type context type env -val empty_context : context val empty_env : env val universes : env -> universes -val context : env -> context val rel_context : env -> rel_context val named_context : env -> named_context (* This forgets named and rel contexts *) val reset_context : env -> env +(* This forgets rel context and sets a new named context *) +val reset_with_named_context : named_context -> env -> env (*s This concerns only local vars referred by names [named_context] *) val push_named_decl : named_declaration -> env -> env -val push_named_assum : identifier * types -> env -> env -val push_named_def : identifier * constr * types -> env -> env -val change_hyps : (named_context -> named_context) -> env -> env -val instantiate_named_context : named_context -> constr list -> (identifier * constr) list val pop_named_decl : identifier -> env -> env (*s This concerns only local vars referred by indice [rel_context] *) val push_rel : rel_declaration -> env -> env -val push_rel_assum : name * types -> env -> env -val push_rel_def : name * constr * types -> env -> env -val push_rels : rel_context -> env -> env -val push_rels_assum : (name * types) list -> env -> env -val names_of_rel_context : env -> names_context - -(*s Returns also the substitution to be applied to rel's *) -val push_rel_context_to_named_context : env -> constr list * env +val push_rel_context : rel_context -> env -> env (*s Push the types of a (co-)fixpoint to [rel_context] *) val push_rec_types : rec_declaration -> env -> env -(*s Push the types of a (co-)fixpoint to [named_context] *) -val push_named_rec_types : rec_declaration -> env -> env - -(* Gives identifiers in [named_context] and [rel_context] *) -val ids_of_context : env -> identifier list -val map_context : (constr -> constr) -> env -> env - -(*s Recurrence on [named_context] *) -val fold_named_context : (env -> named_declaration -> 'a -> 'a) -> env -> 'a -> 'a -val process_named_context : (env -> named_declaration -> env) -> env -> env +(*s Recurrence on [named_context]: older declarations processed first *) +val fold_named_context : + (env -> named_declaration -> 'a -> 'a) -> env -> 'a -> 'a (* Recurrence on [named_context] starting from younger decl *) -val fold_named_context_reverse : ('a -> named_declaration -> 'a) -> 'a -> env -> 'a - -(* [process_named_context_both_sides f env] iters [f] on the named - declarations of [env] taking as argument both the initial segment, the - middle value and the tail segment *) -val process_named_context_both_sides : - (env -> named_declaration -> named_context -> env) -> env -> env +val fold_named_context_reverse : + ('a -> named_declaration -> 'a) -> 'a -> env -> 'a (*s Recurrence on [rel_context] *) val fold_rel_context : (env -> rel_declaration -> 'a -> 'a) -> env -> 'a -> 'a -val process_rel_context : (env -> rel_declaration -> env) -> env -> env (*s add entries to environment *) val set_universes : universes -> env -> env val add_constraints : constraints -> env -> env val add_constant : - section_path -> constant_body -> env -> env + constant -> constant_body -> env -> env val add_mind : section_path -> mutual_inductive_body -> env -> env -(*s Looks up in environment *) - -(* Looks up in the context of local vars referred by names ([named_context]) *) -(* raises [Not_found] if the identifier is not found *) -val lookup_named_type : identifier -> env -> types -val lookup_named_value : identifier -> env -> constr option -val lookup_named : identifier -> env -> constr option * types +(*s Lookups in environment *) (* Looks up in the context of local vars referred by indice ([rel_context]) *) (* raises [Not_found] if the index points out of the context *) -val lookup_rel_type : int -> env -> name * types -val lookup_rel_value : int -> env -> constr option +val lookup_rel : int -> env -> rel_declaration + +(* Looks up in the context of local vars referred by names ([named_context]) *) +(* raises [Not_found] if the identifier is not found *) +val lookup_named : variable -> env -> named_declaration (* Looks up in the context of global constant names *) (* raises [Not_found] if the required path is not found *) val lookup_constant : constant -> env -> constant_body +(*s [constant_value env c] raises [NotEvaluableConst Opaque] if + [c] is opaque and [NotEvaluableConst NoBody] if it has no + body and [Not_found] if it does not exist in [env] *) +type const_evaluation_result = NoBody | Opaque +exception NotEvaluableConst of const_evaluation_result + +val constant_value : env -> constant -> constr +val constant_type : env -> constant -> types +val constant_opt_value : env -> constant -> constr option + (* Looks up in the context of global inductive names *) (* raises [Not_found] if the required path is not found *) val lookup_mind : section_path -> env -> mutual_inductive_body -(* Looks up the array of section variables used by a global (constant, - inductive or constructor). *) -val lookup_constant_variables : constant -> env -> constr array -val lookup_inductive_variables : inductive -> env -> constr array -val lookup_constructor_variables : constructor -> env -> constr array - -(*s Miscellanous *) - -val sp_of_global : env -> global_reference -> section_path - -val id_of_global : env -> global_reference -> identifier - -val make_all_name_different : env -> env - -(*s Functions creating names for anonymous names *) - -val id_of_name_using_hdchar : env -> constr -> name -> identifier -(* [named_hd env t na] just returns [na] is it defined, otherwise it - creates a name built from [t] (e.g. ["n"] if [t] is [nat]) *) - -val named_hd : env -> constr -> name -> name - -(* [lambda_name env (na,t,c)] builds [[[x:t]c] where [x] is created - using [named_hd] if [na] is [Anonymous]; [prod_name env (na,t,c)] - works similarly but build a product; for [it_lambda_name env c - sign] and [it_prod_name env c sign], more recent types should come - first in [sign]; none of these functions substitute named - variables in [c] by de Bruijn indices *) - -val lambda_name : env -> name * types * constr -> constr -val prod_name : env -> name * types * constr -> constr - -val mkLambda_or_LetIn_name : env -> constr -> rel_declaration -> constr -val mkProd_or_LetIn_name : env -> constr -> rel_declaration -> 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 - -val it_mkNamedLambda_or_LetIn : constr -> named_context -> constr -val it_mkNamedProd_or_LetIn : constr -> named_context -> constr -val it_mkNamedProd_wo_LetIn : constr -> named_context -> constr - -(* [lambda_create env (t,c)] builds [[x:t]c] where [x] is a name built - from [t]; [prod_create env (t,c)] builds [(x:t)c] where [x] is a - name built from [t] *) +(* [global_vars_set c] returns the list of [id]'s occurring as [VAR + id] in [c] *) +val global_vars_set : env -> constr -> Idset.t +(* the constr must be an atomic construction *) +val vars_of_global : env -> constr -> identifier list -val lambda_create : env -> types * constr -> constr -val prod_create : env -> types * constr -> constr +val keep_hyps : env -> Idset.t -> section_context val defined_constant : env -> constant -> bool val evaluable_constant : env -> constant -> bool -val evaluable_named_decl : env -> identifier -> bool +val evaluable_named_decl : env -> variable -> bool val evaluable_rel_decl : env -> int -> bool -(*s Ocurrence of section variables. *) -(* [(occur_var id c)] returns [true] if variable [id] occurs free - in c, [false] otherwise *) -val occur_var : env -> identifier -> constr -> bool -val occur_var_in_decl : env -> identifier -> named_declaration -> bool - -(* [global_vars c] returns the list of [id]'s occurring as [VAR id] in [c] *) -val global_vars : env -> constr -> identifier list - -(* [global_vars_decl d] returns the list of [id]'s occurring as [VAR - id] in declaration [d] (type and body if any) *) -val global_vars_decl : env -> named_declaration -> identifier list -val global_vars_set : env -> constr -> Idset.t - -val keep_hyps : env -> Idset.t -> named_context -> named_context - -val rename_bound_var : env -> identifier list -> constr -> constr - (*s Modules. *) type compiled_env @@ -203,10 +122,10 @@ type unsafe_judgment = { uj_val : constr; uj_type : types } +val make_judge : constr -> types -> unsafe_judgment +val j_val : unsafe_judgment -> constr +val j_type : unsafe_judgment -> types + type unsafe_type_judgment = { utj_val : constr; utj_type : sorts } - -(*s Displays the memory use of an environment. *) - -val mem : env -> Pp.std_ppcmds diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 33a26c800..1255e9787 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -10,24 +10,34 @@ open Util open Names +open Univ open Term open Declarations open Inductive open Sign open Environ -open Instantiate open Reduction open Typeops -(* In the following, each time an [evar_map] is required, then [Evd.empty] - is given, since inductive types are typed in an environment without - existentials. *) - (* [check_constructors_names id s cl] checks that all the constructors names appearing in [l] are not present in the set [s], and returns the new set of names. The name [id] is the name of the current inductive type, used when reporting the error. *) +(*s Declaration. *) + +type one_inductive_entry = { + mind_entry_nparams : int; + mind_entry_params : (identifier * local_entry) list; + mind_entry_typename : identifier; + mind_entry_arity : constr; + mind_entry_consnames : identifier list; + mind_entry_lc : constr list } + +type mutual_inductive_entry = { + mind_entry_finite : bool; + mind_entry_inds : one_inductive_entry list } + (***********************************************************************) (* Various well-formedness check for inductive declarations *) @@ -85,7 +95,7 @@ let mind_extract_params = decompose_prod_n_assum let mind_check_arities env mie = let check_arity id c = - if not (is_arity env Evd.empty c) then + if not (is_arity env c) then raise (InductiveError (NotAnArity id)) in List.iter @@ -98,6 +108,143 @@ let mind_check_wellformed env mie = mind_check_arities env mie (***********************************************************************) +(***********************************************************************) + +(* Typing the arities and constructor types *) + +let is_info_arity env c = + match dest_arity env c with + | (_,Prop Null) -> false + | (_,Prop Pos) -> true + | (_,Type _) -> true + +let is_info_type env t = + let s = t.utj_type in + if s = mk_Set then true + else if s = mk_Prop then false + else + try is_info_arity env t.utj_val + with UserError _ -> true + +(* [infos] is a sequence of pair [islogic,issmall] for each type in + the product of a constructor or arity *) + +let is_small infos = List.for_all (fun (logic,small) -> small) infos +let is_logic_constr infos = List.for_all (fun (logic,small) -> logic) infos +let is_logic_arity infos = + List.for_all (fun (logic,small) -> logic || small) infos + +let is_unit arinfos constrsinfos = + match constrsinfos with (* One info = One constructor *) + | [constrinfos] -> is_logic_constr constrinfos && is_logic_arity arinfos + | _ -> false + +let rec infos_and_sort env t = + match kind_of_term t with + | Prod (name,c1,c2) -> + let (varj,_) = infer_type env c1 in + let env1 = Environ.push_rel (name,None,varj.utj_val) env in + let logic = not (is_info_type env varj) in + let small = Term.is_small varj.utj_type in + (logic,small) :: (infos_and_sort env1 c2) + | Cast (c,_) -> infos_and_sort env c + | _ -> [] + +let small_unit constrsinfos (env_ar_par,short_arity) = + let issmall = List.for_all is_small constrsinfos in + let arinfos = infos_and_sort env_ar_par short_arity in + let isunit = is_unit arinfos constrsinfos in + issmall, isunit + +(* This (re)computes informations relevant to extraction and the sort of an + arity or type constructor; we do not to recompute universes constraints *) + +(* [smax] is the max of the sorts of the products of the constructor type *) + +let enforce_type_constructor arsort smax cst = + match smax, arsort with + | Type uc, Type ua -> enforce_geq ua uc cst + | _,_ -> cst + +let type_one_constructor env_ar_par params arsort c = + let infos = infos_and_sort env_ar_par c in + + (* Each constructor is typed-checked here *) + let (j,cst) = infer_type env_ar_par c in + let full_cstr_type = it_mkProd_or_LetIn j.utj_val params in + + (* If the arity is at some level Type arsort, then the sort of the + constructor must be below arsort; here we consider constructors with the + global parameters (which add a priori more constraints on their sort) *) + let cst2 = enforce_type_constructor arsort j.utj_type cst in + + (infos, full_cstr_type, cst2) + +let infer_constructor_packet env_ar params short_arity arsort vc = + let env_ar_par = push_rel_context params env_ar in + let (constrsinfos,jlc,cst) = + List.fold_right + (fun c (infosl,l,cst) -> + let (infos,ct,cst') = + type_one_constructor env_ar_par params arsort c in + (infos::infosl,ct::l, Constraint.union cst cst')) + vc + ([],[],Constraint.empty) in + let vc' = Array.of_list jlc in + let issmall,isunit = small_unit constrsinfos (env_ar_par,short_arity) in + (issmall,isunit,vc', cst) + +let type_inductive env mie = + (* We first type params and arity of each inductive definition *) + (* This allows to build the environment of arities and to share *) + (* the set of constraints *) + let cst, arities, rev_params_arity_list = + List.fold_left + (fun (cst,arities,l) ind -> + (* Params are typed-checked here *) + let params = ind.mind_entry_params in + let env_params, params, cst1 = + infer_local_decls env params in + (* Arities (without params) are typed-checked here *) + let arity, cst2 = + infer_type env_params ind.mind_entry_arity in + (* We do not need to generate the universe of full_arity; if + later, after the validation of the inductive definition, + full_arity is used as argument or subject to cast, an + upper universe will be generated *) + let id = ind.mind_entry_typename in + let full_arity = it_mkProd_or_LetIn arity.utj_val params in + Constraint.union cst (Constraint.union cst1 cst2), + Sign.add_rel_decl (Name id, None, full_arity) arities, + (params, id, full_arity, arity.utj_val)::l) + (Constraint.empty,empty_rel_context,[]) + mie.mind_entry_inds in + + let env_arities = push_rel_context arities env in + + let params_arity_list = List.rev rev_params_arity_list in + + (* Now, we type the constructors (without params) *) + let inds,cst = + List.fold_right2 + (fun ind (params,id,full_arity,short_arity) (inds,cst) -> + let (_,arsort) = dest_arity env full_arity in + let lc = ind.mind_entry_lc in + let (issmall,isunit,lc',cst') = + infer_constructor_packet env_arities params short_arity arsort lc + in + let nparams = ind.mind_entry_nparams in + let consnames = ind.mind_entry_consnames in + let ind' = (params,nparams,id,full_arity,consnames,issmall,isunit,lc') + in + (ind'::inds, Constraint.union cst cst')) + mie.mind_entry_inds + params_arity_list + ([],cst) in + (env_arities, inds, cst) + +(***********************************************************************) +(***********************************************************************) let allowed_sorts issmall isunit = function | Type _ -> @@ -118,7 +265,7 @@ exception IllFormedInd of ill_formed_ind let explain_ind_err ntyp env0 nbpar c err = let (lpar,c') = mind_extract_params nbpar c in - let env = push_rels lpar env0 in + let env = push_rel_context lpar env0 in match err with | LocalNonPos kt -> raise (InductiveError (NonPos (env,c',mkRel (kt+nbpar)))) @@ -150,8 +297,8 @@ let check_correct_par env hyps nparams ntypes n l largs = | [] -> () | (_,Some _,_)::hyps -> check k (index+1) hyps | _::hyps -> - match kind_of_term (whd_betadeltaiotaeta env Evd.empty lpar.(k)) with - | IsRel w when w = index -> check (k-1) (index+1) hyps + match kind_of_term (whd_betadeltaiota env lpar.(k)) with + | Rel w when w = index -> check (k-1) (index+1) hyps | _ -> raise (IllFormedInd (LocalNonPar (k+1,l))) in check (nparams-1) (n-nhyps) hyps; if not (array_for_all (noccur_between n ntypes) largs') then @@ -166,20 +313,20 @@ let abstract_mind_lc env ntyps npars lc = list_tabulate (function i -> lambda_implicit_lift npars (mkRel (i+1))) ntyps in - Array.map (compose nf_beta (substl make_abs)) lc + Array.map (substl make_abs) lc let listrec_mconstr env ntypes hyps nparams i indlc = let nhyps = List.length hyps in (* check the inductive types occur positively in [c] *) let rec check_pos env n c = - let x,largs = whd_betadeltaiota_stack env Evd.empty c in + let x,largs = decompose_app (whd_betadeltaiota env c) in match kind_of_term x with - | IsProd (na,b,d) -> + | Prod (na,b,d) -> assert (largs = []); if not (noccur_between n ntypes b) then raise (IllFormedInd (LocalNonPos n)); - check_pos (push_rel_assum (na, b) env) (n+1) d - | IsRel k -> + check_pos (push_rel (na, None, b) env) (n+1) d + | Rel k -> if k >= n && k<n+ntypes then begin check_correct_par env hyps nparams ntypes n (k-n+1) largs; Mrec(n+ntypes-k-1) @@ -189,7 +336,7 @@ let listrec_mconstr env ntypes hyps nparams i indlc = else Norec else raise (IllFormedInd (LocalNonPos n)) - | IsMutInd ind_sp -> + | Ind ind_sp -> if List.for_all (noccur_between n ntypes) largs then Norec else Imbr(ind_sp,imbr_positive env n ind_sp largs) @@ -199,27 +346,29 @@ let listrec_mconstr env ntypes hyps nparams i indlc = then Norec else raise (IllFormedInd (LocalNonPos n)) + (* accesses to the environment are not factorised, but does it worth + it? *) and imbr_positive env n mi largs = - let mispeci = lookup_mind_specif mi env in - let auxnpar = mis_nparams mispeci in + let (mib,mip) = lookup_mind_specif env mi in + let auxnpar = mip.mind_nparams in 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_nf_lc mispeci - and auxntyp = mis_ntypes mispeci in + let auxlc = arities_of_constructors env mi in + let auxntyp = mib.mind_ntypes in if auxntyp <> 1 then raise (IllFormedInd (LocalNonPos n)); let lrecargs = List.map (check_weak_pos env 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 (* Extends the environment with a variable corresponding to the inductive def *) - let env' = push_rel_assum (Anonymous,mis_arity mispeci) env in + let env' = push_rel (Anonymous,None,type_of_inductive env mi) env in let _ = (* fails if the inductive type occurs non positively *) (* when substituted *) Array.map (function c -> - let c' = hnf_prod_applist env Evd.empty c + let c' = hnf_prod_applist env c (List.map (lift auxntyp) lpar) in check_construct env' false newidx c') auxlcvect @@ -240,16 +389,16 @@ let listrec_mconstr env ntypes hyps nparams i indlc = Abstractions may occur in imbricated recursive ocurrences, but I am not sure if they make sense in a form of constructor. This is why I chose to duplicated the code. Eduardo 13/7/99. *) - (* Since Lambda can no longer occur after a product or a MutInd, + (* Since Lambda can no longer occur after a product or a Ind, I have branched the remaining cases on check_pos. HH 28/1/00 *) and check_weak_pos env n c = - let x = whd_betadeltaiota env Evd.empty c in + let x = whd_betadeltaiota env c in match kind_of_term x with (* The extra case *) - | IsLambda (na,b,d) -> + | Lambda (na,b,d) -> if noccur_between n ntypes b - then check_weak_pos (push_rel_assum (na,b) env) (n+1) d + then check_weak_pos (push_rel (na,None,b) env) (n+1) d else raise (IllFormedInd (LocalNonPos n)) (******************) | _ -> check_pos env n x @@ -260,29 +409,29 @@ let listrec_mconstr env ntypes hyps nparams i indlc = and check_construct env check_head = let rec check_constr_rec env lrec n c = - let x,largs = whd_betadeltaiota_stack env Evd.empty c in + let x,largs = decompose_app (whd_betadeltaiota env c) in match kind_of_term x with - | IsProd (na,b,d) -> + | Prod (na,b,d) -> assert (largs = []); let recarg = check_pos env n b in - check_constr_rec (push_rel_assum (na, b) env) + check_constr_rec (push_rel (na, None, b) env) (recarg::lrec) (n+1) d (* LetIn's must be free of occurrence of the inductive types and they do not contribute to recargs *) - | IsLetIn (na,b,t,d) -> + | LetIn (na,b,t,d) -> assert (largs = []); if not (noccur_between n ntypes b & noccur_between n ntypes t) then - check_constr_rec (push_rel_def (na,b, b) env) + check_constr_rec (push_rel (na,Some b, b) env) lrec n (subst1 b d) else let recarg = check_pos env n b in - check_constr_rec (push_rel_def (na,b, b) env) + check_constr_rec (push_rel (na,Some b, b) env) lrec (n+1) d | hd -> if check_head then - if hd = IsRel (n+ntypes-i) then + if hd = Rel (n+ntypes-i) then check_correct_par env hyps nparams ntypes n (ntypes-i+1) largs else raise (IllFormedInd LocalNotConstructor) @@ -296,7 +445,7 @@ let listrec_mconstr env ntypes hyps nparams i indlc = (fun c -> let c = body_of_type c in let sign, rawc = mind_extract_params nhyps c in - let env' = push_rels sign env in + let env' = push_rel_context sign env in try check_construct env' true (1+nhyps) rawc with IllFormedInd err -> @@ -317,19 +466,19 @@ let abstract_inductive ntypes hyps (par,np,id,arity,cnames,issmall,isunit,lc) = let nhyps = List.length hyps in let nparams = Array.length args in (* nparams = nhyps - nb(letin) *) let new_refs = - list_tabulate (fun k -> appvect(mkRel (k+nhyps+1),args)) ntypes in + list_tabulate (fun k -> mkApp (mkRel (k+nhyps+1),args)) ntypes in let abs_constructor b = it_mkNamedProd_or_LetIn (substl new_refs b) hyps in let lc' = Array.map abs_constructor lc in let arity' = it_mkNamedProd_or_LetIn arity hyps in let par' = push_named_to_rel_context hyps par in (par',np+nparams,id,arity',cnames,issmall,isunit,lc') -let cci_inductive locals env env_ar kind finite inds cst = +let cci_inductive env env_ar finite inds cst = let ntypes = List.length inds in let ids = List.fold_left (fun acc (_,_,_,ar,_,_,_,lc) -> - Idset.union (global_vars_set env (body_of_type ar)) + Idset.union (Environ.global_vars_set env (body_of_type ar)) (Array.fold_left (fun acc c -> Idset.union (global_vars_set env (body_of_type c)) acc) @@ -337,41 +486,46 @@ let cci_inductive locals env env_ar kind finite inds cst = lc)) Idset.empty inds in - let hyps = keep_hyps env ids (named_context env) in + let hyps = keep_hyps env ids in let one_packet i (params,nparams,id,ar,cnames,issmall,isunit,lc) = let recargs = listrec_mconstr env_ar ntypes params nparams i lc in let isunit = isunit && ntypes = 1 && (not (is_recursive [0] recargs)) in - let (ar_sign,ar_sort) = splay_arity env Evd.empty (body_of_type ar) in + let (ar_sign,ar_sort) = dest_arity env ar in - let nf_ar,user_ar = - if isArity (body_of_type ar) then ar,None - else (prod_it (mkSort ar_sort) ar_sign, Some ar) in + let nf_ar = + if isArity (body_of_type ar) then ar + else it_mkProd_or_LetIn (mkSort ar_sort) ar_sign in let kelim = allowed_sorts issmall isunit ar_sort in - let lc_bodies = Array.map body_of_type lc in - let splayed_lc = Array.map (splay_prod_assum env_ar Evd.empty) lc_bodies in + let splayed_lc = Array.map (dest_prod_assum env_ar) lc in let nf_lc = array_map2 (fun (d,b) c -> it_mkProd_or_LetIn b d) splayed_lc lc in - let nf_lc,user_lc = if nf_lc = lc then lc,None else nf_lc, Some lc in + let nf_lc = if nf_lc = lc then lc else nf_lc in { mind_consnames = Array.of_list cnames; mind_typename = id; - mind_user_lc = user_lc; + mind_user_lc = lc; mind_nf_lc = nf_lc; - mind_user_arity = user_ar; + mind_user_arity = ar; mind_nf_arity = nf_ar; mind_nrealargs = List.length ar_sign - nparams; mind_sort = ar_sort; mind_kelim = kelim; mind_listrec = recargs; - mind_finite = finite; mind_nparams = nparams; mind_params_ctxt = params } in - let sp_hyps = List.map (fun (id,b,t) -> (List.assoc id locals,b,t)) hyps in let packets = Array.of_list (list_map_i one_packet 1 inds) in - { mind_kind = kind; - mind_ntypes = ntypes; - mind_hyps = sp_hyps; + { mind_ntypes = ntypes; + mind_finite = finite; + mind_hyps = hyps; mind_packets = packets; mind_constraints = cst; mind_singl = None } + +(***********************************************************************) +(***********************************************************************) + +let check_inductive env mie = + mind_check_wellformed env mie; + let (env_arities, inds, cst) = type_inductive env mie in + cci_inductive env env_arities mie.mind_entry_finite inds cst diff --git a/kernel/indtypes.mli b/kernel/indtypes.mli index 93bfb5454..7e803b11e 100644 --- a/kernel/indtypes.mli +++ b/kernel/indtypes.mli @@ -14,6 +14,7 @@ open Univ open Term open Declarations open Environ +open Typeops (*i*) @@ -37,21 +38,32 @@ type inductive_error = exception InductiveError of inductive_error -(*s The following function does checks on inductive declarations. *) +(*s Declaration of inductive types. *) + +(* Assume the following definition in concrete syntax: +\begin{verbatim} +Inductive I1 [x1:X1;...;xn:Xn] : A1 := c11 : T11 | ... | c1n1 : T1n1 +... +with Ip [x1:X1;...;xn:Xn] : Ap := cp1 : Tp1 | ... | cpnp : Tpnp. +\end{verbatim} +then, in $i^{th}$ block, [mind_entry_params] is [[xn:Xn;...;x1:X1]]; +[mind_entry_arity] is [Ai], defined in context [[[x1:X1;...;xn:Xn]]; +[mind_entry_lc] is [Ti1;...;Tini], defined in context [[A'1;...;A'p;x1:X1;...;xn:Xn]] where [A'i] is [Ai] generalized over [[x1:X1;...;xn:Xn]]. +*) -(* [mind_check_wellformed env mie] checks that the types declared for - all the inductive types are arities. It checks also that - constructor and inductive names altogether are distinct. It raises - an exception [InductiveError _] if [mie] is not well-formed *) +type one_inductive_entry = { + mind_entry_nparams : int; + mind_entry_params : (identifier * local_entry) list; + mind_entry_typename : identifier; + mind_entry_arity : constr; + mind_entry_consnames : identifier list; + mind_entry_lc : constr list } -val mind_check_wellformed : env -> mutual_inductive_entry -> unit +type mutual_inductive_entry = { + mind_entry_finite : bool; + mind_entry_inds : one_inductive_entry list } -(* [cci_inductive] checks positivity and builds an inductive body *) +(*s The following function does checks on inductive declarations. *) -val cci_inductive : - (identifier * variable) list -> env -> env -> path_kind -> bool -> - (Sign.rel_context * int * identifier * types * - identifier list * bool * bool * types array) - list -> - constraints -> - mutual_inductive_body +val check_inductive : + env -> mutual_inductive_entry -> mutual_inductive_body diff --git a/kernel/inductive.ml b/kernel/inductive.ml index 6cd04f76f..06219f084 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -16,6 +16,44 @@ open Sign open Declarations open Environ open Reduction +open Type_errors + +exception Induc + +(* raise Induc if not an inductive type *) +let lookup_mind_specif env (sp,tyi) = + let mib = + try Environ.lookup_mind sp env + with Not_found -> raise Induc in + if tyi >= Array.length mib.mind_packets then + error "Inductive.lookup_mind_specif: invalid inductive index"; + (mib, mib.mind_packets.(tyi)) + +let lookup_recargs env ind = + let (mib,mip) = lookup_mind_specif env ind in + Array.map (fun mip -> mip.mind_listrec) mib.mind_packets + +let find_rectype env c = + let (t, l) = decompose_app (whd_betadeltaiota env c) in + match kind_of_term t with + | Ind ind -> (ind, l) + | _ -> raise Induc + +let find_inductive env c = + let (t, l) = decompose_app (whd_betadeltaiota env c) in + match kind_of_term t with + | Ind ind + when (fst (lookup_mind_specif env ind)).mind_finite -> (ind, l) + | _ -> raise Induc + +let find_coinductive env c = + let (t, l) = decompose_app (whd_betadeltaiota env c) in + match kind_of_term t with + | Ind ind + when not (fst (lookup_mind_specif env ind)).mind_finite -> (ind, l) + | _ -> raise Induc + +(***********************************************************************) type inductive_instance = { mis_sp : section_path; @@ -23,189 +61,95 @@ type inductive_instance = { mis_tyi : int; mis_mip : one_inductive_body } - -let build_mis (sp,tyi) mib = - { mis_sp = sp; mis_mib = mib; mis_tyi = tyi; - mis_mip = mind_nth_type_packet mib tyi } - -let mis_ntypes mis = mis.mis_mib.mind_ntypes -let mis_nparams mis = mis.mis_mip.mind_nparams - -let mis_index mis = mis.mis_tyi - let mis_nconstr mis = Array.length (mis.mis_mip.mind_consnames) -let mis_nrealargs mis = mis.mis_mip.mind_nrealargs -let mis_kelim mis = mis.mis_mip.mind_kelim -let mis_recargs mis = - Array.map (fun mip -> mip.mind_listrec) mis.mis_mib.mind_packets -let mis_recarg mis = mis.mis_mip.mind_listrec -let mis_typename mis = mis.mis_mip.mind_typename -let mis_typepath mis = - make_path (dirpath mis.mis_sp) mis.mis_mip.mind_typename CCI -let mis_consnames mis = mis.mis_mip.mind_consnames -let mis_conspaths mis = - let dir = dirpath mis.mis_sp in - Array.map (fun id -> make_path dir id CCI) mis.mis_mip.mind_consnames let mis_inductive mis = (mis.mis_sp,mis.mis_tyi) -let mis_finite mis = mis.mis_mip.mind_finite - -let mis_typed_nf_lc mis = - let sign = mis.mis_mib.mind_hyps in - mis.mis_mip.mind_nf_lc - -let mis_nf_lc mis = Array.map body_of_type (mis_typed_nf_lc mis) - -let mis_user_lc mis = - let sign = mis.mis_mib.mind_hyps in - (mind_user_lc mis.mis_mip) - -(* gives the vector of constructors and of - types of constructors of an inductive definition - correctly instanciated *) - -let mis_type_mconstructs mispec = - let specif = Array.map body_of_type (mis_user_lc mispec) - and ntypes = mis_ntypes mispec - and nconstr = mis_nconstr mispec in - let make_Ik k = mkMutInd (mispec.mis_sp,ntypes-k-1) - and make_Ck k = - mkMutConstruct ((mispec.mis_sp,mispec.mis_tyi),k+1) in - (Array.init nconstr make_Ck, - Array.map (substl (list_tabulate make_Ik ntypes)) specif) - -let mis_nf_constructor_type i mispec = - let specif = mis_nf_lc mispec - and ntypes = mis_ntypes mispec - and nconstr = mis_nconstr mispec in - let make_Ik k = mkMutInd (mispec.mis_sp,ntypes-k-1) in - if i > nconstr then error "Not enough constructors in the type"; - substl (list_tabulate make_Ik ntypes) specif.(i-1) - -let mis_constructor_type i mispec = - let specif = mis_user_lc mispec - and ntypes = mis_ntypes mispec - and nconstr = mis_nconstr mispec in - let make_Ik k = mkMutInd (mispec.mis_sp,ntypes-k-1) in - if i > nconstr then error "Not enough constructors in the type"; - substl (list_tabulate make_Ik ntypes) specif.(i-1) - -let mis_arity mis = - let hyps = mis.mis_mib.mind_hyps in - mind_user_arity mis.mis_mip - -let mis_nf_arity mis = - let hyps = mis.mis_mib.mind_hyps in - mis.mis_mip.mind_nf_arity -let mis_params_ctxt mis = mis.mis_mip.mind_params_ctxt -(* - let paramsign,_ = - decompose_prod_n_assum mis.mis_mip.mind_nparams - (body_of_type (mis_nf_arity mis)) - in paramsign -*) +let lookup_mind_instance (sp,tyi) env = + let (mib,mip) = lookup_mind_specif env (sp,tyi) in + { mis_sp = sp; mis_mib = mib; mis_tyi = tyi; mis_mip = mip } -let mis_sort mispec = mispec.mis_mip.mind_sort +(* Build the substitution that replaces Rels by the appropriate *) +(* inductives *) +let ind_subst mispec = + let ntypes = mispec.mis_mib.mind_ntypes in + let make_Ik k = mkInd (mispec.mis_sp,ntypes-k-1) in + (list_tabulate make_Ik ntypes) -(* [inductive_family] = [inductive_instance] applied to global parameters *) -type inductive_family = IndFamily of inductive_instance * constr list +(* Instantiate both section variables and inductives *) +let constructor_instantiate mispec = + let s = ind_subst mispec in + substl s -type inductive_type = IndType of inductive_family * constr list +(* Instantiate the parameters of the inductive type *) +let instantiate_params t args sign = + let rec inst s t = function + | ((_,None,_)::ctxt,a::args) -> + (match kind_of_term t with + | Prod(_,_,t) -> inst (a::s) t (ctxt,args) + | _ -> anomaly"instantiate_params: type, ctxt and args mismatch") + | ((_,(Some b),_)::ctxt,args) -> + (match kind_of_term t with + | LetIn(_,_,_,t) -> inst ((substl s b)::s) t (ctxt,args) + | _ -> anomaly"instantiate_params: type, ctxt and args mismatch") + | [], [] -> substl s t + | _ -> anomaly"instantiate_params: type, ctxt and args mismatch" + in inst [] t (List.rev sign,args) -let liftn_inductive_family n d (IndFamily (mis,params)) = - IndFamily (mis, List.map (liftn n d) params) -let lift_inductive_family n = liftn_inductive_family n 1 +let full_inductive_instantiate (mispec,params) t = + instantiate_params t params mispec.mis_mip.mind_params_ctxt -let liftn_inductive_type n d (IndType (indf, realargs)) = - IndType (liftn_inductive_family n d indf, List.map (liftn n d) realargs) -let lift_inductive_type n = liftn_inductive_type n 1 +let full_constructor_instantiate (mispec,params) = + let inst_ind = constructor_instantiate mispec in + (fun t -> + instantiate_params (inst_ind t) params mispec.mis_mip.mind_params_ctxt) -let substnl_ind_family l n (IndFamily (mis,params)) = - IndFamily (mis, List.map (substnl l n) params) +(***********************************************************************) +(***********************************************************************) -let substnl_ind_type l n (IndType (indf,realargs)) = - IndType (substnl_ind_family l n indf, List.map (substnl l n) realargs) +(* Functions to build standard types related to inductive *) -let make_ind_family (mis, params) = IndFamily (mis,params) -let dest_ind_family (IndFamily (mis,params)) = (mis,params) +(* Type of an inductive type *) -let make_ind_type (indf, realargs) = IndType (indf,realargs) -let dest_ind_type (IndType (indf,realargs)) = (indf,realargs) +let type_of_inductive env i = + let mis = lookup_mind_instance i env in + let hyps = mis.mis_mib.mind_hyps in + mis.mis_mip.mind_user_arity -let mkAppliedInd (IndType (IndFamily (mis,params), realargs)) = - applist (mkMutInd (mis_inductive mis),params@realargs) +(* The same, with parameters instantiated *) +let get_arity (mispec,params as indf) = + let arity = mispec.mis_mip.mind_nf_arity in + destArity (full_inductive_instantiate indf arity) -let mis_is_recursive_subset listind mis = - let rec one_is_rec rvec = - List.exists - (function - | Mrec i -> List.mem i listind - | Imbr(_,lvec) -> one_is_rec lvec - | Norec -> false - | Param _ -> false) rvec - in - array_exists one_is_rec (mis_recarg mis) +(***********************************************************************) +(* Type of a constructor *) + +let type_of_constructor env cstr = + let ind = inductive_of_constructor cstr in + let mispec = lookup_mind_instance ind env in + let specif = mispec.mis_mip.mind_user_lc in + let i = index_of_constructor cstr in + let nconstr = mis_nconstr mispec in + if i > nconstr then error "Not enough constructors in the type"; + constructor_instantiate mispec specif.(i-1) -let mis_is_recursive mis = - mis_is_recursive_subset (interval 0 ((mis_ntypes mis)-1)) mis +let arities_of_constructors env ind = + let mispec = lookup_mind_instance ind env in + let specif = mispec.mis_mip.mind_user_lc in + Array.map (constructor_instantiate mispec) specif -(* Annotation for cases *) -let make_case_info mis style pats_source = -(* let constr_lengths = Array.map List.length (mis_recarg mis) in*) - let indsp = (mis.mis_sp,mis.mis_tyi) in - let print_info = - (indsp,mis_consnames mis,mis.mis_mip.mind_nrealargs,style,pats_source) in - ((*constr_lengths*) mis_nparams mis,print_info) -let make_default_case_info mis = - make_case_info mis None (Array.init (mis_nconstr mis) (fun _ -> RegularPat)) +(* gives the vector of constructors and of + types of constructors of an inductive definition + correctly instanciated *) +let mis_nf_constructor_type i mispec = + let nconstr = mis_nconstr mispec in + if i > nconstr then error "Not enough constructors in the type"; + constructor_instantiate mispec mispec.mis_mip.mind_nf_lc.(i-1) + (*s Useful functions *) -let inductive_of_constructor (ind_sp,i) = ind_sp -let index_of_constructor (ind_sp,i) = i -let ith_constructor_of_inductive ind_sp i = (ind_sp,i) - -exception Induc - -let extract_mrectype t = - let (t, l) = whd_stack t in - match kind_of_term t with - | IsMutInd ind -> (ind, l) - | _ -> raise Induc - -let find_mrectype env sigma c = - let (t, l) = whd_betadeltaiota_stack env sigma c in - match kind_of_term t with - | IsMutInd ind -> (ind, l) - | _ -> raise Induc - -let find_inductive env sigma c = - let (t, l) = whd_betadeltaiota_stack env sigma c in - match kind_of_term t with - | IsMutInd ((sp,i) as ind) - when mind_type_finite (lookup_mind sp env) i -> (ind, l) - | _ -> raise Induc - -let find_coinductive env sigma c = - let (t, l) = whd_betadeltaiota_stack env sigma c in - match kind_of_term t with - | IsMutInd ((sp,i) as ind) - when not (mind_type_finite (lookup_mind sp env) i) -> (ind, l) - | _ -> raise Induc - -(* raise Induc if not an inductive type *) -let lookup_mind_specif ((sp,tyi) as ind) env = - build_mis ind (lookup_mind sp env) - -let find_rectype env sigma ty = - let (mind,largs) = find_mrectype env sigma ty in - let mispec = lookup_mind_specif mind env in - let nparams = mis_nparams mispec in - let (params,realargs) = list_chop nparams largs in - make_ind_type (make_ind_family (mispec,params),realargs) - type constructor_summary = { cs_cstr : constructor; cs_params : constr list; @@ -214,63 +158,24 @@ type constructor_summary = { cs_concl_realargs : constr array } -let lift_constructor n cs = { - cs_cstr = cs.cs_cstr; - cs_params = List.map (lift n) cs.cs_params; - cs_nargs = cs.cs_nargs; - cs_args = lift_rel_context n cs.cs_args; - cs_concl_realargs = Array.map (liftn n (cs.cs_nargs+1)) cs.cs_concl_realargs -} - -let instantiate_params t args sign = - let rec inst s t = function - | ((_,None,_)::ctxt,a::args) -> - (match kind_of_term t with - | IsProd(_,_,t) -> inst (a::s) t (ctxt,args) - | _ -> anomaly"instantiate_params: type, ctxt and args mismatch") - | ((_,(Some b),_)::ctxt,args) -> - (match kind_of_term t with - | IsLetIn(_,_,_,t) -> inst ((substl s b)::s) t (ctxt,args) - | _ -> anomaly"instantiate_params: type, ctxt and args mismatch") - | [], [] -> substl s t - | _ -> anomaly"instantiate_params: type, ctxt and args mismatch" - in inst [] t (List.rev sign,args) - -let get_constructor_type (IndFamily (mispec,params)) j = - assert (j <= mis_nconstr mispec); - let typi = mis_constructor_type j mispec in - instantiate_params typi params (mis_params_ctxt mispec) - -let get_constructors_types (IndFamily (mispec,params) as indf) = - Array.init (mis_nconstr mispec) (fun j -> get_constructor_type indf (j+1)) - -let get_constructor (IndFamily (mispec,params) as indf) j = - assert (j <= mis_nconstr mispec); - let typi = mis_nf_constructor_type j mispec in - let typi = instantiate_params typi params (mis_params_ctxt mispec) in +let process_constructor ((mispec,params) as indf) j typi = + let typi = full_constructor_instantiate indf typi in let (args,ccl) = decompose_prod_assum typi in - let (_,allargs) = whd_stack ccl in - let (_,vargs) = list_chop (mis_nparams mispec) allargs in - { cs_cstr = ith_constructor_of_inductive (mis_inductive mispec) j; + let (_,allargs) = decompose_app ccl in + let (_,vargs) = list_chop mispec.mis_mip.mind_nparams allargs in + { cs_cstr = ith_constructor_of_inductive (mis_inductive mispec) (j+1); cs_params = params; cs_nargs = rel_context_length args; cs_args = args; cs_concl_realargs = Array.of_list vargs } -let get_constructors (IndFamily (mispec,params) as indf) = - Array.init (mis_nconstr mispec) (fun j -> get_constructor indf (j+1)) - -let get_arity_type (IndFamily (mispec,params)) = - let arity = body_of_type (mis_arity mispec) in -(* instantiate_params arity params (mis_params_ctxt mispec) *) - prod_applist arity params +let get_constructors ((mispec,params) as indf) = + let constr_tys = mispec.mis_mip.mind_nf_lc in + Array.mapi (process_constructor indf) constr_tys -let get_arity (IndFamily (mispec,params)) = - let arity = body_of_type (mis_nf_arity mispec) in -(* instantiate_params arity params (mis_params_ctxt mispec) *) - destArity (prod_applist arity params) +(***********************************************************************) -(* Functions to build standard types related to inductive *) +(* Type of case branches *) let local_rels = let rec relrec acc n = function (* more recent arg in front *) @@ -281,34 +186,627 @@ let local_rels = let build_dependent_constructor cs = applist - (mkMutConstruct cs.cs_cstr, + (mkConstruct cs.cs_cstr, (List.map (lift cs.cs_nargs) cs.cs_params)@(local_rels cs.cs_args)) -let build_dependent_inductive (IndFamily (mis, params) as indf) = +let build_dependent_inductive ((mis, params) as indf) = let arsign,_ = get_arity indf in - let nrealargs = mis_nrealargs mis in + let nrealargs = mis.mis_mip.mind_nrealargs in applist - (mkMutInd (mis_inductive mis), + (mkInd (mis_inductive mis), (List.map (lift nrealargs) params)@(local_rels arsign)) -(* builds the arity of an elimination predicate in sort [s] *) -let make_arity env dep indf s = - let (arsign,_) = get_arity indf in - if dep then - (* We need names everywhere *) - it_mkProd_or_LetIn_name env - (mkArrow (build_dependent_inductive indf) (mkSort s)) arsign - else - (* No need to enforce names *) - it_mkProd_or_LetIn (mkSort s) arsign - (* [p] is the predicate and [cs] a constructor summary *) -let build_branch_type env dep p cs = - let base = appvect (lift cs.cs_nargs p, cs.cs_concl_realargs) in - if dep then - it_mkProd_or_LetIn_name env - (applist (base,[build_dependent_constructor cs])) - cs.cs_args - else - it_mkProd_or_LetIn base cs.cs_args +let build_branch_type dep p cs = + let args = + if dep then + Array.append cs.cs_concl_realargs [|build_dependent_constructor cs|] + else + cs.cs_concl_realargs in + let base = beta_appvect (lift cs.cs_nargs p) args in + it_mkProd_or_LetIn base cs.cs_args + + +let is_info_arity env c = + match dest_arity env c with + | (_,Prop Null) -> false + | (_,Prop Pos) -> true + | (_,Type _) -> true + +let error_elim_expln env kp ki = + if is_info_arity env kp && not (is_info_arity env ki) then + "non-informative objects may not construct informative ones." + else + match (kind_of_term kp,kind_of_term ki) with + | Sort (Type _), Sort (Prop _) -> + "strong elimination on non-small inductive types leads to paradoxes." + | _ -> "wrong arity" + +exception Arity of (constr * constr * string) option + + +let is_correct_arity env kelim (c,pj) indf t = + let rec srec (pt,t) u = + let pt' = whd_betadeltaiota env pt in + let t' = whd_betadeltaiota env t in + match kind_of_term pt', kind_of_term t' with + | Prod (_,a1,a2), Prod (_,a1',a2') -> + let univ = + try conv env a1 a1' + with NotConvertible -> raise (Arity None) in + srec (a2,a2') (Constraint.union u univ) + | Prod (_,a1,a2), _ -> + let k = whd_betadeltaiota env a2 in + let ksort = match kind_of_term k with + | Sort s -> family_of_sort s + | _ -> raise (Arity None) in + let ind = build_dependent_inductive indf in + let univ = + try conv env a1 ind + with NotConvertible -> raise (Arity None) in + if List.exists ((=) ksort) kelim then + ((true,k), Constraint.union u univ) + else + raise (Arity (Some(k,t',error_elim_expln env k t'))) + | k, Prod (_,_,_) -> + raise (Arity None) + | k, ki -> + let ksort = match k with + | Sort s -> family_of_sort s + | _ -> raise (Arity None) in + if List.exists ((=) ksort) kelim then + (false, pt'), u + else + raise (Arity (Some(pt',t',error_elim_expln env pt' t'))) + in + try srec (pj.uj_type,t) Constraint.empty + with Arity kinds -> + let create_sort = function + | InProp -> mkProp + | InSet -> mkSet + | InType -> mkType (Univ.new_univ ()) in + let listarity = List.map create_sort kelim +(* let listarity = + (List.map (fun s -> make_arity env true indf (create_sort s)) kelim) + @(List.map (fun s -> make_arity env false indf (create_sort s)) kelim)*) + in + let ind = mis_inductive (fst indf) in + error_elim_arity env ind listarity c pj kinds + + +let find_case_dep_nparams env (c,pj) (ind,params) = + let indf = lookup_mind_instance ind env in + let kelim = indf.mis_mip.mind_kelim in + let arsign,s = get_arity (indf,params) in + let glob_t = it_mkProd_or_LetIn (mkSort s) arsign in + let ((dep,_),univ) = + is_correct_arity env kelim (c,pj) (indf,params) glob_t in + (dep,univ) + + +let type_case_branches env (mind,largs) pj c = + let mispec = lookup_mind_instance mind env in + let nparams = mispec.mis_mip.mind_nparams in + let (params,realargs) = list_chop nparams largs in + let indf = (mispec,params) in + let p = pj.uj_val in + let (dep,univ) = find_case_dep_nparams env (c,pj) (mind,params) in + let constructs = get_constructors indf in + let lc = Array.map (build_branch_type dep p) constructs in + let args = if dep then realargs@[c] else realargs in + (lc, beta_appvect p (Array.of_list args), univ) + + +let check_case_info env indsp ci = + let (mib,mip) = lookup_mind_specif env indsp in + if + (indsp <> ci.ci_ind) or + (mip.mind_nparams <> ci.ci_npar) + then raise (TypeError(env,WrongCaseInfo(indsp,ci))) + +(***********************************************************************) +(***********************************************************************) + +(* Guard conditions for fix and cofix-points *) + +(* 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 *) + +(* A powerful notion of subterm *) + +let find_sorted_assoc p = + let rec findrec = function + | (a,ta)::l -> + if a < p then findrec l else if a = p then ta else raise Not_found + | _ -> raise Not_found + in + findrec + +let map_lift_fst_n m = List.map (function (n,t)->(n+m,t)) +let map_lift_fst = map_lift_fst_n 1 + +let rec instantiate_recarg sp lrc ra = + match ra with + | Mrec(j) -> Imbr((sp,j),lrc) + | Imbr(ind_sp,l) -> Imbr(ind_sp, List.map (instantiate_recarg sp lrc) l) + | Norec -> Norec + | Param(k) -> List.nth lrc k + +(* To each inductive definition corresponds an array describing the + structure of recursive arguments for each constructor, we call it + the recursive spec of the type (it has type recargs vect). For + checking the guard, we start from the decreasing argument (Rel n) + with its recursive spec. During checking the guardness condition, + we collect patterns variables corresponding to subterms of n, each + of them with its recursive spec. They are organised in a list lst + of type (int * recargs) list which is sorted with respect to the + first argument. +*) + +(* + f is a function of type + env -> int -> (int * recargs) list -> constr -> 'a + + c is a branch of an inductive definition corresponding to the spec + lrec. mind_recvec is the recursive spec of the inductive + definition of the decreasing argument n. + + check_term env mind_recvec f n lst (lrec,c) will pass the lambdas + of c corresponding to pattern variables and collect possibly new + subterms variables and apply f to the body of the branch with the + correct env and decreasing arg. +*) + +let check_term env mind_recvec f = + let rec crec env n lst (lrec,c) = + let c' = strip_outer_cast c in + match lrec, kind_of_term c' with + (ra::lr,Lambda (x,a,b)) -> + let lst' = map_lift_fst lst + and env' = push_rel (x,None,a) env + and n'=n+1 + in begin match ra with + Mrec(i) -> crec env' n' ((1,mind_recvec.(i))::lst') (lr,b) + | Imbr((sp,i) as ind_sp,lrc) -> + let sprecargs = lookup_recargs env ind_sp in + let lc = Array.map + (List.map (instantiate_recarg sp lrc)) sprecargs.(i) + in crec env' n' ((1,lc)::lst') (lr,b) + | _ -> crec env' n' lst' (lr,b) end + | (_,_) -> f env n lst c' + in crec env + +(* c is supposed to be in beta-delta-iota head normal form *) + +let is_inst_var k c = + match kind_of_term (fst (decompose_app c)) with + | Rel n -> n=k + | _ -> false + +(* + is_subterm_specif env lcx mind_recvec n lst c + + n is the principal arg and has recursive spec lcx, lst is the list + of subterms of n with spec. is_subterm_specif should test if c is + a subterm of n and fails with Not_found if not. In case it is, it + should send its recursive specification. This recursive spec + should be the same size as the number of constructors of the type + of c. A problem occurs when c is built by contradiction. In that + case no spec is given. +*) +let is_subterm_specif env lcx mind_recvec = + let rec crec env n lst c = + let f,l = decompose_app (whd_betadeltaiota env c) in + match kind_of_term f with + | Rel k -> Some (find_sorted_assoc k lst) + + | Case ( _,_,c,br) -> + if Array.length br = 0 then None + + else + let def = Array.create (Array.length br) [] + in let lcv = + (try + if is_inst_var n c then lcx + else match crec env n lst c with Some lr -> lr | None -> def + with Not_found -> def) + 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 let stl0 = stl.(0) in + if array_for_all (fun st -> st=stl0) stl then stl0 + else None + + | Fix ((recindxs,i),(_,typarray,bodies as recdef)) -> + let nbfix = Array.length typarray in + let decrArg = recindxs.(i) in + let theBody = bodies.(i) in + let sign,strippedBody = decompose_lam_n_assum (decrArg+1) theBody in + let nbOfAbst = nbfix+decrArg+1 in +(* when proving that the fixpoint f(x)=e is less than n, it is enough + to prove that e is less than n assuming f is less than n + furthermore when f is applied to a term which is strictly less than + n, one may assume that x itself is strictly less than n +*) + let newlst = + let lst' = (nbOfAbst,lcx) :: (map_lift_fst_n nbOfAbst lst) in + if List.length l < (decrArg+1) then lst' + else + let theDecrArg = List.nth l decrArg in + try + match crec env n lst theDecrArg with + (Some recArgsDecrArg) -> (1,recArgsDecrArg) :: lst' + | None -> lst' + with Not_found -> lst' in + let env' = push_rec_types recdef env in + let env'' = push_rel_context sign env' in + crec env'' (n+nbOfAbst) newlst strippedBody + + | Lambda (x,a,b) when l=[] -> + let lst' = map_lift_fst lst in + crec (push_rel (x, None, a) env) (n+1) lst' b + + (*** Experimental change *************************) + | Meta _ -> None + | _ -> raise Not_found + in + crec env + +let spec_subterm_strict env lcx mind_recvec n lst c nb = + try match is_subterm_specif env lcx mind_recvec n lst c + with Some lr -> lr | None -> Array.create nb [] + with Not_found -> Array.create nb [] + +let spec_subterm_large env lcx mind_recvec n lst c nb = + if is_inst_var n c then lcx + else spec_subterm_strict env lcx mind_recvec n lst c nb + + +let is_subterm env lcx mind_recvec n lst c = + try + let _ = is_subterm_specif env lcx mind_recvec n lst c in true + 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 vectn k def = + (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 env n def = + match kind_of_term (strip_outer_cast def) with + | Lambda (x,a,b) -> + if noccur_with_meta n nfi a then + let env' = push_rel (x, None, a) env in + if n = k+1 then (env', lift 1 a, b) + else check_occur env' (n+1) b + else + anomaly "check_subterm_rec_meta: Bad occurrence of recursive call" + | _ -> raise (FixGuardError NotEnoughAbstractionInFixBody) in + let (env',c,d) = check_occur env 1 def in + let ((sp,tyi) as mind, largs) = + try find_inductive env' c + with Induc -> raise (FixGuardError RecursionNotOnInductiveType) in + let mind_recvec = lookup_recargs env' (sp,tyi) in + let lcx = mind_recvec.(tyi) in + (* n = decreasing argument in the definition; + lst = a mapping var |-> recargs + t = the term to be checked + *) + let rec check_rec_call env n lst t = + (* n gives the index of the recursive variable *) + (noccur_with_meta (n+k+1) nfi t) or + (* no recursive call in the term *) + (let f,l = hnf_stack env t in + match kind_of_term f with + | Rel 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 *) + let np = vectn.(glob) in (* the decreasing arg of the rec call *) + if List.length l > np then + (match list_chop np l with + (la,(z::lrest)) -> + if (is_subterm env lcx mind_recvec n lst z) + then List.for_all (check_rec_call env n lst) (la@lrest) + else raise (FixGuardError RecursionOnIllegalTerm) + | _ -> assert false) + else raise (FixGuardError NotEnoughArgumentsForFixCall) + else List.for_all (check_rec_call env n lst) l + + | Case (ci,p,c_0,lrest) -> + let lc = spec_subterm_large env lcx mind_recvec n lst c_0 + (Array.length lrest) + in + (array_for_all2 + (fun c0 a -> + check_term env mind_recvec check_rec_call n lst (c0,a)) + lc lrest) + && (List.for_all (check_rec_call env n lst) (c_0::p::l)) + + (* Enables to traverse Fixpoint definitions in a more intelligent + way, ie, the rule : + + if - g = Fix g/1 := [y1:T1]...[yp:Tp]e & + - f is guarded with respect to the set of pattern variables S + in a1 ... am & + - f is guarded with respect to the set of pattern variables S + in T1 ... Tp & + - ap is a sub-term of the formal argument of f & + - f is guarded with respect to the set of pattern variables S+{yp} + in e + then f is guarded with respect to S in (g a1 ... am). + + Eduardo 7/9/98 *) + + | Fix ((recindxs,i),(_,typarray,bodies as recdef)) -> + (List.for_all (check_rec_call env n lst) l) && + (array_for_all (check_rec_call env n lst) typarray) && + let nbfix = Array.length typarray in + let decrArg = recindxs.(i) + and env' = push_rec_types recdef env + and n' = n+nbfix + and lst' = map_lift_fst_n nbfix lst + in + if (List.length l < (decrArg+1)) then + array_for_all (check_rec_call env' n' lst') bodies + else + let theDecrArg = List.nth l decrArg in + (try + match + is_subterm_specif env lcx mind_recvec n lst theDecrArg + with + Some recArgsDecrArg -> + let theBody = bodies.(i) in + check_rec_call_fix_body + env' n' lst' (decrArg+1) recArgsDecrArg theBody + | None -> + array_for_all (check_rec_call env' n' lst') bodies + with Not_found -> + array_for_all (check_rec_call env' n' lst') bodies) + + | Cast (a,b) -> + (check_rec_call env n lst a) && + (check_rec_call env n lst b) && + (List.for_all (check_rec_call env n lst) l) + + | Lambda (x,a,b) -> + (check_rec_call env n lst a) && + (check_rec_call (push_rel (x, None, a) env) + (n+1) (map_lift_fst lst) b) && + (List.for_all (check_rec_call env n lst) l) + + | Prod (x,a,b) -> + (check_rec_call env n lst a) && + (check_rec_call (push_rel (x, None, a) env) + (n+1) (map_lift_fst lst) b) && + (List.for_all (check_rec_call env n lst) l) + + | LetIn (x,a,b,c) -> + anomaly "check_rec_call: should have been reduced" + + | Ind _ -> + (List.for_all (check_rec_call env n lst) l) + + | Construct _ -> + (List.for_all (check_rec_call env n lst) l) + + | Const sp as c -> + (try + (List.for_all (check_rec_call env n lst) l) + with (FixGuardError _ ) as e + -> if evaluable_constant env sp then + check_rec_call env n lst (whd_betadeltaiota env t) + else raise e) + + | App (f,la) -> + (check_rec_call env n lst f) && + (array_for_all (check_rec_call env n lst) la) && + (List.for_all (check_rec_call env n lst) l) + + | CoFix (i,(_,typarray,bodies as recdef)) -> + let nbfix = Array.length typarray in + let env' = push_rec_types recdef env in + (array_for_all (check_rec_call env n lst) typarray) && + (List.for_all (check_rec_call env n lst) l) && + (array_for_all + (check_rec_call env' (n+nbfix) (map_lift_fst_n nbfix lst)) + bodies) + + | Evar (_,la) -> + (array_for_all (check_rec_call env n lst) la) && + (List.for_all (check_rec_call env n lst) l) + + | Meta _ -> true + + | Var _ | Sort _ -> List.for_all (check_rec_call env n lst) l + ) + + and check_rec_call_fix_body env n lst decr recArgsDecrArg body = + if decr = 0 then + check_rec_call env n ((1,recArgsDecrArg)::lst) body + else + match kind_of_term body with + | Lambda (x,a,b) -> + (check_rec_call env n lst a) & + (check_rec_call_fix_body + (push_rel (x, None, a) env) (n+1) + (map_lift_fst lst) (decr-1) recArgsDecrArg b) + | _ -> anomaly "Not enough abstractions in fix body" + + in + check_rec_call env' 1 [] d) + +(* vargs is supposed to be built from A1;..Ak;[f1]..[fk][|d1;..;dk|] +and vdeft is [|t1;..;tk|] such that f1:A1,..,fk:Ak |- di:ti +nvect is [|n1;..;nk|] which gives for each recursive definition +the inductive-decreasing index +the function checks the convertibility of ti with Ai *) + +let check_fix env ((nvect,bodynum),(names,types,bodies as recdef)) = + let nbfix = Array.length bodies in + if nbfix = 0 + or Array.length nvect <> nbfix + or Array.length types <> nbfix + or Array.length names <> nbfix + or bodynum < 0 + or bodynum >= nbfix + then anomaly "Ill-formed fix term"; + for i = 0 to nbfix - 1 do + let fixenv = push_rec_types recdef env in + if nvect.(i) < 0 then anomaly "negative recarg position"; + try + let _ = check_subterm_rec_meta fixenv nvect nvect.(i) bodies.(i) + in () + with FixGuardError err -> + error_ill_formed_rec_body fixenv err names i bodies + done + +(* +let cfkey = Profile.declare_profile "check_fix";; +let check_fix env fix = Profile.profile3 cfkey check_fix env fix;; +*) + +(***********************************************************************) +(* Co-fixpoints. *) + +exception CoFixGuardError of guard_error + +let anomaly_ill_typed () = + anomaly "check_guard_rec_meta: too many arguments applied to constructor" + + +let check_guard_rec_meta env nbfix def deftype = + let rec codomain_is_coind env c = + let b = whd_betadeltaiota env (strip_outer_cast c) in + match kind_of_term b with + | Prod (x,a,b) -> + codomain_is_coind (push_rel (x, None, a) env) b + | _ -> + try + find_coinductive env b + with Induc -> + raise (CoFixGuardError (CodomainNotInductiveType b)) + in + let (mind, _) = codomain_is_coind env deftype in + let (sp,tyi) = mind in + let lvlra = lookup_recargs env (sp,tyi) in + let vlra = lvlra.(tyi) in + let rec check_rec_call env alreadygrd n vlra t = + if noccur_with_meta n nbfix t then + true + else + let c,args = decompose_app (whd_betadeltaiota env t) in + match kind_of_term c with + | Meta _ -> true + + | Rel p -> + if n <= p && p < n+nbfix then + (* recursive call *) + if alreadygrd then + if List.for_all (noccur_with_meta n nbfix) args then + true + else + raise (CoFixGuardError NestedRecursiveOccurrences) + else + raise (CoFixGuardError (UnguardedRecursiveCall t)) + else + error "check_guard_rec_meta: ???" (* ??? *) + + | Construct (_,i as cstr_sp) -> + let lra =vlra.(i-1) in + let mI = inductive_of_constructor cstr_sp in + let (mib,mip) = lookup_mind_specif env mI in + let _,realargs = list_chop mip.mind_nparams args in + let rec process_args_of_constr l lra = + match l with + | [] -> true + | t::lr -> + (match lra with + | [] -> anomaly_ill_typed () + | (Mrec i)::lrar -> + let newvlra = lvlra.(i) in + (check_rec_call env true n newvlra t) && + (process_args_of_constr lr lrar) + + | (Imbr((sp,i) as ind_sp,lrc)::lrar) -> + let sprecargs = lookup_recargs env ind_sp in + let lc = (Array.map + (List.map + (instantiate_recarg sp lrc)) + sprecargs.(i)) + in (check_rec_call env true n lc t) & + (process_args_of_constr lr lrar) + + | _::lrar -> + if (noccur_with_meta n nbfix t) + then (process_args_of_constr lr lrar) + else raise (CoFixGuardError + (RecCallInNonRecArgOfConstructor t))) + in (process_args_of_constr realargs lra) + + + | Lambda (x,a,b) -> + assert (args = []); + if (noccur_with_meta n nbfix a) then + check_rec_call (push_rel (x, None, a) env) + alreadygrd (n+1) vlra b + else + raise (CoFixGuardError (RecCallInTypeOfAbstraction t)) + + | CoFix (j,(_,varit,vdefs as recdef)) -> + if (List.for_all (noccur_with_meta n nbfix) args) + then + let nbfix = Array.length vdefs in + if (array_for_all (noccur_with_meta n nbfix) varit) then + let env' = push_rec_types recdef env in + (array_for_all + (check_rec_call env' alreadygrd (n+1) vlra) vdefs) + && + (List.for_all (check_rec_call env alreadygrd (n+1) vlra) args) + else + raise (CoFixGuardError (RecCallInTypeOfDef c)) + else + raise (CoFixGuardError (UnguardedRecursiveCall c)) + + | Case (_,p,tm,vrest) -> + if (noccur_with_meta n nbfix p) then + if (noccur_with_meta n nbfix tm) then + if (List.for_all (noccur_with_meta n nbfix) args) then + (array_for_all (check_rec_call env alreadygrd n vlra) vrest) + else + raise (CoFixGuardError (RecCallInCaseFun c)) + else + raise (CoFixGuardError (RecCallInCaseArg c)) + else + raise (CoFixGuardError (RecCallInCasePred c)) + + | _ -> raise (CoFixGuardError NotGuardedForm) + + in + check_rec_call env false 1 vlra def + +(* The function which checks that the whole block of definitions + satisfies the guarded condition *) + +let check_cofix env (bodynum,(names,types,bodies as recdef)) = + let nbfix = Array.length bodies in + for i = 0 to nbfix-1 do + let fixenv = push_rec_types recdef env in + try + let _ = check_guard_rec_meta fixenv nbfix bodies.(i) types.(i) + in () + with CoFixGuardError err -> + error_ill_formed_rec_body fixenv err names i bodies + done diff --git a/kernel/inductive.mli b/kernel/inductive.mli index 2aee7f420..dbaf36788 100644 --- a/kernel/inductive.mli +++ b/kernel/inductive.mli @@ -12,216 +12,63 @@ open Names open Univ open Term -open Sign open Declarations open Environ -open Evd (*i*) -(*s Inductives are accessible at several stages: - -A [mutual_inductive_body] contains all information about a -declaration of mutual (co-)inductive types. These informations are -closed (they depend on no free variables) and an instance of them -corresponds to a [mutual_inductive_instance = -mutual_inductive_body * constr list]. One inductive type in an -instanciated packet corresponds to an [inductive_instance = -mutual_inductive_instance * int]. Applying global parameters to an -[inductive_instance] gives an [inductive_family = inductive_instance * -constr list]. Finally, applying real parameters gives an -[inductive_type = inductive_family * constr list]. At each level -corresponds various appropriated functions *) - -type inductive_instance (* ex-[mind_specif] *) - -val build_mis : inductive -> mutual_inductive_body -> inductive_instance - -val mis_index : inductive_instance -> int -val mis_ntypes : inductive_instance -> int -val mis_nconstr : inductive_instance -> int -val mis_nparams : inductive_instance -> int -val mis_nrealargs : inductive_instance -> int -val mis_kelim : inductive_instance -> sorts_family list -val mis_recargs : inductive_instance -> (recarg list) array array -val mis_recarg : inductive_instance -> (recarg list) array -val mis_typename : inductive_instance -> identifier -val mis_typepath : inductive_instance -> section_path -val mis_is_recursive_subset : int list -> inductive_instance -> bool -val mis_is_recursive : inductive_instance -> bool -val mis_consnames : inductive_instance -> identifier array -val mis_conspaths : inductive_instance -> section_path array -val mis_inductive : inductive_instance -> inductive -val mis_arity : inductive_instance -> types -val mis_nf_arity : inductive_instance -> types -val mis_params_ctxt : inductive_instance -> rel_context -val mis_sort : inductive_instance -> sorts -val mis_constructor_type : int -> inductive_instance -> types -val mis_finite : inductive_instance -> bool - -(* The ccl of constructor is pre-normalised in the following functions *) -val mis_nf_lc : inductive_instance -> constr array - -(*s [inductive_family] = [inductive_instance] applied to global parameters *) -type inductive_family = IndFamily of inductive_instance * constr list - -val make_ind_family : inductive_instance * constr list -> inductive_family -val dest_ind_family : inductive_family -> inductive_instance * constr list - -val liftn_inductive_family : - int -> int -> inductive_family -> inductive_family -val lift_inductive_family : - int -> inductive_family -> inductive_family - -(*s [inductive_type] = [inductive_family] applied to ``real'' parameters *) -type inductive_type = IndType of inductive_family * constr list - -val make_ind_type : inductive_family * constr list -> inductive_type -val dest_ind_type : inductive_type -> inductive_family * constr list - -val mkAppliedInd : inductive_type -> constr - -val liftn_inductive_type : int -> int -> inductive_type -> inductive_type -val lift_inductive_type : int -> inductive_type -> inductive_type -val substnl_ind_type : constr list -> int -> inductive_type -> inductive_type - -(*s A [constructor] is an [inductive] + an index; the following functions - destructs and builds [constructor] *) -val inductive_of_constructor : constructor -> inductive -val index_of_constructor : constructor -> int -val ith_constructor_of_inductive : inductive -> int -> constructor - -(*s This type gathers useful informations about some instance of a constructor - relatively to some implicit context (the current one) - - If [cs_cstr] is a constructor in [(I p1...pm a1...an)] then - [cs_params] is [p1...pm] and the type of [MutConstruct(cs_cstr) - p1...pn] is [(cs_args)(I p1...pm cs_concl_realargs)] where [cs_args] - and [cs_params] are relative to the current env and [cs_concl_realargs] - is relative to the current env enriched by [cs_args] -*) - -type constructor_summary = { - cs_cstr : constructor; - cs_params : constr list; - cs_nargs : int; - cs_args : rel_context; - cs_concl_realargs : constr array -} - -val lift_constructor : int -> constructor_summary -> constructor_summary +exception Induc -(*s Functions to build standard types related to inductive *) +(*s Extracting an inductive type from a constructions *) -(* This builds [(ci params (Rel 1)...(Rel ci_nargs))] which is the argument - of a dependent predicate in a Cases branch *) -val build_dependent_constructor : constructor_summary -> constr +(* [find_m*type env sigma c] coerce [c] to an recursive type (I args). + [find_rectype], [find_inductive] and [find_coinductive] + respectively accepts any recursive type, only an inductive type and + only a coinductive type. + They raise [Induc] if not convertible to a recursive type. *) -(* This builds [(I params (Rel 1)...(Rel nrealargs))] which is the type of - the constructor argument of a dependent predicate in a cases branch *) -val build_dependent_inductive : inductive_family -> constr +val find_rectype : env -> constr -> inductive * constr list +val find_inductive : env -> constr -> inductive * constr list +val find_coinductive : env -> constr -> inductive * constr list -(* if the arity for some inductive family [indf] associated to [(I - params)] is [(x1:A1)...(xn:An)sort'] then [make_arity env sigma dep - indf k] builds [(x1:A1)...(xn:An)sort] which is the arity of an - elimination predicate on sort [k]; if [dep=true] then it rather - builds [(x1:A1)...(xn:An)(I params x1...xn)->sort] *) -val make_arity : env -> bool -> inductive_family -> sorts -> constr +(*s Fetching information in the environment about an inductive type. + Raises Induc if the inductive type is not found. *) +val lookup_mind_specif : + env -> inductive -> mutual_inductive_body * one_inductive_body -(* [build_branch_type env dep p cs] builds the type of the branch - associated to constructor [cs] in a Case with elimination predicate - [p]; if [dep=true], the predicate is assumed dependent *) -val build_branch_type : env -> bool -> constr -> constructor_summary -> constr +(*s Functions to build standard types related to inductive *) +val type_of_inductive : env -> inductive -> types -(*s Extracting an inductive type from a constructions *) +(* Return type as quoted by the user *) +val type_of_constructor : env -> constructor -> types -exception Induc +(* Return constructor types in normal form *) +val arities_of_constructors : env -> inductive -> types array -(* [extract_mrectype c] assumes [c] is syntactically an inductive type - applied to arguments then it returns its components; if not an - inductive type, it raises [Induc] *) -val extract_mrectype : constr -> inductive * constr list -(* [find_m*type env sigma c] coerce [c] to an recursive type (I args). - [find_rectype], [find_inductive] and [find_coinductive] - respectively accepts any recursive type, only an inductive type and - only a coinductive type. - They raise [Induc] if not convertible to a recursive type. *) +exception Arity of (constr * constr * string) option + +(* [type_case_branches env (I,args) (p:A) c] computes useful types + about the following Cases expression: + <p>Cases (c :: (I args)) of b1..bn end + It computes the type of every branch (pattern variables are + introduced by products), the type for the whole expression, and + the universe constraints generated. + *) +val type_case_branches : + env -> inductive * constr list -> unsafe_judgment -> constr + -> types array * types * constraints + +(* Check a case_info actually correspond to a Case expression on the + given inductive type. *) +val check_case_info : env -> inductive -> case_info -> unit + +(*s Guard conditions for fix and cofix-points. *) +val check_fix : env -> fixpoint -> unit +val check_cofix : env -> cofixpoint -> unit -val find_mrectype : env -> 'a evar_map -> constr -> inductive * constr list -val find_inductive : env -> 'a evar_map -> constr -> inductive * constr list -val find_coinductive : env -> 'a evar_map -> constr -> inductive * constr list - -val lookup_mind_specif : inductive -> env -> inductive_instance - -(* [find_rectype env sigma t] builds an [inductive_type] or raises - [Induc] if [t] is not a (co-)inductive type; The result is relative to - [env] and [sigma] *) - -val find_rectype : env -> 'a evar_map -> constr -> inductive_type - -(* [get_constructors_types indf] returns the array of the types of - constructors of the inductive\_family [indf], i.e. the types are - instantiated by the parameters of the family (the type may be not - in canonical form -- e.g. cf sets library) *) - -val get_constructors_types : inductive_family -> types array -val get_constructor_type : inductive_family -> int -> types - -(* [get_constructors indf] build an array of [constructor_summary] - from some inductive type already analysed as an [inductive_family]; - global parameters are already instanciated in the constructor - types; the resulting summaries are valid in the environment where - [indf] is valid; the names of the products of the constructors types - are not renamed when [Anonymous] *) - -val get_constructors : inductive_family -> constructor_summary array -val get_constructor : inductive_family -> int -> constructor_summary - -(* [get_arity_type indf] returns the type of the arity of the - inductive family described by [indf]; global parameters are already - instanciated (but the type may be not in canonical form -- e.g. cf - sets library); the products signature is relative to the - environment definition of [indf]; the names of the products of the - constructors types are not renamed when [Anonymous]; [get_arity - indf] does the same but normalises and decomposes it as an arity *) - -val get_arity_type : inductive_family -> types -val get_arity : inductive_family -> arity - -(* [get_arity_type indf] returns the type of the arity of the inductive - family described by [indf]; global parameters are already instanciated *) - - - -(* Examples: assume - -\begin{verbatim} -Inductive listn [A:Set] : nat -> Set := - niln : (listn A O) -| consn : (n:nat)A->(listn A n)->(listn A (S n)). -\end{verbatim} - -has been defined. Then in some env containing ['x:nat'], -\begin{quote} -[find_rectype env sigma (listn bool (S x))] returns [IndType (indf, '(S x)')] -\end{quote} -where [indf = IndFamily ('listn',['bool'])]. - -Then, [get_constructors indf] returns -\begin{quote} -[[| { cs_cstr = 'niln'; cs_params = 'bool'; cs_nargs = 0; - cs_args = []; cs_concl_realargs = [|O|]}; - { cs_cstr = 'consn'; cs_params = 'bool'; cs_nargs = 3; - cs_args = [(Anonymous,'(listn A n)'),(Anonymous,'A'),(Name n,'nat')]; - cs_concl_realargs = [|'(S n)'|]} |]] -\end{quote} -and [get_arity indf] returns [[(Anonymous,'nat')],'Set']. -\smallskip -*) - -(*s [Cases] info *) - -val make_case_info : inductive_instance -> case_style option - -> pattern_source array -> case_info -val make_default_case_info : inductive_instance -> case_info +(********************) +(* TODO: remove (used in pretyping only...) *) +val find_case_dep_nparams : + env -> constr * unsafe_judgment -> inductive * constr list -> + bool * constraints diff --git a/kernel/instantiate.ml b/kernel/instantiate.ml deleted file mode 100644 index 0191b6391..000000000 --- a/kernel/instantiate.ml +++ /dev/null @@ -1,147 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) -(* \VV/ *************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(***********************************************************************) - -(* $Id$ *) - -open Pp -open Util -open Names -open Term -open Sign -open Evd -open Declarations -open Environ - -let is_id_inst inst = - let is_id (id,c) = match kind_of_term c with - | IsVar id' -> id = id' - | _ -> false - in - List.for_all is_id inst - -let instantiate sign c args = - let inst = instantiate_named_context sign args in - if is_id_inst inst then - c - else - replace_vars inst c - -(* Vérifier que les instances des let-in sont compatibles ?? *) -let instantiate_sign_including_let sign args = - let rec instrec = function - | ((id,b,_) :: sign, c::args) -> (id,c) :: (instrec (sign,args)) - | ([],[]) -> [] - | ([],_) | (_,[]) -> - anomaly "Signature and its instance do not match" - in - instrec (sign,args) - -let instantiate_evar sign c args = - let inst = instantiate_sign_including_let sign args in - if is_id_inst inst then - c - else - replace_vars inst c - -let instantiate_constr sign c args = - let sign = List.map (fun (sp,b,t) -> (basename sp,b,t)) sign in - instantiate sign c args - -let instantiate_type sign tty args = - type_app (fun c -> instantiate_constr sign c args) tty - -(* Constants. *) - -(* constant_type gives the type of a constant *) -let constant_type env sigma sp = - let cb = lookup_constant sp env in - cb.const_type - -type const_evaluation_result = NoBody | Opaque - -exception NotEvaluableConst of const_evaluation_result - -let constant_value env sp = - let cb = lookup_constant sp env in - if cb.const_opaque then raise (NotEvaluableConst Opaque); - match cb.const_body with - | Some body -> body - | None -> raise (NotEvaluableConst NoBody) - -let constant_opt_value env cst = - try Some (constant_value env cst) - with NotEvaluableConst _ -> None - -(* Existentials. *) - -let name_of_existential n = id_of_string ("?" ^ string_of_int n) - -let existential_type sigma (n,args) = - let info = Evd.map sigma n in - let hyps = info.evar_hyps in - (* TODO: check args [this comment was in Typeops] *) - instantiate_evar hyps info.evar_concl (Array.to_list args) - -exception NotInstantiatedEvar - -let existential_value sigma (n,args) = - let info = Evd.map sigma n in - let hyps = info.evar_hyps in - match evar_body info with - | Evar_defined c -> - instantiate_evar hyps c (Array.to_list args) - | Evar_empty -> - raise NotInstantiatedEvar - -let existential_opt_value sigma ev = - try Some (existential_value sigma ev) - with NotInstantiatedEvar -> None - - -type evaluable_reference = - | EvalConst of constant - | EvalVar of identifier - | EvalRel of int - | EvalEvar of existential - -let mkEvalRef = function - | EvalConst cst -> mkConst cst - | EvalVar id -> mkVar id - | EvalRel n -> mkRel n - | EvalEvar ev -> mkEvar ev - -let isEvalRef c = match kind_of_term c with - | IsConst _ | IsVar _ | IsRel _ | IsEvar _ -> true - | _ -> false - -let destEvalRef c = match kind_of_term c with - | IsConst cst -> EvalConst cst - | IsVar id -> EvalVar id - | IsRel n -> EvalRel n - | IsEvar ev -> EvalEvar ev - | _ -> anomaly "Not an evaluable reference" - -let evaluable_reference sigma env = function - | EvalConst sp -> evaluable_constant env sp - | EvalVar id -> evaluable_named_decl env id - | EvalRel n -> evaluable_rel_decl env n - | EvalEvar (ev,_) -> Evd.is_defined sigma ev - -let reference_opt_value sigma env = function - | EvalConst cst -> constant_opt_value env cst - | EvalVar id -> lookup_named_value id env - | EvalRel n -> lookup_rel_value n env - | EvalEvar ev -> existential_opt_value sigma ev - -exception NotEvaluable -let reference_value sigma env c = - match reference_opt_value sigma env c with - | None -> raise NotEvaluable - | Some d -> d - - diff --git a/kernel/instantiate.mli b/kernel/instantiate.mli deleted file mode 100644 index 14a4746ee..000000000 --- a/kernel/instantiate.mli +++ /dev/null @@ -1,63 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) -(* \VV/ *************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(***********************************************************************) - -(*i $Id$ i*) - -(*i*) -open Names -open Term -open Evd -open Sign -open Environ -(*i*) - -(* Instantiation of constants and inductives on their real arguments. *) - -val instantiate_constr : - section_context -> constr -> constr list -> constr - -val instantiate_type : - section_context -> types -> constr list -> types - -(*s [constant_value env c] raises [NotEvaluableConst Opaque] if - [c] is opaque and [NotEvaluableConst NoBody] if it has no - body and [Not_found] if it does not exist in [env] *) - -type const_evaluation_result = NoBody | Opaque -exception NotEvaluableConst of const_evaluation_result - -val constant_value : env -> constant -> constr -val constant_type : env -> 'a evar_map -> constant -> types -val constant_opt_value : env -> constant -> constr option - -(*s [existential_value sigma ev] raises [NotInstantiatedEvar] if [ev] has -no body and [Not_found] if it does not exist in [sigma] *) - -exception NotInstantiatedEvar -val existential_value : 'a evar_map -> existential -> constr -val existential_type : 'a evar_map -> existential -> constr -val existential_opt_value : 'a evar_map -> existential -> constr option - -type evaluable_reference = - | EvalConst of constant - | EvalVar of identifier - | EvalRel of int - | EvalEvar of existential - -val destEvalRef : constr -> evaluable_reference -val mkEvalRef : evaluable_reference -> constr -val isEvalRef : constr -> bool - -val evaluable_reference : 'a evar_map -> env -> evaluable_reference -> bool - -val reference_opt_value : - 'a evar_map -> env -> evaluable_reference -> constr option - -(* This may raise NotEvaluable *) -exception NotEvaluable -val reference_value : 'a evar_map -> env -> evaluable_reference -> constr diff --git a/kernel/names.ml b/kernel/names.ml index f2fe3be86..b91c6b08c 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -13,119 +13,12 @@ open Util (*s Identifiers *) -(* Utilities *) - -let code_of_0 = Char.code '0' -let code_of_9 = Char.code '9' - -(* Identifiers *) - type identifier = string -let cut_ident s = - let slen = String.length s in - (* [n'] is the position of the first non nullary digit *) - let rec numpart n n' = - if n = 0 then - failwith - ("The string " ^ s ^ " is not an identifier: it contains only digits") - else - let c = Char.code (String.get s (n-1)) in - if c = code_of_0 && n <> slen then - numpart (n-1) n' - else if code_of_0 <= c && c <= code_of_9 then - numpart (n-1) (n-1) - else - n' - in - numpart slen slen - -let repr_ident s = - let slen = String.length s in - let numstart = cut_ident s in - if numstart = slen then - (s, None) - else - (String.sub s 0 numstart, - Some (int_of_string (String.sub s numstart (slen - numstart)))) - -let make_ident sa = function - | Some n -> - let c = Char.code (String.get sa (String.length sa -1)) in - if c < code_of_0 or c > code_of_9 then sa ^ (string_of_int n) - else sa ^ "_" ^ (string_of_int n) - | None -> String.copy sa - -let first_char id = - assert (id <> ""); - String.make 1 id.[0] - let id_ord = Pervasives.compare -(* Rem: semantics is a bit different, if an ident starts with toto00 then - after successive renamings it comes to toto09, then it goes on with toto10 *) -let lift_subscript id = - let len = String.length id in - let rec add carrypos = - let c = id.[carrypos] in - if is_digit c then - if c = '9' then begin - assert (carrypos>0); - add (carrypos-1) - end - else begin - let newid = String.copy id in - String.fill newid (carrypos+1) (len-1-carrypos) '0'; - newid.[carrypos] <- Char.chr (Char.code c + 1); - newid - end - else begin - let newid = id^"0" in - if carrypos < len-1 then begin - String.fill newid (carrypos+1) (len-1-carrypos) '0'; - newid.[carrypos+1] <- '1' - end; - newid - end - in add (len-1) - -let has_subscript id = is_digit (id.[String.length id - 1]) - -let forget_subscript id = - let len = String.length id in - let numstart = cut_ident id in - let newid = String.make (numstart+1) '0' in - String.blit id 0 newid 0 numstart; - newid - -(* This checks that a string is acceptable as an ident, i.e. starts - with a letter and contains only letters, digits or "'" *) - -let check_ident_suffix i l s = - for i=1 to l-1 do - let c = String.get s i in - if not (is_letter c or is_digit c or c = '\'' or c = '_' or c = '@') then - error - ("Character "^(String.sub s i 1)^" is not allowed in identifier "^s) - done - -let check_ident s = - let l = String.length s in - if l = 0 then error "The empty string is not an identifier"; - let c = String.get s 0 in - if (is_letter c) or c = '_' or c = '$' or c = '?' - then check_ident_suffix 1 l s - else error (s^": an identifier should start with a letter") - -let is_ident s = try check_ident s; true with _ -> false - -let check_suffix s = check_ident_suffix 0 (String.length s) s - -let add_suffix id s = check_suffix s; id^s -let add_prefix s id = check_ident s; s^id - let string_of_id id = String.copy id -let id_of_string s = check_ident s; String.copy s +let id_of_string s = String.copy s (* Hash-consing of identifier *) module Hident = Hashcons.Make( @@ -147,65 +40,14 @@ module Idset = Set.Make(IdOrdered) module Idmap = Map.Make(IdOrdered) module Idpred = Predicate.Make(IdOrdered) -let atompart_of_id id = fst (repr_ident id) -let index_of_id id = snd (repr_ident id) let pr_id id = [< 'sTR (string_of_id id) >] let wildcard = id_of_string "_" -(* Fresh names *) - -let lift_ident = lift_subscript - -let next_ident_away id avoid = - if List.mem id avoid then - let id0 = if not (has_subscript id) then id else - (* Ce serait sans doute mieux avec quelque chose inspiré de - *** make_ident id (Some 0) *** mais ça brise la compatibilité... *) - forget_subscript id in - let rec name_rec id = - if List.mem id avoid then name_rec (lift_ident id) else id in - name_rec id0 - else id - -let next_ident_away_from id avoid = - let rec name_rec id = - if List.mem id avoid then name_rec (lift_ident id) else id in - name_rec id - (* Names *) type name = Name of identifier | Anonymous -let next_name_away_with_default default name l = - match name with - | Name str -> next_ident_away str l - | Anonymous -> next_ident_away (id_of_string default) l - -let next_name_away name l = - match name with - | Name str -> next_ident_away str l - | Anonymous -> id_of_string "_" - -let out_name = function - | Name id -> id - | Anonymous -> anomaly "out_name: expects a defined name" - -(* Kinds *) - -type path_kind = CCI | FW | OBJ - -let string_of_kind = function - | CCI -> "cci" - | FW -> "fw" - | OBJ -> "obj" - -let kind_of_string = function - | "cci" -> CCI - | "fw" -> FW - | "obj" -> OBJ - | _ -> invalid_arg "kind_of_string" - (*s Directory paths = section names paths *) let parse_fields s = let len = String.length s in @@ -234,81 +76,38 @@ module ModIdOrdered = module ModIdmap = Map.Make(ModIdOrdered) -(* These are the only functions which depend on how a dirpath is encoded *) -let make_dirpath x = List.rev x -let repr_dirpath x = List.rev x -let rev_repr_dirpath x = x - -let dirpath_prefix = function - | [] -> anomaly "dirpath_prefix: empty dirpath" - | _::l -> l - -let split_dirpath = function - | [] -> failwith "Empty" - | d::b -> (b,d) - -let extend_dirpath d id = id::d -let add_dirpath_prefix id d = d@[id] - -let is_dirpath_prefix_of d1 d2 = list_prefix_of (List.rev d1) (List.rev d2) -(**) - -let is_empty_dirpath d = (d = []) - -let dirpath_of_string s = - try - let sl,s = parse_fields s in - make_dirpath (sl @ [s]) - with - | Invalid_argument _ -> invalid_arg "dirpath_of_string" +let make_dirpath x = x +let repr_dirpath x = x let string_of_dirpath = function | [] -> "<empty>" - | sl -> String.concat "." (List.map string_of_id (repr_dirpath sl)) + | sl -> + String.concat "." (List.map string_of_id (List.rev sl)) let pr_dirpath sl = [< 'sTR (string_of_dirpath sl) >] -let default_module_name = id_of_string "Top" -let default_module = make_dirpath [default_module_name] - (*s Section paths are absolute names *) type section_path = { dirpath : dir_path ; - basename : identifier ; - kind : path_kind } - -let make_path pa id k = { dirpath = pa; basename = id; kind = k } -let repr_path { dirpath = pa; basename = id; kind = k} = (pa,id,k) + basename : identifier } -let kind_of_path sp = sp.kind -let basename sp = sp.basename -let dirpath sp = sp.dirpath +let make_path pa id = { dirpath = pa; basename = id } +let repr_path { dirpath = pa; basename = id } = (pa,id) (* parsing and printing of section paths *) let string_of_path sp = - let (sl,id,k) = repr_path sp in + let (sl,id) = repr_path sp in if sl = [] then string_of_id id else (string_of_dirpath sl) ^ "." ^ (string_of_id id) -let path_of_string s = - try - let sl,s = parse_fields s in - make_path (make_dirpath sl) s CCI - with - | Invalid_argument _ -> invalid_arg "path_of_string" - let pr_sp sp = [< 'sTR (string_of_path sp) >] let sp_ord sp1 sp2 = - let (p1,id1,k) = repr_path sp1 - and (p2,id2,k') = repr_path sp2 in - let ck = compare k k' in - if ck = 0 then - let p_bit = compare p1 p2 in - if p_bit = 0 then id_ord id1 id2 else p_bit - else - ck + let (p1,id1) = repr_path sp1 + and (p2,id2) = repr_path sp2 in + let p_bit = compare p1 p2 in + if p_bit = 0 then id_ord id1 id2 else p_bit module SpOrdered = struct @@ -323,17 +122,16 @@ module Spmap = Map.Make(SpOrdered) (*s********************************************************************) (* type of global reference *) -type variable = section_path +type variable = identifier type constant = section_path type inductive = section_path * int type constructor = inductive * int type mutual_inductive = section_path -type global_reference = - | VarRef of section_path - | ConstRef of constant - | IndRef of inductive - | ConstructRef of constructor +let ith_mutual_inductive (sp,_) i = (sp,i) +let ith_constructor_of_inductive ind_sp i = (ind_sp,i) +let inductive_of_constructor (ind_sp,i) = ind_sp +let index_of_constructor (ind_sp,i) = i (* Hash-consing of name objects *) module Hname = Hashcons.Make( @@ -366,12 +164,10 @@ module Hsp = Hashcons.Make( type u = identifier -> identifier let hash_sub hident sp = { dirpath = List.map hident sp.dirpath; - basename = hident sp.basename; - kind = sp.kind } + basename = hident sp.basename } let equal sp1 sp2 = - (sp1.basename == sp2.basename) && (sp1.kind = sp2.kind) - && (List.length sp1.dirpath = List.length sp2.dirpath) - && List.for_all2 (==) sp1.dirpath sp2.dirpath + (List.length sp1.dirpath = List.length sp2.dirpath) && + (List.for_all2 (==) sp1.dirpath sp2.dirpath) let hash = Hashtbl.hash end) diff --git a/kernel/names.mli b/kernel/names.mli index 478b1c8e4..3aac8c40b 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -16,99 +16,43 @@ open Pp type identifier type name = Name of identifier | Anonymous - -(* Constructor of an identifier; - [make_ident] builds an identifier from a string and an optional index; if - the string ends by a digit, a ["_"] is inserted *) -val make_ident : string -> int option -> identifier - -(* Some destructors of an identifier *) -val atompart_of_id : identifier -> string -val first_char : identifier -> string -val index_of_id : identifier -> int option - (* Parsing and printing of identifiers *) val string_of_id : identifier -> string val id_of_string : string -> identifier val pr_id : identifier -> std_ppcmds -(* This is the identifier ["_"] *) -val wildcard : identifier - -(* Deriving ident from other idents *) -val add_suffix : identifier -> string -> identifier -val add_prefix : string -> identifier -> identifier - (* Identifiers sets and maps *) module Idset : Set.S with type elt = identifier module Idpred : Predicate.S with type elt = identifier module Idmap : Map.S with type key = identifier -val lift_ident : identifier -> identifier -val next_ident_away_from : identifier -> identifier list -> identifier -val next_ident_away : identifier -> identifier list -> identifier -val next_name_away : name -> identifier list -> identifier -val next_name_away_with_default : - string -> name -> identifier list -> identifier - -(* [out_name na] raises an anomaly if [na] is [Anonymous] *) -val out_name : name -> identifier - -(*s [path_kind] is currently degenerated, [FW] is not used *) -type path_kind = CCI | FW | OBJ - -(* parsing and printing of path kinds *) -val string_of_kind : path_kind -> string -val kind_of_string : string -> path_kind - (*s Directory paths = section names paths *) type module_ident = identifier -type dir_path (*= module_ident list*) +type dir_path module ModIdmap : Map.S with type key = module_ident +(* Inner modules idents on top of list *) val make_dirpath : module_ident list -> dir_path val repr_dirpath : dir_path -> module_ident list -val rev_repr_dirpath : dir_path -> module_ident list -val is_empty_dirpath : dir_path -> bool - -(* Give the immediate prefix of a [dir_path] *) -val dirpath_prefix : dir_path -> dir_path - -(* Give the immediate prefix and basename of a [dir_path] *) -val split_dirpath : dir_path -> dir_path * identifier - -val extend_dirpath : dir_path -> module_ident -> dir_path -val add_dirpath_prefix : module_ident -> dir_path -> dir_path (* Printing of directory paths as ["coq_root.module.submodule"] *) val string_of_dirpath : dir_path -> string val pr_dirpath : dir_path -> std_ppcmds -val default_module : dir_path (*s Section paths are {\em absolute} names *) type section_path (* Constructors of [section_path] *) -val make_path : dir_path -> identifier -> path_kind -> section_path +val make_path : dir_path -> identifier -> section_path (* Destructors of [section_path] *) -val repr_path : section_path -> dir_path * identifier * path_kind -val dirpath : section_path -> dir_path -val basename : section_path -> identifier -val kind_of_path : section_path -> path_kind +val repr_path : section_path -> dir_path * identifier (* Parsing and printing of section path as ["coq_root.module.id"] *) -val path_of_string : string -> section_path val string_of_path : section_path -> string val pr_sp : section_path -> std_ppcmds -val dirpath_of_string : string -> dir_path - -val sp_ord : section_path -> section_path -> int - -(* [is_dirpath_prefix p1 p2=true] if [p1] is a prefix of or is equal to [p2] *) -val is_dirpath_prefix_of : dir_path -> dir_path -> bool module Spset : Set.S with type elt = section_path module Sppred : Predicate.S with type elt = section_path @@ -117,17 +61,19 @@ module Spmap : Map.S with type key = section_path (*s********************************************************************) (* type of global reference *) -type variable = section_path +type variable = identifier type constant = section_path +(* Beware: first inductive has index 0 *) type inductive = section_path * int +(* Beware: first constructor has index 1 *) type constructor = inductive * int type mutual_inductive = section_path -type global_reference = - | VarRef of section_path - | ConstRef of constant - | IndRef of inductive - | ConstructRef of constructor +val ith_mutual_inductive : inductive -> int -> inductive + +val ith_constructor_of_inductive : inductive -> int -> constructor +val inductive_of_constructor : constructor -> inductive +val index_of_constructor : constructor -> int (* Hash-consing *) val hcons_names : unit -> diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 734187a9c..10ce90291 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -8,445 +8,64 @@ (* $Id$ *) -open Pp open Util open Names open Term open Univ -open Evd open Declarations open Environ -open Instantiate open Closure open Esubst -exception Elimconst - -(* The type of (machine) states (= lambda-bar-calculus' cuts) *) -type state = constr * constr stack - -type 'a contextual_reduction_function = env -> 'a evar_map -> constr -> constr -type 'a reduction_function = 'a contextual_reduction_function -type local_reduction_function = constr -> constr - -type 'a contextual_stack_reduction_function = - env -> 'a evar_map -> constr -> constr * constr list -type 'a stack_reduction_function = 'a contextual_stack_reduction_function -type local_stack_reduction_function = constr -> constr * constr list - -type 'a contextual_state_reduction_function = - env -> 'a evar_map -> state -> state -type 'a state_reduction_function = 'a contextual_state_reduction_function -type local_state_reduction_function = state -> state - -(*************************************) -(*** Reduction Functions Operators ***) -(*************************************) - -let rec whd_state (x, stack as s) = - match kind_of_term x with - | IsApp (f,cl) -> whd_state (f, append_stack cl stack) - | IsCast (c,_) -> whd_state (c, stack) - | _ -> s +(****************************************************************************) +(* Reduction Functions *) +(****************************************************************************) -let appterm_of_stack (f,s) = (f,list_of_stack s) +let nf_betaiota t = + norm_val (create_clos_infos betaiota empty_env) (inject t) -let whd_stack x = appterm_of_stack (whd_state (x, empty_stack)) -let whd_castapp_stack = whd_stack +let hnf_stack env x = + decompose_app + (norm_val (create_clos_infos hnf_flags env) (inject x)) -let stack_reduction_of_reduction red_fun env sigma s = - let t = red_fun env sigma (app_stack s) in - whd_stack t +let whd_betadeltaiota env t = + whd_val (create_clos_infos betadeltaiota env) (inject t) -let strong whdfun env sigma t = - let rec strongrec env t = - map_constr_with_full_binders push_rel strongrec env (whdfun env sigma t) in - strongrec env t +let whd_betadeltaiota_nolet env t = + whd_val (create_clos_infos betadeltaiotanolet env) (inject t) -let local_strong whdfun = - let rec strongrec t = map_constr strongrec (whdfun t) in - strongrec +(* Beta *) -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 +let beta_appvect c v = + let rec stacklam env t stack = + match (decomp_stack stack,kind_of_term t) with + | Some (h,stacktl), Lambda (_,_,c) -> stacklam (h::env) c stacktl + | _ -> app_stack (substl env t, stack) in + stacklam [] c (append_stack v empty_stack) -(****************************************************************************) -(* Reduction Functions *) -(****************************************************************************) +(* pseudo-reduction rule: + * [hnf_prod_app env s (Prod(_,B)) N --> B[N] + * with an HNF on the first argument to produce a product. + * if this does not work, then we use the string S as part of our + * error message. *) -(* lazy reduction functions. The infos must be created for each term *) -let clos_norm_flags flgs env sigma t = - norm_val (create_clos_infos flgs env sigma) (inject t) - -let nf_beta = clos_norm_flags beta empty_env Evd.empty -let nf_betaiota = clos_norm_flags betaiota empty_env Evd.empty -let nf_betadeltaiota env sigma = clos_norm_flags betadeltaiota env sigma - -(* lazy weak head reduction functions *) -let whd_flags flgs env sigma t = - whd_val (create_clos_infos flgs env sigma) (inject t) - -(*************************************) -(*** Reduction using substitutions ***) -(*************************************) - -(* This signature is very similar to Closure.RedFlagsSig except there - is eta but no per-constant unfolding *) - -module type RedFlagsSig = sig - type flags - type flag - val fbeta : flag - val fevar : flag - val fdelta : flag - val feta : flag - val fiota : flag - val fzeta : flag - val mkflags : flag list -> flags - val red_beta : flags -> bool - val red_delta : flags -> bool - val red_evar : flags -> bool - val red_eta : flags -> bool - val red_iota : flags -> bool - val red_zeta : flags -> bool -end - -(* Naive Implementation -module RedFlags = (struct - type flag = BETA | DELTA | EVAR | IOTA | ZETA | ETA - type flags = flag list - let fbeta = BETA - let fdelta = DELTA - let fevar = EVAR - let fiota = IOTA - let fzeta = ZETA - let feta = ETA - let mkflags l = l - let red_beta = List.mem BETA - let red_delta = List.mem DELTA - let red_evar = List.mem EVAR - let red_eta = List.mem ETA - let red_iota = List.mem IOTA - let red_zeta = List.mem ZETA -end : RedFlagsSig) -*) +let hnf_prod_app env t n = + match kind_of_term (whd_betadeltaiota env t) with + | Prod (_,_,b) -> subst1 n b + | _ -> anomaly "hnf_prod_app: Need a product" -(* Compact Implementation *) -module RedFlags = (struct - type flag = int - type flags = int - let fbeta = 1 - let fdelta = 2 - let fevar = 4 - let feta = 8 - let fiota = 16 - let fzeta = 32 - let mkflags = List.fold_left (lor) 0 - let red_beta f = f land fbeta <> 0 - let red_delta f = f land fdelta <> 0 - let red_evar f = f land fevar <> 0 - let red_eta f = f land feta <> 0 - let red_iota f = f land fiota <> 0 - let red_zeta f = f land fzeta <> 0 -end : RedFlagsSig) - -open RedFlags - -(* Local *) -let beta = mkflags [fbeta] -let betaevar = mkflags [fevar; fbeta] -let betaiota = mkflags [fiota; fbeta] -let betaiotazeta = mkflags [fiota; fbeta;fzeta] - -(* Contextual *) -let delta = mkflags [fdelta;fevar] -let betadelta = mkflags [fbeta;fdelta;fzeta;fevar] -let betadeltaeta = mkflags [fbeta;fdelta;fzeta;fevar;feta] -let betadeltaiota = mkflags [fbeta;fdelta;fzeta;fevar;fiota] -let betadeltaiota_nolet = mkflags [fbeta;fdelta;fevar;fiota] -let betadeltaiotaeta = mkflags [fbeta;fdelta;fzeta;fevar;fiota;feta] -let betaiotaevar = mkflags [fbeta;fiota;fevar] -let betaetalet = mkflags [fbeta;feta;fzeta] - -(* Beta Reduction tools *) - -let rec stacklam recfun env t stack = - match (decomp_stack stack,kind_of_term t) with - | Some (h,stacktl), IsLambda (_,_,c) -> stacklam recfun (h::env) c stacktl - | _ -> recfun (substl env t, stack) - -let beta_applist (c,l) = - stacklam app_stack [] c (append_stack (Array.of_list l) empty_stack) - -(* Iota reduction tools *) - -type 'a miota_args = { - mP : constr; (* the result type *) - mconstr : constr; (* the constructor *) - mci : case_info; (* special info to re-build pattern *) - mcargs : 'a list; (* the constructor's arguments *) - mlf : 'a array } (* the branch code vector *) - -let reducible_mind_case c = match kind_of_term c with - | IsMutConstruct _ | IsCoFix _ -> true - | _ -> false - -let contract_cofix (bodynum,(types,names,bodies as typedbodies)) = - let nbodies = Array.length bodies in - let make_Fi j = mkCoFix (nbodies-j-1,typedbodies) in - substl (list_tabulate make_Fi nbodies) bodies.(bodynum) - -let reduce_mind_case mia = - match kind_of_term mia.mconstr with - | IsMutConstruct (ind_sp,i as cstr_sp) -> -(* let ncargs = (fst mia.mci).(i-1) in*) - let real_cargs = snd (list_chop (fst mia.mci) mia.mcargs) in - applist (mia.mlf.(i-1),real_cargs) - | IsCoFix cofix -> - let cofix_def = contract_cofix cofix in - mkMutCase (mia.mci, mia.mP, applist(cofix_def,mia.mcargs), mia.mlf) - | _ -> assert false - -(* contracts fix==FIX[nl;i](A1...Ak;[F1...Fk]{B1....Bk}) to produce - Bi[Fj --> FIX[nl;j](A1...Ak;[F1...Fk]{B1...Bk})] *) - -let contract_fix ((recindices,bodynum),(types,names,bodies as typedbodies)) = - let nbodies = Array.length recindices in - let make_Fi j = mkFix ((recindices,nbodies-j-1),typedbodies) in - substl (list_tabulate make_Fi nbodies) bodies.(bodynum) - -let fix_recarg ((recindices,bodynum),_) stack = - assert (0 <= bodynum & bodynum < Array.length recindices); - let recargnum = Array.get recindices bodynum in - try - Some (recargnum, stack_nth stack recargnum) - with Not_found -> - None - -type fix_reduction_result = NotReducible | Reduced of state - -let reduce_fix whdfun fix stack = - match fix_recarg fix stack with - | None -> NotReducible - | Some (recargnum,recarg) -> - let (recarg'hd,_ as recarg') = whdfun (recarg, empty_stack) in - let stack' = stack_assign stack recargnum (app_stack recarg') in - (match kind_of_term recarg'hd with - | IsMutConstruct _ -> Reduced (contract_fix fix, stack') - | _ -> NotReducible) - -(* Generic reduction function *) - -(* Y avait un commentaire pour whd_betadeltaiota : - - NB : Cette fonction alloue peu c'est l'appel - ``let (c,cargs) = whfun (recarg, empty_stack)'' - ------------------- - qui coute cher *) - -let rec whd_state_gen flags env sigma = - let rec whrec (x, stack as s) = - match kind_of_term x with - | IsRel n when red_delta flags -> - (match lookup_rel_value n env with - | Some body -> whrec (lift n body, stack) - | None -> s) - | IsVar id when red_delta flags -> - (match lookup_named_value id env with - | Some body -> whrec (body, stack) - | None -> s) - | IsEvar ev when red_evar flags -> - (match existential_opt_value sigma ev with - | Some body -> whrec (body, stack) - | None -> s) - | IsConst const when red_delta flags -> - (match constant_opt_value env const with - | Some body -> whrec (body, stack) - | None -> s) - | IsLetIn (_,b,_,c) when red_zeta flags -> stacklam whrec [b] c stack - | IsCast (c,_) -> whrec (c, stack) - | IsApp (f,cl) -> whrec (f, append_stack cl stack) - | IsLambda (na,t,c) -> - (match decomp_stack stack with - | Some (a,m) when red_beta flags -> stacklam whrec [a] c m - | None when red_eta flags -> - let env' = push_rel_assum (na,t) env in - let whrec' = whd_state_gen flags env' sigma in - (match kind_of_term (app_stack (whrec' (c, empty_stack))) with - | IsApp (f,cl) -> - let napp = Array.length cl in - if napp > 0 then - let x', l' = whrec' (array_last cl, empty_stack) in - match kind_of_term x', decomp_stack l' with - | IsRel 1, None -> - let lc = Array.sub cl 0 (napp-1) in - let u = if napp=1 then f else appvect (f,lc) in - if noccurn 1 u then (pop u,empty_stack) else s - | _ -> s - else s - | _ -> s) - | _ -> s) - - | IsMutCase (ci,p,d,lf) when red_iota flags -> - let (c,cargs) = whrec (d, empty_stack) in - if reducible_mind_case c then - whrec (reduce_mind_case - {mP=p; mconstr=c; mcargs=list_of_stack cargs; - mci=ci; mlf=lf}, stack) - else - (mkMutCase (ci, p, app_stack (c,cargs), lf), stack) - - | IsFix fix when red_iota flags -> - (match reduce_fix whrec fix stack with - | Reduced s' -> whrec s' - | NotReducible -> s) - - | x -> s - in - whrec - -let local_whd_state_gen flags = - let rec whrec (x, stack as s) = - match kind_of_term x with - | IsLetIn (_,b,_,c) when red_zeta flags -> stacklam whrec [b] c stack - | IsCast (c,_) -> whrec (c, stack) - | IsApp (f,cl) -> whrec (f, append_stack cl stack) - | IsLambda (_,_,c) -> - (match decomp_stack stack with - | Some (a,m) when red_beta flags -> stacklam whrec [a] c m - | None when red_eta flags -> - (match kind_of_term (app_stack (whrec (c, empty_stack))) with - | IsApp (f,cl) -> - let napp = Array.length cl in - if napp > 0 then - let x', l' = whrec (array_last cl, empty_stack) in - match kind_of_term x', decomp_stack l' with - | IsRel 1, None -> - let lc = Array.sub cl 0 (napp-1) in - let u = if napp=1 then f else appvect (f,lc) in - if noccurn 1 u then (pop u,empty_stack) else s - | _ -> s - else s - | _ -> s) - | _ -> s) - - | IsMutCase (ci,p,d,lf) when red_iota flags -> - let (c,cargs) = whrec (d, empty_stack) in - if reducible_mind_case c then - whrec (reduce_mind_case - {mP=p; mconstr=c; mcargs=list_of_stack cargs; - mci=ci; mlf=lf}, stack) - else - (mkMutCase (ci, p, app_stack (c,cargs), lf), stack) - - | IsFix fix when red_iota flags -> - (match reduce_fix whrec fix stack with - | Reduced s' -> whrec s' - | NotReducible -> s) - - | x -> s - in - whrec - -(* 1. Beta Reduction Functions *) - -let whd_beta_state = local_whd_state_gen beta -let whd_beta_stack x = appterm_of_stack (whd_beta_state (x, empty_stack)) -let whd_beta x = app_stack (whd_beta_state (x,empty_stack)) - -(* Nouveau ! *) -let whd_betaetalet_state = local_whd_state_gen betaetalet -let whd_betaetalet_stack x = - appterm_of_stack (whd_betaetalet_state (x, empty_stack)) -let whd_betaetalet x = app_stack (whd_betaetalet_state (x,empty_stack)) - -(* 2. Delta Reduction Functions *) - -let whd_delta_state e = whd_state_gen delta e -let whd_delta_stack env sigma x = - appterm_of_stack (whd_delta_state env sigma (x, empty_stack)) -let whd_delta env sigma c = - app_stack (whd_delta_state env sigma (c, empty_stack)) - -let whd_betadelta_state e = whd_state_gen betadelta e -let whd_betadelta_stack env sigma x = - appterm_of_stack (whd_betadelta_state env sigma (x, empty_stack)) -let whd_betadelta env sigma c = - app_stack (whd_betadelta_state env sigma (c, empty_stack)) - -let whd_betaevar_state e = whd_state_gen betaevar e -let whd_betaevar_stack env sigma c = - appterm_of_stack (whd_betaevar_state env sigma (c, empty_stack)) -let whd_betaevar env sigma c = - app_stack (whd_betaevar_state env sigma (c, empty_stack)) - - -let whd_betadeltaeta_state e = whd_state_gen betadeltaeta e -let whd_betadeltaeta_stack env sigma x = - appterm_of_stack (whd_betadeltaeta_state env sigma (x, empty_stack)) -let whd_betadeltaeta env sigma x = - app_stack (whd_betadeltaeta_state env sigma (x, empty_stack)) - -(* 3. Iota reduction Functions *) - -let whd_betaiota_state = local_whd_state_gen betaiota -let whd_betaiota_stack x = - appterm_of_stack (whd_betaiota_state (x, empty_stack)) -let whd_betaiota x = - app_stack (whd_betaiota_state (x, empty_stack)) - -let whd_betaiotazeta_state = local_whd_state_gen betaiotazeta -let whd_betaiotazeta_stack x = - appterm_of_stack (whd_betaiotazeta_state (x, empty_stack)) -let whd_betaiotazeta x = - app_stack (whd_betaiotazeta_state (x, empty_stack)) - -let whd_betaiotaevar_state e = whd_state_gen betaiotaevar e -let whd_betaiotaevar_stack env sigma x = - appterm_of_stack (whd_betaiotaevar_state env sigma (x, empty_stack)) -let whd_betaiotaevar env sigma x = - app_stack (whd_betaiotaevar_state env sigma (x, empty_stack)) - -let whd_betadeltaiota_state e = whd_state_gen betadeltaiota e -let whd_betadeltaiota_stack env sigma x = - appterm_of_stack (whd_betadeltaiota_state env sigma (x, empty_stack)) -let whd_betadeltaiota env sigma x = - app_stack (whd_betadeltaiota_state env sigma (x, empty_stack)) - -let whd_betadeltaiotaeta_state e = whd_state_gen betadeltaiotaeta e -let whd_betadeltaiotaeta_stack env sigma x = - appterm_of_stack (whd_betadeltaiotaeta_state env sigma (x, empty_stack)) -let whd_betadeltaiotaeta env sigma x = - app_stack (whd_betadeltaiotaeta_state env sigma (x, empty_stack)) - -let whd_betadeltaiota_nolet_state e = whd_state_gen betadeltaiota_nolet e -let whd_betadeltaiota_nolet_stack env sigma x = - appterm_of_stack (whd_betadeltaiota_nolet_state env sigma (x, empty_stack)) -let whd_betadeltaiota_nolet env sigma x = - app_stack (whd_betadeltaiota_nolet_state env sigma (x, empty_stack)) +let hnf_prod_applist env t nl = + List.fold_left (hnf_prod_app env) t nl (********************************************************************) (* Conversion *) (********************************************************************) -(* -let fkey = Profile.declare_profile "fhnf";; -let fhnf info v = Profile.profile2 fkey fhnf info v;; - -let fakey = Profile.declare_profile "fhnf_apply";; -let fhnf_apply info k h a = Profile.profile4 fakey fhnf_apply info k h a;; -*) - -type 'a conversion_function = - env -> 'a evar_map -> constr -> constr -> constraints (* Conversion utility functions *) - -type conversion_test = constraints -> constraints +type 'a conversion_function = env -> 'a -> 'a -> constraints exception NotConvertible +exception NotConvertibleVect of int (* Convertibility of sorts *) @@ -454,12 +73,6 @@ type conv_pb = | CONV | CUMUL -let pb_is_equal pb = pb = CONV - -let pb_equal = function - | CUMUL -> CONV - | CONV -> CONV - let sort_cmp pb s0 s1 cuniv = match (s0,s1) with | (Prop c1, Prop c2) -> if c1 = c2 then cuniv else raise NotConvertible @@ -473,13 +86,6 @@ let sort_cmp pb s0 s1 cuniv = | CUMUL -> enforce_geq u2 u1 cuniv) | (_, _) -> raise NotConvertible -let base_sort_cmp pb s0 s1 = - match (s0,s1) with - | (Prop c1, Prop c2) -> c1 = c2 - | (Prop c1, Type u) -> pb = CUMUL - | (Type u1, Type u2) -> true - | (_, _) -> false - (* Conversion between [lft1]term1 and [lft2]term2 *) let rec ccnv cv_pb infos lft1 lft2 term1 term2 cuniv = eqappr cv_pb infos (lft1, fhnf infos term1) (lft2, fhnf infos term2) cuniv @@ -494,15 +100,20 @@ and eqappr cv_pb infos appr1 appr2 cuniv = (* case of leaves *) | (FAtom a1, FAtom a2) -> (match kind_of_term a1, kind_of_term a2 with - | (IsSort s1, IsSort s2) -> + | (Sort s1, Sort s2) -> if stack_args_size v1 = 0 && stack_args_size v2 = 0 then sort_cmp cv_pb s1 s2 cuniv else raise NotConvertible - | (IsMeta n, IsMeta m) -> + | (Meta n, Meta m) -> if n=m then convert_stacks infos lft1 lft2 v1 v2 cuniv else raise NotConvertible | _ -> raise NotConvertible) + | (FEvar (ev1,args1), FEvar (ev2,args2)) -> + if ev1=ev2 then + let u1 = convert_vect infos el1 el2 args1 args2 cuniv in + convert_stacks infos lft1 lft2 v1 v2 u1 + else raise NotConvertible (* 2 index known to be bound to no constant *) | (FRel n, FRel m) -> @@ -575,13 +186,14 @@ and eqappr cv_pb infos appr1 appr2 cuniv = convert_stacks infos lft1 lft2 v1 v2 u3 | (FInd op1, FInd op2) -> - if op1 = op2 - then convert_stacks infos lft1 lft2 v1 v2 cuniv + if op1 = op2 then + convert_stacks infos lft1 lft2 v1 v2 cuniv else raise NotConvertible | (FConstruct op1, FConstruct op2) -> if op1 = op2 - then convert_stacks infos lft1 lft2 v1 v2 cuniv + then + convert_stacks infos lft1 lft2 v1 v2 cuniv else raise NotConvertible | (FFix (op1,(_,tys1,cl1),_,_), FFix(op2,(_,tys2,cl2),_,_)) -> @@ -631,241 +243,80 @@ and convert_vect infos lft1 lft2 v1 v2 cuniv = -let fconv cv_pb env sigma t1 t2 = +let fconv cv_pb env t1 t2 = if eq_constr t1 t2 then Constraint.empty else - let infos = create_clos_infos hnf_flags env sigma in + let infos = create_clos_infos hnf_flags env in ccnv cv_pb infos ELID ELID (inject t1) (inject t2) Constraint.empty let conv env = fconv CONV env -let conv_leq env = fconv CUMUL env - -(* -let convleqkey = Profile.declare_profile "conv_leq";; -let conv_leq env sigma t1 t2 = - Profile.profile4 convleqkey conv_leq env sigma t1 t2;; - -let convkey = Profile.declare_profile "conv";; -let conv env sigma t1 t2 = - Profile.profile4 convleqkey conv env sigma t1 t2;; -*) - -let conv_forall2 f env sigma v1 v2 = - array_fold_left2 - (fun c x y -> let c' = f env sigma x y in Constraint.union c c') - Constraint.empty - v1 v2 +let conv_leq env = fconv CUMUL env -let conv_forall2_i f env sigma v1 v2 = +let conv_leq_vecti env v1 v2 = array_fold_left2_i - (fun i c x y -> let c' = f i env sigma x y in Constraint.union c c') + (fun i c t1 t2 -> + let c' = + try conv_leq env t1 t2 + with NotConvertible -> raise (NotConvertibleVect i) in + Constraint.union c c') Constraint.empty - v1 v2 + v1 + v2 -let test_conversion f env sigma x y = - try let _ = f env sigma x y in true with NotConvertible -> false +(* +let convleqkey = Profile.declare_profile "Kernel_reduction.conv_leq";; +let conv_leq env t1 t2 = + Profile.profile4 convleqkey conv_leq env t1 t2;; -let is_conv env sigma = test_conversion conv env sigma -let is_conv_leq env sigma = test_conversion conv_leq env sigma -let is_fconv = function | CONV -> is_conv | CUMUL -> is_conv_leq +let convkey = Profile.declare_profile "Kernel_reduction.conv";; +let conv env t1 t2 = + Profile.profile4 convleqkey conv env t1 t2;; +*) (********************************************************************) (* Special-Purpose Reduction *) (********************************************************************) -let whd_meta metamap c = match kind_of_term c with - | IsMeta p -> (try List.assoc p metamap with Not_found -> c) - | _ -> c - -(* Try to replace all metas. Does not replace metas in the metas' values - * Differs from (strong whd_meta). *) -let plain_instance s c = - let rec irec u = match kind_of_term u with - | IsMeta p -> (try List.assoc p s with Not_found -> u) - | IsCast (m,_) when isMeta m -> - (try List.assoc (destMeta m) s with Not_found -> u) - | _ -> map_constr irec u - in - if s = [] then c else irec c - -(* Pourquoi ne fait-on pas nf_betaiota si s=[] ? *) -let instance s c = - if s = [] then c else local_strong whd_betaiota (plain_instance s c) - +(* Dealing with arities *) -(* pseudo-reduction rule: - * [hnf_prod_app env s (Prod(_,B)) N --> B[N] - * with an HNF on the first argument to produce a product. - * if this does not work, then we use the string S as part of our - * error message. *) - -let hnf_prod_app env sigma t n = - match kind_of_term (whd_betadeltaiota env sigma t) with - | IsProd (_,_,b) -> subst1 n b - | _ -> anomaly "hnf_prod_app: Need a product" - -let hnf_prod_appvect env sigma t nl = - Array.fold_left (hnf_prod_app env sigma) t nl - -let hnf_prod_applist env sigma t nl = - List.fold_left (hnf_prod_app env sigma) t nl - -let hnf_lam_app env sigma t n = - match kind_of_term (whd_betadeltaiota env sigma t) with - | IsLambda (_,_,b) -> subst1 n b - | _ -> anomaly "hnf_lam_app: Need an abstraction" - -let hnf_lam_appvect env sigma t nl = - Array.fold_left (hnf_lam_app env sigma) t nl - -let hnf_lam_applist env sigma t nl = - List.fold_left (hnf_lam_app env sigma) t nl - -let splay_prod env sigma = +let dest_prod env = let rec decrec env m c = - let t = whd_betadeltaiota env sigma c in + let t = whd_betadeltaiota env c in match kind_of_term t with - | IsProd (n,a,c0) -> - decrec (push_rel_assum (n,a) env) - ((n,a)::m) c0 + | Prod (n,a,c0) -> + let d = (n,None,a) in + decrec (push_rel d env) (Sign.add_rel_decl d m) c0 | _ -> m,t in decrec env [] -let splay_prod_assum env sigma = - let rec prodec_rec env l c = - let t = whd_betadeltaiota_nolet env sigma c in - match kind_of_term c with - | IsProd (x,t,c) -> - prodec_rec (push_rel_assum (x,t) env) - (Sign.add_rel_assum (x, t) l) c - | IsLetIn (x,b,t,c) -> - prodec_rec (push_rel_def (x,b, t) env) - (Sign.add_rel_def (x,b, t) l) c - | IsCast (c,_) -> prodec_rec env l c - | _ -> l,t +(* The same but preserving lets *) +let dest_prod_assum env = + let rec prodec_rec env l ty = + let rty = whd_betadeltaiota_nolet env ty in + match kind_of_term rty with + | Prod (x,t,c) -> + let d = (x,None,t) in + prodec_rec (push_rel d env) (Sign.add_rel_decl d l) c + | LetIn (x,b,t,c) -> + let d = (x,Some b,t) in + prodec_rec (push_rel d env) (Sign.add_rel_decl d l) c + | Cast (c,_) -> prodec_rec env l c + | _ -> l,rty in prodec_rec env Sign.empty_rel_context -let splay_arity env sigma c = - let l, c = splay_prod env sigma c in +let dest_arity env c = + let l, c = dest_prod env c in match kind_of_term c with - | IsSort s -> l,s + | Sort s -> l,s | _ -> error "not an arity" -let sort_of_arity env c = snd (splay_arity env Evd.empty c) - -let decomp_n_prod env sigma n = - let rec decrec env m ln c = if m = 0 then (ln,c) else - match kind_of_term (whd_betadeltaiota env sigma c) with - | IsProd (n,a,c0) -> - decrec (push_rel_assum (n,a) env) - (m-1) (Sign.add_rel_assum (n,a) ln) c0 - | _ -> error "decomp_n_prod: Not enough products" - in - decrec env n Sign.empty_rel_context - -(* One step of approximation *) - -let rec apprec env sigma s = - let (t, stack as s) = whd_betaiota_state s in - match kind_of_term t with - | IsMutCase (ci,p,d,lf) -> - let (cr,crargs) = whd_betadeltaiota_stack env sigma d in - let rslt = mkMutCase (ci, p, applist (cr,crargs), lf) in - if reducible_mind_case cr then - apprec env sigma (rslt, stack) - else - s - | IsFix fix -> - (match reduce_fix (whd_betadeltaiota_state env sigma) fix stack with - | Reduced s -> apprec env sigma s - | NotReducible -> s) - | _ -> s - -let hnf env sigma c = apprec env sigma (c, empty_stack) - -(* A reduction function like whd_betaiota but which keeps casts - * and does not reduce redexes containing existential variables. - * Used in Correctness. - * Added by JCF, 29/1/98. *) - -let whd_programs_stack env sigma = - let rec whrec (x, stack as s) = - match kind_of_term x with - | IsApp (f,cl) -> - let n = Array.length cl - 1 in - let c = cl.(n) in - if occur_existential c then - s - else - whrec (mkApp (f, Array.sub cl 0 n), append_stack [|c|] stack) - | IsLetIn (_,b,_,c) -> - if occur_existential b then - s - else - stacklam whrec [b] c stack - | IsLambda (_,_,c) -> - (match decomp_stack stack with - | None -> s - | Some (a,m) -> stacklam whrec [a] c m) - | IsMutCase (ci,p,d,lf) -> - if occur_existential d then - s - else - let (c,cargs) = whrec (d, empty_stack) in - if reducible_mind_case c then - whrec (reduce_mind_case - {mP=p; mconstr=c; mcargs=list_of_stack cargs; - mci=ci; mlf=lf}, stack) - else - (mkMutCase (ci, p, app_stack(c,cargs), lf), stack) - | IsFix fix -> - (match reduce_fix whrec fix stack with - | Reduced s' -> whrec s' - | NotReducible -> s) - | _ -> s - in - whrec - -let whd_programs env sigma x = - app_stack (whd_programs_stack env sigma (x, empty_stack)) +let is_arity env c = + try + let _ = dest_arity env c in + true + with UserError _ -> false -exception IsType - -let find_conclusion env sigma = - let rec decrec env c = - let t = whd_betadeltaiota env sigma c in - match kind_of_term t with - | IsProd (x,t,c0) -> decrec (push_rel_assum (x,t) env) c0 - | IsLambda (x,t,c0) -> decrec (push_rel_assum (x,t) env) c0 - | t -> t - in - decrec env - -let is_arity env sigma c = - match find_conclusion env sigma c with - | IsSort _ -> true - | _ -> false - -let info_arity env sigma c = - match find_conclusion env sigma c with - | IsSort (Prop Null) -> false - | IsSort (Prop Pos) -> true - | _ -> raise IsType - -let is_info_arity env sigma c = - try (info_arity env sigma c) with IsType -> true - -let is_type_arity env sigma c = - match find_conclusion env sigma c with - | IsSort (Type _) -> true - | _ -> false - -let is_info_type env sigma t = - let s = t.utj_type in - (s = Prop Pos) || - (s <> Prop Null && - try info_arity env sigma t.utj_val with IsType -> true) diff --git a/kernel/reduction.mli b/kernel/reduction.mli index 09d47fec9..d67b321e9 100644 --- a/kernel/reduction.mli +++ b/kernel/reduction.mli @@ -9,195 +9,39 @@ (*i $Id$ i*) (*i*) -open Names open Term -open Univ -open Evd open Environ -open Closure (*i*) -(* Reduction Functions. *) - -exception Elimconst - -type state = constr * constr stack - -type 'a contextual_reduction_function = env -> 'a evar_map -> constr -> constr -type 'a reduction_function = 'a contextual_reduction_function -type local_reduction_function = constr -> constr - -type 'a contextual_stack_reduction_function = - env -> 'a evar_map -> constr -> constr * constr list -type 'a stack_reduction_function = 'a contextual_stack_reduction_function -type local_stack_reduction_function = constr -> constr * constr list - -type 'a contextual_state_reduction_function = - env -> 'a evar_map -> state -> state -type 'a state_reduction_function = 'a contextual_state_reduction_function -type local_state_reduction_function = state -> state - -(* Removes cast and put into applicative form *) -val whd_stack : local_stack_reduction_function - -(* For compatibility: alias for whd\_stack *) -val whd_castapp_stack : local_stack_reduction_function - -(*s Reduction Function Operators *) - -val strong : 'a reduction_function -> 'a reduction_function -val local_strong : local_reduction_function -> local_reduction_function -val strong_prodspine : local_reduction_function -> local_reduction_function -(*i -val stack_reduction_of_reduction : - 'a reduction_function -> 'a state_reduction_function -i*) -val stacklam : (state -> 'a) -> constr list -> constr -> constr stack -> 'a - -(*s Generic Optimized Reduction Function using Closures *) - -val clos_norm_flags : Closure.flags -> 'a reduction_function -(* Same as [(strong whd_beta[delta][iota])], but much faster on big terms *) -val nf_beta : local_reduction_function -val nf_betaiota : local_reduction_function -val nf_betadeltaiota : 'a reduction_function - -(* Lazy strategy, weak head reduction *) -val whd_beta : local_reduction_function -val whd_betaiota : local_reduction_function -val whd_betaiotazeta : local_reduction_function -val whd_betadeltaiota : 'a contextual_reduction_function -val whd_betadeltaiota_nolet : 'a contextual_reduction_function -val whd_betaetalet : local_reduction_function - -val whd_beta_stack : local_stack_reduction_function -val whd_betaiota_stack : local_stack_reduction_function -val whd_betaiotazeta_stack : local_stack_reduction_function -val whd_betadeltaiota_stack : 'a contextual_stack_reduction_function -val whd_betadeltaiota_nolet_stack : 'a contextual_stack_reduction_function -val whd_betaetalet_stack : local_stack_reduction_function - -val whd_beta_state : local_state_reduction_function -val whd_betaiota_state : local_state_reduction_function -val whd_betaiotazeta_state : local_state_reduction_function -val whd_betadeltaiota_state : 'a contextual_state_reduction_function -val whd_betadeltaiota_nolet_state : 'a contextual_state_reduction_function -val whd_betaetalet_state : local_state_reduction_function - -(*s Head normal forms *) - -val whd_delta_stack : 'a stack_reduction_function -val whd_delta_state : 'a state_reduction_function -val whd_delta : 'a reduction_function -val whd_betadelta_stack : 'a stack_reduction_function -val whd_betadelta_state : 'a state_reduction_function -val whd_betadelta : 'a reduction_function -val whd_betaevar_stack : 'a stack_reduction_function -val whd_betaevar_state : 'a state_reduction_function -val whd_betaevar : 'a reduction_function -val whd_betaiotaevar_stack : 'a stack_reduction_function -val whd_betaiotaevar_state : 'a state_reduction_function -val whd_betaiotaevar : 'a reduction_function -val whd_betadeltaeta_stack : 'a stack_reduction_function -val whd_betadeltaeta_state : 'a state_reduction_function -val whd_betadeltaeta : 'a reduction_function -val whd_betadeltaiotaeta_stack : 'a stack_reduction_function -val whd_betadeltaiotaeta_state : 'a state_reduction_function -val whd_betadeltaiotaeta : 'a reduction_function - -val beta_applist : constr * constr list -> constr - -val hnf_prod_app : env -> 'a evar_map -> constr -> constr -> constr -val hnf_prod_appvect : env -> 'a evar_map -> constr -> constr array -> constr -val hnf_prod_applist : env -> 'a evar_map -> constr -> constr list -> constr -val hnf_lam_app : env -> 'a evar_map -> constr -> constr -> constr -val hnf_lam_appvect : env -> 'a evar_map -> constr -> constr array -> constr -val hnf_lam_applist : env -> 'a evar_map -> constr -> constr list -> constr - -val splay_prod : env -> 'a evar_map -> constr -> (name * constr) list * constr -val splay_arity : env -> 'a evar_map -> constr -> (name * constr) list * sorts -val sort_of_arity : env -> constr -> sorts -val decomp_n_prod : - env -> 'a evar_map -> int -> constr -> Sign.rel_context * constr -val splay_prod_assum : - env -> 'a evar_map -> constr -> Sign.rel_context * constr - -type 'a miota_args = { - mP : constr; (* the result type *) - mconstr : constr; (* the constructor *) - mci : case_info; (* special info to re-build pattern *) - mcargs : 'a list; (* the constructor's arguments *) - mlf : 'a array } (* the branch code vector *) - -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_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 whd_programs : 'a reduction_function - -(* [reduce_fix] contracts a fix redex if it is actually reducible *) +(***********************************************************************) +(*s Reduction functions *) -type fix_reduction_result = NotReducible | Reduced of state +val whd_betadeltaiota : env -> constr -> constr +val whd_betadeltaiota_nolet : env -> constr -> constr -val fix_recarg : fixpoint -> constr stack -> (int * constr) option -val reduce_fix : local_state_reduction_function -> fixpoint - -> constr stack -> fix_reduction_result +val nf_betaiota : constr -> constr +val hnf_stack : env -> constr -> constr * constr list +val hnf_prod_applist : env -> types -> constr list -> types -(*s Conversion Functions (uses closures, lazy strategy) *) +(* Builds an application node, reducing beta redexes it may produce. *) +val beta_appvect : constr -> constr array -> constr -type conversion_test = constraints -> constraints +(***********************************************************************) +(*s conversion functions *) exception NotConvertible +exception NotConvertibleVect of int +type 'a conversion_function = env -> 'a -> 'a -> Univ.constraints -type conv_pb = - | CONV - | CUMUL - -val pb_is_equal : conv_pb -> bool -val pb_equal : conv_pb -> conv_pb - -val sort_cmp : conv_pb -> sorts -> sorts -> conversion_test -val base_sort_cmp : conv_pb -> sorts -> sorts -> bool +val conv : constr conversion_function +val conv_leq : types conversion_function +val conv_leq_vecti : types array conversion_function -type 'a conversion_function = - env -> 'a evar_map -> constr -> constr -> constraints - -(* [fconv] has 2 instances: [conv = fconv CONV] i.e. conversion test, and - [conv_leq = fconv CONV_LEQ] i.e. cumulativity test. *) - -val conv : 'a conversion_function -val conv_leq : 'a conversion_function - -val conv_forall2 : - 'a conversion_function -> env -> 'a evar_map -> constr array - -> constr array -> constraints - -val conv_forall2_i : - (int -> 'a conversion_function) -> env -> 'a evar_map - -> constr array -> constr array -> constraints - -val is_conv : env -> 'a evar_map -> constr -> constr -> bool -val is_conv_leq : env -> 'a evar_map -> constr -> constr -> bool -val is_fconv : conv_pb -> env -> 'a evar_map -> constr -> constr -> bool - -(*s Special-Purpose Reduction Functions *) - -val whd_meta : (int * constr) list -> constr -> constr -val plain_instance : (int * constr) list -> constr -> constr -val instance : (int * constr) list -> constr -> constr - -(*s Obsolete Reduction Functions *) +(***********************************************************************) +(*s Recognizing products and arities modulo reduction *) -(*i -val hnf : env -> 'a evar_map -> constr -> constr * constr list -i*) -val apprec : 'a state_reduction_function +val dest_prod : env -> types -> Sign.rel_context * types +val dest_prod_assum : env -> types -> Sign.rel_context * types +val dest_arity : env -> types -> arity +val is_arity : env -> types -> bool diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index a6ae51f89..c770e0237 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -8,7 +8,6 @@ (* $Id$ *) -open Pp open Util open Names open Univ @@ -19,169 +18,16 @@ open Declarations open Inductive open Environ open Type_errors -open Typeops open Indtypes type judgment = unsafe_judgment - -let j_val j = j.uj_val -let j_type j = body_of_type j.uj_type - -let vect_lift = Array.mapi lift -let vect_lift_type = Array.mapi (fun i t -> type_app (lift i) t) - -(* The typing machine without information. *) - - (* ATTENTION : faudra faire le typage du contexte des Const, - MutInd et MutConstructsi un jour cela devient des constructions - arbitraires et non plus des variables *) - -let univ_combinator (cst,univ) (j,c') = - (j,(Constraint.union cst c', merge_constraints c' univ)) - -let rec execute env cstr cu = - match kind_of_term cstr with - | IsMeta _ -> - anomaly "the kernel does not understand metas" - | IsEvar _ -> - anomaly "the kernel does not understand existential variables" - - | IsSort (Prop c) -> - (judge_of_prop_contents c, cu) - - | IsSort (Type u) -> - univ_combinator cu (judge_of_type u) - - | IsApp (f,args) -> - let (j,cu1) = execute env f cu in - let (jl,cu2) = execute_array env args cu1 in - univ_combinator cu2 - (apply_rel_list env Evd.empty false (Array.to_list jl) j) - - | IsLambda (name,c1,c2) -> - let (j,cu1) = execute env c1 cu in - let var = assumption_of_judgment env Evd.empty j in - let env1 = push_rel_assum (name,var) env in - let (j',cu2) = execute env1 c2 cu1 in - univ_combinator cu2 (abs_rel env1 Evd.empty name var j') - - | IsProd (name,c1,c2) -> - let (j,cu1) = execute env c1 cu in - let varj = type_judgment env Evd.empty j in - let env1 = push_rel_assum (name,varj.utj_val) env in - let (j',cu2) = execute env1 c2 cu1 in - let varj' = type_judgment env Evd.empty j' in - univ_combinator cu2 - (gen_rel env1 Evd.empty name varj varj') - - | IsLetIn (name,c1,c2,c3) -> - let (j,cu1) = execute env (mkCast(c1,c2)) cu in - let env1 = push_rel_def (name,j.uj_val,j.uj_type) env in - let (j',cu2) = execute env1 c3 cu1 in - univ_combinator cu2 - (judge_of_letin env1 Evd.empty name j j') - - | IsCast (c,t) -> - let (cj,cu1) = execute env c cu in - let (tj,cu2) = execute env t cu1 in - let tj = assumption_of_judgment env Evd.empty tj in - univ_combinator cu2 - (cast_rel env Evd.empty cj tj) - - | IsRel n -> - (relative env n, cu) - - | IsVar id -> - (make_judge cstr (lookup_named_type id env), cu) - - | IsConst c -> - (make_judge cstr (type_of_constant env Evd.empty c), cu) - - (* Inductive types *) - | IsMutInd ind -> - (make_judge cstr (type_of_inductive env Evd.empty ind), cu) - - | IsMutConstruct c -> - (make_judge cstr (type_of_constructor env Evd.empty c), cu) - - | IsMutCase (ci,p,c,lf) -> - let (cj,cu1) = execute env c cu in - let (pj,cu2) = execute env p cu1 in - let (lfj,cu3) = execute_array env lf cu2 in - univ_combinator cu3 - (judge_of_case env Evd.empty ci pj cj lfj) - - | IsFix ((vn,i as vni),recdef) -> - if array_exists (fun n -> n < 0) vn then - error "General Fixpoints not allowed"; - let ((_,tys,_ as recdef'),cu1) = execute_fix env recdef cu in - let fix = (vni,recdef') in - check_fix env Evd.empty fix; - (make_judge (mkFix fix) tys.(i), cu1) - - | IsCoFix (i,recdef) -> - let ((_,tys,_ as recdef'),cu1) = execute_fix env recdef cu in - let cofix = (i,recdef') in - check_cofix env Evd.empty cofix; - (make_judge (mkCoFix cofix) tys.(i), cu1) - -and execute_fix env (names,lar,vdef) cu = - let (larj,cu1) = execute_array env lar cu in - let lara = Array.map (assumption_of_judgment env Evd.empty) larj in - let env1 = push_rec_types (names,lara,vdef) env in - let (vdefj,cu2) = execute_array env1 vdef cu1 in - let vdefv = Array.map j_val vdefj in - let cst = type_fixpoint env1 Evd.empty names lara vdefj in - univ_combinator cu2 ((names,lara,vdefv),cst) - -and execute_array env v cu = - let (jl,cu1) = execute_list env (Array.to_list v) cu in - (Array.of_list jl, cu1) - -and execute_list env l cu = - match l with - | [] -> - ([], cu) - | c::r -> - let (j,cu1) = execute env c cu in - let (jr,cu2) = execute_list env r cu1 in - (j::jr, cu2) - -(* The typed type of a judgment. *) - -let execute_type env constr cu = - let (j,cu1) = execute env constr cu in - (type_judgment env Evd.empty j, cu1) +let j_val = j_val +let j_type = j_type (* Exported machines. *) -let safe_infer env constr = - let (j,(cst,_)) = - execute env constr (Constraint.empty, universes env) in - (j, cst) - -let safe_infer_type env constr = - let (j,(cst,_)) = - execute_type env constr (Constraint.empty, universes env) in - (j, cst) - -(* Typing of several terms. *) - -let safe_infer_l env cl = - let type_one (cst,l) c = - let (j,cst') = safe_infer env c in - (Constraint.union cst cst', j::l) - in - List.fold_left type_one (Constraint.empty,[]) cl - -let safe_infer_v env cv = - let type_one (cst,l) c = - let (j,cst') = safe_infer env c in - (Constraint.union cst cst', j::l) - in - let cst',l = Array.fold_left type_one (Constraint.empty,[]) cv in - (cst', Array.of_list l) - +let safe_infer = Typeops.infer +let safe_infer_type = Typeops.infer_type (*s Safe environments. *) @@ -189,273 +35,107 @@ type safe_environment = env let empty_environment = empty_env -let universes = universes -let context = context -let named_context = named_context - -let lookup_named_type = lookup_named_type -let lookup_rel_type = lookup_rel_type -let lookup_named = lookup_named -let lookup_constant = lookup_constant -let lookup_mind = lookup_mind -let lookup_mind_specif = lookup_mind_specif - (* Insertion of variables (named and de Bruijn'ed). They are now typed before being added to the environment. *) let push_rel_or_named_def push (id,b) env = let (j,cst) = safe_infer env b in let env' = add_constraints cst env in - push (id,j.uj_val,j.uj_type) env' + let env'' = push (id,Some j.uj_val,j.uj_type) env' in + (cst,env'') -let push_named_def = push_rel_or_named_def push_named_def -let push_rel_def = push_rel_or_named_def push_rel_def +let push_named_def = push_rel_or_named_def push_named_decl +let push_rel_def = push_rel_or_named_def push_rel let push_rel_or_named_assum push (id,t) env = let (j,cst) = safe_infer env t in + let t = Typeops.assumption_of_judgment env j in let env' = add_constraints cst env in - let t = assumption_of_judgment env Evd.empty j in - push (id,t) env' - -let push_named_assum = push_rel_or_named_assum push_named_assum -let push_rel_assum = push_rel_or_named_assum push_rel_assum - -let check_and_push_named_def (id,b) env = - let (j,cst) = safe_infer env b in - let env' = add_constraints cst env in - let env'' = Environ.push_named_def (id,j.uj_val,j.uj_type) env' in - (Some j.uj_val,j.uj_type,cst),env'' + let env'' = push (id,None,t) env' in + (cst,env'') -let check_and_push_named_assum (id,t) env = - let (j,cst) = safe_infer env t in - let env' = add_constraints cst env in - let t = assumption_of_judgment env Evd.empty j in - let env'' = Environ.push_named_assum (id,t) env' in - (None,t,cst),env'' +let push_named_assum = push_rel_or_named_assum push_named_decl +let push_rel_assum d env = snd (push_rel_or_named_assum push_rel d env) let push_rels_with_univ vars env = List.fold_left (fun env nvar -> push_rel_assum nvar env) env vars -let safe_infer_local_decl env id = function - | LocalDef c -> - let (j,cst) = safe_infer env c in - (Name id, Some j.uj_val, j.uj_type), cst - | LocalAssum c -> - let (j,cst) = safe_infer env c in - (Name id, None, assumption_of_judgment env Evd.empty j), cst - -let safe_infer_local_decls env decls = - let rec inferec env = function - | (id, d) :: l -> - let env, l, cst1 = inferec env l in - let d, cst2 = safe_infer_local_decl env id d in - push_rel d env, d :: l, Constraint.union cst1 cst2 - | [] -> env, [], Constraint.empty in - inferec env decls - (* Insertion of constants and parameters in environment. *) -type global_declaration = Def of constr | Assum of constr +type global_declaration = Def of constr * bool | Assum of constr -let safe_infer_declaration env = function - | Def c -> +(* Definition always declared transparent *) +let safe_infer_declaration env dcl = + match dcl with + | Def (c,op) -> let (j,cst) = safe_infer env c in - Some j.uj_val, j.uj_type, cst + Some j.uj_val, j.uj_type, cst, op | Assum t -> let (j,cst) = safe_infer env t in - None, assumption_of_judgment env Evd.empty j, cst + None, Typeops.assumption_of_judgment env j, cst, false -type local_names = (identifier * variable) list - -let add_global_declaration sp env locals (body,typ,cst) op = +let add_global_declaration sp env (body,typ,cst,op) = let env' = add_constraints cst env in let ids = match body with | None -> global_vars_set env typ | Some b -> Idset.union (global_vars_set env b) (global_vars_set env typ) in - let hyps = keep_hyps env ids (named_context env) in - let sp_hyps = List.map (fun (id,b,t) -> (List.assoc id locals, b, t)) hyps in + let hyps = keep_hyps env ids in let cb = { - const_kind = kind_of_path sp; const_body = body; const_type = typ; - const_hyps = sp_hyps; + const_hyps = hyps; const_constraints = cst; - const_opaque = op } - in + const_opaque = op } in Environ.add_constant sp cb env' -let add_parameter sp t locals env = - add_global_declaration - sp env locals (safe_infer_declaration env (Assum t)) false +let add_parameter sp t env = + add_global_declaration sp env (safe_infer_declaration env (Assum t)) + +(*s Global and local constant declaration. *) -let add_constant sp ce locals env = - let { const_entry_body = body; - const_entry_type = typ; - const_entry_opaque = op } = ce in - let body' = - match typ with - | None -> body - | Some ty -> mkCast (body, ty) in - add_global_declaration - sp env locals (safe_infer_declaration env (Def body')) op +type constant_entry = { + const_entry_body : constr; + const_entry_type : types option; + const_entry_opaque : bool } -let add_discharged_constant sp r locals env = +let add_constant sp ce env = + let body = + match ce.const_entry_type with + | None -> ce.const_entry_body + | Some ty -> mkCast (ce.const_entry_body, ty) in + add_global_declaration sp env + (safe_infer_declaration env (Def (body, ce.const_entry_opaque))) + +let add_discharged_constant sp r env = let (body,typ,cst,op) = Cooking.cook_constant env r in - let env' = add_constraints cst env in match body with | None -> - add_parameter sp typ locals (* Bricolage avant poubelle *) env' + add_parameter sp typ (* Bricolage avant poubelle *) env | Some c -> (* let c = hcons1_constr c in *) - let ids = - Idset.union (global_vars_set env c) (global_vars_set env typ) in - let hyps = keep_hyps env ids (named_context env') in - let sp_hyps = - List.map (fun (id,b,t) -> (List.assoc id locals,b,t)) hyps in + let ids = + Idset.union (global_vars_set env c) + (global_vars_set env (body_of_type typ)) + in + let hyps = keep_hyps env ids in + let env' = Environ.add_constraints cst env in let cb = - { const_kind = kind_of_path sp; - const_body = Some c; + { const_body = Some c; const_type = typ; - const_hyps = sp_hyps; + const_hyps = hyps; const_constraints = cst; - const_opaque = op } - in + const_opaque = op } in Environ.add_constant sp cb env' (* Insertion of inductive types. *) -(* Only the case where at least s1 or s2 is a [Type] is taken into account *) -let max_universe (s1,cst1) (s2,cst2) g = - match s1,s2 with - | Type u1, Type u2 -> - let (u12,cst) = sup u1 u2 g in - Type u12, Constraint.union cst (Constraint.union cst1 cst2) - | Type u1, _ -> s1, cst1 - | _, _ -> s2, cst2 - -(* This (re)computes informations relevant to extraction and the sort of an - arity or type constructor; we do not to recompute universes constraints *) - -let rec infos_and_sort env t = - match kind_of_term t with - | IsProd (name,c1,c2) -> - let (varj,_) = safe_infer_type env c1 in - let env1 = Environ.push_rel_assum (name,varj.utj_val) env in - let s1 = varj.utj_type in - let logic = not (is_info_type env Evd.empty varj) in - let small = is_small s1 in - (logic,small) :: (infos_and_sort env1 c2) - | IsCast (c,_) -> infos_and_sort env c - | _ -> [] - -(* [infos] is a sequence of pair [islogic,issmall] for each type in - the product of a constructor or arity *) +let add_mind sp mie env = + let mib = check_inductive env mie in + let cst = mib.mind_constraints in + Environ.add_mind sp mib (add_constraints cst env) -let is_small infos = List.for_all (fun (logic,small) -> small) infos -let is_logic_constr infos = List.for_all (fun (logic,small) -> logic) infos -let is_logic_arity infos = - List.for_all (fun (logic,small) -> logic || small) infos - -let is_unit arinfos constrsinfos = - match constrsinfos with (* One info = One constructor *) - | [constrinfos] -> is_logic_constr constrinfos && is_logic_arity arinfos - | _ -> false - -let small_unit constrsinfos (env_ar_par,short_arity) = - let issmall = List.for_all is_small constrsinfos in - let arinfos = infos_and_sort env_ar_par short_arity in - let isunit = is_unit arinfos constrsinfos in - issmall, isunit - -(* [smax] is the max of the sorts of the products of the constructor type *) - -let enforce_type_constructor arsort smax cst = - match smax, arsort with - | Type uc, Type ua -> enforce_geq ua uc cst - | _,_ -> cst - -let type_one_constructor env_ar_par params arsort c = - let infos = infos_and_sort env_ar_par c in - - (* Each constructor is typed-checked here *) - let (j,cst) = safe_infer_type env_ar_par c in - let full_cstr_type = it_mkProd_or_LetIn j.utj_val params in - - (* If the arity is at some level Type arsort, then the sort of the - constructor must be below arsort; here we consider constructors with the - global parameters (which add a priori more constraints on their sort) *) - let cst2 = enforce_type_constructor arsort j.utj_type cst in - - (infos, full_cstr_type, cst2) - -let infer_constructor_packet env_ar params short_arity arsort vc = - let env_ar_par = push_rels params env_ar in - let (constrsinfos,jlc,cst) = - List.fold_right - (fun c (infosl,l,cst) -> - let (infos,ct,cst') = - type_one_constructor env_ar_par params arsort c in - (infos::infosl,ct::l, Constraint.union cst cst')) - vc - ([],[],Constraint.empty) in - let vc' = Array.of_list jlc in - let issmall,isunit = small_unit constrsinfos (env_ar_par,short_arity) in - (issmall,isunit,vc', cst) - -let add_mind sp mie locals env = - mind_check_wellformed env mie; - - (* We first type params and arity of each inductive definition *) - (* This allows to build the environment of arities and to share *) - (* the set of constraints *) - let cst, env_arities, rev_params_arity_list = - List.fold_left - (fun (cst,env_arities,l) ind -> - (* Params are typed-checked here *) - let params = ind.mind_entry_params in - let env_params, params, cst1 = safe_infer_local_decls env params in - (* Arities (without params) are typed-checked here *) - let arity, cst2 = safe_infer_type env_params ind.mind_entry_arity in - (* We do not need to generate the universe of full_arity; if - later, after the validation of the inductive definition, - full_arity is used as argument or subject to cast, an - upper universe will be generated *) - let id = ind.mind_entry_typename in - let full_arity = it_mkProd_or_LetIn arity.utj_val params in - Constraint.union cst (Constraint.union cst1 cst2), - push_rel_assum (Name id, full_arity) env_arities, - (params, id, full_arity, arity.utj_val)::l) - (Constraint.empty,env,[]) - mie.mind_entry_inds in - - let params_arity_list = List.rev rev_params_arity_list in - - (* Now, we type the constructors (without params) *) - let inds,cst = - List.fold_right2 - (fun ind (params,id,full_arity,short_arity) (inds,cst) -> - let arsort = sort_of_arity env full_arity in - let lc = ind.mind_entry_lc in - let (issmall,isunit,lc',cst') = - infer_constructor_packet env_arities params short_arity arsort lc - in - let nparams = ind.mind_entry_nparams in - let consnames = ind.mind_entry_consnames in - let ind' = (params,nparams,id,full_arity,consnames,issmall,isunit,lc') - in - (ind'::inds, Constraint.union cst cst')) - mie.mind_entry_inds - params_arity_list - ([],cst) in - - (* Finally, we build the inductive packet and push it to env *) - let kind = kind_of_path sp in - let mib = cci_inductive locals env env_arities kind mie.mind_entry_finite inds cst - in - add_mind sp mib (add_constraints cst env) - -let add_constraints = add_constraints +let add_constraints = Environ.add_constraints let rec pop_named_decls idl env = match idl with @@ -471,6 +151,5 @@ let env_of_safe_env e = e let typing env c = let (j,cst) = safe_infer env c in + let _ = add_constraints cst env in j - -let typing_in_unsafe_env = typing diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index 23a970b49..5f6697b4e 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -9,15 +9,9 @@ (*i $Id$ i*) (*i*) -open Pp open Names open Term -open Univ -open Sign open Declarations -open Inductive -open Environ -open Typeops (*i*) (*s Safe environments. Since we are now able to type terms, we can define an @@ -27,50 +21,47 @@ open Typeops type safe_environment -val empty_environment : safe_environment +val env_of_safe_env : safe_environment -> Environ.env -val universes : safe_environment -> universes -val context : safe_environment -> context -val named_context : safe_environment -> named_context +val empty_environment : safe_environment +(* Adding and removing local declarations (Local or Variables) *) val push_named_assum : - identifier * constr -> safe_environment -> safe_environment + identifier * types -> safe_environment -> + Univ.constraints * safe_environment val push_named_def : - identifier * constr -> safe_environment -> safe_environment - -val check_and_push_named_assum : identifier * constr -> safe_environment -> - (constr option * types * constraints) * safe_environment -val check_and_push_named_def : - identifier * constr -> safe_environment -> - (constr option * types * constraints) * safe_environment + Univ.constraints * safe_environment +val pop_named_decls : identifier list -> safe_environment -> safe_environment -type local_names = (identifier * variable) list +(* Adding global axioms or definitions *) val add_parameter : - section_path -> constr -> local_names -> safe_environment -> safe_environment + section_path -> constr -> safe_environment -> safe_environment + +(*s Global and local constant declaration. *) + +type constant_entry = { + const_entry_body : constr; + const_entry_type : types option; + const_entry_opaque : bool } + val add_constant : - section_path -> constant_entry -> local_names -> - safe_environment -> safe_environment + section_path -> constant_entry -> safe_environment -> safe_environment val add_discharged_constant : - section_path -> Cooking.recipe -> local_names -> safe_environment -> safe_environment + section_path -> Cooking.recipe -> safe_environment -> safe_environment +(* Adding an inductive type *) val add_mind : - section_path -> mutual_inductive_entry -> local_names -> safe_environment - -> safe_environment -val add_constraints : constraints -> safe_environment -> safe_environment - -val pop_named_decls : identifier list -> safe_environment -> safe_environment - -val lookup_named : identifier -> safe_environment -> constr option * types -val lookup_constant : section_path -> safe_environment -> constant_body -val lookup_mind : section_path -> safe_environment -> mutual_inductive_body -val lookup_mind_specif : inductive -> safe_environment -> inductive_instance + section_path -> Indtypes.mutual_inductive_entry -> safe_environment -> + safe_environment -val export : safe_environment -> dir_path -> compiled_env -val import : compiled_env -> safe_environment -> safe_environment +(* Adding universe constraints *) +val add_constraints : Univ.constraints -> safe_environment -> safe_environment -val env_of_safe_env : safe_environment -> env +(* Loading and saving a module *) +val export : safe_environment -> dir_path -> Environ.compiled_env +val import : Environ.compiled_env -> safe_environment -> safe_environment (*s Typing judgments *) @@ -80,9 +71,12 @@ type judgment val j_val : judgment -> constr val j_type : judgment -> constr -val safe_infer : safe_environment -> constr -> judgment * constraints +(* Safe typing of a term returning a typing judgment and universe + constraints to be added to the environment for the judgment to + hold. It is guaranteed that the constraints are satisfiable + *) +val safe_infer : safe_environment -> constr -> judgment * Univ.constraints val typing : safe_environment -> constr -> judgment -val typing_in_unsafe_env : env -> constr -> judgment diff --git a/kernel/sign.ml b/kernel/sign.ml index 0899cf5e6..c9da4ab65 100644 --- a/kernel/sign.ml +++ b/kernel/sign.ml @@ -26,17 +26,9 @@ type named_context = named_declaration list let add_named_decl = add let add_named_assum = add_decl let add_named_def = add_def -let rec lookup_id_type id = function - | (id',c,t) :: _ when id=id' -> t - | _ :: sign -> lookup_id_type id sign - | [] -> raise Not_found -let rec lookup_id_value id = function - | (id',c,t) :: _ when id=id' -> c - | _ :: sign -> lookup_id_value id sign - | [] -> raise Not_found -let rec lookup_id id = function - | (id',c,t) :: _ when id=id' -> (c,t) - | _ :: sign -> lookup_id id sign +let rec lookup_named id = function + | (id',_,_ as decl) :: _ when id=id' -> decl + | _ :: sign -> lookup_named id sign | [] -> raise Not_found let empty_named_context = [] let pop_named_decl id = function @@ -59,18 +51,13 @@ let fold_named_context_reverse = List.fold_left let fold_named_context_both_sides = list_fold_right_and_left let it_named_context_quantifier f = List.fold_left (fun c d -> f d c) -(*s Signatures of ordered section variables *) +let it_mkNamedProd_or_LetIn = + List.fold_left (fun c d -> mkNamedProd_or_LetIn d c) +let it_mkNamedLambda_or_LetIn = + List.fold_left (fun c d -> mkNamedLambda_or_LetIn d c) -type section_declaration = variable * constr option * constr -type section_context = section_declaration list -let instance_from_section_context sign = - let rec inst_rec = function - | (sp,None,_) :: sign -> mkVar (basename sp) :: inst_rec sign - | _ :: sign -> inst_rec sign - | [] -> [] in - Array.of_list (inst_rec sign) -let instance_from_section_context x = - instance_from_section_context x +(*s Signatures of ordered section variables *) +type section_context = named_context (*s Signatures of ordered optionally named variables, intended to be accessed by de Bruijn indices *) @@ -79,21 +66,20 @@ type rel_declaration = name * constr option * types type rel_context = rel_declaration list type rev_rel_context = rel_declaration list +let fold_rel_context = List.fold_right +let fold_rel_context_reverse = List.fold_left + +let it_mkProd_or_LetIn = List.fold_left (fun c d -> mkProd_or_LetIn d c) +let it_mkLambda_or_LetIn = List.fold_left (fun c d -> mkLambda_or_LetIn d c) + let add_rel_decl = add let add_rel_assum = add_decl let add_rel_def = add_def -let lookup_rel_type n sign = +let lookup_rel n sign = let rec lookrec = function - | (1, (na,_,t) :: _) -> (na,t) - | (n, _ :: sign) -> lookrec (n-1,sign) - | (_, []) -> raise Not_found - in - lookrec (n,sign) -let lookup_rel_value n sign = - let rec lookrec = function - | (1, (_,c,_) :: _) -> c - | (n, _ :: sign ) -> lookrec (n-1,sign) - | (_, []) -> raise Not_found + | (1, decl :: _) -> decl + | (n, _ :: sign) -> lookrec (n-1,sign) + | (_, []) -> raise Not_found in lookrec (n,sign) let rec lookup_rel_id id sign = @@ -127,10 +113,6 @@ let ids_of_rel_context sign = (fun (na,_,_) l -> match na with Name id -> id::l | Anonymous -> l) sign [] let names_of_rel_context = List.map (fun (na,_,_) -> na) -let assums_of_rel_context sign = - List.fold_right - (fun (na,c,t) l -> match c with Some _ -> l | None -> (na,body_of_type t)::l) - sign [] let map_rel_context = map let push_named_to_rel_context hyps ctxt = let rec push = function @@ -157,7 +139,7 @@ let instantiate_sign sign args = | ([],_) | (_,[]) -> anomaly "Signature and its instance do not match" in - instrec (sign,args) + instrec (sign,Array.to_list args) (*************************) (* Names environments *) @@ -185,9 +167,9 @@ let empty_names_context = [] let decompose_prod_assum = let rec prodec_rec l c = match kind_of_term c with - | IsProd (x,t,c) -> prodec_rec (add_rel_assum (x,t) l) c - | IsLetIn (x,b,t,c) -> prodec_rec (add_rel_def (x,b,t) l) c - | IsCast (c,_) -> prodec_rec l c + | Prod (x,t,c) -> prodec_rec (add_rel_assum (x,t) l) c + | LetIn (x,b,t,c) -> prodec_rec (add_rel_def (x,b,t) l) c + | Cast (c,_) -> prodec_rec l c | _ -> l,c in prodec_rec empty_rel_context @@ -197,9 +179,9 @@ let decompose_prod_assum = let decompose_lam_assum = let rec lamdec_rec l c = match kind_of_term c with - | IsLambda (x,t,c) -> lamdec_rec (add_rel_assum (x,t) l) c - | IsLetIn (x,b,t,c) -> lamdec_rec (add_rel_def (x,b,t) l) c - | IsCast (c,_) -> lamdec_rec l c + | Lambda (x,t,c) -> lamdec_rec (add_rel_assum (x,t) l) c + | LetIn (x,b,t,c) -> lamdec_rec (add_rel_def (x,b,t) l) c + | Cast (c,_) -> lamdec_rec l c | _ -> l,c in lamdec_rec empty_rel_context @@ -212,10 +194,10 @@ let decompose_prod_n_assum n = let rec prodec_rec l n c = if n=0 then l,c else match kind_of_term c with - | IsProd (x,t,c) -> prodec_rec (add_rel_assum(x,t) l) (n-1) c - | IsLetIn (x,b,t,c) -> + | Prod (x,t,c) -> prodec_rec (add_rel_assum(x,t) l) (n-1) c + | LetIn (x,b,t,c) -> prodec_rec (add_rel_def (x,b,t) l) (n-1) c - | IsCast (c,_) -> prodec_rec l n c + | Cast (c,_) -> prodec_rec l n c | c -> error "decompose_prod_n_assum: not enough assumptions" in prodec_rec empty_rel_context n @@ -228,10 +210,10 @@ let decompose_lam_n_assum n = let rec lamdec_rec l n c = if n=0 then l,c else match kind_of_term c with - | IsLambda (x,t,c) -> lamdec_rec (add_rel_assum (x,t) l) (n-1) c - | IsLetIn (x,b,t,c) -> + | Lambda (x,t,c) -> lamdec_rec (add_rel_assum (x,t) l) (n-1) c + | LetIn (x,b,t,c) -> lamdec_rec (add_rel_def (x,b,t) l) (n-1) c - | IsCast (c,_) -> lamdec_rec l n c + | Cast (c,_) -> lamdec_rec l n c | c -> error "decompose_lam_n_assum: not enough abstractions" in lamdec_rec empty_rel_context n diff --git a/kernel/sign.mli b/kernel/sign.mli index dd5aba6c6..d834e263a 100644 --- a/kernel/sign.mli +++ b/kernel/sign.mli @@ -16,38 +16,25 @@ open Term (*s Signatures of ordered named declarations *) type named_context = named_declaration list +type section_context = named_context -val add_named_decl : - identifier * constr option * types -> named_context -> named_context -val add_named_assum : identifier * types -> named_context -> named_context -val add_named_def : - identifier * constr * types -> named_context -> named_context -val lookup_id : identifier -> named_context -> constr option * types -val lookup_id_type : identifier -> named_context -> types -val lookup_id_value : identifier -> named_context -> constr option -val pop_named_decl : identifier -> named_context -> named_context val empty_named_context : named_context -val ids_of_named_context : named_context -> identifier list -val map_named_context : (constr -> constr) -> named_context -> named_context -val mem_named_context : identifier -> named_context -> bool +val add_named_decl : named_declaration -> named_context -> named_context +val pop_named_decl : identifier -> named_context -> named_context + +val lookup_named : identifier -> named_context -> named_declaration + +(*s Recurrence on [named_context]: older declarations processed first *) val fold_named_context : (named_declaration -> 'a -> 'a) -> named_context -> 'a -> 'a +(* newer declarations first *) val fold_named_context_reverse : ('a -> named_declaration -> 'a) -> 'a -> named_context -> 'a -val fold_named_context_both_sides : - ('a -> named_declaration -> named_context -> 'a) -> named_context -> 'a -> 'a -val it_named_context_quantifier : - (named_declaration -> constr -> constr) -> constr -> named_context -> constr -val instantiate_sign : - named_context -> constr list -> (identifier * constr) list -val instance_from_named_context : named_context -> constr array - -(*s Signatures of ordered section variables *) - -type section_declaration = variable * constr option * constr -type section_context = section_declaration list -val instance_from_section_context : section_context -> constr array +(*s Section-related auxiliary functions *) +val instance_from_named_context : named_context -> constr array +val instantiate_sign : + named_context -> constr array -> (identifier * constr) list (*s Signatures of ordered optionally named variables, intended to be accessed by de Bruijn indices *) @@ -55,35 +42,28 @@ val instance_from_section_context : section_context -> constr array (* In [rel_context], more recent declaration is on top *) type rel_context = rel_declaration list -(* In [rev_rel_context], older declaration is on top *) -type rev_rel_context = rel_declaration list - -val add_rel_decl : (name * constr option * types) -> rel_context -> rel_context -val add_rel_assum : (name * types) -> rel_context -> rel_context -val add_rel_def : (name * constr * types) -> rel_context -> rel_context -val lookup_rel_type : int -> rel_context -> name * types -val lookup_rel_value : int -> rel_context -> constr option -val lookup_rel_id : identifier -> rel_context -> int * types val empty_rel_context : rel_context +val add_rel_decl : rel_declaration -> rel_context -> rel_context + +val lookup_rel : int -> rel_context -> rel_declaration val rel_context_length : rel_context -> int -val lift_rel_context : int -> rel_context -> rel_context -val lift_rev_rel_context : int -> rev_rel_context -> rev_rel_context -val concat_rel_context : newer:rel_context -> older:rel_context -> rel_context -val ids_of_rel_context : rel_context -> identifier list -val assums_of_rel_context : rel_context -> (name * constr) list -val map_rel_context : (constr -> constr) -> rel_context -> rel_context + val push_named_to_rel_context : named_context -> rel_context -> rel_context -val reverse_rel_context : rel_context -> rev_rel_context -(*s This is used to translate names into de Bruijn indices and - vice-versa without to care about typing information *) +(*s Recurrence on [rel_context]: older declarations processed first *) +val fold_rel_context : + (rel_declaration -> 'a -> 'a) -> rel_context -> 'a -> 'a +(* newer declarations first *) +val fold_rel_context_reverse : + ('a -> rel_declaration -> 'a) -> 'a -> rel_context -> 'a + +(*s Term constructors *) + +val it_mkNamedLambda_or_LetIn : constr -> named_context -> constr +val it_mkNamedProd_or_LetIn : constr -> named_context -> constr -type names_context -val add_name : name -> names_context -> names_context -val lookup_name_of_rel : int -> names_context -> name -val lookup_rel_of_name : identifier -> names_context -> int -val names_of_rel_context : rel_context -> names_context -val empty_names_context : names_context +val it_mkLambda_or_LetIn : constr -> rel_context -> constr +val it_mkProd_or_LetIn : constr -> rel_context -> constr (*s Term destructors *) diff --git a/kernel/term.ml b/kernel/term.ml index 96a4d0d38..652c4d3c3 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -24,9 +24,15 @@ type existential_key = int type pattern_source = DefaultPat of int | RegularPat type case_style = PrintLet | PrintIf | PrintCases type case_printing = - inductive * identifier array * int - * case_style option * pattern_source array -type case_info = int * case_printing + { cnames : identifier array; + ind_nargs : int; (* number of real args of the inductive type *) + style : case_style option; + source : pattern_source array } +type case_info = + { ci_ind : inductive; + ci_npar : int; + ci_pp_info : case_printing (* not interpreted by the kernel *) + } (* Sorts. *) @@ -39,12 +45,6 @@ type sorts = let mk_Set = Prop Pos let mk_Prop = Prop Null -let print_sort = function - | Prop Pos -> [< 'sTR "Set" >] - | Prop Null -> [< 'sTR "Prop" >] -(* | Type _ -> [< 'sTR "Type" >] *) - | Type u -> [< 'sTR "Type("; pr_uni u; 'sTR ")" >] - type sorts_family = InProp | InSet | InType let new_sort_in_family = function @@ -76,22 +76,22 @@ type fixpoint = (int array * int) * rec_declaration type cofixpoint = int * rec_declaration type kind_of_term = - | IsRel of int - | IsMeta of int - | IsVar of identifier - | IsSort of sorts - | IsCast of constr * constr - | IsProd of name * constr * constr - | IsLambda of name * constr * constr - | IsLetIn of name * constr * constr * constr - | IsApp of constr * constr array - | IsEvar of existential - | IsConst of constant - | IsMutInd of inductive - | IsMutConstruct of constructor - | IsMutCase of case_info * constr * constr * constr array - | IsFix of fixpoint - | IsCoFix of cofixpoint + | Rel of int + | Meta of int + | Var of identifier + | Sort of sorts + | Cast of constr * constr + | Prod of name * constr * constr + | Lambda of name * constr * constr + | LetIn of name * constr * constr * constr + | App of constr * constr array + | Evar of existential + | Const of constant + | Ind of inductive + | Construct of constructor + | Case of case_info * constr * constr * constr array + | Fix of fixpoint + | CoFix of cofixpoint val mkRel : int -> constr val mkMeta : int -> constr @@ -126,42 +126,38 @@ module Internal : InternalSig = struct *) -module Polymorph = -struct (* [constr array] is an instance matching definitional [named_context] in the same order (i.e. last argument first) *) -type 'constr existential = existential_key * 'constr array -type ('constr, 'types) rec_declaration = +type 'constr pexistential = existential_key * 'constr array +type ('constr, 'types) prec_declaration = name array * 'types array * 'constr array -type ('constr, 'types) fixpoint = - (int array * int) * ('constr, 'types) rec_declaration -type ('constr, 'types) cofixpoint = - int * ('constr, 'types) rec_declaration +type ('constr, 'types) pfixpoint = + (int array * int) * ('constr, 'types) prec_declaration +type ('constr, 'types) pcofixpoint = + int * ('constr, 'types) prec_declaration -(* [IsVar] is used for named variables and [IsRel] for variables as +(* [Var] is used for named variables and [Rel] for variables as de Bruijn indices. *) - -end -open Polymorph - type ('constr, 'types) kind_of_term = - | IsRel of int - | IsMeta of int - | IsVar of identifier - | IsSort of sorts - | IsCast of 'constr * 'constr - | IsProd of name * 'types * 'constr - | IsLambda of name * 'types * 'constr - | IsLetIn of name * 'constr * 'types * 'constr - | IsApp of 'constr * 'constr array - | IsEvar of 'constr existential - | IsConst of constant - | IsMutInd of inductive - | IsMutConstruct of constructor - | IsMutCase of case_info * 'constr * 'constr * 'constr array - | IsFix of ('constr, 'types) fixpoint - | IsCoFix of ('constr, 'types) cofixpoint - + | Rel of int + | Var of identifier + | Meta of int + | Evar of 'constr pexistential + | Sort of sorts + | Cast of 'constr * 'constr + | Prod of name * 'types * 'types + | Lambda of name * 'types * 'constr + | LetIn of name * 'constr * 'types * 'constr + | App of 'constr * 'constr array + | Const of constant + | Ind of inductive + | Construct of constructor + | Case of case_info * 'constr * 'constr * 'constr array + | Fix of ('constr, 'types) pfixpoint + | CoFix of ('constr, 'types) pcofixpoint + +(* constr is the fixpoint of the previous type. Requires option + -rectypes of the Caml compiler to be set *) type constr = (constr,constr) kind_of_term type existential = existential_key * constr array @@ -175,28 +171,28 @@ type cofixpoint = int * rec_declaration let comp_term t1 t2 = match t1, t2 with - | IsRel n1, IsRel n2 -> n1 = n2 - | IsMeta m1, IsMeta m2 -> m1 = m2 - | IsVar id1, IsVar id2 -> id1 == id2 - | IsSort s1, IsSort s2 -> s1 == s2 - | IsCast (c1,t1), IsCast (c2,t2) -> c1 == c2 & t1 == t2 - | IsProd (n1,t1,c1), IsProd (n2,t2,c2) -> n1 == n2 & t1 == t2 & c1 == c2 - | IsLambda (n1,t1,c1), IsLambda (n2,t2,c2) -> n1 == n2 & t1 == t2 & c1 == c2 - | IsLetIn (n1,b1,t1,c1), IsLetIn (n2,b2,t2,c2) -> + | Rel n1, Rel n2 -> n1 = n2 + | Meta m1, Meta m2 -> m1 = m2 + | Var id1, Var id2 -> id1 == id2 + | Sort s1, Sort s2 -> s1 == s2 + | Cast (c1,t1), Cast (c2,t2) -> c1 == c2 & t1 == t2 + | Prod (n1,t1,c1), Prod (n2,t2,c2) -> n1 == n2 & t1 == t2 & c1 == c2 + | Lambda (n1,t1,c1), Lambda (n2,t2,c2) -> n1 == n2 & t1 == t2 & c1 == c2 + | LetIn (n1,b1,t1,c1), LetIn (n2,b2,t2,c2) -> n1 == n2 & b1 == b2 & t1 == t2 & c1 == c2 - | IsApp (c1,l1), IsApp (c2,l2) -> c1 == c2 & array_for_all2 (==) l1 l2 - | IsEvar (e1,l1), IsEvar (e2,l2) -> e1 = e2 & array_for_all2 (==) l1 l2 - | IsConst c1, IsConst c2 -> c1 == c2 - | IsMutInd c1, IsMutInd c2 -> c1 == c2 - | IsMutConstruct c1, IsMutConstruct c2 -> c1 == c2 - | IsMutCase (ci1,p1,c1,bl1), IsMutCase (ci2,p2,c2,bl2) -> + | App (c1,l1), App (c2,l2) -> c1 == c2 & array_for_all2 (==) l1 l2 + | Evar (e1,l1), Evar (e2,l2) -> e1 = e2 & array_for_all2 (==) l1 l2 + | Const c1, Const c2 -> c1 == c2 + | Ind c1, Ind c2 -> c1 == c2 + | Construct c1, Construct c2 -> c1 == c2 + | Case (ci1,p1,c1,bl1), Case (ci2,p2,c2,bl2) -> ci1 == ci2 & p1 == p2 & c1 == c2 & array_for_all2 (==) bl1 bl2 - | IsFix (ln1,(lna1,tl1,bl1)), IsFix (ln2,(lna2,tl2,bl2)) -> + | Fix (ln1,(lna1,tl1,bl1)), Fix (ln2,(lna2,tl2,bl2)) -> ln1 = ln2 & array_for_all2 (==) lna1 lna2 & array_for_all2 (==) tl1 tl2 & array_for_all2 (==) bl1 bl2 - | IsCoFix(ln1,(lna1,tl1,bl1)), IsCoFix(ln2,(lna2,tl2,bl2)) -> + | CoFix(ln1,(lna1,tl1,bl1)), CoFix(ln2,(lna2,tl2,bl2)) -> ln1 = ln2 & array_for_all2 (==) lna1 lna2 & array_for_all2 (==) tl1 tl2 @@ -205,26 +201,26 @@ let comp_term t1 t2 = let hash_term (sh_rec,(sh_sort,sh_sp,sh_na,sh_id)) t = match t with - | IsRel _ | IsMeta _ -> t - | IsVar x -> IsVar (sh_id x) - | IsSort s -> IsSort (sh_sort s) - | IsCast (c,t) -> IsCast (sh_rec c, sh_rec t) - | IsProd (na,t,c) -> IsProd (sh_na na, sh_rec t, sh_rec c) - | IsLambda (na,t,c) -> IsLambda (sh_na na, sh_rec t, sh_rec c) - | IsLetIn (na,b,t,c) -> IsLetIn (sh_na na, sh_rec b, sh_rec t, sh_rec c) - | IsApp (c,l) -> IsApp (sh_rec c, Array.map sh_rec l) - | IsEvar (e,l) -> IsEvar (e, Array.map sh_rec l) - | IsConst c -> IsConst (sh_sp c) - | IsMutInd (sp,i) -> IsMutInd (sh_sp sp,i) - | IsMutConstruct ((sp,i),j) -> IsMutConstruct ((sh_sp sp,i),j) - | IsMutCase (ci,p,c,bl) -> (* TO DO: extract ind_sp *) - IsMutCase (ci, sh_rec p, sh_rec c, Array.map sh_rec bl) - | IsFix (ln,(lna,tl,bl)) -> - IsFix (ln,(Array.map sh_na lna, + | Rel _ | Meta _ -> t + | Var x -> Var (sh_id x) + | Sort s -> Sort (sh_sort s) + | Cast (c,t) -> Cast (sh_rec c, sh_rec t) + | Prod (na,t,c) -> Prod (sh_na na, sh_rec t, sh_rec c) + | Lambda (na,t,c) -> Lambda (sh_na na, sh_rec t, sh_rec c) + | LetIn (na,b,t,c) -> LetIn (sh_na na, sh_rec b, sh_rec t, sh_rec c) + | App (c,l) -> App (sh_rec c, Array.map sh_rec l) + | Evar (e,l) -> Evar (e, Array.map sh_rec l) + | Const c -> Const (sh_sp c) + | Ind (sp,i) -> Ind (sh_sp sp,i) + | Construct ((sp,i),j) -> Construct ((sh_sp sp,i),j) + | Case (ci,p,c,bl) -> (* TO DO: extract ind_sp *) + Case (ci, sh_rec p, sh_rec c, Array.map sh_rec bl) + | Fix (ln,(lna,tl,bl)) -> + Fix (ln,(Array.map sh_na lna, Array.map sh_rec tl, Array.map sh_rec bl)) - | IsCoFix(ln,(lna,tl,bl)) -> - IsCoFix (ln,(Array.map sh_na lna, + | CoFix(ln,(lna,tl,bl)) -> + CoFix (ln,(Array.map sh_na lna, Array.map sh_rec tl, Array.map sh_rec bl)) @@ -244,43 +240,36 @@ let hcons_term (hsorts,hsp,hname,hident) = Hashcons.recursive_hcons Hconstr.f (hsorts,hsp,hname,hident) (* Constructs a DeBrujin index with number n *) -let mkRel n = IsRel n - -let r = ref None +let rels = + [|Rel 1;Rel 2;Rel 3;Rel 4;Rel 5;Rel 6;Rel 7; Rel 8; + Rel 9;Rel 10;Rel 11;Rel 12;Rel 13;Rel 14;Rel 15; Rel 16|] -let mkRel n = - let rels = match !r with - | None -> let a = - [|mkRel 1;mkRel 2;mkRel 3;mkRel 4;mkRel 5;mkRel 6;mkRel 7; mkRel 8; - mkRel 9;mkRel 10;mkRel 11;mkRel 12;mkRel 13;mkRel 14;mkRel 15; mkRel 16|] - in r := Some a; a - | Some a -> a in - if 0<n & n<=16 then rels.(n-1) else mkRel n +let mkRel n = if 0<n & n<=16 then rels.(n-1) else Rel n (* Constructs an existential variable named "?n" *) -let mkMeta n = IsMeta n +let mkMeta n = Meta n (* Constructs a Variable named id *) -let mkVar id = IsVar id +let mkVar id = Var id (* Construct a type *) -let mkSort s = IsSort s +let mkSort s = Sort s (* 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) = match t1 with - | IsCast (t,_) -> IsCast (t,t2) - | _ -> IsCast (t1,t2) + | Cast (t,_) -> Cast (t,t2) + | _ -> Cast (t1,t2) (* Constructs the product (x:t1)t2 *) -let mkProd (x,t1,t2) = IsProd (x,t1,t2) +let mkProd (x,t1,t2) = Prod (x,t1,t2) (* Constructs the abstraction [x:t1]t2 *) -let mkLambda (x,t1,t2) = IsLambda (x,t1,t2) +let mkLambda (x,t1,t2) = Lambda (x,t1,t2) (* Constructs [x=c_1:t]c_2 *) -let mkLetIn (x,c1,t,c2) = IsLetIn (x,c1,t,c2) +let mkLetIn (x,c1,t,c2) = LetIn (x,c1,t,c2) (* If lt = [t1; ...; tn], constructs the application (t1 ... tn) *) (* We ensure applicative terms have at least one argument and the @@ -288,32 +277,32 @@ let mkLetIn (x,c1,t,c2) = IsLetIn (x,c1,t,c2) let mkApp (f, a) = if a=[||] then f else match f with - | IsApp (g, cl) -> IsApp (g, Array.append cl a) - | _ -> IsApp (f, a) + | App (g, cl) -> App (g, Array.append cl a) + | _ -> App (f, a) (* Constructs a constant *) (* The array of terms correspond to the variables introduced in the section *) -let mkConst c = IsConst c +let mkConst c = Const c (* Constructs an existential variable *) -let mkEvar e = IsEvar e +let mkEvar e = Evar e (* Constructs the ith (co)inductive type of the block named sp *) (* The array of terms correspond to the variables introduced in the section *) -let mkMutInd m = IsMutInd m +let mkInd m = Ind m (* Constructs the jth constructor of the ith (co)inductive type of the block named sp. The array of terms correspond to the variables introduced in the section *) -let mkMutConstruct c = IsMutConstruct c +let mkConstruct c = Construct c (* Constructs the term <p>Case c of c1 | c2 .. | cn end *) -let mkMutCase (ci, p, c, ac) = IsMutCase (ci, p, c, ac) +let mkCase (ci, p, c, ac) = Case (ci, p, c, ac) -let mkFix fix = IsFix fix +let mkFix fix = Fix fix -let mkCoFix cofix = IsCoFix cofix +let mkCoFix cofix = CoFix cofix let kind_of_term c = c @@ -341,7 +330,7 @@ open Internal END of expected re-export of Internal module *) -(* User view of [constr]. For [IsApp], it is ensured there is at +(* User view of [constr]. For [App], it is ensured there is at least one argument and the function is not itself an applicative term *) @@ -353,7 +342,7 @@ type hnftype = | HnfSort of sorts | HnfProd of name * constr * constr | HnfAtom of constr - | HnfMutInd of inductive * constr array + | HnfInd of inductive * constr array (**********************************************************************) (* Non primitive term destructors *) @@ -364,48 +353,48 @@ type hnftype = (* Destructs a DeBrujin index *) let destRel c = match kind_of_term c with - | IsRel n -> n + | Rel n -> n | _ -> invalid_arg "destRel" (* Destructs an existential variable *) let destMeta c = match kind_of_term c with - | IsMeta n -> n + | Meta n -> n | _ -> invalid_arg "destMeta" -let isMeta c = match kind_of_term c with IsMeta _ -> true | _ -> false +let isMeta c = match kind_of_term c with Meta _ -> true | _ -> false (* Destructs a variable *) let destVar c = match kind_of_term c with - | IsVar id -> id + | Var id -> id | _ -> invalid_arg "destVar" (* Destructs a type *) let isSort c = match kind_of_term c with - | IsSort s -> true + | Sort s -> true | _ -> false let destSort c = match kind_of_term c with - | IsSort s -> s + | Sort s -> s | _ -> invalid_arg "destSort" let rec isprop c = match kind_of_term c with - | IsSort (Prop _) -> true - | IsCast (c,_) -> isprop c + | Sort (Prop _) -> true + | Cast (c,_) -> isprop c | _ -> false let rec is_Prop c = match kind_of_term c with - | IsSort (Prop Null) -> true - | IsCast (c,_) -> is_Prop c + | Sort (Prop Null) -> true + | Cast (c,_) -> is_Prop c | _ -> false let rec is_Set c = match kind_of_term c with - | IsSort (Prop Pos) -> true - | IsCast (c,_) -> is_Set c + | Sort (Prop Pos) -> true + | Cast (c,_) -> is_Set c | _ -> false let rec is_Type c = match kind_of_term c with - | IsSort (Type _) -> true - | IsCast (c,_) -> is_Type c + | Sort (Type _) -> true + | Cast (c,_) -> is_Type c | _ -> false let isType = function @@ -422,79 +411,79 @@ let same_kind c1 c2 = (isprop c1 & isprop c2) or (is_Type c1 & is_Type c2) (* Destructs a casted term *) let destCast c = match kind_of_term c with - | IsCast (t1, t2) -> (t1,t2) + | Cast (t1, t2) -> (t1,t2) | _ -> invalid_arg "destCast" -let isCast c = match kind_of_term c with IsCast (_,_) -> true | _ -> false +let isCast c = match kind_of_term c with Cast (_,_) -> true | _ -> false (* Tests if a de Bruijn index *) -let isRel c = match kind_of_term c with IsRel _ -> true | _ -> false +let isRel c = match kind_of_term c with Rel _ -> true | _ -> false (* Tests if a variable *) -let isVar c = match kind_of_term c with IsVar _ -> true | _ -> false +let isVar c = match kind_of_term c with Var _ -> true | _ -> false (* Destructs the product (x:t1)t2 *) let destProd c = match kind_of_term c with - | IsProd (x,t1,t2) -> (x,t1,t2) + | Prod (x,t1,t2) -> (x,t1,t2) | _ -> invalid_arg "destProd" (* Destructs the abstraction [x:t1]t2 *) let destLambda c = match kind_of_term c with - | IsLambda (x,t1,t2) -> (x,t1,t2) + | Lambda (x,t1,t2) -> (x,t1,t2) | _ -> invalid_arg "destLambda" (* Destructs the let [x:=b:t1]t2 *) let destLetIn c = match kind_of_term c with - | IsLetIn (x,b,t1,t2) -> (x,b,t1,t2) + | LetIn (x,b,t1,t2) -> (x,b,t1,t2) | _ -> invalid_arg "destProd" (* Destructs an application *) let destApplication c = match kind_of_term c with - | IsApp (f,a) -> (f, a) + | App (f,a) -> (f, a) | _ -> invalid_arg "destApplication" -let isApp c = match kind_of_term c with IsApp _ -> true | _ -> false +let isApp c = match kind_of_term c with App _ -> true | _ -> false (* Destructs a constant *) let destConst c = match kind_of_term c with - | IsConst sp -> sp + | Const sp -> sp | _ -> invalid_arg "destConst" -let isConst c = match kind_of_term c with IsConst _ -> true | _ -> false +let isConst c = match kind_of_term c with Const _ -> true | _ -> false (* Destructs an existential variable *) let destEvar c = match kind_of_term c with - | IsEvar (sp, a as r) -> r + | Evar (sp, a as r) -> r | _ -> invalid_arg "destEvar" let num_of_evar c = match kind_of_term c with - | IsEvar (n, _) -> n + | Evar (n, _) -> n | _ -> anomaly "num_of_evar called with bad args" (* Destructs a (co)inductive type named sp *) -let destMutInd c = match kind_of_term c with - | IsMutInd (sp, a as r) -> r - | _ -> invalid_arg "destMutInd" +let destInd c = match kind_of_term c with + | Ind (sp, a as r) -> r + | _ -> invalid_arg "destInd" (* Destructs a constructor *) -let destMutConstruct c = match kind_of_term c with - | IsMutConstruct (sp, a as r) -> r +let destConstruct c = match kind_of_term c with + | Construct (sp, a as r) -> r | _ -> invalid_arg "dest" -let isMutConstruct c = match kind_of_term c with - IsMutConstruct _ -> true | _ -> false +let isConstruct c = match kind_of_term c with + Construct _ -> true | _ -> false (* Destructs a term <p>Case c of lc1 | lc2 .. | lcn end *) let destCase c = match kind_of_term c with - | IsMutCase (ci,p,c,v) -> (ci,p,c,v) + | Case (ci,p,c,v) -> (ci,p,c,v) | _ -> anomaly "destCase" let destFix c = match kind_of_term c with - | IsFix fix -> fix + | Fix fix -> fix | _ -> invalid_arg "destFix" let destCoFix c = match kind_of_term c with - | IsCoFix cofix -> cofix + | CoFix cofix -> cofix | _ -> invalid_arg "destCoFix" (******************************************************************) @@ -503,31 +492,31 @@ let destCoFix c = match kind_of_term c with (* flattens application lists *) let rec collapse_appl c = match kind_of_term c with - | IsApp (f,cl) -> + | App (f,cl) -> let rec collapse_rec f cl2 = match kind_of_term f with - | IsApp (g,cl1) -> collapse_rec g (Array.append cl1 cl2) - | IsCast (c,_) when isApp c -> collapse_rec c cl2 + | App (g,cl1) -> collapse_rec g (Array.append cl1 cl2) + | Cast (c,_) when isApp c -> collapse_rec c cl2 | _ -> if cl2 = [||] then f else mkApp (f,cl2) in collapse_rec f cl | _ -> c -let rec decomp_app c = +let rec decompose_app c = match kind_of_term (collapse_appl c) with - | IsApp (f,cl) -> (f, Array.to_list cl) - | IsCast (c,t) -> decomp_app c + | App (f,cl) -> (f, Array.to_list cl) + | Cast (c,t) -> decompose_app c | _ -> (c,[]) (* strips head casts and flattens head applications *) let rec strip_head_cast c = match kind_of_term c with - | IsApp (f,cl) -> + | App (f,cl) -> let rec collapse_rec f cl2 = match kind_of_term f with - | IsApp (g,cl1) -> collapse_rec g (Array.append cl1 cl2) - | IsCast (c,_) -> collapse_rec c cl2 + | App (g,cl1) -> collapse_rec g (Array.append cl1 cl2) + | Cast (c,_) -> collapse_rec c cl2 | _ -> if cl2 = [||] then f else mkApp (f,cl2) in collapse_rec f cl - | IsCast (c,t) -> strip_head_cast c + | Cast (c,t) -> strip_head_cast c | _ -> c (****************************************************************************) @@ -539,19 +528,19 @@ let rec strip_head_cast c = match kind_of_term c with the usual representation of the constructions; it is not recursive *) let fold_constr f acc c = match kind_of_term c with - | (IsRel _ | IsMeta _ | IsVar _ | IsSort _ | IsConst _ | IsMutInd _ - | IsMutConstruct _) -> acc - | IsCast (c,t) -> f (f acc c) t - | IsProd (_,t,c) -> f (f acc t) c - | IsLambda (_,t,c) -> f (f acc t) c - | IsLetIn (_,b,t,c) -> f (f (f acc b) t) c - | IsApp (c,l) -> Array.fold_left f (f acc c) l - | IsEvar (_,l) -> Array.fold_left f acc l - | IsMutCase (_,p,c,bl) -> Array.fold_left f (f (f acc p) c) bl - | IsFix (_,(lna,tl,bl)) -> + | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ + | Construct _) -> acc + | Cast (c,t) -> f (f acc c) t + | Prod (_,t,c) -> f (f acc t) c + | Lambda (_,t,c) -> f (f acc t) c + | LetIn (_,b,t,c) -> f (f (f acc b) t) c + | App (c,l) -> Array.fold_left f (f acc c) l + | Evar (_,l) -> Array.fold_left f acc l + | Case (_,p,c,bl) -> Array.fold_left f (f (f acc p) c) bl + | Fix (_,(lna,tl,bl)) -> let fd = array_map3 (fun na t b -> (na,t,b)) lna tl bl in Array.fold_left (fun acc (na,t,b) -> f (f acc t) b) acc fd - | IsCoFix (_,(lna,tl,bl)) -> + | CoFix (_,(lna,tl,bl)) -> let fd = array_map3 (fun na t b -> (na,t,b)) lna tl bl in Array.fold_left (fun acc (na,t,b) -> f (f acc t) b) acc fd @@ -563,20 +552,20 @@ let fold_constr f acc c = match kind_of_term c with each binder traversal; it is not recursive *) let fold_constr_with_binders g f n acc c = match kind_of_term c with - | (IsRel _ | IsMeta _ | IsVar _ | IsSort _ | IsConst _ | IsMutInd _ - | IsMutConstruct _) -> acc - | IsCast (c,t) -> f n (f n acc c) t - | IsProd (_,t,c) -> f (g n) (f n acc t) c - | IsLambda (_,t,c) -> f (g n) (f n acc t) c - | IsLetIn (_,b,t,c) -> f (g n) (f n (f n acc b) t) c - | IsApp (c,l) -> Array.fold_left (f n) (f n acc c) l - | IsEvar (_,l) -> Array.fold_left (f n) acc l - | IsMutCase (_,p,c,bl) -> Array.fold_left (f n) (f n (f n acc p) c) bl - | IsFix (_,(lna,tl,bl)) -> + | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ + | Construct _) -> acc + | Cast (c,t) -> f n (f n acc c) t + | Prod (_,t,c) -> f (g n) (f n acc t) c + | Lambda (_,t,c) -> f (g n) (f n acc t) c + | LetIn (_,b,t,c) -> f (g n) (f n (f n acc b) t) c + | App (c,l) -> Array.fold_left (f n) (f n acc c) l + | Evar (_,l) -> Array.fold_left (f n) acc l + | Case (_,p,c,bl) -> Array.fold_left (f n) (f n (f n acc p) c) bl + | Fix (_,(lna,tl,bl)) -> let n' = iterate g (Array.length tl) n in let fd = array_map2 (fun t b -> (t,b)) tl bl in Array.fold_left (fun acc (t,b) -> f n (f n' acc t) b) acc fd - | IsCoFix (_,(lna,tl,bl)) -> + | CoFix (_,(lna,tl,bl)) -> let n' = iterate g (Array.length tl) n in let fd = array_map2 (fun t b -> (t,b)) tl bl in Array.fold_left (fun acc (t,b) -> f n (f n' acc t) b) acc fd @@ -586,17 +575,17 @@ let fold_constr_with_binders g f n acc c = match kind_of_term c with not specified *) let iter_constr f c = match kind_of_term c with - | (IsRel _ | IsMeta _ | IsVar _ | IsSort _ | IsConst _ | IsMutInd _ - | IsMutConstruct _) -> () - | IsCast (c,t) -> f c; f t - | IsProd (_,t,c) -> f t; f c - | IsLambda (_,t,c) -> f t; f c - | IsLetIn (_,b,t,c) -> f b; f t; f c - | IsApp (c,l) -> f c; Array.iter f l - | IsEvar (_,l) -> Array.iter f l - | IsMutCase (_,p,c,bl) -> f p; f c; Array.iter f bl - | IsFix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl - | IsCoFix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl + | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ + | Construct _) -> () + | Cast (c,t) -> f c; f t + | Prod (_,t,c) -> f t; f c + | Lambda (_,t,c) -> f t; f c + | LetIn (_,b,t,c) -> f b; f t; f c + | App (c,l) -> f c; Array.iter f l + | Evar (_,l) -> Array.iter f l + | Case (_,p,c,bl) -> f p; f c; Array.iter f bl + | Fix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl + | CoFix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl (* [iter_constr_with_binders g f n c] iters [f n] on the immediate subterms of [c]; it carries an extra data [n] (typically a lift @@ -605,19 +594,19 @@ let iter_constr f c = match kind_of_term c with subterms are processed is not specified *) let iter_constr_with_binders g f n c = match kind_of_term c with - | (IsRel _ | IsMeta _ | IsVar _ | IsSort _ | IsConst _ | IsMutInd _ - | IsMutConstruct _) -> () - | IsCast (c,t) -> f n c; f n t - | IsProd (_,t,c) -> f n t; f (g n) c - | IsLambda (_,t,c) -> f n t; f (g n) c - | IsLetIn (_,b,t,c) -> f n b; f n t; f (g n) c - | IsApp (c,l) -> f n c; Array.iter (f n) l - | IsEvar (_,l) -> Array.iter (f n) l - | IsMutCase (_,p,c,bl) -> f n p; f n c; Array.iter (f n) bl - | IsFix (_,(_,tl,bl)) -> + | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ + | Construct _) -> () + | Cast (c,t) -> f n c; f n t + | Prod (_,t,c) -> f n t; f (g n) c + | Lambda (_,t,c) -> f n t; f (g n) c + | LetIn (_,b,t,c) -> f n b; f n t; f (g n) c + | App (c,l) -> f n c; Array.iter (f n) l + | Evar (_,l) -> Array.iter (f n) l + | Case (_,p,c,bl) -> f n p; f n c; Array.iter (f n) bl + | Fix (_,(_,tl,bl)) -> Array.iter (f n) tl; Array.iter (f (iterate g (Array.length tl) n)) bl - | IsCoFix (_,(_,tl,bl)) -> + | CoFix (_,(_,tl,bl)) -> Array.iter (f n) tl; Array.iter (f (iterate g (Array.length tl) n)) bl @@ -626,18 +615,18 @@ let iter_constr_with_binders g f n c = match kind_of_term c with not specified *) let map_constr f c = match kind_of_term c with - | (IsRel _ | IsMeta _ | IsVar _ | IsSort _ | IsConst _ | IsMutInd _ - | IsMutConstruct _) -> c - | IsCast (c,t) -> mkCast (f c, f t) - | IsProd (na,t,c) -> mkProd (na, f t, f c) - | IsLambda (na,t,c) -> mkLambda (na, f t, f c) - | IsLetIn (na,b,t,c) -> mkLetIn (na, f b, f t, f c) - | IsApp (c,l) -> mkApp (f c, Array.map f l) - | IsEvar (e,l) -> mkEvar (e, Array.map f l) - | IsMutCase (ci,p,c,bl) -> mkMutCase (ci, f p, f c, Array.map f bl) - | IsFix (ln,(lna,tl,bl)) -> + | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ + | Construct _) -> c + | Cast (c,t) -> mkCast (f c, f t) + | Prod (na,t,c) -> mkProd (na, f t, f c) + | Lambda (na,t,c) -> mkLambda (na, f t, f c) + | LetIn (na,b,t,c) -> mkLetIn (na, f b, f t, f c) + | App (c,l) -> mkApp (f c, Array.map f l) + | Evar (e,l) -> mkEvar (e, Array.map f l) + | Case (ci,p,c,bl) -> mkCase (ci, f p, f c, Array.map f bl) + | Fix (ln,(lna,tl,bl)) -> mkFix (ln,(lna,Array.map f tl,Array.map f bl)) - | IsCoFix(ln,(lna,tl,bl)) -> + | CoFix(ln,(lna,tl,bl)) -> mkCoFix (ln,(lna,Array.map f tl,Array.map f bl)) (* [map_constr_with_binders g f n c] maps [f n] on the immediate @@ -647,118 +636,20 @@ let map_constr f c = match kind_of_term c with subterms are processed is not specified *) let map_constr_with_binders g f l c = match kind_of_term c with - | (IsRel _ | IsMeta _ | IsVar _ | IsSort _ | IsConst _ | IsMutInd _ - | IsMutConstruct _) -> c - | IsCast (c,t) -> mkCast (f l c, f l t) - | IsProd (na,t,c) -> mkProd (na, f l t, f (g l) c) - | IsLambda (na,t,c) -> mkLambda (na, f l t, f (g l) c) - | IsLetIn (na,b,t,c) -> mkLetIn (na, f l b, f l t, f (g l) c) - | IsApp (c,al) -> mkApp (f l c, Array.map (f l) al) - | IsEvar (e,al) -> mkEvar (e, Array.map (f l) al) - | IsMutCase (ci,p,c,bl) -> mkMutCase (ci, f l p, f l c, Array.map (f l) bl) - | IsFix (ln,(lna,tl,bl)) -> - let l' = iterate g (Array.length tl) l in - mkFix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl)) - | IsCoFix(ln,(lna,tl,bl)) -> + | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ + | Construct _) -> c + | Cast (c,t) -> mkCast (f l c, f l t) + | Prod (na,t,c) -> mkProd (na, f l t, f (g l) c) + | Lambda (na,t,c) -> mkLambda (na, f l t, f (g l) c) + | LetIn (na,b,t,c) -> mkLetIn (na, f l b, f l t, f (g l) c) + | App (c,al) -> mkApp (f l c, Array.map (f l) al) + | Evar (e,al) -> mkEvar (e, Array.map (f l) al) + | Case (ci,p,c,bl) -> mkCase (ci, f l p, f l c, Array.map (f l) bl) + | Fix (ln,(lna,tl,bl)) -> let l' = iterate g (Array.length tl) l in - mkCoFix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl)) - -(* [map_constr_with_named_binders g f l c] maps [f l] on the immediate - subterms of [c]; it carries an extra data [l] (typically a name - list) which is processed by [g na] (which typically cons [na] to - [l]) at each binder traversal (with name [na]); it is not recursive - and the order with which subterms are processed is not specified *) - -let map_constr_with_named_binders g f l c = match kind_of_term c with - | (IsRel _ | IsMeta _ | IsVar _ | IsSort _ | IsConst _ | IsMutInd _ - | IsMutConstruct _) -> c - | IsCast (c,t) -> mkCast (f l c, f l t) - | IsProd (na,t,c) -> mkProd (na, f l t, f (g na l) c) - | IsLambda (na,t,c) -> mkLambda (na, f l t, f (g na l) c) - | IsLetIn (na,b,t,c) -> mkLetIn (na, f l b, f l t, f (g na l) c) - | IsApp (c,al) -> mkApp (f l c, Array.map (f l) al) - | IsEvar (e,al) -> mkEvar (e, Array.map (f l) al) - | IsMutCase (ci,p,c,bl) -> mkMutCase (ci, f l p, f l c, Array.map (f l) bl) - | IsFix (ln,(lna,tl,bl)) -> - let l' = Array.fold_left (fun l na -> g na l) l lna in mkFix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl)) - | IsCoFix(ln,(lna,tl,bl)) -> - let l' = Array.fold_left (fun l na -> g na l) l lna in - mkCoFix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl)) - -(* [map_constr_with_binders_left_to_right g f n c] maps [f n] on the - immediate subterms of [c]; it carries an extra data [n] (typically - a lift index) which is processed by [g] (which typically add 1 to - [n]) at each binder traversal; the subterms are processed from left - to right according to the usual representation of the constructions - (this may matter if [f] does a side-effect); it is not recursive; - in fact, the usual representation of the constructions is at the - time being almost those of the ML representation (except for - (co-)fixpoint) *) - -let array_map_left f a = (* Ocaml does not guarantee Array.map is LR *) - let l = Array.length a in (* (even if so), then we rewrite it *) - if l = 0 then [||] else begin - let r = Array.create l (f a.(0)) in - for i = 1 to l - 1 do - r.(i) <- f a.(i) - done; - r - end - -let array_map_left_pair f a g b = - let l = Array.length a in - if l = 0 then [||],[||] else begin - let r = Array.create l (f a.(0)) in - let s = Array.create l (g b.(0)) in - for i = 1 to l - 1 do - r.(i) <- f a.(i); - s.(i) <- g b.(i) - done; - r, s - end - -let map_constr_with_binders_left_to_right g f l c = match kind_of_term c with - | (IsRel _ | IsMeta _ | IsVar _ | IsSort _ | IsConst _ | IsMutInd _ - | IsMutConstruct _) -> c - | IsCast (c,t) -> let c' = f l c in mkCast (c', f l t) - | IsProd (na,t,c) -> let t' = f l t in mkProd (na, t', f (g l) c) - | IsLambda (na,t,c) -> let t' = f l t in mkLambda (na, t', f (g l) c) - | IsLetIn (na,b,t,c) -> - let b' = f l b in let t' = f l t in mkLetIn (na, b', t', f (g l) c) - | IsApp (c,al) -> - let c' = f l c in mkApp (c', array_map_left (f l) al) - | IsEvar (e,al) -> mkEvar (e, array_map_left (f l) al) - | IsMutCase (ci,p,c,bl) -> - let p' = f l p in let c' = f l c in - mkMutCase (ci, p', c', array_map_left (f l) bl) - | IsFix (ln,(lna,tl,bl)) -> + | CoFix(ln,(lna,tl,bl)) -> let l' = iterate g (Array.length tl) l in - let (tl',bl') = array_map_left_pair (f l) tl (f l') bl in - mkFix (ln,(lna,tl',bl')) - | IsCoFix(ln,(lna,tl,bl)) -> - let l' = iterate g (Array.length tl) l in - let (tl',bl') = array_map_left_pair (f l) tl (f l') bl in - mkCoFix (ln,(lna,tl',bl')) - -(* strong *) -let map_constr_with_full_binders g f l c = match kind_of_term c with - | (IsRel _ | IsMeta _ | IsVar _ | IsSort _ | IsConst _ | IsMutInd _ - | IsMutConstruct _) -> c - | IsCast (c,t) -> mkCast (f l c, f l t) - | IsProd (na,t,c) -> mkProd (na, f l t, f (g (na,None,t) l) c) - | IsLambda (na,t,c) -> mkLambda (na, f l t, f (g (na,None,t) l) c) - | IsLetIn (na,b,t,c) -> mkLetIn (na, f l b, f l t, f (g (na,Some b,t) l) c) - | IsApp (c,al) -> mkApp (f l c, Array.map (f l) al) - | IsEvar (e,al) -> mkEvar (e, Array.map (f l) al) - | IsMutCase (ci,p,c,bl) -> mkMutCase (ci, f l p, f l c, Array.map (f l) bl) - | IsFix (ln,(lna,tl,bl)) -> - let l' = - array_fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in - mkFix (ln,(lna,Array.map (f l) tl, Array.map (f l') bl)) - | IsCoFix(ln,(lna,tl,bl)) -> - let l' = - array_fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in mkCoFix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl)) (* [compare_constr f c1 c2] compare [c1] and [c2] using [f] to compare @@ -768,33 +659,33 @@ let map_constr_with_full_binders g f l c = match kind_of_term c with let compare_constr f t1 t2 = match kind_of_term t1, kind_of_term t2 with - | IsRel n1, IsRel n2 -> n1 = n2 - | IsMeta m1, IsMeta m2 -> m1 = m2 - | IsVar id1, IsVar id2 -> id1 = id2 - | IsSort s1, IsSort s2 -> s1 = s2 - | IsCast (c1,_), _ -> f c1 t2 - | _, IsCast (c2,_) -> f t1 c2 - | IsProd (_,t1,c1), IsProd (_,t2,c2) -> f t1 t2 & f c1 c2 - | IsLambda (_,t1,c1), IsLambda (_,t2,c2) -> f t1 t2 & f c1 c2 - | IsLetIn (_,b1,t1,c1), IsLetIn (_,b2,t2,c2) -> f b1 b2 & f t1 t2 & f c1 c2 - | IsApp (c1,l1), IsApp (c2,l2) -> + | Rel n1, Rel n2 -> n1 = n2 + | Meta m1, Meta m2 -> m1 = m2 + | Var id1, Var id2 -> id1 = id2 + | Sort s1, Sort s2 -> s1 = s2 + | Cast (c1,_), _ -> f c1 t2 + | _, Cast (c2,_) -> f t1 c2 + | Prod (_,t1,c1), Prod (_,t2,c2) -> f t1 t2 & f c1 c2 + | Lambda (_,t1,c1), Lambda (_,t2,c2) -> f t1 t2 & f c1 c2 + | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> f b1 b2 & f t1 t2 & f c1 c2 + | App (c1,l1), App (c2,l2) -> if Array.length l1 = Array.length l2 then f c1 c2 & array_for_all2 f l1 l2 else - let (h1,l1) = decomp_app t1 in - let (h2,l2) = decomp_app t2 in + let (h1,l1) = decompose_app t1 in + let (h2,l2) = decompose_app t2 in if List.length l1 = List.length l2 then f h1 h2 & List.for_all2 f l1 l2 else false - | IsEvar (e1,l1), IsEvar (e2,l2) -> e1 = e2 & array_for_all2 f l1 l2 - | IsConst c1, IsConst c2 -> c1 = c2 - | IsMutInd c1, IsMutInd c2 -> c1 = c2 - | IsMutConstruct c1, IsMutConstruct c2 -> c1 = c2 - | IsMutCase (_,p1,c1,bl1), IsMutCase (_,p2,c2,bl2) -> + | Evar (e1,l1), Evar (e2,l2) -> e1 = e2 & array_for_all2 f l1 l2 + | Const c1, Const c2 -> c1 = c2 + | Ind c1, Ind c2 -> c1 = c2 + | Construct c1, Construct c2 -> c1 = c2 + | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> f p1 p2 & f c1 c2 & array_for_all2 f bl1 bl2 - | IsFix (ln1,(_,tl1,bl1)), IsFix (ln2,(_,tl2,bl2)) -> + | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) -> ln1 = ln2 & array_for_all2 f tl1 tl2 & array_for_all2 f bl1 bl2 - | IsCoFix(ln1,(_,tl1,bl1)), IsCoFix(ln2,(_,tl2,bl2)) -> + | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) -> ln1 = ln2 & array_for_all2 f tl1 tl2 & array_for_all2 f bl1 bl2 | _ -> false @@ -811,7 +702,9 @@ let body_of_type ty = ty type named_declaration = identifier * constr option * types type rel_declaration = name * constr option * types - +let map_named_declaration f = function + (id, Some v, ty) -> (id, Some (f v), f ty) + | (id, None, ty) -> (id, None, f ty) (****************************************************************************) (* Functions for dealing with constr terms *) @@ -829,7 +722,7 @@ exception Occur let closedn = let rec closed_rec n c = match kind_of_term c with - | IsRel m -> if m>n then raise FreeVar + | Rel m -> if m>n then raise FreeVar | _ -> iter_constr_with_binders succ closed_rec n c in closed_rec @@ -839,20 +732,11 @@ let closedn = 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 c = match kind_of_term c with - | IsRel n -> if n >= depth then Intset.add (n-depth+1) acc else acc - | _ -> fold_constr_with_binders succ frec depth acc c - 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 c = match kind_of_term c with - | IsRel m -> if m = n then raise Occur + | Rel m -> if m = n then raise Occur | _ -> iter_constr_with_binders succ occur_rec n c in try occur_rec n term; true with Occur -> false @@ -862,7 +746,7 @@ let noccurn n term = let noccur_between n m term = let rec occur_rec n c = match kind_of_term c with - | IsRel(p) -> if n<=p && p<n+m then raise Occur + | Rel(p) -> if n<=p && p<n+m then raise Occur | _ -> iter_constr_with_binders succ occur_rec n c in try occur_rec n term; true with Occur -> false @@ -876,13 +760,13 @@ let noccur_between n m term = let noccur_with_meta n m term = let rec occur_rec n c = match kind_of_term c with - | IsRel p -> if n<=p & p<n+m then raise Occur - | IsApp(f,cl) -> + | Rel p -> if n<=p & p<n+m then raise Occur + | App(f,cl) -> (match kind_of_term f with - | IsCast (c,_) when isMeta c -> () - | IsMeta _ -> () + | Cast (c,_) when isMeta c -> () + | Meta _ -> () | _ -> iter_constr_with_binders succ occur_rec n c) - | IsEvar (_, _) -> () + | Evar (_, _) -> () | _ -> iter_constr_with_binders succ occur_rec n c in try (occur_rec n term; true) with Occur -> false @@ -894,7 +778,7 @@ let noccur_with_meta n m term = (* The generic lifting function *) let rec exliftn el c = match kind_of_term c with - | IsRel i -> mkRel(reloc_rel i el) + | Rel i -> mkRel(reloc_rel i el) | _ -> map_constr_with_binders el_lift exliftn el c (* Lifting the binding depth across k bindings *) @@ -934,7 +818,7 @@ let make_substituend c = { sinfo=Unknown; sit=c } let substn_many lamv n = let lv = Array.length lamv in let rec substrec depth c = match kind_of_term c with - | IsRel k -> + | Rel k -> if k<=depth then c else if k-depth <= lv then @@ -976,7 +860,7 @@ let replace_vars 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 c = match kind_of_term c with - | IsVar x -> + | Var x -> (try lift_substituend n (List.assoc x var_alist) with Not_found -> c) | _ -> map_constr_with_binders succ substrec n c @@ -1099,16 +983,16 @@ let mkEvar = mkEvar (* Constructs the ith (co)inductive type of the block named sp *) (* The array of terms correspond to the variables introduced in the section *) -let mkMutInd = mkMutInd +let mkInd = mkInd (* Constructs the jth constructor of the ith (co)inductive type of the block named sp. The array of terms correspond to the variables introduced in the section *) -let mkMutConstruct = mkMutConstruct +let mkConstruct = mkConstruct (* Constructs the term <p>Case c of c1 | c2 .. | cn end *) -let mkMutCase = mkMutCase -let mkMutCaseL (ci, p, c, ac) = mkMutCase (ci, p, c, Array.of_list ac) +let mkCase = mkCase +let mkCaseL (ci, p, c, ac) = mkCase (ci, p, c, Array.of_list ac) (* If recindxs = [|i1,...in|] funnames = [|f1,...fn|] @@ -1151,17 +1035,17 @@ let implicit_sort = Type implicit_univ let mkImplicit = mkSort implicit_sort let rec strip_outer_cast c = match kind_of_term c with - | IsCast (c,_) -> strip_outer_cast c + | Cast (c,_) -> strip_outer_cast c | _ -> c -(* Fonction spéciale qui laisse les cast clés sous les Fix ou les MutCase *) +(* Fonction spéciale qui laisse les cast clés sous les Fix ou les Case *) let under_outer_cast f c = match kind_of_term c with - | IsCast (b,t) -> mkCast (f b,f t) + | Cast (b,t) -> mkCast (f b,f t) | _ -> f c let rec under_casts f c = match kind_of_term c with - | IsCast (c,t) -> mkCast (under_casts f c, t) + | Cast (c,t) -> mkCast (under_casts f c, t) | _ -> f c (***************************) @@ -1172,13 +1056,6 @@ 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)) - -(* 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)) - (* prodn n [xn:Tn;..;x1:T1;Gamma] b = (x1:T1)..(xn:Tn)b *) let prodn n env b = let rec prodrec = function @@ -1212,8 +1089,8 @@ let rec to_lambda n prod = prod else match kind_of_term prod with - | IsProd (na,ty,bd) -> mkLambda (na,ty,to_lambda (n-1) bd) - | IsCast (c,_) -> to_lambda n c + | Prod (na,ty,bd) -> mkLambda (na,ty,to_lambda (n-1) bd) + | Cast (c,_) -> to_lambda n c | _ -> errorlabstrm "to_lambda" [<>] let rec to_prod n lam = @@ -1221,8 +1098,8 @@ let rec to_prod n lam = lam else match kind_of_term lam with - | IsLambda (na,ty,bd) -> mkProd (na,ty,to_prod (n-1) bd) - | IsCast (c,_) -> to_prod n c + | Lambda (na,ty,bd) -> mkProd (na,ty,to_prod (n-1) bd) + | Cast (c,_) -> to_prod n c | _ -> errorlabstrm "to_prod" [<>] (* pseudo-reduction rule: @@ -1231,7 +1108,7 @@ let rec to_prod n lam = let prod_app t n = match kind_of_term (strip_outer_cast t) with - | IsProd (_,_,b) -> subst1 n b + | Prod (_,_,b) -> subst1 n b | _ -> errorlabstrm "prod_app" [< 'sTR"Needed a product, but didn't find one" ; 'fNL >] @@ -1243,27 +1120,6 @@ let prod_appvect t nL = Array.fold_left prod_app t nL (* prod_applist T [ a1 ; ... ; an ] -> (T a1 ... an) *) let prod_applist t nL = List.fold_left prod_app t nL - -(* [Rel (n+m);...;Rel(n+1)] *) -let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i)) - -let rel_list n m = - let rec reln l p = - if p>m then l else reln (mkRel(n+p)::l) (p+1) - in - reln [] 1 - -(* Same as [rel_list] but takes a context as argument and skips let-ins *) -let extended_rel_list n hyps = - let rec reln l p = function - | (_,None,_) :: hyps -> reln (mkRel (n+p) :: l) (p+1) hyps - | (_,Some _,_) :: hyps -> reln l (p+1) hyps - | [] -> l - in - reln [] 1 hyps - -let extended_rel_vect n hyps = Array.of_list (extended_rel_list n hyps) - (*********************************) (* Other term destructors *) (*********************************) @@ -1275,43 +1131,37 @@ type arity = rel_declaration list * sorts let destArity = let rec prodec_rec l c = match kind_of_term c with - | IsProd (x,t,c) -> prodec_rec ((x,None,t)::l) c - | IsLetIn (x,b,t,c) -> prodec_rec ((x,Some b,t)::l) c - | IsCast (c,_) -> prodec_rec l c - | IsSort s -> l,s + | Prod (x,t,c) -> prodec_rec ((x,None,t)::l) c + | LetIn (x,b,t,c) -> prodec_rec ((x,Some b,t)::l) c + | Cast (c,_) -> prodec_rec l c + | Sort s -> l,s | _ -> anomaly "destArity: not an arity" in prodec_rec [] let rec isArity c = match kind_of_term c with - | IsProd (_,_,c) -> isArity c - | IsCast (c,_) -> isArity c - | IsSort _ -> true + | Prod (_,_,c) -> isArity c + | Cast (c,_) -> isArity c + | Sort _ -> 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 c = match kind_of_term c with - | IsProd (x,t,c) -> prodec_rec ((x,t)::l) c - | IsCast (c,_) -> prodec_rec l c + | Prod (x,t,c) -> prodec_rec ((x,t)::l) c + | Cast (c,_) -> prodec_rec l c | _ -> l,c in prodec_rec [] -let rec hd_of_prod prod = - match kind_of_term prod with - | IsProd (n,c,t') -> hd_of_prod t' - | IsCast (c,_) -> hd_of_prod c - | _ -> prod - (* 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 = let rec lamdec_rec l c = match kind_of_term c with - | IsLambda (x,t,c) -> lamdec_rec ((x,t)::l) c - | IsCast (c,_) -> lamdec_rec l c + | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) c + | Cast (c,_) -> lamdec_rec l c | _ -> l,c in lamdec_rec [] @@ -1323,8 +1173,8 @@ let decompose_prod_n n = let rec prodec_rec l n c = if n=0 then l,c else match kind_of_term c with - | IsProd (x,t,c) -> prodec_rec ((x,t)::l) (n-1) c - | IsCast (c,_) -> prodec_rec l n c + | Prod (x,t,c) -> prodec_rec ((x,t)::l) (n-1) c + | Cast (c,_) -> prodec_rec l n c | _ -> error "decompose_prod_n: not enough products" in prodec_rec [] n @@ -1336,8 +1186,8 @@ let decompose_lam_n n = let rec lamdec_rec l n c = if n=0 then l,c else match kind_of_term c with - | IsLambda (x,t,c) -> lamdec_rec ((x,t)::l) (n-1) c - | IsCast (c,_) -> lamdec_rec l n c + | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) (n-1) c + | Cast (c,_) -> lamdec_rec l n c | _ -> error "decompose_lam_n: not enough abstractions" in lamdec_rec [] n @@ -1346,8 +1196,8 @@ let decompose_lam_n n = * gives n (casts are ignored) *) let nb_lam = let rec nbrec n c = match kind_of_term c with - | IsLambda (_,_,c) -> nbrec (n+1) c - | IsCast (c,_) -> nbrec n c + | Lambda (_,_,c) -> nbrec (n+1) c + | Cast (c,_) -> nbrec n c | _ -> n in nbrec 0 @@ -1355,282 +1205,28 @@ let nb_lam = (* similar to nb_lam, but gives the number of products instead *) let nb_prod = let rec nbrec n c = match kind_of_term c with - | IsProd (_,_,c) -> nbrec (n+1) c - | IsCast (c,_) -> nbrec n c + | Prod (_,_,c) -> nbrec (n+1) c + | Cast (c,_) -> nbrec n c | _ -> n in nbrec 0 -(* Misc *) -let sort_hdchar = function - | Prop(_) -> "P" - | Type(_) -> "T" - -(* Level comparison for information extraction : Prop <= Type *) -let le_kind l m = (isprop l) or (is_Type m) - -let le_kind_implicit k1 k2 = - (k1=mkImplicit) or (isprop k1) or (k2=mkImplicit) or (is_Type k2) - - (* Rem: end of import from old module Generic *) -(* Various occurs checks *) - -(* (occur_const s c) -> true if constant s occurs in c, - * false otherwise *) -let occur_const s c = - let rec occur_rec c = match kind_of_term c with - | IsConst sp when sp=s -> raise Occur - | _ -> iter_constr occur_rec c - in - try occur_rec c; false with Occur -> true - -let occur_evar n c = - let rec occur_rec c = match kind_of_term c with - | IsEvar (sp,_) when sp=n -> raise Occur - | _ -> iter_constr occur_rec c - in - try occur_rec c; false with Occur -> true - -(***************************************) -(* alpha and eta conversion functions *) -(***************************************) +(*******************************) +(* alpha conversion functions *) +(*******************************) (* alpha conversion : ignore print names and casts *) let rec eq_constr m n = - (m = n) or (* Rem: ocaml '=' includes '==' *) + (m==n) or compare_constr eq_constr m n let eq_constr m n = eq_constr m n (* to avoid tracing a recursive fun *) -(* (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 m t = - let rec deprec m t = - if (eq_constr m t) then - raise Occur - else - iter_constr_with_binders (lift 1) deprec m t - in - try deprec m t; false with Occur -> true - -(* On reduit une serie d'eta-redex de tete ou rien du tout *) -(* [x1:c1;...;xn:cn]@(f;a1...an;x1;...;xn) --> @(f;a1...an) *) -(* Remplace 2 versions précédentes buggées *) - -let rec eta_reduce_head c = - match kind_of_term c with - | IsLambda (_,c1,c') -> - (match kind_of_term (eta_reduce_head c') with - | IsApp (f,cl) -> - let lastn = (Array.length cl) - 1 in - if lastn < 1 then anomaly "application without arguments" - else - (match kind_of_term cl.(lastn) with - | IsRel 1 -> - let c' = - if lastn = 1 then f - else mkApp (f, Array.sub cl 0 lastn) - in - if not (dependent (mkRel 1) c') - then lift (-1) c' - else c - | _ -> c) - | _ -> c) - | _ -> c - -(* alpha-eta conversion : ignore print names and casts *) -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 compare_constr aux t1 t2 - in aux - - -(***************************) -(* substitution functions *) -(***************************) - -(* First utilities for avoiding telescope computation for subst_term *) - -let prefix_application (k,c) (t : constr) = - let c' = strip_head_cast c and t' = strip_head_cast t in - match kind_of_term c', kind_of_term t' with - | IsApp (f1,cl1), IsApp (f2,cl2) -> - let l1 = Array.length cl1 - and l2 = Array.length cl2 in - if l1 <= l2 - && eq_constr c' (mkApp (f2, Array.sub cl2 0 l1)) then - Some (mkApp (mkRel k, Array.sub cl2 l1 (l2 - l1))) - else - None - | _ -> None - -let my_prefix_application (k,c) (by_c : constr) (t : constr) = - let c' = strip_head_cast c and t' = strip_head_cast t in - match kind_of_term c', kind_of_term t' with - | IsApp (f1,cl1), IsApp (f2,cl2) -> - let l1 = Array.length cl1 - and l2 = Array.length cl2 in - if l1 <= l2 - && eq_constr c' (mkApp (f2, Array.sub cl2 0 l1)) then - Some (mkApp ((lift k by_c), Array.sub cl2 l1 (l2 - l1))) - else - None - | _ -> None - -let prefix_application_eta (k,c) (t : constr) = - let c' = strip_head_cast c and t' = strip_head_cast t in - match kind_of_term c', kind_of_term t' with - | IsApp (f1,cl1), IsApp (f2,cl2) -> - let l1 = Array.length cl1 - and l2 = Array.length cl2 in - if l1 <= l2 && - eta_eq_constr c' (mkApp (f2, Array.sub cl2 0 l1)) then - Some (mkApp (mkRel k, Array.sub cl2 l1 (l2 - l1))) - else - None - | (_,_) -> None - -let sort_increasing_snd = - Sort.list - (fun (_,x) (_,y) -> match kind_of_term x, kind_of_term y with - | IsRel m, IsRel n -> m < n - | _ -> assert false) - -(* Recognizing occurrences of a given (closed) subterm in a term for Pattern : - [subst_term c t] substitutes [(Rel 1)] for all occurrences of (closed) - term [c] in a term [t] *) -(*i Bizarre : si on cherche un sous terme clos, pourquoi le lifter ? i*) - -let subst_term_gen eq_fun c t = - let rec substrec (k,c as kc) t = - match prefix_application kc t with - | Some x -> x - | None -> - (if eq_fun t c then mkRel k else match kind_of_term t with - | IsConst _ | IsMutInd _ | IsMutConstruct _ -> t - | _ -> - map_constr_with_binders - (fun (k,c) -> (k+1,lift 1 c)) - substrec kc t) - in - substrec (1,c) t - -(* Recognizing occurrences of a given (closed) subterm in a term : - [replace_term c1 c2 t] substitutes [c2] for all occurrences of (closed) - term [c1] in a term [t] *) -(*i Meme remarque : a priori [c] n'est pas forcement clos i*) - -let replace_term_gen eq_fun c by_c in_t = - let rec substrec (k,c as kc) t = - match my_prefix_application kc by_c t with - | Some x -> x - | None -> - (if eq_fun t c then (lift k by_c) else match kind_of_term t with - | IsConst _ | IsMutInd _ | IsMutConstruct _ -> t - | _ -> - map_constr_with_binders - (fun (k,c) -> (k+1,lift 1 c)) - substrec kc t) - in - substrec (0,c) in_t - -let subst_term = subst_term_gen eq_constr -let subst_term_eta = subst_term_gen eta_eq_constr - -let replace_term = replace_term_gen 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 kind_of_term c with - | IsMeta i -> (try List.assoc i bl with Not_found -> c) - | _ -> map_constr (subst_meta bl) c - -(* Substitute only a list of locations locs, the empty list is - interpreted as substitute all, if 0 is in the list then no - substitution is done. The list may contain only negative occurrences - that will not be substituted. *) - -let subst_term_occ_gen locs occ c t = - let maxocc = List.fold_right max locs 0 in - let pos = ref occ in - let check = ref true in - let except = List.exists (fun n -> n<0) locs in - if except & (List.exists (fun n -> n>=0) locs) - then error "mixing of positive and negative occurences" - else - let rec substrec (k,c as kc) t = - if (not except) & (!pos > maxocc) then t - else - if eq_constr t c then - let r = - if except then - if List.mem (- !pos) locs then t else (mkRel k) - else - if List.mem !pos locs then (mkRel k) else t - in incr pos; r - else - match kind_of_term t with - | IsConst _ | IsMutConstruct _ | IsMutInd _ -> t - | _ -> - map_constr_with_binders_left_to_right - (fun (k,c) -> (k+1,lift 1 c)) substrec kc t - in - let t' = substrec (1,c) t in - (!pos, t') - -let subst_term_occ locs c t = - if locs = [] then - subst_term c t - else if List.mem 0 locs then - t - else - let (nbocc,t') = subst_term_occ_gen locs 1 c t in - if List.exists (fun o -> o >= nbocc or o <= -nbocc) locs then - errorlabstrm "subst_term_occ" [< 'sTR "Too few occurences" >]; - t' - -let subst_term_occ_decl locs c (id,bodyopt,typ as d) = - match bodyopt with - | None -> (id,None,subst_term_occ locs c typ) - | Some body -> - if locs = [] then - (id,Some (subst_term c body),type_app (subst_term c) typ) - else if List.mem 0 locs then - d - else - let (nbocc,body') = subst_term_occ_gen locs 1 c body in - let (nbocc',t') = type_app (subst_term_occ_gen locs nbocc c) typ in - if List.exists (fun o -> o >= nbocc' or o <= -nbocc') locs then - errorlabstrm "subst_term_occ_decl" [< 'sTR "Too few occurences" >]; - (id,Some body',t') - -(***************************) -(* occurs check functions *) -(***************************) - -let occur_meta c = - let rec occrec c = match kind_of_term c with - | IsMeta _ -> raise Occur - | _ -> iter_constr occrec c - in try occrec c; false with Occur -> true - -let occur_existential c = - let rec occrec c = match kind_of_term c with - | IsEvar _ -> raise Occur - | _ -> iter_constr occrec c - in try occrec c; false with Occur -> true - +(*******************) +(* hash-consing *) +(*******************) module Htype = Hashcons.Make( @@ -1672,136 +1268,4 @@ let hcons_constr (hspcci,hdir,hname,hident,hstr) = let htcci = Hashcons.simple_hcons Htype.f (hcci,hsortscci) in (hcci,htcci) -let hcons1_constr = - let hnames = hcons_names () in - let (hc,_) = hcons_constr hnames in - hc - -let hcons1_types = - let hnames = hcons_names () in - let (_,ht) = hcons_constr hnames in - ht - -(* Abstract decomposition of constr to deal with generic functions *) - -type fix_kind = RFix of (int array * int) | RCoFix of int - -type constr_operator = - | OpMeta of int - | OpSort of sorts - | OpRel of int | OpVar of identifier - | OpCast | OpProd of name | OpLambda of name | OpLetIn of name - | OpApp | OpConst of constant - | OpEvar of existential_key - | OpMutInd of inductive - | OpMutConstruct of constructor - | OpMutCase of case_info - | OpRec of fix_kind * name array - -let splay_constr c = match kind_of_term c with - | IsRel n -> OpRel n, [||] - | IsVar id -> OpVar id, [||] - | IsMeta n -> OpMeta n, [||] - | IsSort s -> OpSort s, [||] - | IsCast (t1, t2) -> OpCast, [|t1;t2|] - | IsProd (x, t1, t2) -> OpProd x, [|t1;t2|] - | IsLambda (x, t1, t2) -> OpLambda x, [|t1;t2|] - | IsLetIn (x, b, t1, t2) -> OpLetIn x, [|b;t1;t2|] - | IsApp (f,a) -> OpApp, Array.append [|f|] a - | IsConst sp -> OpConst sp,[||] - | IsEvar (sp, a) -> OpEvar sp, a - | IsMutInd ind_sp -> OpMutInd ind_sp,[||] - | IsMutConstruct cstr_sp -> OpMutConstruct cstr_sp, [||] - | IsMutCase (ci,p,c,bl) -> OpMutCase ci, Array.append [|p;c|] bl - | IsFix (fi,(lna,tl,bl)) -> OpRec (RFix fi,lna), Array.append tl bl - | IsCoFix (fi,(lna,tl,bl)) -> OpRec (RCoFix fi,lna), Array.append tl bl - -let gather_constr = function - | OpRel n, [||] -> mkRel n - | OpVar id, [||] -> mkVar id - | OpMeta n, [||] -> mkMeta n - | OpSort s, [||] -> mkSort s - | OpCast, [|t1;t2|] -> mkCast (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) - | OpApp, v -> let f = v.(0) and a = array_tl v in mkApp (f, a) - | OpConst sp, [||] -> mkConst sp - | OpEvar sp, a -> mkEvar (sp, a) - | OpMutInd ind_sp, [||] -> mkMutInd ind_sp - | OpMutConstruct cstr_sp, [||] -> mkMutConstruct cstr_sp - | OpMutCase ci, v -> - let p = v.(0) and c = v.(1) and bl = Array.sub v 2 (Array.length v -2) - in mkMutCase (ci, p, c, bl) - | OpRec (RFix fi,na), a -> - let n = Array.length a / 2 in - mkFix (fi,(na, Array.sub a 0 n, Array.sub a n n)) - | OpRec (RCoFix i,na), a -> - let n = Array.length a / 2 in - mkCoFix (i,(na, Array.sub a 0 n, Array.sub a n n)) - | _ -> errorlabstrm "Term.gather_term" [< 'sTR "ill-formed splayed constr">] - -let splay_constr_with_binders c = match kind_of_term c with - | IsRel n -> OpRel n, [], [||] - | IsVar id -> OpVar id, [], [||] - | IsMeta n -> OpMeta n, [], [||] - | IsSort s -> OpSort s, [], [||] - | IsCast (t1, t2) -> OpCast, [], [|t1;t2|] - | IsProd (x, t1, t2) -> OpProd x, [x,None,t1], [|t2|] - | IsLambda (x, t1, t2) -> OpLambda x, [x,None,t1], [|t2|] - | IsLetIn (x, b, t1, t2) -> OpLetIn x, [x,Some b,t1], [|t2|] - | IsApp (f,v) -> OpApp, [], Array.append [|f|] v - | IsConst sp -> OpConst sp, [], [||] - | IsEvar (sp, a) -> OpEvar sp, [], a - | IsMutInd ind_sp -> OpMutInd ind_sp, [], [||] - | IsMutConstruct cstr_sp -> OpMutConstruct cstr_sp, [], [||] - | IsMutCase (ci,p,c,bl) -> - let v = Array.append [|p;c|] bl in OpMutCase ci, [], v - | IsFix (fi,(na,tl,bl)) -> - let n = Array.length bl in - let ctxt = - Array.to_list - (array_map2_i (fun i x t -> (x,None,lift i t)) na tl) in - OpRec (RFix fi,na), ctxt, bl - | IsCoFix (fi,(na,tl,bl)) -> - let n = Array.length bl in - let ctxt = - Array.to_list - (array_map2_i (fun i x t -> (x,None,lift i t)) na tl) in - OpRec (RCoFix fi,na), ctxt, bl - -let gather_constr_with_binders = function - | OpRel n, [], [||] -> mkRel n - | OpVar id, [], [||] -> mkVar id - | OpMeta n, [], [||] -> mkMeta n - | OpSort s, [], [||] -> mkSort s - | OpCast, [], [|t1;t2|] -> mkCast (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) - | OpApp, [], v -> let f = v.(0) and a = array_tl v in mkApp (f, a) - | OpConst sp, [], [||] -> mkConst sp - | OpEvar sp, [], a -> mkEvar (sp, a) - | OpMutInd ind_sp, [], [||] -> mkMutInd ind_sp - | OpMutConstruct cstr_sp, [], [||] -> mkMutConstruct cstr_sp - | OpMutCase ci, [], v -> - let p = v.(0) and c = v.(1) and bl = Array.sub v 2 (Array.length v -2) - in mkMutCase (ci, p, c, bl) - | OpRec (RFix fi,na), ctxt, bl -> - let tl = - Array.mapi (fun i (_,_,t) -> lift (-i) t) (Array.of_list ctxt) in - mkFix (fi,(na, tl, bl)) - | OpRec (RCoFix i,na), ctxt, bl -> - let tl = - Array.mapi (fun i (_,_,t) -> lift (-i) t) (Array.of_list ctxt) in - mkCoFix (i,(na, tl, bl)) - | _ -> errorlabstrm "Term.gather_term" [< 'sTR "ill-formed splayed 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 +let (hcons1_constr, hcons1_types) = hcons_constr (hcons_names()) diff --git a/kernel/term.mli b/kernel/term.mli index 90b1dd807..0ce4f3d4a 100644 --- a/kernel/term.mli +++ b/kernel/term.mli @@ -1,4 +1,4 @@ -(***********************************************************************) +(***********************Sppc************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) (* \VV/ *************************************************************) @@ -9,8 +9,6 @@ (*i $Id$ i*) (*i*) -open Util -open Pp open Names (*i*) @@ -24,8 +22,7 @@ type sorts = val mk_Set : sorts val mk_Prop : sorts - -val print_sort : sorts -> std_ppcmds +val type_0 : sorts (*s The sorts family of CCI. *) @@ -36,38 +33,33 @@ val new_sort_in_family : sorts_family -> sorts (*s Useful types *) +(*s Existential variables *) type existential_key = int +(*s Case annotation *) type pattern_source = DefaultPat of int | RegularPat type case_style = PrintLet | PrintIf | PrintCases type case_printing = - inductive * identifier array * int - * case_style option * pattern_source array + { cnames : identifier array; + ind_nargs : int; (* number of real args of the inductive type *) + style : case_style option; + source : pattern_source array } (* the integer is the number of real args, needed for reduction *) -type case_info = int * case_printing - -(*s Concrete type for making pattern-matching. *) -module Polymorph : -sig -(* [constr array] is an instance matching definitional [named_context] in - the same order (i.e. last argument first) *) -type 'constr existential = existential_key * 'constr array -type ('constr, 'types) rec_declaration = - name array * 'types array * 'constr array -type ('constr, 'types) fixpoint = - (int array * int) * ('constr, 'types) rec_declaration -type ('constr, 'types) cofixpoint = - int * ('constr, 'types) rec_declaration - -(* [IsVar] is used for named variables and [IsRel] for variables as - de Bruijn indices. *) -end +type case_info = + { ci_ind : inductive; + ci_npar : int; + ci_pp_info : case_printing (* not interpreted by the kernel *) + } (*s*******************************************************************) (* The type of constructions *) type constr +(* [eq_constr a b] is true if [a] equals [b] modulo alpha, casts, + and application grouping *) +val eq_constr : constr -> constr -> bool + (* [types] is the same as [constr] but is intended to be used where a {\em type} in CCI sense is expected (Rem:plurial form since [type] is a reserved ML keyword) *) @@ -80,144 +72,79 @@ val type_app : (constr -> constr) -> types -> types val body_of_type : types -> constr -(*s A {\em declaration} has the form (name,body,type). It is either an - {\em assumption} if [body=None] or a {\em definition} if - [body=Some actualbody]. It is referred by {\em name} if [na] is an - identifier or by {\em relative index} if [na] is not an identifier - (in the latter case, [na] is of type [name] but just for printing - purpose *) - -type named_declaration = identifier * constr option * types -type rel_declaration = name * constr option * types - -type arity = rel_declaration list * sorts - (*s Functions for dealing with constr terms. The following functions are intended to simplify and to uniform the manipulation of terms. Some of these functions may be overlapped with previous ones. *) -open Polymorph -type ('constr, 'types) kind_of_term = - | IsRel of int - | IsMeta of int - | IsVar of identifier - | IsSort of sorts - | IsCast of 'constr * 'constr - | IsProd of name * 'types * 'constr - | IsLambda of name * 'types * 'constr - | IsLetIn of name * 'constr * 'types * 'constr - | IsApp of 'constr * 'constr array - | IsEvar of 'constr existential - | IsConst of constant - | IsMutInd of inductive - | IsMutConstruct of constructor - | IsMutCase of case_info * 'constr * 'constr * 'constr array - | IsFix of ('constr, 'types) fixpoint - | IsCoFix of ('constr, 'types) cofixpoint - -type existential = existential_key * constr array -type rec_declaration = name array * types array * constr array -type fixpoint = (int array * int) * rec_declaration -type cofixpoint = int * rec_declaration - -(* User view of [constr]. For [IsApp], it is ensured there is at - least one argument and the function is not itself an applicative - term *) - -val kind_of_term : constr -> (constr, types) kind_of_term - (*s Term constructors. *) (* Constructs a DeBrujin index *) val mkRel : int -> constr -(* Constructs an existential variable named "?n" *) -val mkMeta : int -> constr - (* Constructs a Variable *) val mkVar : identifier -> constr -(* Construct a type *) +(* Constructs an metavariable named "?n" *) +val mkMeta : int -> constr + +(* Constructs an existential variable *) +type existential = existential_key * constr array +val mkEvar : existential -> constr + +(* Construct a sort *) val mkSort : sorts -> constr val mkProp : constr -val mkSet : constr +val mkSet : constr val mkType : Univ.universe -> constr -val prop : sorts -val spec : sorts -(*val types : sorts *) -val type_0 : sorts - -(* Construct an implicit (see implicit arguments in the RefMan). - Used for extraction *) -val mkImplicit : constr -val implicit_sort : sorts -(* Constructs the term $t_1::t2$, i.e. the term $t_1$ casted with the +(* Constructs the term [t1::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 * types -> constr -(* Constructs the product $(x:t_1)t_2$ *) -val mkProd : name * types * 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 * types * constr -> constr -val mkNamedLetIn : identifier -> constr -> constr -> constr -> constr - -(* Constructs either [(x:t)c] or [[x=b:t]c] *) -val mkProd_or_LetIn : rel_declaration -> constr -> constr -val mkNamedProd_or_LetIn : named_declaration -> constr -> constr - -(* Constructs either [[x:t]c] or [[x=b:t]c] *) -val mkLambda_or_LetIn : rel_declaration -> constr -> constr -val mkNamedLambda_or_LetIn : named_declaration -> constr -> constr - -(* Constructs either [(x:t)c] or [c] where [x] is replaced by [b] *) -val mkProd_wo_LetIn : rel_declaration -> constr -> constr -val mkNamedProd_wo_LetIn : named_declaration -> constr -> constr - -(* non-dependant product $t_1 \rightarrow t_2$ *) -val mkArrow : constr -> constr -> constr +(* Constructs the product [(x:t1)t2] *) +val mkProd : name * types * types -> constr +val mkNamedProd : identifier -> types -> types -> constr +(* non-dependant product $t_1 \rightarrow t_2$, an alias for + [(_:t1)t2]. Beware $t_2$ is NOT lifted. + Eg: A |- A->A is built by [(mkArrow (mkRel 0) (mkRel 1))] *) +val mkArrow : types -> types -> constr (* Constructs the abstraction $[x:t_1]t_2$ *) val mkLambda : name * types * constr -> constr -val mkNamedLambda : identifier -> constr -> constr -> constr +val mkNamedLambda : identifier -> types -> constr -> constr -(* [mkLambda_string s t c] constructs $[s:t]c$ *) -val mkLambda_string : string -> constr -> constr -> constr +(* Constructs the product [let x = t1 : t2 in t3] *) +val mkLetIn : name * constr * types * constr -> constr +val mkNamedLetIn : identifier -> constr -> types -> constr -> constr (* [mkApp (f,[| t_1; ...; t_n |]] constructs the application $(f~t_1~\dots~t_n)$. *) val mkApp : constr * constr array -> constr -val mkAppA : constr array -> constr (* Constructs a constant *) (* The array of terms correspond to the variables introduced in the section *) val mkConst : constant -> constr -(* Constructs an existential variable *) -val mkEvar : existential -> constr +(* Inductive types *) (* Constructs the ith (co)inductive type of the block named sp *) (* The array of terms correspond to the variables introduced in the section *) -val mkMutInd : inductive -> constr +val mkInd : inductive -> constr (* Constructs the jth constructor of the ith (co)inductive type of the block named sp. The array of terms correspond to the variables introduced in the section *) -val mkMutConstruct : constructor -> constr +val mkConstruct : constructor -> constr (* Constructs the term <p>Case c of c1 | c2 .. | cn end *) -val mkMutCaseL : case_info * constr * constr * constr list -> constr -val mkMutCase : case_info * constr * constr * constr array -> constr +val mkCase : case_info * constr * constr * constr array -> constr (* If [recindxs = [|i1,...in|]] + [funnames = [|f1,.....fn|]] [typarray = [|t1,...tn|]] - [funnames = [f1,.....fn]] - [bodies = [b1,.....bn]] - then [ mkFix ((recindxs,i),typarray, funnames, bodies) ] + [bodies = [|b1,.....bn|]] + then [ mkFix ((recindxs,i), funnames, typarray, bodies) ] constructs the $i$th function of the block (counting from 0) [Fixpoint f1 [ctx1] = b1 @@ -225,12 +152,14 @@ val mkMutCase : case_info * constr * constr * constr array -> constr ... with fn [ctxn] = bn.] - \noindent where the lenght of the $j$th context is $ij$. + \noindent where the length of the $j$th context is $ij$. *) +type rec_declaration = name array * types array * constr array +type fixpoint = (int array * int) * rec_declaration val mkFix : fixpoint -> constr -(* If [typarray = [|t1,...tn|]] - [funnames = [f1,.....fn]] +(* If [funnames = [|f1,.....fn|]] + [typarray = [|t1,...tn|]] [bodies = [b1,.....bn]] \par\noindent then [mkCoFix (i, (typsarray, funnames, bodies))] constructs the ith function of the block @@ -240,22 +169,73 @@ val mkFix : fixpoint -> constr ... with fn = bn.] *) +type cofixpoint = int * rec_declaration val mkCoFix : cofixpoint -> constr + +(*s Concrete type for making pattern-matching. *) + +(* [constr array] is an instance matching definitional [named_context] in + the same order (i.e. last argument first) *) +type 'constr pexistential = existential_key * 'constr array +type ('constr, 'types) prec_declaration = + name array * 'types array * 'constr array +type ('constr, 'types) pfixpoint = + (int array * int) * ('constr, 'types) prec_declaration +type ('constr, 'types) pcofixpoint = + int * ('constr, 'types) prec_declaration + +type ('constr, 'types) kind_of_term = + | Rel of int + | Var of identifier + | Meta of int + | Evar of 'constr pexistential + | Sort of sorts + | Cast of 'constr * 'constr + | Prod of name * 'types * 'types + | Lambda of name * 'types * 'constr + | LetIn of name * 'constr * 'types * 'constr + | App of 'constr * 'constr array + | Const of constant + | Ind of inductive + | Construct of constructor + | Case of case_info * 'constr * 'constr * 'constr array + | Fix of ('constr, 'types) pfixpoint + | CoFix of ('constr, 'types) pcofixpoint + +(* User view of [constr]. For [App], it is ensured there is at + least one argument and the function is not itself an applicative + term *) + +val kind_of_term : constr -> (constr, types) kind_of_term + +(*s Simple term case analysis. *) + +val isRel : constr -> bool +val isVar : constr -> bool +val isMeta : constr -> bool +val isSort : constr -> bool +val isCast : constr -> bool +val isApp : constr -> bool +val isConst : constr -> bool +val isConstruct : constr -> bool + +val is_Prop : constr -> bool +val is_Set : constr -> bool +val isprop : constr -> bool +val is_Type : constr -> bool +val iskind : constr -> bool +val is_small : sorts -> bool + (*s Term destructors. Destructor operations are partial functions and raise [invalid_arg "dest*"] if the term has not the expected form. *) -(* Destructs a term of the form $(x_1:T_1)..(x_n:T_n)s$ into the pair *) -val destArity : constr -> arity -val isArity : constr -> bool - (* Destructs a DeBrujin index *) val destRel : constr -> int (* Destructs an existential variable *) val destMeta : constr -> int -val isMeta : constr -> bool (* Destructs a variable *) val destVar : constr -> identifier @@ -263,68 +243,35 @@ val destVar : constr -> identifier (* Destructs a sort. [is_Prop] recognizes the sort \textsf{Prop}, whether [isprop] recognizes both \textsf{Prop} and \textsf{Set}. *) val destSort : constr -> sorts -val is_Prop : constr -> bool -val is_Set : constr -> bool -val isprop : constr -> bool -val is_Type : constr -> bool -val iskind : constr -> bool -val isSort : constr -> bool - -val isType : sorts -> bool -val is_small : sorts -> bool (* true for \textsf{Prop} and \textsf{Set} *) (* Destructs a casted term *) -val destCast : constr -> constr * constr -val isCast : constr -> bool - -(* Removes recursively the casts around a term i.e. - [strip_outer_cast] (Cast (Cast ... (Cast c, t) ... ))] is [c]. *) -val strip_outer_cast : constr -> constr - -(* Apply a function letting Casted types in place *) -val under_casts : (constr -> constr) -> constr -> constr - -(* Tests if a de Bruijn index *) -val isRel : constr -> bool - -(* Tests if a variable *) -val isVar : constr -> bool +val destCast : constr -> constr * types (* Destructs the product $(x:t_1)t_2$ *) -val destProd : constr -> name * constr * constr -val hd_of_prod : constr -> constr -(*i -val hd_is_constructor : constr -> bool -i*) +val destProd : types -> name * types * types (* Destructs the abstraction $[x:t_1]t_2$ *) -val destLambda : constr -> name * constr * constr +val destLambda : constr -> name * types * constr (* Destructs the let $[x:=b:t_1]t_2$ *) -val destLetIn : constr -> name * constr * constr * constr +val destLetIn : constr -> name * constr * types * constr (* Destructs an application *) -val isApp : constr -> bool -(*i -val hd_app : constr -> constr -val args_app : constr -> constr array -i*) val destApplication : constr -> constr * constr array +(* ... removing casts *) +val decompose_app : constr -> constr * constr list (* Destructs a constant *) val destConst : constr -> constant -val isConst : constr -> bool (* Destructs an existential variable *) -val destEvar : constr -> existential_key * constr array -val num_of_evar : constr -> existential_key +val destEvar : constr -> existential (* Destructs a (co)inductive type *) -val destMutInd : constr -> inductive +val destInd : constr -> inductive (* Destructs a constructor *) -val destMutConstruct : constr -> constructor -val isMutConstruct : constr -> bool +val destConstruct : constr -> constructor (* Destructs a term <p>Case c of lc1 | lc2 .. | lcn end *) val destCase : constr -> case_info * constr * constr * constr array @@ -340,6 +287,30 @@ val destFix : constr -> fixpoint val destCoFix : constr -> cofixpoint + +(*s A {\em declaration} has the form (name,body,type). It is either an + {\em assumption} if [body=None] or a {\em definition} if + [body=Some actualbody]. It is referred by {\em name} if [na] is an + identifier or by {\em relative index} if [na] is not an identifier + (in the latter case, [na] is of type [name] but just for printing + purpose *) + +type named_declaration = identifier * constr option * types +type rel_declaration = name * constr option * types + +val map_named_declaration : + (constr -> constr) -> named_declaration -> named_declaration + +(* Constructs either [(x:t)c] or [[x=b:t]c] *) +val mkProd_or_LetIn : rel_declaration -> types -> constr +val mkNamedProd_or_LetIn : named_declaration -> types -> constr +val mkNamedProd_wo_LetIn : named_declaration -> types -> constr + +(* Constructs either [[x:t]c] or [[x=b:t]c] *) +val mkLambda_or_LetIn : rel_declaration -> constr -> constr +val mkNamedLambda_or_LetIn : named_declaration -> constr -> constr + + (*s Other term constructors. *) val abs_implicit : constr -> constr @@ -361,14 +332,6 @@ val prodn : int -> (name * constr) list -> constr -> constr where $l = [(x_n,T_n);\dots;(x_1,T_1);Gamma]$ *) val lamn : int -> (name * constr) list -> constr -> constr -(* [prod_it b l] = $(x_1:T_1)..(x_n:T_n)b$ - where $l = [(x_n,T_n);\dots;(x_1,T_1)]$ *) -val prod_it : constr -> (name * constr) list -> constr - -(* [lam_it b l] = $[x_1:T_1]..[x_n:T_n]b$ - where $l = [(x_n,T_n);\dots;(x_1,T_1)]$ *) -val lam_it : constr -> (name * constr) list -> constr - (* [to_lambda n l] = $[x_1:T_1]...[x_n:T_n](x_{n+1}:T_{n+1})...(x_{n+j}:T_{n+j})T$ where $l = (x_1:T_1)...(x_n:T_n)(x_{n+1}:T_{n+1})...(x_{n+j}:T_{n+j})T$ *) @@ -381,6 +344,11 @@ val prod_applist : constr -> constr list -> constr (*s Other term destructors. *) +(* Destructs a term of the form $(x_1:T_1)..(x_n:T_n)s$ into the pair *) +type arity = rel_declaration list * sorts +val destArity : constr -> arity +val isArity : constr -> bool + (* Transforms a product term $(x_1:T_1)..(x_n:T_n)T$ into the pair $([(x_n,T_n);...;(x_1,T_1)],T)$, where $T$ is not a product. It includes also local definitions *) @@ -408,20 +376,16 @@ val nb_prod : constr -> int (* flattens application lists *) val collapse_appl : constr -> constr -val decomp_app : constr -> constr * constr list - -(*s Misc functions on terms, sorts and conversion problems. *) -(* Level comparison for information extraction : Prop <= Type *) -val same_kind : constr -> constr -> bool -val le_kind : constr -> constr -> bool -val le_kind_implicit : constr -> constr -> bool +(* Removes recursively the casts around a term i.e. + [strip_outer_cast] (Cast (Cast ... (Cast c, t) ... ))] is [c]. *) +val strip_outer_cast : constr -> constr -val sort_hdchar : sorts -> string +(* Apply a function letting Casted types in place *) +val under_casts : (constr -> constr) -> constr -> constr -(* Generic functions *) -val free_rels : constr -> Intset.t +(*s Occur checks *) (* [closed0 M] is true iff [M] is a (deBruijn) closed term *) val closed0 : constr -> bool @@ -439,6 +403,8 @@ val noccur_between : int -> int -> constr -> bool context) (for existential variables, it is necessarily the case) *) val noccur_with_meta : int -> int -> constr -> bool +(*s Relocation and substitution *) + (* [liftn n k c] lifts by [n] indexes above [k] in [c] *) val liftn : int -> int -> constr -> constr @@ -469,91 +435,6 @@ val subst_vars : identifier list -> constr -> constr if two names are identical, the one of least indice is keeped *) val substn_vars : int -> 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 - -(*s [extended_rel_vect n hyps] and [extended_rel_list n hyps] - generalizes [rel_vect] when local definitions may occur in parameters *) -val extended_rel_vect : int -> rel_declaration list -> constr array -val extended_rel_list : int -> rel_declaration list -> constr list - -(*s Occur check functions. *) - -val occur_meta : constr -> bool - -(*i Returns the maximum of metas. Returns -1 if there is no meta i*) -(*i val max_occur_meta : constr -> int i*) - -val occur_existential : constr -> bool - -(* [(occur_const (s:section_path) c)] returns [true] if constant [s] occurs - in c, [false] otherwise *) -val occur_const : constant -> constr -> bool - -(* [(occur_evar ev c)] returns [true] if existential variable [ev] occurs - in c, [false] otherwise *) -val occur_evar : existential_key -> 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 *) -val dependent : constr -> constr -> bool - -(* strips head casts and flattens head applications *) -val strip_head_cast : constr -> constr -val eta_reduce_head : constr -> constr -val eq_constr : constr -> constr -> bool -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_occ : occs:int list -> what:constr -> where:constr -> constr -val subst_term_occ_decl : occs:int list -> what:constr -> - where:named_declaration -> named_declaration - -(* [replace_term c by_c in_t substitutes c by by_c in in_t *) -val replace_term : constr -> constr -> constr -> constr - -(* [subst_meta bl c] substitutes the metavar $i$ by $c_i$ in [c] - for each binding $(i,c_i)$ in [bl], - and raises [Not_found] if [c] contains a meta that is not in the - association list *) - -val subst_meta : (int * constr) list -> constr -> constr - -(*s Generic representation of constructions *) - -type fix_kind = RFix of (int array * int) | RCoFix of int - -type constr_operator = - | OpMeta of int - | OpSort of sorts - | OpRel of int | OpVar of identifier - | OpCast | OpProd of name | OpLambda of name | OpLetIn of name - | OpApp | OpConst of constant - | OpEvar of existential_key - | OpMutInd of inductive - | OpMutConstruct of constructor - | OpMutCase of case_info - | OpRec of fix_kind * name array - - -val splay_constr : constr -> constr_operator * constr array -val gather_constr : constr_operator * constr array -> constr -(*i -val splay_constr : ('a,'a)kind_of_term -> constr_operator * 'a array -val gather_constr : constr_operator * 'a array -> ('a,'a) kind_of_term -i*) -val splay_constr_with_binders : constr -> - constr_operator * rel_declaration list * constr array -val gather_constr_with_binders : - constr_operator * rel_declaration list * constr array - -> constr - -val generic_fold_left : - ('a -> constr -> 'a) -> 'a -> rel_declaration list - -> constr array -> 'a - (*s Functionals working on the immediate subterm of a construction *) (* [fold_constr f acc c] folds [f] on the immediate subterms of [c] @@ -572,21 +453,6 @@ val fold_constr : ('a -> constr -> 'a) -> 'a -> constr -> 'a val fold_constr_with_binders : ('a -> 'a) -> ('a -> 'b -> constr -> 'b) -> 'a -> 'b -> constr -> 'b -(* [iter_constr f c] iters [f] on the immediate subterms of [c]; it is - not recursive and the order with which subterms are processed is - not specified *) - -val iter_constr : (constr -> unit) -> constr -> unit - -(* [iter_constr_with_binders g f n c] iters [f n] on the immediate - subterms of [c]; it carries an extra data [n] (typically a lift - index) which is processed by [g] (which typically add 1 to [n]) at - each binder traversal; it is not recursive and the order with which - subterms are processed is not specified *) - -val iter_constr_with_binders : - ('a -> 'a) -> ('a -> constr -> unit) -> 'a -> constr -> unit - (* [map_constr f c] maps [f] on the immediate subterms of [c]; it is not recursive and the order with which subterms are processed is not specified *) @@ -602,34 +468,14 @@ val map_constr : (constr -> constr) -> constr -> constr val map_constr_with_binders : ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr -(* [map_constr_with_named_binders g f l c] maps [f l] on the immediate - subterms of [c]; it carries an extra data [l] (typically a name - list) which is processed by [g na] (which typically cons [na] to - [l]) at each binder traversal (with name [na]); it is not recursive - and the order with which subterms are processed is not specified *) - -val map_constr_with_named_binders : - (name -> 'a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr - -(* [map_constr_with_binders_left_to_right g f n c] maps [f n] on the - immediate subterms of [c]; it carries an extra data [n] (typically - a lift index) which is processed by [g] (which typically add 1 to - [n]) at each binder traversal; the subterms are processed from left - to right according to the usual representation of the constructions - (this may matter if [f] does a side-effect); it is not recursive *) - -val map_constr_with_binders_left_to_right : - ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr - -(* [map_constr_with_named_binders g f l c] maps [f l] on the immediate - subterms of [c]; it carries an extra data [l] (typically a name - list) which is processed by [g na] (which typically cons [na] to - [l]) at each binder traversal (with name [na]); it is not recursive - and the order with which subterms are processed is not specified *) +(* [iter_constr_with_binders g f n c] iters [f n] on the immediate + subterms of [c]; it carries an extra data [n] (typically a lift + index) which is processed by [g] (which typically add 1 to [n]) at + each binder traversal; it is not recursive and the order with which + subterms are processed is not specified *) -val map_constr_with_full_binders : - (rel_declaration -> 'a -> 'a) -> ('a -> constr -> constr) -> - 'a -> constr -> constr +val iter_constr_with_binders : + ('a -> 'a) -> ('a -> constr -> unit) -> 'a -> constr -> unit (* [compare_constr f c1 c2] compare [c1] and [c2] using [f] to compare the immediate subterms of [c1] of [c2] if needed; Cast's, binders @@ -637,7 +483,7 @@ val map_constr_with_full_binders : val compare_constr : (constr -> constr -> bool) -> constr -> constr -> bool -(*s Hash-consing functions for constr. *) +(*********************************************************************) val hcons_constr: (section_path -> section_path) * diff --git a/kernel/type_errors.ml b/kernel/type_errors.ml index 05b6e2675..169df5904 100644 --- a/kernel/type_errors.ml +++ b/kernel/type_errors.ml @@ -8,7 +8,6 @@ (* $Id$ *) -open Pp open Names open Term open Sign @@ -38,68 +37,69 @@ type guard_error = type type_error = | UnboundRel of int | NotAType of unsafe_judgment - | BadAssumption of constr - | ReferenceVariables of identifier + | BadAssumption of unsafe_judgment + | ReferenceVariables of constr | ElimArity of inductive * constr list * constr * unsafe_judgment * (constr * constr * string) option | CaseNotInductive of unsafe_judgment + | WrongCaseInfo of inductive * case_info | NumberBranches of unsafe_judgment * int | IllFormedBranch of constr * int * constr * constr | Generalization of (name * types) * unsafe_judgment - | ActualType of constr * constr * constr + | ActualType of unsafe_judgment * types | CantApplyBadType of (int * constr * constr) - * unsafe_judgment * unsafe_judgment list - | CantApplyNonFunctional of unsafe_judgment * unsafe_judgment list + * unsafe_judgment * unsafe_judgment array + | CantApplyNonFunctional of unsafe_judgment * unsafe_judgment array | IllFormedRecBody of guard_error * name array * int * constr array | IllTypedRecBody of int * name array * unsafe_judgment array * types array -exception TypeError of path_kind * env * type_error +exception TypeError of env * type_error let nfj {uj_val=c;uj_type=ct} = {uj_val=c;uj_type=nf_betaiota ct} -let error_unbound_rel k env n = - raise (TypeError (k, env, UnboundRel n)) +let error_unbound_rel env n = + raise (TypeError (env, UnboundRel n)) -let error_not_type k env c = - raise (TypeError (k, env, NotAType c)) +let error_not_type env j = + raise (TypeError (env, NotAType j)) -let error_assumption k env c = - raise (TypeError (k, env, BadAssumption c)) +let error_assumption env j = + raise (TypeError (env, BadAssumption j)) -let error_reference_variables k env id = - raise (TypeError (k, env, ReferenceVariables id)) +let error_reference_variables env id = + raise (TypeError (env, ReferenceVariables id)) -let error_elim_arity k env ind aritylst c pj okinds = - raise (TypeError (k, env, ElimArity (ind,aritylst,c,pj,okinds))) +let error_elim_arity env ind aritylst c pj okinds = + raise (TypeError (env, ElimArity (ind,aritylst,c,pj,okinds))) -let error_case_not_inductive k env j = - raise (TypeError (k, env, CaseNotInductive j)) +let error_case_not_inductive env j = + raise (TypeError (env, CaseNotInductive j)) -let error_number_branches k env cj expn = - raise (TypeError (k, env, NumberBranches (nfj cj,expn))) +let error_number_branches env cj expn = + raise (TypeError (env, NumberBranches (nfj cj,expn))) -let error_ill_formed_branch k env c i actty expty = - raise (TypeError (k, env, +let error_ill_formed_branch env c i actty expty = + raise (TypeError (env, IllFormedBranch (c,i,nf_betaiota actty, nf_betaiota expty))) -let error_generalization k env nvar c = - raise (TypeError (k, env, Generalization (nvar,c))) +let error_generalization env nvar c = + raise (TypeError (env, Generalization (nvar,c))) -let error_actual_type k env c actty expty = - raise (TypeError (k, env, ActualType (c,actty,expty))) +let error_actual_type env j expty = + raise (TypeError (env, ActualType (j,expty))) -let error_cant_apply_not_functional k env rator randl = - raise (TypeError (k, env, CantApplyNonFunctional (rator,randl))) +let error_cant_apply_not_functional env rator randl = + raise (TypeError (env, CantApplyNonFunctional (rator,randl))) -let error_cant_apply_bad_type k env t rator randl = - raise(TypeError (k, env, CantApplyBadType (t,rator,randl))) +let error_cant_apply_bad_type env t rator randl = + raise(TypeError (env, CantApplyBadType (t,rator,randl))) -let error_ill_formed_rec_body k env why lna i vdefs = - raise (TypeError (k, env, IllFormedRecBody (why,lna,i,vdefs))) +let error_ill_formed_rec_body env why lna i vdefs = + raise (TypeError (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))) +let error_ill_typed_rec_body env i lna vdefj vargs = + raise (TypeError (env, IllTypedRecBody (i,lna,vdefj,vargs))) diff --git a/kernel/type_errors.mli b/kernel/type_errors.mli index 11729171b..c342ce892 100644 --- a/kernel/type_errors.mli +++ b/kernel/type_errors.mli @@ -9,7 +9,6 @@ (*i $Id$ i*) (*i*) -open Pp open Names open Term open Sign @@ -41,62 +40,63 @@ type guard_error = type type_error = | UnboundRel of int | NotAType of unsafe_judgment - | BadAssumption of constr - | ReferenceVariables of identifier + | BadAssumption of unsafe_judgment + | ReferenceVariables of constr | ElimArity of inductive * constr list * constr * unsafe_judgment * (constr * constr * string) option | CaseNotInductive of unsafe_judgment + | WrongCaseInfo of inductive * case_info | NumberBranches of unsafe_judgment * int | IllFormedBranch of constr * int * constr * constr | Generalization of (name * types) * unsafe_judgment - | ActualType of constr * constr * constr + | ActualType of unsafe_judgment * types | CantApplyBadType of (int * constr * constr) - * unsafe_judgment * unsafe_judgment list - | CantApplyNonFunctional of unsafe_judgment * unsafe_judgment list + * unsafe_judgment * unsafe_judgment array + | CantApplyNonFunctional of unsafe_judgment * unsafe_judgment array | IllFormedRecBody of guard_error * name array * int * constr array | IllTypedRecBody of int * name array * unsafe_judgment array * types array -exception TypeError of path_kind * env * type_error +exception TypeError of env * type_error -val error_unbound_rel : path_kind -> env -> int -> 'a +val error_unbound_rel : env -> int -> 'a -val error_not_type : path_kind -> env -> unsafe_judgment -> 'a +val error_not_type : env -> unsafe_judgment -> 'a -val error_assumption : path_kind -> env -> constr -> 'a +val error_assumption : env -> unsafe_judgment -> 'a -val error_reference_variables : path_kind -> env -> identifier -> 'a +val error_reference_variables : env -> constr -> 'a val error_elim_arity : - path_kind -> env -> inductive -> constr list -> constr + env -> inductive -> constr list -> constr -> unsafe_judgment -> (constr * constr * string) option -> 'a val error_case_not_inductive : - path_kind -> env -> unsafe_judgment -> 'a + env -> unsafe_judgment -> 'a val error_number_branches : - path_kind -> env -> unsafe_judgment -> int -> 'a + env -> unsafe_judgment -> int -> 'a val error_ill_formed_branch : - path_kind -> env -> constr -> int -> constr -> constr -> 'a + env -> constr -> int -> constr -> constr -> 'a val error_generalization : - path_kind -> env -> name * types -> unsafe_judgment -> 'a + env -> name * types -> unsafe_judgment -> 'a val error_actual_type : - path_kind -> env -> constr -> constr -> constr -> 'a + env -> unsafe_judgment -> types -> 'a val error_cant_apply_not_functional : - path_kind -> env -> unsafe_judgment -> unsafe_judgment list -> 'a + env -> unsafe_judgment -> unsafe_judgment array -> 'a val error_cant_apply_bad_type : - path_kind -> env -> int * constr * constr -> - unsafe_judgment -> unsafe_judgment list -> 'a + env -> int * constr * constr -> + unsafe_judgment -> unsafe_judgment array -> 'a val error_ill_formed_rec_body : - path_kind -> env -> guard_error -> name array -> int -> constr array -> 'a + env -> guard_error -> name array -> int -> constr array -> 'a val error_ill_typed_rec_body : - path_kind -> env -> int -> name array -> unsafe_judgment array + env -> int -> name array -> unsafe_judgment array -> types array -> 'a diff --git a/kernel/typeops.ml b/kernel/typeops.ml index e8e8f35b9..a2c6fe686 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -8,7 +8,6 @@ (* $Id$ *) -open Pp open Util open Names open Univ @@ -18,48 +17,42 @@ open Sign open Environ open Reduction open Inductive - open Type_errors -let make_judge v tj = - { uj_val = v; - uj_type = tj } - -let j_val j = j.uj_val -(* This should be a type intended to be assumed *) -let assumption_of_judgment env sigma j = - match kind_of_term(whd_betadeltaiota env sigma (body_of_type j.uj_type)) with - | IsSort s -> j.uj_val - | _ -> error_assumption CCI env j.uj_val +(* This should be a type (a priori without intension to be an assumption) *) +let type_judgment env j = + match kind_of_term(whd_betadeltaiota env (body_of_type j.uj_type)) with + | Sort s -> {utj_val = j.uj_val; utj_type = s } + | _ -> error_not_type env j + +(* This should be a type intended to be assumed. The error message is *) +(* not as useful as for [type_judgment]. *) +let assumption_of_judgment env j = + try (type_judgment env j).utj_val + with TypeError _ -> + error_assumption env j (* let aojkey = Profile.declare_profile "assumption_of_judgment";; -let assumption_of_judgment env sigma j - = Profile.profile3 aojkey assumption_of_judgment env sigma j;; +let assumption_of_judgment env j + = Profile.profile2 aojkey assumption_of_judgment env j;; *) -(* This should be a type (a priori without intension to be an assumption) *) -let type_judgment env sigma j = - match kind_of_term(whd_betadeltaiota env sigma (body_of_type j.uj_type)) with - | IsSort s -> {utj_val = j.uj_val; utj_type = s } - | _ -> error_not_type CCI env j - - (************************************************) (* Incremental typing rules: builds a typing judgement given the *) (* judgements for the subterms. *) -(* Type of sorts *) +(*s Type of sorts *) (* Prop and Set *) let judge_of_prop = - { uj_val = mkSort prop; + { uj_val = mkProp; uj_type = mkSort type_0 } let judge_of_set = - { uj_val = mkSort spec; + { uj_val = mkSet; uj_type = mkSort type_0 } let judge_of_prop_contents = function @@ -70,92 +63,84 @@ let judge_of_prop_contents = function let judge_of_type u = let (uu,c) = super u in - { uj_val = mkSort (Type u); - uj_type = mkSort (Type uu) }, + { uj_val = mkType u; + uj_type = mkType uu }, c -(* -let type_of_sort c = - match kind_of_term c with - | IsSort (Type u) -> let (uu,cst) = super u in Type uu, cst - | IsSort (Prop _) -> Type prop_univ, Constraint.empty - | _ -> invalid_arg "type_of_sort" -*) - -(* Type of a de Bruijn index. *) +(*s Type of a de Bruijn index. *) -let relative env n = +let judge_of_relative env n = try - let (_,typ) = lookup_rel_type n env in + let (_,_,typ) = lookup_rel n env in { uj_val = mkRel n; uj_type = type_app (lift n) typ } with Not_found -> - error_unbound_rel CCI env n + error_unbound_rel env n (* -let relativekey = Profile.declare_profile "relative";; -let relative env sigma n = Profile.profile3 relativekey relative env sigma n;; +let relativekey = Profile.declare_profile "judge_of_relative";; +let judge_of_relative env n = + Profile.profile2 relativekey judge_of_relative env n;; *) (* Management of context of variables. *) -(* Checks if a context of variable is included in another one. *) -(* -let rec hyps_inclusion env sigma sign1 sign2 = - if sign1 = empty_named_context then true - else - let (id1,ty1) = hd_sign sign1 in - let rec search sign2 = - if sign2 = empty_named_context then false - else - let (id2,ty2) = hd_sign sign2 in - if id1 = id2 then - (is_conv env sigma (body_of_type ty1) (body_of_type ty2)) - & - hyps_inclusion env sigma (tl_sign sign1) (tl_sign sign2) - else - search (tl_sign sign2) - in - search sign2 -*) +(* Checks if a context of variable can be instanciated by the + variables of the current env *) +(* TODO: check order? *) +let rec check_hyps_inclusion env sign = + let env_sign = named_context env in + Sign.fold_named_context + (fun (id,_,ty1) () -> + let (_,_,ty2) = Sign.lookup_named id env_sign in + if not (eq_constr ty2 ty1) then + error "types do not match") + sign + () + + +let check_args env c hyps = + let hyps' = named_context env in + try check_hyps_inclusion env hyps + with UserError _ | Not_found -> + error_reference_variables env c + (* Checks if the given context of variables [hyps] is included in the current context of [env]. *) (* -let check_hyps id env sigma hyps = +let check_hyps id env hyps = let hyps' = named_context env in - if not (hyps_inclusion env sigma hyps hyps') then - error_reference_variables CCI env id + if not (hyps_inclusion env hyps hyps') then + error_reference_variables env id *) (* Instantiation of terms on real arguments. *) -let type_of_constant = Instantiate.constant_type +(* Type of variables *) +let judge_of_variable env id = + try + let (_,_,ty) = lookup_named id env in + make_judge (mkVar id) ty + with Not_found -> + error ("execute: variable " ^ (string_of_id id) ^ " not defined") + +(* Type of constants *) +let judge_of_constant env cst = + let constr = mkConst cst in + let _ = + let ce = lookup_constant cst env in + check_args env constr ce.const_hyps in + make_judge constr (constant_type env cst) (* let tockey = Profile.declare_profile "type_of_constant";; -let type_of_constant env sigma c - = Profile.profile3 tockey type_of_constant env sigma c;; +let type_of_constant env c + = Profile.profile3 tockey type_of_constant env c;; *) -(* Type of an existential variable. Not used in kernel. *) -let type_of_existential env sigma ev = - Instantiate.existential_type sigma ev - - (* Type of a lambda-abstraction. *) -let sort_of_product domsort rangsort g = - match rangsort with - (* Product rule (s,Prop,Prop) *) - | Prop _ -> rangsort, Constraint.empty - | Type u2 -> - (match domsort with - (* Product rule (Prop,Type_i,Type_i) *) - | Prop _ -> rangsort, Constraint.empty - (* Product rule (Type_i,Type_i,Type_i) *) - | Type u1 -> let (u12,cst) = sup u1 u2 g in Type u12, cst) - -(* [abs_rel env sigma name var j] implements the rule +(* [judge_of_abstraction env name var j] implements the rule env, name:typ |- j.uj_val:j.uj_type env, |- (name:typ)j.uj_type : s ----------------------------------------------------------------------- @@ -165,788 +150,335 @@ let sort_of_product domsort rangsort g = and no upper constraint exists on the sort $s$, we don't need to compute $s$ *) -let abs_rel env sigma name var j = - { uj_val = mkLambda (name, var, j.uj_val); - uj_type = mkProd (name, var, j.uj_type) }, - Constraint.empty +let judge_of_abstraction env name var j = + { uj_val = mkLambda (name, var.utj_val, j.uj_val); + uj_type = mkProd (name, var.utj_val, j.uj_type) } + +(* Type of let-in. *) -let judge_of_letin env sigma name defj j = +let judge_of_letin env name defj j = let v = match kind_of_term defj.uj_val with - IsCast(c,t) -> c + Cast(c,t) -> c | _ -> defj.uj_val in - ({ uj_val = mkLetIn (name, v, defj.uj_type, j.uj_val) ; - uj_type = type_app (subst1 v) j.uj_type }, - Constraint.empty) - -(* [gen_rel env sigma name (typ1,s1) (typ2,s2)] implements the rule - - env |- typ1:s1 env, name:typ |- typ2 : s2 - ------------------------------------------------------------------------- - s' >= (s1,s2), env |- (name:typ)j.uj_val : s' - - where j.uj_type is convertible to a sort s2 -*) + { uj_val = mkLetIn (name, v, defj.uj_type, j.uj_val) ; + uj_type = type_app (subst1 v) j.uj_type } (* Type of an application. *) -let apply_rel_list env sigma nocheck argjl funj = +let judge_of_apply env funj argjv = let rec apply_rec n typ cst = function | [] -> - { uj_val = applist (j_val funj, List.map j_val argjl); - uj_type = type_app (fun _ -> typ) funj.uj_type }, + { uj_val = mkApp (j_val funj, Array.map j_val argjv); + uj_type = typ }, cst | hj::restjl -> - 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 - (try - let c = conv_leq env sigma (body_of_type hj.uj_type) c1 in - let cst' = Constraint.union cst c in - apply_rec (n+1) (subst1 hj.uj_val c2) cst' restjl - with NotConvertible -> - error_cant_apply_bad_type CCI env - (n,c1,body_of_type hj.uj_type) - funj argjl) + (match kind_of_term (whd_betadeltaiota env typ) with + | Prod (_,c1,c2) -> + (try + let c = conv_leq env hj.uj_type c1 in + let cst' = Constraint.union cst c in + apply_rec (n+1) (subst1 hj.uj_val c2) cst' restjl + with NotConvertible -> + error_cant_apply_bad_type env + (n,c1,body_of_type hj.uj_type) + funj argjv) | _ -> - error_cant_apply_not_functional CCI env funj argjl + error_cant_apply_not_functional env funj argjv) in - apply_rec 1 (body_of_type funj.uj_type) Constraint.empty argjl + apply_rec 1 + funj.uj_type + Constraint.empty + (Array.to_list argjv) (* -let applykey = Profile.declare_profile "apply_rel_list";; -let apply_rel_list env sigma nocheck argjl funj - = Profile.profile5 applykey apply_rel_list env sigma nocheck argjl funj;; +let applykey = Profile.declare_profile "judge_of_apply";; +let judge_of_apply env nocheck funj argjl + = Profile.profile5 applykey judge_of_apply env nocheck funj argjl;; *) + (* Type of product *) -let gen_rel env sigma name t1 t2 = + +let sort_of_product domsort rangsort g = + match rangsort with + (* Product rule (s,Prop,Prop) *) + | Prop _ -> rangsort, Constraint.empty + | Type u2 -> + (match domsort with + (* Product rule (Prop,Type_i,Type_i) *) + | Prop _ -> rangsort, Constraint.empty + (* Product rule (Type_i,Type_i,Type_i) *) + | Type u1 -> let (u12,cst) = sup u1 u2 g in Type u12, cst) + +(* [judge_of_product env name (typ1,s1) (typ2,s2)] implements the rule + + env |- typ1:s1 env, name:typ1 |- typ2 : s2 + ------------------------------------------------------------------------- + s' >= (s1,s2), env |- (name:typ)j.uj_val : s' + + where j.uj_type is convertible to a sort s2 +*) +let judge_of_product env name t1 t2 = let (s,g) = sort_of_product t1.utj_type t2.utj_type (universes env) in { uj_val = mkProd (name, t1.utj_val, t2.utj_val); uj_type = mkSort s }, g -(* [cast_rel env sigma (typ1,s1) j] implements the rule +(* Type of a type cast *) + +(* [judge_of_cast env (c,typ1) (typ2,s)] implements the rule - env, sigma |- cj.uj_val:cj.uj_type cst, env, sigma |- cj.uj_type = t + env |- c:typ1 env |- typ2:s env |- typ1 <= typ2 --------------------------------------------------------------------- - cst, env, sigma |- cj.uj_val:t + env |- c:typ2 *) -(* Type of casts *) -let cast_rel env sigma cj t = +let judge_of_cast env cj tj = try - let cst = conv_leq env sigma (body_of_type cj.uj_type) t in + let cst = conv_leq env cj.uj_type tj.utj_val in { uj_val = j_val cj; - uj_type = t }, + uj_type = tj.utj_val }, cst with NotConvertible -> - error_actual_type CCI env cj.uj_val (body_of_type cj.uj_type) t + error_actual_type env cj tj.utj_val (* Inductive types. *) -let type_of_inductive env sigma i = - (* TODO: check args *) - mis_arity (lookup_mind_specif i env) +let judge_of_inductive env i = + let constr = mkInd i in + let _ = + let (sp,_) = i in + let mib = lookup_mind sp env in + check_args env constr mib.mind_hyps in + make_judge constr (type_of_inductive env i) (* -let toikey = Profile.declare_profile "type_of_inductive";; -let type_of_inductive env sigma i - = Profile.profile3 toikey type_of_inductive env sigma i;; +let toikey = Profile.declare_profile "judge_of_inductive";; +let judge_of_inductive env i + = Profile.profile2 toikey judge_of_inductive env i;; *) (* Constructors. *) -let type_of_constructor env sigma cstr = - mis_constructor_type - (index_of_constructor cstr) - (lookup_mind_specif (inductive_of_constructor cstr) env) +let judge_of_constructor env c = + let constr = mkConstruct c in + let _ = + let ((sp,_),_) = c in + let mib = lookup_mind sp env in + check_args env constr mib.mind_hyps in + make_judge constr (type_of_constructor env c) (* -let tockey = Profile.declare_profile "type_of_constructor";; -let type_of_constructor env sigma cstr - = Profile.profile3 tockey type_of_constructor env sigma cstr;; +let tockey = Profile.declare_profile "judge_of_constructor";; +let judge_of_constructor env cstr + = Profile.profile2 tockey judge_of_constructor env cstr;; *) (* Case. *) -let rec mysort_of_arity env sigma c = - 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_arity env sigma kp && not (is_info_arity env sigma ki) then - "non-informative objects may not construct informative ones." - else - 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" - -exception Arity of (constr * constr * string) option - -let is_correct_arity env sigma kelim (c,pj) indf t = - let rec srec (pt,t) u = - 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') -> - let univ = - try conv env sigma a1 a1' - with NotConvertible -> raise (Arity None) in - srec (a2,a2') (Constraint.union u univ) - | IsProd (_,a1,a2), _ -> - let k = whd_betadeltaiota env sigma a2 in - let ksort = match kind_of_term k with - | IsSort s -> family_of_sort s - | _ -> raise (Arity None) in - let ind = build_dependent_inductive indf in - let univ = - try conv env sigma a1 ind - with NotConvertible -> raise (Arity None) in - if List.exists ((=) ksort) kelim then - ((true,k), Constraint.union u univ) - else - raise (Arity (Some(k,t',error_elim_expln env sigma k t'))) - | k, IsProd (_,_,_) -> - raise (Arity None) - | k, ki -> - let ksort = match k with - | IsSort s -> family_of_sort s - | _ -> raise (Arity None) in - if List.exists ((=) ksort) kelim then - (false, pt'), u - else - raise (Arity (Some(pt',t',error_elim_expln env sigma pt' t'))) - in - try srec (pj.uj_type,t) Constraint.empty - with Arity kinds -> - let create_sort = function - | InProp -> prop - | InSet -> spec - | InType -> Type (Univ.new_univ ()) in - let listarity = - (List.map (fun s -> make_arity env true indf (create_sort s)) kelim) - @(List.map (fun s -> make_arity env false indf (create_sort s)) kelim) - in - let ind = mis_inductive (fst (dest_ind_family indf)) in - error_elim_arity CCI env ind listarity c pj kinds - - -let find_case_dep_nparams env sigma (c,pj) (IndFamily (mis,_) as indf) = - let kelim = mis_kelim mis in - let arsign,s = get_arity indf in - let glob_t = it_mkProd_or_LetIn (mkSort s) arsign in - let ((dep,_),univ) = - is_correct_arity env sigma kelim (c,pj) indf glob_t in - (dep,univ) - -(* type_case_branches type un <p>Case c of ... end - IndType (indf,realargs) = type de c - pt = sorte de p - type_case_branches retourne (lb, lr); lb est le vecteur des types - attendus dans les branches du Case; lr est le type attendu du resultat - *) - -let type_case_branches env sigma (IndType (indf,realargs)) pj c = - let p = pj.uj_val in - let (dep,univ) = find_case_dep_nparams env sigma (c,pj) indf in - let constructs = get_constructors indf in - let lc = Array.map (build_branch_type env dep p) constructs in - if dep then - (lc, beta_applist (p,(realargs@[c])), univ) - else - (lc, beta_applist (p,realargs), univ) - -let check_branches_message env sigma cj (explft,lft) = - let expn = Array.length explft and n = Array.length lft in - if n<>expn then error_number_branches CCI env cj expn; - let univ = ref Constraint.empty in - (for i = 0 to n-1 do - try - univ := Constraint.union !univ - (conv_leq env sigma lft.(i) (explft.(i))) - with NotConvertible -> - error_ill_formed_branch CCI env cj.uj_val i lft.(i) explft.(i) - done; - !univ) - -let nparams_of (IndType (IndFamily (mis,_),_)) = mis_nparams mis - -let judge_of_case env sigma (np,_ as ci) pj cj lfj = - let lft = Array.map (fun j -> body_of_type j.uj_type) lfj in +let check_branch_types env cj (lft,explft) = + try conv_leq_vecti env lft explft + with + NotConvertibleVect i -> + error_ill_formed_branch env cj.uj_val i lft.(i) explft.(i) + | Invalid_argument _ -> + error_number_branches env cj (Array.length explft) + +let judge_of_case env ci pj cj lfj = let indspec = - try find_rectype env sigma (body_of_type cj.uj_type) - with Induc -> error_case_not_inductive CCI env cj in - if np <> nparams_of indspec then - anomaly "judge_of_case: wrong parameters number"; - let (bty,rslty,univ) = type_case_branches env sigma indspec pj cj.uj_val in - let kind = mysort_of_arity env sigma (body_of_type pj.uj_type) in - let univ' = check_branches_message env sigma cj (bty,lft) in - ({ uj_val = mkMutCase (ci, (nf_betaiota pj.uj_val), cj.uj_val, Array.map j_val lfj); + try find_rectype env cj.uj_type + with Induc -> error_case_not_inductive env cj in + let _ = check_case_info env (fst indspec) ci in + let (bty,rslty,univ) = + type_case_branches env indspec pj cj.uj_val in + let (_,kind) = dest_arity env pj.uj_type in + let lft = Array.map j_type lfj in + let univ' = check_branch_types env cj (lft,bty) in + ({ uj_val = mkCase (ci, nf_betaiota pj.uj_val, cj.uj_val, + Array.map j_val lfj); uj_type = rslty }, Constraint.union univ univ') (* -let tocasekey = Profile.declare_profile "type_of_case";; -let type_of_case env sigma ci pj cj lfj - = Profile.profile6 tocasekey type_of_case env sigma ci pj cj lfj;; +let tocasekey = Profile.declare_profile "judge_of_case";; +let judge_of_case env ci pj cj lfj + = Profile.profile6 tocasekey judge_of_case env ci pj cj lfj;; *) (* Fixpoints. *) -(* 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 *) - -(* A powerful notion of subterm *) - -let find_sorted_assoc p = - let rec findrec = function - | (a,ta)::l -> - if a < p then findrec l else if a = p then ta else raise Not_found - | _ -> raise Not_found - in - findrec - -let map_lift_fst_n m = List.map (function (n,t)->(n+m,t)) -let map_lift_fst = map_lift_fst_n 1 - -let rec instantiate_recarg sp lrc ra = - match ra with - | Mrec(j) -> Imbr((sp,j),lrc) - | Imbr(ind_sp,l) -> Imbr(ind_sp, List.map (instantiate_recarg sp lrc) l) - | Norec -> Norec - | Param(k) -> List.nth lrc k - -(* To each inductive definition corresponds an array describing the - structure of recursive arguments for each constructor, we call it - the recursive spec of the type (it has type recargs vect). For - checking the guard, we start from the decreasing argument (Rel n) - with its recursive spec. During checking the guardness condition, - we collect patterns variables corresponding to subterms of n, each - of them with its recursive spec. They are organised in a list lst - of type (int * recargs) list which is sorted with respect to the - first argument. -*) - -(* - f is a function of type - env -> int -> (int * recargs) list -> constr -> 'a - - c is a branch of an inductive definition corresponding to the spec - lrec. mind_recvec is the recursive spec of the inductive - definition of the decreasing argument n. - - check_term env mind_recvec f n lst (lrec,c) will pass the lambdas - of c corresponding to pattern variables and collect possibly new - subterms variables and apply f to the body of the branch with the - correct env and decreasing arg. -*) - -let check_term env mind_recvec f = - let rec crec env n lst (lrec,c) = - let c' = strip_outer_cast c in - match lrec, kind_of_term c' with - (ra::lr,IsLambda (x,a,b)) -> - let lst' = map_lift_fst lst - and env' = push_rel_assum (x,a) env - and n'=n+1 - in begin match ra with - Mrec(i) -> crec env' n' ((1,mind_recvec.(i))::lst') (lr,b) - | Imbr((sp,i) as ind_sp,lrc) -> - let sprecargs = - mis_recargs (lookup_mind_specif ind_sp env) in - let lc = Array.map - (List.map (instantiate_recarg sp lrc)) sprecargs.(i) - in crec env' n' ((1,lc)::lst') (lr,b) - | _ -> crec env' n' lst' (lr,b) end - | (_,IsLetIn (x,c,a,b)) -> - let env' = push_rel_def (x,c,a) env in - crec env' (n+1) (map_lift_fst lst) (lrec,(subst1 c b)) - | (_,_) -> f env n lst c' - in crec env - -(* c is supposed to be in beta-delta-iota head normal form *) - -let is_inst_var k c = - match kind_of_term (fst (decomp_app c)) with - | IsRel n -> n=k - | _ -> false - -(* - is_subterm_specif env sigma lcx mind_recvec n lst c - - n is the principal arg and has recursive spec lcx, lst is the list - of subterms of n with spec. is_subterm_specif should test if c is - a subterm of n and fails with Not_found if not. In case it is, it - should send its recursive specification. This recursive spec - should be the same size as the number of constructors of the type - of c. A problem occurs when c is built by contradiction. In that - case no spec is given. - -*) -let is_subterm_specif env sigma lcx mind_recvec = - let rec crec env n lst c = - let f,l = whd_betadeltaiota_stack env sigma c in - match kind_of_term f with - | IsRel k -> Some (find_sorted_assoc k lst) - - | IsMutCase ( _,_,c,br) -> - if Array.length br = 0 then None - - else - let def = Array.create (Array.length br) [] - in let lcv = - (try - if is_inst_var n c then lcx - else match crec env n lst c with Some lr -> lr | None -> def - with Not_found -> def) - 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 let stl0 = stl.(0) in - if array_for_all (fun st -> st=stl0) stl then stl0 - else None - - | IsFix ((recindxs,i),(_,typarray,bodies as recdef)) -> - let nbfix = Array.length typarray in - let decrArg = recindxs.(i) in - let theBody = bodies.(i) in - let sign,strippedBody = decompose_lam_n_assum (decrArg+1) theBody in - let nbOfAbst = nbfix+decrArg+1 in -(* when proving that the fixpoint f(x)=e is less than n, it is enough - to prove that e is less than n assuming f is less than n - furthermore when f is applied to a term which is strictly less than - n, one may assume that x itself is strictly less than n -*) - let newlst = - let lst' = (nbOfAbst,lcx) :: (map_lift_fst_n nbOfAbst lst) in - if List.length l < (decrArg+1) then lst' - else let theDecrArg = List.nth l decrArg in - try - match crec env n lst theDecrArg with - (Some recArgsDecrArg) -> (1,recArgsDecrArg) :: lst' - | None -> lst' - with Not_found -> lst' - in let env' = push_rec_types recdef env in - let env'' = push_rels sign env' in - crec env'' (n+nbOfAbst) newlst strippedBody - - | IsLambda (x,a,b) when l=[] -> - let lst' = map_lift_fst lst in - crec (push_rel_assum (x, a) env) (n+1) lst' b - - (*** Experimental change *************************) - | IsMeta _ -> None - | _ -> raise Not_found - in - crec env - -let spec_subterm_strict env sigma lcx mind_recvec n lst c nb = - try match is_subterm_specif env sigma lcx mind_recvec n lst c - with Some lr -> lr | None -> Array.create nb [] - with Not_found -> Array.create nb [] +(* Checks the type of a general (co)fixpoint, i.e. without checking *) +(* the specific guard condition. *) -let spec_subterm_large env sigma lcx mind_recvec n lst c nb = - if is_inst_var n c then lcx - else spec_subterm_strict env sigma lcx mind_recvec n lst c nb - - -let is_subterm env sigma lcx mind_recvec n lst c = - try - let _ = is_subterm_specif env sigma lcx mind_recvec n lst c in true - 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 = - (* 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 env n def = - match kind_of_term (strip_outer_cast def) with - | IsLambda (x,a,b) -> - if noccur_with_meta n nfi a then - let env' = push_rel_assum (x, a) env in - if n = k+1 then (env', lift 1 a, b) - else check_occur env' (n+1) b - else - anomaly "check_subterm_rec_meta: Bad occurrence of recursive call" - | _ -> raise (FixGuardError NotEnoughAbstractionInFixBody) in - let (env',c,d) = check_occur env 1 def in - let ((sp,tyi) as mind, largs) = - try find_inductive 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; - lst = a mapping var |-> recargs - t = the term to be checked - *) - let rec check_rec_call env n lst t = - (* n gives the index of the recursive variable *) - (noccur_with_meta (n+k+1) nfi t) or - (* no recursive call in the term *) - (let f,l = whd_betaiotazeta_stack 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 *) - let np = vectn.(glob) in (* the decreasing arg of the rec call *) - if List.length l > np then - (match list_chop np l with - (la,(z::lrest)) -> - if (is_subterm env sigma lcx mind_recvec n lst z) - then List.for_all (check_rec_call env n lst) (la@lrest) - else raise (FixGuardError RecursionOnIllegalTerm) - | _ -> assert false) - else raise (FixGuardError NotEnoughArgumentsForFixCall) - else List.for_all (check_rec_call env n lst) l - - | IsMutCase (ci,p,c_0,lrest) -> - let lc = spec_subterm_large env sigma lcx mind_recvec n lst c_0 - (Array.length lrest) - in - (array_for_all2 - (fun c0 a -> - check_term env mind_recvec check_rec_call n lst (c0,a)) - lc lrest) - && (List.for_all (check_rec_call env n lst) (c_0::p::l)) - - (* Enables to traverse Fixpoint definitions in a more intelligent - way, ie, the rule : - - if - g = Fix g/1 := [y1:T1]...[yp:Tp]e & - - f is guarded with respect to the set of pattern variables S - in a1 ... am & - - f is guarded with respect to the set of pattern variables S - in T1 ... Tp & - - ap is a sub-term of the formal argument of f & - - f is guarded with respect to the set of pattern variables S+{yp} - in e - then f is guarded with respect to S in (g a1 ... am). - - Eduardo 7/9/98 *) - - | IsFix ((recindxs,i),(_,typarray,bodies as recdef)) -> - (List.for_all (check_rec_call env n lst) l) && - (array_for_all (check_rec_call env n lst) typarray) && - let nbfix = Array.length typarray in - let decrArg = recindxs.(i) - and env' = push_rec_types recdef env - and n' = n+nbfix - and lst' = map_lift_fst_n nbfix lst - in - if (List.length l < (decrArg+1)) then - array_for_all (check_rec_call env' n' lst') bodies - else - let theDecrArg = List.nth l decrArg in - (try - match - is_subterm_specif env sigma lcx mind_recvec n lst theDecrArg - with - Some recArgsDecrArg -> - let theBody = bodies.(i) in - check_rec_call_fix_body - env' n' lst' (decrArg+1) recArgsDecrArg theBody - | None -> - array_for_all (check_rec_call env' n' lst') bodies - with Not_found -> - array_for_all (check_rec_call env' n' lst') bodies) - - | IsCast (a,b) -> - (check_rec_call env n lst a) && - (check_rec_call env n lst b) && - (List.for_all (check_rec_call env n lst) l) - - | IsLambda (x,a,b) -> - (check_rec_call env n lst a) && - (check_rec_call (push_rel_assum (x, a) env) - (n+1) (map_lift_fst lst) b) && - (List.for_all (check_rec_call env n lst) l) - - | IsProd (x,a,b) -> - (check_rec_call env n lst a) && - (check_rec_call (push_rel_assum (x, a) env) - (n+1) (map_lift_fst lst) b) && - (List.for_all (check_rec_call env n lst) l) - - | IsLetIn (x,a,b,c) -> - anomaly "check_rec_call: should have been reduced" - - | IsMutInd _ -> - (List.for_all (check_rec_call env n lst) l) - - | IsMutConstruct _ -> - (List.for_all (check_rec_call env n lst) l) - - | IsConst sp -> - (try - (List.for_all (check_rec_call env n lst) l) - with (FixGuardError _ ) as e - -> if evaluable_constant env sp then - check_rec_call env n lst (whd_betadeltaiota env sigma t) - else raise e) - - | IsApp (f,la) -> - (check_rec_call env n lst f) && - (array_for_all (check_rec_call env n lst) la) && - (List.for_all (check_rec_call env n lst) l) - - | IsCoFix (i,(_,typarray,bodies as recdef)) -> - let nbfix = Array.length typarray in - let env' = push_rec_types recdef env in - (array_for_all (check_rec_call env n lst) typarray) && - (List.for_all (check_rec_call env n lst) l) && - (array_for_all - (check_rec_call env' (n+nbfix) (map_lift_fst_n nbfix lst)) - bodies) - - | IsEvar (_,la) -> - (array_for_all (check_rec_call env n lst) la) && - (List.for_all (check_rec_call env n lst) l) - - | IsMeta _ -> true - - | IsVar _ | IsSort _ -> List.for_all (check_rec_call env n lst) l - ) - - and check_rec_call_fix_body env n lst decr recArgsDecrArg body = - if decr = 0 then - check_rec_call env n ((1,recArgsDecrArg)::lst) body - else - match kind_of_term body with - | IsLambda (x,a,b) -> - (check_rec_call env n lst a) & - (check_rec_call_fix_body - (push_rel_assum (x, a) env) (n+1) - (map_lift_fst lst) (decr-1) recArgsDecrArg b) - | _ -> anomaly "Not enough abstractions in fix body" - - in - check_rec_call env' 1 [] d) - -(* vargs is supposed to be built from A1;..Ak;[f1]..[fk][|d1;..;dk|] -and vdeft is [|t1;..;tk|] such that f1:A1,..,fk:Ak |- di:ti -nvect is [|n1;..;nk|] which gives for each recursive definition -the inductive-decreasing index -the function checks the convertibility of ti with Ai *) - -let check_fix env sigma ((nvect,bodynum),(names,types,bodies as recdef)) = - let nbfix = Array.length bodies in - if nbfix = 0 - or Array.length nvect <> nbfix - or Array.length types <> nbfix - or Array.length names <> nbfix - or bodynum < 0 - or bodynum >= nbfix - then anomaly "Ill-formed fix term"; - for i = 0 to nbfix - 1 do - let fixenv = push_rec_types recdef env in - try - let _ = check_subterm_rec_meta fixenv sigma nvect nvect.(i) bodies.(i) - in () - with FixGuardError err -> - error_ill_formed_rec_body CCI fixenv err names i bodies - done - -(* -let cfkey = Profile.declare_profile "check_fix";; -let check_fix env sigma fix = Profile.profile3 cfkey check_fix env sigma fix;; -*) - -(* Co-fixpoints. *) - -exception CoFixGuardError of guard_error - -let check_guard_rec_meta env sigma nbfix def deftype = - let rec codomain_is_coind env c = - let b = whd_betadeltaiota env sigma (strip_outer_cast c) in - match kind_of_term b with - | IsProd (x,a,b) -> - codomain_is_coind (push_rel_assum (x, a) env) b - | _ -> - try - find_coinductive env sigma b - with Induc -> - raise (CoFixGuardError (CodomainNotInductiveType b)) - in - let (mind, _) = codomain_is_coind env deftype in - let (sp,tyi) = mind in - let lvlra = mis_recargs (lookup_mind_specif mind env) in - let vlra = lvlra.(tyi) in - let rec check_rec_call env alreadygrd n vlra t = - if noccur_with_meta n nbfix t then - true - else - let c,args = whd_betadeltaiota_stack env sigma t in - match kind_of_term c with - | IsMeta _ -> true - - | IsRel p -> - if n <= p && p < n+nbfix then - (* recursive call *) - if alreadygrd then - if List.for_all (noccur_with_meta n nbfix) args then - true - else - raise (CoFixGuardError NestedRecursiveOccurrences) - else - raise (CoFixGuardError (UnguardedRecursiveCall t)) - else - error "check_guard_rec_meta: ???" (* ??? *) - - | IsMutConstruct (_,i as cstr_sp) -> - let lra =vlra.(i-1) in - let mI = inductive_of_constructor cstr_sp in - let mis = lookup_mind_specif mI env in - let _,realargs = list_chop (mis_nparams mis) args in - let rec process_args_of_constr l lra = - match l with - | [] -> true - | t::lr -> - (match lra with - | [] -> - anomalylabstrm "check_guard_rec_meta" - [< 'sTR "a constructor with an empty list"; - 'sTR "of recargs is being applied" >] - | (Mrec i)::lrar -> - let newvlra = lvlra.(i) in - (check_rec_call env true n newvlra t) && - (process_args_of_constr lr lrar) - - | (Imbr((sp,i) as ind_sp,lrc)::lrar) -> - let mis = lookup_mind_specif ind_sp env in - let sprecargs = mis_recargs mis in - let lc = (Array.map - (List.map - (instantiate_recarg sp lrc)) - sprecargs.(i)) - in (check_rec_call env true n lc t) & - (process_args_of_constr lr lrar) - - | _::lrar -> - if (noccur_with_meta n nbfix t) - then (process_args_of_constr lr lrar) - else raise (CoFixGuardError - (RecCallInNonRecArgOfConstructor t))) - in (process_args_of_constr realargs lra) - - - | IsLambda (x,a,b) -> - assert (args = []); - if (noccur_with_meta n nbfix a) then - check_rec_call (push_rel_assum (x, a) env) - alreadygrd (n+1) vlra b - else - raise (CoFixGuardError (RecCallInTypeOfAbstraction t)) - - | IsCoFix (j,(_,varit,vdefs as recdef)) -> - if (List.for_all (noccur_with_meta n nbfix) args) - then - let nbfix = Array.length vdefs in - if (array_for_all (noccur_with_meta n nbfix) varit) then - let env' = push_rec_types recdef env in - (array_for_all - (check_rec_call env' alreadygrd (n+1) vlra) vdefs) - && - (List.for_all (check_rec_call env alreadygrd (n+1) vlra) args) - else - raise (CoFixGuardError (RecCallInTypeOfDef c)) - else - raise (CoFixGuardError (UnguardedRecursiveCall c)) - - | IsMutCase (_,p,tm,vrest) -> - if (noccur_with_meta n nbfix p) then - if (noccur_with_meta n nbfix tm) then - if (List.for_all (noccur_with_meta n nbfix) args) then - (array_for_all (check_rec_call env alreadygrd n vlra) vrest) - else - raise (CoFixGuardError (RecCallInCaseFun c)) - else - raise (CoFixGuardError (RecCallInCaseArg c)) - else - raise (CoFixGuardError (RecCallInCasePred c)) - - | _ -> raise (CoFixGuardError NotGuardedForm) - - in - check_rec_call env false 1 vlra def - -(* The function which checks that the whole block of definitions - satisfies the guarded condition *) - -let check_cofix env sigma (bodynum,(names,types,bodies as recdef)) = - let nbfix = Array.length bodies in - for i = 0 to nbfix-1 do - let fixenv = push_rec_types recdef env in - try - let _ = check_guard_rec_meta fixenv sigma nbfix bodies.(i) types.(i) - in () - with CoFixGuardError err -> - error_ill_formed_rec_body CCI fixenv err names i bodies - done - -(* Checks the type of a (co)fixpoint. - Fix and CoFix are typed the same way; only the guard condition differs. *) - -exception IllBranch of int - -let type_fixpoint env sigma lna lar vdefj = +let type_fixpoint env lna lar vdefj = let lt = Array.length vdefj in assert (Array.length lar = lt); try - conv_forall2_i - (fun i env sigma def ar -> - try conv_leq env sigma def (lift lt ar) - with NotConvertible -> raise (IllBranch i)) - env sigma + conv_leq_vecti env (Array.map (fun j -> body_of_type j.uj_type) vdefj) - (Array.map body_of_type lar) - with IllBranch i -> - error_ill_typed_rec_body CCI env i lna vdefj lar - - -(* A function which checks that a term well typed verifies both - syntaxic conditions *) - -let control_only_guard env sigma = - let rec control_rec c = match kind_of_term c with - | IsRel _ | IsVar _ -> () - | IsSort _ | IsMeta _ -> () - | IsMutInd _ -> () - | IsMutConstruct _ -> () - | IsConst _ -> () - | 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 - | IsEvar (_,cl) -> Array.iter control_rec cl - | IsApp (_,cl) -> Array.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 + (Array.map (fun ty -> lift lt (body_of_type ty)) lar) + with NotConvertibleVect i -> + error_ill_typed_rec_body env i lna vdefj lar + +(***********************************************************************) +(***********************************************************************) + +(* This combinator adds the universe constraints both in the local + graph and in the universes of the environment. This is to ensure + that the infered local graph is satisfiable. *) +let univ_combinator (cst,univ) (j,c') = + (j,(Constraint.union cst c', merge_constraints c' univ)) + +(* The typing machine. *) + (* ATTENTION : faudra faire le typage du contexte des Const, + Ind et Constructsi un jour cela devient des constructions + arbitraires et non plus des variables *) +let rec execute env cstr cu = + match kind_of_term cstr with + (* Atomic terms *) + | Sort (Prop c) -> + (judge_of_prop_contents c, cu) + + | Sort (Type u) -> + univ_combinator cu (judge_of_type u) + + | Rel n -> + (judge_of_relative env n, cu) + + | Var id -> + (judge_of_variable env id, cu) + + | Const c -> + (judge_of_constant env c, cu) + + (* Lambda calculus operators *) + | App (f,args) -> + let (j,cu1) = execute env f cu in + let (jl,cu2) = execute_array env args cu1 in + univ_combinator cu2 + (judge_of_apply env j jl) + + | Lambda (name,c1,c2) -> + let (varj,cu1) = execute_type env c1 cu in + let env1 = push_rel (name,None,varj.utj_val) env in + let (j',cu2) = execute env1 c2 cu1 in + (judge_of_abstraction env name varj j', cu2) + + | Prod (name,c1,c2) -> + let (varj,cu1) = execute_type env c1 cu in + let env1 = push_rel (name,None,varj.utj_val) env in + let (varj',cu2) = execute_type env1 c2 cu1 in + univ_combinator cu2 + (judge_of_product env name varj varj') + + | LetIn (name,c1,c2,c3) -> + let (j,cu1) = execute env (mkCast(c1,c2)) cu in + let env1 = push_rel (name,Some j.uj_val,j.uj_type) env in + let (j',cu2) = execute env1 c3 cu1 in + (judge_of_letin env name j j', cu2) + + | Cast (c,t) -> + let (cj,cu1) = execute env c cu in + let (tj,cu2) = execute_type env t cu1 in + univ_combinator cu2 + (judge_of_cast env cj tj) + + (* Inductive types *) + | Ind ind -> + (judge_of_inductive env ind, cu) + + | Construct c -> + (judge_of_constructor env c, cu) + + | Case (ci,p,c,lf) -> + let (cj,cu1) = execute env c cu in + let (pj,cu2) = execute env p cu1 in + let (lfj,cu3) = execute_array env lf cu2 in + univ_combinator cu3 + (judge_of_case env ci pj cj lfj) + + | Fix ((vn,i as vni),recdef) -> + let ((fix_ty,recdef'),cu1) = execute_recdef env recdef i cu in + let fix = (vni,recdef') in + check_fix env fix; + (make_judge (mkFix fix) fix_ty, cu1) + + | CoFix (i,recdef) -> + let ((fix_ty,recdef'),cu1) = execute_recdef env recdef i cu in + let cofix = (i,recdef') in + check_cofix env cofix; + (make_judge (mkCoFix cofix) fix_ty, cu1) + + (* Partial proofs: unsupported by the kernel *) + | Meta _ -> + anomaly "the kernel does not support metavariables" + + | Evar _ -> + anomaly "the kernel does not support existential variables" + +and execute_type env constr cu = + let (j,cu1) = execute env constr cu in + (type_judgment env j, cu1) + +and execute_recdef env (names,lar,vdef) i cu = + let (larj,cu1) = execute_array env lar cu in + let lara = Array.map (assumption_of_judgment env) larj in + let env1 = push_rec_types (names,lara,vdef) env in + let (vdefj,cu2) = execute_array env1 vdef cu1 in + let vdefv = Array.map j_val vdefj in + let cst = type_fixpoint env1 names lara vdefj in + univ_combinator cu2 + ((lara.(i),(names,lara,vdefv)),cst) + +and execute_array env v cu = + let (jl,cu1) = execute_list env (Array.to_list v) cu in + (Array.of_list jl, cu1) + +and execute_list env l cu = + match l with + | [] -> + ([], cu) + | c::r -> + let (j,cu1) = execute env c cu in + let (jr,cu2) = execute_list env r cu1 in + (j::jr, cu2) + +(* Derived functions *) +let infer env constr = + let (j,(cst,_)) = + execute env constr (Constraint.empty, universes env) in + (j, cst) + +let infer_type env constr = + let (j,(cst,_)) = + execute_type env constr (Constraint.empty, universes env) in + (j, cst) + +let infer_v env cv = + let (jv,(cst,_)) = + execute_array env cv (Constraint.empty, universes env) in + (jv, cst) + +(* Typing of several terms. *) + +type local_entry = + | LocalDef of constr + | LocalAssum of constr + +let infer_local_decl env id = function + | LocalDef c -> + let (j,cst) = infer env c in + (Name id, Some j.uj_val, j.uj_type), cst + | LocalAssum c -> + let (j,cst) = infer env c in + (Name id, None, assumption_of_judgment env j), cst + +let infer_local_decls env decls = + let rec inferec env = function + | (id, d) :: l -> + let env, l, cst1 = inferec env l in + let d, cst2 = infer_local_decl env id d in + push_rel d env, d :: l, Constraint.union cst1 cst2 + | [] -> env, [], Constraint.empty in + inferec env decls diff --git a/kernel/typeops.mli b/kernel/typeops.mli index e4464fd89..24ffa47b1 100644 --- a/kernel/typeops.mli +++ b/kernel/typeops.mli @@ -10,97 +10,83 @@ (*i*) open Names -open Sign open Univ open Term -open Evd open Environ +open Inductive (*i*) +(*s Typing functions (not yet tagged as safe) *) + +val infer : env -> constr -> unsafe_judgment * constraints +val infer_v : env -> constr array -> unsafe_judgment array * constraints +val infer_type : env -> types -> unsafe_type_judgment * constraints -(* Basic operations of the typing machine. *) +type local_entry = + | LocalDef of constr + | LocalAssum of constr -val make_judge : constr -> types -> unsafe_judgment +val infer_local_decls : + env -> (identifier * local_entry) list + -> env * Sign.rel_context * constraints -val j_val : unsafe_judgment -> constr +(*s Basic operations of the typing machine. *) (* If [j] is the judgement $c:t$, then [assumption_of_judgement env j] returns the type $c$, checking that $t$ is a sort. *) -val assumption_of_judgment : - env -> 'a evar_map -> unsafe_judgment -> types - -val type_judgment : - env -> 'a evar_map -> unsafe_judgment -> unsafe_type_judgment +val assumption_of_judgment : env -> unsafe_judgment -> types +val type_judgment : env -> unsafe_judgment -> unsafe_type_judgment (*s Type of sorts. *) val judge_of_prop_contents : contents -> unsafe_judgment +val judge_of_type : universe -> unsafe_judgment * constraints -val judge_of_type : universe -> unsafe_judgment * constraints +(*s Type of a bound variable. *) +val judge_of_relative : env -> int -> unsafe_judgment -(*s Type of atomic terms. *) -val relative : env -> int -> unsafe_judgment +(*s Type of variables *) +val judge_of_variable : env -> identifier -> unsafe_judgment -val type_of_constant : env -> 'a evar_map -> constant -> types - -val type_of_existential : env -> 'a evar_map -> existential -> types - -(*s Type of an abstraction. *) -val abs_rel : - env -> 'a evar_map -> name -> types -> unsafe_judgment - -> unsafe_judgment * constraints - -(* s Type of a let in. *) -val judge_of_letin : - env -> 'a evar_map -> name -> unsafe_judgment -> unsafe_judgment - -> unsafe_judgment * constraints +(*s type of a constant *) +val judge_of_constant : env -> constant -> unsafe_judgment (*s Type of application. *) -val apply_rel_list : - env -> 'a evar_map -> bool -> unsafe_judgment list -> unsafe_judgment +val judge_of_apply : + env -> unsafe_judgment -> unsafe_judgment array -> unsafe_judgment * constraints +(*s Type of an abstraction. *) +val judge_of_abstraction : + env -> name -> unsafe_type_judgment -> unsafe_judgment + -> unsafe_judgment + (*s Type of a product. *) -val gen_rel : - env -> 'a evar_map -> name -> unsafe_type_judgment -> unsafe_type_judgment +val judge_of_product : + env -> name -> unsafe_type_judgment -> unsafe_type_judgment -> unsafe_judgment * constraints -val sort_of_product : sorts -> sorts -> universes -> sorts * constraints +(* s Type of a let in. *) +val judge_of_letin : + env -> name -> unsafe_judgment -> unsafe_judgment + -> unsafe_judgment (*s Type of a cast. *) -val cast_rel : - env -> 'a evar_map -> unsafe_judgment -> types +val judge_of_cast : + env -> unsafe_judgment -> unsafe_type_judgment -> unsafe_judgment * constraints (*s Inductive types. *) -open Inductive -val type_of_inductive : env -> 'a evar_map -> inductive -> types +val judge_of_inductive : env -> inductive -> unsafe_judgment -val type_of_constructor : env -> 'a evar_map -> constructor -> types +val judge_of_constructor : env -> constructor -> unsafe_judgment (*s Type of Cases. *) -val judge_of_case : env -> 'a evar_map -> case_info - -> unsafe_judgment -> unsafe_judgment - -> unsafe_judgment array -> unsafe_judgment * constraints - -val find_case_dep_nparams : - env -> 'a evar_map -> constr * unsafe_judgment -> inductive_family - -> bool * constraints - -val type_case_branches : - env -> 'a evar_map -> Inductive.inductive_type -> unsafe_judgment - -> constr -> types array * types * constraints - -(*s Type of fixpoints and guard condition. *) -val check_fix : env -> 'a evar_map -> fixpoint -> unit -val check_cofix : env -> 'a evar_map -> cofixpoint -> unit -val type_fixpoint : env -> 'a evar_map -> name array -> types array - -> unsafe_judgment array -> constraints - -val control_only_guard : env -> 'a evar_map -> constr -> unit - -(*i -val hyps_inclusion : env -> 'a evar_map -> named_context -> named_context -> bool -i*) +val judge_of_case : env -> case_info + -> unsafe_judgment -> unsafe_judgment -> unsafe_judgment array + -> unsafe_judgment * constraints +(* Typecheck general fixpoint (not checking guard conditions) *) +val type_fixpoint : env -> name array -> types array + -> unsafe_judgment array -> constraints diff --git a/kernel/univ.ml b/kernel/univ.ml index a74ea74fb..b55b3ca6f 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -67,7 +67,7 @@ let implicit_univ = { u_mod = Names.make_dirpath [Names.id_of_string "implicit_univ"]; u_num = 0 } -let current_module = ref Names.default_module +let current_module = ref (Names.make_dirpath[Names.id_of_string"Top"]) let set_module m = current_module := m diff --git a/kernel/univ.mli b/kernel/univ.mli index da66f4aed..97dd6bdef 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -8,10 +8,6 @@ (*i $Id$ i*) -(*i*) -open Names -(*i*) - (* Universes. *) type universe @@ -20,7 +16,7 @@ val implicit_univ : universe val prop_univ : universe -val set_module : dir_path -> unit +val set_module : Names.dir_path -> unit val new_univ : unit -> universe @@ -32,9 +28,7 @@ val initial_universes : universes (*s Constraints. *) -type univ_constraint - -module Constraint : Set.S with type elt = univ_constraint +module Constraint : Set.S type constraints = Constraint.t diff --git a/library/declare.ml b/library/declare.ml index 1c034190e..1f5b69458 100644 --- a/library/declare.ml +++ b/library/declare.ml @@ -11,19 +11,23 @@ open Pp open Util open Names +open Nameops open Term open Sign open Declarations open Inductive +open Indtypes open Reduction open Type_errors open Typeops open Libobject open Lib open Impargs -open Indrec open Nametab open Library +open Safe_typing + +(**********************************************) (* For [DischargeAt (dir,n)], [dir] is the minimum prefix that a construction keeps in its name (if persistent), or the section name @@ -41,20 +45,11 @@ let depth_of_strength = function | NeverDischarge -> 0 | NotDeclare -> assert false -let restrict_path n sp = - let dir, s, k = repr_path sp in - let dir' = list_lastn n (repr_dirpath dir) in - Names.make_path (make_dirpath dir') s k - let make_strength_0 () = let depth = Lib.sections_depth () in let cwd = Lib.cwd() in if depth > 0 then DischargeAt (cwd, depth) else NeverDischarge -let extract_dirpath_prefix n dir = - let dir = repr_dirpath dir in - make_dirpath (list_firstn (List.length dir -n) dir) - let make_strength_1 () = let depth = Lib.sections_depth () in let cwd = Lib.cwd() in @@ -74,37 +69,32 @@ type section_variable_entry = | SectionLocalDef of constr | SectionLocalAssum of constr -type variable_declaration = section_variable_entry * strength +type variable_declaration = dir_path * section_variable_entry * strength type checked_section_variable = constr option * types * Univ.constraints type checked_variable_declaration = - checked_section_variable * strength + dir_path * checked_section_variable * strength -let vartab = - ref ((Spmap.empty, []) : - (identifier * checked_variable_declaration) Spmap.t * section_path list) - -let current_section_context () = - List.map (fun sp -> (basename sp, sp)) (snd !vartab) +let vartab = ref (Idmap.empty : checked_variable_declaration Idmap.t) let _ = Summary.declare_summary "VARIABLE" { Summary.freeze_function = (fun () -> !vartab); Summary.unfreeze_function = (fun ft -> vartab := ft); - Summary.init_function = (fun () -> vartab := (Spmap.empty, [])); + Summary.init_function = (fun () -> vartab := Idmap.empty); Summary.survive_section = false } -let cache_variable (sp,(id,(d,str))) = +let cache_variable (sp,(id,(p,d,str))) = (* Constr raisonne sur les noms courts *) - if List.mem_assoc id (current_section_context ()) then - errorlabstrm "cache_variable" - [< pr_id (basename sp); 'sTR " already exists" >]; - let vd = match d with (* Fails if not well-typed *) + if Idmap.mem id !vartab then + errorlabstrm "cache_variable" [< pr_id id; 'sTR " already exists" >]; + let cst = match d with (* Fails if not well-typed *) | SectionLocalAssum ty -> Global.push_named_assum (id,ty) - | SectionLocalDef c -> Global.push_named_def (id,c) - in - Nametab.push 0 (restrict_path 0 sp) (VarRef sp); - vartab := let (m,l) = !vartab in (Spmap.add sp (id,(vd,str)) m, sp::l) + | SectionLocalDef c -> Global.push_named_def (id,c) in + let (_,bd,ty) = Global.lookup_named id in + let vd = (bd,ty,cst) in + Nametab.push 0 (restrict_path 0 sp) (VarRef id); + vartab := Idmap.add id (p,vd,str) !vartab let (in_variable, out_variable) = let od = { @@ -116,23 +106,23 @@ let (in_variable, out_variable) = declare_object ("VARIABLE", od) let declare_variable id obj = - let sp = add_leaf id CCI (in_variable (id,obj)) in - if is_implicit_args() then declare_var_implicits sp; + let sp = add_leaf id (in_variable (id,obj)) in + if is_implicit_args() then declare_var_implicits id; sp (* Parameters. *) let cache_parameter (sp,c) = - if Nametab.exists_cci sp then - errorlabstrm "cache_parameter" - [< pr_id (basename sp); 'sTR " already exists" >]; - Global.add_parameter sp c (current_section_context ()); + (if Nametab.exists_cci sp then + let (_,id) = repr_path sp in + errorlabstrm "cache_parameter" [< pr_id id; 'sTR " already exists" >]); + Global.add_parameter sp c; Nametab.push 0 sp (ConstRef sp) let load_parameter (sp,_) = - if Nametab.exists_cci sp then - errorlabstrm "cache_parameter" - [< pr_id (basename sp); 'sTR " already exists" >]; + (if Nametab.exists_cci sp then + let (_,id) = repr_path sp in + errorlabstrm "cache_parameter" [< pr_id id; 'sTR " already exists" >]); Nametab.push 1 sp (ConstRef sp) let open_parameter (sp,_) = @@ -153,7 +143,7 @@ let (in_parameter, out_parameter) = declare_object ("PARAMETER", od) let declare_parameter id c = - let sp = add_leaf id CCI (in_parameter c) in + let sp = add_leaf id (in_parameter c) in if is_implicit_args() then declare_constant_implicits sp; sp @@ -174,16 +164,15 @@ let _ = Summary.declare_summary "CONSTANT" Summary.survive_section = false } let cache_constant (sp,(cdt,stre)) = - if Nametab.exists_cci sp then - errorlabstrm "cache_constant" - [< pr_id (basename sp); 'sTR " already exists" >] ; - let sc = current_section_context() in + (if Nametab.exists_cci sp then + let (_,id) = repr_path sp in + errorlabstrm "cache_constant" [< pr_id id; 'sTR " already exists" >]); begin match cdt with - | ConstantEntry ce -> Global.add_constant sp ce sc - | ConstantRecipe r -> Global.add_discharged_constant sp r sc + | ConstantEntry ce -> Global.add_constant sp ce + | ConstantRecipe r -> Global.add_discharged_constant sp r end; (match stre with - | DischargeAt (sp',n) when not (is_dirpath_prefix_of sp' (Lib.cwd ())) -> + | DischargeAt (dp,n) when not (is_dirpath_prefix_of dp (Lib.cwd ())) -> (* Only qualifications including the sections segment from the current section to the discharge section is available for Remark & Fact *) Nametab.push (n-Lib.sections_depth()) sp (ConstRef sp) @@ -196,9 +185,9 @@ let cache_constant (sp,(cdt,stre)) = (* At load-time, the segment starting from the module name to the discharge *) (* section (if Remark or Fact) is needed to access a construction *) let load_constant (sp,(ce,stre)) = - if Nametab.exists_cci sp then - errorlabstrm "cache_constant" - [< pr_id (basename sp); 'sTR " already exists" >] ; + (if Nametab.exists_cci sp then + let (_,id) = repr_path sp in + errorlabstrm "cache_constant" [< pr_id id; 'sTR " already exists" >]); csttab := Spmap.add sp stre !csttab; Nametab.push (depth_of_strength stre + 1) sp (ConstRef sp) @@ -235,7 +224,7 @@ let hcons_constant_declaration = function let declare_constant id cd = (* let cd = hcons_constant_declaration cd in *) - let sp = add_leaf id CCI (in_constant cd) in + let sp = add_leaf id (in_constant cd) in if is_implicit_args() then declare_constant_implicits sp; sp @@ -245,8 +234,8 @@ let redeclare_constant sp cd = (* Inductives. *) - let inductive_names sp mie = + let (dp,_) = repr_path sp in let names, _ = List.fold_left (fun (names, n) ind -> @@ -254,23 +243,23 @@ let inductive_names sp mie = let names, _ = List.fold_left (fun (names, p) id -> - let sp = Names.make_path (dirpath sp) id CCI in + let sp = Names.make_path dp id in ((sp, ConstructRef (indsp,p)) :: names, p+1)) (names, 1) ind.mind_entry_consnames in - let sp = Names.make_path (dirpath sp) ind.mind_entry_typename CCI in + let sp = Names.make_path dp ind.mind_entry_typename in ((sp, IndRef indsp) :: names, n+1)) ([], 0) mie.mind_entry_inds in names let check_exists_inductive (sp,_) = if Nametab.exists_cci sp then - errorlabstrm "cache_inductive" - [< pr_id (basename sp); 'sTR " already exists" >] + let (_,id) = repr_path sp in + errorlabstrm "cache_inductive" [< pr_id id; 'sTR " already exists" >] let cache_inductive (sp,mie) = let names = inductive_names sp mie in List.iter check_exists_inductive names; - Global.add_mind sp mie (current_section_context ()); + Global.add_mind sp mie; List.iter (fun (sp, ref) -> Nametab.push 0 sp ref) names @@ -314,7 +303,7 @@ let declare_mind mie = | ind::_ -> ind.mind_entry_typename | [] -> anomaly "cannot declare an empty list of inductives" in - let sp = add_leaf id CCI (in_inductive mie) in + let sp = add_leaf id (in_inductive mie) in if is_implicit_args() then declare_mib_implicits sp; sp @@ -329,18 +318,19 @@ let constant_strength sp = Spmap.find sp !csttab let constant_or_parameter_strength sp = try constant_strength sp with Not_found -> NeverDischarge -let get_variable sp = - let (id,((c,ty,cst),str)) = Spmap.find sp (fst !vartab) in -(* let (c,ty) = Global.lookup_named id in*) +let get_variable id = + let (p,(c,ty,cst),str) = Idmap.find id !vartab in ((id,c,ty),str) -let get_variable_with_constraints sp = - let (id,((c,ty,cst),str)) = Spmap.find sp (fst !vartab) in -(* let (c,ty) = Global.lookup_named id in*) +let get_variable_with_constraints id = + let (p,(c,ty,cst),str) = Idmap.find id !vartab in ((id,c,ty),cst,str) -let variable_strength sp = - let _,(_,str) = Spmap.find sp (fst !vartab) in str +let variable_strength id = + let (_,_,str) = Idmap.find id !vartab in str + +let find_section_variable id = + let (p,_,_) = Idmap.find id !vartab in Names.make_path p id (* Global references. *) @@ -367,54 +357,33 @@ let mind_oper_of_id sp id mib = mib.mind_packets let context_of_global_reference = function - | VarRef sp -> [] + | VarRef id -> [] | ConstRef sp -> (Global.lookup_constant sp).const_hyps | IndRef (sp,_) -> (Global.lookup_mind sp).mind_hyps | ConstructRef ((sp,_),_) -> (Global.lookup_mind sp).mind_hyps -let find_section_variable id = - let l = - Spmap.fold - (fun sp (id',_) hyps -> if id=id' then sp::hyps else hyps) - (fst !vartab) [] in - match l with - | [] -> raise Not_found - | [sp] -> sp - | _ -> anomaly "Several section variables with same base name" - let reference_of_constr c = match kind_of_term c with - | IsConst sp -> ConstRef sp - | IsMutInd ind_sp -> IndRef ind_sp - | IsMutConstruct cstr_cp -> ConstructRef cstr_cp - | IsVar id -> VarRef (find_section_variable id) + | Const sp -> ConstRef sp + | Ind ind_sp -> IndRef ind_sp + | Construct cstr_cp -> ConstructRef cstr_cp + | Var id -> VarRef id | _ -> raise Not_found let last_section_hyps dir = - List.fold_right - (fun sp hyps -> if dirpath sp = dir then basename sp :: hyps else hyps) - (snd !vartab) [] - -let rec find_var id = function - | [] -> raise Not_found - | sp::l -> if basename sp = id then sp else find_var id l - -let extract_instance ref args = - let hyps = context_of_global_reference ref in - let hyps0 = current_section_context () in - let na = Array.length args in - let rec peel n acc = function - | (sp,None,_ as d)::hyps -> - if List.mem_assoc (basename sp) hyps0 then peel (n-1) acc hyps - else peel (n-1) (args.(n)::acc) hyps - | (_,Some _,_)::hyps -> peel n acc hyps - | [] -> Array.of_list acc - in peel (na-1) [] hyps + fold_named_context + (fun (id,_,_) sec_ids -> + try + let (p,_,_) = Idmap.find id !vartab in + if dir=p then id::sec_ids else sec_ids + with Not_found -> sec_ids) + (Environ.named_context (Global.env())) + [] let constr_of_reference = function - | VarRef sp -> mkVar (basename sp) + | VarRef id -> mkVar id | ConstRef sp -> mkConst sp - | ConstructRef sp -> mkMutConstruct sp - | IndRef sp -> mkMutInd sp + | ConstructRef sp -> mkConstruct sp + | IndRef sp -> mkInd sp let construct_absolute_reference sp = constr_of_reference (Nametab.absolute_reference sp) @@ -427,7 +396,7 @@ let construct_reference env id = try mkVar (let _ = Environ.lookup_named id env in id) with Not_found -> - let ref = Nametab.sp_of_id CCI id in + let ref = Nametab.sp_of_id id in constr_of_reference ref let global_qualified_reference qid = @@ -442,8 +411,10 @@ let global_reference_in_absolute_module dir id = let global_reference id = construct_reference (Global.env()) id +let dirpath sp = let (p,_) = repr_path sp in p + let dirpath_of_global = function - | VarRef sp -> dirpath sp + | VarRef id -> empty_dirpath | ConstRef sp -> dirpath sp | IndRef (sp,_) -> dirpath sp | ConstructRef ((sp,_),_) -> dirpath sp @@ -460,80 +431,3 @@ let is_global id = is_dirpath_prefix_of (dirpath_of_global osp) (Lib.cwd()) with Not_found -> false - -let path_of_constructor_path ((sp,tyi),ind) = - let mib = Global.lookup_mind sp in - let mip = mind_nth_type_packet mib tyi in - let (pa,_,k) = repr_path sp in - Names.make_path pa (mip.mind_consnames.(ind-1)) k - -let path_of_inductive_path (sp,tyi) = - if tyi = 0 then sp - else - let mib = Global.lookup_mind sp in - let mip = mind_nth_type_packet mib tyi in - let (pa,_,k) = repr_path sp in - Names.make_path pa (mip.mind_typename) k - -(*s Eliminations. *) - -let eliminations = - [ (InProp,"_ind") ; (InSet,"_rec") ; (InType,"_rect") ] - -let elimination_suffix = function - | InProp -> "_ind" - | InSet -> "_rec" - | InType -> "_rect" - -let make_elimination_ident id s = add_suffix id (elimination_suffix s) - -let declare_one_elimination mispec = - let mindstr = string_of_id (mis_typename mispec) in - let declare na c = - let _ = declare_constant (id_of_string na) - (ConstantEntry - { const_entry_body = c; - const_entry_type = None; - const_entry_opaque = false }, - NeverDischarge) in - Options.if_verbose pPNL [< 'sTR na; 'sTR " is defined" >] - in - let env = Global.env () in - let sigma = Evd.empty in - let elim_scheme = build_indrec env sigma mispec in - let npars = mis_nparams mispec in - let make_elim s = instanciate_indrec_scheme s npars elim_scheme in - let kelim = mis_kelim mispec in - List.iter - (fun (sort,suff) -> - if List.mem sort kelim then - declare (mindstr^suff) (make_elim (new_sort_in_family sort))) - eliminations - -let declare_eliminations sp = - let mib = Global.lookup_mind sp in -(* - let ids = ids_of_named_context mib.mind_hyps in - if not (list_subset ids (ids_of_named_context (Global.named_context ()))) then error ("Declarations of elimination scheme outside the section "^ - "of the inductive definition is not implemented"); -*) - for i = 0 to Array.length mib.mind_packets - 1 do - if mind_type_finite mib i then - let mispec = Global.lookup_mind_specif (sp,i) in - declare_one_elimination mispec - done - -(* Look up function for the default elimination constant *) - -let lookup_eliminator env ind_sp s = - let path = path_of_inductive_path ind_sp in - let dir, base,k = repr_path path in - let id = add_suffix base (elimination_suffix s) in - (* Try first to get an eliminator defined in the same section as the *) - (* inductive type *) - try construct_absolute_reference (Names.make_path dir id k) - with Not_found -> - (* Then try to get a user-defined eliminator in some other places *) - (* using short name (e.g. for "eq_rec") *) - construct_reference env id - diff --git a/library/declare.mli b/library/declare.mli index be5678f7f..c57dd2079 100644 --- a/library/declare.mli +++ b/library/declare.mli @@ -13,8 +13,10 @@ open Names open Term open Sign open Declarations -open Inductive +open Indtypes +open Safe_typing open Library +open Nametab (*i*) (* This module provides the official functions to declare new variables, @@ -33,9 +35,9 @@ type section_variable_entry = | SectionLocalDef of constr | SectionLocalAssum of constr -type variable_declaration = section_variable_entry * strength +type variable_declaration = dir_path * section_variable_entry * strength -val declare_variable : identifier -> variable_declaration -> variable +val declare_variable : variable -> variable_declaration -> section_path type constant_declaration_type = | ConstantEntry of constant_entry @@ -57,10 +59,6 @@ val declare_parameter : identifier -> constr -> constant the whole block *) val declare_mind : mutual_inductive_entry -> mutual_inductive -(* [declare_eliminations sp] declares elimination schemes associated - to the mutual inductive block refered by [sp] *) -val declare_eliminations : mutual_inductive -> unit - val out_inductive : Libobject.obj -> mutual_inductive_entry val make_strength_0 : unit -> strength @@ -78,13 +76,12 @@ val get_variable : variable -> named_declaration * strength val get_variable_with_constraints : variable -> named_declaration * Univ.constraints * strength val variable_strength : variable -> strength -val find_section_variable : identifier -> variable +val find_section_variable : variable -> section_path val last_section_hyps : dir_path -> identifier list (*s Global references *) val context_of_global_reference : global_reference -> section_context -val extract_instance : global_reference -> constr array -> constr array (* Turn a global reference into a construction *) val constr_of_reference : global_reference -> constr @@ -108,12 +105,3 @@ val global_reference : identifier -> constr val construct_reference : Environ.env -> identifier -> constr val is_global : identifier -> bool - -val path_of_inductive_path : inductive -> mutual_inductive -val path_of_constructor_path : constructor -> mutual_inductive - -(* Look up function for the default elimination constant *) -val elimination_suffix : sorts_family -> string -val make_elimination_ident : - inductive_ident:identifier -> sorts_family -> identifier -val lookup_eliminator : Environ.env -> inductive -> sorts_family -> constr diff --git a/library/global.ml b/library/global.ml index b55f741dd..3f009d6d2 100644 --- a/library/global.ml +++ b/library/global.ml @@ -11,7 +11,6 @@ open Util open Names open Term -open Instantiate open Sign open Environ open Safe_typing @@ -35,69 +34,38 @@ let _ = (* Then we export the functions of [Typing] on that environment. *) -let universes () = universes !global_env -let context () = context !global_env -let named_context () = named_context !global_env - -let push_named_def idc = - let d, env = check_and_push_named_def idc !global_env in - global_env := env; d - -let push_named_assum idc = - let d, env = check_and_push_named_assum idc !global_env in - global_env := env; d +let universes () = universes (env()) +let named_context () = named_context (env()) + +let push_named_assum a = + let (cst,env) = push_named_assum a !global_env in + global_env := env; + cst +let push_named_def d = + let (cst,env) = push_named_def d !global_env in + global_env := env; + cst +let pop_named_decls ids = global_env := pop_named_decls ids !global_env -let add_parameter sp c l = global_env := add_parameter sp c l !global_env -let add_constant sp ce l = global_env := add_constant sp ce l !global_env -let add_discharged_constant sp r l = - global_env := add_discharged_constant sp r l !global_env -let add_mind sp mie l = global_env := add_mind sp mie l !global_env +let add_parameter sp c = global_env := add_parameter sp c !global_env +let add_constant sp ce = global_env := add_constant sp ce !global_env +let add_discharged_constant sp r = + global_env := add_discharged_constant sp r !global_env +let add_mind sp mie = global_env := add_mind sp mie !global_env let add_constraints c = global_env := add_constraints c !global_env -let pop_named_decls ids = global_env := pop_named_decls ids !global_env - -let lookup_named id = lookup_named id !global_env -let lookup_constant sp = lookup_constant sp !global_env -let lookup_mind sp = lookup_mind sp !global_env -let lookup_mind_specif c = lookup_mind_specif c !global_env +let lookup_named id = lookup_named id (env()) +let lookup_constant sp = lookup_constant sp (env()) +let lookup_inductive ind = Inductive.lookup_mind_specif (env()) ind +let lookup_mind sp = lookup_mind sp (env()) let export s = export !global_env s let import cenv = global_env := import cenv !global_env -(* Some instanciations of functions from [Environ]. *) - -let sp_of_global ref = Environ.sp_of_global (env_of_safe_env !global_env) ref - -(* To know how qualified a name should be to be understood in the current env*) - -let qualid_of_global ref = - let sp = sp_of_global ref in - let id = basename sp in - let rec find_visible dir qdir = - let qid = Nametab.make_qualid qdir id in - if (try Nametab.locate qid = ref with Not_found -> false) then qid - else match dir with - | [] -> Nametab.qualid_of_sp sp - | a::l -> find_visible l (add_dirpath_prefix a qdir) - in - find_visible (rev_repr_dirpath (dirpath sp)) (make_dirpath []) - -let string_of_global ref = Nametab.string_of_qualid (qualid_of_global ref) - (*s Function to get an environment from the constants part of the global environment and a given context. *) let env_of_context hyps = - change_hyps (fun _ -> hyps) (env_of_safe_env !global_env) - -(* Functions of [Inductive], composed with [lookup_mind_specif]. *) -(* Rem:Cannot open Inductive to avoid clash with Inductive.lookup_mind_specif*) - -let mind_is_recursive = - Util.compose Inductive.mis_is_recursive lookup_mind_specif - -let mind_nconstr = Util.compose Inductive.mis_nconstr lookup_mind_specif -let mind_nparams = Util.compose Inductive.mis_nparams lookup_mind_specif -let mind_nf_lc = Util.compose Inductive.mis_nf_lc lookup_mind_specif + reset_with_named_context hyps (env()) diff --git a/library/global.mli b/library/global.mli index a9cda1289..0a5edc9ad 100644 --- a/library/global.mli +++ b/library/global.mli @@ -12,10 +12,8 @@ open Names open Univ open Term -open Sign open Declarations -open Inductive -open Environ +open Indtypes open Safe_typing (*i*) @@ -24,51 +22,34 @@ open Safe_typing operating on that global environment. *) val safe_env : unit -> safe_environment -val env : unit -> env +val env : unit -> Environ.env val universes : unit -> universes -val context : unit -> context -val named_context : unit -> named_context +val named_context : unit -> Sign.named_context -(* This has also a side-effect to push the declaration in the environment*) -val push_named_assum : identifier * constr -> constr option * types*constraints -val push_named_def : identifier * constr -> constr option * types * constraints +(* Extending env with variables, constants and inductives *) +val push_named_assum : (identifier * types) -> Univ.constraints +val push_named_def : (identifier * constr) -> Univ.constraints +val pop_named_decls : identifier list -> unit -val add_parameter : section_path -> constr -> local_names -> unit -val add_constant : section_path -> constant_entry -> local_names -> unit -val add_discharged_constant : section_path -> Cooking.recipe -> - local_names -> unit -val add_mind : section_path -> mutual_inductive_entry -> local_names -> unit -val add_constraints : constraints -> unit - -val pop_named_decls : identifier list -> unit - -val lookup_named : identifier -> constr option * types -val lookup_constant : section_path -> constant_body -val lookup_mind : section_path -> mutual_inductive_body -val lookup_mind_specif : inductive -> inductive_instance - -val export : dir_path -> compiled_env -val import : compiled_env -> unit +val add_parameter : constant -> types -> unit +val add_constant : constant -> constant_entry -> unit +val add_discharged_constant : constant -> Cooking.recipe -> unit -(*s Some functions of [Environ] instanciated on the global environment. *) +val add_mind : mutual_inductive -> mutual_inductive_entry -> unit +val add_constraints : constraints -> unit -val sp_of_global : global_reference -> section_path +(* Queries *) +val lookup_named : variable -> named_declaration +val lookup_constant : constant -> constant_body +val lookup_inductive : inductive -> mutual_inductive_body * one_inductive_body +val lookup_mind : mutual_inductive -> mutual_inductive_body -(*s This is for printing purpose *) -val qualid_of_global : global_reference -> Nametab.qualid -val string_of_global : global_reference -> string +(* Modules *) +val export : dir_path -> Environ.compiled_env +val import : Environ.compiled_env -> unit (*s Function to get an environment from the constants part of the global environment and a given context. *) -val env_of_context : named_context -> env - -(*s Re-exported functions of [Inductive], composed with - [lookup_mind_specif]. *) - -val mind_is_recursive : inductive -> bool -val mind_nconstr : inductive -> int -val mind_nparams : inductive -> int -val mind_nf_lc : inductive -> constr array - +val env_of_context : Sign.named_context -> Environ.env diff --git a/library/goptions.ml b/library/goptions.ml index 9af867ce7..0eae518b4 100644 --- a/library/goptions.ml +++ b/library/goptions.ml @@ -15,6 +15,7 @@ open Util open Libobject open Names open Term +open Nametab (****************************************************************************) (* 0- Common things *) @@ -301,7 +302,7 @@ let msg_option_value (name,v) = | BoolValue false -> [< 'sTR "false" >] | IntValue n -> [< 'iNT n >] | StringValue s -> [< 'sTR s >] - | IdentValue id -> [< 'sTR (Global.string_of_global id) >] + | IdentValue id -> pr_sp(Nametab.sp_of_global (Global.env())id) let print_option_value key = let (name,(_,read,_)) = get_option key in diff --git a/library/goptions.mli b/library/goptions.mli index 92eeb4108..8f810a266 100644 --- a/library/goptions.mli +++ b/library/goptions.mli @@ -56,6 +56,7 @@ open Pp open Names open Term +open Nametab (*i*) (*s Things common to tables and options. *) diff --git a/library/impargs.ml b/library/impargs.ml index e203a594d..fec4df020 100644 --- a/library/impargs.ml +++ b/library/impargs.ml @@ -17,6 +17,7 @@ open Environ open Inductive open Libobject open Lib +open Nametab (* calcul des arguments implicites *) @@ -31,7 +32,7 @@ let ord_add x l = let add_free_rels_until bound m acc = let rec frec depth acc c = match kind_of_term c with - | IsRel n when (n < bound+depth) & (n >= depth) -> + | Rel n when (n < bound+depth) & (n >= depth) -> Intset.add (bound+depth-n) acc | _ -> fold_constr_with_binders succ frec depth acc c in @@ -39,17 +40,17 @@ let add_free_rels_until bound m acc = (* calcule la liste des arguments implicites *) -let compute_implicits env sigma t = +let compute_implicits env t = let rec aux env n t = - match kind_of_term (whd_betadeltaiota env sigma t) with - | IsProd (x,a,b) -> + match kind_of_term (whd_betadeltaiota env t) with + | Prod (x,a,b) -> add_free_rels_until n a - (aux (push_rel_assum (x,a) env) (n+1) b) + (aux (push_rel (x,None,a) env) (n+1) b) | _ -> Intset.empty in - match kind_of_term (whd_betadeltaiota env sigma t) with - | IsProd (x,a,b) -> - Intset.elements (aux (push_rel_assum (x,a) env) 1 b) + match kind_of_term (whd_betadeltaiota env t) with + | Prod (x,a,b) -> + Intset.elements (aux (push_rel (x,None,a) env) 1 b) | _ -> [] type implicits_list = int list @@ -82,7 +83,7 @@ let using_implicits = function | No_impl -> with_implicits false | _ -> with_implicits true -let auto_implicits env ty = Impl_auto (compute_implicits env Evd.empty ty) +let auto_implicits env ty = Impl_auto (compute_implicits env ty) let list_of_implicits = function | Impl_auto l -> l @@ -128,7 +129,7 @@ let constant_implicits_list sp = module Inductive_path = struct type t = inductive let compare (spx,ix) (spy,iy) = - let c = ix - iy in if c = 0 then sp_ord spx spy else c + let c = ix - iy in if c = 0 then compare spx spy else c end module Indmap = Map.Make(Inductive_path) @@ -174,11 +175,16 @@ let (in_constructor_implicits, _) = let compute_mib_implicits sp = let env = Global.env () in let mib = lookup_mind sp env in - let env_ar = push_rels (mind_arities_context mib) env in + let ar = + Array.to_list + (Array.map (* No need to lift, arities contain no de Bruijn *) + (fun mip -> (Name mip.mind_typename, None, mip.mind_user_arity)) + mib.mind_packets) in + let env_ar = push_rel_context ar env in let imps_one_inductive mip = - (auto_implicits env (body_of_type (mind_user_arity mip)), + (auto_implicits env (body_of_type mip.mind_user_arity), Array.map (fun c -> auto_implicits env_ar (body_of_type c)) - (mind_user_lc mip)) + mip.mind_user_lc) in Array.map imps_one_inductive mib.mind_packets @@ -220,15 +226,15 @@ let inductive_implicits_list ind_sp = (*s Variables. *) -let var_table = ref Spmap.empty +let var_table = ref Idmap.empty -let compute_var_implicits sp = +let compute_var_implicits id = let env = Global.env () in - let (_,ty) = lookup_named (basename sp) env in + let (_,_,ty) = lookup_named id env in auto_implicits env (body_of_type ty) -let cache_var_implicits (_,(sp,imps)) = - var_table := Spmap.add sp imps !var_table +let cache_var_implicits (_,(id,imps)) = + var_table := Idmap.add id imps !var_table let (in_var_implicits, _) = let od = { @@ -239,12 +245,12 @@ let (in_var_implicits, _) = in declare_object ("VARIABLE-IMPLICITS", od) -let declare_var_implicits sp = - let imps = compute_var_implicits sp in - add_anonymous_leaf (in_var_implicits (sp,imps)) +let declare_var_implicits id = + let imps = compute_var_implicits id in + add_anonymous_leaf (in_var_implicits (id,imps)) -let implicits_of_var sp = - list_of_implicits (try Spmap.find sp !var_table with Not_found -> No_impl) +let implicits_of_var id = + list_of_implicits (try Idmap.find id !var_table with Not_found -> No_impl) (*s Implicits of a global reference. *) @@ -270,27 +276,28 @@ let context_of_global_reference = function let type_of_global r = match r with - | VarRef sp -> - lookup_named_type (basename sp) (Global.env ()) + | VarRef id -> + let (_,_,ty) = lookup_named id (Global.env ()) in + ty | ConstRef sp -> - Typeops.type_of_constant (Global.env ()) Evd.empty sp + Environ.constant_type (Global.env ()) sp | IndRef sp -> - Typeops.type_of_inductive (Global.env ()) Evd.empty sp + Inductive.type_of_inductive (Global.env ()) sp | ConstructRef sp -> - Typeops.type_of_constructor (Global.env ()) Evd.empty sp + Inductive.type_of_constructor (Global.env ()) sp let check_range n i = if i<1 or i>n then error ("Bad argument number: "^(string_of_int i)) let declare_manual_implicits r l = let t = type_of_global r in - let n = List.length (fst (splay_prod (Global.env()) Evd.empty t)) in + let n = List.length (fst (dest_prod (Global.env()) t)) in if not (list_distinct l) then error ("Some numbers occur several time"); List.iter (check_range n) l; let l = List.sort (-) l in match r with - | VarRef sp -> - add_anonymous_leaf (in_var_implicits (sp,Impl_manual l)) + | VarRef id -> + add_anonymous_leaf (in_var_implicits (id,Impl_manual l)) | ConstRef sp -> add_anonymous_leaf (in_constant_implicits (sp,Impl_manual l)) | IndRef indp -> @@ -307,11 +314,11 @@ let is_implicit_inductive_definition indp = try let _ = Indmap.find indp !inductives_table in true with Not_found -> false -let is_implicit_var sp = - try let _ = Spmap.find sp !var_table in true with Not_found -> false +let is_implicit_var id = + try let _ = Idmap.find id !var_table in true with Not_found -> false let implicits_of_global = function - | VarRef sp -> implicits_of_var sp + | VarRef id -> implicits_of_var id | ConstRef sp -> list_of_implicits (constant_implicits sp) | IndRef isp -> list_of_implicits (inductive_implicits isp) | ConstructRef csp -> list_of_implicits (constructor_implicits csp) @@ -321,13 +328,13 @@ let implicits_of_global = function type frozen_t = implicits Spmap.t * implicits Indmap.t * implicits Constrmap.t - * implicits Spmap.t + * implicits Idmap.t let init () = constants_table := Spmap.empty; inductives_table := Indmap.empty; constructors_table := Constrmap.empty; - var_table := Spmap.empty + var_table := Idmap.empty let freeze () = (!constants_table, !inductives_table, diff --git a/library/impargs.mli b/library/impargs.mli index ceaa30cdf..46d03d996 100644 --- a/library/impargs.mli +++ b/library/impargs.mli @@ -13,6 +13,7 @@ open Names open Term open Environ open Inductive +open Nametab (*i*) (*s Implicit arguments. Here we store the implicit arguments. Notice that we @@ -29,7 +30,7 @@ type implicits_list = int list (* Computation of the positions of arguments automatically inferable for an object of the given type in the given env *) -val compute_implicits : env -> 'a Evd.evar_map -> types -> implicits_list +val compute_implicits : env -> types -> implicits_list (*s Computation of implicits (done using the global environment). *) diff --git a/library/lib.ml b/library/lib.ml index e85e834ec..cd71de3a3 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -11,9 +11,11 @@ open Pp open Util open Names +open Nameops open Libobject open Summary + type node = | Leaf of obj | Module of dir_path @@ -36,7 +38,6 @@ and library_segment = library_entry list let lib_stk = ref ([] : (section_path * node) list) -let init_toplevel_root () = Nametab.push_library_root default_module let module_name = ref None let path_prefix = ref (default_module : dir_path) @@ -54,11 +55,11 @@ let recalc_path_prefix () = let pop_path_prefix () = path_prefix := fst (split_dirpath !path_prefix) -let make_path id k = Names.make_path !path_prefix id k +let make_path id = Names.make_path !path_prefix id let sections_depth () = - List.length (rev_repr_dirpath !path_prefix) - - List.length (rev_repr_dirpath (module_sp ())) + List.length (repr_dirpath !path_prefix) + - List.length (repr_dirpath (module_sp ())) let cwd () = !path_prefix @@ -87,7 +88,7 @@ let anonymous_id = fun () -> incr n; id_of_string ("_" ^ (string_of_int !n)) let add_anonymous_entry node = - let sp = make_path (anonymous_id()) OBJ in + let sp = make_path (anonymous_id()) in add_entry sp node; sp @@ -95,14 +96,14 @@ let add_absolutely_named_lead sp obj = cache_object (sp,obj); add_entry sp (Leaf obj) -let add_leaf id kind obj = - let sp = make_path id kind in +let add_leaf id obj = + let sp = make_path id in cache_object (sp,obj); add_entry sp (Leaf obj); sp let add_anonymous_leaf obj = - let sp = make_path (anonymous_id()) OBJ in + let sp = make_path (anonymous_id()) in cache_object (sp,obj); add_entry sp (Leaf obj) @@ -117,7 +118,7 @@ let contents_after = function let open_section id = let dir = extend_dirpath !path_prefix id in - let sp = make_path id OBJ in + let sp = make_path id in if Nametab.exists_section dir then errorlabstrm "open_section" [< pr_id id; 'sTR " already exists" >]; add_entry sp (OpenedSection (dir, freeze_summaries())); @@ -139,7 +140,6 @@ let start_module s = if !path_prefix <> default_module then error "some sections are already opened"; module_name := Some s; - Nametab.push_library_root s; Univ.set_module s; let _ = add_anonymous_entry (Module s) in path_prefix := s @@ -148,7 +148,7 @@ let end_module s = match !module_name with | None -> error "no module declared" | Some m -> - let bm = snd (split_dirpath m) in + let (_,bm) = split_dirpath m in if bm <> s then error ("The current open module has basename "^(string_of_id bm)); m @@ -187,7 +187,7 @@ let close_section export id = lib_stk := before; let after' = export_segment after in pop_path_prefix (); - add_entry (make_path id OBJ) (ClosedSection (export, dir, after')); + add_entry (make_path id) (ClosedSection (export, dir, after')); (dir,after,fs) (* The following function exports the whole library segment, that will be @@ -222,7 +222,7 @@ let reset_to sp = let reset_name id = let (sp,_) = try - find_entry_p (fun (sp,_) -> id = basename sp) + find_entry_p (fun (sp,_) -> let (_,spi) = repr_path sp in id = spi) with Not_found -> error (string_of_id id ^ ": no such entry") in diff --git a/library/lib.mli b/library/lib.mli index faf80428a..832e6cff9 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -33,7 +33,7 @@ and library_segment = library_entry list (*s Adding operations (which calls the [cache] method, and getting the current list of operations (most recent ones coming first). *) -val add_leaf : identifier -> path_kind -> obj -> section_path +val add_leaf : identifier -> obj -> section_path val add_absolutely_named_lead : section_path -> obj -> unit val add_anonymous_leaf : obj -> unit val add_frozen_state : unit -> unit @@ -53,14 +53,11 @@ val close_section : export:bool -> identifier -> dir_path * library_segment * Summary.frozen val sections_are_opened : unit -> bool -val make_path : identifier -> path_kind -> section_path +val make_path : identifier -> section_path val cwd : unit -> dir_path val sections_depth : unit -> int val is_section_p : dir_path -> bool -(* This is to declare the interactive toplevel default module name as a root*) -val init_toplevel_root : unit -> unit - val start_module : dir_path -> unit val end_module : module_ident -> dir_path val export_module : dir_path -> library_segment diff --git a/library/library.ml b/library/library.ml index 46c6b8b50..b35f7bbee 100644 --- a/library/library.ml +++ b/library/library.ml @@ -12,6 +12,7 @@ open Pp open Util open Names +open Nameops open Environ open Libobject open Lib @@ -57,7 +58,7 @@ let find_logical_path phys_dir = let phys_dir = canonical_path_name phys_dir in match list_filter2 (fun p d -> p = phys_dir) !load_path with | _,[dir] -> dir - | _,[] -> Nametab.default_root_prefix + | _,[] -> Nameops.default_root_prefix | _,l -> anomaly ("Two logical paths are associated to "^phys_dir) let remove_path dir = @@ -71,11 +72,11 @@ let add_load_path_entry (phys_path,coq_path) = (* If this is not the default -I . to coqtop *) && not (phys_path = canonical_path_name Filename.current_dir_name - && coq_path = Nametab.default_root_prefix) + && coq_path = Nameops.default_root_prefix) then begin (* Assume the user is concerned by module naming *) - if dir <> Nametab.default_root_prefix then + if dir <> Nameops.default_root_prefix then (Options.if_verbose warning (phys_path^" was previously bound to " ^(string_of_dirpath dir) ^("\nIt is remapped to "^(string_of_dirpath coq_path))); @@ -264,7 +265,6 @@ let rec load_module = function [< 'sTR ("The file " ^ f ^ " contains module"); 'sPC; pr_dirpath md.md_name; 'sPC; 'sTR "and not module"; 'sPC; pr_dirpath dir >]; - Nametab.push_library_root dir; compunit_cache := Stringmap.add f (md, digest) !compunit_cache; (md, digest) in intern_module digest f md @@ -316,7 +316,7 @@ let locate_qualified_library qid = try let dir, base = repr_qualid qid in let loadpath = - if is_empty_dirpath dir then get_load_path () + if repr_dirpath dir = [] then get_load_path () else (* we assume dir is an absolute dirpath *) load_path_of_logical_path dir @@ -364,7 +364,6 @@ let locate_by_filename_only id f = m.module_filename); (LibLoaded, md.md_name, m.module_filename) with Not_found -> - Nametab.push_library_root md.md_name; compunit_cache := Stringmap.add f (md, digest) !compunit_cache; (LibInPath, md.md_name, f) @@ -372,7 +371,7 @@ let locate_module qid = function | Some f -> (* A name is specified, we have to check it contains module id *) let prefix, id = repr_qualid qid in - assert (is_empty_dirpath prefix); + assert (repr_dirpath prefix = []); let _, f = System.find_file_in_path (get_load_path ()) (f^".vo") in locate_by_filename_only (Some id) f | None -> diff --git a/library/nameops.ml b/library/nameops.ml new file mode 100644 index 000000000..b7609bafd --- /dev/null +++ b/library/nameops.ml @@ -0,0 +1,228 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +(* $Id$ *) + +open Util +open Names +open Declarations +open Environ +open Term + +(* Identifiers *) + +let wildcard = id_of_string "_" + +(* Utilities *) + +let code_of_0 = Char.code '0' +let code_of_9 = Char.code '9' + +let cut_ident s = + let s = string_of_id s in + let slen = String.length s in + (* [n'] is the position of the first non nullary digit *) + let rec numpart n n' = + if n = 0 then + failwith + ("The string " ^ s ^ " is not an identifier: it contains only digits") + else + let c = Char.code (String.get s (n-1)) in + if c = code_of_0 && n <> slen then + numpart (n-1) n' + else if code_of_0 <= c && c <= code_of_9 then + numpart (n-1) (n-1) + else + n' + in + numpart slen slen + +let repr_ident s = + let numstart = cut_ident s in + let s = string_of_id s in + let slen = String.length s in + if numstart = slen then + (s, None) + else + (String.sub s 0 numstart, + Some (int_of_string (String.sub s numstart (slen - numstart)))) + +let make_ident sa = function + | Some n -> + let c = Char.code (String.get sa (String.length sa -1)) in + let s = + if c < code_of_0 or c > code_of_9 then sa ^ (string_of_int n) + else sa ^ "_" ^ (string_of_int n) in + id_of_string s + | None -> id_of_string (String.copy sa) + +(* Rem: semantics is a bit different, if an ident starts with toto00 then + after successive renamings it comes to toto09, then it goes on with toto10 *) +let lift_subscript id = + let id = string_of_id id in + let len = String.length id in + let rec add carrypos = + let c = id.[carrypos] in + if is_digit c then + if c = '9' then begin + assert (carrypos>0); + add (carrypos-1) + end + else begin + let newid = String.copy id in + String.fill newid (carrypos+1) (len-1-carrypos) '0'; + newid.[carrypos] <- Char.chr (Char.code c + 1); + newid + end + else begin + let newid = id^"0" in + if carrypos < len-1 then begin + String.fill newid (carrypos+1) (len-1-carrypos) '0'; + newid.[carrypos+1] <- '1' + end; + newid + end + in id_of_string (add (len-1)) + +let has_subscript id = + let id = string_of_id id in + is_digit (id.[String.length id - 1]) + +let forget_subscript id = + let numstart = cut_ident id in + let newid = String.make (numstart+1) '0' in + String.blit (string_of_id id) 0 newid 0 numstart; + (id_of_string newid) + +let add_suffix id s = id_of_string (string_of_id id ^ s) +let add_prefix s id = id_of_string (s ^ string_of_id id) + +let atompart_of_id id = fst (repr_ident id) + +(* Fresh names *) + +let lift_ident = lift_subscript + +let next_ident_away id avoid = + if List.mem id avoid then + let id0 = if not (has_subscript id) then id else + (* Ce serait sans doute mieux avec quelque chose inspiré de + *** make_ident id (Some 0) *** mais ça brise la compatibilité... *) + forget_subscript id in + let rec name_rec id = + if List.mem id avoid then name_rec (lift_ident id) else id in + name_rec id0 + else id + +let next_ident_away_from id avoid = + let rec name_rec id = + if List.mem id avoid then name_rec (lift_ident id) else id in + name_rec id + +(* Names *) + +let out_name = function + | Name id -> id + | Anonymous -> anomaly "out_name: expects a defined name" + +let next_name_away_with_default default name l = + match name with + | Name str -> next_ident_away str l + | Anonymous -> next_ident_away (id_of_string default) l + +let next_name_away name l = + match name with + | Name str -> next_ident_away str l + | Anonymous -> id_of_string "_" + +(**********************************************) +(* Operations on dirpaths *) +let empty_dirpath = make_dirpath [] + +let default_module_name = id_of_string "Top" +let default_module = make_dirpath [default_module_name] + +(*s Roots of the space of absolute names *) +let coq_root = id_of_string "Coq" +let default_root_prefix = make_dirpath [] + +let restrict_path n sp = + let dir, s = repr_path sp in + let (dir',_) = list_chop n (repr_dirpath dir) in + Names.make_path (make_dirpath dir') s + +(* Pop the last n module idents *) +let extract_dirpath_prefix n dir = + let (_,dir') = list_chop n (repr_dirpath dir) in + make_dirpath dir' + +let dirpath_prefix p = match repr_dirpath p with + | [] -> anomaly "dirpath_prefix: empty dirpath" + | _::l -> make_dirpath l + +let is_dirpath_prefix_of d1 d2 = + list_prefix_of (List.rev (repr_dirpath d1)) (List.rev (repr_dirpath d2)) + +(* To know how qualified a name should be to be understood in the current env*) +let add_dirpath_prefix id d = make_dirpath (repr_dirpath d @ [id]) + +let split_dirpath d = + let l = repr_dirpath d in (make_dirpath (List.tl l), List.hd l) + +let extend_dirpath p id = make_dirpath (id :: repr_dirpath p) + + +(* Section paths *) + +let dirpath sp = let (p,_) = repr_path sp in p +let basename sp = let (_,id) = repr_path sp in id + +let path_of_constructor env ((sp,tyi),ind) = + let mib = Environ.lookup_mind sp env in + let mip = mib.mind_packets.(tyi) in + let (pa,_) = repr_path sp in + Names.make_path pa (mip.mind_consnames.(ind-1)) + +let path_of_inductive env (sp,tyi) = + if tyi = 0 then sp + else + let mib = Environ.lookup_mind sp env in + let mip = mib.mind_packets.(tyi) in + let (pa,_) = repr_path sp in + Names.make_path pa (mip.mind_typename) + +(* parsing *) +let parse_sp s = + let len = String.length s in + let rec decoupe_dirs n = + try + let pos = String.index_from s n '.' in + let dir = String.sub s n (pos-n) in + let dirs,n' = decoupe_dirs (succ pos) in + (id_of_string dir)::dirs,n' + with + | Not_found -> [],n + in + if len = 0 then invalid_arg "parse_section_path"; + let dirs,n = decoupe_dirs 0 in + let id = String.sub s n (len-n) in + make_dirpath (List.rev dirs), (id_of_string id) + +let dirpath_of_string s = + try + let sl,s = parse_sp s in + extend_dirpath sl s + with + | Invalid_argument _ -> invalid_arg "dirpath_of_string" + +let path_of_string s = + try + let sl,s = parse_sp s in + make_path sl s + with + | Invalid_argument _ -> invalid_arg "path_of_string" diff --git a/library/nameops.mli b/library/nameops.mli new file mode 100644 index 000000000..fc5bc6a6a --- /dev/null +++ b/library/nameops.mli @@ -0,0 +1,71 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +(* $Id$ *) + +open Names +open Term +open Environ + +(* Identifiers and names *) +val wildcard : identifier + +val make_ident : string -> int option -> identifier +val repr_ident : identifier -> string * int option + +val atompart_of_id : identifier -> string + +val add_suffix : identifier -> string -> identifier +val add_prefix : string -> identifier -> identifier + +val lift_ident : identifier -> identifier +val next_ident_away : identifier -> identifier list -> identifier +val next_ident_away_from : identifier -> identifier list -> identifier + +val next_name_away : name -> identifier list -> identifier +val next_name_away_with_default : + string -> name -> identifier list -> identifier + +val out_name : name -> identifier + +(* Section and module mechanism: dealinng with dir paths *) +val empty_dirpath : dir_path +val default_module : dir_path + +(* This is the root of the standard library of Coq *) +val coq_root : module_ident + +(* This is the default root prefix for developments which doesn't + mention a root *) +val default_root_prefix : dir_path + + +val dirpath_of_string : string -> dir_path +val path_of_string : string -> section_path + +val path_of_constructor : env -> constructor -> section_path +val path_of_inductive : env -> inductive -> section_path + + +val dirpath : section_path -> dir_path +val basename : section_path -> identifier + +(* Give the immediate prefix of a [dir_path] *) +val dirpath_prefix : dir_path -> dir_path + +(* Give the immediate prefix and basename of a [dir_path] *) +val split_dirpath : dir_path -> dir_path * identifier + +val extend_dirpath : dir_path -> module_ident -> dir_path +val add_dirpath_prefix : module_ident -> dir_path -> dir_path + +val extract_dirpath_prefix : int -> dir_path -> dir_path +val is_dirpath_prefix_of : dir_path -> dir_path -> bool + +val restrict_path : int -> section_path -> section_path + diff --git a/library/nametab.ml b/library/nametab.ml index 309841796..9348ff30d 100755 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -11,21 +11,20 @@ open Util open Pp open Names +open Nameops +open Declarations (*s qualified names *) -type qualid = dir_path * identifier +type qualid = section_path -let make_qualid p id = (p,id) -let repr_qualid q = q +let make_qualid = make_path +let repr_qualid = repr_path -let empty_dirpath = make_dirpath [] -let make_short_qualid id = (empty_dirpath,id) +let string_of_qualid = string_of_path +let pr_qualid = pr_sp -let string_of_qualid (l,id) = string_of_path (make_path l id CCI) - -let pr_qualid p = pr_str (string_of_qualid p) - -let qualid_of_sp sp = make_qualid (dirpath sp) (basename sp) +let qualid_of_sp sp = sp +let make_short_qualid id = make_qualid empty_dirpath id let qualid_of_dirpath dir = let (l,a) = split_dirpath dir in make_qualid l a @@ -41,24 +40,38 @@ let error_global_constant_not_found_loc loc q = let error_global_not_found q = raise (GlobalizationError q) -(*s Roots of the space of absolute names *) - -let coq_root = id_of_string "Coq" -let default_root_prefix = make_dirpath [] - -(* Obsolčte -let roots = ref [] -let push_library_root = function - | [] -> () - | s::_ -> roots := list_add_set s !roots -*) -let push_library_root s = () - (* Constructions and syntactic definitions live in the same space *) +type global_reference = + | VarRef of variable + | ConstRef of constant + | IndRef of inductive + | ConstructRef of constructor + type extended_global_reference = | TrueGlobal of global_reference | SyntacticDef of section_path +let sp_of_global env = function + | VarRef id -> make_path empty_dirpath id + | ConstRef sp -> sp + | IndRef (sp,tyi) -> + (* Does not work with extracted inductive types when the first + inductive is logic : if tyi=0 then basename sp else *) + let mib = Environ.lookup_mind sp env in + assert (tyi < mib.mind_ntypes && tyi >= 0); + let mip = mib.mind_packets.(tyi) in + let (p,_) = repr_path sp in + make_path p mip.mind_typename + | ConstructRef ((sp,tyi),i) -> + let mib = Environ.lookup_mind sp env in + assert (tyi < mib.mind_ntypes && i >= 0); + let mip = mib.mind_packets.(tyi) in + assert (i <= Array.length mip.mind_consnames && i > 0); + let (p,_) = repr_path sp in + make_path p mip.mind_consnames.(i-1) + + +(* Dictionaries of short names *) type 'a nametree = ('a option * 'a nametree ModIdmap.t) type ccitab = extended_global_reference nametree Idmap.t type objtab = section_path nametree Idmap.t @@ -69,15 +82,19 @@ let the_libtab = ref (ModIdmap.empty : dirtab) let the_sectab = ref (ModIdmap.empty : dirtab) let the_objtab = ref (Idmap.empty : objtab) -let dirpath_of_reference = function - | ConstRef sp -> dirpath sp - | VarRef sp -> dirpath sp - | ConstructRef ((sp,_),_) -> dirpath sp - | IndRef (sp,_) -> dirpath sp +let dirpath_of_reference ref = + let sp = match ref with + | ConstRef sp -> sp + | VarRef id -> make_path empty_dirpath id + | ConstructRef ((sp,_),_) -> sp + | IndRef (sp,_) -> sp in + let (p,_) = repr_path sp in + p let dirpath_of_extended_ref = function | TrueGlobal ref -> dirpath_of_reference ref - | SyntacticDef sp -> dirpath sp + | SyntacticDef sp -> + let (p,_) = repr_path sp in p (* How [visibility] works: a value of [0] means all suffixes of [dir] are allowed to access the object, a value of [1] means all suffixes, except the @@ -94,7 +111,7 @@ let dirpath_of_extended_ref = function (* We add a binding of [[modid1;...;modidn;id]] to [o] in the name tab *) (* We proceed in the reverse way, looking first to [id] *) let push_tree extract_dirpath tab visibility dir o = - let extract = option_app (fun c -> rev_repr_dirpath (extract_dirpath c)) in + let extract = option_app (fun c -> repr_dirpath (extract_dirpath c)) in let rec push level (current,dirmap) = function | modid :: path as dir -> let mc = @@ -112,7 +129,7 @@ let push_tree extract_dirpath tab visibility dir o = else current in (this, ModIdmap.add modid (push (level+1) mc path) dirmap) | [] -> (Some o,dirmap) in - push 0 tab (rev_repr_dirpath dir) + push 0 tab (repr_dirpath dir) let push_idtree extract_dirpath tab n dir id o = let modtab = @@ -122,7 +139,8 @@ let push_idtree extract_dirpath tab n dir id o = let push_long_names_ccipath = push_idtree dirpath_of_extended_ref the_ccitab let push_short_name_ccipath = push_idtree dirpath_of_extended_ref the_ccitab -let push_short_name_objpath = push_idtree dirpath the_objtab +let push_short_name_objpath = + push_idtree (fun sp -> let (p,_) = repr_path sp in p) the_objtab let push_modidtree tab dir id o = let modtab = @@ -140,7 +158,7 @@ let push_long_names_libpath = push_modidtree the_libtab Parameter but also Remark and Fact) *) let push_cci n sp ref = - let dir, s = repr_qualid (qualid_of_sp sp) in + let dir, s = repr_path sp in (* We push partially qualified name (with at least one prefix) *) push_long_names_ccipath n dir s (TrueGlobal ref) @@ -149,7 +167,7 @@ let push = push_cci (* This is for Syntactic Definitions *) let push_syntactic_definition sp = - let dir, s = repr_qualid (qualid_of_sp sp) in + let dir, s = repr_path sp in push_long_names_ccipath 0 dir s (SyntacticDef sp) let push_short_name_syntactic_definition sp = @@ -164,7 +182,6 @@ let push_short_name_object sp = push_short_name_objpath 0 empty_dirpath s sp (* This is to remember absolute Section/Module names and to avoid redundancy *) - let push_section fulldir = let dir, s = split_dirpath fulldir in (* We push all partially qualified name *) @@ -173,7 +190,7 @@ let push_section fulldir = (* These are entry points to locate names *) let locate_in_tree tab dir = - let dir = rev_repr_dirpath dir in + let dir = repr_dirpath dir in let rec search (current,modidtab) = function | modid :: path -> search (ModIdmap.find modid modidtab) path | [] -> match current with Some o -> o | _ -> raise Not_found @@ -217,10 +234,9 @@ let locate_constant qid = (* TODO: restrict to defined constants *) match locate_cci qid with | TrueGlobal (ConstRef sp) -> sp - | TrueGlobal (VarRef sp) -> sp | _ -> raise Not_found -let sp_of_id _ id = match locate_cci (make_short_qualid id) with +let sp_of_id id = match locate_cci (make_short_qualid id) with | TrueGlobal ref -> ref | SyntacticDef _ -> anomaly ("sp_of_id: "^(string_of_id id) @@ -232,15 +248,16 @@ let constant_sp_of_id id = | _ -> raise Not_found let absolute_reference sp = - let a = locate_cci (qualid_of_sp sp) in - if not (dirpath_of_extended_ref a = dirpath sp) then + let a = locate_cci sp in + let (p,_) = repr_path sp in + if not (dirpath_of_extended_ref a = p) then anomaly ("Not an absolute path: "^(string_of_path sp)); match a with | TrueGlobal ref -> ref | _ -> raise Not_found let locate_in_absolute_module dir id = - absolute_reference (make_path dir id CCI) + absolute_reference (make_path dir id) let global loc qid = try match extended_locate qid with @@ -253,13 +270,28 @@ let global loc qid = error_global_not_found_loc loc qid let exists_cci sp = - try let _ = locate_cci (qualid_of_sp sp) in true + try let _ = locate_cci sp in true with Not_found -> false let exists_section dir = try let _ = locate_section (qualid_of_dirpath dir) in true with Not_found -> false + +(* For a sp Coq.A.B.x, try to find the shortest among x, B.x, A.B.x + and Coq.A.B.x is a qualid that denotes the same object. *) +let qualid_of_global env ref = + let sp = sp_of_global env ref in + let (pth,id) = repr_path sp in + let rec find_visible dir qdir = + let qid = make_qualid qdir id in + if (try locate qid = ref with Not_found -> false) then qid + else match dir with + | [] -> qualid_of_sp sp + | a::l -> find_visible l (add_dirpath_prefix a qdir) + in + find_visible (repr_dirpath pth) (make_dirpath []) + (********************************************************************) (********************************************************************) @@ -272,21 +304,18 @@ let init () = the_libtab := ModIdmap.empty; the_sectab := ModIdmap.empty; the_objtab := Idmap.empty -(* ;roots := []*) let freeze () = !the_ccitab, !the_libtab, !the_sectab, !the_objtab -(* ,!roots*) -let unfreeze (mc,ml,ms,mo(*,r*)) = +let unfreeze (mc,ml,ms,mo) = the_ccitab := mc; the_libtab := ml; the_sectab := ms; - the_objtab := mo(*; - roots := r*) + the_objtab := mo let _ = Summary.declare_summary "names" diff --git a/library/nametab.mli b/library/nametab.mli index 5fb7eb237..6cf3f8673 100755 --- a/library/nametab.mli +++ b/library/nametab.mli @@ -17,6 +17,16 @@ open Names (*s This module contains the table for globalization, which associates global names (section paths) to qualified names. *) +type global_reference = + | VarRef of variable + | ConstRef of constant + | IndRef of inductive + | ConstructRef of constructor + +(* Finds the real name of a global (e.g. fetch the constructor names + from the inductive name and constructor number) *) +val sp_of_global : Environ.env -> global_reference -> section_path + type extended_global_reference = | TrueGlobal of global_reference | SyntacticDef of section_path @@ -33,9 +43,11 @@ val make_short_qualid : identifier -> qualid val string_of_qualid : qualid -> string val pr_qualid : qualid -> std_ppcmds -(* Turns an absolute name into a qualified name denoting the same name *) val qualid_of_sp : section_path -> qualid +(* Turns an absolute name into a qualified name denoting the same name *) +val qualid_of_global : Environ.env -> global_reference -> qualid + exception GlobalizationError of qualid exception GlobalizationConstantError of qualid @@ -56,7 +68,7 @@ val push_short_name_object : section_path -> unit val push_section : dir_path -> unit (* This should eventually disappear *) -val sp_of_id : path_kind -> identifier -> global_reference +val sp_of_id : identifier -> global_reference (*s The following functions perform globalization of qualified names *) @@ -83,15 +95,6 @@ val exists_section : dir_path -> bool (*s Roots of the space of absolute names *) -(* This is the root of the standard library of Coq *) -val coq_root : module_ident - -(* This is the default root prefix for developments which doesn't mention a root *) -val default_root_prefix : dir_path - -(* This is to declare a new root *) -val push_library_root : dir_path -> unit - (* This turns a "user" absolute name into a global reference; especially, constructor/inductive names are turned into internal references inside a block of mutual inductive *) diff --git a/library/opaque.ml b/library/opaque.ml index 26d2798b1..c672454a5 100644 --- a/library/opaque.ml +++ b/library/opaque.ml @@ -38,7 +38,8 @@ let is_evaluable env ref = | EvalVarRef id -> let (ids,sps) = !tr_state in Idpred.mem id ids & - Environ.lookup_named_value id env <> None + let (_,value,_) = Environ.lookup_named id env in + value <> None (* Modifying this state *) let set_opaque_const sp = @@ -48,8 +49,8 @@ let set_transparent_const sp = let (ids,sps) = !tr_state in let cb = Global.lookup_constant sp in if cb.const_body <> None & cb.const_opaque then - error ("Cannot make "^Global.string_of_global (ConstRef sp)^ - " transparent because it was declared opaque."); + let s = string_of_path sp in + error ("Cannot make "^s^" transparent because it was declared opaque."); tr_state := (ids, Sppred.add sp sps) let set_opaque_var id = diff --git a/parsing/astterm.ml b/parsing/astterm.ml index f9a0fdc3c..b471059f4 100644 --- a/parsing/astterm.ml +++ b/parsing/astterm.ml @@ -11,11 +11,13 @@ open Pp open Util open Names +open Nameops open Sign open Term +open Termops open Environ open Evd -open Reduction +open Reductionops open Impargs open Declare open Rawterm @@ -135,7 +137,7 @@ let interp_qualid p = | [] -> anomaly "interp_qualid: empty qualified identifier" | l -> let p, r = list_chop (List.length l -1) (List.map outnvar l) in - make_qualid (make_dirpath p) (List.hd r) + make_qualid (make_dirpath (List.rev p)) (List.hd r) let maybe_variable = function | [Nvar (_,s)] -> Some s @@ -145,44 +147,44 @@ let ids_of_ctxt ctxt = Array.to_list (Array.map (function c -> match kind_of_term c with - | IsVar id -> id + | Var id -> id | _ -> error "Astterm: arbitrary substitution of references not yet implemented") ctxt) type pattern_qualid_kind = - | IsConstrPat of loc * constructor - | IsVarPat of loc * identifier + | ConstrPat of loc * constructor + | VarPat of loc * identifier let maybe_constructor env = function | Node(loc,"QUALID",l) -> let qid = interp_qualid l in (try match kind_of_term (global_qualified_reference qid) with - | IsMutConstruct c -> IsConstrPat (loc,c) + | Construct c -> ConstrPat (loc,c) | _ -> (match maybe_variable l with | Some s -> warning ("Defined reference "^(string_of_qualid qid) ^" is here considered as a matching variable"); - IsVarPat (loc,s) + VarPat (loc,s) | _ -> error ("This reference does not denote a constructor: " ^(string_of_qualid qid))) with Not_found -> match maybe_variable l with - | Some s -> IsVarPat (loc,s) + | Some s -> VarPat (loc,s) | _ -> error ("Unknown qualified constructor: " ^(string_of_qualid qid))) (* This may happen in quotations *) | Node(loc,"MUTCONSTRUCT",[sp;Num(_,ti);Num(_,n)]) -> (* Buggy: needs to compute the context *) - IsConstrPat (loc,((ast_to_sp sp,ti),n)) + ConstrPat (loc,((ast_to_sp sp,ti),n)) | Path(loc,sp) -> (match absolute_reference sp with - | ConstructRef c -> IsConstrPat (loc,c) + | ConstructRef c -> ConstrPat (loc,c) | _ -> error ("Unknown absolute constructor name: "^(string_of_path sp))) @@ -216,11 +218,11 @@ let ast_to_global loc c = (* let ref_from_constr c = match kind_of_term c with - | IsConst (sp,ctxt) -> RConst (sp, ast_to_constr_ctxt ctxt) - | IsEvar (ev,ctxt) -> REVar (ev, ast_to_constr_ctxt ctxt) - | IsMutConstruct (csp,ctxt) -> RConstruct (csp, ast_to_constr_ctxt ctxt) - | IsMutInd (isp,ctxt) -> RInd (isp, ast_to_constr_ctxt ctxt) - | IsVar id -> RVar id (* utilisé pour coercion_value (tmp) *) + | Const (sp,ctxt) -> RConst (sp, ast_to_constr_ctxt ctxt) + | Evar (ev,ctxt) -> REVar (ev, ast_to_constr_ctxt ctxt) + | Construct (csp,ctxt) -> RConstruct (csp, ast_to_constr_ctxt ctxt) + | Ind (isp,ctxt) -> RInd (isp, ast_to_constr_ctxt ctxt) + | Var id -> RVar id (* utilisé pour coercion_value (tmp) *) | _ -> anomaly "Not a reference" *) @@ -235,10 +237,10 @@ let ast_to_var (env,impls) (vars1,vars2) loc id = try List.assoc id impls with Not_found -> [] else - let _ = lookup_id id vars2 in + let _ = lookup_named id vars2 in (* Car Fixpoint met les fns définies tmporairement comme vars de sect *) try - let ref = VarRef (find_section_variable id) in + let ref = VarRef id in implicits_of_global ref with _ -> [] in RVar (loc, id), imps @@ -255,7 +257,7 @@ let rawconstr_of_qualid env vars loc qid = (* Is it a bound variable? *) try match repr_qualid qid with - | d,s when is_empty_dirpath d -> ast_to_var env vars loc s + | d,s when repr_dirpath d = [] -> ast_to_var env vars loc s | _ -> raise Not_found with Not_found -> (* Is it a global reference or a syntactic definition? *) @@ -301,18 +303,18 @@ let rec ast_to_pattern env aliases = function | Node(_,"PATTCONSTRUCT", head::((_::_) as pl)) -> (match maybe_constructor env head with - | IsConstrPat (loc,c) -> + | ConstrPat (loc,c) -> let (idsl,pl') = List.split (List.map (ast_to_pattern env ([],[])) pl) in (aliases::(List.flatten idsl), PatCstr (loc,c,pl',alias_of aliases)) - | IsVarPat (loc,s) -> + | VarPat (loc,s) -> user_err_loc (loc,"ast_to_pattern",mssg_hd_is_not_constructor s)) | ast -> (match maybe_constructor env ast with - | IsConstrPat (loc,c) -> ([aliases], PatCstr (loc,c,[],alias_of aliases)) - | IsVarPat (loc,s) -> + | ConstrPat (loc,c) -> ([aliases], PatCstr (loc,c,[],alias_of aliases)) + | VarPat (loc,s) -> let aliases = merge_aliases aliases (name_of_nvar s) in ([aliases], PatVar (loc,alias_of aliases))) @@ -573,7 +575,7 @@ let adjust_qualid env loc ast qid = (* Is it a bound variable? *) try match repr_qualid qid with - | d,id when is_empty_dirpath d -> ast_of_var env ast id + | d,id when repr_dirpath d = [] -> ast_of_var env ast id | _ -> raise Not_found with Not_found -> (* Is it a global reference or a syntactic definition? *) @@ -636,7 +638,7 @@ let globalize_ast ast = let interp_rawconstr_gen sigma env impls allow_soapp lvar com = ast_to_rawconstr sigma (from_list (ids_of_rel_context (rel_context env)), impls) - allow_soapp (lvar,named_context env) com + allow_soapp (lvar,env) com let interp_rawconstr sigma env com = interp_rawconstr_gen sigma env [] false [] com @@ -786,7 +788,7 @@ let interp_constrpattern_gen sigma env lvar com = let c = ast_to_rawconstr sigma (from_list (ids_of_rel_context (rel_context env)), []) - true (List.map fst lvar,named_context env) com + true (List.map fst lvar,env) com and nlvar = List.map (fun (id,c) -> (id,pattern_of_constr c)) lvar in try pattern_of_rawconstr nlvar c diff --git a/parsing/coqlib.ml b/parsing/coqlib.ml index d691b8297..022b6942f 100644 --- a/parsing/coqlib.ml +++ b/parsing/coqlib.ml @@ -15,7 +15,7 @@ open Declare open Pattern open Nametab -let make_dir l = make_dirpath (List.map id_of_string l) +let make_dir l = make_dirpath (List.map id_of_string (List.rev l)) let coq_id = id_of_string "Coq" let init_id = id_of_string "Init" let arith_id = id_of_string "Arith" @@ -26,9 +26,9 @@ let logic_type_module = make_dir ["Coq";"Init";"Logic_Type"] let datatypes_module = make_dir ["Coq";"Init";"Datatypes"] let arith_module = make_dir ["Coq";"Arith";"Arith"] -let nat_path = make_path datatypes_module (id_of_string "nat") CCI +let nat_path = make_path datatypes_module (id_of_string "nat") let myvar_path = - make_path arith_module (id_of_string "My_special_variable") CCI + make_path arith_module (id_of_string "My_special_variable") let glob_nat = IndRef (nat_path,0) @@ -37,8 +37,8 @@ let glob_S = ConstructRef ((nat_path,0),2) let glob_My_special_variable_nat = ConstRef myvar_path -let eq_path = make_path logic_module (id_of_string "eq") CCI -let eqT_path = make_path logic_type_module (id_of_string "eqT") CCI +let eq_path = make_path logic_module (id_of_string "eq") +let eqT_path = make_path logic_type_module (id_of_string "eqT") let glob_eq = IndRef (eq_path,0) let glob_eqT = IndRef (eqT_path,0) diff --git a/parsing/coqlib.mli b/parsing/coqlib.mli index 1ee79d886..dc65d7ab8 100644 --- a/parsing/coqlib.mli +++ b/parsing/coqlib.mli @@ -10,6 +10,7 @@ (*i*) open Names +open Nametab open Term open Pattern (*i*) diff --git a/parsing/g_minicoq.ml4 b/parsing/g_minicoq.ml4 index 901e68631..9faf6d877 100644 --- a/parsing/g_minicoq.ml4 +++ b/parsing/g_minicoq.ml4 @@ -41,7 +41,7 @@ let inductive = Grammar.Entry.create gram "inductive" let constructor = Grammar.Entry.create gram "constructor" let command = Grammar.Entry.create gram "command" -let path_of_string s = make_path [] (id_of_string s) CCI +let path_of_string s = make_path [] (id_of_string s) EXTEND name: @@ -145,32 +145,32 @@ let rename bv = function let rec pp bv t = match kind_of_term t with - | IsSort (Prop Pos) -> [< 'sTR "Set" >] - | IsSort (Prop Null) -> [< 'sTR "Prop" >] - | IsSort (Type u) -> print_type u - | IsLambda (na, t, c) -> + | Sort (Prop Pos) -> [< 'sTR "Set" >] + | Sort (Prop Null) -> [< 'sTR "Prop" >] + | Sort (Type u) -> print_type u + | Lambda (na, t, c) -> [< 'sTR"["; print_name na; 'sTR":"; pp bv t; 'sTR"]"; pp (na::bv) c >] - | IsProd (Anonymous, t, c) -> + | Prod (Anonymous, t, c) -> [< pp bv t; 'sTR"->"; pp (Anonymous::bv) c >] - | IsProd (na, t, c) -> + | Prod (na, t, c) -> [< 'sTR"("; print_name na; 'sTR":"; pp bv t; 'sTR")"; pp (na::bv) c >] - | IsCast (c, t) -> + | Cast (c, t) -> if !print_casts then [< 'sTR"("; pp bv c; 'sTR"::"; pp bv t; 'sTR")" >] else pp bv c - | IsApp(h, v) -> + | App(h, v) -> [< 'sTR"("; pp bv h; 'sPC; prvect_with_sep (fun () -> [< 'sPC >]) (pp bv) v; 'sTR")" >] - | IsConst (sp, _) -> + | Const (sp, _) -> [< 'sTR"Const "; pr_id (basename sp) >] - | IsMutInd ((sp,i), _) -> + | Ind ((sp,i), _) -> [< 'sTR"Ind "; pr_id (basename sp); 'sTR" "; 'iNT i >] - | IsMutConstruct (((sp,i),j), _) -> + | Construct (((sp,i),j), _) -> [< 'sTR"Construct "; pr_id (basename sp); 'sTR" "; 'iNT i; 'sTR" "; 'iNT j >] - | IsVar id -> pr_id id - | IsRel n -> print_rel bv n + | Var id -> pr_id id + | Rel n -> print_rel bv n | _ -> [< 'sTR"<???>" >] let pr_term _ ctx = pp (fold_rel_context (fun _ (n,_,_) l -> n::l) ctx []) diff --git a/parsing/g_prim.ml4 b/parsing/g_prim.ml4 index 168b5bc9f..e8cd55117 100644 --- a/parsing/g_prim.ml4 +++ b/parsing/g_prim.ml4 @@ -34,7 +34,8 @@ GEXTEND Gram ; astpath: [ [ id = IDENT; (l,a) = astfields -> - Path(loc, make_path (make_dirpath (id_of_string id :: l)) a CCI) + let p = make_dirpath (List.rev (id_of_string id :: l)) in + Path(loc, make_path p a) | id = IDENT -> Nvar(loc, id_of_string id) ] ] ; diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index 21e151c11..5cbfd4954 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -196,7 +196,6 @@ GEXTEND Gram | IDENT "Delta" -> <:ast< (Delta) >> | IDENT "Iota" -> <:ast< (Iota) >> | IDENT "Zeta" -> <:ast< (Zeta) >> - | IDENT "Evar" -> <:ast< (Evar) >> | "["; idl = ne_qualidarg_list; "]" -> <:ast< (Unf ($LIST $idl)) >> | "-"; "["; idl = ne_qualidarg_list; "]" -> <:ast< (UnfBut ($LIST $idl)) >> ] ] @@ -207,7 +206,7 @@ GEXTEND Gram | IDENT "Simpl" -> <:ast< (Simpl) >> | IDENT "Cbv"; s = LIST1 red_flag -> <:ast< (Cbv ($LIST $s)) >> | IDENT "Lazy"; s = LIST1 red_flag -> <:ast< (Lazy ($LIST $s)) >> - | IDENT "Compute" -> <:ast< (Cbv (Beta) (Delta) (Evar) (Iota) (Zeta)) >> + | IDENT "Compute" -> <:ast< (Cbv (Beta) (Delta) (Iota) (Zeta)) >> | IDENT "Unfold"; ul = ne_unfold_occ_list -> <:ast< (Unfold ($LIST $ul)) >> | IDENT "Fold"; cl = constrarg_list -> <:ast< (Fold ($LIST $cl)) >> diff --git a/parsing/prettyp.ml b/parsing/prettyp.ml index 7baad745a..4ee232915 100644 --- a/parsing/prettyp.ml +++ b/parsing/prettyp.ml @@ -11,9 +11,12 @@ open Pp open Util open Names +open Nameops open Term +open Termops open Declarations open Inductive +open Inductiveops open Sign open Reduction open Environ @@ -33,11 +36,6 @@ let print_typed_value_in_env env (trm,typ) = 'sTR " : "; prtype_env env typ ; 'fNL >] let print_typed_value x = print_typed_value_in_env (Global.env ()) x - -let pkprinters = function - | FW -> (fprterm,fprterm_env) - | CCI -> (prterm,prterm_env) - | _ -> anomaly "pkprinters" let print_impl_args = function | [] -> [<>] @@ -105,19 +103,19 @@ let print_constructors envpar names types = in hV 0 [< 'sTR " "; pc >] let build_inductive sp tyi = - let mis = Global.lookup_mind_specif (sp,tyi) in - let params = mis_params_ctxt mis in + let (mib,mip) = Global.lookup_inductive (sp,tyi) in + let params = mip.mind_params_ctxt in let args = extended_rel_list 0 params in - let indf = make_ind_family (mis,args) in - let arity = get_arity_type indf in - let cstrtypes = get_constructors_types indf in - let cstrnames = mis_consnames mis in + let indf = make_ind_family ((sp,tyi),args) in + let arity = mip.mind_user_arity in + let cstrtypes = arities_of_constructors (Global.env()) (sp,tyi) in + let cstrnames = mip.mind_consnames in (IndRef (sp,tyi), params, arity, cstrnames, cstrtypes) let print_one_inductive sp tyi = let (ref, params, arity, cstrnames, cstrtypes) = build_inductive sp tyi in let env = Global.env () in - let envpar = push_rels params env in + let envpar = push_rel_context params env in (hOV 0 [< (hOV 0 [< pr_global (IndRef (sp,tyi)) ; 'bRK(1,2); print_params env params; @@ -125,26 +123,27 @@ let print_one_inductive sp tyi = 'bRK(1,2); print_constructors envpar cstrnames cstrtypes >]) let print_mutual sp = - let mipv = (Global.lookup_mind sp).mind_packets in - if Array.length mipv = 1 then + let (mib,mip) = Global.lookup_inductive (sp,0) in + let mipv = mib.mind_packets in + if Array.length mib.mind_packets = 1 then let (ref, params, arity, cstrnames, cstrtypes) = build_inductive sp 0 in let sfinite = - if mipv.(0).mind_finite then "Inductive " else "CoInductive " in + if mib.mind_finite then "Inductive " else "CoInductive " in let env = Global.env () in - let envpar = push_rels params env in + let envpar = push_rel_context params env in (hOV 0 [< 'sTR sfinite ; pr_global (IndRef (sp,0)); 'bRK(1,2); print_params env params; 'bRK(1,5); 'sTR": "; prterm_env envpar arity; 'sTR" :="; 'bRK(0,4); print_constructors envpar cstrnames cstrtypes; 'fNL; - implicit_args_msg sp mipv >] ) + implicit_args_msg sp mib.mind_packets >] ) (* Mutual [co]inductive definitions *) else let _,(mipli,miplc) = Array.fold_right (fun mi (n,(li,lc)) -> - if mi.mind_finite then (n+1,(n::li,lc)) else (n+1,(li,n::lc))) + if mib.mind_finite then (n+1,(n::li,lc)) else (n+1,(li,n::lc))) mipv (0,([],[])) in let strind = @@ -161,7 +160,7 @@ let print_mutual sp = (print_one_inductive sp) miplc); 'fNL >] in (hV 0 [< 'sTR"Mutual " ; - if mipv.(0).mind_finite then + if mib.mind_finite then [< strind; strcoind >] else [<strcoind; strind>]; @@ -270,11 +269,10 @@ let print_typed_body (val_0,typ) = let print_constant with_values sep sp = let cb = Global.lookup_constant sp in - if kind_of_path sp = CCI then - let val_0 = cb.const_body in - let typ = cb.const_type in - let impls = constant_implicits_list sp in - hOV 0 [< (match val_0 with + let val_0 = cb.const_body in + let typ = cb.const_type in + let impls = constant_implicits_list sp in + hOV 0 [< (match val_0 with | None -> [< 'sTR"*** [ "; print_basename sp; @@ -287,16 +285,8 @@ let print_constant with_values sep sp = else [< prtype typ ; 'fNL >] >]); print_impl_args impls; 'fNL >] - else - hOV 0 [< 'sTR"Fw constant " ; - print_basename sp ; 'fNL>] -let print_inductive sp = - if kind_of_path sp = CCI then - [< print_mutual sp; 'fNL >] - else - hOV 0 [< 'sTR"Fw inductive definition "; - print_basename sp; 'fNL >] +let print_inductive sp = [< print_mutual sp; 'fNL >] let print_syntactic_def sep sp = let id = basename sp in @@ -307,7 +297,7 @@ let print_leaf_entry with_values sep (sp,lobj) = let tag = object_tag lobj in match (sp,tag) with | (_,"VARIABLE") -> - print_section_variable sp + print_section_variable (basename sp) | (_,("CONSTANT"|"PARAMETER")) -> print_constant with_values sep sp | (_,"INDUCTIVE") -> @@ -439,8 +429,8 @@ let print_name qid = with Not_found -> try (* Var locale de but, pas var de section... donc pas d'implicits *) let dir,str = repr_qualid qid in - if not (is_empty_dirpath dir) then raise Not_found; - let (c,typ) = Global.lookup_named str in + if (repr_dirpath dir) <> [] then raise Not_found; + let (_,c,typ) = Global.lookup_named str in [< print_named_decl (str,c,typ) >] with Not_found -> try @@ -457,19 +447,19 @@ let print_opaque_name qid = try let x = global_qualified_reference qid in match kind_of_term x with - | IsConst cst -> + | Const cst -> let cb = Global.lookup_constant cst in - if is_defined cb then + if cb.const_body <> None then print_constant true " = " cst else error "not a defined constant" - | IsMutInd (sp,_) -> + | Ind (sp,_) -> print_mutual sp - | IsMutConstruct cstr -> - let ty = Typeops.type_of_constructor env sigma cstr in + | Construct cstr -> + let ty = Inductive.type_of_constructor env cstr in print_typed_value (x, ty) - | IsVar id -> - let (c,ty) = lookup_named id env in + | Var id -> + let (_,c,ty) = lookup_named id env in print_named_decl (id,c,ty) | _ -> assert false @@ -482,7 +472,7 @@ let print_local_context () = | [] -> [< >] | (sp,Lib.Leaf lobj)::rest -> if "VARIABLE" = object_tag lobj then - let (d,_) = get_variable sp in + let (d,_) = get_variable (basename sp) in [< print_var_rec rest; print_named_decl d >] else @@ -514,9 +504,9 @@ let fprint_judge {uj_val=trm;uj_type=typ} = let unfold_head_fconst = let rec unfrec k = match kind_of_term k with - | IsConst cst -> constant_value (Global.env ()) cst - | IsLambda (na,t,b) -> mkLambda (na,t,unfrec b) - | IsApp (f,v) -> appvect (unfrec f,v) + | Const cst -> constant_value (Global.env ()) cst + | Lambda (na,t,b) -> mkLambda (na,t,unfrec b) + | App (f,v) -> appvect (unfrec f,v) | _ -> k in unfrec diff --git a/parsing/prettyp.mli b/parsing/prettyp.mli index a50a8371f..f8ea1ba1d 100644 --- a/parsing/prettyp.mli +++ b/parsing/prettyp.mli @@ -13,9 +13,11 @@ open Pp open Names open Sign open Term +open Termops open Inductive -open Reduction open Environ +open Reductionops +open Nametab (*i*) (* A Pretty-Printer for the Calculus of Inductive Constructions. *) diff --git a/parsing/printer.ml b/parsing/printer.ml index 2d01371a5..3e664806d 100644 --- a/parsing/printer.ml +++ b/parsing/printer.ml @@ -12,6 +12,7 @@ open Pp open Util open Names open Term +open Termops open Sign open Environ open Global @@ -19,6 +20,7 @@ open Declare open Coqast open Ast open Termast +open Nametab let emacs_str s = if !Options.print_emacs then s else "" @@ -28,7 +30,7 @@ let pr_global ref = (* Il est important de laisser le let-in, car les streams s'évaluent paresseusement : il faut forcer l'évaluation pour capturer l'éventuelle levée d'une exception (le cas échoit dans le debugger) *) - let s = Global.string_of_global ref in + let s = string_of_id (id_of_global (Global.env()) ref) in [< 'sTR s >] let global_const_name sp = @@ -224,8 +226,9 @@ let pr_context_unlimited env = in [< sign_env; db_env >] -let pr_ne_context_of header k env = - if Environ.context env = empty_context then [< >] +let pr_ne_context_of header env = + if Environ.rel_context env = empty_rel_context & + Environ.named_context env = empty_named_context then [< >] else let penv = pr_context_unlimited env in [< header; penv; 'fNL >] let pr_context_limit n env = diff --git a/parsing/printer.mli b/parsing/printer.mli index 9f0d84e6d..967fa5306 100644 --- a/parsing/printer.mli +++ b/parsing/printer.mli @@ -16,6 +16,8 @@ open Sign open Environ open Rawterm open Pattern +open Nametab +open Termops (*i*) (* These are the entry points for printing terms, context, tac, ... *) @@ -42,7 +44,7 @@ val pr_ref_label : constr_label -> std_ppcmds val pr_pattern : constr_pattern -> std_ppcmds val pr_pattern_env : names_context -> constr_pattern -> std_ppcmds -val pr_ne_context_of : std_ppcmds -> path_kind -> env -> std_ppcmds +val pr_ne_context_of : std_ppcmds -> env -> std_ppcmds val pr_var_decl : env -> named_declaration -> std_ppcmds val pr_rel_decl : env -> rel_declaration -> std_ppcmds diff --git a/parsing/q_coqast.ml4 b/parsing/q_coqast.ml4 index 2161e86b6..5670b2ce5 100644 --- a/parsing/q_coqast.ml4 +++ b/parsing/q_coqast.ml4 @@ -78,13 +78,13 @@ let rec expr_of_ast = function | Coqast.Id loc id -> <:expr< Coqast.Id loc $str:id$ >> | Coqast.Str loc str -> <:expr< Coqast.Str loc $str:str$ >> | Coqast.Path loc qid -> - let l,a,_ = Names.repr_path qid in + let l,a = Names.repr_path qid in let expr_of_modid id = <:expr< Names.id_of_string $str:Names.string_of_id id$ >> in let e = List.map expr_of_modid (Names.repr_dirpath l) in let e = expr_list_of_var_list e in - <:expr< Coqast.Path loc (Names.make_path (Names.make_dirpath - $e$) (Names.id_of_string $str:Names.string_of_id a$) Names.CCI) >> + <:expr< Coqast.Path loc (Names.make_path (Names.make_dirpath $e$) + (Names.id_of_string $str:Names.string_of_id a$)) >> | Coqast.Dynamic _ _ -> failwith "Q_Coqast: dynamic: not implemented" diff --git a/parsing/search.ml b/parsing/search.ml index fc069f41e..a96567bf4 100644 --- a/parsing/search.ml +++ b/parsing/search.ml @@ -11,6 +11,7 @@ open Pp open Util open Names +open Nameops open Term open Rawterm open Declarations @@ -21,6 +22,7 @@ open Astterm open Environ open Pattern open Printer +open Nametab (* The functions print_constructors and crible implement the behavior needed for the Coq searching commands. @@ -30,7 +32,7 @@ open Printer and the constr term that represent its type. *) let print_constructors indsp fn env mip = - let lc = mind_user_lc mip in + let lc = mip.mind_user_lc in for i=1 to Array.length lc do fn (ConstructRef (indsp,i)) env (Retyping.get_type_of env Evd.empty @@ -39,10 +41,10 @@ let print_constructors indsp fn env mip = done let rec head_const c = match kind_of_term c with - | IsProd (_,_,d) -> head_const d - | IsLetIn (_,_,_,d) -> head_const d - | IsApp (f,_) -> head_const f - | IsCast (d,_) -> head_const d + | Prod (_,_,d) -> head_const d + | LetIn (_,_,_,d) -> head_const d + | App (f,_) -> head_const f + | Cast (d,_) -> head_const d | _ -> c let crible (fn : global_reference -> env -> constr -> unit) ref = @@ -53,8 +55,8 @@ let crible (fn : global_reference -> env -> constr -> unit) ref = match object_tag lobj with | "VARIABLE" -> (try - let ((idc,_,typ),_) = get_variable sp in - if (head_const typ) = const then fn (VarRef sp) env typ + let ((idc,_,typ),_) = get_variable (basename sp) in + if (head_const typ) = const then fn (VarRef idc) env typ with Not_found -> (* we are in a section *) ()) | "CONSTANT" | "PARAMETER" -> @@ -68,10 +70,9 @@ let crible (fn : global_reference -> env -> constr -> unit) ref = (Name mip.mind_typename, None, mip.mind_nf_arity)) mib.mind_packets in (match kind_of_term const with - | IsMutInd ((sp',tyi) as indsp) -> + | Ind ((sp',tyi) as indsp) -> if sp=sp' then - print_constructors indsp fn env - (mind_nth_type_packet mib tyi) + print_constructors indsp fn env mib.mind_packets.(tyi) | _ -> ()) | _ -> () in @@ -88,11 +89,11 @@ exception No_section_path let rec head c = let c = strip_outer_cast c in match kind_of_term c with - | IsProd (_,_,c) -> head c + | Prod (_,_,c) -> head c | _ -> c let constr_to_section_path c = match kind_of_term c with - | IsConst sp -> sp + | Const sp -> sp | _ -> raise No_section_path let xor a b = (a or b) & (not (a & b)) @@ -116,9 +117,9 @@ let filter_by_module (module_list:dir_path list) (accept:bool) false let gref_eq = - IndRef (make_path Coqlib.logic_module (id_of_string "eq") CCI, 0) + IndRef (make_path Coqlib.logic_module (id_of_string "eq"), 0) let gref_eqT = - IndRef (make_path Coqlib.logic_type_module (id_of_string "eqT") CCI, 0) + IndRef (make_path Coqlib.logic_type_module (id_of_string "eqT"), 0) let mk_rewrite_pattern1 eq pattern = PApp (PRef eq, [| PMeta None; pattern; PMeta None |]) diff --git a/parsing/search.mli b/parsing/search.mli index 14a0dc1e9..111858733 100644 --- a/parsing/search.mli +++ b/parsing/search.mli @@ -13,6 +13,7 @@ open Names open Term open Environ open Pattern +open Nametab (*s Search facilities. *) diff --git a/parsing/termast.ml b/parsing/termast.ml index 4a686a17e..fb9852f3b 100644 --- a/parsing/termast.ml +++ b/parsing/termast.ml @@ -12,7 +12,9 @@ open Pp open Util open Univ open Names +open Nameops open Term +open Termops open Inductive open Sign open Environ @@ -71,7 +73,7 @@ let ids_of_ctxt ctxt = Array.to_list (Array.map (function c -> match kind_of_term c with - | IsVar id -> id + | Var id -> id | _ -> error "Termast: arbitrary substitution of references not yet implemented") @@ -103,11 +105,11 @@ let ast_of_ref = function | ConstRef sp -> ast_of_constant_ref sp | IndRef sp -> ast_of_inductive_ref sp | ConstructRef sp -> ast_of_constructor_ref sp - | VarRef sp -> ast_of_ident (basename sp) + | VarRef id -> ast_of_ident id let ast_of_qualid p = let dir, s = repr_qualid p in - let args = List.map nvar ((repr_dirpath dir)@[s]) in + let args = List.map nvar ((List.rev(repr_dirpath dir))@[s]) in ope ("QUALID", args) (**********************************************************************) @@ -298,7 +300,7 @@ let ast_of_rawconstr = ast_of_raw let ast_of_constr at_top env t = let t' = if !print_casts then t - else Reduction.local_strong strip_outer_cast t in + else Reductionops.local_strong strip_outer_cast t in let avoid = if at_top then ids_of_context env else [] in ast_of_raw (Detyping.detype avoid (names_of_rel_context env) t') diff --git a/parsing/termast.mli b/parsing/termast.mli index 31dd7d25c..d8458263a 100644 --- a/parsing/termast.mli +++ b/parsing/termast.mli @@ -11,8 +11,10 @@ (*i*) open Names open Term +open Termops open Sign open Environ +open Nametab open Rawterm open Pattern (*i*) diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 39191f395..1ecb4ce2d 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -10,12 +10,14 @@ open Util open Names +open Nameops open Term +open Termops open Declarations -open Inductive +open Inductiveops open Environ open Sign -open Reduction +open Reductionops open Typeops open Type_errors @@ -53,14 +55,14 @@ let error_wrong_numarg_constructor_loc loc c n = let error_wrong_predicate_arity_loc loc env c n1 n2 = raise_pattern_matching_error (loc, env, WrongPredicateArity (c,n1,n2)) -let error_needs_inversion k env x t = +let error_needs_inversion env x t = raise (PatternMatchingError (env, NeedsInversion (x,t))) (*********************************************************************) (* A) Typing old cases *) (* This was previously in Indrec but creates existential holes *) -let mkExistential isevars env = new_isevar isevars env (new_Type ()) CCI +let mkExistential isevars env = new_isevar isevars env (new_Type ()) let norec_branch_scheme env isevars cstr = let rec crec env = function @@ -77,7 +79,7 @@ let rec_branch_scheme env isevars (sp,j) recargs cstr = | Mrec k when k=j -> let t = mkExistential isevars env in mkArrow t - (crec (push_rel_assum (Anonymous,t) env) + (crec (push_rel (Anonymous,None,t) env) (List.rev (lift_rel_context 1 (List.rev rea)),reca)) | _ -> crec (push_rel d env) (rea,reca) in mkProd (name, body_of_type c, d) @@ -89,12 +91,13 @@ let rec_branch_scheme env isevars (sp,j) recargs cstr = in crec env (List.rev cstr.cs_args,recargs) -let branch_scheme env isevars isrec (IndFamily (mis,params) as indf) = - let cstrs = get_constructors indf in +let branch_scheme env isevars isrec ((ind,params) as indf) = + let (mib,mip) = Inductive.lookup_mind_specif env ind in + let cstrs = get_constructors env indf in if isrec then array_map2 - (rec_branch_scheme env isevars (mis_inductive mis)) - (mis_recarg mis) cstrs + (rec_branch_scheme env isevars ind) + mip.mind_listrec cstrs else Array.map (norec_branch_scheme env isevars) cstrs @@ -104,7 +107,7 @@ 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 (nf_evar sigma c) else match kind_of_term (whd_betadeltaiota env sigma c) with - | IsProd (n,_,c_0) -> decrec (m-1) c_0 + | Prod (n,_,c_0) -> decrec (m-1) c_0 | _ -> failwith "Typing.concl_n" in decrec @@ -123,24 +126,25 @@ let count_rec_arg j = * where A'_bar = A_bar[p_bar <- globargs] *) let build_notdep_pred env sigma indf pred = - let arsign,_ = get_arity indf in + let arsign,_ = get_arity env indf in let nar = List.length arsign in it_mkLambda_or_LetIn_name env (lift nar pred) arsign exception NotInferable of ml_case_error let rec refresh_types t = match kind_of_term t with - | IsSort (Type _) -> new_Type () - | IsProd (na,u,v) -> mkProd (na,u,refresh_types v) + | Sort (Type _) -> new_Type () + | Prod (na,u,v) -> mkProd (na,u,refresh_types v) | _ -> t let pred_case_ml_fail env sigma isrec (IndType (indf,realargs)) (i,ft) = let pred = - let mispec,_ = dest_ind_family indf in - let recargs = mis_recarg mispec in + let (ind,params) = indf in + let (mib,mip) = Inductive.lookup_mind_specif env ind in + let recargs = mip.mind_listrec in if Array.length recargs = 0 then raise (NotInferable MlCaseAbsurd); let recargi = recargs.(i) in - let j = mis_index mispec in + let j = snd ind in (* index of inductive *) let nbrec = if isrec then count_rec_arg j recargi else 0 in let nb_arg = List.length (recargs.(i)) + nbrec in let pred = refresh_types (concl_n env sigma nb_arg ft) in @@ -188,7 +192,8 @@ let make_anonymous_patvars = (* Environment management *) let push_rels vars env = List.fold_right push_rel vars env -let push_rel_defs = List.fold_right push_rel_def +let push_rel_defs = + List.fold_right (fun (x,d,t) e -> push_rel (x,Some d,t) e) let it_mkSpecialLetIn = List.fold_left @@ -701,7 +706,7 @@ let build_aliases_context env sigma names allpats pats = List.map2 (fun l1 l2 -> List.hd l2::l1) newallpats oldallpats in let oldallpats = List.map List.tl oldallpats in let d = (na,pat,t) in - insert (push_rel_def d env) (d::sign) (n+1) + insert (push_rel (na,Some pat,t) env) (d::sign) (n+1) newallpats oldallpats (pats,names) | [], [] -> newallpats, sign, env | _ -> anomaly "Inconsistent alias and name lists" @@ -738,8 +743,8 @@ let insert_aliases env sigma aliases eqns = exception Occur let noccur_between_without_evar n m term = let rec occur_rec n c = match kind_of_term c with - | IsRel p -> if n<=p && p<n+m then raise Occur - | IsEvar (_,cl) -> () + | Rel p -> if n<=p && p<n+m then raise Occur + | Evar (_,cl) -> () | _ -> iter_constr_with_binders succ occur_rec n c in try occur_rec n term; true with Occur -> false @@ -755,7 +760,7 @@ let prepare_unif_pb typ cs = else (* TODO4-1 *) error "Inference of annotation not yet implemented in this case" in let args = extended_rel_list (-n) cs.cs_args in - let ci = applist (mkMutConstruct cs.cs_cstr, cs.cs_params@args) in + let ci = applist (mkConstruct cs.cs_cstr, cs.cs_params@args) in (* This is the problem: finding P s.t. cs_args |- (P realargs ci) = p' *) (Array.map (lift (-n)) cs.cs_concl_realargs, ci, p') @@ -837,7 +842,7 @@ let abstract_conclusion typ cs = let (sign,p) = decompose_prod_n n typ in lam_it p sign -let infer_predicate env isevars typs cstrs (IndFamily (mis,_) as indf) = +let infer_predicate env isevars typs cstrs ((mis,_) as indf) = (* Il faudra substituer les isevars a un certain moment *) if Array.length cstrs = 0 then (* "TODO4-3" *) error "Inference of annotation for empty inductive types not implemented" @@ -850,7 +855,7 @@ let infer_predicate env isevars typs cstrs (IndFamily (mis,_) as indf) = let eqns = array_map2 prepare_unif_pb typs cstrs in (* First strategy: no dependencies at all *) (* let (cclargs,_,typn) = eqns.(mis_nconstr mis -1) in*) - let (sign,_) = get_arity indf in + let (sign,_) = get_arity env indf in let mtyp = if array_exists is_Type typs then (* Heuristic to avoid comparison between non-variables algebric univs*) @@ -861,7 +866,7 @@ let infer_predicate env isevars typs cstrs (IndFamily (mis,_) as indf) = if array_for_all (fun (_,_,typ) -> the_conv_x_leq env isevars typ mtyp) eqns then (* Non dependent case -> turn it into a (dummy) dependent one *) - let sign = (Anonymous,None,build_dependent_inductive indf)::sign in + let sign = (Anonymous,None,build_dependent_inductive env indf)::sign in let pred = it_mkLambda_or_LetIn (lift (List.length sign) mtyp) sign in (true,pred) (* true = dependent -- par défaut *) else @@ -870,7 +875,7 @@ let infer_predicate env isevars typs cstrs (IndFamily (mis,_) as indf) = let predpred = it_mkLambda_or_LetIn (mkSort s) sign in let caseinfo = make_default_case_info mis in let brs = array_map2 abstract_conclusion typs cstrs in - let predbody = mkMutCase (caseinfo, (nf_betaiota predpred), mkRel 1, brs) in + let predbody = mkCase (caseinfo, (nf_betaiota predpred), mkRel 1, brs) in let pred = it_mkLambda_or_LetIn (lift (List.length sign) mtyp) sign in *) (* "TODO4-2" *) @@ -936,11 +941,11 @@ let abstract_predicate env sigma indf = function | (PrProd _ | PrCcl _ | PrNotInd _) -> anomaly "abstract_predicate: must be some LetIn" | PrLetIn ((_,copt),pred) -> - let sign,_ = get_arity indf in + let sign,_ = get_arity env indf in let dep = copt <> None in let sign' = if dep then - (Anonymous,None,build_dependent_inductive indf) :: sign + (Anonymous,None,build_dependent_inductive env indf) :: sign else sign in (dep, it_mkLambda_or_LetIn_name env (extract_predicate pred) sign') @@ -1088,7 +1093,7 @@ let build_branch current pb eqns const_info = NonDepAlias current else let params = const_info.cs_params in - DepAlias (applist (mkMutConstruct const_info.cs_cstr, params)) in + DepAlias (applist (mkConstruct const_info.cs_cstr, params)) in let history = push_history_pattern const_info.cs_nargs (AliasConstructor (partialci, const_info.cs_cstr)) @@ -1117,7 +1122,7 @@ let build_branch current pb eqns const_info = terms is relative to the current context enriched by topushs *) let ci = applist - (mkMutConstruct const_info.cs_cstr, + (mkConstruct const_info.cs_cstr, (List.map (lift const_info.cs_nargs) const_info.cs_params) @(extended_rel_list 0 const_info.cs_args)) in @@ -1160,9 +1165,8 @@ and match_current pb (n,tm) = check_all_variables typ pb.mat; compile_aliases (shift_problem current pb) | IsInd (_,(IndType(indf,realargs) as indt)) -> - let mis,_ = dest_ind_family indf in - let mind = mis_inductive mis in - let cstrs = get_constructors indf in + let mind,_ = dest_ind_family indf in + let cstrs = get_constructors pb.env indf in let eqns,onlydflt = group_equations mind current cstrs pb.mat in if (cstrs <> [||] or not (initial_history pb.history)) & onlydflt then compile_aliases (shift_problem current pb) @@ -1176,9 +1180,9 @@ and match_current pb (n,tm) = let (pred,typ,s) = find_predicate pb.env pb.isevars pb.pred brtyps cstrs current indt in - let ci = make_case_info mis None tags in + let ci = make_case_info pb.env mind None tags in pattern_status tags, - { uj_val = mkMutCase (ci, (*eta_reduce_if_rel*)(nf_betaiota pred),current,brvals); + { uj_val = mkCase (ci, (*eta_reduce_if_rel*)(nf_betaiota pred),current,brvals); uj_type = typ } and compile_further pb firstnext rest = @@ -1238,7 +1242,7 @@ let rename_env subst env = let n = ref (rel_context_length (rel_context env)) in let seen_ids = ref [] in process_rel_context - (fun env (na,c,t as d) -> + (fun (na,c,t as d) env -> let d = try let id = List.assoc !n subst in @@ -1263,7 +1267,7 @@ let prepare_initial_alias_eqn isdep tomatchl eqn = | Anonymous -> (subst, pat::stripped_pats) | Name idpat as na -> match kind_of_term tm with - | IsRel n when not (is_dependent_indtype tmtyp) & not isdep + | Rel n when not (is_dependent_indtype tmtyp) & not isdep -> (n, idpat)::subst, (unalias_pat pat::stripped_pats) | _ -> (subst, pat::stripped_pats)) eqn.patterns tomatchl ([], []) in @@ -1333,15 +1337,15 @@ let rec find_row_ind = function exception NotCoercible let inh_coerce_to_ind isevars env ty tyi = - let (ntys,_) = - splay_prod env (evars_of isevars) (mis_arity (Global.lookup_mind_specif tyi)) in + let (mib,mip) = Inductive.lookup_mind_specif env tyi in + let (ntys,_) = splay_prod env (evars_of isevars) mip.mind_nf_arity in let (_,evarl) = List.fold_right (fun (na,ty) (env,evl) -> - (push_rel_assum (na,ty) env, - (new_isevar isevars env ty CCI)::evl)) + (push_rel (na,None,ty) env, + (new_isevar isevars env ty)::evl)) ntys (env,[]) in - let expected_typ = applist (mkMutInd tyi,evarl) in + let expected_typ = applist (mkInd tyi,evarl) in (* devrait ętre indifférent d'exiger leq ou pas puisque pour un inductif cela doit ętre égal *) if the_conv_x_leq env isevars expected_typ ty then ty @@ -1364,7 +1368,7 @@ let coerce_row typing_fun isevars env cstropt tomatch = error_bad_constructor_loc cloc c mind with Induc -> error_case_not_inductive_loc - (loc_of_rawconstr tomatch) CCI env (evars_of isevars) j) + (loc_of_rawconstr tomatch) env (evars_of isevars) j) | None -> try IsInd (typ,find_rectype env (evars_of isevars) typ) with Induc -> NotInd (None,typ) @@ -1384,7 +1388,7 @@ let build_expected_arity env isevars isdep tomatchl = let cook n = function | _,IsInd (_,IndType(indf,_)) -> let indf' = lift_inductive_family n indf in - Some (build_dependent_inductive indf', fst (get_arity indf')) + Some (build_dependent_inductive env indf', fst (get_arity env indf')) | _,NotInd _ -> None in let rec buildrec n env = function @@ -1414,7 +1418,7 @@ let build_initial_predicate env sigma isdep pred tomatchl = | c,NotInd _ -> None, Some (lift n c) in let decomp_lam_force p = match kind_of_term p with - | IsLambda (_,_,c) -> c + | Lambda (_,_,c) -> c | _ -> (* eta-expansion *) applist (lift 1 p, [mkRel 1]) in let rec strip_and_adjust nargs pred = if nargs = 0 then diff --git a/pretyping/cases.mli b/pretyping/cases.mli index e44bda7d2..3126198f9 100644 --- a/pretyping/cases.mli +++ b/pretyping/cases.mli @@ -13,7 +13,7 @@ open Names open Term open Evd open Environ -open Inductive +open Inductiveops open Rawterm open Evarutil (*i*) @@ -32,7 +32,7 @@ exception PatternMatchingError of env * pattern_matching_error (* Used for old cases in pretyping *) val branch_scheme : - env -> 'a evar_defs -> bool -> inductive_family -> constr array + env -> 'a evar_defs -> bool -> inductive * constr list -> constr array val pred_case_ml_onebranch : loc -> env -> 'c evar_map -> bool -> inductive_type -> int * unsafe_judgment -> constr diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml index c4f5b13a4..96af71ce6 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -137,10 +137,9 @@ let red_allowed flags stack rk = open RedFlags let red_allowed_ref flags stack = function - | FarRelBinding _ -> red_allowed flags stack fDELTA - | VarBinding id -> red_allowed flags stack (fVAR id) - | EvarBinding _ -> red_allowed flags stack fEVAR - | ConstBinding sp -> red_allowed flags stack (fCONST sp) + | FarRelKey _ -> red_allowed flags stack fDELTA + | VarKey id -> red_allowed flags stack (fVAR id) + | ConstKey sp -> red_allowed flags stack (fCONST sp) (* Transfer application lists from a value to the stack * useful because fixpoints may be totally applied in several times @@ -190,7 +189,7 @@ let cofixp_reducible redfun flgs _ stk = let mindsp_nparams env (sp,i) = let mib = lookup_mind sp env in - (Declarations.mind_nth_type_packet mib i).Declarations.mind_nparams + mib.Declarations.mind_packets.(i).Declarations.mind_nparams (* The main recursive functions * @@ -207,17 +206,17 @@ let rec norm_head info env t stack = (* no reduction under binders *) match kind_of_term t with (* stack grows (remove casts) *) - | IsApp (head,args) -> (* Applied terms are normalized immediately; + | App (head,args) -> (* Applied terms are normalized immediately; they could be computed when getting out of the stack *) let nargs = Array.map (cbv_stack_term info TOP env) args in norm_head info env head (stack_app (Array.to_list 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 + | Case (ci,p,c,v) -> norm_head info env c (CASE(p,v,ci,env,stack)) + | Cast (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 *) - | IsRel i -> (match expand_rel i env with + | Rel i -> (match expand_rel i env with | Inl (0,v) -> reduce_const_body (cbv_norm_more info env) v stack | Inl (n,v) -> @@ -226,18 +225,14 @@ let rec norm_head info env t stack = | Inr (n,None) -> (VAL(0, mkRel n), stack) | Inr (n,Some p) -> - norm_head_ref (n-p) info env stack (FarRelBinding p)) + norm_head_ref (n-p) info env stack (FarRelKey p)) - | IsVar id -> norm_head_ref 0 info env stack (VarBinding id) + | Var id -> norm_head_ref 0 info env stack (VarKey id) - | IsConst sp -> - norm_head_ref 0 info env stack (ConstBinding sp) + | Const sp -> + norm_head_ref 0 info env stack (ConstKey sp) - | IsEvar (ev,args) -> - let evar = (ev, Array.map (cbv_norm_term info env) args) in - norm_head_ref 0 info env stack (EvarBinding evar) - - | IsLetIn (x, b, t, c) -> + | LetIn (x, b, t, c) -> (* zeta means letin are contracted; delta without zeta means we *) (* allow substitution but leave let's in place *) let zeta = red_allowed (info_flags info) stack fZETA in @@ -256,14 +251,14 @@ let rec norm_head info env t stack = (VAL(0,normt), stack) (* Considérer une coupure commutative ? *) (* non-neutral cases *) - | IsLambda (x,a,b) -> (LAM(x,a,b,env), stack) - | IsFix fix -> (FIXP(fix,env,[]), stack) - | IsCoFix cofix -> (COFIXP(cofix,env,[]), stack) - | IsMutConstruct c -> (CONSTR(c, []), stack) + | Lambda (x,a,b) -> (LAM(x,a,b,env), stack) + | Fix fix -> (FIXP(fix,env,[]), stack) + | CoFix cofix -> (COFIXP(cofix,env,[]), stack) + | Construct c -> (CONSTR(c, []), stack) (* neutral cases *) - | (IsSort _ | IsMeta _ | IsMutInd _) -> (VAL(0, t), stack) - | IsProd (x,t,c) -> + | (Sort _ | Meta _ | Ind _|Evar _) -> (VAL(0, t), stack) + | Prod (x,t,c) -> (VAL(0, mkProd (x, cbv_norm_term info env t, cbv_norm_term info (subs_lift env) c)), stack) @@ -277,11 +272,9 @@ and norm_head_ref k info env stack normt = else (VAL(0,make_constr_ref k info normt), stack) and make_constr_ref n info = function - | FarRelBinding p -> mkRel (n+p) - | VarBinding id -> mkVar id - | EvarBinding (ev,args) -> - mkEvar (ev,Array.map (cbv_norm_term info (ESID 0)) args) - | ConstBinding cst -> mkConst cst + | FarRelKey p -> mkRel (n+p) + | VarKey id -> mkVar id + | ConstKey cst -> mkConst cst (* cbv_stack_term performs weak reduction on constr t under the subs * env, with context stack, i.e. ([env]t stack). First computes weak @@ -311,9 +304,9 @@ and cbv_stack_term info stack env t = (* constructor in a Case -> IOTA (use red_under because we know there is a Case) *) - | (CONSTR((sp,n),_), APP(args,CASE(_,br,(arity,_),env,stk))) + | (CONSTR((sp,n),_), APP(args,CASE(_,br,ci,env,stk))) when red_under (info_flags info) fIOTA -> - let real_args = snd (list_chop arity args) in + let real_args = snd (list_chop ci.ci_npar args) in cbv_stack_term info (stack_app real_args stk) env br.(n-1) (* constructor of arity 0 in a Case -> IOTA ( " " )*) @@ -349,7 +342,7 @@ and apply_stack info t = function apply_stack info (applistc t (List.map (cbv_norm_value info) args)) st | CASE (ty,br,ci,env,st) -> apply_stack info - (mkMutCase (ci, cbv_norm_term info env ty, t, + (mkCase (ci, cbv_norm_term info env ty, t, Array.map (cbv_norm_term info env) br)) st @@ -382,7 +375,7 @@ and cbv_norm_value info = function (* reduction under binders *) (List.map (cbv_norm_value info) args) | CONSTR (c,args) -> applistc - (mkMutConstruct c) + (mkConstruct c) (List.map (cbv_norm_value info) args) (* with profiling *) @@ -390,12 +383,11 @@ let cbv_norm infos constr = with_stats (lazy (cbv_norm_term infos (ESID 0) constr)) -type 'a cbv_infos = (cbv_value, 'a) infos +type cbv_infos = cbv_value infos (* constant bodies are normalized at the first expansion *) -let create_cbv_infos flgs env sigma = +let create_cbv_infos flgs env = create (fun old_info c -> cbv_stack_term old_info TOP (ESID 0) c) flgs env - sigma diff --git a/pretyping/cbv.mli b/pretyping/cbv.mli index d78711137..000ed4e3f 100644 --- a/pretyping/cbv.mli +++ b/pretyping/cbv.mli @@ -22,9 +22,9 @@ open Esubst (*s Call-by-value reduction *) (* Entry point for cbv normalization of a constr *) -type 'a cbv_infos -val create_cbv_infos : flags -> env -> 'a evar_map -> 'a cbv_infos -val cbv_norm : 'a cbv_infos -> constr -> constr +type cbv_infos +val create_cbv_infos : flags -> env -> cbv_infos +val cbv_norm : cbv_infos -> constr -> constr (***********************************************************************) (*i This is for cbv debug *) @@ -52,12 +52,12 @@ val reduce_const_body : (cbv_value -> cbv_value) -> cbv_value -> cbv_stack -> cbv_value * cbv_stack (* recursive functions... *) -val cbv_stack_term : 'a cbv_infos -> +val cbv_stack_term : cbv_infos -> cbv_stack -> cbv_value subs -> constr -> cbv_value -val cbv_norm_term : 'a cbv_infos -> cbv_value subs -> constr -> constr -val cbv_norm_more : 'a cbv_infos -> cbv_value subs -> cbv_value -> cbv_value -val norm_head : 'a cbv_infos -> +val cbv_norm_term : cbv_infos -> cbv_value subs -> constr -> constr +val cbv_norm_more : cbv_infos -> cbv_value subs -> cbv_value -> cbv_value +val norm_head : cbv_infos -> cbv_value subs -> constr -> cbv_stack -> cbv_value * cbv_stack -val apply_stack : 'a cbv_infos -> constr -> cbv_stack -> constr -val cbv_norm_value : 'a cbv_infos -> cbv_value -> constr +val apply_stack : cbv_infos -> constr -> cbv_stack -> constr +val cbv_norm_value : cbv_infos -> cbv_value -> constr (* End of cbv debug section i*) diff --git a/pretyping/classops.ml b/pretyping/classops.ml index 18bb39099..9df00372c 100755 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -12,11 +12,13 @@ open Util open Pp open Options open Names +open Nametab open Environ open Libobject open Library open Declare open Term +open Termops open Rawterm (* usage qque peu general: utilise aussi dans record *) @@ -189,14 +191,14 @@ let _ = let constructor_at_head t = let rec aux t' = match kind_of_term t' with - | IsVar id -> CL_SECVAR (find_section_variable id),0 - | IsConst sp -> CL_CONST 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) - | IsApp (f,args) -> let c,_ = aux f in c, Array.length args + | Var id -> CL_SECVAR id,0 + | Const sp -> CL_CONST sp,0 + | Ind ind_sp -> CL_IND ind_sp,0 + | Prod (_,_,c) -> CL_FUN,0 + | LetIn (_,_,_,c) -> aux c + | Sort _ -> CL_SORT,0 + | Cast (c,_) -> aux (collapse_appl c) + | App (f,args) -> let c,_ = aux f in c, Array.length args | _ -> raise Not_found in aux (collapse_appl t) @@ -217,7 +219,7 @@ let class_of env sigma t = in if n = n1 then t,i else raise Not_found -let class_args_of c = snd (decomp_app c) +let class_args_of c = snd (decompose_app c) let strength_of_cl = function | CL_CONST sp -> constant_or_parameter_strength sp @@ -227,9 +229,9 @@ let strength_of_cl = function let string_of_class = function | CL_FUN -> "FUNCLASS" | CL_SORT -> "SORTCLASS" - | CL_CONST sp -> Global.string_of_global (ConstRef sp) - | CL_IND sp -> Global.string_of_global (IndRef sp) - | CL_SECVAR sp -> Global.string_of_global (VarRef sp) + | CL_CONST sp -> string_of_id (id_of_global (Global.env()) (ConstRef sp)) + | CL_IND sp -> string_of_id (id_of_global (Global.env()) (IndRef sp)) + | CL_SECVAR sp -> string_of_id (id_of_global (Global.env()) (VarRef sp)) (* coercion_value : int -> unsafe_judgment * bool *) diff --git a/pretyping/classops.mli b/pretyping/classops.mli index c68eba1dd..eaeb25bc0 100644 --- a/pretyping/classops.mli +++ b/pretyping/classops.mli @@ -10,6 +10,7 @@ (*i*) open Names +open Nametab open Term open Evd open Environ diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 84a648341..5a540353b 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -10,7 +10,7 @@ open Util open Names open Term -open Reduction +open Reductionops open Environ open Typeops open Pretype_errors @@ -32,7 +32,7 @@ let apply_coercion_args env argl funj = | h::restl -> (* On devrait pouvoir s'arranger pour qu'on ait pas ŕ faire hnf_constr *) match kind_of_term (whd_betadeltaiota env Evd.empty typ) with - | IsProd (_,c1,c2) -> + | Prod (_,c1,c2) -> (* Typage garanti par l'appel a app_coercion*) apply_rec (h::acc) (subst1 h c2) restl | _ -> anomaly "apply_coercion_args" @@ -65,8 +65,8 @@ let apply_coercion env p hj typ_cl = let inh_app_fun env isevars j = let t = whd_betadeltaiota env (evars_of isevars) j.uj_type in match kind_of_term t with - | IsProd (_,_,_) -> j - | IsEvar ev when not (is_defined_evar isevars ev) -> + | Prod (_,_,_) -> j + | Evar ev when not (is_defined_evar isevars ev) -> let (sigma',t) = define_evar_as_arrow (evars_of isevars) ev in evars_reset_evd sigma' isevars; { uj_val = j.uj_val; uj_type = t } @@ -88,14 +88,14 @@ let inh_tosort_force env isevars j = let inh_coerce_to_sort env isevars j = let typ = whd_betadeltaiota env (evars_of isevars) j.uj_type in match kind_of_term typ with - | IsSort s -> { utj_val = j.uj_val; utj_type = s } - | IsEvar ev when not (is_defined_evar isevars ev) -> + | Sort s -> { utj_val = j.uj_val; utj_type = s } + | Evar ev when not (is_defined_evar isevars ev) -> let (sigma', s) = define_evar_as_sort (evars_of isevars) ev in evars_reset_evd sigma' isevars; { utj_val = j.uj_val; utj_type = s } | _ -> let j1 = inh_tosort_force env isevars j in - type_judgment env (evars_of isevars) j1 + type_judgment env (j_nf_evar (evars_of isevars) j1) let inh_coerce_to_fail env isevars c1 hj = let hj' = @@ -120,18 +120,19 @@ let rec inh_conv_coerce_to_fail env isevars hj c1 = with NoCoercion -> (* try ... with _ -> ... is BAD *) (match kind_of_term (whd_betadeltaiota env (evars_of isevars) t), kind_of_term (whd_betadeltaiota env (evars_of isevars) c1) with - | IsProd (_,t1,t2), IsProd (name,u1,u2) -> + | Prod (_,t1,t2), Prod (name,u1,u2) -> let v' = whd_betadeltaiota env (evars_of isevars) v in if (match kind_of_term v' with - | IsLambda (_,v1,v2) -> + | Lambda (_,v1,v2) -> the_conv_x env isevars v1 u1 (* leq v1 u1? *) | _ -> false) then let (x,v1,v2) = destLambda v' in - let env1 = push_rel_assum (x,v1) env in + let env1 = push_rel (x,None,v1) env in let h2 = inh_conv_coerce_to_fail env1 isevars {uj_val = v2; uj_type = t2 } u2 in - fst (abs_rel env (evars_of isevars) x v1 h2) + { uj_val = mkLambda (x, v1, h2.uj_val); + uj_type = mkProd (x, v1, h2.uj_type) } else (* Mismatch on t1 and u1 or not a lambda: we eta-expand *) (* we look for a coercion c:u1->t1 s.t. [name:u1](v' (c x)) *) @@ -139,7 +140,7 @@ let rec inh_conv_coerce_to_fail env isevars hj c1 = let name = (match name with | Anonymous -> Name (id_of_string "x") | _ -> name) in - let env1 = push_rel_assum (name,u1) env in + let env1 = push_rel (name,None,u1) env in let h1 = inh_conv_coerce_to_fail env1 isevars {uj_val = mkRel 1; uj_type = (lift 1 u1) } @@ -149,7 +150,8 @@ let rec inh_conv_coerce_to_fail env isevars hj c1 = uj_type = subst1 h1.uj_val t2 } u2 in - fst (abs_rel env (evars_of isevars) name u1 h2) + { uj_val = mkLambda (name, u1, h2.uj_val); + uj_type = mkProd (name, u1, h2.uj_type) } | _ -> raise NoCoercion) (* Look for cj' obtained from cj by inserting coercions, s.t. cj'.typ = t *) @@ -175,7 +177,7 @@ let inh_apply_rel_list apploc env isevars argjl (funloc,funj) tycon = let resj = inh_app_fun env isevars resj in let ntyp = whd_betadeltaiota env sigma resj.uj_type in match kind_of_term ntyp with - | IsProd (na,c1,c2) -> + | Prod (na,c1,c2) -> let hj' = try inh_conv_coerce_to_fail env isevars hj c1 @@ -185,7 +187,7 @@ let inh_apply_rel_list apploc env isevars argjl (funloc,funj) tycon = let newresj = { uj_val = applist (j_val resj, [j_val hj']); uj_type = subst1 hj'.uj_val c2 } in - apply_rec (push_rel_assum (na,c1) env) (n+1) newresj restjl + apply_rec (push_rel (na,None,c1) env) (n+1) newresj restjl | _ -> error_cant_apply_not_functional_loc (Rawterm.join_loc funloc loc) env sigma resj diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 2026bdb21..405e2e16b 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -13,87 +13,16 @@ open Util open Univ open Names open Term +open Declarations open Inductive open Environ open Sign open Declare open Impargs open Rawterm - -(* Nouvelle version de renommage des variables (DEC 98) *) -(* This is the algorithm to display distinct bound variables - - - Rčgle 1 : un nom non anonyme, męme non affiché, contribue ŕ la liste - des noms ŕ éviter - - Rčgle 2 : c'est la dépendance qui décide si on affiche ou pas - - Exemple : - si bool_ind = (P:bool->Prop)(f:(P true))(f:(P false))(b:bool)(P b), alors - il est affiché (P:bool->Prop)(P true)->(P false)->(b:bool)(P b) - mais f et f0 contribue ŕ la liste des variables ŕ éviter (en supposant - que les noms f et f0 ne sont pas déjŕ pris) - Intéręt : noms homogčnes dans un but avant et aprčs Intro -*) - -type used_idents = identifier list - -exception Occur - -let occur_rel p env id = - try lookup_name_of_rel p env = Name id - with Not_found -> false (* Unbound indice : may happen in debug *) - -let occur_id env id0 c = - let rec occur n c = match kind_of_term c with - | IsVar id when id=id0 -> raise Occur - | IsConst sp when basename sp = id0 -> raise Occur - | IsMutInd ind_sp - when basename (path_of_inductive_path ind_sp) = id0 -> raise Occur - | IsMutConstruct cstr_sp - when basename (path_of_constructor_path cstr_sp) = id0 -> raise Occur - | IsRel p when p>n & occur_rel (p-n) env id0 -> raise Occur - | _ -> iter_constr_with_binders succ occur n c - in - try occur 1 c; false - with Occur -> true - -let next_name_not_occuring name l env_names t = - let rec next id = - if List.mem id l or occur_id env_names id t then next (lift_ident id) - else id - in - match name with - | Name id -> next id - | Anonymous -> id_of_string "_" - -(* Remark: Anonymous var may be dependent in Evar's contexts *) -let concrete_name l env_names n c = - 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 (mkRel 1) c then (Some fresh_id) else None in - (idopt, fresh_id::l) - -let concrete_let_name l env_names n c = - let fresh_id = next_name_not_occuring n l env_names c in - (Name fresh_id, fresh_id::l) - - (* Returns the list of global variables and constants in a term *) -let global_vars_and_consts t = - 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' - | 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) - -let used_of = global_vars_and_consts +open Nameops +open Termops +open Nametab (****************************************************************************) (* Tools for printing of Cases *) @@ -101,23 +30,20 @@ let used_of = global_vars_and_consts let encode_inductive ref = let indsp = match ref with | IndRef indsp -> indsp - | _ -> errorlabstrm "indsp_of_id" - [< 'sTR ((Global.string_of_global ref)^" is not an inductive type") >] - in - let mis = Global.lookup_mind_specif indsp in - let constr_lengths = Array.map List.length (mis_recarg mis) in + | _ -> + let id = basename (Nametab.sp_of_global (Global.env()) ref) in + errorlabstrm "indsp_of_id" + [< pr_id id; 'sTR" is not an inductive type" >] in + let (mib,mip) = Global.lookup_inductive indsp in + let constr_lengths = Array.map List.length mip.mind_listrec in (indsp,constr_lengths) let constr_nargs indsp = - let mis = Global.lookup_mind_specif indsp in - let nparams = mis_nparams mis in - Array.map (fun t -> List.length (fst (decompose_prod_assum t)) - nparams) - (mis_nf_lc mis) - -let sp_of_spi (refsp,tyi) = - let mip = Declarations.mind_nth_type_packet (Global.lookup_mind refsp) tyi in - let (pa,_,k) = repr_path refsp in - make_path pa mip.Declarations.mind_typename k + let (mib,mip) = Global.lookup_inductive indsp in + let nparams = mip.mind_nparams in + Array.map + (fun t -> List.length (fst (decompose_prod_assum t)) - nparams) + mip.mind_nf_lc (* Parameterization of the translation from constr to ast *) @@ -142,7 +68,8 @@ module PrintingCasesMake = let check (_,lc) = if not (Test.test lc) then errorlabstrm "check_encode" [< 'sTR Test.error_message >] - let printer (spi,_) = [< 'sTR(string_of_path (sp_of_spi spi)) >] + let printer (ind,_) = + pr_id (basename (path_of_inductive (Global.env()) ind)) let key = Goptions.SecondaryTable ("Printing",Test.field) let title = Test.title let member_message = Test.member_message @@ -155,13 +82,12 @@ module PrintingCasesIf = let error_message = "This type cannot be seen as a boolean type" let field = "If" let title = "Types leading to pretty-printing of Cases using a `if' form: " - let member_message id = function - | true -> - "Cases on elements of " ^ (Global.string_of_global id) - ^ " are printed using a `if' form" - | false -> - "Cases on elements of " ^ (Global.string_of_global id) - ^ " are not printed using `if' form" + let member_message ref b = + let s = string_of_id (basename (sp_of_global (Global.env()) ref)) in + if b then + "Cases on elements of " ^ s ^ " are printed using a `if' form" + else + "Cases on elements of " ^ s ^ " are not printed using `if' form" end) module PrintingCasesLet = @@ -171,21 +97,22 @@ module PrintingCasesLet = let field = "Let" let title = "Types leading to a pretty-printing of Cases using a `let' form:" - let member_message id = function - | true -> - "Cases on elements of " ^ (Global.string_of_global id) - ^ " are printed using a `let' form" - | false -> - "Cases on elements of " ^ (Global.string_of_global id) - ^ " are not printed using a `let' form" + let member_message ref b = + let s = string_of_id (basename (sp_of_global (Global.env()) ref)) in + if b then + "Cases on elements of " ^ s ^ " are printed using a `let' form" + else + "Cases on elements of " ^ s ^ " are not printed using a `let' form" end) module PrintingIf = Goptions.MakeIdentTable(PrintingCasesIf) module PrintingLet = Goptions.MakeIdentTable(PrintingCasesLet) -let force_let (_,(indsp,_,_,_,_)) = +let force_let ci = + let indsp = ci.ci_ind in let lc = constr_nargs indsp in PrintingLet.active (indsp,lc) -let force_if (_,(indsp,_,_,_,_)) = +let force_if ci = + let indsp = ci.ci_ind in let lc = constr_nargs indsp in PrintingIf.active (indsp,lc) (* Options for printing or not wildcard and synthetisable types *) @@ -241,68 +168,70 @@ let computable p k = let lookup_name_as_renamed ctxt t s = let rec lookup avoid env_names n c = match kind_of_term c with - | IsProd (name,_,c') -> + | Prod (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')) - | IsLetIn (name,_,_,c') -> + | LetIn (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')) - | IsCast (c,_) -> lookup avoid env_names n c + | Cast (c,_) -> lookup avoid env_names n c | _ -> None in lookup (ids_of_named_context ctxt) empty_names_context 1 t let lookup_index_as_renamed t n = let rec lookup n d c = match kind_of_term c with - | IsProd (name,_,c') -> + | Prod (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') - | IsLetIn (name,_,_,c') -> + | LetIn (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') - | IsCast (c,_) -> lookup n d c + | Cast (c,_) -> lookup n d c | _ -> None in lookup n 1 t let rec detype avoid env t = match kind_of_term (collapse_appl t) with - | IsRel n -> + | Rel n -> (try match lookup_name_of_rel n env with | Name id -> RVar (dummy_loc, id) | Anonymous -> anomaly "detype: index to an anonymous variable" with Not_found -> let s = "_UNBOUND_REL_"^(string_of_int n) in RVar (dummy_loc, id_of_string s)) - | IsMeta n -> RMeta (dummy_loc, n) - | IsVar id -> RVar (dummy_loc, id) - | IsSort (Prop c) -> RSort (dummy_loc,RProp c) - | IsSort (Type u) -> RSort (dummy_loc,RType (Some u)) - | IsCast (c1,c2) -> + | Meta n -> RMeta (dummy_loc, n) + | Var id -> RVar (dummy_loc, id) + | Sort (Prop c) -> RSort (dummy_loc,RProp c) + | Sort (Type u) -> RSort (dummy_loc,RType (Some u)) + | Cast (c1,c2) -> 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 - | IsApp (f,args) -> + | Prod (na,ty,c) -> detype_binder BProd avoid env na ty c + | Lambda (na,ty,c) -> detype_binder BLambda avoid env na ty c + | LetIn (na,b,_,c) -> detype_binder BLetIn avoid env na b c + | App (f,args) -> RApp (dummy_loc,detype avoid env f,array_map_to_list (detype avoid env) args) - | IsConst sp -> RRef (dummy_loc, ConstRef sp) - | IsEvar (ev,cl) -> + | Const sp -> RRef (dummy_loc, ConstRef sp) + | Evar (ev,cl) -> let f = REvar (dummy_loc, ev) in RApp (dummy_loc, f, List.map (detype avoid env) (Array.to_list cl)) - | IsMutInd ind_sp -> + | Ind ind_sp -> RRef (dummy_loc, IndRef ind_sp) - | IsMutConstruct cstr_sp -> + | Construct cstr_sp -> RRef (dummy_loc, ConstructRef cstr_sp) - | IsMutCase (annot,p,c,bl) -> + | Case (annot,p,c,bl) -> let synth_type = synthetize_type () in let tomatch = detype avoid env c in - let (_,(indsp,considl,k,style,tags)) = annot in + let indsp = annot.ci_ind in + let considl = annot.ci_pp_info.cnames in + let k = annot.ci_pp_info.ind_nargs in let consnargsl = constr_nargs indsp in let pred = if synth_type & computable p k & considl <> [||] then @@ -324,8 +253,8 @@ let rec detype avoid env t = in RCases (dummy_loc,tag,pred,[tomatch],eqnl) - | IsFix (nvn,recdef) -> detype_fix avoid env (RFix nvn) recdef - | IsCoFix (n,recdef) -> detype_fix avoid env (RCoFix n) recdef + | Fix (nvn,recdef) -> detype_fix avoid env (RFix nvn) recdef + | CoFix (n,recdef) -> detype_fix avoid env (RCoFix n) recdef and detype_fix avoid env fixkind (names,tys,bodies) = let lfi = Array.map (fun id -> next_name_away id avoid) names in @@ -351,15 +280,15 @@ and detype_eqn avoid env constr construct_nargs branch = detype avoid env b) else match kind_of_term b with - | IsLambda (x,_,b) -> + | Lambda (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 - | IsLetIn (x,_,_,b) -> + | LetIn (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 *) + | Cast (c,_) -> (* Oui, il y a parfois des cast *) buildrec ids patlist avoid env n c | _ -> (* eta-expansion : n'arrivera plus lorsque tous les diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli index f68c0356f..f787da2ba 100644 --- a/pretyping/detyping.mli +++ b/pretyping/detyping.mli @@ -14,6 +14,7 @@ open Term open Sign open Environ open Rawterm +open Termops (*i*) (* [detype avoid env c] turns [c], typed in [env], into a rawconstr. *) @@ -22,7 +23,8 @@ open Rawterm val detype : identifier list -> names_context -> constr -> rawconstr (* look for the index of a named var or a nondep var as it is renamed *) -val lookup_name_as_renamed : named_context -> constr -> identifier -> int option +val lookup_name_as_renamed : + named_context -> constr -> identifier -> int option val lookup_index_as_renamed : constr -> int -> int option diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 2858151c1..6269dc941 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -11,7 +11,7 @@ open Util open Names open Term -open Reduction +open Reductionops open Closure open Instantiate open Environ @@ -28,22 +28,22 @@ type flex_kind_of_term = let flex_kind_of_term c = match kind_of_term c with - | IsConst c -> MaybeFlexible (FConst c) - | IsRel n -> MaybeFlexible (FRel n) - | IsVar id -> MaybeFlexible (FVar id) - | IsEvar ev -> Flexible ev + | Const c -> MaybeFlexible (FConst c) + | Rel n -> MaybeFlexible (FRel n) + | Var id -> MaybeFlexible (FVar id) + | Evar ev -> Flexible ev | _ -> Rigid c let eval_flexible_term env = function | FConst c -> constant_opt_value env c - | FRel n -> option_app (lift n) (lookup_rel_value n env) - | FVar id -> lookup_named_value id env + | FRel n -> let (_,v,_) = lookup_rel n env in option_app (lift n) v + | FVar id -> let (_,v,_) = lookup_named id env in v let evar_apprec env isevars stack c = let rec aux s = - let (t,stack as s') = Reduction.apprec env (evars_of isevars) s in + let (t,stack as s') = Reductionops.apprec env (evars_of isevars) s in match kind_of_term t with - | IsEvar (n,_ as ev) when Evd.is_defined (evars_of isevars) n -> + | Evar (n,_ as ev) when Evd.is_defined (evars_of isevars) n -> aux (existential_value (evars_of isevars) ev, stack) | _ -> (t, list_of_stack stack) in aux (c, append_stack (Array.of_list stack) empty_stack) @@ -239,25 +239,25 @@ and evar_eqappr_x env isevars pbty (term1,l1 as appr1) (term2,l2 as appr2) = | Rigid c1, Rigid c2 -> match kind_of_term c1, kind_of_term c2 with - | IsCast (c1,_), _ -> evar_eqappr_x env isevars pbty (c1,l1) appr2 + | Cast (c1,_), _ -> evar_eqappr_x env isevars pbty (c1,l1) appr2 - | _, IsCast (c2,_) -> evar_eqappr_x env isevars pbty appr1 (c2,l2) + | _, Cast (c2,_) -> evar_eqappr_x env isevars pbty appr1 (c2,l2) - | IsSort s1, IsSort s2 when l1=[] & l2=[] -> base_sort_cmp pbty s1 s2 + | Sort s1, Sort s2 when l1=[] & l2=[] -> base_sort_cmp pbty s1 s2 - | IsLambda (na,c1,c'1), IsLambda (_,c2,c'2) when l1=[] & l2=[] -> + | Lambda (na,c1,c'1), Lambda (_,c2,c'2) when l1=[] & l2=[] -> evar_conv_x env isevars CONV c1 c2 & (let c = nf_evar (evars_of isevars) c1 in - evar_conv_x (push_rel_assum (na,c) env) isevars CONV c'1 c'2) + evar_conv_x (push_rel (na,None,c) env) isevars CONV c'1 c'2) - | IsLetIn (na,b1,t1,c'1), IsLetIn (_,b2,_,c'2) -> + | LetIn (na,b1,t1,c'1), LetIn (_,b2,_,c'2) -> let f1 () = evar_conv_x env isevars CONV b1 b2 & (let b = nf_evar (evars_of isevars) b1 in let t = nf_evar (evars_of isevars) t1 in - evar_conv_x (push_rel_def (na,b,t) env) isevars pbty c'1 c'2) + evar_conv_x (push_rel (na,Some b,t) 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 () = @@ -267,35 +267,35 @@ and evar_eqappr_x env isevars pbty (term1,l1 as appr1) (term2,l2 as appr2) = in ise_try isevars [f1; f2] - | IsLetIn (_,b1,_,c'1), _ ->(* On fait commuter les args avec le Let *) + | LetIn (_,b1,_,c'1), _ ->(* On fait commuter les args avec le Let *) let appr1 = evar_apprec env isevars l1 (subst1 b1 c'1) in evar_eqappr_x env isevars pbty appr1 appr2 - | _, IsLetIn (_,b2,_,c'2) -> + | _, LetIn (_,b2,_,c'2) -> let appr2 = evar_apprec env isevars l2 (subst1 b2 c'2) in evar_eqappr_x env isevars pbty appr1 appr2 - | IsProd (n,c1,c'1), IsProd (_,c2,c'2) when l1=[] & l2=[] -> + | Prod (n,c1,c'1), Prod (_,c2,c'2) when l1=[] & l2=[] -> evar_conv_x env isevars CONV c1 c2 & (let c = nf_evar (evars_of isevars) c1 in - evar_conv_x (push_rel_assum (n,c) env) isevars pbty c'1 c'2) + evar_conv_x (push_rel (n,None,c) env) isevars pbty c'1 c'2) - | IsMutInd sp1, IsMutInd sp2 -> + | Ind sp1, Ind sp2 -> sp1=sp2 & list_for_all2eq (evar_conv_x env isevars CONV) l1 l2 - | IsMutConstruct sp1, IsMutConstruct sp2 -> + | Construct sp1, Construct sp2 -> sp1=sp2 & list_for_all2eq (evar_conv_x env isevars CONV) l1 l2 - | IsMutCase (_,p1,c1,cl1), IsMutCase (_,p2,c2,cl2) -> + | Case (_,p1,c1,cl1), Case (_,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) l1 l2) - | IsFix (li1,(_,tys1,bds1 as recdef1)), IsFix (li2,(_,tys2,bds2)) -> + | Fix (li1,(_,tys1,bds1 as recdef1)), Fix (li2,(_,tys2,bds2)) -> li1=li2 & (array_for_all2 (evar_conv_x env isevars CONV) tys1 tys2) & (array_for_all2 @@ -303,7 +303,7 @@ and evar_eqappr_x env isevars pbty (term1,l1 as appr1) (term2,l2 as appr2) = bds1 bds2) & (list_for_all2eq (evar_conv_x env isevars CONV) l1 l2) - | IsCoFix (i1,(_,tys1,bds1 as recdef1)), IsCoFix (i2,(_,tys2,bds2)) -> + | CoFix (i1,(_,tys1,bds1 as recdef1)), CoFix (i2,(_,tys2,bds2)) -> i1=i2 & (array_for_all2 (evar_conv_x env isevars CONV) tys1 tys2) & (array_for_all2 @@ -311,22 +311,22 @@ and evar_eqappr_x env isevars pbty (term1,l1 as appr1) (term2,l2 as appr2) = bds1 bds2) & (list_for_all2eq (evar_conv_x env isevars CONV) l1 l2) - | (IsMeta _ | IsLambda _), _ -> false - | _, (IsMeta _ | IsLambda _) -> false + | (Meta _ | Lambda _), _ -> false + | _, (Meta _ | Lambda _) -> false - | (IsMutInd _ | IsMutConstruct _ | IsSort _ | IsProd _), _ -> false - | _, (IsMutInd _ | IsMutConstruct _ | IsSort _ | IsProd _) -> false + | (Ind _ | Construct _ | Sort _ | Prod _), _ -> false + | _, (Ind _ | Construct _ | Sort _ | Prod _) -> false - | (IsApp _ | IsMutCase _ | IsFix _ | IsCoFix _), - (IsApp _ | IsMutCase _ | IsFix _ | IsCoFix _) -> false + | (App _ | Case _ | Fix _ | CoFix _), + (App _ | Case _ | Fix _ | CoFix _) -> false - | (IsRel _ | IsVar _ | IsConst _ | IsEvar _), _ -> assert false - | _, (IsRel _ | IsVar _ | IsConst _ | IsEvar _) -> assert false + | (Rel _ | Var _ | Const _ | Evar _), _ -> assert false + | _, (Rel _ | Var _ | Const _ | Evar _) -> assert false and conv_record env isevars (c,bs,(params,params1),(us,us2),(ts,ts1),c1) = let ks = List.fold_left - (fun ks b -> (new_isevar isevars env (substl ks b) CCI) :: ks) + (fun ks b -> (new_isevar isevars env (substl ks b)) :: ks) [] bs in if (list_for_all2eq diff --git a/pretyping/evarconv.mli b/pretyping/evarconv.mli index 9b45a5094..06a866f48 100644 --- a/pretyping/evarconv.mli +++ b/pretyping/evarconv.mli @@ -12,7 +12,7 @@ open Term open Sign open Environ -open Reduction +open Reductionops open Evarutil (*i*) diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml index a1432ff88..533292ec7 100644 --- a/pretyping/evarutil.ml +++ b/pretyping/evarutil.ml @@ -11,13 +11,15 @@ open Util open Pp open Names +open Nameops open Univ open Term +open Termops open Sign open Environ open Evd open Instantiate -open Reduction +open Reductionops open Indrec open Pretype_errors @@ -54,7 +56,7 @@ exception Uninstantiated_evar of int let rec whd_ise sigma c = match kind_of_term c with - | IsEvar (ev,args) when Evd.in_dom sigma ev -> + | Evar (ev,args) when Evd.in_dom sigma ev -> if Evd.is_defined sigma ev then whd_ise sigma (existential_value sigma (ev,args)) else raise (Uninstantiated_evar ev) @@ -65,10 +67,10 @@ let rec whd_ise sigma c = let whd_castappevar_stack sigma c = let rec whrec (c, l as s) = match kind_of_term c with - | IsEvar (ev,args) when Evd.in_dom sigma ev & Evd.is_defined sigma ev -> + | Evar (ev,args) when Evd.in_dom sigma ev & Evd.is_defined sigma ev -> whrec (existential_value sigma (ev,args), l) - | IsCast (c,_) -> whrec (c, l) - | IsApp (f,args) -> whrec (f, Array.fold_right (fun a l -> a::l) args l) + | Cast (c,_) -> whrec (c, l) + | App (f,args) -> whrec (f, Array.fold_right (fun a l -> a::l) args l) | _ -> s in whrec (c, []) @@ -146,12 +148,12 @@ let split_evar_to_arrow sigma (ev,args) = let (sigma1,dom) = new_type_var evenv sigma in let hyps = evd.evar_hyps in let nvar = next_ident_away (id_of_string "x") (ids_of_named_context hyps) in - let newenv = push_named_assum (nvar, dom) evenv in + let newenv = push_named_decl (nvar, None, dom) 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 sigma3 = Evd.define sigma2 ev prod in - let dsp = num_of_evar dom in - let rsp = num_of_evar rng in + let dsp = fst (destEvar dom) in + let rsp = fst (destEvar rng) in (sigma3, prod, (dsp,args), (rsp, array_cons (mkRel 1) (Array.map (lift 1) args))) @@ -188,7 +190,7 @@ let do_restrict_hyps sigma ev args = (hyps,([],[])) args in let sign' = List.rev rsign in - let env' = change_hyps (fun _ -> sign') env in + let env' = reset_with_named_context sign' env in let instance = make_evar_instance env' in let (sigma',nc) = new_isevar_sign env' sigma evd.evar_concl instance in let sigma'' = Evd.define sigma' ev nc in @@ -241,7 +243,7 @@ let is_defined_evar isevars (n,_) = Evd.is_defined isevars.evars n (* Does k corresponds to an (un)defined existential ? *) let ise_undefined isevars c = match kind_of_term c with - | IsEvar ev -> not (is_defined_evar isevars ev) + | Evar ev -> not (is_defined_evar isevars ev) | _ -> false let need_restriction isevars args = not (array_for_all closed0 args) @@ -259,10 +261,10 @@ let real_clean isevars ev args rhs = let subst = List.map (fun (x,y) -> (y,mkVar x)) (filter_unique args) in let rec subs k t = match kind_of_term t with - | IsRel i -> + | Rel i -> if i<=k then t else (try List.assoc (mkRel (i-k)) subst with Not_found -> t) - | IsEvar (ev,args) -> + | Evar (ev,args) -> let args' = Array.map (subs k) args in if need_restriction isevars args' then if Evd.is_defined isevars.evars ev then @@ -275,7 +277,7 @@ let real_clean isevars ev args rhs = end else mkEvar (ev,args') - | IsVar _ -> (try List.assoc t subst with Not_found -> t) + | Var _ -> (try List.assoc t subst with Not_found -> t) | _ -> map_constr_with_binders succ subs k t in let body = subs 0 rhs in @@ -305,7 +307,22 @@ let make_subst env 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 *) -let new_isevar isevars env typ k = +let push_rel_context_to_named_context env = + let sign0 = named_context env in + let (subst,_,sign) = + Sign.fold_rel_context + (fun (na,c,t) (subst,avoid,sign) -> + let na = if na = Anonymous then Name(id_of_string"_") else na in + let id = next_name_away na avoid in + ((mkVar id)::subst, + id::avoid, + add_named_decl (id,option_app (substl subst) c, + type_app (substl subst) t) + sign)) + (rel_context env) ([],ids_of_named_context sign0,sign0) + in (subst, reset_with_named_context sign env) + +let new_isevar isevars env typ = let subst,env' = push_rel_context_to_named_context env in let typ' = substl subst typ in let instance = make_evar_instance_with_rel env in @@ -331,14 +348,10 @@ let new_isevar isevars env typ k = * ?1 would be instantiated by (le y y) but y is not in the scope of ?1 *) -let keep_rels_and_vars c = match kind_of_term c with - | IsVar _ | IsRel _ -> c - | _ -> mkImplicit (* Mettre mkMeta ?? *) - let evar_define isevars (ev,argsv) rhs = if occur_evar ev rhs then error_occur_check empty_env (evars_of isevars) ev rhs; - let args = List.map keep_rels_and_vars (Array.to_list argsv) in + let args = Array.to_list argsv in let evd = ise_map isevars ev in (* the substitution to invert *) let worklist = make_subst (evar_env evd) args in @@ -356,17 +369,17 @@ let has_undefined_isevars isevars t = let head_is_evar isevars = let rec hrec k = match kind_of_term k with - | IsEvar (n,_) -> not (Evd.is_defined isevars.evars n) - | IsApp (f,_) -> hrec f - | IsCast (c,_) -> hrec c + | Evar (n,_) -> not (Evd.is_defined isevars.evars n) + | App (f,_) -> hrec f + | Cast (c,_) -> hrec c | _ -> false in hrec let rec is_eliminator c = match kind_of_term c with - | IsApp _ -> true - | IsMutCase _ -> true - | IsCast (c,_) -> is_eliminator c + | App _ -> true + | Case _ -> true + | Cast (c,_) -> is_eliminator c | _ -> false let head_is_embedded_evar isevars c = @@ -374,10 +387,10 @@ let head_is_embedded_evar isevars c = let head_evar = let rec hrec c = match kind_of_term c with - | IsEvar (ev,_) -> ev - | IsMutCase (_,_,c,_) -> hrec c - | IsApp (c,_) -> hrec c - | IsCast (c,_) -> hrec c + | Evar (ev,_) -> ev + | Case (_,_,c,_) -> hrec c + | App (c,_) -> hrec c + | Cast (c,_) -> hrec c | _ -> failwith "headconstant" in hrec @@ -466,7 +479,7 @@ let solve_refl conv_algo env isevars ev argsv1 argsv2 = let solve_simple_eqn conv_algo env isevars (pbty,(n1,args1 as ev1),t2) = let t2 = nf_evar isevars.evars t2 in let lsp = match kind_of_term t2 with - | IsEvar (n2,args2 as ev2) + | Evar (n2,args2 as ev2) when not (Evd.is_defined isevars.evars n2) -> if n1 = n2 then solve_refl conv_algo env isevars n1 args1 args2 @@ -522,8 +535,8 @@ let split_tycon loc env isevars = function let sigma = evars_of isevars in let t = whd_betadeltaiota env sigma c in match kind_of_term t with - | IsProd (na,dom,rng) -> Some dom, Some rng - | IsEvar (n,_ as ev) when not (Evd.is_defined isevars.evars n) -> + | Prod (na,dom,rng) -> Some dom, Some rng + | Evar (n,_ as ev) when not (Evd.is_defined isevars.evars n) -> let (sigma',_,evdom,evrng) = split_evar_to_arrow sigma ev in evars_reset_evd sigma' isevars; Some (mkEvar evdom), Some (mkEvar evrng) diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli index 73dae829a..01a2437b2 100644 --- a/pretyping/evarutil.mli +++ b/pretyping/evarutil.mli @@ -14,7 +14,7 @@ open Term open Sign open Evd open Environ -open Reduction +open Reductionops (*i*) (*s This modules provides useful functions for unification modulo evars *) @@ -22,14 +22,14 @@ open Reduction (* [whd_ise] raise [Uninstantiated_evar] if an evar remains uninstantiated; *) (* *[whd_evar]* and *[nf_evar]* leave uninstantiated evar as is *) -val nf_evar : 'a Evd.evar_map -> constr -> constr -val j_nf_evar : 'a Evd.evar_map -> unsafe_judgment -> unsafe_judgment +val nf_evar : 'a evar_map -> constr -> constr +val j_nf_evar : 'a evar_map -> unsafe_judgment -> unsafe_judgment val jl_nf_evar : - 'a Evd.evar_map -> unsafe_judgment list -> unsafe_judgment list + 'a evar_map -> unsafe_judgment list -> unsafe_judgment list val jv_nf_evar : - 'a Evd.evar_map -> unsafe_judgment array -> unsafe_judgment array + 'a evar_map -> unsafe_judgment array -> unsafe_judgment array val tj_nf_evar : - 'a Evd.evar_map -> unsafe_type_judgment -> unsafe_type_judgment + 'a evar_map -> unsafe_type_judgment -> unsafe_type_judgment (* Replacing all evars *) exception Uninstantiated_evar of int @@ -55,7 +55,7 @@ val ise_try : 'a evar_defs -> (unit -> bool) list -> bool val ise_undefined : 'a evar_defs -> constr -> bool val has_undefined_isevars : 'a evar_defs -> constr -> bool -val new_isevar : 'a evar_defs -> env -> constr -> path_kind -> constr +val new_isevar : 'a evar_defs -> env -> constr -> constr val is_eliminator : constr -> bool val head_is_embedded_evar : 'a evar_defs -> constr -> bool diff --git a/kernel/evd.ml b/pretyping/evd.ml index a80f21b52..a80f21b52 100644 --- a/kernel/evd.ml +++ b/pretyping/evd.ml diff --git a/kernel/evd.mli b/pretyping/evd.mli index f6192c7e5..f6192c7e5 100644 --- a/kernel/evd.mli +++ b/pretyping/evd.mli diff --git a/library/indrec.ml b/pretyping/indrec.ml index 36ce4f783..3c5e17b09 100644 --- a/library/indrec.ml +++ b/pretyping/indrec.ml @@ -11,17 +11,24 @@ open Pp open Util open Names +open Nameops open Term +open Termops open Declarations open Inductive +open Inductiveops open Instantiate open Environ -open Reduction +open Reductionops open Typeops open Type_errors open Indtypes (* pour les erreurs *) +open Declare +open Safe_typing +open Nametab let make_prod_dep dep env = if dep then prod_name env else mkProd +let mkLambda_string s t c = mkLambda (Name (id_of_string s), t, c) (*******************************************) (* Building curryfied elimination *) @@ -33,38 +40,38 @@ let make_prod_dep dep env = if dep then prod_name env else mkProd lift_constructor et lift_inductive_family qui ne se contentent pas de lifter les paramčtres globaux *) -let mis_make_case_com depopt env sigma mispec kind = - let lnamespar = mis_params_ctxt mispec in - let nparams = mis_nparams mispec in +let mis_make_case_com depopt env sigma (ind,mib,mip) kind = + let lnamespar = mip.mind_params_ctxt in + let nparams = mip.mind_nparams in let dep = match depopt with - | None -> mis_sort mispec <> (Prop Null) + | None -> mip.mind_sort <> (Prop Null) | Some d -> d in - if not (List.exists ((=) kind) (mis_kelim mispec)) then + if not (List.exists ((=) kind) mip.mind_kelim) then raise (InductiveError (NotAllowedCaseAnalysis - (dep,(new_sort_in_family kind),mis_inductive mispec))); + (dep,(new_sort_in_family kind),ind))); - let nbargsprod = mis_nrealargs mispec + 1 in + let nbargsprod = mip.mind_nrealargs + 1 in (* Pas génant car env ne sert pas ŕ typer mais juste ŕ renommer les Anonym *) (* mais pas trčs joli ... (mais manque get_sort_of ŕ ce niveau) *) - let env' = push_rels lnamespar env in + let env' = push_rel_context lnamespar env in - let indf = make_ind_family (mispec, extended_rel_list 0 lnamespar) in - let constrs = get_constructors indf in + let indf = (ind, extended_rel_list 0 lnamespar) in + let constrs = get_constructors env indf in let rec add_branch env k = - if k = mis_nconstr mispec then + if k = Array.length mip.mind_consnames then let nbprod = k+1 in - let indf = make_ind_family (mispec,extended_rel_list nbprod lnamespar) in - let lnamesar,_ = get_arity indf in - let ci = make_default_case_info mispec in + let indf = (ind,extended_rel_list nbprod lnamespar) in + let lnamesar,_ = get_arity env indf in + let ci = make_default_case_info env ind in it_mkLambda_or_LetIn_name env' (lambda_create env' - (build_dependent_inductive indf, - mkMutCase (ci, + (build_dependent_inductive env indf, + mkCase (ci, mkRel (nbprod+nbargsprod), mkRel 1, rel_vect nbargsprod k))) @@ -103,13 +110,13 @@ let type_rec_branch dep env sigma (vargs,depPvect,decP) tyi cs recargs = let rec prec env i sign p = let p',largs = whd_betadeltaiota_nolet_stack env sigma p in match kind_of_term p' with - | IsProd (n,t,c) -> + | Prod (n,t,c) -> let d = (n,None,t) in make_prod env (n,t,prec (push_rel d env) (i+1) (d::sign) c) - | IsLetIn (n,b,t,c) -> + | LetIn (n,b,t,c) -> let d = (n,Some b,t) in mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::sign) c) - | IsMutInd (_,_) -> + | Ind (_,_) -> let (_,realargs) = list_chop nparams largs in let base = applist (lift i pk,realargs) in if depK then @@ -122,7 +129,7 @@ let type_rec_branch dep env sigma (vargs,depPvect,decP) tyi cs recargs = in let rec process_constr env i c recargs nhyps li = if nhyps > 0 then match kind_of_term c with - | IsProd (n,t,c_0) -> + | Prod (n,t,c_0) -> let (optionpos,rest) = match recargs with | [] -> None,[] @@ -148,7 +155,7 @@ let type_rec_branch dep env sigma (vargs,depPvect,decP) tyi cs recargs = (push_rel (n,None,t) (push_rel (Anonymous,None,t_0) env)) (i+2) (lift 1 c_0) rest (nhyps-1) (i::li)))) - | IsLetIn (n,b,t,c_0) -> + | LetIn (n,b,t,c_0) -> mkLetIn (n,b,t, process_constr (push_rel (n,Some b,t) env) @@ -158,13 +165,13 @@ let type_rec_branch dep env sigma (vargs,depPvect,decP) tyi cs recargs = if dep then let realargs = List.map (fun k -> mkRel (i-k)) (List.rev li) in let params = List.map (lift i) vargs in - let co = applist (mkMutConstruct cs.cs_cstr,params@realargs) in + let co = applist (mkConstruct cs.cs_cstr,params@realargs) in mkApp (c, [|co|]) else c (* let c', largs = whd_stack c in match kind_of_term c' with - | IsProd (n,t,c_0) -> + | Prod (n,t,c_0) -> let (optionpos,rest) = match recargs with | [] -> None,[] @@ -191,13 +198,13 @@ let type_rec_branch dep env sigma (vargs,depPvect,decP) tyi cs recargs = (push_rel (Anonymous,None,t_0) env)) (i+2) (lift 1 c_0) rest (mkApp (lift 2 co, [|mkRel 2|]))))) - | IsLetIn (n,b,t,c_0) -> + | LetIn (n,b,t,c_0) -> mkLetIn (n,b,t, process_constr (push_rel (n,Some b,t) env) (i+1) c_0 recargs (lift 1 co)) - | IsMutInd ((_,tyi),_) -> + | Ind ((_,tyi),_) -> let nP = match depPvect.(tyi) with | Some(_,p) -> lift (i+decP) p | _ -> assert false in @@ -220,13 +227,13 @@ let make_rec_branch_arg env sigma (nparams,fvect,decF) f cstr recargs = let rec prec env i hyps p = let p',largs = whd_betadeltaiota_nolet_stack env sigma p in match kind_of_term p' with - | IsProd (n,t,c) -> + | Prod (n,t,c) -> let d = (n,None,t) in lambda_name env (n,t,prec (push_rel d env) (i+1) (d::hyps) c) - | IsLetIn (n,b,t,c) -> + | LetIn (n,b,t,c) -> let d = (n,Some b,t) in mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::hyps) c) - | IsMutInd _ -> + | Ind _ -> let (_,realargs) = list_chop nparams largs and arg = appvect (mkRel (i+1),extended_rel_vect 0 hyps) in applist(lift i fk,realargs@[arg]) @@ -269,43 +276,44 @@ let make_rec_branch_arg env sigma (nparams,fvect,decF) f cstr recargs = process_constr env 0 f (List.rev cstr.cs_args, recargs) (* Main function *) -let mis_make_indrec env sigma listdepkind mispec = - let nparams = mis_nparams mispec in - let lnamespar = mis_params_ctxt mispec in - let env' = (* push_rels lnamespar *) env in +let mis_make_indrec env sigma listdepkind (ind,mib,mip) = + let nparams = mip.mind_nparams in + let lnamespar = mip.mind_params_ctxt in let nrec = List.length listdepkind in let depPvec = - Array.create (mis_ntypes mispec) (None : (bool * constr) option) in + Array.create mib.mind_ntypes (None : (bool * constr) option) in let _ = let rec assign k = function | [] -> () - | (mispeci,dep,_)::rest -> - (Array.set depPvec (mis_index mispeci) (Some(dep,mkRel k)); + | (indi,mibi,mipi,dep,_)::rest -> + (Array.set depPvec (snd indi) (Some(dep,mkRel k)); assign (k-1) rest) in assign nrec listdepkind in - let recargsvec = mis_recargs mispec in + let recargsvec = + Array.map (fun mip -> mip.mind_listrec) mib.mind_packets in let make_one_rec p = let makefix nbconstruct = let rec mrec i ln ltyp ldef = function - | (mispeci,dep,_)::rest -> - let tyi = mis_index mispeci in - let nctyi = mis_nconstr mispeci in (* nb constructeurs du type *) + | (indi,mibi,mipi,dep,_)::rest -> + let tyi = snd indi in + let nctyi = + Array.length mipi.mind_consnames in (* nb constructeurs du type *) (* arity in the context P1..P_nrec f1..f_nbconstruct *) let args = extended_rel_list (nrec+nbconstruct) lnamespar in - let indf = make_ind_family (mispeci,args) in - let lnames,_ = get_arity indf in + let indf = (indi,args) in + let lnames,_ = get_arity env indf in - let nar = mis_nrealargs mispeci in + let nar = mipi.mind_nrealargs in let decf = nar+nrec+nbconstruct+nrec in let dect = nar+nrec+nbconstruct in let vecfi = rel_vect (dect+1-i-nctyi) nctyi in let args = extended_rel_list (decf+1) lnamespar in - let constrs = get_constructors (make_ind_family (mispeci,args)) in + let constrs = get_constructors env (indi,args) in let branches = array_map3 (make_rec_branch_arg env sigma (nparams,depPvec,nar+1)) @@ -314,17 +322,17 @@ let mis_make_indrec env sigma listdepkind mispec = | Some (_,c) when isRel c -> destRel c | _ -> assert false) in let args = extended_rel_list (nrec+nbconstruct) lnamespar in - let indf = make_ind_family (mispeci,args) in + let indf = (indi,args) in let deftyi = it_mkLambda_or_LetIn_name env (lambda_create env - (build_dependent_inductive + (build_dependent_inductive env (lift_inductive_family nrec indf), - mkMutCase (make_default_case_info mispeci, + mkCase (make_default_case_info env indi, mkRel (dect+j+1), mkRel 1, branches))) - (Sign.lift_rel_context nrec lnames) + (Termops.lift_rel_context nrec lnames) in - let ind = build_dependent_inductive indf in + let ind = build_dependent_inductive env indf in let typtyi = it_mkProd_or_LetIn_name env (prod_create env @@ -349,17 +357,17 @@ let mis_make_indrec env sigma listdepkind mispec = mrec 0 [] [] [] in let rec make_branch env i = function - | (mispeci,dep,_)::rest -> - let tyi = mis_index mispeci in - let nconstr = mis_nconstr mispeci in + | (indi,mibi,mipi,dep,_)::rest -> + let tyi = snd indi in + let nconstr = Array.length mipi.mind_consnames in let rec onerec env j = if j = nconstr then make_branch env (i+j) rest else let recarg = recargsvec.(tyi).(j) in let vargs = extended_rel_list (nrec+i+j) lnamespar in - let indf = make_ind_family (mispeci, vargs) in - let cs = get_constructor indf (j+1) in + let indf = (indi, vargs) in + let cs = get_constructor (indi,mibi,mipi,vargs) (j+1) in let p_0 = type_rec_branch dep env sigma (vargs,depPvec,i+j) tyi cs recarg in @@ -370,22 +378,22 @@ let mis_make_indrec env sigma listdepkind mispec = makefix i listdepkind in let rec put_arity env i = function - | (mispeci,dep,kinds)::rest -> - let indf = make_ind_family (mispeci,extended_rel_list i lnamespar) in + | (indi,_,_,dep,kinds)::rest -> + let indf = make_ind_family (indi,extended_rel_list i lnamespar) in let typP = make_arity env dep indf (new_sort_in_family kinds) in mkLambda_string "P" typP (put_arity (push_rel (Anonymous,None,typP) env) (i+1) rest) | [] -> make_branch env 0 listdepkind in - let (mispeci,dep,kind) = List.nth listdepkind p in - let env' = push_rels lnamespar env in + let (indi,mibi,mipi,dep,kind) = List.nth listdepkind p in + let env' = push_rel_context lnamespar env in if mis_is_recursive_subset - (List.map (fun (mispec,_,_) -> mis_index mispec) listdepkind) mispeci + (List.map (fun (indi,_,_,_,_) -> snd indi) listdepkind) mipi then it_mkLambda_or_LetIn_name env (put_arity env' 0 listdepkind) lnamespar else - mis_make_case_com (Some dep) env sigma mispeci kind + mis_make_case_com (Some dep) env sigma (indi,mibi,mipi) kind in list_tabulate make_one_rec nrec @@ -393,8 +401,8 @@ let mis_make_indrec env sigma listdepkind mispec = (* This builds elimination predicate for Case tactic *) let make_case_com depopt env sigma ity kind = - let mispec = lookup_mind_specif ity env in - mis_make_case_com depopt env sigma mispec kind + let (mib,mip) = lookup_mind_specif env ity in + mis_make_case_com depopt env sigma (ity,mib,mip) kind let make_case_dep env = make_case_com (Some true) env let make_case_nodep env = make_case_com (Some false) env @@ -407,9 +415,9 @@ let make_case_gen env = make_case_com None env let change_sort_arity 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 + | Cast (c,t) -> drec c + | Prod (n,t,c) -> mkProd (n, t, drec c) + | Sort _ -> mkSort sort | _ -> assert false in drec @@ -418,12 +426,12 @@ let change_sort_arity sort = let instanciate_indrec_scheme sort = let rec drec npar elim = match kind_of_term elim with - | IsLambda (n,t,c) -> + | Lambda (n,t,c) -> if npar = 0 then mkLambda (n, change_sort_arity sort t, c) else mkLambda (n, t, drec (npar-1) c) - | IsLetIn (n,b,t,c) -> mkLetIn (n,b,t,drec npar c) + | LetIn (n,b,t,c) -> mkLetIn (n,b,t,drec npar c) | _ -> anomaly "instanciate_indrec_scheme: wrong elimination type" in drec @@ -433,37 +441,38 @@ let instanciate_indrec_scheme sort = let check_arities listdepkind = List.iter - (function (mispeci,dep,kind) -> - let id = mis_typename mispeci in - let kelim = mis_kelim mispeci in + (function (indi,mibi,mipi,dep,kind) -> + let id = mipi.mind_typename in + let kelim = mipi.mind_kelim in if not (List.exists ((=) kind) kelim) then raise (InductiveError (BadInduction (dep, id, new_sort_in_family kind)))) listdepkind let build_mutual_indrec env sigma = function - | (mind,dep,s)::lrecspec -> + | (mind,mib,mip,dep,s)::lrecspec -> let (sp,tyi) = mind in - let mispec = lookup_mind_specif mind env in let listdepkind = - (mispec, dep,s):: + (mind,mib,mip, dep,s):: (List.map - (function (mind',dep',s') -> + (function (mind',mibi',mipi',dep',s') -> let (sp',_) = mind' in if sp=sp' then - (lookup_mind_specif mind' env,dep',s') + let (mibi',mipi') = lookup_mind_specif env mind' in + (mind',mibi',mipi',dep',s') else raise (InductiveError NotMutualInScheme)) lrecspec) in let _ = check_arities listdepkind in - mis_make_indrec env sigma listdepkind mispec + mis_make_indrec env sigma listdepkind (mind,mib,mip) | _ -> anomaly "build_indrec expects a non empty list of inductive types" -let build_indrec env sigma mispec = - let kind = family_of_sort (mis_sort mispec) in +let build_indrec env sigma ind = + let (mib,mip) = lookup_mind_specif env ind in + let kind = family_of_sort mip.mind_sort in let dep = kind <> InProp in - List.hd (mis_make_indrec env sigma [(mispec,dep,kind)] mispec) + List.hd (mis_make_indrec env sigma [(ind,mib,mip,dep,kind)] (ind,mib,mip)) (**********************************************************************) (* To handle old Case/Match syntax in Pretyping *) @@ -472,30 +481,103 @@ let build_indrec env sigma mispec = (* To interpret the Match operator *) (* TODO: check that we can drop universe constraints ? *) -let type_mutind_rec env sigma (IndType (indf,realargs) as ind) pj c = +let type_mutind_rec env sigma (IndType (indf,realargs) as indt) pj c = let p = pj.uj_val in - let (mispec,params) = dest_ind_family indf in - let tyi = mis_index mispec in - if mis_is_recursive_subset [tyi] mispec then - let (dep,_) = find_case_dep_nparams env sigma (c,pj) indf in + let (ind,params) = dest_ind_family indf in + let tyi = snd ind in + let (mib,mip) = lookup_mind_specif env ind in + if mis_is_recursive_subset [tyi] mip then + let (dep,_) = find_case_dep_nparams env (c,pj) indf in let init_depPvec i = if i = tyi then Some(dep,p) else None in - let depPvec = Array.init (mis_ntypes mispec) init_depPvec in + let depPvec = Array.init mib.mind_ntypes init_depPvec in let vargs = Array.of_list params in - let constructors = get_constructors indf in - let recargs = mis_recarg mispec in + let constructors = get_constructors env indf in + let recargs = mip.mind_listrec in let lft = array_map2 (type_rec_branch dep env sigma (params,depPvec,0) tyi) constructors recargs in (lft, if dep then applist(p,realargs@[c]) else applist(p,realargs) ) else - let (p,ra,_) = type_case_branches env sigma ind pj c in + let (p,ra,_) = type_case_branches env (ind,params@realargs) pj c in (p,ra) -let type_rec_branches recursive env sigma ind pj c = +let type_rec_branches recursive env sigma indt pj c = if recursive then - type_mutind_rec env sigma ind pj c + type_mutind_rec env sigma indt pj c else - let (p,ra,_) = type_case_branches env sigma ind pj c in + let IndType((ind,params),rargs) = indt in + let (p,ra,_) = type_case_branches env (ind,params@rargs) pj c in (p,ra) + +(*s Eliminations. *) + +let eliminations = + [ (InProp,"_ind") ; (InSet,"_rec") ; (InType,"_rect") ] + +let elimination_suffix = function + | InProp -> "_ind" + | InSet -> "_rec" + | InType -> "_rect" + +let make_elimination_ident id s = add_suffix id (elimination_suffix s) + +let declare_one_elimination ind = + let (mib,mip) = Global.lookup_inductive ind in + let mindstr = string_of_id mip.mind_typename in + let declare na c = + let _ = Declare.declare_constant (id_of_string na) + (ConstantEntry + { const_entry_body = c; + const_entry_type = None; + const_entry_opaque = false }, + NeverDischarge) in + Options.if_verbose pPNL [< 'sTR na; 'sTR " is defined" >] + in + let env = Global.env () in + let sigma = Evd.empty in + let elim_scheme = build_indrec env sigma ind in + let npars = mip.mind_nparams in + let make_elim s = instanciate_indrec_scheme s npars elim_scheme in + let kelim = mip.mind_kelim in + List.iter + (fun (sort,suff) -> + if List.mem sort kelim then + declare (mindstr^suff) (make_elim (new_sort_in_family sort))) + eliminations + +let declare_eliminations sp = + let mib = Global.lookup_mind sp in +(* + let ids = ids_of_named_context mib.mind_hyps in + if not (list_subset ids (ids_of_named_context (Global.named_context ()))) then error ("Declarations of elimination scheme outside the section "^ + "of the inductive definition is not implemented"); +*) + if mib.mind_finite then + for i = 0 to Array.length mib.mind_packets - 1 do + declare_one_elimination (sp,i) + done + +(* Look up function for the default elimination constant *) + +let lookup_eliminator ind_sp s = + let env = Global.env() in + let path = sp_of_global env (IndRef ind_sp) in + let dir, base = repr_path path in + let id = add_suffix base (elimination_suffix s) in + (* Try first to get an eliminator defined in the same section as the *) + (* inductive type *) + try construct_absolute_reference (Names.make_path dir id) + with Not_found -> + (* Then try to get a user-defined eliminator in some other places *) + (* using short name (e.g. for "eq_rec") *) + try construct_reference env id + with Not_found -> + errorlabstrm "default_elim" + [< 'sTR "Cannot find the elimination combinator :"; + pr_id id; 'sPC; + 'sTR "The elimination of the inductive definition :"; + pr_id base; 'sPC; 'sTR "on sort "; + 'sPC; print_sort (new_sort_in_family s) ; + 'sTR " is probably not allowed" >] diff --git a/library/indrec.mli b/pretyping/indrec.mli index aa3a0b6f1..7e6dd8fa1 100644 --- a/library/indrec.mli +++ b/pretyping/indrec.mli @@ -12,7 +12,7 @@ open Names open Term open Declarations -open Inductive +open Inductiveops open Environ open Evd (*i*) @@ -28,13 +28,15 @@ val make_case_gen : env -> 'a evar_map -> inductive -> sorts_family -> constr (* This builds an elimination scheme associated (using the own arity of the inductive) *) -val build_indrec : env -> 'a evar_map -> inductive_instance -> constr +val build_indrec : env -> 'a evar_map -> inductive -> constr val instanciate_indrec_scheme : sorts -> int -> constr -> constr (* This builds complex [Scheme] *) val build_mutual_indrec : - env -> 'a evar_map -> (inductive * bool * sorts_family) list + env -> 'a evar_map -> + (inductive * mutual_inductive_body * one_inductive_body + * bool * sorts_family) list -> constr list (* These are for old Case/Match typing *) @@ -45,3 +47,8 @@ val make_rec_branch_arg : env -> 'a evar_map -> int * ('b * constr) option array * int -> constr -> constructor_summary -> recarg list -> constr + +(* *) +val declare_eliminations : mutual_inductive -> unit +val lookup_eliminator : inductive -> sorts_family -> constr +val elimination_suffix : sorts_family -> string diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml new file mode 100644 index 000000000..066df1209 --- /dev/null +++ b/pretyping/inductiveops.ml @@ -0,0 +1,393 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +(* $Id$ *) + +open Util +open Names +open Univ +open Term +open Termops +open Sign +open Declarations +open Environ +open Reductionops + +(* +type inductive_instance = { + mis_sp : section_path; + mis_mib : mutual_inductive_body; + mis_tyi : int; + mis_mip : one_inductive_body } + + +let build_mis (sp,tyi) mib = + { mis_sp = sp; mis_mib = mib; mis_tyi = tyi; + mis_mip = mind_nth_type_packet mib tyi } + +let mis_ntypes mis = mis.mis_mib.mind_ntypes +let mis_nparams mis = mis.mis_mip.mind_nparams + +let mis_index mis = mis.mis_tyi + +let mis_nconstr mis = Array.length (mis.mis_mip.mind_consnames) +let mis_nrealargs mis = mis.mis_mip.mind_nrealargs +let mis_kelim mis = mis.mis_mip.mind_kelim +let mis_recargs mis = + Array.map (fun mip -> mip.mind_listrec) mis.mis_mib.mind_packets +let mis_recarg mis = mis.mis_mip.mind_listrec +let mis_typename mis = mis.mis_mip.mind_typename +let mis_typepath mis = + make_path (dirpath mis.mis_sp) mis.mis_mip.mind_typename CCI +let mis_consnames mis = mis.mis_mip.mind_consnames +let mis_conspaths mis = + let dir = dirpath mis.mis_sp in + Array.map (fun id -> make_path dir id CCI) mis.mis_mip.mind_consnames +let mis_inductive mis = (mis.mis_sp,mis.mis_tyi) +let mis_finite mis = mis.mis_mip.mind_finite + +let mis_typed_nf_lc mis = + let sign = mis.mis_mib.mind_hyps in + mis.mis_mip.mind_nf_lc + +let mis_nf_lc mis = Array.map body_of_type (mis_typed_nf_lc mis) + +let mis_user_lc mis = + let sign = mis.mis_mib.mind_hyps in + (mind_user_lc mis.mis_mip) + +(* gives the vector of constructors and of + types of constructors of an inductive definition + correctly instanciated *) + +let mis_type_mconstructs mispec = + let specif = Array.map body_of_type (mis_user_lc mispec) + and ntypes = mis_ntypes mispec + and nconstr = mis_nconstr mispec in + let make_Ik k = mkMutInd (mispec.mis_sp,ntypes-k-1) + and make_Ck k = + mkMutConstruct ((mispec.mis_sp,mispec.mis_tyi),k+1) in + (Array.init nconstr make_Ck, + Array.map (substl (list_tabulate make_Ik ntypes)) specif) +*) +let mis_nf_constructor_type (ind,mib,mip) j = + let specif = mip.mind_nf_lc + and ntypes = mib.mind_ntypes + and nconstr = Array.length mip.mind_consnames in + let make_Ik k = mkInd ((fst ind),ntypes-k-1) in + if j > nconstr then error "Not enough constructors in the type"; + substl (list_tabulate make_Ik ntypes) specif.(j-1) +(* +let mis_constructor_type i mispec = + let specif = mis_user_lc mispec + and ntypes = mis_ntypes mispec + and nconstr = mis_nconstr mispec in + let make_Ik k = mkMutInd (mispec.mis_sp,ntypes-k-1) in + if i > nconstr then error "Not enough constructors in the type"; + substl (list_tabulate make_Ik ntypes) specif.(i-1) + +let mis_arity mis = + let hyps = mis.mis_mib.mind_hyps in + mind_user_arity mis.mis_mip + +let mis_nf_arity mis = + let hyps = mis.mis_mib.mind_hyps in + mis.mis_mip.mind_nf_arity + +let mis_params_ctxt mis = mis.mis_mip.mind_params_ctxt +(* + let paramsign,_ = + decompose_prod_n_assum mis.mis_mip.mind_nparams + (body_of_type (mis_nf_arity mis)) + in paramsign +*) + +let mis_sort mispec = mispec.mis_mip.mind_sort +*) + +(* [inductive_family] = [inductive_instance] applied to global parameters *) +type inductive_family = inductive * constr list + +type inductive_type = IndType of inductive_family * constr list + +let liftn_inductive_family n d (mis,params) = + (mis, List.map (liftn n d) params) +let lift_inductive_family n = liftn_inductive_family n 1 + +let liftn_inductive_type n d (IndType (indf, realargs)) = + IndType (liftn_inductive_family n d indf, List.map (liftn n d) realargs) +let lift_inductive_type n = liftn_inductive_type n 1 + +let substnl_ind_family l n (mis,params) = + (mis, List.map (substnl l n) params) + +let substnl_ind_type l n (IndType (indf,realargs)) = + IndType (substnl_ind_family l n indf, List.map (substnl l n) realargs) + +let make_ind_family (mis, params) = (mis,params) +let dest_ind_family (mis,params) = (mis,params) + +let make_ind_type (indf, realargs) = IndType (indf,realargs) +let dest_ind_type (IndType (indf,realargs)) = (indf,realargs) + +let mkAppliedInd (IndType ((ind,params), realargs)) = + applist (mkInd ind,params@realargs) + +let mis_is_recursive_subset listind mip = + let rec one_is_rec rvec = + List.exists + (function + | Mrec i -> List.mem i listind + | Imbr(_,lvec) -> one_is_rec lvec + | Norec -> false + | Param _ -> false) rvec + in + array_exists one_is_rec mip.mind_listrec + +let mis_is_recursive (mib,mip) = + mis_is_recursive_subset (interval 0 (mib.mind_ntypes-1)) mip + +(* Annotation for cases *) +let make_case_info env ind style pats_source = + let (mib,mip) = Inductive.lookup_mind_specif env ind in + let print_info = + { cnames = mip.mind_consnames; + ind_nargs = mip.mind_nrealargs; + style = style; + source =pats_source } in + { ci_ind = ind; + ci_npar = mip.mind_nparams; + ci_pp_info = print_info } + +let make_default_case_info env ind = + let (mib,mip) = Inductive.lookup_mind_specif env ind in + make_case_info env ind None + (Array.map (fun _ -> RegularPat) mip.mind_consnames) + +(*s Useful functions *) + +type constructor_summary = { + cs_cstr : constructor; + cs_params : constr list; + cs_nargs : int; + cs_args : rel_context; + cs_concl_realargs : constr array +} + +let lift_constructor n cs = { + cs_cstr = cs.cs_cstr; + cs_params = List.map (lift n) cs.cs_params; + cs_nargs = cs.cs_nargs; + cs_args = lift_rel_context n cs.cs_args; + cs_concl_realargs = Array.map (liftn n (cs.cs_nargs+1)) cs.cs_concl_realargs +} + +let instantiate_params t args sign = + let rec inst s t = function + | ((_,None,_)::ctxt,a::args) -> + (match kind_of_term t with + | Prod(_,_,t) -> inst (a::s) t (ctxt,args) + | _ -> anomaly"instantiate_params: type, ctxt and args mismatch") + | ((_,(Some b),_)::ctxt,args) -> + (match kind_of_term t with + | LetIn(_,_,_,t) -> inst ((substl s b)::s) t (ctxt,args) + | _ -> anomaly"instantiate_params: type, ctxt and args mismatch") + | [], [] -> substl s t + | _ -> anomaly"instantiate_params: type, ctxt and args mismatch" + in inst [] t (List.rev sign,args) +(* +let get_constructor_type (IndFamily (mispec,params)) j = + assert (j <= mis_nconstr mispec); + let typi = mis_constructor_type j mispec in + instantiate_params typi params (mis_params_ctxt mispec) + +let get_constructors_types (IndFamily (mispec,params) as indf) = + Array.init (mis_nconstr mispec) (fun j -> get_constructor_type indf (j+1)) +*) +let get_constructor (ind,mib,mip,params) j = + assert (j <= Array.length mip.mind_consnames); + let typi = mis_nf_constructor_type (ind,mib,mip) j in + let typi = instantiate_params typi params mip.mind_params_ctxt in + let (args,ccl) = decompose_prod_assum typi in + let (_,allargs) = decompose_app ccl in + let (_,vargs) = list_chop mip.mind_nparams allargs in + { cs_cstr = ith_constructor_of_inductive ind j; + cs_params = params; + cs_nargs = rel_context_length args; + cs_args = args; + cs_concl_realargs = Array.of_list vargs } + +let get_constructors env (ind,params) = + let (mib,mip) = Inductive.lookup_mind_specif env ind in + Array.init (Array.length mip.mind_consnames) + (fun j -> get_constructor (ind,mib,mip,params) (j+1)) + +let get_arity env (ind,params) = + let (mib,mip) = Inductive.lookup_mind_specif env ind in + let arity = body_of_type mip.mind_nf_arity in + destArity (prod_applist arity params) + +(* Functions to build standard types related to inductive *) +let local_rels = + let rec relrec acc n = function (* more recent arg in front *) + | [] -> acc + | (_,None,_)::l -> relrec (mkRel n :: acc) (n+1) l + | (_,Some _,_)::l -> relrec acc (n+1) l + in relrec [] 1 + +let build_dependent_constructor cs = + applist + (mkConstruct cs.cs_cstr, + (List.map (lift cs.cs_nargs) cs.cs_params)@(local_rels cs.cs_args)) + +let build_dependent_inductive env ((ind, params) as indf) = + let arsign,_ = get_arity env indf in + let (mib,mip) = Inductive.lookup_mind_specif env ind in + let nrealargs = mip.mind_nrealargs in + applist + (mkInd ind, + (List.map (lift nrealargs) params)@(local_rels arsign)) + +(* builds the arity of an elimination predicate in sort [s] *) + +let make_arity env dep indf s = + let (arsign,_) = get_arity env indf in + if dep then + (* We need names everywhere *) + it_mkProd_or_LetIn_name env + (mkArrow (build_dependent_inductive env indf) (mkSort s)) arsign + else + (* No need to enforce names *) + it_mkProd_or_LetIn (mkSort s) arsign + +(* [p] is the predicate and [cs] a constructor summary *) +let build_branch_type env dep p cs = + let base = appvect (lift cs.cs_nargs p, cs.cs_concl_realargs) in + if dep then + it_mkProd_or_LetIn_name env + (applist (base,[build_dependent_constructor cs])) + cs.cs_args + else + it_mkProd_or_LetIn base cs.cs_args + +(**************************************************) + +exception Induc + +let extract_mrectype t = + let (t, l) = decompose_app t in + match kind_of_term t with + | Ind ind -> (ind, l) + | _ -> raise Induc + +let find_mrectype env sigma c = + let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in + match kind_of_term t with + | Ind ind -> (ind, l) + | _ -> raise Induc + +let find_rectype env sigma c = + let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in + match kind_of_term t with + | Ind ind -> + let (mib,mip) = Inductive.lookup_mind_specif env ind in + let (par,rargs) = list_chop mip.mind_nparams l in + IndType((ind, par),rargs) + | _ -> raise Induc + +let find_inductive env sigma c = + let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in + match kind_of_term t with + | Ind ind + when (fst (Inductive.lookup_mind_specif env ind)).mind_finite -> + (ind, l) + | _ -> raise Induc + +let find_coinductive env sigma c = + let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in + match kind_of_term t with + | Ind ind + when not (fst (Inductive.lookup_mind_specif env ind)).mind_finite -> + (ind, l) + | _ -> raise Induc + + +(***********************************************) +(* find appropriate names for pattern variables. Useful in the + Case tactic. *) + +let is_dep_arity env kelim predty t = + let rec srec (pt,t) = + let pt' = whd_betadeltaiota env Evd.empty pt in + let t' = whd_betadeltaiota env Evd.empty t in + match kind_of_term pt', kind_of_term t' with + | Prod (_,a1,a2), Prod (_,a1',a2') -> srec (a2,a2') + | Prod (_,a1,a2), _ -> true + | _ -> false in + srec (predty,t) + +let is_dep env predty (ind,args) = + let (mib,mip) = Inductive.lookup_mind_specif env ind in + let params = fst (list_chop mip.mind_nparams args) in + let kelim = mip.mind_kelim in + let arsign,s = get_arity env (ind,params) in + let glob_t = it_mkProd_or_LetIn (mkSort s) arsign in + is_dep_arity env kelim predty glob_t + + + +let set_names env n brty = + let (args,cl) = decompose_prod_n n brty in + let ctxt = List.map (fun (x,ty) -> (x,None,ty)) args in + it_mkProd_or_LetIn_name env cl ctxt + +let set_pattern_names env ind brv = + let (_,mip) = Inductive.lookup_mind_specif env ind in + let arities = + Array.map + (fun c -> List.length (fst (decompose_prod c)) - mip.mind_nparams) + mip.mind_nf_lc in + array_map2 (set_names env) arities brv + + +let type_case_branches_with_names env indspec pj c = + let (lbrty,conclty,_) = Inductive.type_case_branches env indspec pj c in + if is_dep env pj.uj_type indspec then + (set_pattern_names env (fst indspec) lbrty, conclty) + else (lbrty, conclty) + +(***********************************************) +(* Guard condition *) + +(* A function which checks that a term well typed verifies both + syntaxic conditions *) + +let control_only_guard env = + let rec control_rec c = match kind_of_term c with + | Rel _ | Var _ -> () + | Sort _ | Meta _ -> () + | Ind _ -> () + | Construct _ -> () + | Const _ -> () + | CoFix (_,(_,tys,bds) as cofix) -> + Inductive.check_cofix env cofix; + Array.iter control_rec tys; + Array.iter control_rec bds; + | Fix (_,(_,tys,bds) as fix) -> + Inductive.check_fix env fix; + Array.iter control_rec tys; + Array.iter control_rec bds; + | Case(_,p,c,b) ->control_rec p;control_rec c;Array.iter control_rec b + | Evar (_,cl) -> Array.iter control_rec cl + | App (_,cl) -> Array.iter control_rec cl + | Cast (c1,c2) -> control_rec c1; control_rec c2 + | Prod (_,c1,c2) -> control_rec c1; control_rec c2 + | Lambda (_,c1,c2) -> control_rec c1; control_rec c2 + | LetIn (_,c1,c2,c3) -> control_rec c1; control_rec c2; control_rec c3 + in + control_rec diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli new file mode 100644 index 000000000..7ca5b8b1b --- /dev/null +++ b/pretyping/inductiveops.mli @@ -0,0 +1,86 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +(* $Id$ *) + +open Names +open Term +open Declarations +open Sign +open Environ +open Evd + +val mis_nf_constructor_type : + (section_path * 'a) * mutual_inductive_body * + one_inductive_body -> int -> constr + +type inductive_family = inductive * constr list +and inductive_type = IndType of inductive_family * constr list +val liftn_inductive_family : + int -> int -> 'a * constr list -> 'a * constr list +val lift_inductive_family : + int -> 'a * constr list -> 'a * constr list +val liftn_inductive_type : int -> int -> inductive_type -> inductive_type +val lift_inductive_type : int -> inductive_type -> inductive_type +val substnl_ind_family : + constr list -> int -> 'a * constr list -> 'a * constr list +val substnl_ind_type : + constr list -> int -> inductive_type -> inductive_type +val make_ind_family : 'a * 'b -> 'a * 'b +val dest_ind_family : 'a * 'b -> 'a * 'b +val make_ind_type : inductive_family * constr list -> inductive_type +val dest_ind_type : inductive_type -> inductive_family * constr list +val mkAppliedInd : inductive_type -> constr +val mis_is_recursive_subset : + int list -> one_inductive_body -> bool +val mis_is_recursive : + mutual_inductive_body * one_inductive_body -> + bool +val make_case_info : + env -> inductive -> + case_style option -> pattern_source array -> case_info +val make_default_case_info : env -> inductive -> case_info + +type constructor_summary = { + cs_cstr : constructor; + cs_params : constr list; + cs_nargs : int; + cs_args : rel_context; + cs_concl_realargs : constr array; +} +val lift_constructor : int -> constructor_summary -> constructor_summary +val get_constructor : + inductive * mutual_inductive_body * one_inductive_body * constr list -> + int -> constructor_summary +val get_constructors : + env -> inductive * constr list -> constructor_summary array +val get_arity : + env -> inductive * constr list -> arity +val local_rels : rel_context -> constr list +val build_dependent_constructor : constructor_summary -> constr +val build_dependent_inductive : env -> inductive * constr list -> constr +val make_arity : + env -> bool -> inductive * constr list -> sorts -> types +val build_branch_type : + env -> bool -> constr -> constructor_summary -> types + +exception Induc +val extract_mrectype : constr -> inductive * constr list +val find_mrectype : + env -> 'a evar_map -> constr -> inductive * constr list +val find_rectype : + env -> 'a evar_map -> constr -> inductive_type +val find_inductive : + env -> 'a evar_map -> constr -> inductive * constr list +val find_coinductive : + env -> + 'a evar_map -> constr -> inductive * constr list +val type_case_branches_with_names : + env -> inductive * constr list -> unsafe_judgment -> constr -> + types array * types +val control_only_guard : env -> types -> unit diff --git a/pretyping/instantiate.ml b/pretyping/instantiate.ml new file mode 100644 index 000000000..42a4dbba7 --- /dev/null +++ b/pretyping/instantiate.ml @@ -0,0 +1,65 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +(* $Id$ *) + +open Pp +open Util +open Names +open Term +open Sign +open Evd +open Declarations +open Environ + +let is_id_inst inst = + let is_id (id,c) = match kind_of_term c with + | Var id' -> id = id' + | _ -> false + in + List.for_all is_id inst + +(* Vérifier que les instances des let-in sont compatibles ?? *) +let instantiate_sign_including_let sign args = + let rec instrec = function + | ((id,b,_) :: sign, c::args) -> (id,c) :: (instrec (sign,args)) + | ([],[]) -> [] + | ([],_) | (_,[]) -> + anomaly "Signature and its instance do not match" + in + instrec (sign,args) + +let instantiate_evar sign c args = + let inst = instantiate_sign_including_let sign args in + if is_id_inst inst then + c + else + replace_vars inst c + +(* Existentials. *) + +let existential_type sigma (n,args) = + let info = Evd.map sigma n in + let hyps = info.evar_hyps in + instantiate_evar hyps info.evar_concl (Array.to_list args) + +exception NotInstantiatedEvar + +let existential_value sigma (n,args) = + let info = Evd.map sigma n in + let hyps = info.evar_hyps in + match evar_body info with + | Evar_defined c -> + instantiate_evar hyps c (Array.to_list args) + | Evar_empty -> + raise NotInstantiatedEvar + +let existential_opt_value sigma ev = + try Some (existential_value sigma ev) + with NotInstantiatedEvar -> None + diff --git a/pretyping/instantiate.mli b/pretyping/instantiate.mli new file mode 100644 index 000000000..4f4184769 --- /dev/null +++ b/pretyping/instantiate.mli @@ -0,0 +1,25 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +(*i $Id$ i*) + +(*i*) +open Names +open Term +open Evd +open Sign +open Environ +(*i*) + +(*s [existential_value sigma ev] raises [NotInstantiatedEvar] if [ev] has +no body and [Not_found] if it does not exist in [sigma] *) + +exception NotInstantiatedEvar +val existential_value : 'a evar_map -> existential -> constr +val existential_type : 'a evar_map -> existential -> types +val existential_opt_value : 'a evar_map -> existential -> constr option diff --git a/pretyping/pattern.ml b/pretyping/pattern.ml index 253e3e579..85d38ab4d 100644 --- a/pretyping/pattern.ml +++ b/pretyping/pattern.ml @@ -10,10 +10,13 @@ open Util open Names +open Nameops open Term -open Reduction +open Termops +open Reductionops open Rawterm open Environ +open Nametab type constr_pattern = | PRef of global_reference @@ -57,7 +60,7 @@ let label_of_ref = function | ConstRef sp -> ConstNode sp | IndRef sp -> IndNode sp | ConstructRef sp -> CstrNode sp - | VarRef sp -> VarNode (basename sp) + | VarRef id -> VarNode id let rec head_pattern_bound t = match t with @@ -74,10 +77,10 @@ let rec head_pattern_bound t = | PCoFix _ -> anomaly "head_pattern_bound: not a type" let head_of_constr_reference c = match kind_of_term c with - | IsConst sp -> ConstNode sp - | IsMutConstruct sp -> CstrNode sp - | IsMutInd sp -> IndNode sp - | IsVar id -> VarNode id + | Const sp -> ConstNode sp + | Construct sp -> CstrNode sp + | Ind sp -> IndNode sp + | Var id -> VarNode id | _ -> anomaly "Not a rigid reference" @@ -157,29 +160,29 @@ let matches_core convert pat c = | PMeta None, m -> sigma - | PRef (VarRef sp1), IsVar v2 when basename sp1 = v2 -> sigma + | PRef (VarRef v1), Var v2 when v1 = v2 -> sigma - | PVar v1, IsVar v2 when v1 = v2 -> sigma + | PVar v1, Var v2 when v1 = v2 -> sigma | PRef ref, _ when Declare.constr_of_reference ref = cT -> sigma - | PRel n1, IsRel n2 when n1 = n2 -> sigma + | PRel n1, Rel n2 when n1 = n2 -> sigma - | PSort (RProp c1), IsSort (Prop c2) when c1 = c2 -> sigma + | PSort (RProp c1), Sort (Prop c2) when c1 = c2 -> sigma - | PSort (RType _), IsSort (Type _) -> sigma + | PSort (RType _), Sort (Type _) -> sigma - | PApp (c1,arg1), IsApp (c2,arg2) -> + | PApp (c1,arg1), App (c2,arg2) -> (try array_fold_left2 (sorec stk) (sorec stk sigma c1 c2) arg1 arg2 with Invalid_argument _ -> raise PatternMatchingFailure) - | PProd (na1,c1,d1), IsProd(na2,c2,d2) -> + | PProd (na1,c1,d1), Prod(na2,c2,d2) -> sorec ((na2,c2)::stk) (sorec stk sigma c1 c2) d1 d2 - | PLambda (na1,c1,d1), IsLambda(na2,c2,d2) -> + | PLambda (na1,c1,d1), Lambda(na2,c2,d2) -> sorec ((na2,c2)::stk) (sorec stk sigma c1 c2) d1 d2 - | PLetIn (na1,c1,d1), IsLetIn(na2,c2,t2,d2) -> + | PLetIn (na1,c1,d1), LetIn(na2,c2,t2,d2) -> sorec ((na2,t2)::stk) (sorec stk sigma c1 c2) d1 d2 | PRef (ConstRef _ as ref), _ when convert <> None -> @@ -188,15 +191,15 @@ let matches_core convert pat c = if is_conv env evars c cT then sigma else raise PatternMatchingFailure - | PCase (_,a1,br1), IsMutCase (_,_,a2,br2) -> + | PCase (_,a1,br1), Case (_,_,a2,br2) -> (* On ne teste pas le prédicat *) if (Array.length br1) = (Array.length br2) then array_fold_left2 (sorec stk) (sorec stk sigma a1 a2) br1 br2 else raise PatternMatchingFailure (* Ŕ faire *) - | PFix f0, IsFix f1 when f0 = f1 -> sigma - | PCoFix c0, IsCoFix c1 when c0 = c1 -> sigma + | PFix f0, Fix f1 when f0 = f1 -> sigma + | PCoFix c0, CoFix c1 when c0 = c1 -> sigma | _ -> raise PatternMatchingFailure in @@ -223,7 +226,7 @@ let rec try_matches nocc pat = function (* Tries to match a subterm of [c] with [pat] *) let rec sub_match nocc pat c = match kind_of_term c with - | IsCast (c1,c2) -> + | Cast (c1,c2) -> (try authorized_occ nocc ((matches pat c), mkMeta (-1)) with | PatternMatchingFailure -> let (lm,lc) = try_sub_match nocc pat [c1] in @@ -231,7 +234,7 @@ let rec sub_match nocc pat c = | NextOccurrence nocc -> let (lm,lc) = try_sub_match (nocc - 1) pat [c1] in (lm,mkCast (List.hd lc, c2))) - | IsLambda (x,c1,c2) -> + | Lambda (x,c1,c2) -> (try authorized_occ nocc ((matches pat c), mkMeta (-1)) with | PatternMatchingFailure -> let (lm,lc) = try_sub_match nocc pat [c1;c2] in @@ -239,7 +242,7 @@ let rec sub_match nocc pat c = | NextOccurrence nocc -> let (lm,lc) = try_sub_match (nocc - 1) pat [c1;c2] in (lm,mkLambda (x,List.hd lc,List.nth lc 1))) - | IsProd (x,c1,c2) -> + | Prod (x,c1,c2) -> (try authorized_occ nocc ((matches pat c), mkMeta (-1)) with | PatternMatchingFailure -> let (lm,lc) = try_sub_match nocc pat [c1;c2] in @@ -247,7 +250,7 @@ let rec sub_match nocc pat c = | NextOccurrence nocc -> 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) -> + | LetIn (x,c1,t2,c2) -> (try authorized_occ nocc ((matches pat c), mkMeta (-1)) with | PatternMatchingFailure -> let (lm,lc) = try_sub_match nocc pat [c1;t2;c2] in @@ -255,7 +258,7 @@ let rec sub_match nocc pat c = | 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))) - | IsApp (c1,lc) -> + | App (c1,lc) -> (try authorized_occ nocc ((matches pat c), mkMeta (-1)) with | PatternMatchingFailure -> let (lm,le) = try_sub_match nocc pat (c1::(Array.to_list lc)) in @@ -263,16 +266,16 @@ let rec sub_match nocc pat c = | NextOccurrence nocc -> let (lm,le) = try_sub_match (nocc - 1) pat (c1::(Array.to_list lc)) in (lm,mkApp (List.hd le, Array.of_list (List.tl le)))) - | IsMutCase (ci,hd,c1,lc) -> + | Case (ci,hd,c1,lc) -> (try authorized_occ nocc ((matches pat c), mkMeta (-1)) with | PatternMatchingFailure -> let (lm,le) = try_sub_match nocc pat (c1::Array.to_list lc) in - (lm,mkMutCaseL (ci,hd,List.hd le,List.tl le)) + (lm,mkCase (ci,hd,List.hd le,Array.of_list (List.tl le))) | NextOccurrence nocc -> let (lm,le) = try_sub_match (nocc - 1) pat (c1::Array.to_list lc) in - (lm,mkMutCaseL (ci,hd,List.hd le,List.tl le))) - | IsMutConstruct _ | IsFix _ | IsMutInd _|IsCoFix _ |IsEvar _|IsConst _ - | IsRel _|IsMeta _|IsVar _|IsSort _ -> + (lm,mkCase (ci,hd,List.hd le,Array.of_list (List.tl le)))) + | Construct _ | Fix _ | Ind _|CoFix _ |Evar _|Const _ + | Rel _|Meta _|Var _|Sort _ -> (try authorized_occ nocc ((matches pat c),mkMeta (-1)) with | PatternMatchingFailure -> raise (NextOccurrence nocc) | NextOccurrence nocc -> raise (NextOccurrence (nocc - 1))) @@ -301,25 +304,25 @@ let is_matching_conv env sigma pat n = let rec pattern_of_constr t = match kind_of_term t with - | IsRel n -> PRel n - | IsMeta n -> PMeta (Some n) - | IsVar id -> PVar id - | IsSort (Prop c) -> PSort (RProp c) - | IsSort (Type _) -> PSort (RType None) - | IsCast (c,_) -> pattern_of_constr c - | IsLetIn (na,c,_,b) -> PLetIn (na,pattern_of_constr c,pattern_of_constr b) - | IsProd (na,c,b) -> PProd (na,pattern_of_constr c,pattern_of_constr b) - | IsLambda (na,c,b) -> PLambda (na,pattern_of_constr c,pattern_of_constr b) - | IsApp (f,a) -> PApp (pattern_of_constr f,Array.map pattern_of_constr a) - | IsConst sp -> PRef (ConstRef sp) - | IsMutInd sp -> PRef (IndRef sp) - | IsMutConstruct sp -> PRef (ConstructRef sp) - | IsEvar (n,ctxt) -> + | Rel n -> PRel n + | Meta n -> PMeta (Some n) + | Var id -> PVar id + | Sort (Prop c) -> PSort (RProp c) + | Sort (Type _) -> PSort (RType None) + | Cast (c,_) -> pattern_of_constr c + | LetIn (na,c,_,b) -> PLetIn (na,pattern_of_constr c,pattern_of_constr b) + | Prod (na,c,b) -> PProd (na,pattern_of_constr c,pattern_of_constr b) + | Lambda (na,c,b) -> PLambda (na,pattern_of_constr c,pattern_of_constr b) + | App (f,a) -> PApp (pattern_of_constr f,Array.map pattern_of_constr a) + | Const sp -> PRef (ConstRef sp) + | Ind sp -> PRef (IndRef sp) + | Construct sp -> PRef (ConstructRef sp) + | Evar (n,ctxt) -> if ctxt = [||] then PEvar n else PApp (PEvar n, Array.map pattern_of_constr ctxt) - | IsMutCase (ci,p,a,br) -> + | Case (ci,p,a,br) -> PCase (Some (pattern_of_constr p),pattern_of_constr a, Array.map pattern_of_constr br) - | IsFix f -> PFix f - | IsCoFix _ -> + | Fix f -> PFix f + | CoFix _ -> error "pattern_of_constr: (co)fix currently not supported" diff --git a/pretyping/pattern.mli b/pretyping/pattern.mli index 42b680820..4a477b8e5 100644 --- a/pretyping/pattern.mli +++ b/pretyping/pattern.mli @@ -13,6 +13,7 @@ open Names open Sign open Term open Environ +open Nametab (*i*) type constr_pattern = diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml index 2d52ad5fd..fd42ca0ba 100644 --- a/pretyping/pretype_errors.ml +++ b/pretyping/pretype_errors.ml @@ -12,10 +12,11 @@ open Util open Names open Sign open Term +open Termops open Environ open Type_errors open Rawterm -open Inductive +open Inductiveops type ml_case_error = | MlCaseAbsurd @@ -35,14 +36,7 @@ type pretype_error = exception PretypeError of env * pretype_error -(* Replacing defined evars for error messages *) -let rec whd_evar sigma c = - match kind_of_term c with - | IsEvar (ev,args) when Evd.in_dom sigma ev & Evd.is_defined sigma ev -> - whd_evar sigma (Instantiate.existential_value sigma (ev,args)) - | _ -> collapse_appl c - -let nf_evar sigma = Reduction.local_strong (whd_evar sigma) +let nf_evar = Reductionops.nf_evar let j_nf_evar sigma j = { uj_val = nf_evar sigma j.uj_val; uj_type = nf_evar sigma j.uj_type } @@ -52,13 +46,22 @@ let tj_nf_evar sigma {utj_val=v;utj_type=t} = {utj_val=type_app (nf_evar sigma) v;utj_type=t} let env_ise sigma env = - map_context (nf_evar sigma) env + let sign = named_context env in + let ctxt = rel_context env in + let env0 = reset_with_named_context sign env in + Sign.fold_rel_context + (fun (na,b,ty) e -> + push_rel + (na, option_app (nf_evar sigma) b, nf_evar sigma ty) + e) + ctxt + env0 (* This simplify the typing context of Cases clauses *) (* hope it does not disturb other typing contexts *) let contract env lc = let l = ref [] in - let contract_context env (na,c,t) = + let contract_context (na,c,t) env = match c with | Some c' when isRel c' -> l := (substl !l c') :: !l; @@ -81,50 +84,52 @@ let contract3 env a b c = match contract env [a;b;c] with let raise_pretype_error (loc,ctx,sigma,te) = Stdpp.raise_with_loc loc (PretypeError(env_ise sigma ctx,te)) -let raise_located_type_error (loc,k,ctx,sigma,te) = - Stdpp.raise_with_loc loc (TypeError(k,env_ise sigma ctx,te)) +let raise_located_type_error (loc,ctx,sigma,te) = + Stdpp.raise_with_loc loc (TypeError(env_ise sigma ctx,te)) let error_actual_type_loc loc env sigma {uj_val=c;uj_type=actty} expty = let env, c, actty, expty = contract3 env c actty expty in + let j = j_nf_evar sigma {uj_val=c;uj_type=actty} in raise_located_type_error - (loc, CCI, env, sigma, - ActualType (c,nf_evar sigma actty, nf_evar sigma expty)) + (loc, env, sigma, ActualType (j, nf_evar sigma expty)) let error_cant_apply_not_functional_loc loc env sigma rator randl = + let ja = Array.of_list (jl_nf_evar sigma randl) in raise_located_type_error - (loc, CCI, env, sigma, - CantApplyNonFunctional (j_nf_evar sigma rator, jl_nf_evar sigma randl)) + (loc, env, sigma, + CantApplyNonFunctional (j_nf_evar sigma rator, ja)) let error_cant_apply_bad_type_loc loc env sigma (n,c,t) rator randl = + let ja = Array.of_list (jl_nf_evar sigma randl) in raise_located_type_error - (loc, CCI, env, sigma, + (loc, env, sigma, CantApplyBadType ((n,nf_evar sigma c, nf_evar sigma t), - j_nf_evar sigma rator, jl_nf_evar sigma randl)) + j_nf_evar sigma rator, ja)) let error_cant_find_case_type_loc loc env sigma expr = raise_pretype_error (loc, env, sigma, CantFindCaseType (nf_evar sigma expr)) -let error_ill_formed_branch_loc loc k env sigma c i actty expty = +let error_ill_formed_branch_loc loc env sigma c i actty expty = let simp t = Reduction.nf_betaiota (nf_evar sigma t) in raise_located_type_error - (loc, k, env, sigma, + (loc, env, sigma, IllFormedBranch (nf_evar sigma c,i,simp actty, simp expty)) -let error_number_branches_loc loc k env sigma cj expn = +let error_number_branches_loc loc env sigma cj expn = raise_located_type_error - (loc, k, env, sigma, + (loc, env, sigma, NumberBranches (j_nf_evar sigma cj, expn)) -let error_case_not_inductive_loc loc k env sigma cj = +let error_case_not_inductive_loc loc env sigma cj = raise_located_type_error - (loc, k, env, sigma, CaseNotInductive (j_nf_evar sigma cj)) + (loc, env, sigma, CaseNotInductive (j_nf_evar sigma cj)) -let error_ill_typed_rec_body_loc loc k env sigma i na jl tys = +let error_ill_typed_rec_body_loc loc env sigma i na jl tys = raise_located_type_error - (loc, k, env, sigma, + (loc, env, sigma, IllTypedRecBody (i,na,jv_nf_evar sigma jl, Array.map (nf_evar sigma) tys)) diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli index 90d90120e..11bf5b531 100644 --- a/pretyping/pretype_errors.mli +++ b/pretyping/pretype_errors.mli @@ -15,7 +15,7 @@ open Term open Sign open Environ open Rawterm -open Inductive +open Inductiveops (*i*) (*s The type of errors raised by the pretyper *) @@ -65,18 +65,18 @@ val error_cant_find_case_type_loc : loc -> env -> 'a Evd.evar_map -> constr -> 'b val error_case_not_inductive_loc : - loc -> path_kind -> env -> 'a Evd.evar_map -> unsafe_judgment -> 'b + loc -> env -> 'a Evd.evar_map -> unsafe_judgment -> 'b val error_ill_formed_branch_loc : - loc -> path_kind -> env -> 'a Evd.evar_map -> + loc -> env -> 'a Evd.evar_map -> constr -> int -> constr -> constr -> 'b val error_number_branches_loc : - loc -> path_kind -> env -> 'a Evd.evar_map -> + loc -> env -> 'a Evd.evar_map -> unsafe_judgment -> int -> 'b val error_ill_typed_rec_body_loc : - loc -> path_kind -> env -> 'a Evd.evar_map -> + loc -> env -> 'a Evd.evar_map -> int -> name array -> unsafe_judgment array -> types array -> 'b (*s Implicit arguments synthesis errors *) diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index c0238dbda..e717ffe95 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -14,7 +14,8 @@ open Names open Sign open Evd open Term -open Reduction +open Termops +open Reductionops open Environ open Type_errors open Typeops @@ -31,7 +32,9 @@ open Dyn (***********************************************************************) (* This concerns Cases *) +open Declarations open Inductive +open Inductiveops open Instantiate let lift_context n l = @@ -40,24 +43,27 @@ let lift_context n l = let transform_rec loc env sigma (pj,c,lf) indt = let p = pj.uj_val in - let (indf,realargs) = dest_ind_type indt in - let (mispec,params) = dest_ind_family indf in - let mI = mkMutInd (mis_inductive mispec) in - let recargs = mis_recarg mispec in - let tyi = mis_index mispec in - if Array.length lf <> mis_nconstr mispec then + let ((ind,params) as indf,realargs) = dest_ind_type indt in + let (mib,mip) = lookup_mind_specif env ind in + let mI = mkInd ind in + let recargs = mip.mind_listrec in + let tyi = snd ind in + let ci = make_default_case_info env ind in + let nconstr = Array.length mip.mind_consnames in + if Array.length lf <> nconstr then (let cj = {uj_val=c; uj_type=mkAppliedInd indt} in - error_number_branches_loc loc CCI env sigma cj (mis_nconstr mispec)); - if mis_is_recursive_subset [tyi] mispec then - let (dep,_) = find_case_dep_nparams env sigma (c,pj) indf in + error_number_branches_loc loc env sigma cj nconstr); + if mis_is_recursive_subset [tyi] mip then + let (dep,_) = + find_case_dep_nparams env + (nf_evar sigma c, j_nf_evar sigma pj) indf in let init_depFvec i = if i = tyi then Some(dep,mkRel 1) else None in - let depFvec = Array.init (mis_ntypes mispec) init_depFvec in + let depFvec = Array.init mib.mind_ntypes init_depFvec in (* build now the fixpoint *) - let lnames,_ = get_arity indf in + let lnames,_ = get_arity env indf in let nar = List.length lnames in - let nparams = mis_nparams mispec in - let constrs = get_constructors (lift_inductive_family (nar+2) indf) in - let ci = make_default_case_info mispec in + let nparams = mip.mind_nparams in + let constrs = get_constructors env (lift_inductive_family (nar+2) indf) in let branches = array_map3 (fun f t reca -> @@ -72,7 +78,7 @@ let transform_rec loc env sigma (pj,c,lf) indt = (lambda_create env (applist (mI,List.append (List.map (lift (nar+1)) params) (extended_rel_list 0 lnames)), - mkMutCase (ci, lift (nar+2) p, mkRel 1, branches))) + mkCase (ci, lift (nar+2) p, mkRel 1, branches))) (lift_rel_context 1 lnames) in if noccurn 1 deffix then @@ -98,8 +104,7 @@ let transform_rec loc env sigma (pj,c,lf) indt = ([|Name(id_of_string "F")|],[|typPfix|],[|deffix|])) in applist (fix,realargs@[c]) else - let ci = make_default_case_info mispec in - mkMutCase (ci, p, c, lf) + mkCase (ci, p, c, lf) (***********************************************************************) @@ -125,7 +130,7 @@ let evar_type_fixpoint loc env isevars lna lar vdefj = if not (the_conv_x_leq env isevars (vdefj.(i)).uj_type (lift lt lar.(i))) then - error_ill_typed_rec_body_loc loc CCI env (evars_of isevars) + error_ill_typed_rec_body_loc loc env (evars_of isevars) i lna vdefj lar done @@ -133,7 +138,7 @@ let check_branches_message loc env isevars c (explft,lft) = for i = 0 to Array.length explft - 1 do if not (the_conv_x_leq env isevars lft.(i) explft.(i)) then let sigma = evars_of isevars in - error_ill_formed_branch_loc loc CCI env sigma c i lft.(i) explft.(i) + error_ill_formed_branch_loc loc env sigma c i lft.(i) explft.(i) done (* coerce to tycon if any *) @@ -156,7 +161,7 @@ let pretype_id loc env lvar id = { uj_val = mkRel n; uj_type = type_app (lift n) typ } with Not_found -> try - let typ = lookup_id_type id (named_context env) in + let (_,_,typ) = lookup_named id env in { uj_val = mkVar id; uj_type = typ } with Not_found -> error_var_not_found_loc loc id @@ -190,12 +195,12 @@ let pretype_ref _ isevars env lvar ref = | RInd (ind_sp,ctxt) -> let ind = (ind_sp,Array.map pretype ctxt) in - make_judge (mkMutInd ind) (type_of_inductive env (evars_of isevars) ind) + make_judge (mkInd ind) (type_of_inductive env (evars_of isevars) ind) | RConstruct (cstr_sp,ctxt) -> let cstr = (cstr_sp,Array.map pretype ctxt) in let typ = type_of_constructor env (evars_of isevars) cstr in - { uj_val=mkMutConstruct cstr; uj_type=typ } + { uj_val=mkConstruct cstr; uj_type=typ } *) let pretype_sort = function | RProp c -> judge_of_prop_contents c @@ -239,7 +244,7 @@ let rec pretype tycon env isevars lvar lmeta = function | RHole loc -> if !compter then nbimpl:=!nbimpl+1; (match tycon with - | Some ty -> { uj_val = new_isevar isevars env ty CCI; uj_type = ty } + | Some ty -> { uj_val = new_isevar isevars env ty; uj_type = ty } | None -> (match loc with None -> anomaly "There is an implicit argument I cannot solve" @@ -267,11 +272,11 @@ let rec pretype tycon env isevars lvar lmeta = function match fixkind with | RFix (vn,i as vni) -> let fix = (vni,(names,lara,Array.map j_val vdefj)) in - check_fix env (evars_of isevars) fix; + check_fix env fix; make_judge (mkFix fix) lara.(i) | RCoFix i -> let cofix = (i,(names,lara,Array.map j_val vdefj)) in - check_cofix env (evars_of isevars) cofix; + check_cofix env cofix; make_judge (mkCoFix cofix) lara.(i) in inh_conv_coerce_to_tycon loc env isevars fixj tycon @@ -289,7 +294,7 @@ let rec pretype tycon env isevars lvar lmeta = function let resty = whd_betadeltaiota env (evars_of isevars) resj.uj_type in match kind_of_term resty with - | IsProd (na,c1,c2) -> + | Prod (na,c1,c2) -> let hj = pretype (mk_tycon c1) env isevars lvar lmeta c in let newresj = { uj_val = applist (j_val resj, [j_val hj]); @@ -321,10 +326,9 @@ let rec pretype tycon env isevars lvar lmeta = function let (dom,rng) = split_tycon loc env isevars tycon in let dom_valcon = valcon_of_tycon dom in let j = pretype_type dom_valcon env isevars lvar lmeta c1 in - let var = (name,j.utj_val) in - let j' = pretype rng (push_rel_assum var env) isevars lvar lmeta c2 - in - fst (abs_rel env (evars_of isevars) name j.utj_val j') + let var = (name,None,j.utj_val) in + let j' = pretype rng (push_rel var env) isevars lvar lmeta c2 in + judge_of_abstraction env name j j' | RProd(loc,name,c1,c2) -> let j = pretype_type empty_valcon env isevars lvar lmeta c1 in @@ -332,15 +336,15 @@ let rec pretype tycon env isevars lvar lmeta = function let env' = push_rel_assum var env in let j' = pretype_type empty_valcon env' isevars lvar lmeta c2 in let resj = - try fst (gen_rel env (evars_of isevars) name j j') + try fst (judge_of_product env name j j') with TypeError _ as e -> Stdpp.raise_with_loc loc e in inh_conv_coerce_to_tycon loc env isevars resj tycon | RLetIn(loc,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 var = (name,Some j.uj_val,j.uj_type) in let tycon = option_app (lift 1) tycon in - let j' = pretype tycon (push_rel_def var env) isevars lvar lmeta c2 in + let j' = pretype tycon (push_rel var env) isevars lvar lmeta c2 in { uj_val = mkLetIn (name, j.uj_val, j.uj_type, j'.uj_val) ; uj_type = type_app (subst1 j.uj_val) j'.uj_type } @@ -349,7 +353,7 @@ let rec pretype tycon env isevars lvar lmeta = function let (IndType (indf,realargs) as indt) = try find_rectype env (evars_of isevars) cj.uj_type with Induc -> - error_case_not_inductive_loc loc CCI env (evars_of isevars) cj in + error_case_not_inductive_loc loc env (evars_of isevars) cj in let pj = match po with | Some p -> pretype empty_tycon env isevars lvar lmeta p | None -> @@ -382,8 +386,7 @@ let rec pretype tycon env isevars lvar lmeta = function findtype 0 in let pj = j_nf_evar (evars_of isevars) pj in - let (dep,_) = find_case_dep_nparams env (evars_of isevars) - (cj.uj_val,pj) indf in + let (dep,_) = find_case_dep_nparams env (cj.uj_val,pj) indf in let pj = if dep then pj else @@ -391,10 +394,10 @@ let rec pretype tycon env isevars lvar lmeta = function let rec decomp n p = if n=0 then p else match kind_of_term p with - | IsLambda (_,_,c) -> decomp (n-1) c + | Lambda (_,_,c) -> decomp (n-1) c | _ -> decomp (n-1) (applist (lift 1 p, [mkRel 1])) in let sign,s = decompose_prod_n n pj.uj_type in - let ind = build_dependent_inductive indf in + let ind = build_dependent_inductive env indf in let s' = mkProd (Anonymous, ind, s) in let ccl = lift 1 (decomp n pj.uj_val) in let ccl' = mkLambda (Anonymous, ind, ccl) in @@ -403,7 +406,7 @@ let rec pretype tycon env isevars lvar lmeta = function Indrec.type_rec_branches isrec env (evars_of isevars) indt pj cj.uj_val in if Array.length bty <> Array.length lf then - error_number_branches_loc loc CCI env (evars_of isevars) + error_number_branches_loc loc env (evars_of isevars) cj (Array.length bty) else let lfj = @@ -419,8 +422,8 @@ let rec pretype tycon env isevars lvar lmeta = function transform_rec loc env (evars_of isevars)(pj,cj.uj_val,lfv) indt else let mis,_ = dest_ind_family indf in - let ci = make_default_case_info mis in - mkMutCase (ci, (nf_betaiota pj.uj_val), cj.uj_val, + let ci = make_default_case_info env mis in + mkCase (ci, (nf_betaiota pj.uj_val), cj.uj_val, Array.map (fun j-> j.uj_val) lfj) in {uj_val = v; @@ -456,7 +459,7 @@ and pretype_type valcon env isevars lvar lmeta = function utj_type = Retyping.get_sort_of env (evars_of isevars) v } | None -> let s = new_Type_sort () in - { utj_val = new_isevar isevars env (mkSort s) CCI; utj_type = s}) + { utj_val = new_isevar isevars env (mkSort s); utj_type = s}) | c -> let j = pretype empty_tycon env isevars lvar lmeta c in let tj = inh_coerce_to_sort env isevars j in @@ -490,7 +493,7 @@ let check_evars fail_evar initial_sigma sigma c = let metamap = ref [] in let rec proc_rec c = match kind_of_term c with - | IsEvar (ev,args as k) -> + | Evar (ev,args as k) -> assert (Evd.in_dom sigma ev); if not (Evd.in_dom initial_sigma ev) then (if fail_evar then diff --git a/pretyping/rawterm.ml b/pretyping/rawterm.ml index c8c91a945..d82d7fbc8 100644 --- a/pretyping/rawterm.ml +++ b/pretyping/rawterm.ml @@ -13,6 +13,7 @@ open Util open Names open Sign open Term +open Nametab (*i*) (* Untyped intermediate terms, after ASTs and before constr. *) @@ -27,6 +28,8 @@ type cases_pattern = type rawsort = RProp of Term.contents | RType of Univ.universe option +type fix_kind = RFix of (int array * int) | RCoFix of int + type binder_kind = BProd | BLambda | BLetIn type 'ctxt reference = diff --git a/pretyping/rawterm.mli b/pretyping/rawterm.mli index 336b3ffa1..8d5184299 100644 --- a/pretyping/rawterm.mli +++ b/pretyping/rawterm.mli @@ -12,6 +12,7 @@ open Names open Sign open Term +open Nametab (*i*) (* Untyped intermediate terms, after ASTs and before constr. *) @@ -26,6 +27,8 @@ type cases_pattern = type rawsort = RProp of Term.contents | RType of Univ.universe option +type fix_kind = RFix of (int array * int) | RCoFix of int + type binder_kind = BProd | BLambda | BLetIn type 'ctxt reference = diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index 4c72ca1c0..6617a7a9b 100755 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -11,7 +11,9 @@ open Util open Pp open Names +open Nametab open Term +open Termops open Typeops open Libobject open Library diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli index d3811f413..a3dd2f2a3 100755 --- a/pretyping/recordops.mli +++ b/pretyping/recordops.mli @@ -10,6 +10,7 @@ (*i*) open Names +open Nametab open Term open Classops open Libobject diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml new file mode 100644 index 000000000..a34c47c5a --- /dev/null +++ b/pretyping/reductionops.ml @@ -0,0 +1,886 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +(* $Id$ *) + +open Pp +open Util +open Names +open Term +open Termops +open Univ +open Evd +open Declarations +open Environ +open Instantiate +open Closure +open Esubst + +exception Elimconst + +(* The type of (machine) states (= lambda-bar-calculus' cuts) *) +type state = constr * constr stack + +type 'a contextual_reduction_function = env -> 'a evar_map -> constr -> constr +type 'a reduction_function = 'a contextual_reduction_function +type local_reduction_function = constr -> constr + +type 'a contextual_stack_reduction_function = + env -> 'a evar_map -> constr -> constr * constr list +type 'a stack_reduction_function = 'a contextual_stack_reduction_function +type local_stack_reduction_function = constr -> constr * constr list + +type 'a contextual_state_reduction_function = + env -> 'a evar_map -> state -> state +type 'a state_reduction_function = 'a contextual_state_reduction_function +type local_state_reduction_function = state -> state + +(*************************************) +(*** Reduction Functions Operators ***) +(*************************************) + +let rec whd_state (x, stack as s) = + match kind_of_term x with + | App (f,cl) -> whd_state (f, append_stack cl stack) + | Cast (c,_) -> whd_state (c, stack) + | _ -> s + +let appterm_of_stack (f,s) = (f,list_of_stack s) + +let whd_stack x = appterm_of_stack (whd_state (x, empty_stack)) +let whd_castapp_stack = whd_stack + +let stack_reduction_of_reduction red_fun env sigma s = + let t = red_fun env sigma (app_stack s) in + whd_stack t + +let strong whdfun env sigma t = + let rec strongrec env t = + map_constr_with_full_binders push_rel strongrec env (whdfun env sigma t) in + strongrec env t + +let local_strong whdfun = + let rec strongrec t = map_constr strongrec (whdfun t) in + strongrec + +let rec strong_prodspine redfun c = + let x = redfun c in + match kind_of_term x with + | Prod (na,a,b) -> mkProd (na,a,strong_prodspine redfun b) + | _ -> x + +(*************************************) +(*** Reduction using substitutions ***) +(*************************************) + +(* This signature is very similar to Closure.RedFlagsSig except there + is eta but no per-constant unfolding *) + +module type RedFlagsSig = sig + type flags + type flag + val fbeta : flag + val fevar : flag + val fdelta : flag + val feta : flag + val fiota : flag + val fzeta : flag + val mkflags : flag list -> flags + val red_beta : flags -> bool + val red_delta : flags -> bool + val red_evar : flags -> bool + val red_eta : flags -> bool + val red_iota : flags -> bool + val red_zeta : flags -> bool +end + +(* Naive Implementation +module RedFlags = (struct + type flag = BETA | DELTA | EVAR | IOTA | ZETA | ETA + type flags = flag list + let fbeta = BETA + let fdelta = DELTA + let fevar = EVAR + let fiota = IOTA + let fzeta = ZETA + let feta = ETA + let mkflags l = l + let red_beta = List.mem BETA + let red_delta = List.mem DELTA + let red_evar = List.mem EVAR + let red_eta = List.mem ETA + let red_iota = List.mem IOTA + let red_zeta = List.mem ZETA +end : RedFlagsSig) +*) + +(* Compact Implementation *) +module RedFlags = (struct + type flag = int + type flags = int + let fbeta = 1 + let fdelta = 2 + let fevar = 4 + let feta = 8 + let fiota = 16 + let fzeta = 32 + let mkflags = List.fold_left (lor) 0 + let red_beta f = f land fbeta <> 0 + let red_delta f = f land fdelta <> 0 + let red_evar f = f land fevar <> 0 + let red_eta f = f land feta <> 0 + let red_iota f = f land fiota <> 0 + let red_zeta f = f land fzeta <> 0 +end : RedFlagsSig) + +open RedFlags + +(* Local *) +let beta = mkflags [fbeta] +let evar = mkflags [fevar] +let betaevar = mkflags [fevar; fbeta] +let betaiota = mkflags [fiota; fbeta] +let betaiotazeta = mkflags [fiota; fbeta;fzeta] + +(* Contextual *) +let delta = mkflags [fdelta;fevar] +let betadelta = mkflags [fbeta;fdelta;fzeta;fevar] +let betadeltaeta = mkflags [fbeta;fdelta;fzeta;fevar;feta] +let betadeltaiota = mkflags [fbeta;fdelta;fzeta;fevar;fiota] +let betadeltaiota_nolet = mkflags [fbeta;fdelta;fevar;fiota] +let betadeltaiotaeta = mkflags [fbeta;fdelta;fzeta;fevar;fiota;feta] +let betaiotaevar = mkflags [fbeta;fiota;fevar] +let betaetalet = mkflags [fbeta;feta;fzeta] + +(* Beta Reduction tools *) + +let rec stacklam recfun env t stack = + match (decomp_stack stack,kind_of_term t) with + | Some (h,stacktl), Lambda (_,_,c) -> stacklam recfun (h::env) c stacktl + | _ -> recfun (substl env t, stack) + +let beta_applist (c,l) = + stacklam app_stack [] c (append_stack (Array.of_list l) empty_stack) + +(* Iota reduction tools *) + +type 'a miota_args = { + mP : constr; (* the result type *) + mconstr : constr; (* the constructor *) + mci : case_info; (* special info to re-build pattern *) + mcargs : 'a list; (* the constructor's arguments *) + mlf : 'a array } (* the branch code vector *) + +let reducible_mind_case c = match kind_of_term c with + | Construct _ | CoFix _ -> true + | _ -> false + +let contract_cofix (bodynum,(types,names,bodies as typedbodies)) = + let nbodies = Array.length bodies in + let make_Fi j = mkCoFix (nbodies-j-1,typedbodies) in + substl (list_tabulate make_Fi nbodies) bodies.(bodynum) + +let reduce_mind_case mia = + match kind_of_term mia.mconstr with + | Construct (ind_sp,i as cstr_sp) -> +(* let ncargs = (fst mia.mci).(i-1) in*) + let real_cargs = snd (list_chop mia.mci.ci_npar mia.mcargs) in + applist (mia.mlf.(i-1),real_cargs) + | CoFix cofix -> + let cofix_def = contract_cofix cofix in + mkCase (mia.mci, mia.mP, applist(cofix_def,mia.mcargs), mia.mlf) + | _ -> assert false + +(* contracts fix==FIX[nl;i](A1...Ak;[F1...Fk]{B1....Bk}) to produce + Bi[Fj --> FIX[nl;j](A1...Ak;[F1...Fk]{B1...Bk})] *) + +let contract_fix ((recindices,bodynum),(types,names,bodies as typedbodies)) = + let nbodies = Array.length recindices in + let make_Fi j = mkFix ((recindices,nbodies-j-1),typedbodies) in + substl (list_tabulate make_Fi nbodies) bodies.(bodynum) + +let fix_recarg ((recindices,bodynum),_) stack = + assert (0 <= bodynum & bodynum < Array.length recindices); + let recargnum = Array.get recindices bodynum in + try + Some (recargnum, stack_nth stack recargnum) + with Not_found -> + None + +type fix_reduction_result = NotReducible | Reduced of state + +let reduce_fix whdfun fix stack = + match fix_recarg fix stack with + | None -> NotReducible + | Some (recargnum,recarg) -> + let (recarg'hd,_ as recarg') = whdfun (recarg, empty_stack) in + let stack' = stack_assign stack recargnum (app_stack recarg') in + (match kind_of_term recarg'hd with + | Construct _ -> Reduced (contract_fix fix, stack') + | _ -> NotReducible) + +(* Generic reduction function *) + +(* Y avait un commentaire pour whd_betadeltaiota : + + NB : Cette fonction alloue peu c'est l'appel + ``let (c,cargs) = whfun (recarg, empty_stack)'' + ------------------- + qui coute cher *) + +let rec whd_state_gen flags env sigma = + let rec whrec (x, stack as s) = + match kind_of_term x with + | Rel n when red_delta flags -> + (match lookup_rel n env with + | (_,Some body,_) -> whrec (lift n body, stack) + | _ -> s) + | Var id when red_delta flags -> + (match lookup_named id env with + | (_,Some body,_) -> whrec (body, stack) + | _ -> s) + | Evar ev when red_evar flags -> + (match existential_opt_value sigma ev with + | Some body -> whrec (body, stack) + | None -> s) + | Const const when red_delta flags -> + (match constant_opt_value env const with + | Some body -> whrec (body, stack) + | None -> s) + | LetIn (_,b,_,c) when red_zeta flags -> stacklam whrec [b] c stack + | Cast (c,_) -> whrec (c, stack) + | App (f,cl) -> whrec (f, append_stack cl stack) + | Lambda (na,t,c) -> + (match decomp_stack stack with + | Some (a,m) when red_beta flags -> stacklam whrec [a] c m + | None when red_eta flags -> + let env' = push_rel (na,None,t) env in + let whrec' = whd_state_gen flags env' sigma in + (match kind_of_term (app_stack (whrec' (c, empty_stack))) with + | App (f,cl) -> + let napp = Array.length cl in + if napp > 0 then + let x', l' = whrec' (array_last cl, empty_stack) in + match kind_of_term x', decomp_stack l' with + | Rel 1, None -> + let lc = Array.sub cl 0 (napp-1) in + let u = if napp=1 then f else appvect (f,lc) in + if noccurn 1 u then (pop u,empty_stack) else s + | _ -> s + else s + | _ -> s) + | _ -> s) + + | Case (ci,p,d,lf) when red_iota flags -> + let (c,cargs) = whrec (d, empty_stack) in + if reducible_mind_case c then + whrec (reduce_mind_case + {mP=p; mconstr=c; mcargs=list_of_stack cargs; + mci=ci; mlf=lf}, stack) + else + (mkCase (ci, p, app_stack (c,cargs), lf), stack) + + | Fix fix when red_iota flags -> + (match reduce_fix whrec fix stack with + | Reduced s' -> whrec s' + | NotReducible -> s) + + | x -> s + in + whrec + +let local_whd_state_gen flags = + let rec whrec (x, stack as s) = + match kind_of_term x with + | LetIn (_,b,_,c) when red_zeta flags -> stacklam whrec [b] c stack + | Cast (c,_) -> whrec (c, stack) + | App (f,cl) -> whrec (f, append_stack cl stack) + | Lambda (_,_,c) -> + (match decomp_stack stack with + | Some (a,m) when red_beta flags -> stacklam whrec [a] c m + | None when red_eta flags -> + (match kind_of_term (app_stack (whrec (c, empty_stack))) with + | App (f,cl) -> + let napp = Array.length cl in + if napp > 0 then + let x', l' = whrec (array_last cl, empty_stack) in + match kind_of_term x', decomp_stack l' with + | Rel 1, None -> + let lc = Array.sub cl 0 (napp-1) in + let u = if napp=1 then f else appvect (f,lc) in + if noccurn 1 u then (pop u,empty_stack) else s + | _ -> s + else s + | _ -> s) + | _ -> s) + + | Case (ci,p,d,lf) when red_iota flags -> + let (c,cargs) = whrec (d, empty_stack) in + if reducible_mind_case c then + whrec (reduce_mind_case + {mP=p; mconstr=c; mcargs=list_of_stack cargs; + mci=ci; mlf=lf}, stack) + else + (mkCase (ci, p, app_stack (c,cargs), lf), stack) + + | Fix fix when red_iota flags -> + (match reduce_fix whrec fix stack with + | Reduced s' -> whrec s' + | NotReducible -> s) + + | x -> s + in + whrec + +(* 1. Beta Reduction Functions *) + +let whd_beta_state = local_whd_state_gen beta +let whd_beta_stack x = appterm_of_stack (whd_beta_state (x, empty_stack)) +let whd_beta x = app_stack (whd_beta_state (x,empty_stack)) + +(* Nouveau ! *) +let whd_betaetalet_state = local_whd_state_gen betaetalet +let whd_betaetalet_stack x = + appterm_of_stack (whd_betaetalet_state (x, empty_stack)) +let whd_betaetalet x = app_stack (whd_betaetalet_state (x,empty_stack)) + +(* 2. Delta Reduction Functions *) + +let whd_delta_state e = whd_state_gen delta e +let whd_delta_stack env sigma x = + appterm_of_stack (whd_delta_state env sigma (x, empty_stack)) +let whd_delta env sigma c = + app_stack (whd_delta_state env sigma (c, empty_stack)) + +let whd_betadelta_state e = whd_state_gen betadelta e +let whd_betadelta_stack env sigma x = + appterm_of_stack (whd_betadelta_state env sigma (x, empty_stack)) +let whd_betadelta env sigma c = + app_stack (whd_betadelta_state env sigma (c, empty_stack)) + +let whd_betaevar_state e = whd_state_gen betaevar e +let whd_betaevar_stack env sigma c = + appterm_of_stack (whd_betaevar_state env sigma (c, empty_stack)) +let whd_betaevar env sigma c = + app_stack (whd_betaevar_state env sigma (c, empty_stack)) + + +let whd_betadeltaeta_state e = whd_state_gen betadeltaeta e +let whd_betadeltaeta_stack env sigma x = + appterm_of_stack (whd_betadeltaeta_state env sigma (x, empty_stack)) +let whd_betadeltaeta env sigma x = + app_stack (whd_betadeltaeta_state env sigma (x, empty_stack)) + +(* 3. Iota reduction Functions *) + +let whd_betaiota_state = local_whd_state_gen betaiota +let whd_betaiota_stack x = + appterm_of_stack (whd_betaiota_state (x, empty_stack)) +let whd_betaiota x = + app_stack (whd_betaiota_state (x, empty_stack)) + +let whd_betaiotazeta_state = local_whd_state_gen betaiotazeta +let whd_betaiotazeta_stack x = + appterm_of_stack (whd_betaiotazeta_state (x, empty_stack)) +let whd_betaiotazeta x = + app_stack (whd_betaiotazeta_state (x, empty_stack)) + +let whd_betaiotaevar_state e = whd_state_gen betaiotaevar e +let whd_betaiotaevar_stack env sigma x = + appterm_of_stack (whd_betaiotaevar_state env sigma (x, empty_stack)) +let whd_betaiotaevar env sigma x = + app_stack (whd_betaiotaevar_state env sigma (x, empty_stack)) + +let whd_betadeltaiota_state e = whd_state_gen betadeltaiota e +let whd_betadeltaiota_stack env sigma x = + appterm_of_stack (whd_betadeltaiota_state env sigma (x, empty_stack)) +let whd_betadeltaiota env sigma x = + app_stack (whd_betadeltaiota_state env sigma (x, empty_stack)) + +let whd_betadeltaiotaeta_state e = whd_state_gen betadeltaiotaeta e +let whd_betadeltaiotaeta_stack env sigma x = + appterm_of_stack (whd_betadeltaiotaeta_state env sigma (x, empty_stack)) +let whd_betadeltaiotaeta env sigma x = + app_stack (whd_betadeltaiotaeta_state env sigma (x, empty_stack)) + +let whd_betadeltaiota_nolet_state e = whd_state_gen betadeltaiota_nolet e +let whd_betadeltaiota_nolet_stack env sigma x = + appterm_of_stack (whd_betadeltaiota_nolet_state env sigma (x, empty_stack)) +let whd_betadeltaiota_nolet env sigma x = + app_stack (whd_betadeltaiota_nolet_state env sigma (x, empty_stack)) + +(****************************************************************************) +(* Reduction Functions *) +(****************************************************************************) + +(* Replacing defined evars for error messages *) +let rec whd_evar sigma c = + match kind_of_term c with + | Evar (ev,args) when Evd.in_dom sigma ev & Evd.is_defined sigma ev -> + whd_evar sigma (Instantiate.existential_value sigma (ev,args)) + | _ -> collapse_appl c + +let nf_evar sigma = + local_strong (whd_evar sigma) + +(* lazy reduction functions. The infos must be created for each term *) +let clos_norm_flags flgs env sigma t = + norm_val (create_clos_infos flgs env) (inject (nf_evar sigma t)) + +let nf_beta = clos_norm_flags Closure.beta empty_env Evd.empty +let nf_betaiota = clos_norm_flags Closure.betaiota empty_env Evd.empty +let nf_betadeltaiota env sigma = + clos_norm_flags Closure.betadeltaiota env sigma + +(* lazy weak head reduction functions *) +let whd_flags flgs env sigma t = + whd_val (create_clos_infos flgs env) (inject (nf_evar sigma t)) + +(********************************************************************) +(* Conversion *) +(********************************************************************) +(* +let fkey = Profile.declare_profile "fhnf";; +let fhnf info v = Profile.profile2 fkey fhnf info v;; + +let fakey = Profile.declare_profile "fhnf_apply";; +let fhnf_apply info k h a = Profile.profile4 fakey fhnf_apply info k h a;; +*) + +type 'a conversion_function = + env -> 'a evar_map -> constr -> constr -> constraints + +(* Conversion utility functions *) + +type conversion_test = constraints -> constraints + +exception NotConvertible + +(* Convertibility of sorts *) + +type conv_pb = + | CONV + | CUMUL + +let pb_is_equal pb = pb = CONV + +let pb_equal = function + | CUMUL -> CONV + | CONV -> CONV + +let sort_cmp pb s0 s1 cuniv = + match (s0,s1) with + | (Prop c1, Prop c2) -> if c1 = c2 then cuniv else raise NotConvertible + | (Prop c1, Type u) -> + (match pb with + CUMUL -> cuniv + | _ -> raise NotConvertible) + | (Type u1, Type u2) -> + (match pb with + | CONV -> enforce_eq u1 u2 cuniv + | CUMUL -> enforce_geq u2 u1 cuniv) + | (_, _) -> raise NotConvertible + +let base_sort_cmp pb s0 s1 = + match (s0,s1) with + | (Prop c1, Prop c2) -> c1 = c2 + | (Prop c1, Type u) -> pb = CUMUL + | (Type u1, Type u2) -> true + | (_, _) -> false + +(* Conversion between [lft1]term1 and [lft2]term2 *) +let rec ccnv cv_pb infos lft1 lft2 term1 term2 cuniv = + eqappr cv_pb infos (lft1, fhnf infos term1) (lft2, fhnf infos term2) cuniv + +(* Conversion between [lft1]([^n1]hd1 v1) and [lft2]([^n2]hd2 v2) *) +and eqappr cv_pb infos appr1 appr2 cuniv = + let (lft1,(n1,hd1,v1)) = appr1 + and (lft2,(n2,hd2,v2)) = appr2 in + let el1 = el_shft n1 lft1 + and el2 = el_shft n2 lft2 in + match (fterm_of hd1, fterm_of hd2) with + (* case of leaves *) + | (FAtom a1, FAtom a2) -> + (match kind_of_term a1, kind_of_term a2 with + | (Sort s1, Sort s2) -> + if stack_args_size v1 = 0 && stack_args_size v2 = 0 + then sort_cmp cv_pb s1 s2 cuniv + else raise NotConvertible + | (Meta n, Meta m) -> + if n=m + then convert_stacks infos lft1 lft2 v1 v2 cuniv + else raise NotConvertible + | _ -> raise NotConvertible) + + (* 2 index known to be bound to no constant *) + | (FRel n, FRel m) -> + if reloc_rel n el1 = reloc_rel m el2 + then convert_stacks infos lft1 lft2 v1 v2 cuniv + else raise NotConvertible + + (* 2 constants, 2 existentials or 2 local defined vars or 2 defined rels *) + | (FFlex fl1, FFlex fl2) -> + (try (* try first intensional equality *) + if fl1 = fl2 + then + convert_stacks infos lft1 lft2 v1 v2 cuniv + else raise NotConvertible + with NotConvertible -> + (* else expand the second occurrence (arbitrary heuristic) *) + match unfold_reference infos fl2 with + | Some def2 -> + eqappr cv_pb infos appr1 + (lft2, fhnf_apply infos n2 def2 v2) cuniv + | None -> + (match unfold_reference infos fl1 with + | Some def1 -> + eqappr cv_pb infos + (lft1, fhnf_apply infos n1 def1 v1) appr2 cuniv + | None -> raise NotConvertible)) + + (* only one constant, existential, defined var or defined rel *) + | (FFlex fl1, _) -> + (match unfold_reference infos fl1 with + | Some def1 -> + eqappr cv_pb infos (lft1, fhnf_apply infos n1 def1 v1) + appr2 cuniv + | None -> raise NotConvertible) + | (_, FFlex fl2) -> + (match unfold_reference infos fl2 with + | Some def2 -> + eqappr cv_pb infos appr1 + (lft2, fhnf_apply infos n2 def2 v2) + cuniv + | None -> raise NotConvertible) + + (* other constructors *) + | (FLambda (_,c1,c2,_,_), FLambda (_,c'1,c'2,_,_)) -> + if stack_args_size v1 = 0 && stack_args_size v2 = 0 + then + let u1 = ccnv CONV infos el1 el2 c1 c'1 cuniv in + ccnv CONV infos + (el_lift el1) (el_lift el2) c2 c'2 u1 + else raise NotConvertible + + | (FLetIn _, _) | (_, FLetIn _) -> + anomaly "LetIn normally removed by fhnf" + + | (FProd (_,c1,c2,_,_), FProd (_,c'1,c'2,_,_)) -> + if stack_args_size v1 = 0 && stack_args_size v2 = 0 + then (* Luo's system *) + let u1 = ccnv CONV infos el1 el2 c1 c'1 cuniv in + ccnv cv_pb infos (el_lift el1) (el_lift el2) c2 c'2 u1 + else raise NotConvertible + + (* Inductive types: Ind Construct Case Fix Cofix *) + + (* Les annotations du Case ne servent qu'ŕ l'affichage *) + + | (FCases (_,p1,c1,cl1), FCases (_,p2,c2,cl2)) -> + let u1 = ccnv CONV infos el1 el2 p1 p2 cuniv in + let u2 = ccnv CONV infos el1 el2 c1 c2 u1 in + let u3 = convert_vect infos el1 el2 cl1 cl2 u2 in + convert_stacks infos lft1 lft2 v1 v2 u3 + + | (FInd op1, FInd op2) -> + if op1 = op2 + then convert_stacks infos lft1 lft2 v1 v2 cuniv + else raise NotConvertible + + | (FConstruct op1, FConstruct op2) -> + if op1 = op2 + then convert_stacks infos lft1 lft2 v1 v2 cuniv + else raise NotConvertible + + | (FFix (op1,(_,tys1,cl1),_,_), FFix(op2,(_,tys2,cl2),_,_)) -> + if op1 = op2 + then + let u1 = convert_vect infos el1 el2 tys1 tys2 cuniv in + let n = Array.length cl1 in + let u2 = + convert_vect infos + (el_liftn n el1) (el_liftn n el2) cl1 cl2 u1 in + convert_stacks infos lft1 lft2 v1 v2 u2 + else raise NotConvertible + + | (FCoFix (op1,(_,tys1,cl1),_,_), FCoFix(op2,(_,tys2,cl2),_,_)) -> + if op1 = op2 + then + let u1 = convert_vect infos el1 el2 tys1 tys2 cuniv in + let n = Array.length cl1 in + let u2 = + convert_vect infos + (el_liftn n el1) (el_liftn n el2) cl1 cl2 u1 in + convert_stacks infos lft1 lft2 v1 v2 u2 + else raise NotConvertible + + | _ -> raise NotConvertible + +and convert_stacks infos lft1 lft2 stk1 stk2 cuniv = + match (decomp_stack stk1, decomp_stack stk2) with + (Some(a1,s1), Some(a2,s2)) -> + let u1 = ccnv CONV infos lft1 lft2 a1 a2 cuniv in + convert_stacks infos lft1 lft2 s1 s2 u1 + | (None, None) -> cuniv + | _ -> raise NotConvertible + +and convert_vect infos lft1 lft2 v1 v2 cuniv = + let lv1 = Array.length v1 in + let lv2 = Array.length v2 in + if lv1 = lv2 + then + let rec fold n univ = + if n >= lv1 then univ + else + let u1 = ccnv CONV infos lft1 lft2 v1.(n) v2.(n) univ in + fold (n+1) u1 in + fold 0 cuniv + else raise NotConvertible + + + +let fconv cv_pb env sigma t1 t2 = + if eq_constr t1 t2 then + Constraint.empty + else + let infos = create_clos_infos hnf_flags env in + ccnv cv_pb infos ELID ELID + (inject (nf_evar sigma t1)) + (inject (nf_evar sigma t2)) + Constraint.empty + +let conv env = fconv CONV env +let conv_leq env = fconv CUMUL env + +(* +let convleqkey = Profile.declare_profile "conv_leq";; +let conv_leq env sigma t1 t2 = + Profile.profile4 convleqkey conv_leq env sigma t1 t2;; + +let convkey = Profile.declare_profile "conv";; +let conv env sigma t1 t2 = + Profile.profile4 convleqkey conv env sigma t1 t2;; +*) + +let conv_forall2 f env sigma v1 v2 = + array_fold_left2 + (fun c x y -> let c' = f env sigma x y in Constraint.union c c') + Constraint.empty + v1 v2 + +let conv_forall2_i f env sigma v1 v2 = + array_fold_left2_i + (fun i c x y -> let c' = f i env sigma x y in Constraint.union c c') + Constraint.empty + v1 v2 + +let test_conversion f env sigma x y = + try let _ = f env sigma x y in true with NotConvertible -> false + +let is_conv env sigma = test_conversion conv env sigma +let is_conv_leq env sigma = test_conversion conv_leq env sigma +let is_fconv = function | CONV -> is_conv | CUMUL -> is_conv_leq + +(********************************************************************) +(* Special-Purpose Reduction *) +(********************************************************************) + +let whd_meta metamap c = match kind_of_term c with + | Meta p -> (try List.assoc p metamap with Not_found -> c) + | _ -> c + +(* Try to replace all metas. Does not replace metas in the metas' values + * Differs from (strong whd_meta). *) +let plain_instance s c = + let rec irec u = match kind_of_term u with + | Meta p -> (try List.assoc p s with Not_found -> u) + | Cast (m,_) when isMeta m -> + (try List.assoc (destMeta m) s with Not_found -> u) + | _ -> map_constr irec u + in + if s = [] then c else irec c + +(* Pourquoi ne fait-on pas nf_betaiota si s=[] ? *) +let instance s c = + if s = [] then c else local_strong whd_betaiota (plain_instance s c) + + +(* pseudo-reduction rule: + * [hnf_prod_app env s (Prod(_,B)) N --> B[N] + * with an HNF on the first argument to produce a product. + * if this does not work, then we use the string S as part of our + * error message. *) + +let hnf_prod_app env sigma t n = + match kind_of_term (whd_betadeltaiota env sigma t) with + | Prod (_,_,b) -> subst1 n b + | _ -> anomaly "hnf_prod_app: Need a product" + +let hnf_prod_appvect env sigma t nl = + Array.fold_left (hnf_prod_app env sigma) t nl + +let hnf_prod_applist env sigma t nl = + List.fold_left (hnf_prod_app env sigma) t nl + +let hnf_lam_app env sigma t n = + match kind_of_term (whd_betadeltaiota env sigma t) with + | Lambda (_,_,b) -> subst1 n b + | _ -> anomaly "hnf_lam_app: Need an abstraction" + +let hnf_lam_appvect env sigma t nl = + Array.fold_left (hnf_lam_app env sigma) t nl + +let hnf_lam_applist env sigma t nl = + List.fold_left (hnf_lam_app env sigma) t nl + +let splay_prod env sigma = + let rec decrec env m c = + let t = whd_betadeltaiota env sigma c in + match kind_of_term t with + | Prod (n,a,c0) -> + decrec (push_rel (n,None,a) env) + ((n,a)::m) c0 + | _ -> m,t + in + decrec env [] + +let splay_prod_assum env sigma = + let rec prodec_rec env l c = + let t = whd_betadeltaiota_nolet env sigma c in + match kind_of_term c with + | Prod (x,t,c) -> + prodec_rec (push_rel (x,None,t) env) + (Sign.add_rel_decl (x, None, t) l) c + | LetIn (x,b,t,c) -> + prodec_rec (push_rel (x, Some b, t) env) + (Sign.add_rel_decl (x, Some b, t) l) c + | Cast (c,_) -> prodec_rec env l c + | _ -> l,t + in + prodec_rec env Sign.empty_rel_context + +let splay_arity env sigma c = + let l, c = splay_prod env sigma c in + match kind_of_term c with + | Sort s -> l,s + | _ -> error "not an arity" + +let sort_of_arity env c = snd (splay_arity env Evd.empty c) + +let decomp_n_prod env sigma n = + let rec decrec env m ln c = if m = 0 then (ln,c) else + match kind_of_term (whd_betadeltaiota env sigma c) with + | Prod (n,a,c0) -> + decrec (push_rel (n,None,a) env) + (m-1) (Sign.add_rel_decl (n,None,a) ln) c0 + | _ -> error "decomp_n_prod: Not enough products" + in + decrec env n Sign.empty_rel_context + +(* One step of approximation *) + +let rec apprec env sigma s = + let (t, stack as s) = whd_betaiota_state s in + match kind_of_term t with + | Case (ci,p,d,lf) -> + let (cr,crargs) = whd_betadeltaiota_stack env sigma d in + let rslt = mkCase (ci, p, applist (cr,crargs), lf) in + if reducible_mind_case cr then + apprec env sigma (rslt, stack) + else + s + | Fix fix -> + (match reduce_fix (whd_betadeltaiota_state env sigma) fix stack with + | Reduced s -> apprec env sigma s + | NotReducible -> s) + | _ -> s + +let hnf env sigma c = apprec env sigma (c, empty_stack) + +(* A reduction function like whd_betaiota but which keeps casts + * and does not reduce redexes containing existential variables. + * Used in Correctness. + * Added by JCF, 29/1/98. *) + +let whd_programs_stack env sigma = + let rec whrec (x, stack as s) = + match kind_of_term x with + | App (f,cl) -> + let n = Array.length cl - 1 in + let c = cl.(n) in + if occur_existential c then + s + else + whrec (mkApp (f, Array.sub cl 0 n), append_stack [|c|] stack) + | LetIn (_,b,_,c) -> + if occur_existential b then + s + else + stacklam whrec [b] c stack + | Lambda (_,_,c) -> + (match decomp_stack stack with + | None -> s + | Some (a,m) -> stacklam whrec [a] c m) + | Case (ci,p,d,lf) -> + if occur_existential d then + s + else + let (c,cargs) = whrec (d, empty_stack) in + if reducible_mind_case c then + whrec (reduce_mind_case + {mP=p; mconstr=c; mcargs=list_of_stack cargs; + mci=ci; mlf=lf}, stack) + else + (mkCase (ci, p, app_stack(c,cargs), lf), stack) + | Fix fix -> + (match reduce_fix whrec fix stack with + | Reduced s' -> whrec s' + | NotReducible -> s) + | _ -> s + in + whrec + +let whd_programs env sigma x = + app_stack (whd_programs_stack env sigma (x, empty_stack)) + +exception IsType + +let find_conclusion env sigma = + let rec decrec env c = + let t = whd_betadeltaiota env sigma c in + match kind_of_term t with + | Prod (x,t,c0) -> decrec (push_rel (x,None,t) env) c0 + | Lambda (x,t,c0) -> decrec (push_rel (x,None,t) env) c0 + | t -> t + in + decrec env + +let is_arity env sigma c = + match find_conclusion env sigma c with + | Sort _ -> true + | _ -> false + +let info_arity env sigma c = + match find_conclusion env sigma c with + | Sort (Prop Null) -> false + | Sort (Prop Pos) -> true + | _ -> raise IsType + +let is_info_arity env sigma c = + try (info_arity env sigma c) with IsType -> true + +let is_type_arity env sigma c = + match find_conclusion env sigma c with + | Sort (Type _) -> true + | _ -> false + +let is_info_type env sigma t = + let s = t.utj_type in + (s = Prop Pos) || + (s <> Prop Null && + try info_arity env sigma t.utj_val with IsType -> true) diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli new file mode 100644 index 000000000..20c991032 --- /dev/null +++ b/pretyping/reductionops.mli @@ -0,0 +1,205 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +(*i $Id$ i*) + +(*i*) +open Names +open Term +open Univ +open Evd +open Environ +open Closure +(*i*) + +(* Reduction Functions. *) + +exception Elimconst + +type state = constr * constr stack + +type 'a contextual_reduction_function = env -> 'a evar_map -> constr -> constr +type 'a reduction_function = 'a contextual_reduction_function +type local_reduction_function = constr -> constr + +type 'a contextual_stack_reduction_function = + env -> 'a evar_map -> constr -> constr * constr list +type 'a stack_reduction_function = 'a contextual_stack_reduction_function +type local_stack_reduction_function = constr -> constr * constr list + +type 'a contextual_state_reduction_function = + env -> 'a evar_map -> state -> state +type 'a state_reduction_function = 'a contextual_state_reduction_function +type local_state_reduction_function = state -> state + +(* Removes cast and put into applicative form *) +val whd_stack : local_stack_reduction_function + +(* For compatibility: alias for whd\_stack *) +val whd_castapp_stack : local_stack_reduction_function + +(*s Reduction Function Operators *) + +val strong : 'a reduction_function -> 'a reduction_function +val local_strong : local_reduction_function -> local_reduction_function +val strong_prodspine : local_reduction_function -> local_reduction_function +(*i +val stack_reduction_of_reduction : + 'a reduction_function -> 'a state_reduction_function +i*) +val stacklam : (state -> 'a) -> constr list -> constr -> constr stack -> 'a + +(*s Generic Optimized Reduction Function using Closures *) + +val clos_norm_flags : Closure.flags -> 'a reduction_function +(* Same as [(strong whd_beta[delta][iota])], but much faster on big terms *) +val nf_beta : local_reduction_function +val nf_betaiota : local_reduction_function +val nf_betadeltaiota : 'a reduction_function +val nf_evar : 'a evar_map -> constr -> constr + +(* Lazy strategy, weak head reduction *) +val whd_evar : 'a evar_map -> constr -> constr +val whd_beta : local_reduction_function +val whd_betaiota : local_reduction_function +val whd_betaiotazeta : local_reduction_function +val whd_betadeltaiota : 'a contextual_reduction_function +val whd_betadeltaiota_nolet : 'a contextual_reduction_function +val whd_betaetalet : local_reduction_function + +val whd_beta_stack : local_stack_reduction_function +val whd_betaiota_stack : local_stack_reduction_function +val whd_betaiotazeta_stack : local_stack_reduction_function +val whd_betadeltaiota_stack : 'a contextual_stack_reduction_function +val whd_betadeltaiota_nolet_stack : 'a contextual_stack_reduction_function +val whd_betaetalet_stack : local_stack_reduction_function + +val whd_beta_state : local_state_reduction_function +val whd_betaiota_state : local_state_reduction_function +val whd_betaiotazeta_state : local_state_reduction_function +val whd_betadeltaiota_state : 'a contextual_state_reduction_function +val whd_betadeltaiota_nolet_state : 'a contextual_state_reduction_function +val whd_betaetalet_state : local_state_reduction_function + +(*s Head normal forms *) + +val whd_delta_stack : 'a stack_reduction_function +val whd_delta_state : 'a state_reduction_function +val whd_delta : 'a reduction_function +val whd_betadelta_stack : 'a stack_reduction_function +val whd_betadelta_state : 'a state_reduction_function +val whd_betadelta : 'a reduction_function +val whd_betaevar_stack : 'a stack_reduction_function +val whd_betaevar_state : 'a state_reduction_function +val whd_betaevar : 'a reduction_function +val whd_betaiotaevar_stack : 'a stack_reduction_function +val whd_betaiotaevar_state : 'a state_reduction_function +val whd_betaiotaevar : 'a reduction_function +val whd_betadeltaeta_stack : 'a stack_reduction_function +val whd_betadeltaeta_state : 'a state_reduction_function +val whd_betadeltaeta : 'a reduction_function +val whd_betadeltaiotaeta_stack : 'a stack_reduction_function +val whd_betadeltaiotaeta_state : 'a state_reduction_function +val whd_betadeltaiotaeta : 'a reduction_function + +val beta_applist : constr * constr list -> constr + +val hnf_prod_app : env -> 'a evar_map -> constr -> constr -> constr +val hnf_prod_appvect : env -> 'a evar_map -> constr -> constr array -> constr +val hnf_prod_applist : env -> 'a evar_map -> constr -> constr list -> constr +val hnf_lam_app : env -> 'a evar_map -> constr -> constr -> constr +val hnf_lam_appvect : env -> 'a evar_map -> constr -> constr array -> constr +val hnf_lam_applist : env -> 'a evar_map -> constr -> constr list -> constr + +val splay_prod : env -> 'a evar_map -> constr -> (name * constr) list * constr +val splay_arity : env -> 'a evar_map -> constr -> (name * constr) list * sorts +val sort_of_arity : env -> constr -> sorts +val decomp_n_prod : + env -> 'a evar_map -> int -> constr -> Sign.rel_context * constr +val splay_prod_assum : + env -> 'a evar_map -> constr -> Sign.rel_context * constr + +type 'a miota_args = { + mP : constr; (* the result type *) + mconstr : constr; (* the constructor *) + mci : case_info; (* special info to re-build pattern *) + mcargs : 'a list; (* the constructor's arguments *) + mlf : 'a array } (* the branch code vector *) + +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_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 whd_programs : 'a reduction_function + +(* [reduce_fix] contracts a fix redex if it is actually reducible *) + +type fix_reduction_result = NotReducible | Reduced of state + +val fix_recarg : fixpoint -> constr stack -> (int * constr) option +val reduce_fix : local_state_reduction_function -> fixpoint + -> constr stack -> fix_reduction_result + +(*s Conversion Functions (uses closures, lazy strategy) *) + +type conversion_test = constraints -> constraints + +exception NotConvertible + +type conv_pb = + | CONV + | CUMUL + +val pb_is_equal : conv_pb -> bool +val pb_equal : conv_pb -> conv_pb + +val sort_cmp : conv_pb -> sorts -> sorts -> conversion_test +val base_sort_cmp : conv_pb -> sorts -> sorts -> bool + +type 'a conversion_function = + env -> 'a evar_map -> constr -> constr -> constraints + +(* [fconv] has 2 instances: [conv = fconv CONV] i.e. conversion test, and + [conv_leq = fconv CONV_LEQ] i.e. cumulativity test. *) + +val conv : 'a conversion_function +val conv_leq : 'a conversion_function + +val conv_forall2 : + 'a conversion_function -> env -> 'a evar_map -> constr array + -> constr array -> constraints + +val conv_forall2_i : + (int -> 'a conversion_function) -> env -> 'a evar_map + -> constr array -> constr array -> constraints + +val is_conv : env -> 'a evar_map -> constr -> constr -> bool +val is_conv_leq : env -> 'a evar_map -> constr -> constr -> bool +val is_fconv : conv_pb -> env -> 'a evar_map -> constr -> constr -> bool + +(*s Special-Purpose Reduction Functions *) + +val whd_meta : (int * constr) list -> constr -> constr +val plain_instance : (int * constr) list -> constr -> constr +val instance : (int * constr) list -> constr -> constr + +(*s Obsolete Reduction Functions *) + +(*i +val hnf : env -> 'a evar_map -> constr -> constr * constr list +i*) +val apprec : 'a state_reduction_function + diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index 5ed6e6051..bb6948767 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -12,23 +12,25 @@ open Util open Term open Inductive open Names -open Reduction +open Reductionops open Environ open Typeops +open Declarations +open Instantiate type metamap = (int * constr) list let outsort env sigma t = match kind_of_term (whd_betadeltaiota env sigma t) with - | IsSort s -> s + | Sort s -> s | _ -> anomaly "Retyping: found a type of type which is not a sort" let rec subst_type env sigma typ = function | [] -> typ | h::rest -> match kind_of_term (whd_betadeltaiota env sigma typ) with - | IsProd (na,c1,c2) -> - subst_type (push_rel_assum (na,c1) env) sigma (subst1 h c2) rest + | Prod (na,c1,c2) -> + subst_type (push_rel (na,None,c1) env) sigma (subst1 h c2) rest | _ -> anomaly "Non-functional construction" (* Si ft est le type d'un terme f, lequel est appliqué ŕ args, *) @@ -39,71 +41,74 @@ let rec subst_type env sigma typ = function let sort_of_atomic_type env sigma ft args = let rec concl_of_arity env ar = match kind_of_term (whd_betadeltaiota env sigma ar) with - | IsProd (na, t, b) -> concl_of_arity (push_rel_assum (na,t) env) b - | IsSort s -> s + | Prod (na, t, b) -> concl_of_arity (push_rel (na,None,t) env) b + | Sort s -> s | _ -> outsort env sigma (subst_type env sigma ft (Array.to_list args)) in concl_of_arity env ft let typeur sigma metamap = let rec type_of env cstr= match kind_of_term cstr with - | IsMeta n -> + | Meta 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))) - | IsVar id -> - (try body_of_type (snd (lookup_named id env)) - with Not_found -> - anomaly ("type_of: variable "^(string_of_id id)^" unbound")) - | IsConst c -> body_of_type (type_of_constant env sigma c) - | IsEvar ev -> type_of_existential env sigma ev - | IsMutInd ind -> body_of_type (type_of_inductive env sigma ind) - | IsMutConstruct cstr -> body_of_type (type_of_constructor env sigma cstr) - | IsMutCase (_,p,c,lf) -> - let IndType (indf,realargs) = - try find_rectype env sigma (type_of env c) + | Rel n -> + let (_,_,ty) = lookup_rel n env in + lift n (body_of_type ty) + | Var id -> + let (_,_,ty) = lookup_named id env in + (try body_of_type ty + with Not_found -> + anomaly ("type_of: variable "^(string_of_id id)^" unbound")) + | Const c -> + let cb = lookup_constant c env in + body_of_type cb.const_type + | Evar ev -> existential_type sigma ev + | Ind ind -> body_of_type (type_of_inductive env ind) + | Construct cstr -> body_of_type (type_of_constructor env cstr) + | Case (_,p,c,lf) -> + (* TODO: could avoid computing the type of branches *) + let i = + try find_rectype env (type_of env c) with Induc -> anomaly "type_of: Bad recursive type" in - let (aritysign,_) = get_arity indf in - let (psign,_) = splay_prod env sigma (type_of env p) in - let al = - if List.length psign > List.length aritysign - then realargs@[c] else realargs in - whd_betadeltaiota env sigma (applist (p,al)) - | IsLambda (name,c1,c2) -> - mkProd (name, c1, type_of (push_rel_assum (name,c1) env) c2) - | IsLetIn (name,b,c1,c2) -> - subst1 b (type_of (push_rel_def (name,b,c1) env) c2) - | IsFix ((_,i),(_,tys,_)) -> tys.(i) - | IsCoFix (i,(_,tys,_)) -> tys.(i) - | IsApp(f,args)-> + let pj = { uj_val = p; uj_type = type_of env p } in + let (_,ty,_) = type_case_branches env i pj c in + ty + | Lambda (name,c1,c2) -> + mkProd (name, c1, type_of (push_rel (name,None,c1) env) c2) + | LetIn (name,b,c1,c2) -> + subst1 b (type_of (push_rel (name,Some b,c1) env) c2) + | Fix ((_,i),(_,tys,_)) -> tys.(i) + | CoFix (i,(_,tys,_)) -> tys.(i) + | App(f,args)-> strip_outer_cast (subst_type env sigma (type_of env f) (Array.to_list args)) - | IsCast (c,t) -> t - | IsSort _ | IsProd (_,_,_) | IsMutInd _ -> mkSort (sort_of env cstr) + | Cast (c,t) -> t + | Sort _ | Prod (_,_,_) | Ind _ -> mkSort (sort_of env cstr) and sort_of env t = match kind_of_term t with - | IsCast (c,s) when isSort s -> destSort s - | IsSort (Prop c) -> type_0 - | IsSort (Type u) -> Type (fst (Univ.super u)) - | IsProd (name,t,c2) -> - (match (sort_of (push_rel_assum (name,t) env) c2) with + | Cast (c,s) when isSort s -> destSort s + | Sort (Prop c) -> type_0 + | Sort (Type u) -> Type (fst (Univ.super u)) + | Prod (name,t,c2) -> + (match (sort_of (push_rel (name,None,t) env) c2) with | Prop _ as s -> s | Type u2 as s -> s (*Type Univ.dummy_univ*)) - | IsApp(f,args) -> sort_of_atomic_type env sigma (type_of env f) args - | IsLambda _ | IsFix _ | IsMutConstruct _ -> + | App(f,args) -> sort_of_atomic_type env sigma (type_of env f) args + | Lambda _ | Fix _ | Construct _ -> anomaly "sort_of: Not a type (1)" | _ -> outsort env sigma (type_of env t) and sort_family_of env t = match kind_of_term (whd_betadeltaiota env sigma t) with - | IsCast (c,s) when isSort s -> family_of_sort (destSort s) - | IsSort (Prop c) -> InType - | IsSort (Type u) -> InType - | IsProd (name,t,c2) -> sort_family_of (push_rel_assum (name,t) env) c2 - | IsApp(f,args) -> + | Cast (c,s) when isSort s -> family_of_sort (destSort s) + | Sort (Prop c) -> InType + | Sort (Type u) -> InType + | Prod (name,t,c2) -> sort_family_of (push_rel (name,None,t) env) c2 + | App(f,args) -> family_of_sort (sort_of_atomic_type env sigma (type_of env f) args) - | IsLambda _ | IsFix _ | IsMutConstruct _ -> + | Lambda _ | Fix _ | Construct _ -> anomaly "sort_of: Not a type (1)" | _ -> family_of_sort (outsort env sigma (type_of env t)) diff --git a/pretyping/syntax_def.ml b/pretyping/syntax_def.ml index 1b875affa..381a40ee6 100644 --- a/pretyping/syntax_def.ml +++ b/pretyping/syntax_def.ml @@ -14,6 +14,7 @@ open Names open Rawterm open Libobject open Lib +open Nameops (* Syntactic definitions. *) @@ -57,7 +58,7 @@ let (in_syntax_constant, out_syntax_constant) = declare_object ("SYNTAXCONSTANT", od) let declare_syntactic_definition id c = - let _ = add_leaf id CCI (in_syntax_constant c) in () + let _ = add_leaf id (in_syntax_constant c) in () let search_syntactic_definition sp = Spmap.find sp !syntax_table diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 7d1564a8c..854a61b26 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -11,10 +11,12 @@ open Pp open Util open Names +open Nameops open Term +open Termops open Inductive open Environ -open Reduction +open Reductionops open Closure open Instantiate open Cbv @@ -22,16 +24,46 @@ open Cbv exception Elimconst exception Redelimination -let check_transparency env ref = - match ref with - EvalConst sp -> Opaque.is_evaluable env (EvalConstRef sp) - | EvalVar id -> Opaque.is_evaluable env (EvalVarRef id) - | _ -> false - -let isEvalRef env x = - Instantiate.isEvalRef x & - let ref = Instantiate.destEvalRef x in - check_transparency env ref +type evaluable_reference = + | EvalConst of constant + | EvalVar of identifier + | EvalRel of int + | EvalEvar of existential + +let mkEvalRef = function + | EvalConst cst -> mkConst cst + | EvalVar id -> mkVar id + | EvalRel n -> mkRel n + | EvalEvar ev -> mkEvar ev + +let isEvalRef env c = match kind_of_term c with + | Const sp -> Opaque.is_evaluable env (EvalConstRef sp) + | Var id -> Opaque.is_evaluable env (EvalVarRef id) + | Rel _ | Evar _ -> true + | _ -> false + +let destEvalRef c = match kind_of_term c with + | Const cst -> EvalConst cst + | Var id -> EvalVar id + | Rel n -> EvalRel n + | Evar ev -> EvalEvar ev + | _ -> anomaly "Not an evaluable reference" + +let reference_opt_value sigma env = function + | EvalConst cst -> constant_opt_value env cst + | EvalVar id -> + let (_,v,_) = lookup_named id env in + v + | EvalRel n -> + let (_,v,_) = lookup_rel n env in + option_app (lift n) v + | EvalEvar ev -> existential_opt_value sigma ev + +exception NotEvaluable +let reference_value sigma env c = + match reference_opt_value sigma env c with + | None -> raise NotEvaluable + | Some d -> d (************************************************************************) (* Reduction of constant hiding fixpoints (e.g. for Simpl). The trick *) @@ -95,7 +127,7 @@ let check_fix_reversibility labs args ((lv,i),(_,tys,bds)) = let li = List.map (function d -> match kind_of_term d with - | IsRel k -> + | Rel k -> if array_for_all (noccurn k) tys && array_for_all (noccurn (k+nbfix)) bds @@ -129,7 +161,7 @@ let invert_name labs l na0 env sigma ref = function | EvalRel _ | EvalEvar _ -> None | EvalVar id' -> Some (EvalVar id) | EvalConst sp -> - Some (EvalConst (make_path (dirpath sp) id CCI)) in + Some (EvalConst (make_path (dirpath sp) id)) in match refi with | None -> None | Some ref -> @@ -151,12 +183,12 @@ let compute_consteval_direct sigma env ref = let rec srec env n labs c = let c',l = whd_betadeltaeta_stack env sigma c in match kind_of_term c' with - | IsLambda (id,t,g) when l=[] -> - srec (push_rel_assum (id,t) env) (n+1) (t::labs) g - | IsFix fix -> + | Lambda (id,t,g) when l=[] -> + srec (push_rel (id,None,t) env) (n+1) (t::labs) g + | Fix fix -> (try check_fix_reversibility labs l fix with Elimconst -> NotAnElimination) - | IsMutCase (_,_,d,_) when isRel d -> EliminationCases n + | Case (_,_,d,_) when isRel d -> EliminationCases n | _ -> NotAnElimination in match reference_opt_value sigma env ref with @@ -168,9 +200,9 @@ let compute_consteval_mutual_fix sigma env ref = let c',l = whd_betaetalet_stack c in let nargs = List.length l in match kind_of_term c' with - | IsLambda (na,t,g) when l=[] -> - srec (push_rel_assum (na,t) env) (minarg+1) (t::labs) ref g - | IsFix ((lv,i),(names,_,_) as fix) -> + | Lambda (na,t,g) when l=[] -> + srec (push_rel (na,None,t) env) (minarg+1) (t::labs) ref g + | Fix ((lv,i),(names,_,_) as fix) -> (* Last known constant wrapping Fix is ref = [labs](Fix l) *) (match compute_consteval_direct sigma env ref with | NotAnElimination -> (*Above const was eliminable but this not!*) @@ -285,7 +317,7 @@ let reduce_fix_use_function f whfun fix stack = whfun (recarg, empty_stack) in let stack' = stack_assign stack recargnum (app_stack recarg') in (match kind_of_term recarg'hd with - | IsMutConstruct _ -> + | Construct _ -> Reduced (contract_fix_use_function f fix,stack') | _ -> NotReducible) @@ -300,27 +332,27 @@ let contract_cofix_use_function f (bodynum,(_,names,bodies as typedbodies)) = let reduce_mind_case_use_function sp env mia = match kind_of_term mia.mconstr with - | IsMutConstruct(ind_sp,i as cstr_sp) -> - let real_cargs = snd (list_chop (fst mia.mci) mia.mcargs) in + | Construct(ind_sp,i as cstr_sp) -> + let real_cargs = snd (list_chop mia.mci.ci_npar mia.mcargs) in applist (mia.mlf.(i-1), real_cargs) - | IsCoFix (_,(names,_,_) as cofix) -> + | CoFix (_,(names,_,_) as cofix) -> let build_fix_name i = match names.(i) with | Name id -> - let sp = make_path (dirpath sp) id (kind_of_path sp) in + let sp = make_path (dirpath sp) id in (match constant_opt_value env sp with | None -> None | Some _ -> Some (mkConst sp)) | Anonymous -> None in let cofix_def = contract_cofix_use_function build_fix_name cofix in - mkMutCase (mia.mci, mia.mP, applist(cofix_def,mia.mcargs), mia.mlf) + mkCase (mia.mci, mia.mP, applist(cofix_def,mia.mcargs), mia.mlf) | _ -> assert false let special_red_case env whfun (ci, p, c, lf) = let rec redrec s = let (constr, cargs) = whfun s in match kind_of_term constr with - | IsConst cst -> + | Const cst -> (if not (Opaque.is_evaluable env (EvalConstRef cst)) then raise Redelimination; let gvalue = constant_value env cst in @@ -377,21 +409,21 @@ let rec red_elim_const env sigma ref largs = and construct_const env sigma = let rec hnfstack (x, stack as s) = match kind_of_term x with - | IsCast (c,_) -> hnfstack (c, stack) - | IsApp (f,cl) -> hnfstack (f, append_stack cl stack) - | IsLambda (id,t,c) -> + | Cast (c,_) -> hnfstack (c, stack) + | App (f,cl) -> hnfstack (f, append_stack cl stack) + | Lambda (id,t,c) -> (match decomp_stack stack with | None -> assert false | Some (c',rest) -> stacklam hnfstack [c'] c rest) - | IsLetIn (n,b,t,c) -> stacklam hnfstack [b] c stack - | IsMutCase (ci,p,c,lf) -> + | LetIn (n,b,t,c) -> stacklam hnfstack [b] c stack + | Case (ci,p,c,lf) -> hnfstack (special_red_case env (construct_const env sigma) (ci,p,c,lf), stack) - | IsMutConstruct _ -> s - | IsCoFix _ -> s - | IsFix fix -> + | Construct _ -> s + | CoFix _ -> s + | Fix fix -> (match reduce_fix hnfstack fix stack with | Reduced s' -> hnfstack s' | NotReducible -> raise Redelimination) @@ -403,7 +435,7 @@ and construct_const env sigma = (match reference_opt_value sigma env ref with | Some cval -> (match kind_of_term cval with - | IsCoFix _ -> s + | CoFix _ -> s | _ -> hnfstack (cval, stack)) | None -> raise Redelimination)) @@ -420,9 +452,9 @@ let internal_red_product env sigma c = let simpfun = clos_norm_flags (UNIFORM,betaiotazeta_red) env sigma in let rec redrec env x = match kind_of_term x with - | IsApp (f,l) -> + | App (f,l) -> (match kind_of_term f with - | IsFix fix -> + | Fix fix -> let stack = append_stack l empty_stack in (match fix_recarg fix stack with | None -> raise Redelimination @@ -431,10 +463,10 @@ let internal_red_product env sigma c = let stack' = stack_assign stack recargnum recarg' in simpfun (app_stack (f,stack'))) | _ -> simpfun (appvect (redrec env f, l))) - | IsCast (c,_) -> redrec env c - | IsProd (x,a,b) -> mkProd (x, a, redrec (push_rel_assum (x,a) env) b) - | IsLetIn (x,a,b,t) -> redrec env (subst1 a t) - | IsMutCase (ci,p,d,lf) -> simpfun (mkMutCase (ci,p,redrec env d,lf)) + | Cast (c,_) -> redrec env c + | Prod (x,a,b) -> mkProd (x, a, redrec (push_rel (x,None,a) env) b) + | LetIn (x,a,b,t) -> redrec env (subst1 a t) + | Case (ci,p,d,lf) -> simpfun (mkCase (ci,p,redrec env d,lf)) | _ when isEvalRef env x -> (* TO DO: re-fold fixpoints after expansion *) (* to get true one-step reductions *) @@ -454,22 +486,22 @@ let red_product env sigma c = let hnf_constr env sigma c = let rec redrec (x, largs as s) = match kind_of_term x with - | IsLambda (n,t,c) -> + | Lambda (n,t,c) -> (match decomp_stack largs with | None -> app_stack s | Some (a,rest) -> stacklam redrec [a] c rest) - | IsLetIn (n,b,t,c) -> stacklam redrec [b] c largs - | IsApp (f,cl) -> redrec (f, append_stack cl largs) - | IsCast (c,_) -> redrec (c, largs) - | IsMutCase (ci,p,c,lf) -> + | LetIn (n,b,t,c) -> stacklam redrec [b] c largs + | App (f,cl) -> redrec (f, append_stack cl largs) + | Cast (c,_) -> redrec (c, largs) + | Case (ci,p,c,lf) -> (try redrec (special_red_case env (whd_betadeltaiota_state env sigma) (ci, p, c, lf), largs) with Redelimination -> app_stack s) - | IsFix fix -> + | Fix fix -> (match reduce_fix (whd_betadeltaiota_state env sigma) fix largs with | Reduced s' -> redrec s' | NotReducible -> app_stack s) @@ -482,7 +514,7 @@ let hnf_constr env sigma c = match reference_opt_value sigma env ref with | Some c -> (match kind_of_term c with - | IsCoFix _ -> app_stack (x,largs) + | CoFix _ -> app_stack (x,largs) | _ -> redrec (c, largs)) | None -> app_stack s) | _ -> app_stack s @@ -495,20 +527,20 @@ let hnf_constr env sigma c = let whd_nf env sigma c = let rec nf_app (c, stack as s) = match kind_of_term c with - | IsLambda (name,c1,c2) -> + | Lambda (name,c1,c2) -> (match decomp_stack stack with | None -> (c,empty_stack) | Some (a1,rest) -> stacklam nf_app [a1] c2 rest) - | IsLetIn (n,b,t,c) -> stacklam nf_app [b] c stack - | IsApp (f,cl) -> nf_app (f, append_stack cl stack) - | IsCast (c,_) -> nf_app (c, stack) - | IsMutCase (ci,p,d,lf) -> + | LetIn (n,b,t,c) -> stacklam nf_app [b] c stack + | App (f,cl) -> nf_app (f, append_stack cl stack) + | Cast (c,_) -> nf_app (c, stack) + | Case (ci,p,d,lf) -> (try nf_app (special_red_case env nf_app (ci,p,d,lf), stack) with Redelimination -> s) - | IsFix fix -> + | Fix fix -> (match reduce_fix nf_app fix stack with | Reduced s' -> nf_app s' | NotReducible -> s) @@ -528,7 +560,7 @@ let nf env sigma c = strong whd_nf env sigma c * ol is the occurence list to find. *) let rec substlin env name n ol c = match kind_of_term c with - | IsConst const when EvalConstRef const = name -> + | Const const when EvalConstRef const = name -> if List.hd ol = n then try (n+1, List.tl ol, constant_value env const) @@ -539,18 +571,18 @@ let rec substlin env name n ol c = else ((n+1), ol, c) - | IsVar id when EvalVarRef id = name -> + | Var id when EvalVarRef id = name -> if List.hd ol = n then - match lookup_named_value id env with - | Some c -> (n+1, List.tl ol, c) - | None -> + match lookup_named id env with + | (_,Some c,_) -> (n+1, List.tl ol, c) + | _ -> errorlabstrm "substlin" [< pr_id id; 'sTR " is not a defined constant" >] else ((n+1), ol, c) (* INEFFICIENT: OPTIMIZE *) - | IsApp (c1,cl) -> + | App (c1,cl) -> Array.fold_left (fun (n1,ol1,c1') c2 -> (match ol1 with @@ -560,7 +592,7 @@ let rec substlin env name n ol c = (n2,ol2,applist(c1',[c2'])))) (substlin env name n ol c1) cl - | IsLambda (na,c1,c2) -> + | Lambda (na,c1,c2) -> let (n1,ol1,c1') = substlin env name n ol c1 in (match ol1 with | [] -> (n1,[],mkLambda (na,c1',c2)) @@ -568,7 +600,7 @@ let rec substlin env name n ol c = let (n2,ol2,c2') = substlin env name n1 ol1 c2 in (n2,ol2,mkLambda (na,c1',c2'))) - | IsLetIn (na,c1,t,c2) -> + | LetIn (na,c1,t,c2) -> let (n1,ol1,c1') = substlin env name n ol c1 in (match ol1 with | [] -> (n1,[],mkLetIn (na,c1',t,c2)) @@ -576,7 +608,7 @@ let rec substlin env name n ol c = let (n2,ol2,c2') = substlin env name n1 ol1 c2 in (n2,ol2,mkLetIn (na,c1',t,c2'))) - | IsProd (na,c1,c2) -> + | Prod (na,c1,c2) -> let (n1,ol1,c1') = substlin env name n ol c1 in (match ol1 with | [] -> (n1,[],mkProd (na,c1',c2)) @@ -584,7 +616,7 @@ let rec substlin env name n ol c = let (n2,ol2,c2') = substlin env name n1 ol1 c2 in (n2,ol2,mkProd (na,c1',c2'))) - | IsMutCase (ci,p,d,llf) -> + | Case (ci,p,d,llf) -> let rec substlist nn oll = function | [] -> (nn,oll,[]) | f::lfe -> @@ -597,16 +629,16 @@ let rec substlin env name n ol c = in let (n1,ol1,p') = substlin env name n ol p in (* ATTENTION ERREUR *) (match ol1 with (* si P pas affiche *) - | [] -> (n1,[],mkMutCase (ci, p', d, llf)) + | [] -> (n1,[],mkCase (ci, p', d, llf)) | _ -> let (n2,ol2,d') = substlin env name n1 ol1 d in (match ol2 with - | [] -> (n2,[],mkMutCase (ci, p', d', llf)) + | [] -> (n2,[],mkCase (ci, p', d', llf)) | _ -> let (n3,ol3,lf') = substlist n2 ol2 (Array.to_list llf) - in (n3,ol3,mkMutCaseL (ci, p', d', lf')))) + in (n3,ol3,mkCase (ci, p', d', Array.of_list lf')))) - | IsCast (c1,c2) -> + | Cast (c1,c2) -> let (n1,ol1,c1') = substlin env name n ol c1 in (match ol1 with | [] -> (n1,[],mkCast (c1',c2)) @@ -614,14 +646,14 @@ let rec substlin env name n ol c = let (n2,ol2,c2') = substlin env name n1 ol1 c2 in (n2,ol2,mkCast (c1',c2'))) - | IsFix _ -> + | Fix _ -> (warning "do not consider occurrences inside fixpoints"; (n,ol,c)) - | IsCoFix _ -> + | CoFix _ -> (warning "do not consider occurrences inside cofixpoints"; (n,ol,c)) - | (IsRel _|IsMeta _|IsVar _|IsSort _ - |IsEvar _|IsConst _|IsMutInd _|IsMutConstruct _) -> (n,ol,c) + | (Rel _|Meta _|Var _|Sort _ + |Evar _|Const _|Ind _|Construct _) -> (n,ol,c) let string_of_evaluable_ref = function | EvalVarRef id -> string_of_id id @@ -664,7 +696,7 @@ let fold_commands cl env sigma c = (* call by value reduction functions *) let cbv_norm_flags flags env sigma t = - cbv_norm (create_cbv_infos flags env sigma) t + cbv_norm (create_cbv_infos flags env) (nf_evar sigma t) let cbv_beta = cbv_norm_flags beta empty_env Evd.empty let cbv_betaiota = cbv_norm_flags betaiota empty_env Evd.empty @@ -719,22 +751,22 @@ exception NotStepReducible let one_step_reduce env sigma c = let rec redrec (x, largs as s) = match kind_of_term x with - | IsLambda (n,t,c) -> + | Lambda (n,t,c) -> (match decomp_stack largs with | None -> raise NotStepReducible | Some (a,rest) -> (subst1 a c, rest)) - | IsApp (f,cl) -> redrec (f, append_stack cl largs) - | IsLetIn (_,f,_,cl) -> (subst1 f cl,largs) - | IsMutCase (ci,p,c,lf) -> + | App (f,cl) -> redrec (f, append_stack cl largs) + | LetIn (_,f,_,cl) -> (subst1 f cl,largs) + | Case (ci,p,c,lf) -> (try (special_red_case env (whd_betadeltaiota_state env sigma) (ci,p,c,lf), largs) with Redelimination -> raise NotStepReducible) - | IsFix fix -> + | Fix fix -> (match reduce_fix (whd_betadeltaiota_state env sigma) fix largs with | Reduced s' -> s' | NotReducible -> raise NotStepReducible) - | IsCast (c,_) -> redrec (c,largs) + | Cast (c,_) -> redrec (c,largs) | _ when isEvalRef env x -> let ref = try destEvalRef x @@ -757,10 +789,10 @@ let reduce_to_ind_gen allow_product env sigma t = let rec elimrec env t l = let c, _ = whd_stack t in match kind_of_term c with - | IsMutInd (mind,args) -> ((mind,args),it_mkProd_or_LetIn t l) - | IsProd (n,ty,t') -> + | Ind (mind,args) -> ((mind,args),it_mkProd_or_LetIn t l) + | Prod (n,ty,t') -> if allow_product then - elimrec (push_rel_assum (n,t) env) t' ((n,None,ty)::l) + elimrec (push_rel (n,None,t) env) t' ((n,None,ty)::l) else errorlabstrm "tactics__reduce_to_mind" [< 'sTR"Not an inductive definition" >] diff --git a/pretyping/tacred.mli b/pretyping/tacred.mli index fc9e55e30..fbeadc986 100644 --- a/pretyping/tacred.mli +++ b/pretyping/tacred.mli @@ -13,7 +13,7 @@ open Names open Term open Environ open Evd -open Reduction +open Reductionops open Closure (*i*) diff --git a/pretyping/termops.ml b/pretyping/termops.ml new file mode 100644 index 000000000..f8dd8ce15 --- /dev/null +++ b/pretyping/termops.ml @@ -0,0 +1,709 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +(* $Id$ *) + +open Pp +open Util +open Names +open Nameops +open Term +open Environ +open Nametab +open Sign + +let print_sort = function + | Prop Pos -> [< 'sTR "Set" >] + | Prop Null -> [< 'sTR "Prop" >] +(* | Type _ -> [< 'sTR "Type" >] *) + | Type u -> [< 'sTR "Type("; Univ.pr_uni u; 'sTR ")" >] + +(* 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)) + +(* 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)) + +(* [Rel (n+m);...;Rel(n+1)] *) +let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i)) + +let rel_list n m = + let rec reln l p = + if p>m then l else reln (mkRel(n+p)::l) (p+1) + in + reln [] 1 + +(* Same as [rel_list] but takes a context as argument and skips let-ins *) +let extended_rel_list n hyps = + let rec reln l p = function + | (_,None,_) :: hyps -> reln (mkRel (n+p) :: l) (p+1) hyps + | (_,Some _,_) :: hyps -> reln l (p+1) hyps + | [] -> l + in + reln [] 1 hyps + +let extended_rel_vect n hyps = Array.of_list (extended_rel_list n hyps) + + + +let push_rel_assum (x,t) env = push_rel (x,None,t) env + +let push_rels_assum assums = + push_rel_context (List.map (fun (x,t) -> (x,None,t)) assums) + +let push_named_rec_types (lna,typarray,_) env = + let ctxt = + array_map2_i + (fun i na t -> + match na with + | Name id -> (id, None, type_app (lift i) t) + | Anonymous -> anomaly "Fix declarations must be named") + lna typarray in + Array.fold_left + (fun e assum -> push_named_decl assum e) env ctxt + +let rec lookup_rel_id id sign = + let rec lookrec = function + | (n, (Anonymous,_,_)::l) -> lookrec (n+1,l) + | (n, (Name id',_,t)::l) -> if id' = id then (n,t) else lookrec (n+1,l) + | (_, []) -> raise Not_found + in + lookrec (1,sign) + +(* 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) + +(* 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) + | Some b -> subst1 b c + +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) + +let it_named_context_quantifier f = List.fold_left (fun c d -> f d c) + +let it_mkNamedProd_or_LetIn = it_named_context_quantifier mkNamedProd_or_LetIn +let it_mkNamedLambda_or_LetIn = it_named_context_quantifier mkNamedLambda_or_LetIn + +(* *) + +(* [map_constr_with_named_binders g f l c] maps [f l] on the immediate + subterms of [c]; it carries an extra data [l] (typically a name + list) which is processed by [g na] (which typically cons [na] to + [l]) at each binder traversal (with name [na]); it is not recursive + and the order with which subterms are processed is not specified *) + +let map_constr_with_named_binders g f l c = match kind_of_term c with + | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ + | Construct _) -> c + | Cast (c,t) -> mkCast (f l c, f l t) + | Prod (na,t,c) -> mkProd (na, f l t, f (g na l) c) + | Lambda (na,t,c) -> mkLambda (na, f l t, f (g na l) c) + | LetIn (na,b,t,c) -> mkLetIn (na, f l b, f l t, f (g na l) c) + | App (c,al) -> mkApp (f l c, Array.map (f l) al) + | Evar (e,al) -> mkEvar (e, Array.map (f l) al) + | Case (ci,p,c,bl) -> mkCase (ci, f l p, f l c, Array.map (f l) bl) + | Fix (ln,(lna,tl,bl)) -> + let l' = Array.fold_left (fun l na -> g na l) l lna in + mkFix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl)) + | CoFix(ln,(lna,tl,bl)) -> + let l' = Array.fold_left (fun l na -> g na l) l lna in + mkCoFix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl)) + +(* [map_constr_with_binders_left_to_right g f n c] maps [f n] on the + immediate subterms of [c]; it carries an extra data [n] (typically + a lift index) which is processed by [g] (which typically add 1 to + [n]) at each binder traversal; the subterms are processed from left + to right according to the usual representation of the constructions + (this may matter if [f] does a side-effect); it is not recursive; + in fact, the usual representation of the constructions is at the + time being almost those of the ML representation (except for + (co-)fixpoint) *) + +let array_map_left f a = (* Ocaml does not guarantee Array.map is LR *) + let l = Array.length a in (* (even if so), then we rewrite it *) + if l = 0 then [||] else begin + let r = Array.create l (f a.(0)) in + for i = 1 to l - 1 do + r.(i) <- f a.(i) + done; + r + end + +let array_map_left_pair f a g b = + let l = Array.length a in + if l = 0 then [||],[||] else begin + let r = Array.create l (f a.(0)) in + let s = Array.create l (g b.(0)) in + for i = 1 to l - 1 do + r.(i) <- f a.(i); + s.(i) <- g b.(i) + done; + r, s + end + +let map_constr_with_binders_left_to_right g f l c = match kind_of_term c with + | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ + | Construct _) -> c + | Cast (c,t) -> let c' = f l c in mkCast (c', f l t) + | Prod (na,t,c) -> let t' = f l t in mkProd (na, t', f (g l) c) + | Lambda (na,t,c) -> let t' = f l t in mkLambda (na, t', f (g l) c) + | LetIn (na,b,t,c) -> + let b' = f l b in let t' = f l t in mkLetIn (na, b', t', f (g l) c) + | App (c,al) -> + let c' = f l c in mkApp (c', array_map_left (f l) al) + | Evar (e,al) -> mkEvar (e, array_map_left (f l) al) + | Case (ci,p,c,bl) -> + let p' = f l p in let c' = f l c in + mkCase (ci, p', c', array_map_left (f l) bl) + | Fix (ln,(lna,tl,bl)) -> + let l' = iterate g (Array.length tl) l in + let (tl',bl') = array_map_left_pair (f l) tl (f l') bl in + mkFix (ln,(lna,tl',bl')) + | CoFix(ln,(lna,tl,bl)) -> + let l' = iterate g (Array.length tl) l in + let (tl',bl') = array_map_left_pair (f l) tl (f l') bl in + mkCoFix (ln,(lna,tl',bl')) + +(* strong *) +let map_constr_with_full_binders g f l c = match kind_of_term c with + | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ + | Construct _) -> c + | Cast (c,t) -> mkCast (f l c, f l t) + | Prod (na,t,c) -> mkProd (na, f l t, f (g (na,None,t) l) c) + | Lambda (na,t,c) -> mkLambda (na, f l t, f (g (na,None,t) l) c) + | LetIn (na,b,t,c) -> mkLetIn (na, f l b, f l t, f (g (na,Some b,t) l) c) + | App (c,al) -> mkApp (f l c, Array.map (f l) al) + | Evar (e,al) -> mkEvar (e, Array.map (f l) al) + | Case (ci,p,c,bl) -> mkCase (ci, f l p, f l c, Array.map (f l) bl) + | Fix (ln,(lna,tl,bl)) -> + let l' = + array_fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in + mkFix (ln,(lna,Array.map (f l) tl, Array.map (f l') bl)) + | CoFix(ln,(lna,tl,bl)) -> + let l' = + array_fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in + mkCoFix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl)) + + +(* [iter_constr f c] iters [f] on the immediate subterms of [c]; it is + not recursive and the order with which subterms are processed is + not specified *) + +let iter_constr f c = match kind_of_term c with + | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> () + | Cast (c,t) -> f c; f t + | Prod (_,t,c) -> f t; f c + | Lambda (_,t,c) -> f t; f c + | LetIn (_,b,t,c) -> f b; f t; f c + | App (c,l) -> f c; Array.iter f l + | Evar (_,l) -> Array.iter f l + | Case (_,p,c,bl) -> f p; f c; Array.iter f bl + | Fix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl + | CoFix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl + + +(***************************) +(* occurs check functions *) +(***************************) + +exception Occur + +let occur_meta c = + let rec occrec c = match kind_of_term c with + | Meta _ -> raise Occur + | _ -> iter_constr occrec c + in try occrec c; false with Occur -> true + +let occur_existential c = + let rec occrec c = match kind_of_term c with + | Evar _ -> raise Occur + | _ -> iter_constr occrec c + in try occrec c; false with Occur -> true + +let occur_const s c = + let rec occur_rec c = match kind_of_term c with + | Const sp when sp=s -> raise Occur + | _ -> iter_constr occur_rec c + in + try occur_rec c; false with Occur -> true + +let occur_evar n c = + let rec occur_rec c = match kind_of_term c with + | Evar (sp,_) when sp=n -> raise Occur + | _ -> iter_constr occur_rec c + in + try occur_rec c; false with Occur -> true + +let occur_in_global env id constr = + let vars = vars_of_global env constr in + if List.mem id vars then raise Occur + +let occur_var env s c = + let rec occur_rec c = + occur_in_global env s c; + iter_constr occur_rec c + in + try occur_rec c; false with Occur -> true + +let occur_var_in_decl env hyp (_,c,typ) = + match c with + | None -> occur_var env hyp (body_of_type typ) + | Some body -> + occur_var env hyp (body_of_type typ) || + occur_var env hyp body + +(* (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 m t = + let rec deprec m t = + if (eq_constr m t) then + raise Occur + else + iter_constr_with_binders (lift 1) deprec m t + in + try deprec m t; false with Occur -> true + +(* returns the list of free debruijn indices in a term *) + +let free_rels m = + let rec frec depth acc c = match kind_of_term c with + | Rel n -> if n >= depth then Intset.add (n-depth+1) acc else acc + | _ -> fold_constr_with_binders succ frec depth acc c + in + frec 1 Intset.empty m + + +(***************************) +(* substitution functions *) +(***************************) + +(* First utilities for avoiding telescope computation for subst_term *) + +let prefix_application (k,c) (t : constr) = + let c' = collapse_appl c and t' = collapse_appl t in + match kind_of_term c', kind_of_term t' with + | App (f1,cl1), App (f2,cl2) -> + let l1 = Array.length cl1 + and l2 = Array.length cl2 in + if l1 <= l2 + && eq_constr c' (mkApp (f2, Array.sub cl2 0 l1)) then + Some (mkApp (mkRel k, Array.sub cl2 l1 (l2 - l1))) + else + None + | _ -> None + +let my_prefix_application (k,c) (by_c : constr) (t : constr) = + let c' = collapse_appl c and t' = collapse_appl t in + match kind_of_term c', kind_of_term t' with + | App (f1,cl1), App (f2,cl2) -> + let l1 = Array.length cl1 + and l2 = Array.length cl2 in + if l1 <= l2 + && eq_constr c' (mkApp (f2, Array.sub cl2 0 l1)) then + Some (mkApp ((lift k by_c), Array.sub cl2 l1 (l2 - l1))) + else + None + | _ -> None + +(* Recognizing occurrences of a given (closed) subterm in a term for Pattern : + [subst_term c t] substitutes [(Rel 1)] for all occurrences of (closed) + term [c] in a term [t] *) +(*i Bizarre : si on cherche un sous terme clos, pourquoi le lifter ? i*) + +let subst_term_gen eq_fun c t = + let rec substrec (k,c as kc) t = + match prefix_application kc t with + | Some x -> x + | None -> + (if eq_fun t c then mkRel k else match kind_of_term t with + | Const _ | Ind _ | Construct _ -> t + | _ -> + map_constr_with_binders + (fun (k,c) -> (k+1,lift 1 c)) + substrec kc t) + in + substrec (1,c) t + +(* Recognizing occurrences of a given (closed) subterm in a term : + [replace_term c1 c2 t] substitutes [c2] for all occurrences of (closed) + term [c1] in a term [t] *) +(*i Meme remarque : a priori [c] n'est pas forcement clos i*) + +let replace_term_gen eq_fun c by_c in_t = + let rec substrec (k,c as kc) t = + match my_prefix_application kc by_c t with + | Some x -> x + | None -> + (if eq_fun t c then (lift k by_c) else match kind_of_term t with + | Const _ | Ind _ | Construct _ -> t + | _ -> + map_constr_with_binders + (fun (k,c) -> (k+1,lift 1 c)) + substrec kc t) + in + substrec (0,c) in_t + +let subst_term = subst_term_gen eq_constr + +let replace_term = replace_term_gen eq_constr + +let rec subst_meta bl c = + match kind_of_term c with + | Meta i -> (try List.assoc i bl with Not_found -> c) + | _ -> map_constr (subst_meta bl) c + +(* strips head casts and flattens head applications *) +let rec strip_head_cast c = match kind_of_term c with + | App (f,cl) -> + let rec collapse_rec f cl2 = match kind_of_term f with + | App (g,cl1) -> collapse_rec g (Array.append cl1 cl2) + | Cast (c,_) -> collapse_rec c cl2 + | _ -> if cl2 = [||] then f else mkApp (f,cl2) + in + collapse_rec f cl + | Cast (c,t) -> strip_head_cast c + | _ -> c + +(* On reduit une serie d'eta-redex de tete ou rien du tout *) +(* [x1:c1;...;xn:cn]@(f;a1...an;x1;...;xn) --> @(f;a1...an) *) +(* Remplace 2 versions précédentes buggées *) + +let rec eta_reduce_head c = + match kind_of_term c with + | Lambda (_,c1,c') -> + (match kind_of_term (eta_reduce_head c') with + | App (f,cl) -> + let lastn = (Array.length cl) - 1 in + if lastn < 1 then anomaly "application without arguments" + else + (match kind_of_term cl.(lastn) with + | Rel 1 -> + let c' = + if lastn = 1 then f + else mkApp (f, Array.sub cl 0 lastn) + in + if not (dependent (mkRel 1) c') + then lift (-1) c' + else c + | _ -> c) + | _ -> c) + | _ -> c + +(* alpha-eta conversion : ignore print names and casts *) +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 compare_constr aux t1 t2 + in aux + +(* Substitute only a list of locations locs, the empty list is + interpreted as substitute all, if 0 is in the list then no + substitution is done. The list may contain only negative occurrences + that will not be substituted. *) + +let subst_term_occ_gen locs occ c t = + let maxocc = List.fold_right max locs 0 in + let pos = ref occ in + let check = ref true in + let except = List.exists (fun n -> n<0) locs in + if except & (List.exists (fun n -> n>=0) locs) + then error "mixing of positive and negative occurences" + else + let rec substrec (k,c as kc) t = + if (not except) & (!pos > maxocc) then t + else + if eq_constr t c then + let r = + if except then + if List.mem (- !pos) locs then t else (mkRel k) + else + if List.mem !pos locs then (mkRel k) else t + in incr pos; r + else + match kind_of_term t with + | Const _ | Construct _ | Ind _ -> t + | _ -> + map_constr_with_binders_left_to_right + (fun (k,c) -> (k+1,lift 1 c)) substrec kc t + in + let t' = substrec (1,c) t in + (!pos, t') + +let subst_term_occ locs c t = + if locs = [] then + subst_term c t + else if List.mem 0 locs then + t + else + let (nbocc,t') = subst_term_occ_gen locs 1 c t in + if List.exists (fun o -> o >= nbocc or o <= -nbocc) locs then + errorlabstrm "subst_term_occ" [< 'sTR "Too few occurences" >]; + t' + +let subst_term_occ_decl locs c (id,bodyopt,typ as d) = + match bodyopt with + | None -> (id,None,subst_term_occ locs c typ) + | Some body -> + if locs = [] then + (id,Some (subst_term c body),type_app (subst_term c) typ) + else if List.mem 0 locs then + d + else + let (nbocc,body') = subst_term_occ_gen locs 1 c body in + let (nbocc',t') = subst_term_occ_gen locs nbocc c typ in + if List.exists (fun o -> o >= nbocc' or o <= -nbocc') locs then + errorlabstrm "subst_term_occ_decl" [< 'sTR "Too few occurences" >]; + (id,Some body',t') + + + +(* First character of a constr *) + +let first_char id = + let id = string_of_id id in + assert (id <> ""); + String.make 1 id.[0] + +let lowercase_first_char id = String.lowercase (first_char id) + +let id_of_global env ref = basename (sp_of_global env ref) + +let sort_hdchar = function + | Prop(_) -> "P" + | Type(_) -> "T" + +let hdchar env c = + let rec hdrec k c = + match kind_of_term c with + | Prod (_,_,c) -> hdrec (k+1) c + | Lambda (_,_,c) -> hdrec (k+1) c + | LetIn (_,_,_,c) -> hdrec (k+1) c + | Cast (c,_) -> hdrec k c + | App (f,l) -> hdrec k f + | Const sp -> + let c = lowercase_first_char (basename sp) in + if c = "?" then "y" else c + | Ind ((sp,i) as x) -> + if i=0 then + lowercase_first_char (basename sp) + else + lowercase_first_char (id_of_global env (IndRef x)) + | Construct ((sp,i) as x) -> + lowercase_first_char (id_of_global env (ConstructRef x)) + | Var id -> lowercase_first_char id + | Sort s -> sort_hdchar s + | Rel n -> + (if n<=k then "p" (* the initial term is flexible product/function *) + else + try match Environ.lookup_rel (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") + | Fix ((_,i),(lna,_,_)) -> + let id = match lna.(i) with Name id -> id | _ -> assert false in + lowercase_first_char id + | CoFix (i,(lna,_,_)) -> + let id = match lna.(i) with Name id -> id | _ -> assert false in + lowercase_first_char id + | Meta _|Evar _|Case (_, _, _, _) -> "y" + in + hdrec 0 c + +let id_of_name_using_hdchar env a = function + | Anonymous -> id_of_string (hdchar env a) + | Name id -> id + +let named_hd env a = function + | Anonymous -> Name (id_of_string (hdchar env a)) + | x -> x + +let named_hd_type env a = named_hd env (body_of_type a) + +let prod_name env (n,a,b) = mkProd (named_hd_type env a n, a, b) +let lambda_name env (n,a,b) = mkLambda (named_hd_type env a n, a, b) + +let prod_create env (a,b) = mkProd (named_hd_type env a Anonymous, a, b) +let lambda_create env (a,b) = mkLambda (named_hd_type env a Anonymous, a, b) + +let name_assumption env (na,c,t) = + match c with + | None -> (named_hd_type env t na, None, t) + | Some body -> (named_hd env body na, c, t) + +let name_context env hyps = + snd + (List.fold_left + (fun (env,hyps) d -> + let d' = name_assumption env d in (push_rel d' env, d' :: hyps)) + (env,[]) (List.rev hyps)) + +let mkProd_or_LetIn_name env b d = mkProd_or_LetIn (name_assumption env d) b +let mkLambda_or_LetIn_name env b d = mkLambda_or_LetIn (name_assumption env d)b + +let it_mkProd_or_LetIn_name env b hyps = + it_mkProd_or_LetIn b (name_context env hyps) +let it_mkLambda_or_LetIn_name env b hyps = + it_mkLambda_or_LetIn b (name_context env hyps) + +(*************************) +(* Names environments *) +(*************************) +type names_context = name list +let add_name n nl = n::nl +let lookup_name_of_rel p names = + try List.nth names (p-1) + with Invalid_argument _ | Failure _ -> raise Not_found +let rec lookup_rel_of_name id names = + let rec lookrec n = function + | Anonymous :: l -> lookrec (n+1) l + | (Name id') :: l -> if id' = id then n else lookrec (n+1) l + | [] -> raise Not_found + in + lookrec 1 names +let empty_names_context = [] + +let ids_of_rel_context sign = + Sign.fold_rel_context + (fun (na,_,_) l -> match na with Name id -> id::l | Anonymous -> l) + sign [] +let ids_of_named_context sign = + Sign.fold_named_context (fun (id,_,_) idl -> id::idl) sign [] + +let ids_of_context env = + (ids_of_rel_context (rel_context env)) + @ (ids_of_named_context (named_context env)) + +let names_of_rel_context env = + List.map (fun (na,_,_) -> na) (rel_context env) + +(* Nouvelle version de renommage des variables (DEC 98) *) +(* This is the algorithm to display distinct bound variables + + - Rčgle 1 : un nom non anonyme, męme non affiché, contribue ŕ la liste + des noms ŕ éviter + - Rčgle 2 : c'est la dépendance qui décide si on affiche ou pas + + Exemple : + si bool_ind = (P:bool->Prop)(f:(P true))(f:(P false))(b:bool)(P b), alors + il est affiché (P:bool->Prop)(P true)->(P false)->(b:bool)(P b) + mais f et f0 contribue ŕ la liste des variables ŕ éviter (en supposant + que les noms f et f0 ne sont pas déjŕ pris) + Intéręt : noms homogčnes dans un but avant et aprčs Intro +*) + +type used_idents = identifier list + +let occur_rel p env id = + try lookup_name_of_rel p env = Name id + with Not_found -> false (* Unbound indice : may happen in debug *) + +let occur_id env id0 c = + let rec occur n c = match kind_of_term c with + | Var id when id=id0 -> raise Occur + | Const sp when basename sp = id0 -> raise Occur + | Ind ind_sp + when basename (path_of_inductive (Global.env()) ind_sp) = id0 -> + raise Occur + | Construct cstr_sp + when basename (path_of_constructor (Global.env()) cstr_sp) = id0 -> + raise Occur + | Rel p when p>n & occur_rel (p-n) env id0 -> raise Occur + | _ -> iter_constr_with_binders succ occur n c + in + try occur 1 c; false + with Occur -> true + +let next_name_not_occuring name l env_names t = + let rec next id = + if List.mem id l or occur_id env_names id t then next (lift_ident id) + else id + in + match name with + | Name id -> next id + | Anonymous -> id_of_string "_" + +(* Remark: Anonymous var may be dependent in Evar's contexts *) +let concrete_name l env_names n c = + 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 (mkRel 1) c then (Some fresh_id) else None in + (idopt, fresh_id::l) + +let concrete_let_name l env_names n c = + let fresh_id = next_name_not_occuring n l env_names c in + (Name fresh_id, fresh_id::l) + +let global_vars env ids = Idset.elements (global_vars_set env ids) + +let rec rename_bound_var env l c = + match kind_of_term c with + | Prod (Name s,c1,c2) -> + if dependent (mkRel 1) c2 then + let s' = next_ident_away s (global_vars env c2@l) in + let env' = push_rel (Name s',None,c1) env in + mkProd (Name s', c1, rename_bound_var env' (s'::l) c2) + else + let env' = push_rel (Name s,None,c1) env in + mkProd (Name s, c1, rename_bound_var env' l c2) + | Prod (Anonymous,c1,c2) -> + let env' = push_rel (Anonymous,None,c1) env in + mkProd (Anonymous, c1, rename_bound_var env' l c2) + | Cast (c,t) -> mkCast (rename_bound_var env l c, t) + | x -> c + +(* iterator on rel context *) +let process_rel_context f env = + let sign = named_context env in + let rels = rel_context env in + let env0 = reset_with_named_context sign env in + Sign.fold_rel_context f rels env0 + +let assums_of_rel_context sign = + Sign.fold_rel_context + (fun (na,c,t) l -> + match c with + Some _ -> l + | None -> (na,body_of_type t)::l) + sign [] + +let lift_rel_context n sign = + let rec liftrec k = function + | (na,c,t)::sign -> + (na,option_app (liftn n k) c,type_app (liftn n k) t) + ::(liftrec (k-1) sign) + | [] -> [] + in + liftrec (rel_context_length sign) sign + +let fold_named_context_both_sides = list_fold_right_and_left + +let rec mem_named_context id = function + | (id',_,_) :: _ when id=id' -> true + | _ :: sign -> mem_named_context id sign + | [] -> false + +let make_all_name_different env = + let avoid = ref (ids_of_named_context (named_context env)) in + process_rel_context + (fun (na,c,t) newenv -> + let id = next_name_away na !avoid in + avoid := id::!avoid; + push_rel (Name id,c,t) newenv) + env diff --git a/pretyping/termops.mli b/pretyping/termops.mli new file mode 100644 index 000000000..30a7fa8ca --- /dev/null +++ b/pretyping/termops.mli @@ -0,0 +1,143 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +(* $Id$ *) + +open Util +open Pp +open Names +open Term +open Sign +open Environ + +val print_sort : sorts -> std_ppcmds +val prod_it : init:types -> (name * types) list -> types +val lam_it : init:constr -> (name * types) list -> constr +val rel_vect : int -> int -> constr array +val rel_list : int -> int -> constr list +val extended_rel_list : int -> rel_context -> constr list +val extended_rel_vect : int -> rel_context -> constr array +val push_rel_assum : name * types -> env -> env +val push_rels_assum : (name * types) list -> env -> env +val push_named_rec_types : name array * types array * 'a -> env -> env +val lookup_rel_id : identifier -> rel_context -> int * types +val mkProd_or_LetIn : rel_declaration -> types -> types +val mkProd_wo_LetIn : rel_declaration -> types -> types +val it_mkProd_wo_LetIn : init:types -> rel_context -> types +val it_mkProd_or_LetIn : init:types -> rel_context -> types +val it_mkLambda_or_LetIn : init:constr -> rel_context -> constr +val it_named_context_quantifier : + (named_declaration -> 'a -> 'a) -> init:'a -> named_context -> 'a +val it_mkNamedProd_or_LetIn : init:types -> named_context -> types +val it_mkNamedLambda_or_LetIn : init:constr -> named_context -> constr + +val map_constr_with_named_binders : + (name -> 'a -> 'a) -> + ('a -> types -> types) -> 'a -> constr -> constr +val map_constr_with_binders_left_to_right : + ('a -> 'a) -> ('a -> types -> types) -> 'a -> constr -> constr +val map_constr_with_full_binders : + (name * types option * types -> 'a -> 'a) -> + ('a -> types -> types) -> 'a -> constr -> constr +val iter_constr : (types -> unit) -> constr -> unit + +(* occur checks *) +exception Occur +val occur_meta : types -> bool +val occur_existential : types -> bool +val occur_const : constant -> types -> bool +val occur_evar : existential_key -> types -> bool +val occur_in_global : env -> identifier -> constr -> unit +val occur_var : env -> identifier -> types -> bool +val occur_var_in_decl : + env -> + identifier -> 'a * types option * types -> bool +val dependent : constr -> constr -> bool +val free_rels : constr -> Intset.t + +(* substitution *) +val prefix_application : + int * constr -> constr -> constr option +val my_prefix_application : + int * constr -> constr -> constr -> constr option +val subst_term_gen : + (constr -> constr -> bool) -> + constr -> constr -> constr +val replace_term_gen : + (constr -> constr -> bool) -> + constr -> constr -> constr -> constr +val subst_term : constr -> constr -> constr +val replace_term : constr -> constr -> constr -> constr +val subst_meta : (int * constr) list -> constr -> constr +val strip_head_cast : constr -> constr +val eta_reduce_head : constr -> constr +val eta_eq_constr : constr -> constr -> bool +val subst_term_occ_gen : + int list -> int -> constr -> types -> int * types +val subst_term_occ : int list -> constr -> types -> types +val subst_term_occ_decl : + int list -> constr -> named_declaration -> named_declaration + +(* finding "intuitive" names to hypotheses *) +val first_char : identifier -> string +val lowercase_first_char : identifier -> string +val id_of_global : env -> Nametab.global_reference -> identifier +val sort_hdchar : sorts -> string +val hdchar : env -> types -> string +val id_of_name_using_hdchar : + env -> types -> name -> identifier +val named_hd : env -> types -> name -> name +val named_hd_type : env -> types -> name -> name +val prod_name : env -> name * types * types -> constr +val lambda_name : env -> name * types * constr -> constr +val prod_create : env -> types * types -> constr +val lambda_create : env -> types * constr -> constr +val name_assumption : env -> rel_declaration -> rel_declaration +val name_context : env -> rel_context -> rel_context + +val mkProd_or_LetIn_name : env -> types -> rel_declaration -> types +val mkLambda_or_LetIn_name : env -> constr -> rel_declaration -> constr +val it_mkProd_or_LetIn_name : env -> types -> rel_context -> types +val it_mkLambda_or_LetIn_name : env -> constr -> rel_context -> constr + +(* name contexts *) +type names_context = name list +val add_name : name -> names_context -> names_context +val lookup_name_of_rel : int -> names_context -> name +val lookup_rel_of_name : identifier -> names_context -> int +val empty_names_context : names_context +val ids_of_rel_context : rel_context -> identifier list +val ids_of_named_context : named_context -> identifier list +val ids_of_context : env -> identifier list +val names_of_rel_context : env -> names_context + +(* sets of free identifiers *) +type used_idents = identifier list +val occur_rel : int -> name list -> identifier -> bool +val occur_id : name list -> identifier -> constr -> bool + +val next_name_not_occuring : + name -> identifier list -> name list -> constr -> identifier +val concrete_name : + identifier list -> name list -> name -> + constr -> identifier option * identifier list +val concrete_let_name : + identifier list -> name list -> + name -> constr -> name * identifier list +val global_vars : env -> constr -> identifier list +val rename_bound_var : env -> identifier list -> types -> types + +(* other signature iterators *) +val process_rel_context : (rel_declaration -> env -> env) -> env -> env +val assums_of_rel_context : rel_context -> (name * constr) list +val lift_rel_context : int -> rel_context -> rel_context +val fold_named_context_both_sides : + ('a -> named_declaration -> named_context -> 'a) -> + named_context -> 'a -> 'a +val mem_named_context : identifier -> named_context -> bool +val make_all_name_different : env -> env diff --git a/pretyping/typing.ml b/pretyping/typing.ml index f9110c62a..7dd552e38 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -12,8 +12,10 @@ open Util open Names open Term open Environ -open Reduction +open Reductionops open Type_errors +open Pretype_errors +open Inductive open Typeops let vect_lift = Array.mapi lift @@ -26,111 +28,108 @@ type 'a mach_flags = { (* The typing machine without information, without universes but with existential variables. *) +let assumption_of_judgment env sigma j = + assumption_of_judgment env (j_nf_evar sigma j) + +let type_judgment env sigma j = + type_judgment env (j_nf_evar sigma j) + + let rec execute mf env sigma cstr = match kind_of_term cstr with - | IsMeta n -> + | Meta n -> error "execute: found a non-instanciated goal" - | IsEvar ev -> - let ty = type_of_existential env sigma ev in + | Evar ev -> + let ty = Instantiate.existential_type sigma ev in let jty = execute mf env sigma ty in let jty = assumption_of_judgment env sigma jty in { uj_val = cstr; uj_type = jty } - | IsRel n -> - relative env n - - | IsVar id -> - (try - make_judge cstr (snd (lookup_named id env)) - with Not_found -> - error ("execute: variable " ^ (string_of_id id) ^ " not defined")) + | Rel n -> + judge_of_relative env n + + | Var id -> + judge_of_variable env id - | IsConst c -> - make_judge cstr (type_of_constant env sigma c) + | Const c -> + make_judge cstr (constant_type env c) - | IsMutInd ind -> - make_judge cstr (type_of_inductive env sigma ind) + | Ind ind -> + make_judge cstr (type_of_inductive env ind) - | IsMutConstruct cstruct -> - make_judge cstr (type_of_constructor env sigma cstruct) + | Construct cstruct -> + make_judge cstr (type_of_constructor env cstruct) - | IsMutCase (ci,p,c,lf) -> + | Case (ci,p,c,lf) -> let cj = execute mf env sigma c in let pj = execute mf env sigma p in let lfj = execute_array mf env sigma lf in - let (j,_) = judge_of_case env sigma ci pj cj lfj in + let (j,_) = judge_of_case env ci pj cj lfj in j - | IsFix ((vn,i as vni),recdef) -> + | Fix ((vn,i as vni),recdef) -> if (not mf.fix) && array_exists (fun n -> n < 0) vn then error "General Fixpoints not allowed"; - let (_,tys,_ as recdef') = execute_fix mf env sigma recdef in + let (_,tys,_ as recdef') = execute_recdef mf env sigma recdef in let fix = (vni,recdef') in - check_fix env sigma fix; + check_fix env fix; make_judge (mkFix fix) tys.(i) - | IsCoFix (i,recdef) -> - let (_,tys,_ as recdef') = execute_fix mf env sigma recdef in + | CoFix (i,recdef) -> + let (_,tys,_ as recdef') = execute_recdef mf env sigma recdef in let cofix = (i,recdef') in - check_cofix env sigma cofix; + check_cofix env cofix; make_judge (mkCoFix cofix) tys.(i) - | IsSort (Prop c) -> + | Sort (Prop c) -> judge_of_prop_contents c - | IsSort (Type u) -> + | Sort (Type u) -> let (j,_) = judge_of_type u in j - | IsApp (f,args) -> + | App (f,args) -> let j = execute mf env sigma f in - let jl = execute_list mf env sigma (Array.to_list args) in - let (j,_) = apply_rel_list env sigma mf.nocheck jl j in + let jl = execute_array mf env sigma args in + let (j,_) = judge_of_apply env j jl in j - | IsLambda (name,c1,c2) -> + | Lambda (name,c1,c2) -> let j = execute mf env sigma c1 in - let var = assumption_of_judgment env sigma j in - let env1 = push_rel_assum (name,var) env in + let var = type_judgment env sigma j in + let env1 = push_rel (name,None,var.utj_val) env in let j' = execute mf env1 sigma c2 in - let (j,_) = abs_rel env1 sigma name var j' in - j + judge_of_abstraction env1 name var j' - | IsProd (name,c1,c2) -> + | Prod (name,c1,c2) -> let j = execute mf env sigma c1 in let varj = type_judgment env sigma j in - let env1 = push_rel_assum (name,varj.utj_val) env in + let env1 = push_rel (name,None,varj.utj_val) env in let j' = execute mf env1 sigma c2 in let varj' = type_judgment env sigma j' in - let (j,_) = gen_rel env1 sigma name varj varj' in + let (j,_) = judge_of_product env1 name varj varj' in j - | IsLetIn (name,c1,c2,c3) -> - let j1 = execute mf env sigma c1 in - let j2 = execute mf env sigma c2 in - let tj2 = assumption_of_judgment env sigma j2 in - let { uj_val = b; uj_type = t },_ = cast_rel env sigma j1 tj2 in - let j3 = execute mf (push_rel_def (name,b,t) env) sigma c3 in - { uj_val = mkLetIn (name, j1.uj_val, tj2, j3.uj_val) ; - uj_type = type_app (subst1 j1.uj_val) j3.uj_type } + | LetIn (name,c1,c2,c3) -> + let j1 = execute mf env sigma (mkCast (c1, c2)) in + let env1 = push_rel (name,Some j1.uj_val,j1.uj_type) env in + let j3 = execute mf env1 sigma c3 in + judge_of_letin env name j1 j3 - | IsCast (c,t) -> + | Cast (c,t) -> let cj = execute mf env sigma c in let tj = execute mf env sigma t in - let tj = assumption_of_judgment env sigma tj in - let j, _ = cast_rel env sigma cj tj in + let tj = type_judgment env sigma tj in + let j, _ = judge_of_cast env cj tj in j - -and execute_fix mf env sigma (names,lar,vdef) = + +and execute_recdef mf env sigma (names,lar,vdef) = let larj = execute_array mf env sigma lar in let lara = Array.map (assumption_of_judgment env sigma) larj in - let ctxt = - array_map2_i (fun i na ty -> (na, type_app (lift i) ty)) names lara in - let env1 = - Array.fold_left (fun env nvar -> push_rel_assum nvar env) env ctxt in + let env1 = push_rec_types (names,lara,vdef) env in let vdefj = execute_array mf env1 sigma vdef in let vdefv = Array.map j_val vdefj in - let cst3 = type_fixpoint env1 sigma names lara vdefj in + let _ = type_fixpoint env1 names lara vdefj in (names,lara,vdefv) and execute_array mf env sigma v = diff --git a/proofs/clenv.ml b/proofs/clenv.ml index c2aa9a7ff..4ea4c4f50 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -12,13 +12,14 @@ open Pp open Util open Names open Term +open Termops open Sign open Instantiate open Environ open Evd open Proof_type open Logic -open Reduction +open Reductionops open Tacmach open Evar_refiner @@ -39,7 +40,7 @@ let exist_to_meta (emap, c) = List.iter add_binding emap; let rec replace c = match kind_of_term c with - IsEvar k -> List.assoc k !subst + Evar k -> List.assoc k !subst | _ -> map_constr replace c in (!mmap, replace c) @@ -66,7 +67,7 @@ let applyHead n c wc = (wc,c) else match kind_of_term (w_whd_betadeltaiota wc cty) with - | IsProd (_,c1,c2) -> + | Prod (_,c1,c2) -> let evar = Evarutil.new_evar_in_sign (w_env wc) in let (evar_n, _) = destEvar evar in (compose @@ -99,20 +100,20 @@ let unify_0 cv_pb mc wc m n = and cN = Evarutil.whd_castappevar sigma n in try match (kind_of_term cM,kind_of_term cN) with - | IsCast (c,_), _ -> unirec_rec pb substn c cN - | _, IsCast (c,_) -> unirec_rec pb substn cM c - | IsMeta k1, IsMeta k2 -> + | Cast (c,_), _ -> unirec_rec pb substn c cN + | _, Cast (c,_) -> unirec_rec pb substn cM c + | Meta k1, Meta k2 -> if k1 < k2 then (k1,cN)::metasubst,evarsubst else if k1 = k2 then substn else (k2,cM)::metasubst,evarsubst - | IsMeta k, _ -> (k,cN)::metasubst,evarsubst - | _, IsMeta k -> (k,cM)::metasubst,evarsubst - | IsLambda (_,t1,c1), IsLambda (_,t2,c2) -> + | Meta k, _ -> (k,cN)::metasubst,evarsubst + | _, Meta k -> (k,cM)::metasubst,evarsubst + | Lambda (_,t1,c1), Lambda (_,t2,c2) -> unirec_rec CONV (unirec_rec CONV substn t1 t2) c1 c2 - | IsProd (_,t1,c1), IsProd (_,t2,c2) -> + | Prod (_,t1,c1), Prod (_,t2,c2) -> unirec_rec pb (unirec_rec CONV substn t1 t2) c1 c2 - | IsApp (f1,l1), IsApp (f2,l2) -> + | App (f1,l1), App (f2,l2) -> let len1 = Array.length l1 and len2 = Array.length l2 in if len1 = len2 then @@ -129,42 +130,42 @@ let unify_0 cv_pb mc wc m n = (unirec_rec CONV substn (appvect (f1,extras)) f2) restl1 l2 - | IsMutCase (_,p1,c1,cl1), IsMutCase (_,p2,c2,cl2) -> + | Case (_,p1,c1,cl1), Case (_,p2,c2,cl2) -> array_fold_left2 (unirec_rec CONV) (unirec_rec CONV (unirec_rec CONV substn p1 p2) c1 c2) cl1 cl2 - | IsMutConstruct _, IsMutConstruct _ -> + | Construct _, Construct _ -> if is_conv env sigma cM cN then substn else - error_cannot_unify CCI (m,n) + error_cannot_unify (m,n) - | IsMutInd _, IsMutInd _ -> + | Ind _, Ind _ -> if is_conv env sigma cM cN then substn else - error_cannot_unify CCI (m,n) + error_cannot_unify (m,n) - | IsEvar _, _ -> + | Evar _, _ -> metasubst,((cM,cN)::evarsubst) - | _, IsEvar _ -> + | _, Evar _ -> metasubst,((cN,cM)::evarsubst) - | (IsConst _ | IsVar _ | IsRel _), _ -> + | (Const _ | Var _ | Rel _), _ -> if is_conv env sigma cM cN then substn else - error_cannot_unify CCI (m,n) + error_cannot_unify (m,n) - | _, (IsConst _ | IsVar _| IsRel _) -> + | _, (Const _ | Var _| Rel _) -> if (not (occur_meta cM)) & is_conv env sigma cM cN then substn else - error_cannot_unify CCI (m,n) + error_cannot_unify (m,n) - | IsLetIn (_,b,_,c), _ -> unirec_rec pb substn (subst1 b c) cN + | LetIn (_,b,_,c), _ -> unirec_rec pb substn (subst1 b c) cN - | _ -> error_cannot_unify CCI (m,n) + | _ -> error_cannot_unify (m,n) with ex when catchable_exception ex -> if (not(occur_meta cM)) & is_fconv pb env sigma cM cN then @@ -239,12 +240,12 @@ and w_resrec metas evars wc = | (lhs,rhs) :: t -> match kind_of_term rhs with - | IsMeta k -> w_resrec ((k,lhs)::metas) t wc + | Meta k -> w_resrec ((k,lhs)::metas) t wc | krhs -> match kind_of_term lhs with - | IsEvar (evn,_) -> + | Evar (evn,_) -> if w_defined_evar wc evn then let (wc',metas') = w_Unify CONV rhs lhs metas wc in w_resrec metas' t wc' @@ -253,7 +254,7 @@ and w_resrec metas evars wc = w_resrec metas t (w_Define evn rhs wc) with ex when catchable_exception ex -> (match krhs with - | IsApp (f,cl) when isConst f -> + | App (f,cl) when isConst f -> let wc' = mimick_evar f (Array.length cl) evn wc in w_resrec metas evars wc' | _ -> error "w_Unify")) @@ -276,7 +277,7 @@ let unify m gls = let collect_metas c = let rec collrec acc c = match kind_of_term c with - | IsMeta mv -> mv::acc + | Meta mv -> mv::acc | _ -> fold_constr collrec acc c in List.rev (collrec [] c) @@ -284,7 +285,7 @@ let collect_metas c = let metavars_of c = let rec collrec acc c = match kind_of_term c with - | IsMeta mv -> Intset.add mv acc + | Meta mv -> Intset.add mv acc | _ -> fold_constr collrec acc c in collrec Intset.empty c @@ -326,8 +327,8 @@ let clenv_environments bound c = let rec clrec (ne,e,metas) n c = 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)) -> + | (n, Cast (c,_)) -> clrec (ne,e,metas) n c + | (n, Prod (na,c1,c2)) -> let mv = new_meta () in let dep = dependent (mkRel 1) c2 in let ne' = @@ -347,7 +348,7 @@ let clenv_environments bound c = let e' = Intmap.add mv (Cltyp (mk_freelisted c1)) e in clrec (ne',e', (mkMeta mv)::metas) (n-1) (if dep then (subst1 (mkMeta mv) c2) else c2) - | (n, IsLetIn (na,b,_,c)) -> clrec (ne,e,metas) (n-1) (subst1 b c) + | (n, LetIn (na,b,_,c)) -> clrec (ne,e,metas) (n-1) (subst1 b c) | (n, _) -> (ne, e, List.rev metas, c) in clrec (Intmap.empty,Intmap.empty,[]) bound c @@ -463,13 +464,13 @@ let clenv_instance_term clenv c = let clenv_cast_meta clenv = let rec crec u = match kind_of_term u with - | IsApp _ | IsMutCase _ -> crec_hd u - | IsCast (c,_) when isMeta c -> u + | App _ | Case _ -> crec_hd u + | Cast (c,_) when isMeta c -> u | _ -> map_constr crec u and crec_hd u = match kind_of_term (strip_outer_cast u) with - | IsMeta mv -> + | Meta mv -> (try match Intmap.find mv clenv.env with | Cltyp b -> @@ -478,9 +479,9 @@ let clenv_cast_meta clenv = | Clval(_) -> u with Not_found -> u) - | IsApp(f,args) -> mkApp (crec_hd f, Array.map crec args) - | IsMutCase(ci,p,c,br) -> - mkMutCase (ci, crec_hd p, crec_hd c, Array.map crec br) + | App(f,args) -> mkApp (crec_hd f, Array.map crec args) + | Case(ci,p,c,br) -> + mkCase (ci, crec_hd p, crec_hd c, Array.map crec br) | _ -> u in crec @@ -564,12 +565,12 @@ let clenv_merge with_types = | ((lhs,rhs)::t, metas) -> (match kind_of_term rhs with - | IsMeta k -> clenv_resrec ((k,lhs)::metas) t clenv + | Meta k -> clenv_resrec ((k,lhs)::metas) t clenv | krhs -> (match kind_of_term lhs with - | IsEvar (evn,_) -> + | Evar (evn,_) -> if w_defined_evar clenv.hook evn then let (metas',evars') = unify_0 CONV [] clenv.hook rhs lhs in clenv_resrec (metas'@metas) (evars'@t) clenv @@ -583,7 +584,7 @@ let clenv_merge with_types = (clenv_wtactic (w_Define evn rhs') clenv) with ex when catchable_exception ex -> (match krhs with - | IsApp (f,cl) when isConst f or isMutConstruct f -> + | App (f,cl) when isConst f or isConstruct f -> clenv_resrec metas evars (clenv_wtactic (mimick_evar f (Array.length cl) evn) @@ -728,7 +729,7 @@ let constrain_clenv_to_subterm clause (op,cl) = else error "Bound 1" with ex when catchable_exception ex -> (match kind_of_term cl with - | IsApp (f,args) -> + | App (f,args) -> let n = Array.length args in assert (n>0); let c1 = mkApp (f,Array.sub args 0 (n-1)) in @@ -737,35 +738,35 @@ let constrain_clenv_to_subterm clause (op,cl) = matchrec c1 with ex when catchable_exception ex -> matchrec c2) - | IsMutCase(_,_,c,lf) -> (* does not search in the predicate *) + | Case(_,_,c,lf) -> (* does not search in the predicate *) (try matchrec c with ex when catchable_exception ex -> iter_fail matchrec lf) - | IsLetIn(_,c1,_,c2) -> + | LetIn(_,c1,_,c2) -> (try matchrec c1 with ex when catchable_exception ex -> matchrec c2) - | IsFix(_,(_,types,terms)) -> + | Fix(_,(_,types,terms)) -> (try iter_fail matchrec types with ex when catchable_exception ex -> iter_fail matchrec terms) - | IsCoFix(_,(_,types,terms)) -> + | CoFix(_,(_,types,terms)) -> (try iter_fail matchrec types with ex when catchable_exception ex -> iter_fail matchrec terms) - | IsProd (_,t,c) -> + | Prod (_,t,c) -> (try matchrec t with ex when catchable_exception ex -> matchrec c) - | IsLambda (_,t,c) -> + | Lambda (_,t,c) -> (try matchrec t with ex when catchable_exception ex -> @@ -1007,7 +1008,7 @@ let secondOrderAbstraction allow_K gl p oplist clause = let clenv_so_resolver allow_K clause gl = let c, oplist = whd_stack (clenv_instance_template_type clause) in match kind_of_term c with - | IsMeta p -> + | Meta p -> let clause' = secondOrderAbstraction allow_K gl p oplist clause in clenv_fo_resolver clause' gl | _ -> error "clenv_so_resolver" @@ -1027,7 +1028,7 @@ let clenv_unique_resolver allow_K clenv gls = let pathd,_ = whd_stack (clenv_instance_template_type clenv) in let glhd,_ = whd_stack (pf_concl gls) in match kind_of_term pathd, kind_of_term glhd with - | IsMeta _, IsLambda _ -> + | Meta _, Lambda _ -> (try clenv_typed_fo_resolver clenv gls with ex when catchable_exception ex -> @@ -1036,7 +1037,7 @@ let clenv_unique_resolver allow_K clenv gls = with ex when catchable_exception ex -> error "Cannot solve a second-order unification problem") - | IsMeta _, _ -> + | Meta _, _ -> (try clenv_so_resolver allow_K clenv gls with ex when catchable_exception ex -> diff --git a/proofs/clenv.mli b/proofs/clenv.mli index f402e964d..65307debe 100644 --- a/proofs/clenv.mli +++ b/proofs/clenv.mli @@ -56,7 +56,7 @@ type wc = walking_constraints (* for a better reading of the following *) val unify : constr -> tactic val unify_0 : - Reduction.conv_pb -> (int * constr) list -> wc -> constr -> constr + Reductionops.conv_pb -> (int * constr) list -> wc -> constr -> constr -> (int * constr) list * (constr * constr) list val collect_metas : constr -> int list @@ -80,7 +80,7 @@ val clenv_instance_type : wc clausenv -> int -> constr val clenv_instance_template : wc clausenv -> constr val clenv_instance_template_type : wc clausenv -> constr val clenv_unify : - Reduction.conv_pb -> constr -> constr -> wc clausenv -> wc clausenv + Reductionops.conv_pb -> constr -> constr -> wc clausenv -> wc clausenv val clenv_fchain : int -> 'a clausenv -> wc clausenv -> wc clausenv val clenv_refine : (wc -> tactic) -> wc clausenv -> tactic val res_pf : (wc -> tactic) -> wc clausenv -> tactic @@ -120,7 +120,7 @@ val clenv_constrain_dep_args_of : val constrain_clenv_using_subterm_list : bool -> wc clausenv -> constr list -> constr -> wc clausenv * constr list val clenv_typed_unify : - Reduction.conv_pb -> constr -> constr -> wc clausenv -> wc clausenv + Reductionops.conv_pb -> constr -> constr -> wc clausenv -> wc clausenv val pr_clenv : 'a clausenv -> Pp.std_ppcmds diff --git a/proofs/evar_refiner.ml b/proofs/evar_refiner.ml index 0256dd600..a4fb3fe9b 100644 --- a/proofs/evar_refiner.ml +++ b/proofs/evar_refiner.ml @@ -15,7 +15,7 @@ open Names open Term open Environ open Evd -open Reduction +open Reductionops open Typing open Instantiate open Tacred @@ -104,7 +104,7 @@ let w_add_sign (id,t) (wc : walking_constraints) = ids_mk (ts_mod (fun evr -> { focus = evr.focus; - hyps = Sign.add_named_assum (id,t) evr.hyps; + hyps = Sign.add_named_decl (id,None,t) evr.hyps; decls = evr.decls }) (ids_it wc)) @@ -144,14 +144,13 @@ let w_Declare_At sp sp' c = w_Focusing sp (w_Declare sp' c) let evars_of sigma constr = let rec filtrec acc c = - match splay_constr c with - | OpEvar ev, cl -> + match kind_of_term c with + | Evar (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 + | _ -> fold_constr filtrec acc c in filtrec Intset.empty constr diff --git a/proofs/logic.ml b/proofs/logic.ml index 58fb85240..ed13b9c25 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -13,10 +13,12 @@ open Util open Names open Evd open Term +open Termops open Sign open Environ -open Reduction +open Reductionops open Inductive +open Inductiveops open Typing open Proof_trees open Proof_type @@ -31,10 +33,10 @@ open Evarutil variables only in Application and Case *) let collect_meta_variables c = - let rec collrec acc c = match splay_constr c with - | OpMeta mv, _ -> mv::acc - | OpCast, [|c;_|] -> collrec acc c - | (OpApp | OpMutCase _), cl -> Array.fold_left collrec acc cl + let rec collrec acc c = match kind_of_term c with + | Meta mv -> mv::acc + | Cast(c,_) -> collrec acc c + | (App _| Case _) -> fold_constr collrec acc c | _ -> acc in List.rev(collrec [] c) @@ -64,7 +66,7 @@ let catchable_exception = function Nametab.GlobalizationError _)) -> true | _ -> false -let error_cannot_unify k (m,n) = +let error_cannot_unify (m,n) = raise (RefinerError (CannotUnify (m,n))) let check = ref true @@ -91,25 +93,25 @@ let rec mk_refgoals sigma goal goalacc conclty trm = else *) match kind_of_term trm with - | IsMeta _ -> + | Meta _ -> if occur_meta conclty then raise (RefinerError (OccurMetaGoal conclty)); let ctxt = out_some goal.evar_info in (mk_goal ctxt hyps (nf_betaiota conclty))::goalacc, conclty - | IsCast (t,ty) -> + | Cast (t,ty) -> let _ = type_of env sigma ty in conv_leq_goal env sigma trm ty conclty; mk_refgoals sigma goal goalacc ty t - | IsApp (f,l) -> + | App (f,l) -> let (acc',hdty) = mk_hdgoals sigma goal goalacc f in let (acc'',conclty') = mk_arggoals sigma goal acc' hdty (Array.to_list l) in let _ = conv_leq_goal env sigma trm conclty' conclty in (acc'',conclty') - | IsMutCase (_,p,c,lf) -> + | Case (_,p,c,lf) -> let (acc',lbrty,conclty') = mk_casegoals sigma goal goalacc p c in let acc'' = array_fold_left2 @@ -132,16 +134,16 @@ and mk_hdgoals sigma goal goalacc trm = let env = evar_env goal in let hyps = goal.evar_hyps in match kind_of_term trm with - | IsCast (c,ty) when isMeta c -> + | Cast (c,ty) when isMeta c -> let _ = type_of env sigma ty in let ctxt = out_some goal.evar_info in (mk_goal ctxt hyps (nf_betaiota ty))::goalacc,ty - | IsApp (f,l) -> + | App (f,l) -> let (acc',hdty) = mk_hdgoals sigma goal goalacc f in mk_arggoals sigma goal acc' hdty (Array.to_list l) - | IsMutCase (_,p,c,lf) -> + | Case (_,p,c,lf) -> let (acc',lbrty,conclty') = mk_casegoals sigma goal goalacc p c in let acc'' = array_fold_left2 @@ -157,10 +159,10 @@ and mk_arggoals sigma goal goalacc funty = function | harg::tlargs as allargs -> let t = whd_betadeltaiota (evar_env goal) sigma funty in match kind_of_term t with - | IsProd (_,c1,b) -> + | Prod (_,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) -> + | LetIn (_,c1,_,b) -> mk_arggoals sigma goal goalacc (subst1 c1 b) allargs | _ -> raise (RefinerError (CannotApply (t,harg))) @@ -170,10 +172,10 @@ and mk_casegoals sigma goal goalacc p c = let (acc'',pt) = mk_hdgoals sigma goal acc' p in let pj = {uj_val=p; uj_type=pt} in let indspec = - try find_rectype env sigma ct + try find_mrectype env sigma ct with Induc -> anomaly "mk_casegoals" in - let (lbrty,conclty,_) = - type_case_branches env sigma indspec pj c in + let (lbrty,conclty) = + type_case_branches_with_names env indspec pj c in (acc'',lbrty,conclty) @@ -377,15 +379,15 @@ let prim_refiner r sigma goal = if !check && mem_named_context id sign then error "New variable is already declared"; (match kind_of_term (strip_outer_cast cl) with - | IsProd (_,c1,b) -> + | Prod (_,c1,b) -> if occur_meta c1 then error_use_instantiate(); - let sg = mk_goal info (add_named_assum (id,c1) sign) + let sg = mk_goal info (add_named_decl (id,None,c1) sign) (subst1 (mkVar id) b) in [sg] - | IsLetIn (_,c1,t1,b) -> + | LetIn (_,c1,t1,b) -> if occur_meta c1 or occur_meta t1 then error_use_instantiate(); let sg = - mk_goal info (add_named_def (id,c1,t1) sign) + mk_goal info (add_named_decl (id,Some c1,t1) sign) (subst1 (mkVar id) b) in [sg] | _ -> @@ -396,12 +398,12 @@ let prim_refiner r sigma goal = if !check && mem_named_context id sign then error "New variable is already declared"; (match kind_of_term (strip_outer_cast cl) with - | IsProd (_,c1,b) -> + | Prod (_,c1,b) -> if occur_meta c1 then error_use_instantiate(); let sign' = insert_after_hyp sign whereid (id,None,c1) in let sg = mk_goal info sign' (subst1 (mkVar id) b) in [sg] - | IsLetIn (_,c1,t1,b) -> + | LetIn (_,c1,t1,b) -> if occur_meta c1 or occur_meta t1 then error_use_instantiate(); let sign' = insert_after_hyp sign whereid (id,Some c1,t1) in let sg = mk_goal info sign' (subst1 (mkVar id) b) in @@ -412,12 +414,12 @@ let prim_refiner r sigma goal = | { name = Intro_replacing; newids = []; hypspecs = [id] } -> (match kind_of_term (strip_outer_cast cl) with - | IsProd (_,c1,b) -> + | Prod (_,c1,b) -> if occur_meta c1 then error_use_instantiate(); let sign' = replace_hyp sign id (id,None,c1) in let sg = mk_goal info sign' (subst1 (mkVar id) b) in [sg] - | IsLetIn (_,c1,t1,b) -> + | LetIn (_,c1,t1,b) -> if occur_meta c1 then error_use_instantiate(); let sign' = replace_hyp sign id (id,Some c1,t1) in let sg = mk_goal info sign' (subst1 (mkVar id) b) in @@ -432,11 +434,11 @@ let prim_refiner r sigma goal = let sg2 = mk_goal info (add_named_decl (id,None,t) sign) cl in if b then [sg1;sg2] else [sg2;sg1] - | { name = Fix; hypspecs = []; terms = []; + | { name = FixRule; hypspecs = []; terms = []; newids = [f]; params = [Num(_,n)] } -> let rec check_ind k cl = match kind_of_term (strip_outer_cast cl) with - | IsProd (_,c1,b) -> + | Prod (_,c1,b) -> if k = 1 then try let _ = find_inductive env sigma c1 in () @@ -449,13 +451,13 @@ let prim_refiner r sigma goal = check_ind n cl; if !check && mem_named_context f sign then error ("The name "^(string_of_id f)^" is already used"); - let sg = mk_goal info (add_named_assum (f,cl) sign) cl in + let sg = mk_goal info (add_named_decl (f,None,cl) sign) cl in [sg] - | { name = Fix; hypspecs = []; terms = lar; newids = lf; params = ln } -> + | { name = FixRule; hypspecs = []; terms = lar; newids = lf; params = ln } -> let rec check_ind k cl = match kind_of_term (strip_outer_cast cl) with - | IsProd (_,c1,b) -> + | Prod (_,c1,b) -> if k = 1 then try fst (find_inductive env sigma c1) @@ -475,7 +477,7 @@ let prim_refiner r sigma goal = "mutual inductive declaration"); if mem_named_context f sign then error "name already used in the environment"; - mk_sign (add_named_assum (f,ar) sign) (lar',lf',ln') + mk_sign (add_named_decl (f,None,ar) sign) (lar',lf',ln') | ([],[],[]) -> List.map (mk_goal info sign) (cl::lar) | _ -> error "not the right number of arguments" @@ -486,7 +488,7 @@ let prim_refiner r sigma goal = let rec check_is_coind cl = let b = whd_betadeltaiota env sigma cl in match kind_of_term b with - | IsProd (_,c1,b) -> check_is_coind b + | Prod (_,c1,b) -> check_is_coind b | _ -> try let _ = find_coinductive env sigma b in () @@ -498,10 +500,11 @@ let prim_refiner r sigma goal = let rec mk_sign sign = function | (ar::lar'),(f::lf') -> (try - (let _ = lookup_id f sign in + (let _ = Sign.lookup_named f sign in error "name already used in the environment") with - | Not_found -> mk_sign (add_named_assum (f,ar) sign) (lar',lf')) + | Not_found -> + mk_sign (add_named_decl (f,None,ar) sign) (lar',lf')) | ([],[]) -> List.map (mk_goal info sign) (cl::lar) | _ -> error "not the right number of arguments" in @@ -566,10 +569,10 @@ let prim_extractor subfun vl pft = match pft with | { ref = Some (Prim { name = Intro; newids = [id] }, [spf]) } -> (match kind_of_term (strip_outer_cast cl) with - | IsProd (_,ty,_) -> + | Prod (_,ty,_) -> let cty = subst_vars vl ty in mkLambda (Name id, cty, subfun (id::vl) spf) - | IsLetIn (_,b,ty,_) -> + | LetIn (_,b,ty,_) -> let cb = subst_vars vl b in let cty = subst_vars vl ty in mkLetIn (Name id, cb, cty, subfun (id::vl) spf) @@ -577,10 +580,10 @@ let prim_extractor subfun vl pft = | { ref = Some (Prim { name = Intro_after; newids = [id]}, [spf]) } -> (match kind_of_term (strip_outer_cast cl) with - | IsProd (_,ty,_) -> + | Prod (_,ty,_) -> let cty = subst_vars vl ty in mkLambda (Name id, cty, subfun (id::vl) spf) - | IsLetIn (_,b,ty,_) -> + | LetIn (_,b,ty,_) -> let cb = subst_vars vl b in let cty = subst_vars vl ty in mkLetIn (Name id, cb, cty, subfun (id::vl) spf) @@ -588,10 +591,10 @@ let prim_extractor subfun vl pft = | {ref=Some(Prim{name=Intro_replacing;hypspecs=[id]},[spf]) } -> (match kind_of_term (strip_outer_cast cl) with - | IsProd (_,ty,_) -> + | Prod (_,ty,_) -> let cty = subst_vars vl ty in mkLambda (Name id, cty, subfun (id::vl) spf) - | IsLetIn (_,b,ty,_) -> + | LetIn (_,b,ty,_) -> let cb = subst_vars vl b in let cty = subst_vars vl ty in mkLetIn (Name id, cb, cty, subfun (id::vl) spf) @@ -601,12 +604,12 @@ let prim_extractor subfun vl pft = let spf1, spf2 = if b then spf1, spf2 else spf2, spf1 in mkLetIn (Name id,subfun vl spf1,subst_vars vl t,subfun (id::vl) spf2) - | {ref=Some(Prim{name=Fix;newids=[f];params=[Num(_,n)]},[spf]) } -> + | {ref=Some(Prim{name=FixRule;newids=[f];params=[Num(_,n)]},[spf]) } -> let cty = subst_vars vl cl in let na = Name f in mkFix (([|n-1|],0),([|na|], [|cty|], [|subfun (f::vl) spf|])) - | {ref=Some(Prim{name=Fix;newids=lf;terms=lar;params=ln},spfl) } -> + | {ref=Some(Prim{name=FixRule;newids=lf;terms=lar;params=ln},spfl) } -> let lcty = List.map (subst_vars vl) (cl::lar) in let vn = Array.of_list (List.map (function Num(_,n) -> n-1 @@ -680,10 +683,10 @@ let pr_prim_rule = function else [< 'sTR"Cut "; prterm t; 'sTR ";[Intro "; pr_id id; 'sTR "|Idtac]" >] - | {name=Fix;newids=[f];params=[Num(_,n)]} -> + | {name=FixRule;newids=[f];params=[Num(_,n)]} -> [< 'sTR"Fix "; pr_id f; 'sTR"/"; 'iNT n>] - | {name=Fix;newids=(f::lf);params=(Num(_,n))::ln;terms=lar} -> + | {name=FixRule;newids=(f::lf);params=(Num(_,n))::ln;terms=lar} -> let rec print_mut = function (f::lf),((Num(_,n))::ln),(ar::lar) -> [< pr_id f; 'sTR"/"; 'iNT n; 'sTR" : "; prterm ar; diff --git a/proofs/logic.mli b/proofs/logic.mli index a1c525a34..3c960b657 100644 --- a/proofs/logic.mli +++ b/proofs/logic.mli @@ -61,7 +61,7 @@ type refiner_error = exception RefinerError of refiner_error -val error_cannot_unify : path_kind -> constr * constr -> 'a +val error_cannot_unify : constr * constr -> 'a val catchable_exception : exn -> bool diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 1dfc55973..5d015dbf8 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -23,6 +23,7 @@ open Proof_trees open Proof_type open Lib open Astterm +open Safe_typing (*********************************************************************) (* Managing the proofs state *) diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index 0ea59eea2..cd63d419e 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -93,7 +93,7 @@ val suspend_proof : unit -> unit into a constant with its name and strength; it fails if there is no current proof of if it is not completed *) -val cook_proof : unit -> identifier * (Declarations.constant_entry * strength) +val cook_proof : unit -> identifier * (Safe_typing.constant_entry * strength) (*s [get_pftreestate ()] returns the current focused pending proof or raises [UserError "no focused proof"] *) diff --git a/proofs/proof_trees.ml b/proofs/proof_trees.ml index 222b8277a..3003f20c6 100644 --- a/proofs/proof_trees.ml +++ b/proofs/proof_trees.ml @@ -12,6 +12,7 @@ open Closure open Util open Names open Term +open Termops open Sign open Evd open Stamps @@ -20,6 +21,7 @@ open Evarutil open Proof_type open Tacred open Typing +open Nametab let is_bind = function | Bindings _ -> true @@ -364,7 +366,8 @@ let last_of_cvt_flags (_,red) = (function | EvalVarRef id -> nvar id | EvalConstRef sp -> - ast_of_qualid (Global.qualid_of_global (ConstRef sp))) + ast_of_qualid + (qualid_of_global (Global.env()) (ConstRef sp))) lconst in if lqid = [] then [] else if n_unf then [ope("Delta",[]);ope("UnfBut",lqid)] @@ -384,7 +387,7 @@ let ast_of_cvt_redexp = function [match sp with | EvalVarRef id -> nvar id | EvalConstRef sp -> - ast_of_qualid (Global.qualid_of_global (ConstRef sp))] + ast_of_qualid (qualid_of_global (Global.env()) (ConstRef sp))] @(List.map num locc))) l) | Fold l -> ope("Fold",List.map (fun c -> ope ("COMMAND", diff --git a/proofs/proof_type.ml b/proofs/proof_type.ml index f427ec1f5..1109a5837 100644 --- a/proofs/proof_type.ml +++ b/proofs/proof_type.ml @@ -37,7 +37,7 @@ type prim_rule_name = | Intro_after | Intro_replacing | Cut of bool - | Fix + | FixRule | Cofix | Refine | Convert_concl diff --git a/proofs/proof_type.mli b/proofs/proof_type.mli index eb31544cb..bf7162aa3 100644 --- a/proofs/proof_type.mli +++ b/proofs/proof_type.mli @@ -40,7 +40,7 @@ type prim_rule_name = | Intro_after | Intro_replacing | Cut of bool - | Fix + | FixRule | Cofix | Refine | Convert_concl diff --git a/proofs/refiner.ml b/proofs/refiner.ml index e8d1574da..820c6eaff 100644 --- a/proofs/refiner.ml +++ b/proofs/refiner.ml @@ -12,11 +12,12 @@ open Pp open Util open Stamps open Term +open Termops open Sign open Evd open Sign open Environ -open Reduction +open Reductionops open Instantiate open Type_errors open Proof_trees @@ -52,7 +53,11 @@ let norm_goal sigma gl = let red_fun = Evarutil.nf_evar sigma in let ncl = red_fun gl.evar_concl in { evar_concl = ncl; - evar_hyps = map_named_context red_fun gl.evar_hyps; + evar_hyps = + Sign.fold_named_context + (fun (d,b,ty) sign -> + add_named_decl (d, option_app red_fun b, red_fun ty) sign) + empty_named_context gl.evar_hyps; evar_body = gl.evar_body; evar_info = gl.evar_info } @@ -252,7 +257,7 @@ let extract_open_proof sigma pf = let abs_concl = List.fold_right (fun (_,id) concl -> - let (c,ty) = lookup_id id goal.evar_hyps in + let (_,c,ty) = Sign.lookup_named id goal.evar_hyps in mkNamedProd_or_LetIn (id,c,ty) concl) sorted_rels goal.evar_concl in incr meta_cnt; @@ -811,7 +816,7 @@ let thin_sign osign sign = Sign.fold_named_context (fun (id,c,ty as d) sign -> try - if lookup_id id osign = (c,ty) then sign + if Sign.lookup_named id osign = (id,c,ty) then sign else raise Different with Not_found | Different -> add_named_decl d sign) sign empty_named_context diff --git a/proofs/tacinterp.ml b/proofs/tacinterp.ml index 339a53d82..b037a4a31 100644 --- a/proofs/tacinterp.ml +++ b/proofs/tacinterp.ml @@ -21,6 +21,7 @@ open Sign open Tacred open Util open Names +open Nameops open Nametab open Pfedit open Proof_type @@ -29,7 +30,9 @@ open Tactic_debug open Coqast open Ast open Term +open Termops open Declare +open Safe_typing let err_msg_tactic_not_found macro_loc macro = user_err_loc @@ -107,7 +110,7 @@ let make_qid = function | VArg (Identifier id) -> VArg (Qualid (make_short_qualid id)) | VArg (Constr c) -> (match (kind_of_term c) with - | IsConst cst -> VArg (Qualid (qualid_of_sp cst)) + | Const cst -> VArg (Qualid (qualid_of_sp cst)) | _ -> anomalylabstrm "make_qid" [< 'sTR "Not a Qualid" >]) | _ -> anomalylabstrm "make_qid" [< 'sTR "Not a Qualid" >] @@ -124,7 +127,7 @@ let constr_of_id id = function else let csr = global_qualified_reference (make_short_qualid id) in (match kind_of_term csr with - | IsVar _ -> raise Not_found + | Var _ -> raise Not_found | _ -> csr) (* Extracted the constr list from lfun *) @@ -209,21 +212,21 @@ let glob_const_nvar loc env qid = try (* We first look for a variable of the current proof *) match Nametab.repr_qualid qid with - | d,id when is_empty_dirpath d -> + | d,id when repr_dirpath d = [] -> (* lookup_value may raise Not_found *) - (match Environ.lookup_named_value id env with - | Some _ -> + (match Environ.lookup_named id env with + | (_,Some _,_) -> let v = EvalVarRef id in if Opaque.is_evaluable env v then v else error ("variable "^(string_of_id id)^" is opaque") - | None -> error ((string_of_id id)^ + | _ -> error ((string_of_id id)^ " does not denote an evaluable constant")) | _ -> raise Not_found with Not_found -> try let ev = (match Nametab.locate qid with | ConstRef sp -> EvalConstRef sp - | VarRef sp -> EvalVarRef (basename sp) + | VarRef id -> EvalVarRef id | _ -> error ((Nametab.string_of_qualid qid) ^ " does not denote an evaluable constant")) in if Opaque.is_evaluable env ev then ev @@ -1135,7 +1138,6 @@ and flag_of_ast ist lf = add_flag red lf | Node(_,"Iota",[])::lf -> add_flag (red_add red fIOTA) lf | Node(_,"Zeta",[])::lf -> add_flag (red_add red fZETA) lf - | Node(_,"Evar",[])::lf -> add_flag (red_add red fEVAR) lf | Node(loc,("Unf"|"UnfBut"),l)::_ -> user_err_loc(loc,"flag_of_ast", [<'sTR "Delta must be specified just before">]) @@ -1232,6 +1234,6 @@ let add_tacdef na vbody = [< 'sTR "There is already a Meta Definition or a Tactic Definition named "; pr_id na>]; - let _ = Lib.add_leaf na OBJ (inMD (na,vbody)) in + let _ = Lib.add_leaf na (inMD (na,vbody)) in Options.if_verbose mSGNL [< pr_id na; 'sTR " is defined" >] end diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index d429b4069..e5ccf6d32 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -13,9 +13,10 @@ open Stamps open Names open Sign open Term +open Termops open Instantiate open Environ -open Reduction +open Reductionops open Evd open Typing open Tacred @@ -60,11 +61,13 @@ let pf_last_hyp gl = List.hd (pf_hyps gl) let pf_get_hyp gls id = try - lookup_id id (pf_hyps gls) + Sign.lookup_named id (pf_hyps gls) with Not_found -> error ("No such hypothesis : " ^ (string_of_id id)) -let pf_get_hyp_typ gls id = snd (pf_get_hyp gls id) +let pf_get_hyp_typ gls id = + let (_,_,ty)= (pf_get_hyp gls id) in + ty let pf_ids_of_hyps gls = ids_of_named_context (pf_hyps gls) @@ -264,7 +267,7 @@ let move_hyp with_dep id1 id2 gl = newids = []; params = []}) gl let mutual_fix lf ln lar pf = - refiner (Prim { name = Fix; newids = lf; + refiner (Prim { name = FixRule; newids = lf; hypspecs = []; terms = lar; params = List.map Ast.num ln}) pf diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index 640e29439..c81748a28 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -56,7 +56,7 @@ val hnf_type_of : goal sigma -> constr -> constr val pf_interp_constr : goal sigma -> Coqast.t -> constr val pf_interp_type : goal sigma -> Coqast.t -> constr -val pf_get_hyp : goal sigma -> identifier -> constr option * types +val pf_get_hyp : goal sigma -> identifier -> named_declaration val pf_get_hyp_typ : goal sigma -> identifier -> types val pf_reduction_of_redexp : goal sigma -> red_expr -> constr -> constr diff --git a/tactics/auto.ml b/tactics/auto.ml index 6bd773698..a1b251c7a 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -11,7 +11,9 @@ open Pp open Util open Names +open Nameops open Term +open Termops open Sign open Inductive open Evd @@ -32,6 +34,8 @@ open Libobject open Library open Vernacinterp open Printer +open Nametab +open Declarations (****************************************************************************) (* The Type of Constructions Autotactic Hints *) @@ -186,7 +190,7 @@ let (inAutoHint,outAutoHint) = (**************************************************************************) let rec nb_hyp c = match kind_of_term c with - | IsProd(_,_,c2) -> if dependent (mkRel 1) c2 then nb_hyp c2 else 1+(nb_hyp c2) + | Prod(_,_,c2) -> if dependent (mkRel 1) c2 then nb_hyp c2 else 1+(nb_hyp c2) | _ -> 0 (* adding and removing tactics in the search table *) @@ -198,7 +202,7 @@ let try_head_pattern c = let make_exact_entry name (c,cty) = let cty = strip_outer_cast cty in match kind_of_term cty with - | IsProd (_,_,_) -> + | Prod (_,_,_) -> failwith "make_exact_entry" | _ -> (head_of_constr_reference (List.hd (head_constr cty)), @@ -207,7 +211,7 @@ let make_exact_entry name (c,cty) = let make_apply_entry env sigma (eapply,verbose) name (c,cty) = let cty = hnf_constr env sigma cty in match kind_of_term cty with - | IsProd _ -> + | Prod _ -> let ce = mk_clenv_from () (c,cty) in let c' = (clenv_template_type ce).rebus in let pat = Pattern.pattern_of_constr c' in @@ -374,14 +378,16 @@ let _ = begin try let env = Global.env() and sigma = Evd.empty in - let isp = destMutInd (Declare.global_qualified_reference qid) in + let isp = destInd (Declare.global_qualified_reference qid) in let conspaths = - mis_conspaths (Global.lookup_mind_specif isp) in + let (mib,mip) = Global.lookup_inductive isp in + mip.mind_consnames in let lcons = array_map_to_list - (fun sp -> - let c = Declare.global_absolute_reference sp in - (basename sp, c)) + (fun id -> + let sp = make_path (dirpath (fst isp)) id in + let c = Declare.global_absolute_reference sp in + (id, c)) conspaths in let dbnames = if l = [] then ["core"] else List.map (function VARG_IDENTIFIER i -> string_of_id i @@ -726,7 +732,7 @@ let decomp_unary_term c gls = let decomp_empty_term c gls = let typc = pf_type_of gls c in - let (hd,_) = decomp_app typc in + let (hd,_) = decompose_app typc in if Hipattern.is_empty_type hd then simplest_case c gls else @@ -874,7 +880,8 @@ let compileAutoArg contac = function tclFIRST (List.map (fun (id,_,typ) -> - if (Hipattern.is_conjunction (hd_of_prod (body_of_type typ))) + let cl = snd (decompose_prod (body_of_type typ)) in + if (Hipattern.is_conjunction cl) then (tclTHEN (tclTHEN (simplest_elim (mkVar id)) @@ -918,7 +925,7 @@ let rec super_search n db_list local_db argl goal = let search_superauto n to_add argl g = let sigma = List.fold_right - (fun (id,c) -> add_named_assum (id, pf_type_of g c)) + (fun (id,c) -> add_named_decl (id, None, pf_type_of g c)) to_add empty_named_context in let db0 = list_map_append (make_resolve_hyp (pf_env g) (project g)) sigma in let db = Hint_db.add_list db0 (make_local_hint_db g) in diff --git a/tactics/auto.mli b/tactics/auto.mli index bff61a849..504cb8ba9 100644 --- a/tactics/auto.mli +++ b/tactics/auto.mli @@ -19,6 +19,7 @@ open Clenv open Pattern open Environ open Evd +open Nametab (*i*) type auto_tactic = diff --git a/tactics/eauto.ml b/tactics/eauto.ml index 24beccf3b..3928d6a5e 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -12,6 +12,7 @@ open Pp open Util open Names open Term +open Termops open Sign open Reduction open Proof_type @@ -79,9 +80,10 @@ let prolog_tac l n gl = errorlabstrm "Prolog.prolog" [< 'sTR "Prolog failed" >] let evars_of evc c = - let rec evrec acc c = match splay_constr c with - | OpEvar n, _ when Evd.in_dom evc n -> c :: acc - | _, cl -> Array.fold_left evrec acc cl + let rec evrec acc c = + match kind_of_term c with + | Evar (n, _) when Evd.in_dom evc n -> c :: acc + | _ -> fold_constr evrec acc c in evrec [] c diff --git a/tactics/elim.ml b/tactics/elim.ml index fed756814..a79186719 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -12,9 +12,10 @@ open Pp open Util open Names open Term +open Termops open Environ open Reduction -open Inductive +open Inductiveops open Proof_type open Clenv open Hipattern @@ -104,7 +105,7 @@ let inductive_of_qualid gls qid = with Not_found -> Nametab.error_global_not_found qid in match kind_of_term c with - | IsMutInd ity -> ity + | Ind ity -> ity | _ -> errorlabstrm "Decompose" [< Nametab.pr_qualid qid; 'sTR " is not an inductive type" >] diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml index ae2d8a4a5..d2d2dadd5 100644 --- a/tactics/eqdecide.ml +++ b/tactics/eqdecide.ml @@ -10,7 +10,9 @@ open Util open Names +open Nameops open Term +open Declarations open Tactics open Tacticals open Hiddentac @@ -65,9 +67,9 @@ let h_solveRightBranch = (* Constructs the type {c1=c2}+{~c1=c2} *) let mkDecideEqGoal rectype c1 c2 g = - let equality = mkAppA [|build_coq_eq_data.eq (); rectype; c1; c2|] in - let disequality = mkAppA [|build_coq_not (); equality|] in - mkAppA [|build_coq_sumbool (); equality; disequality |] + let equality = mkApp(build_coq_eq_data.eq (), [|rectype; c1; c2|]) in + let disequality = mkApp(build_coq_not (), [|equality|]) in + mkApp(build_coq_sumbool (), [|equality; disequality |]) (* Constructs the type (x1,x2:R){x1=x2}+{~x1=x2} *) @@ -110,8 +112,9 @@ let solveLeftBranch rectype g = with Pattern.PatternMatchingFailure -> error "Unexpected conclusion!" with | _ :: lhs :: rhs :: _ -> - let nparams = Global.mind_nparams rectype in - let getargs l = snd (list_chop nparams (snd (decomp_app l))) in + let (mib,mip) = Global.lookup_inductive rectype in + let nparams = mip.mind_nparams in + let getargs l = snd (list_chop nparams (snd (decompose_app l))) in let rargs = getargs (snd rhs) and largs = getargs (snd lhs) in List.fold_right2 @@ -122,7 +125,7 @@ let solveLeftBranch rectype g = (* The tactic Decide Equality *) let hd_app c = match kind_of_term c with - | IsApp (h,_) -> h + | App (h,_) -> h | _ -> c let decideGralEquality g = @@ -135,7 +138,7 @@ let decideGralEquality g = let headtyp = hd_app (pf_compute g typ) in let rectype = match kind_of_term headtyp with - | IsMutInd mi -> mi + | Ind mi -> mi | _ -> error "This decision procedure only works for inductive objects" in diff --git a/tactics/equality.ml b/tactics/equality.ml index 2137b4f1c..d1ac66b1f 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -13,9 +13,11 @@ open Util open Names open Univ open Term +open Termops open Inductive +open Inductiveops open Environ -open Reduction +open Reductionops open Instantiate open Typeops open Typing @@ -34,6 +36,7 @@ open Tacred open Vernacinterp open Coqlib open Setoid_replace +open Declarations (* Rewriting tactics *) @@ -57,7 +60,7 @@ let general_rewrite_bindings lft2rgt (c,l) gl = else error "The term provided does not end with an equation" | Some (hdcncl,_) -> let hdcncls = string_of_inductive hdcncl in - let suffix = Declare.elimination_suffix (elimination_sort_of_goal gl)in + let suffix = Indrec.elimination_suffix (elimination_sort_of_goal gl)in let elim = if lft2rgt then pf_global gl (id_of_string (hdcncls^suffix^"_r")) @@ -105,8 +108,8 @@ let abstract_replace (eq,sym_eq) (eqt,sym_eqt) c2 c1 unsafe gl = if unsafe or (pf_conv_x gl t1 t2) then let (e,sym) = match kind_of_term (hnf_type_of gl t1) with - | IsSort (Prop(Pos)) -> (eq,sym_eq) - | IsSort (Type(_)) -> (eqt,sym_eqt) + | Sort (Prop(Pos)) -> (eq,sym_eq) + | Sort (Type(_)) -> (eqt,sym_eqt) | _ -> error "replace" in (tclTHENL (elim_type (applist (e, [t1;c1;c2]))) @@ -176,7 +179,7 @@ let v_conditional_rewriteRL = let find_constructor env sigma c = let hd,stack = whd_betadeltaiota_stack env sigma c in match kind_of_term hd with - | IsMutConstruct _ -> (hd,stack) + | Construct _ -> (hd,stack) | _ -> error "find_constructor" (* Patterns *) @@ -204,23 +207,24 @@ type elimination_types = let necessary_elimination sort_arity sort = let sort_arity = mkSort sort_arity in - if (isType sort) then - if is_Set sort_arity then - Set_Type - else - if is_Type sort_arity then - Type_Type - else - errorlabstrm "necessary_elimination" - [< 'sTR "no primitive equality on proofs" >] - else - if is_Set sort_arity then - Set_SetorProp - else - if is_Type sort_arity then - Type_SetorProp - else errorlabstrm "necessary_elimination" - [< 'sTR "no primitive equality on proofs" >] + match sort with + Type _ -> + if is_Set sort_arity then + Set_Type + else + if is_Type sort_arity then + Type_Type + else + errorlabstrm "necessary_elimination" + [< 'sTR "no primitive equality on proofs" >] + | _ -> + if is_Set sort_arity then + Set_SetorProp + else + if is_Type sort_arity then + Type_SetorProp + else errorlabstrm "necessary_elimination" + [< 'sTR "no primitive equality on proofs" >] let find_eq_pattern aritysort sort = match necessary_elimination aritysort sort with @@ -273,7 +277,7 @@ let find_positions env sigma t1 t2 = let hd2,args2 = whd_betadeltaiota_stack env sigma t2 in match (kind_of_term hd1, kind_of_term hd2) with - | IsMutConstruct sp1, IsMutConstruct sp2 -> + | Construct sp1, Construct sp2 -> (* both sides are constructors, so either we descend, or we can discriminate here. *) if sp1 = sp2 then @@ -378,21 +382,24 @@ let descend_then sigma env head dirn = let IndType (indf,_) as indt = try find_rectype env sigma (get_type_of env sigma head) with Not_found -> assert false in - let mispec,_ = dest_ind_family indf in - let cstr = get_constructors indf in + let ind,_ = dest_ind_family indf in + let (mib,mip) = lookup_mind_specif env ind in + let cstr = get_constructors env indf in let dirn_nlams = cstr.(dirn-1).cs_nargs in let dirn_env = push_rels cstr.(dirn-1).cs_args env in (dirn_nlams, dirn_env, (fun dirnval (dfltval,resty) -> - let arign,_ = get_arity indf in - let p = it_mkLambda_or_LetIn (lift (mis_nrealargs mispec) resty) arign in + let arign,_ = get_arity env indf in + let p = it_mkLambda_or_LetIn (lift mip.mind_nrealargs resty) arign in let build_branch i = let result = if i = dirn then dirnval else dfltval in - it_mkLambda_or_LetIn_name env result cstr.(i-1).cs_args - in - mkMutCaseL (make_default_case_info mispec, p, head, - List.map build_branch (interval 1 (mis_nconstr mispec))))) + it_mkLambda_or_LetIn_name env result cstr.(i-1).cs_args in + let brl = + List.map build_branch + (interval 1 (Array.length mip.mind_consnames)) in + let ci = make_default_case_info env ind in + mkCase (ci, p, head, Array.of_list brl))) (* Now we need to construct the discriminator, given a discriminable position. This boils down to: @@ -412,7 +419,7 @@ let descend_then sigma env head dirn = giving [True], and all the rest giving False. *) let construct_discriminator sigma env dirn c sort = - let (IndType(IndFamily (mispec,_) as indf,_) as indt) = + let (IndType((ind,_) as indf,_) as indt) = try find_rectype env sigma (type_of env sigma c) with Not_found -> (* one can find Rel(k) in case of dependent constructors @@ -423,7 +430,8 @@ let construct_discriminator sigma env dirn c sort = errorlabstrm "Equality.construct_discriminator" [< 'sTR "Cannot discriminate on inductive constructors with dependent types" >] in - let arsign,arsort = get_arity indf in + let (mib,mip) = lookup_mind_specif env ind in + let arsign,arsort = get_arity env indf in let (true_0,false_0,sort_0) = match necessary_elimination arsort (destSort sort) with | Type_Type -> @@ -431,25 +439,24 @@ let construct_discriminator sigma env dirn c sort = | _ -> build_coq_True (), build_coq_False (), (Prop Null) in let p = it_mkLambda_or_LetIn (mkSort sort_0) arsign in - let cstrs = get_constructors indf in + let cstrs = get_constructors env indf in let build_branch i = let endpt = if i = dirn then true_0 else false_0 in - it_mkLambda_or_LetIn endpt cstrs.(i-1).cs_args - in - let build_match = - mkMutCaseL (make_default_case_info mispec, p, c, - List.map build_branch (interval 1 (mis_nconstr mispec))) - in - build_match + it_mkLambda_or_LetIn endpt cstrs.(i-1).cs_args in + let brl = + List.map build_branch(interval 1 (Array.length mip.mind_consnames)) in + let ci = make_default_case_info env ind in + mkCase (ci, p, c, Array.of_list brl) let rec build_discriminator sigma env dirn c sort = function | [] -> construct_discriminator sigma env dirn c sort | ((sp,cnum),argnum)::l -> let cty = type_of env sigma c in - let IndType (indf,_) = + let IndType ((ind,_)as indf,_) = try find_rectype env sigma cty with Not_found -> assert false in - let _,arsort = get_arity indf in - let nparams = mis_nparams (fst (dest_ind_family indf)) in + let (mib,mip) = lookup_mind_specif env ind in + let _,arsort = get_arity env indf in + let nparams = mip.mind_nparams in let (cnum_nlams,cnum_env,kont) = descend_then sigma env c cnum in let newc = mkRel(cnum_nlams-(argnum-nparams)) in let subval = build_discriminator sigma cnum_env dirn newc sort l in @@ -489,7 +496,8 @@ let gen_absurdity id gl = let discrimination_pf e (t,t1,t2) discriminator lbeq gls = let env = pf_env gls in let (indt,_) = find_mrectype env (project gls) t in - let aritysort = mis_sort (Global.lookup_mind_specif indt) in + let (mib,mip) = lookup_mind_specif env indt in + let aritysort = mip.mind_sort in let sort = pf_type_of gls (pf_concl gls) in match necessary_elimination aritysort (destSort sort) with | Type_Type -> @@ -530,7 +538,7 @@ let discr id gls = errorlabstrm "discr" [< 'sTR" Not a discriminable equality" >] | Inl (cpath, (_,dirn), _) -> let e = pf_get_new_id (id_of_string "ee") gls in - let e_env = push_named_assum (e,t) env in + let e_env = push_named_decl (e,None,t) env in let discriminator = build_discriminator sigma e_env dirn (mkVar e) sort cpath in let (indt,_) = find_mrectype env sigma t in @@ -601,7 +609,7 @@ let make_tuple env sigma (prev_lind,rterm,rty) lind = let {intro = exist_term; typ = sig_term} = find_sigma_data (get_sort_of env sigma rty) in let a = type_of env sigma (mkRel lind) in - let na = fst (lookup_rel_type lind env) in + let (na,_,_) = lookup_rel lind env in (* If [lind] is not [prev_lind+1] then we lift down rty *) let rty = lift (- lind + prev_lind + 1) rty in (* Now [lind] is [mkRel 1] and we abstract on (na:a) *) @@ -729,7 +737,8 @@ let rec build_injrec sigma env (t1,t2) c = function | ((sp,cnum),argnum)::l -> let cty = type_of env sigma c in let (ity,_) = find_mrectype env sigma cty in - let nparams = Global.mind_nparams ity in + let (mib,mip) = lookup_mind_specif env ity in + let nparams = mip.mind_nparams in let (cnum_nlams,cnum_env,kont) = descend_then sigma env c cnum in let newc = mkRel(cnum_nlams-(argnum-nparams)) in let (subval,tuplety,dfltval) = @@ -746,9 +755,9 @@ let try_delta_expand env sigma t = let whdt = whd_betadeltaiota env sigma t in let rec hd_rec c = match kind_of_term c with - | IsMutConstruct _ -> whdt - | IsApp (f,_) -> hd_rec f - | IsCast (c,_) -> hd_rec c + | Construct _ -> whdt + | App (f,_) -> hd_rec f + | Cast (c,_) -> hd_rec c | _ -> t in hd_rec whdt @@ -778,7 +787,7 @@ let inj id gls = [<'sTR"Nothing to do, it is an equality between convertible terms">] | Inr posns -> let e = pf_get_new_id (id_of_string "e") gls in - let e_env = push_named_assum (e,t) env in + let e_env = push_named_decl (e,None,t) env in let injectors = map_succeed (fun (cpath,t1_0,t2_0) -> @@ -832,7 +841,7 @@ let decompEqThen ntac id gls = (match find_positions env sigma t1 t2 with | Inl (cpath, (_,dirn), _) -> let e = pf_get_new_id (id_of_string "e") gls in - let e_env = push_named_assum (e,t) env in + let e_env = push_named_decl (e,None,t) env in let discriminator = build_discriminator sigma e_env dirn (mkVar e) sort cpath in let (pf, absurd_term) = @@ -846,7 +855,7 @@ let decompEqThen ntac id gls = [<'sTR"Nothing to do, it is an equality between convertible terms">] | Inr posns -> (let e = pf_get_new_id (id_of_string "e") gls in - let e_env = push_named_assum (e,t) env in + let e_env = push_named_decl (e,None,t) env in let injectors = map_succeed (fun (cpath,t1_0,t2_0) -> @@ -924,8 +933,8 @@ let swapEquandsInHyp id gls = let find_elim sort_of_gl lbeq = match kind_of_term sort_of_gl with - | IsSort(Prop Null) (* Prop *) -> (lbeq.ind (), false) - | IsSort(Prop Pos) (* Set *) -> + | Sort(Prop Null) (* Prop *) -> (lbeq.ind (), false) + | Sort(Prop Pos) (* Set *) -> (match lbeq.rrec with | Some eq_rec -> (eq_rec (), false) | None -> errorlabstrm "find_elim" @@ -1097,54 +1106,25 @@ let rec list_int n cmr l = (* Tells if two constrs are equal modulo unification *) -(* Alpha-conversion *) -let bind_eq = function - | (Anonymous,Anonymous) -> true - | (Name _,Name _) -> true - | _ -> false - -(* TODO: Fix and CoFix also contain bound names *) -let eqop_mod_names = function - | OpLambda n0, OpLambda n1 -> bind_eq (n0,n1) - | OpProd n0, OpProd n1 -> bind_eq (n0,n1) - | OpLetIn n0, OpLetIn n1 -> bind_eq (n0,n1) - | op0, op1 -> op0 = op1 - exception NotEqModRel -let rec eq_mod_rel l_meta t0 t1 = - match splay_constr_with_binders t1 with - | OpMeta n, [], [||] -> - if not (List.mem_assoc n l_meta) then - [(n,t0)]@l_meta - else if (List.assoc n l_meta) = t0 then - l_meta - else - raise NotEqModRel - | op1, bd1, v1 -> - match splay_constr_with_binders t0 with - | op0, bd0, v0 - when (eqop_mod_names (op0, op1) - & (List.length bd0 = List.length bd1) - & (Array.length v0 = Array.length v1)) -> - array_fold_left2 eq_mod_rel - (List.fold_left2 eq_mod_rel_binders l_meta bd0 bd1) - v0 v1 - | _ -> raise NotEqModRel - - and eq_mod_rel_binders l_meta t0 t1 = match (t0,t1) with - | (na0,Some b0,t0), (na1,Some b1,t1) when bind_eq (na0,na1) -> - eq_mod_rel (eq_mod_rel l_meta b0 b1) t0 t1 - | (na0,None,t0), (na1,None,t1) when bind_eq (na0,na1) -> - eq_mod_rel l_meta t0 t1 - | _ -> raise NotEqModRel +let eq_mod_rel l_meta t0 t1 = + let bindings = ref l_meta in + let rec eq_rec t0 t1 = + match kind_of_term t1 with + | Meta n -> + if not (List.mem_assoc n !bindings) then + (bindings := (n,t0) :: !bindings; true) + else (List.assoc n l_meta) = t0 + | _ -> compare_constr eq_rec t0 t1 in + if eq_rec t0 t1 then !bindings else raise NotEqModRel (* Verifies if the constr has an head constant *) let is_hd_const c = match kind_of_term c with - | IsApp (f,args) -> + | App (f,args) -> (match kind_of_term f with - | IsConst c -> Some (c, args) + | Const c -> Some (c, args) |_ -> None) | _ -> None @@ -1154,10 +1134,10 @@ let is_hd_const c = match kind_of_term c with let nb_occ_term t u = let rec nbrec nocc u = - if t = u then (* Pourquoi pas eq_constr ?? *) + if eq_constr t u then nocc + 1 else - Array.fold_left nbrec nocc (snd (splay_constr u)) + fold_constr nbrec nocc u in nbrec 0 u @@ -1166,35 +1146,24 @@ let nb_occ_term t u = Rem: t_eq is assumed closed then there is no need to lift it *) let sub_term_with_unif cref ceq = - let rec find_match l_meta nb_occ hdsp t_args u = match splay_constr u with - | OpApp, cl -> begin - let f, args = destApplication u in - match kind_of_term f with - | IsConst sp when sp = hdsp -> begin + let rec find_match hdsp t_args (l_meta,nb_occ) u = + match kind_of_term u with + | App(f,args) -> + (match kind_of_term f with + | Const sp when sp = hdsp -> begin try (array_fold_left2 eq_mod_rel l_meta args t_args, nb_occ+1) with NotEqModRel -> - Array.fold_left - (fun (l_meta,nb_occ) x -> find_match l_meta nb_occ - hdsp t_args x) (l_meta,nb_occ) args + Array.fold_left (find_match hdsp t_args) (l_meta,nb_occ) args end - | IsConst _ | IsVar _ | IsMutInd _ | IsMutConstruct _ - | IsFix _ | IsCoFix _ -> - Array.fold_left - (fun (l_meta,nb_occ) x -> find_match l_meta - nb_occ hdsp t_args x) (l_meta,nb_occ) cl + | (Const _ | Var _ | Ind _ | Construct _ | Fix _ | CoFix _) -> + fold_constr (find_match hdsp t_args) (l_meta,nb_occ) u (* Pourquoi ne récurre-t-on pas dans f ? *) - | _ -> (l_meta,nb_occ) - end + | _ -> (l_meta,nb_occ)) -(* Le code original ne récurrait pas sous les Cast - | OpCast, _ -> (l_meta,nb_occ) -*) - | _, t -> - Array.fold_left - (fun (l_meta,nb_occ) x -> find_match l_meta nb_occ hdsp t_args x) - (l_meta,nb_occ) t + | _ -> + fold_constr (find_match hdsp t_args) (l_meta,nb_occ) u in match (is_hd_const ceq) with @@ -1208,7 +1177,7 @@ let sub_term_with_unif cref ceq = else Some (ceq,nb_occ) |Some (head,t_args) -> - let (l,nb) = find_match [] 0 head t_args cref in + let (l,nb) = find_match head t_args ([],0) cref in if nb = 0 then None else diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml index a3bdf52b9..e6def959b 100644 --- a/tactics/hipattern.ml +++ b/tactics/hipattern.ml @@ -11,15 +11,18 @@ open Pp open Util open Names +open Nameops open Term -open Reduction -open Inductive +open Termops +open Reductionops +open Inductiveops open Evd open Environ open Proof_trees open Clenv open Pattern open Coqlib +open Declarations (* I implemented the following functions which test whether a term t is an inductive but non-recursive type, a general conjuction, a @@ -39,11 +42,11 @@ let op2bool = function Some _ -> true | None -> false let match_with_non_recursive_type t = match kind_of_term t with - | IsApp _ -> - let (hdapp,args) = decomp_app t in + | App _ -> + let (hdapp,args) = decompose_app t in (match kind_of_term hdapp with - | IsMutInd ind -> - if not (Global.mind_is_recursive ind) then + | Ind ind -> + if not (Global.lookup_mind (fst ind)).mind_finite then Some (hdapp,args) else None @@ -56,12 +59,13 @@ let is_non_recursive_type t = op2bool (match_with_non_recursive_type t) only one constructor. *) let match_with_conjunction t = - let (hdapp,args) = decomp_app t in + let (hdapp,args) = decompose_app t in match kind_of_term hdapp with - | IsMutInd ind -> - let mispec = Global.lookup_mind_specif ind in - if (mis_nconstr mispec = 1) - && (not (mis_is_recursive mispec)) && (mis_nrealargs mispec = 0) + | Ind ind -> + let (mib,mip) = Global.lookup_inductive ind in + if (Array.length mip.mind_consnames = 1) + && (not (mis_is_recursive (mib,mip))) + && (mip.mind_nrealargs = 0) then Some (hdapp,args) else @@ -74,15 +78,15 @@ let is_conjunction t = op2bool (match_with_conjunction t) whose constructors have a single argument. *) let match_with_disjunction t = - let (hdapp,args) = decomp_app t in + let (hdapp,args) = decompose_app t in match kind_of_term hdapp with - | IsMutInd ind -> - let mispec = Global.lookup_mind_specif ind in - let constr_types = mis_nf_lc mispec in + | Ind ind -> + let (mib,mip) = Global.lookup_inductive ind in + let constr_types = mip.mind_nf_lc in let only_one_arg c = - ((nb_prod c) - (mis_nparams mispec)) = 1 in + ((nb_prod c) - mip.mind_nparams) = 1 in if (array_for_all only_one_arg constr_types) && - (not (mis_is_recursive mispec)) + (not (mis_is_recursive (mib,mip))) then Some (hdapp,args) else @@ -92,22 +96,25 @@ let match_with_disjunction t = let is_disjunction t = op2bool (match_with_disjunction t) let match_with_empty_type t = - let (hdapp,args) = decomp_app t in + let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with - | IsMutInd ind -> - let nconstr = Global.mind_nconstr ind in + | Ind ind -> + let (mib,mip) = Global.lookup_inductive ind in + let nconstr = Array.length mip.mind_consnames in if nconstr = 0 then Some hdapp else None | _ -> None let is_empty_type t = op2bool (match_with_empty_type t) let match_with_unit_type t = - let (hdapp,args) = decomp_app t in + let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with - | IsMutInd ind -> - let constr_types = Global.mind_nf_lc ind in - let nconstr = Global.mind_nconstr ind in - let zero_args c = nb_prod c = Global.mind_nparams ind in + | Ind ind -> + let (mib,mip) = Global.lookup_inductive ind in + let constr_types = mip.mind_nf_lc in + let nconstr = Array.length mip.mind_consnames in + let zero_args c = + nb_prod c = mip.mind_nparams in if nconstr = 1 && array_for_all zero_args constr_types then Some hdapp else @@ -122,11 +129,12 @@ let is_unit_type t = op2bool (match_with_unit_type t) establishing its reflexivity. *) let match_with_equation t = - let (hdapp,args) = decomp_app t in + let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with - | IsMutInd ind -> - let constr_types = Global.mind_nf_lc ind in - let nconstr = Global.mind_nconstr ind in + | Ind ind -> + let (mib,mip) = Global.lookup_inductive ind in + let constr_types = mip.mind_nf_lc in + let nconstr = Array.length mip.mind_consnames in if nconstr = 1 && (is_matching (build_coq_refl_rel1_pattern ()) constr_types.(0) || is_matching (build_coq_refl_rel1_pattern ()) constr_types.(0)) @@ -149,7 +157,7 @@ let match_with_nottype t = let is_nottype t = op2bool (match_with_nottype t) let is_imp_term c = match kind_of_term c with - | IsProd (_,_,b) -> not (dependent (mkRel 1) b) + | Prod (_,_,b) -> not (dependent (mkRel 1) b) | _ -> false diff --git a/tactics/inv.ml b/tactics/inv.ml index 15e8ee6b3..c8da9ed1d 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -12,12 +12,13 @@ open Pp open Util open Names open Term +open Termops open Global open Sign open Environ -open Inductive +open Inductiveops open Printer -open Reduction +open Reductionops open Retyping open Tacmach open Proof_type @@ -88,7 +89,7 @@ let make_inv_predicate env sigma ind id status concl = match status with | NoDep -> (* We push the arity and leave concl unchanged *) - let hyps_arity,_ = get_arity indf in + let hyps_arity,_ = get_arity env indf in (hyps_arity,concl) | Dep dflt_concl -> if not (dependent (mkVar id) concl) then @@ -188,7 +189,7 @@ let rec dependent_hyps id idlist sign = let rec dep_rec =function | [] -> [] | (id1::l) -> - let id1ty = snd (lookup_named id1 sign) in + let (_,_,id1ty) = lookup_named id1 sign in if occur_var (Global.env()) id (body_of_type id1ty) then id1::dep_rec l else dep_rec l @@ -233,21 +234,21 @@ let projectAndApply thin id depids gls = let (t,t1,t2) = dest_eq gls (pf_get_hyp_typ gls id) in match (kind_of_term (strip_outer_cast t1), kind_of_term (strip_outer_cast t2)) with - | IsVar id1, _ -> generalizeRewriteIntros (subst_hyp_LR id) depids id1 - | _, IsVar id2 -> generalizeRewriteIntros (subst_hyp_RL id) depids id2 + | Var id1, _ -> generalizeRewriteIntros (subst_hyp_LR id) depids id1 + | _, Var id2 -> generalizeRewriteIntros (subst_hyp_RL id) depids id2 | _ -> subst_hyp_RL id in onLastHyp orient_rule gls in let (t,t1,t2) = dest_eq gls (pf_get_hyp_typ gls id) in match (thin, kind_of_term (strip_outer_cast t1), kind_of_term (strip_outer_cast t2)) with - | (true, IsVar id1, _) -> generalizeRewriteIntros + | (true, Var id1, _) -> generalizeRewriteIntros (tclTHEN (subst_hyp_LR id) (clear_clause id)) depids id1 gls - | (false, IsVar id1, _) -> + | (false, Var id1, _) -> generalizeRewriteIntros (subst_hyp_LR id) depids id1 gls - | (true, _ , IsVar id2) -> generalizeRewriteIntros + | (true, _ , Var id2) -> generalizeRewriteIntros (tclTHEN (subst_hyp_RL id) (clear_clause id)) depids id2 gls - | (false, _ , IsVar id2) -> + | (false, _ , Var id2) -> generalizeRewriteIntros (subst_hyp_RL id) depids id2 gls | (true, _, _) -> let deq_trailer neqns = @@ -323,7 +324,7 @@ let case_trailer othin neqns ba gl = let collect_meta_variables c = let rec collrec acc c = match kind_of_term c with - | IsMeta mv -> mv::acc + | Meta mv -> mv::acc | _ -> fold_constr collrec acc c in collrec [] c diff --git a/tactics/leminv.ml b/tactics/leminv.ml index f6b2ba06f..ab0590a71 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -11,13 +11,15 @@ open Pp open Util open Names +open Nameops open Term +open Termops open Sign open Evd open Printer -open Reduction +open Reductionops open Declarations -open Inductive +open Inductiveops open Environ open Tacmach open Proof_trees @@ -30,6 +32,7 @@ open Wcclausenv open Tacticals open Tactics open Inv +open Safe_typing let not_work_message = "tactic fails to build the inversion lemma, may be because the predicate has arguments that depend on other arguments" @@ -131,14 +134,14 @@ let max_prefix_sign lid sign = *) let rec add_prods_sign env sigma t = match kind_of_term (whd_betadeltaiota env sigma t) with - | IsProd (na,c1,b) -> - let id = Environ.id_of_name_using_hdchar env t na in + | Prod (na,c1,b) -> + let id = id_of_name_using_hdchar env t na in let b'= subst1 (mkVar id) b in - add_prods_sign (Environ.push_named_assum (id,c1) env) sigma b' - | IsLetIn (na,c1,t1,b) -> - let id = Environ.id_of_name_using_hdchar env t na in + add_prods_sign (push_named_decl (id,None,c1) env) sigma b' + | LetIn (na,c1,t1,b) -> + let id = id_of_name_using_hdchar env t na in let b'= subst1 (mkVar id) b in - add_prods_sign (Environ.push_named_def (id,c1,t1) env) sigma b' + add_prods_sign (push_named_decl (id,Some c1,t1) env) sigma b' | _ -> (env,t) (* [dep_option] indicates wether the inversion lemma is dependent or not. @@ -180,7 +183,7 @@ let compute_first_inversion_scheme env sigma ind sort dep_option = (pty,goal) in let npty = nf_betadeltaiota env sigma pty in - let extenv = push_named_assum (p,npty) env in + let extenv = push_named_decl (p,None,npty) env in extenv, goal (* [inversion_scheme sign I] @@ -224,7 +227,7 @@ let inversion_scheme env sigma t sort dep_option inv_op = List.fold_left (fun (avoid,sign,mvb) (mv,mvty) -> let h = next_ident_away (id_of_string "H") avoid in - (h::avoid, add_named_assum (h,mvty) sign, (mv,mkVar h)::mvb)) + (h::avoid, add_named_decl (h,None,mvty) sign, (mv,mkVar h)::mvb)) (ids_of_context invEnv, ownSign, []) meta_types in @@ -271,7 +274,7 @@ let _ = (function | [VARG_NUMBER n; VARG_IDENTIFIER na; VARG_IDENTIFIER id] -> fun () -> - inversion_lemma_from_goal n na id prop false inv_clear_tac + inversion_lemma_from_goal n na id mk_Prop false inv_clear_tac | _ -> bad_vernac_args "MakeInversionLemmaFromHyp") let add_inversion_lemma_exn na com comsort bool tac = @@ -299,7 +302,7 @@ let _ = (function | [VARG_NUMBER n; VARG_IDENTIFIER na; VARG_IDENTIFIER id] -> fun () -> - inversion_lemma_from_goal n na id prop false half_inv_tac + inversion_lemma_from_goal n na id mk_Prop false half_inv_tac | _ -> bad_vernac_args "MakeSemiInversionLemmaFromHyp") let _ = diff --git a/tactics/refine.ml b/tactics/refine.ml index 6fdc75ae4..366611d43 100644 --- a/tactics/refine.ml +++ b/tactics/refine.ml @@ -50,6 +50,7 @@ open Pp open Util open Names open Term +open Termops open Tacmach open Sign open Environ @@ -97,14 +98,14 @@ let replace_by_meta env = function let m = mkMeta n in (* quand on introduit une mv on calcule son type *) let ty = match kind_of_term c with - | IsLambda (Name id,c1,c2) when isCast c2 -> + | Lambda (Name id,c1,c2) when isCast c2 -> mkNamedProd id c1 (snd (destCast c2)) - | IsLambda (Anonymous,c1,c2) when isCast c2 -> + | Lambda (Anonymous,c1,c2) when isCast c2 -> mkArrow c1 (snd (destCast c2)) - | _ -> (* (IsApp _ | IsMutCase _) -> *) + | _ -> (* (App _ | Case _) -> *) Retyping.get_type_of_with_meta env Evd.empty mm c (* - | IsFix ((_,j),(v,_,_)) -> + | Fix ((_,j),(v,_,_)) -> v.(j) (* en pleine confiance ! *) | _ -> invalid_arg "Tcc.replace_by_meta (TO DO)" *) @@ -131,25 +132,25 @@ let fresh env n = let rec compute_metamap env c = match kind_of_term c with (* le terme est directement une preuve *) - | (IsConst _ | IsEvar _ | IsMutInd _ | IsMutConstruct _ | - IsSort _ | IsVar _ | IsRel _) -> + | (Const _ | Evar _ | Ind _ | Construct _ | + Sort _ | Var _ | Rel _) -> TH (c,[],[]) (* le terme est une mv => un but *) - | IsMeta n -> + | Meta n -> (* Pp.warning (Printf.sprintf ("compute_metamap: MV(%d) sans type !\n") n); let ty = Retyping.get_type_of_with_meta env Evd.empty lmeta c in *) TH (c,[],[None]) - | IsCast (m,ty) when isMeta m -> + | Cast (m,ty) when isMeta m -> TH (c,[destMeta m,ty],[None]) (* abstraction => il faut décomposer si le terme dessous n'est pas pur * attention : dans ce cas il faut remplacer (Rel 1) par (Var x) * oů x est une variable FRAICHE *) - | IsLambda (name,c1,c2) -> + | Lambda (name,c1,c2) -> let v = fresh env name in - let env' = push_named_assum (v,c1) env in + let env' = push_named_decl (v,None,c1) env in begin match compute_metamap env' (subst1 (mkVar v) c2) with (* terme de preuve complet *) | TH (_,_,[]) -> TH (c,[],[]) @@ -159,11 +160,11 @@ let rec compute_metamap env c = match kind_of_term c with TH (mkLambda (Name v,c1,m), mm, sgp) end - | IsLetIn (name, c1, t1, c2) -> + | LetIn (name, c1, t1, c2) -> if occur_meta c1 then error "Refine: body of let-in cannot contain existentials"; let v = fresh env name in - let env' = push_named_def (v,c1,t1) env in + let env' = push_named_decl (v,Some c1,t1) env in begin match compute_metamap env' (subst1 (mkVar v) c2) with (* terme de preuve complet *) | TH (_,_,[]) -> TH (c,[],[]) @@ -174,16 +175,18 @@ let rec compute_metamap env c = match kind_of_term c with end (* 4. Application *) - | IsApp (f,v) -> + | App (f,v) -> let a = Array.map (compute_metamap env) (Array.append [|f|] v) in begin try - let v',mm,sgp = replace_in_array env a in TH (mkAppA v',mm,sgp) + let v',mm,sgp = replace_in_array env a in + let v'' = Array.sub v' 1 (Array.length v) in + TH (mkApp(v'.(0), v''),mm,sgp) with NoMeta -> TH (c,[],[]) end - | IsMutCase (ci,p,c,v) -> + | Case (ci,p,c,v) -> (* bof... *) let nbr = Array.length v in let v = Array.append [|p;c|] v in @@ -192,13 +195,13 @@ let rec compute_metamap env c = match kind_of_term c with try let v',mm,sgp = replace_in_array env a in let v'' = Array.sub v' 2 nbr in - TH (mkMutCase (ci,v'.(0),v'.(1),v''),mm,sgp) + TH (mkCase (ci,v'.(0),v'.(1),v''),mm,sgp) with NoMeta -> TH (c,[],[]) end (* 5. Fix. *) - | IsFix ((ni,i),(fi,ai,v)) -> + | Fix ((ni,i),(fi,ai,v)) -> (* TODO: use a fold *) let vi = Array.map (fresh env) fi in let fi' = Array.map (fun id -> Name id) vi in @@ -217,19 +220,19 @@ let rec compute_metamap env c = match kind_of_term c with end (* Cast. Est-ce bien exact ? *) - | IsCast (c,t) -> compute_metamap env c + | Cast (c,t) -> compute_metamap env c (*let TH (c',mm,sgp) = compute_metamap sign c in TH (mkCast (c',t),mm,sgp) *) (* Produit. Est-ce bien exact ? *) - | IsProd (_,_,_) -> + | Prod (_,_,_) -> if occur_meta c then error "Refine: proof term contains metas in a product" else TH (c,[],[]) (* Cofix. *) - | IsCoFix (i,(fi,ai,v)) -> + | CoFix (i,(fi,ai,v)) -> let vi = Array.map (fresh env) fi in let fi' = Array.map (fun id -> Name id) vi in let env' = push_named_rec_types (fi',ai,v) env in @@ -255,10 +258,10 @@ let rec compute_metamap env c = match kind_of_term c with let rec tcc_aux (TH (c,mm,sgp) as th) gl = match (kind_of_term c,sgp) with (* mv => sous-but : on ne fait rien *) - | IsMeta _ , _ -> + | Meta _ , _ -> tclIDTAC gl - | IsCast (c,_), _ when isMeta c -> + | Cast (c,_), _ when isMeta c -> tclIDTAC gl (* terme pur => refine *) @@ -266,18 +269,18 @@ let rec tcc_aux (TH (c,mm,sgp) as th) gl = refine c gl (* abstraction => intro *) - | IsLambda (Name id,_,m), _ when isMeta (strip_outer_cast m) -> + | Lambda (Name id,_,m), _ when isMeta (strip_outer_cast m) -> begin match sgp with | [None] -> introduction id gl | [Some th] -> tclTHEN (introduction id) (tcc_aux th) gl | _ -> assert false end - | IsLambda _, _ -> + | Lambda _, _ -> anomaly "invalid lambda passed to function tcc_aux" (* let in *) - | IsLetIn (Name id,c1,t1,c2), _ when isMeta (strip_outer_cast c2) -> + | LetIn (Name id,c1,t1,c2), _ when isMeta (strip_outer_cast c2) -> let c = pf_concl gl in let newc = mkNamedLetIn id c1 t1 c in tclTHEN @@ -288,11 +291,11 @@ let rec tcc_aux (TH (c,mm,sgp) as th) gl = | _ -> assert false) gl - | IsLetIn _, _ -> + | LetIn _, _ -> anomaly "invalid let-in passed to function tcc_aux" (* fix => tactique Fix *) - | IsFix ((ni,_),(fi,ai,_)) , _ -> + | Fix ((ni,_),(fi,ai,_)) , _ -> let ids = Array.to_list (Array.map @@ -309,7 +312,7 @@ let rec tcc_aux (TH (c,mm,sgp) as th) gl = gl (* cofix => tactique CoFix *) - | IsCoFix (_,(fi,ai,_)) , _ -> + | CoFix (_,(fi,ai,_)) , _ -> let ids = Array.to_list (Array.map diff --git a/tactics/setoid_replace.ml b/tactics/setoid_replace.ml index ea9e9d104..f83436e16 100644 --- a/tactics/setoid_replace.ml +++ b/tactics/setoid_replace.ml @@ -11,9 +11,11 @@ open Tacmach open Proof_type open Libobject -open Reduction +open Reductionops open Term +open Termops open Names +open Nameops open Util open Pp open Printer @@ -22,6 +24,8 @@ open Environ open Termast open Command open Tactics +open Safe_typing +open Nametab type setoid = { set_a : constr; @@ -39,7 +43,8 @@ type morphism = let constr_of c = Astterm.interp_constr Evd.empty (Global.env()) c let constant dir s = - let dir = make_dirpath (List.map id_of_string ("Coq"::"Setoids"::dir)) in + let dir = make_dirpath + (List.map id_of_string (List.rev ("Coq"::"Setoids"::dir))) in let id = id_of_string s in try Declare.global_reference_in_absolute_module dir id @@ -47,7 +52,8 @@ let constant dir s = anomaly ("Setoid: cannot find "^(Nametab.string_of_qualid (Nametab.make_qualid dir id))) let global_constant dir s = - let dir = make_dirpath (List.map id_of_string ("Coq"::"Init"::dir)) in + let dir = make_dirpath + (List.map id_of_string (List.rev ("Coq"::"Init"::dir))) in let id = id_of_string s in try Declare.global_reference_in_absolute_module dir id @@ -228,14 +234,14 @@ let add_setoid a aeq th = let eq_ext_name = gen_eq_lem_name () in let eq_ext_name2 = gen_eq_lem_name () in let _ = Declare.declare_constant eq_ext_name - ((Declare.ConstantEntry {Declarations.const_entry_body = eq_morph; - Declarations.const_entry_type = None; - Declarations.const_entry_opaque = true}), + ((Declare.ConstantEntry {const_entry_body = eq_morph; + const_entry_type = None; + const_entry_opaque = true}), Declare.NeverDischarge) in let _ = Declare.declare_constant eq_ext_name2 - ((Declare.ConstantEntry {Declarations.const_entry_body = eq_morph2; - Declarations.const_entry_type = None; - Declarations.const_entry_opaque = true}), + ((Declare.ConstantEntry {const_entry_body = eq_morph2; + const_entry_type = None; + const_entry_opaque = true}), Declare.NeverDischarge) in let eqmorph = (current_constant eq_ext_name) in let eqmorph2 = (current_constant eq_ext_name2) in @@ -291,10 +297,10 @@ let check_is_dependent t n = in aux t 0 n let gen_lem_name m = match kind_of_term m with - | IsVar id -> add_suffix id "_ext" - | IsConst sp -> add_suffix (basename sp) "_ext" - | IsMutInd (sp, i) -> add_suffix (basename sp) ((string_of_int i)^"_ext") - | IsMutConstruct ((sp,i),j) -> add_suffix + | Var id -> add_suffix id "_ext" + | Const sp -> add_suffix (basename sp) "_ext" + | Ind (sp, i) -> add_suffix (basename sp) ((string_of_int i)^"_ext") + | Construct ((sp,i),j) -> add_suffix (basename sp) ((string_of_int i)^(string_of_int i)^"_ext") | _ -> errorlabstrm "New Morphism" [< 'sTR "The term "; prterm m; 'sTR "is not a known name">] @@ -453,9 +459,9 @@ let add_morphism lem_name (m,profil) = (let lem_2 = gen_lem_iff env m mext args_t poss in let lem2_name = add_suffix lem_name "2" in let _ = Declare.declare_constant lem2_name - ((Declare.ConstantEntry {Declarations.const_entry_body = lem_2; - Declarations.const_entry_type = None; - Declarations.const_entry_opaque = true}), + ((Declare.ConstantEntry {const_entry_body = lem_2; + const_entry_type = None; + const_entry_opaque = true}), Declare.NeverDischarge) in let lem2 = (current_constant lem2_name) in (Lib.add_anonymous_leaf @@ -542,10 +548,10 @@ let get_mark a = let rec mark_occur t in_c = if (eq_constr t in_c) then Toreplace else match kind_of_term in_c with - | IsApp (c,al) -> + | App (c,al) -> let a = Array.map (mark_occur t) al in if (get_mark a) then (MApp a) else Tokeep - | IsProd (_, c1, c2) -> + | Prod (_, c1, c2) -> if (dependent (mkRel 1) c2) then Tokeep else @@ -599,7 +605,7 @@ let rec create_tac_list i a al c1 c2 hyp args_t = function (* else tclIDTAC::(create_tac_list (i+1) a al c1 c2 hyp q) *) and zapply is_r gl gl_m c1 c2 hyp glll = (match ((kind_of_term gl), gl_m) with - | ((IsApp (c,al)),(MApp a)) -> ( + | ((App (c,al)),(MApp a)) -> ( try let m = morphism_table_find c in let args = Array.of_list (create_args al a m.profil c1 c2) in @@ -613,7 +619,7 @@ and zapply is_r gl gl_m c1 c2 hyp glll = (match ((kind_of_term gl), gl_m) with tclTHENS (apply (mkApp (xom, args))) (create_tac_list 0 a al c1 c2 hyp m.arg_types m.profil)) with Not_found -> errorlabstrm "Setoid_replace" [< 'sTR "The term "; prterm c; 'sTR " has not been declared as a morphism">]) - | ((IsProd (_,hh, cc)),(Mimp (hhm, ccm))) -> + | ((Prod (_,hh, cc)),(Mimp (hhm, ccm))) -> let al = [|hh; cc|] in let a = [|hhm; ccm|] in let fleche_constr = (Lazy.force coq_fleche) in @@ -649,7 +655,7 @@ let setoid_replace c1 c2 hyp gl = let general_s_rewrite lft2rgt c gl = let ctype = pf_type_of gl c in - let (equiv, args) = decomp_app ctype in + let (equiv, args) = decompose_app ctype in let rec get_last_two = function | [c1;c2] -> (c1, c2) | x::y::z -> get_last_two (y::z) diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index d9919b7e0..b71f7ab2a 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -12,6 +12,7 @@ open Pp open Util open Names open Term +open Termops open Sign open Declarations open Inductive @@ -272,13 +273,13 @@ let reduce_to_ind_goal gl t = let rec elimrec t = let c,args = decomp_app t in match kind_of_term c with - | IsMutInd (ind_sp,args as ity) -> + | Ind (ind_sp,args as ity) -> ((ity, path_of_inductive_path ind_sp, t), t) - | IsCast (c,_) when args = [] -> + | Cast (c,_) when args = [] -> elimrec c - | IsProd (n,ty,t') when args = [] -> + | Prod (n,ty,t') when args = [] -> let (ind, t) = elimrec t' in (ind, mkProd (n,ty,t)) - | IsLetIn (n,c,ty,t') when args = [] -> + | LetIn (n,c,ty,t') when args = [] -> let (ind, t) = elimrec t' in (ind, mkLetIn (n,c,ty,t)) | _ when Instantiate.isEvalRef c -> elimrec (pf_nf_betaiota gl (pf_one_step_reduce gl t)) @@ -294,7 +295,8 @@ let case_sign ity i = | [] -> acc | (c::rest) -> analrec (false::acc) rest in - let recarg = mis_recarg (lookup_mind_specif ity (Global.env())) in + let (mib,mip) = Global.lookup_inductive ity in + let recarg = mip.mind_listrec in analrec [] recarg.(i-1) let elim_sign ity i = @@ -306,12 +308,13 @@ let elim_sign ity i = | (Mrec k::rest) -> analrec ((j=k)::acc) rest | [] -> List.rev acc in - let recarg = mis_recarg (lookup_mind_specif ity (Global.env())) in + let (mib,mip) = Global.lookup_inductive ity in + let recarg = mip.mind_listrec in analrec [] recarg.(i-1) let elimination_sort_of_goal gl = match kind_of_term (hnf_type_of gl (pf_concl gl)) with - | IsSort s -> + | Sort s -> (match s with | Prop Null -> InProp | Prop Pos -> InSet @@ -323,7 +326,7 @@ let elimination_sort_of_goal gl = (* c should be of type A1->.. An->B with B an inductive definition *) let last_arg c = match kind_of_term c with - | IsApp (f,cl) -> array_last cl + | App (f,cl) -> array_last cl | _ -> anomaly "last_arg" let general_elim_then_using @@ -336,18 +339,18 @@ let general_elim_then_using let elimclause = mk_clenv_from () (elim,w_type_of wc elim) in let indmv = match kind_of_term (last_arg (clenv_template elimclause).rebus) with - | IsMeta mv -> mv + | Meta mv -> mv | _ -> error "elimination" in let pmv = - let p, _ = decomp_app (clenv_template_type elimclause).rebus in + let p, _ = decompose_app (clenv_template_type elimclause).rebus in match kind_of_term p with - | IsMeta p -> p + | Meta p -> p | _ -> let name_elim = match kind_of_term elim with - | IsConst sp -> string_of_path sp - | IsVar id -> string_of_id id + | Const sp -> string_of_path sp + | Var id -> string_of_id id | _ -> "\b" in error ("The elimination combinator " ^ name_elim ^ " is not known") @@ -355,7 +358,7 @@ let general_elim_then_using let elimclause' = clenv_fchain indmv elimclause indclause' in let elimclause' = clenv_constrain_with_bindings elimbindings elimclause' in let after_tac ce i gl = - let (hd,largs) = decomp_app (clenv_template_type ce).rebus in + let (hd,largs) = decompose_app (clenv_template_type ce).rebus in let branchsign = elim_sign_fun ity i in let ba = { branchsign = branchsign; nassums = @@ -378,7 +381,8 @@ let general_elim_then_using let elimination_then_using tac predicate (indbindings,elimbindings) c gl = let (ind,t) = reduce_to_ind_goal gl (pf_type_of gl c) in - let elim = lookup_eliminator (pf_env gl) ind (elimination_sort_of_goal gl) in + let elim = + Indrec.lookup_eliminator ind (elimination_sort_of_goal gl) in general_elim_then_using elim elim_sign tac predicate (indbindings,elimbindings) c gl diff --git a/tactics/tactics.ml b/tactics/tactics.ml index de1893c3c..ca22b899b 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -12,10 +12,14 @@ open Pp open Util open Stamps open Names +open Nameops open Sign open Term +open Termops +open Declarations open Inductive -open Reduction +open Inductiveops +open Reductionops open Environ open Declare open Evd @@ -30,15 +34,16 @@ open Clenv open Tacticals open Hipattern open Coqlib +open Nametab exception Bound let rec nb_prod x = let rec count n c = match kind_of_term c with - IsProd(_,_,t) -> count (n+1) t - | IsLetIn(_,a,_,t) -> count n (subst1 a t) - | IsCast(c,_) -> count n c + Prod(_,_,t) -> count (n+1) t + | LetIn(_,a,_,t) -> count n (subst1 a t) + | Cast(c,_) -> count n c | _ -> n in count 0 x @@ -59,23 +64,23 @@ let get_pairs_from_bindings = let string_of_inductive c = try match kind_of_term c with - | IsMutInd ind_sp -> - let mispec = Global.lookup_mind_specif ind_sp in - string_of_id (mis_typename mispec) + | Ind ind_sp -> + let (mib,mip) = Global.lookup_inductive ind_sp in + string_of_id mip.mind_typename | _ -> raise Bound with Bound -> error "Bound head variable" let rec head_constr_bound t l = let t = strip_outer_cast(collapse_appl t) in match kind_of_term t with - | IsProd (_,_,c2) -> head_constr_bound c2 l - | IsLetIn (_,_,_,c2) -> head_constr_bound c2 l - | IsApp (f,args) -> + | Prod (_,_,c2) -> head_constr_bound c2 l + | LetIn (_,_,_,c2) -> head_constr_bound c2 l + | App (f,args) -> head_constr_bound f (Array.fold_right (fun a l -> a::l) args l) - | IsConst _ -> t::l - | IsMutInd _ -> t::l - | IsMutConstruct _ -> t::l - | IsVar _ -> t::l + | Const _ -> t::l + | Ind _ -> t::l + | Construct _ -> t::l + | Var _ -> t::l | _ -> raise Bound let head_constr c = @@ -161,7 +166,7 @@ let reduct_in_hyp redfun idref gl = let inhyp,id = match idref with | InHyp id -> true, id | InHypType id -> false, id in - let c, ty = pf_get_hyp gl id in + let (_,c, ty) = pf_get_hyp gl id in let redfun' = under_casts (pf_reduce redfun gl) in match c with | None -> convert_hyp id (redfun' ty) gl @@ -247,7 +252,7 @@ let dyn_reduce = function let unfold_constr = function | ConstRef sp -> unfold_in_concl [[],Closure.EvalConstRef sp] - | VarRef sp -> unfold_in_concl [[],Closure.EvalVarRef (basename sp)] + | VarRef id -> unfold_in_concl [[],Closure.EvalVarRef id] | _ -> errorlabstrm "unfold_constr" [< 'sTR "Cannot unfold a non-constant.">] (*******************************************) @@ -280,12 +285,12 @@ let id_of_name_with_default s = function let default_id gl = match kind_of_term (strip_outer_cast (pf_concl gl)) with - | IsProd (name,c1,c2) -> + | Prod (name,c1,c2) -> (match kind_of_term (pf_whd_betadeltaiota gl (pf_type_of gl c1)) with - | IsSort (Prop _) -> (id_of_name_with_default "H" name) - | IsSort (Type _) -> (id_of_name_with_default "X" name) + | Sort (Prop _) -> (id_of_name_with_default "H" name) + | Sort (Type _) -> (id_of_name_with_default "X" name) | _ -> anomaly "Wrong sort") - | IsLetIn (name,b,_,_) -> id_of_name_using_hdchar (pf_env gl) b name + | LetIn (name,b,_,_) -> id_of_name_using_hdchar (pf_env gl) b name | _ -> raise (RefinerError IntroNeedsProduct) (* Non primitive introduction tactics are treated by central_intro @@ -424,7 +429,7 @@ let hide_ident_or_numarg_tactic s tac = let intros_do n g = let depth = let rec lookup all nodep c = match kind_of_term c with - | IsProd (name,_,c') -> + | Prod (name,_,c') -> (match name with | Name(s') -> if dependent (mkRel 1) c' then @@ -435,7 +440,7 @@ let intros_do n g = lookup (all+1) (nodep+1) c' | Anonymous -> if nodep=n then all else lookup (all+1) (nodep+1) c') - | IsCast (c,_) -> lookup all nodep c + | Cast (c,_) -> lookup all nodep c | _ -> error "No such hypothesis in current goal" in lookup 1 1 (pf_concl g) @@ -507,7 +512,7 @@ let bring_hyps ids gl = let apply_with_bindings (c,lbind) gl = let apply = match kind_of_term c with - | IsLambda _ -> res_pf_cast + | Lambda _ -> res_pf_cast | _ -> res_pf in let (wc,kONT) = startWalk gl in @@ -566,7 +571,7 @@ let dyn_apply l = let cut_and_apply c gl = let goal_constr = pf_concl gl in match kind_of_term (pf_hnf_constr gl (pf_type_of gl c)) with - | IsProd (_,c1,c2) when not (dependent (mkRel 1) c2) -> + | Prod (_,c1,c2) when not (dependent (mkRel 1) c2) -> tclTHENS (apply_type (mkProd (Anonymous,c2,goal_constr)) [mkMeta (new_meta())]) @@ -584,12 +589,12 @@ let dyn_cut_and_apply = function let true_cut id c gl = match kind_of_term (hnf_type_of gl c) with - | IsSort _ -> internal_cut id c gl + | Sort _ -> internal_cut id c gl | _ -> error "Not a proposition or a type" let true_cut_anon c gl = match kind_of_term (hnf_type_of gl c) with - | IsSort s -> + | Sort s -> let d = match s with Prop _ -> "H" | Type _ -> "X" in let id = next_name_away_with_default d Anonymous (pf_ids_of_hyps gl) in internal_cut id c gl @@ -604,7 +609,7 @@ let dyn_true_cut = function let cut c gl = match kind_of_term (hnf_type_of gl c) with - | IsSort _ -> + | Sort _ -> let id=next_name_away_with_default "H" Anonymous (pf_ids_of_hyps gl) in let t = mkProd (Anonymous, c, pf_concl gl) in tclTHENS @@ -641,7 +646,7 @@ let cut_in_parallel l = let generalize_goal gl c cl = let t = pf_type_of gl c in match kind_of_term c with - | IsVar id -> mkNamedProd id t cl + | Var id -> mkNamedProd id t cl | _ -> let cl' = subst_term c cl in if noccurn 1 cl' then @@ -668,7 +673,7 @@ let generalize_dep c gl = let tothin = List.filter (fun id -> not (List.mem id init_ids)) qhyps in let tothin' = match kind_of_term c with - | IsVar id when mem_named_context id sign & not (List.mem id init_ids) + | Var id when mem_named_context id sign & not (List.mem id init_ids) -> id::tothin | _ -> tothin in @@ -955,7 +960,8 @@ let dyn_move_dep = function let constructor_checking_bound boundopt i lbind gl = let cl = pf_concl gl in let (mind,redcl) = pf_reduce_to_quantified_ind gl cl in - let nconstr = mis_nconstr (Global.lookup_mind_specif mind) + let nconstr = + Array.length (snd (Global.lookup_inductive mind)).mind_consnames and sigma = project gl in if i=0 then error "The constructors are numbered starting from 1"; if i > nconstr then error "Not enough constructors"; @@ -965,7 +971,7 @@ let constructor_checking_bound boundopt i lbind gl = error "Not the expected number of constructors" | None -> () end; - let cons = mkMutConstruct (ith_constructor_of_inductive mind i) in + let cons = mkConstruct (ith_constructor_of_inductive mind i) in let apply_tac = apply_with_bindings (cons,lbind) in (tclTHENLIST [convert_concl redcl; intros; apply_tac]) gl @@ -974,7 +980,8 @@ let one_constructor i = (constructor_checking_bound None i) let any_constructor gl = let cl = pf_concl gl in let (mind,redcl) = pf_reduce_to_quantified_ind gl cl in - let nconstr = mis_nconstr (Global.lookup_mind_specif mind) + let nconstr = + Array.length (snd (Global.lookup_inductive mind)).mind_consnames and sigma = project gl in if nconstr = 0 then error "The type has no constructors"; tclFIRST (List.map (fun i -> one_constructor i []) @@ -1024,13 +1031,13 @@ let dyn_split = function *) let last_arg c = match kind_of_term c with - | IsApp (f,cl) -> array_last cl + | App (f,cl) -> array_last cl | _ -> anomaly "last_arg" let elimination_clause_scheme kONT wc elimclause indclause gl = let indmv = (match kind_of_term (last_arg (clenv_template elimclause).rebus) with - | IsMeta mv -> mv + | Meta mv -> mv | _ -> errorlabstrm "elimination_clause" [< 'sTR "The type of elimination clause is not well-formed" >]) in @@ -1067,19 +1074,8 @@ let default_elim (c,lbindc) gl = let env = pf_env gl in let (ind,t) = reduce_to_quantified_ind env (project gl) (pf_type_of gl c) in let s = elimination_sort_of_goal gl in - let elimc = - try lookup_eliminator env ind s - with Not_found -> - let dir, base,k = repr_path (path_of_inductive_path ind) in - let id = make_elimination_ident base s in - errorlabstrm "default_elim" - [< 'sTR "Cannot find the elimination combinator :"; - pr_id id; 'sPC; - 'sTR "The elimination of the inductive definition :"; - pr_id base; 'sPC; 'sTR "on sort "; - 'sPC; print_sort (new_sort_in_family s) ; - 'sTR " is probably not allowed" >] - in general_elim (c,lbindc) (elimc,[]) gl + let elimc = Indrec.lookup_eliminator ind s in + general_elim (c,lbindc) (elimc,[]) gl (* The simplest elimination tactic, with no substitutions at all. *) @@ -1124,13 +1120,13 @@ comes from a canonically generated one *) let rec is_rec_arg env sigma indpath t = try let (ind_sp,_) = find_mrectype env sigma t in - Declare.path_of_inductive_path ind_sp = indpath + path_of_inductive env ind_sp = indpath with Induc -> false let rec recargs indpath env sigma t = match kind_of_term (whd_betadeltaiota env sigma t) with - | IsProd (na,t,c2) -> + | Prod (na,t,c2) -> (is_rec_arg env sigma indpath t) ::(recargs indpath (push_rel_assum (na,t) env) sigma c2) | _ -> [] @@ -1149,7 +1145,7 @@ let induct_discharge old_style mind statuslists cname destopt avoid ra gl = let hyprecname = add_prefix indhyp (if old_style || atompart_of_id recvarname <> "H" then recvarname - else mis_typename (lookup_mind_specif mind (Global.env()))) + else (snd (Global.lookup_inductive mind)).mind_typename) in let avoid = if old_style then avoid @@ -1190,10 +1186,10 @@ let induct_discharge old_style mind statuslists cname destopt avoid ra gl = let atomize_param_of_ind hyp0 gl = let tmptyp0 = pf_get_hyp_typ gl hyp0 in let (mind,typ0) = pf_reduce_to_quantified_ind gl tmptyp0 in - let mis = Global.lookup_mind_specif mind in - let nparams = mis_nparams mis in + let (mib,mip) = Global.lookup_inductive mind in + let nparams = mip.mind_nparams in let prods, indtyp = decompose_prod typ0 in - let argl = snd (decomp_app indtyp) in + let argl = snd (decompose_app indtyp) in let params = list_firstn nparams argl in (* le gl est important pour ne pas préévaluer *) let rec atomize_one i avoid gl = @@ -1202,12 +1198,12 @@ let atomize_param_of_ind hyp0 gl = (* If argl <> [], we expect typ0 not to be quantified, in order to avoid bound parameters... then we call pf_reduce_to_atomic_ind *) let (_,indtyp) = pf_reduce_to_atomic_ind gl tmptyp0 in - let argl = snd (decomp_app indtyp) in + let argl = snd (decompose_app indtyp) in let c = List.nth argl (i-1) in match kind_of_term c with - | IsVar id when not (List.exists (occur_var (pf_env gl) id) avoid) -> + | Var id when not (List.exists (occur_var (pf_env gl) id) avoid) -> atomize_one (i-1) ((mkVar id)::avoid) gl - | IsVar id -> + | Var id -> let x = fresh_id [] id gl in tclTHEN (letin_tac true (Name x) (mkVar id) (None,[])) @@ -1225,15 +1221,15 @@ let atomize_param_of_ind hyp0 gl = atomize_one (List.length argl) params gl let find_atomic_param_of_ind mind indtyp = - let mis = Global.lookup_mind_specif mind in - let nparams = mis_nparams mis in - let argl = snd (decomp_app indtyp) in + let (mib,mip) = Global.lookup_inductive mind in + let nparams = mip.mind_nparams in + let argl = snd (decompose_app indtyp) in let argv = Array.of_list argl in let params = list_firstn nparams argl in let indvars = ref Idset.empty in for i = nparams to (Array.length argv)-1 do match kind_of_term argv.(i) with - | IsVar id + | Var id when not (List.exists (occur_var (Global.env()) id) params) -> indvars := Idset.add id !indvars | _ -> () @@ -1389,28 +1385,28 @@ let induction_tac varname typ (elimc,elimt) gl = elimination_clause_scheme kONT wc elimclause indclause gl let is_indhyp p n t = - let c,_ = decomp_app t in + let c,_ = decompose_app t in match kind_of_term c with - | IsRel k when p < k & k <= p + n -> true + | Rel k when p < k & k <= p + n -> true | _ -> false (* We check that the eliminator has been build by Coq (usual *) (* eliminator _ind, _rec or _rect, or eliminator built by Scheme) *) let compute_elim_signature_and_roughly_check elimt mind = - let mis = Global.lookup_mind_specif mind in - let lra = mis_recarg mis in - let nconstr = mis_nconstr mis in - let _,elimt2 = decompose_prod_n (mis_nparams mis) elimt in + let (mib,mip) = Global.lookup_inductive mind in + let lra = mip.mind_listrec in + let nconstr = Array.length mip.mind_consnames in + let _,elimt2 = decompose_prod_n mip.mind_nparams elimt in let n = nb_prod elimt2 in - let npred = n - nconstr - (mis_nrealargs mis) - 1 in + let npred = n - nconstr - mip.mind_nrealargs - 1 in let rec check_branch p c ra = match kind_of_term c, ra with - | IsProd (_,_,c), Declarations.Mrec i :: ra' -> + | Prod (_,_,c), Declarations.Mrec i :: ra' -> (match kind_of_term c with - | IsProd (_,t,c) when is_indhyp (p+1) npred t -> + | Prod (_,t,c) when is_indhyp (p+1) npred t -> true::(check_branch (p+2) c ra') | _ -> false::(check_branch (p+1) c ra')) - | IsLetIn (_,_,_,c), ra' -> false::(check_branch (p+1) c ra) - | IsProd (_,_,c), _ :: ra -> false::(check_branch (p+1) c ra) + | LetIn (_,_,_,c), ra' -> false::(check_branch (p+1) c ra) + | Prod (_,_,c), _ :: ra -> false::(check_branch (p+1) c ra) | _, [] -> [] | _ -> error"Not a recursive eliminator: some constructor argument is lacking" @@ -1418,7 +1414,7 @@ let compute_elim_signature_and_roughly_check elimt mind = let rec check_elim c n = if n = nconstr then [] else match kind_of_term c with - | IsProd (_,t,c) -> (check_branch n t lra.(n)) :: (check_elim c (n+1)) + | Prod (_,t,c) -> (check_branch n t lra.(n)) :: (check_elim c (n+1)) | _ -> error "Not an eliminator: some constructor case is lacking" in let _,elimt3 = decompose_prod_n npred elimt2 in check_elim elimt3 0 @@ -1433,7 +1429,7 @@ let induction_from_context isrec style hyp0 gl = let (mind,typ0) = pf_reduce_to_quantified_ind gl tmptyp0 in let indvars = find_atomic_param_of_ind mind (snd (decompose_prod typ0)) in let elimc = - if isrec then lookup_eliminator env mind (elimination_sort_of_goal gl) + if isrec then Indrec.lookup_eliminator mind (elimination_sort_of_goal gl) else Indrec.make_case_gen env (project gl) mind (elimination_sort_of_goal gl) in let elimt = pf_type_of gl elimc in @@ -1476,7 +1472,7 @@ let induction_with_atomization_of_ind_arg isrec hyp0 = let new_induct isrec c gl = match kind_of_term c with - | IsVar id when not (mem_named_context id (Global.named_context())) -> + | Var id when not (mem_named_context id (Global.named_context())) -> induction_with_atomization_of_ind_arg isrec id gl | _ -> let x = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c) @@ -1592,7 +1588,7 @@ let elim_scheme_type elim t gl = let (wc,kONT) = startWalk gl in let clause = mk_clenv_type_of wc elim in match kind_of_term (last_arg (clenv_template clause).rebus) with - | IsMeta mv -> + | Meta mv -> let clause' = (* t is inductive, then CUMUL or CONV is irrelevant *) clenv_unify CUMUL t (clenv_instance_type clause mv) clause in @@ -1601,7 +1597,7 @@ let elim_scheme_type elim t gl = let elim_type t gl = let (ind,t) = pf_reduce_to_atomic_ind gl t in - let elimc = lookup_eliminator (pf_env gl) ind (elimination_sort_of_goal gl) in + let elimc = Indrec.lookup_eliminator ind (elimination_sort_of_goal gl) in elim_scheme_type elimc t gl let dyn_elim_type = function diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 75235b657..d49441775 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -20,6 +20,7 @@ open Evar_refiner open Clenv open Tacred open Tacticals +open Nametab (*i*) (* Main tactics. *) diff --git a/tactics/termdn.ml b/tactics/termdn.ml index 6672e56c4..2d0f49f4e 100644 --- a/tactics/termdn.ml +++ b/tactics/termdn.ml @@ -10,9 +10,11 @@ open Util open Names +open Nameops open Term open Pattern open Rawterm +open Nametab (* Discrimination nets of terms. See the module dn.ml for further explanations. @@ -24,8 +26,8 @@ type 'a t = (constr_label,constr_pattern,'a) Dn.t let decomp = let rec decrec acc c = match kind_of_term c with - | IsApp (f,l) -> decrec (Array.fold_right (fun a l -> a::l) l acc) f - | IsCast (c1,_) -> decrec acc c1 + | App (f,l) -> decrec (Array.fold_right (fun a l -> a::l) l acc) f + | Cast (c1,_) -> decrec acc c1 | _ -> (c,acc) in decrec [] @@ -44,17 +46,17 @@ let constr_pat_discr t = match decomp_pat t with | PRef (IndRef sp), args -> Some(IndNode sp,args) | PRef (ConstructRef sp), args -> Some(CstrNode sp,args) - | PRef (VarRef sp), args -> Some(VarNode (basename sp),args) + | PRef (VarRef id), args -> Some(VarNode id,args) | _ -> None let constr_val_discr t = let c, l = decomp t in match kind_of_term c with - (* IsConst _,_) -> Some(TERM c,l) *) - | IsMutInd ind_sp -> Some(IndNode ind_sp,l) - | IsMutConstruct cstr_sp -> Some(CstrNode cstr_sp,l) + (* Const _,_) -> Some(TERM c,l) *) + | Ind ind_sp -> Some(IndNode ind_sp,l) + | Construct cstr_sp -> Some(CstrNode cstr_sp,l) (* Ici, comment distinguer SectionVarNode de VarNode ?? *) - | IsVar id -> Some(VarNode id,l) + | Var id -> Some(VarNode id,l) | _ -> None (* Les deux fonctions suivantes ecrasaient les precedentes, diff --git a/tactics/wcclausenv.ml b/tactics/wcclausenv.ml index 2c791f3bb..0df646c0c 100644 --- a/tactics/wcclausenv.ml +++ b/tactics/wcclausenv.ml @@ -11,9 +11,11 @@ open Pp open Util open Names +open Nameops open Term +open Termops open Sign -open Reduction +open Reductionops open Environ open Logic open Tacmach @@ -99,10 +101,10 @@ let clenv_constrain_with_bindings bl clause = let add_prod_rel sigma (t,env) = match kind_of_term t with - | IsProd (na,t1,b) -> + | Prod (na,t1,b) -> (b,push_rel_assum (na, t1) env) - | IsLetIn (na,c1,t1,b) -> - (b,push_rel_def (na,c1, t1) env) + | LetIn (na,c1,t1,b) -> + (b,push_rel (na,Some c1, t1) env) | _ -> failwith "add_prod_rel" let rec add_prods_rel sigma (t,env) = @@ -127,20 +129,20 @@ let elim_res_pf_THEN_i kONT clenv tac gls = let rec build_args acc ce p_0 p_1 = match kind_of_term p_0, p_1 with - | (IsProd (na,a,b), (a_0::bargs)) -> + | (Prod (na,a,b), (a_0::bargs)) -> let (newa,ce') = (build_term ce (na,Some a) a_0) in build_args (newa::acc) ce' (subst1 a_0 b) bargs - | (IsLetIn (na,a,t,b), args) -> build_args acc ce (subst1 a b) args + | (LetIn (na,a,t,b), args) -> build_args acc ce (subst1 a b) args | (_, []) -> (List.rev acc,ce) | (_, (_::_)) -> failwith "mk_clenv_using" and build_term ce p_0 c = let env = w_env ce.hook in match p_0, kind_of_term c with - | ((na,Some t), IsMeta mv) -> + | ((na,Some t), Meta mv) -> (* let mv = new_meta() in *) (mkMeta mv, clenv_pose (na,mv,t) ce) - | ((na,_), IsCast (c,t)) -> build_term ce (na,Some t) c + | ((na,_), Cast (c,t)) -> build_term ce (na,Some t) c | ((na,Some t), _) -> if (not((occur_meta c))) then (c,ce) @@ -169,7 +171,7 @@ and build_term ce p_0 c = (newc,ce') let mk_clenv_using wc c = - let ce = mk_clenv wc mkImplicit in + let ce = mk_clenv wc mkProp in let (newc,ce') = try build_term ce (Anonymous,None) c @@ -192,11 +194,11 @@ let clenv_apply_n_times n ce = match (n, kind_of_term templtyp) with | (0, _) -> clenv_change_head (applist(templval,List.rev argacc), templtyp) ce - | (n, IsProd (na,dom,rng)) -> + | (n, Prod (na,dom,rng)) -> let mv = new_meta() in let newce = clenv_pose (na,mv,dom) ce in apprec newce (mkMeta mv::argacc) (n-1, subst1 (mkMeta mv) rng) - | (n, IsLetIn (na,b,t,c)) -> + | (n, LetIn (na,b,t,c)) -> apprec ce argacc (n, subst1 b c) | (n, _) -> failwith "clenv_apply_n_times" in diff --git a/toplevel/class.ml b/toplevel/class.ml index 21e1242f8..d2524b067 100644 --- a/toplevel/class.ml +++ b/toplevel/class.ml @@ -11,7 +11,9 @@ open Util open Pp open Names +open Nameops open Term +open Termops open Inductive open Declarations open Environ @@ -19,6 +21,8 @@ open Inductive open Lib open Classops open Declare +open Nametab +open Safe_typing (* manipulations concernant les strength *) @@ -47,7 +51,7 @@ let stre_max4 stre1 stre2 stre3 stre4 = stre_max ((stre_max (stre1,stre2)),(stre_max (stre3,stre4))) let id_of_varid c = match kind_of_term c with - | IsVar id -> id + | Var id -> id | _ -> anomaly "class__id_of_varid" (* lf liste des variable dont depend la coercion f @@ -67,16 +71,16 @@ let rec stre_unif_cond = function let stre_of_global = function | ConstRef sp -> constant_or_parameter_strength sp - | VarRef sp -> variable_strength sp + | VarRef id -> variable_strength id | IndRef _ | ConstructRef _ -> NeverDischarge (* verfications pour l'ajout d'une classe *) 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 + | Sort (Prop _ | Type _) -> 0 + | Prod (_,_,c) -> (arity_sort c) +1 + | LetIn (_,_,_,c) -> arity_sort c (* Utile ?? *) + | Cast (c,_) -> arity_sort c | _ -> raise Not_found (* try_add_class : Names.identifier -> @@ -185,15 +189,15 @@ let check_target clt = function let constructor_at_head1 t = let rec aux t' = match kind_of_term t' with - | IsConst sp -> t',[],CL_CONST sp,0 - | IsMutInd ind_sp -> t',[],CL_IND ind_sp,0 - | IsVar id -> t',[],CL_SECVAR (find_section_variable id),0 - | IsCast (c,_) -> aux c - | IsApp(f,args) -> + | Const sp -> t',[],CL_CONST sp,0 + | Ind ind_sp -> t',[],CL_IND ind_sp,0 + | Var id -> t',[],CL_SECVAR id,0 + | Cast (c,_) -> aux c + | App(f,args) -> let t',_,l,_ = aux f in t',Array.to_list args,l,Array.length args - | IsProd (_,_,_) -> t',[],CL_FUN,0 - | IsLetIn (_,_,_,c) -> aux c - | IsSort _ -> t',[],CL_SORT,0 + | Prod (_,_,_) -> t',[],CL_FUN,0 + | LetIn (_,_,_,c) -> aux c + | Sort _ -> t',[],CL_SORT,0 | _ -> raise Not_found in aux (collapse_appl t) @@ -210,17 +214,18 @@ let uniform_cond nargs lt = aux (nargs,lt) let id_of_cl = function - | CL_FUN -> (id_of_string "FUNCLASS") - | CL_SORT -> (id_of_string "SORTCLASS") - | CL_CONST sp -> (basename sp) - | CL_IND (sp,i) -> - (mind_nth_type_packet (Global.lookup_mind sp) i).mind_typename - | CL_SECVAR sp -> (basename sp) + | CL_FUN -> id_of_string "FUNCLASS" + | CL_SORT -> id_of_string "SORTCLASS" + | CL_CONST sp -> basename sp + | CL_IND ind -> + let (_,mip) = Global.lookup_inductive ind in + mip.mind_typename + | CL_SECVAR id -> id let class_of_ref = function | ConstRef sp -> CL_CONST sp | IndRef sp -> CL_IND sp - | VarRef sp -> CL_SECVAR sp + | VarRef id -> CL_SECVAR id | ConstructRef _ as c -> errorlabstrm "class_of_ref" [< 'sTR "Constructors, such as "; Printer.pr_global c; @@ -268,8 +273,8 @@ let get_target t ind = let prods_of t = let rec aux acc d = match kind_of_term d with - | IsProd (_,c1,c2) -> aux (c1::acc) c2 - | IsCast (c,_) -> aux acc c + | Prod (_,c1,c2) -> aux (c1::acc) c2 + | Cast (c,_) -> aux acc c | _ -> d::acc in aux [] t @@ -296,7 +301,7 @@ let build_id_coercion idf_opt source = let vs = match source with | CL_CONST sp -> mkConst sp | _ -> error_not_transparent source in - let c = match Instantiate.constant_opt_value env (destConst vs) with + let c = match constant_opt_value env (destConst vs) with | Some c -> c | None -> error_not_transparent source in let lams,t = Sign.decompose_lam_assum c in @@ -315,7 +320,7 @@ let build_id_coercion idf_opt source = (* juste pour verification *) let _ = try - Reduction.conv_leq env Evd.empty + Reductionops.conv_leq env Evd.empty (Typing.type_of env Evd.empty val_f) typ_f with _ -> error ("cannot be defined as coercion - "^ @@ -417,7 +422,7 @@ let count_extra_abstractions hyps ids_to_discard = List.fold_left (fun (hyps,n as sofar) id -> match hyps with - | (hyp,None,_)::rest when id = basename hyp ->(rest, n+1) + | (hyp,None,_)::rest when id = hyp ->(rest, n+1) | _ -> sofar) (hyps,0) ids_to_discard in n @@ -430,20 +435,20 @@ let process_global sec_sp = function anomaly "process_global only processes global surviving the section" | ConstRef sp as x -> if defined_in_sec sp sec_sp then - let ((_,spid,spk)) = repr_path sp in - let newsp = Lib.make_path spid CCI in + let (_,spid) = repr_path sp in + let newsp = Lib.make_path spid in ConstRef newsp else x | IndRef (sp,i) as x -> if defined_in_sec sp sec_sp then - let ((_,spid,spk)) = repr_path sp in - let newsp = Lib.make_path spid CCI in + let (_,spid) = repr_path sp in + let newsp = Lib.make_path spid in IndRef (newsp,i) else x | ConstructRef ((sp,i),j) as x -> if defined_in_sec sp sec_sp then - let ((_,spid,spk)) = repr_path sp in - let newsp = Lib.make_path spid CCI in + let (_,spid) = repr_path sp in + let newsp = Lib.make_path spid in ConstructRef ((newsp,i),j) else x @@ -454,8 +459,8 @@ let process_class sec_sp ids_to_discard x = | CL_SECVAR _ -> x | CL_CONST sp -> if defined_in_sec sp sec_sp then - let ((_,spid,spk)) = repr_path sp in - let newsp = Lib.make_path spid CCI in + let (_,spid) = repr_path sp in + let newsp = Lib.make_path spid in let hyps = (Global.lookup_constant sp).const_hyps in let n = count_extra_abstractions hyps ids_to_discard in (CL_CONST newsp,{cl_strength=stre;cl_param=p+n}) @@ -463,8 +468,8 @@ let process_class sec_sp ids_to_discard x = x | CL_IND (sp,i) -> if defined_in_sec sp sec_sp then - let ((_,spid,spk)) = repr_path sp in - let newsp = Lib.make_path spid CCI in + let (_,spid) = repr_path sp in + let newsp = Lib.make_path spid in let hyps = (Global.lookup_mind sp).mind_hyps in let n = count_extra_abstractions hyps ids_to_discard in (CL_IND (newsp,i),{cl_strength=stre;cl_param=p+n}) @@ -477,15 +482,15 @@ let process_cl sec_sp cl = | CL_SECVAR id -> cl | CL_CONST sp -> if defined_in_sec sp sec_sp then - let ((_,spid,spk)) = repr_path sp in - let newsp = Lib.make_path spid CCI in + let (_,spid) = repr_path sp in + let newsp = Lib.make_path spid in CL_CONST newsp else cl | CL_IND (sp,i) -> if defined_in_sec sp sec_sp then - let ((_,spid,spk)) = repr_path sp in - let newsp = Lib.make_path spid CCI in + let (_,spid) = repr_path sp in + let newsp = Lib.make_path spid in CL_IND (newsp,i) else cl diff --git a/toplevel/class.mli b/toplevel/class.mli index f651329d6..f140351ce 100644 --- a/toplevel/class.mli +++ b/toplevel/class.mli @@ -13,6 +13,7 @@ open Names open Term open Classops open Declare +open Nametab (*i*) (* Classes and coercions. *) diff --git a/toplevel/command.ml b/toplevel/command.ml index ab2517b28..1089539c4 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -12,6 +12,7 @@ open Pp open Util open Options open Term +open Termops open Declarations open Inductive open Environ @@ -19,6 +20,7 @@ open Reduction open Tacred open Declare open Names +open Nameops open Coqast open Ast open Library @@ -26,6 +28,10 @@ open Libobject open Astterm open Proof_type open Tacmach +open Safe_typing +open Nametab +open Typeops +open Indtypes let mkCastC(c,t) = ope("CAST",[c;t]) let mkLambdaC(x,a,b) = ope("LAMBDA",[a;slam(Some x,b)]) @@ -78,12 +84,12 @@ let definition_body_red red_option ident (local,n) com comtypeopt = | DischargeAt (disch_sp,_) -> if Lib.is_section_p disch_sp then begin let c = constr_of_constr_entry ce' in - let sp = declare_variable ident (SectionLocalDef c,n) in + let sp = declare_variable ident (Lib.cwd(),SectionLocalDef c,n) in if_verbose message ((string_of_id ident) ^ " is defined"); if Pfedit.refining () then mSGERRNL [< 'sTR"Warning: Local definition "; pr_id ident; 'sTR" is not visible from current goals" >]; - VarRef sp + VarRef ident end else declare_global_definition ident ce' n true @@ -118,12 +124,12 @@ let hypothesis_def_var is_refining ident n c = | DischargeAt (disch_sp,_) -> if Lib.is_section_p disch_sp then begin let t = interp_type Evd.empty (Global.env()) c in - let sp = declare_variable ident (SectionLocalAssum t,n) in + let sp = declare_variable ident (Lib.cwd(),SectionLocalAssum t,n) in if_verbose message ((string_of_id ident) ^ " is assumed"); if is_refining then mSGERRNL [< 'sTR"Warning: Variable "; pr_id ident; 'sTR" is not visible from current goals" >]; - VarRef sp + VarRef ident end else declare_global_assumption ident c @@ -166,12 +172,12 @@ let interp_mutual lparams lnamearconstrs finite = List.fold_left (fun (env, params) (id,t) -> let p = interp_type sigma env t in - (Environ.push_rel_assum (Name id,p) env, (Name id,p)::params)) + (Termops.push_rel_assum (Name id,p) env, (Name id,None,p)::params)) (env0,[]) lparams in (* Pour permettre ŕ terme les let-in dans les params *) let params' = - List.map (fun (na,p) -> + List.map (fun (na,_,p) -> let id = match na with | Name id -> id | Anonymous -> anomaly "Unnamed inductive variable" @@ -181,16 +187,17 @@ let interp_mutual lparams lnamearconstrs finite = List.fold_left (fun (env, ind_impls, arl) (recname, arityc,_) -> let arity = interp_type sigma env_params arityc in - let fullarity = prod_it arity params in - let env' = Environ.push_rel_assum (Name recname,fullarity) env in + let fullarity = + prod_it arity (List.map (fun (id,_,ty) -> (id,ty)) params) in + let env' = Termops.push_rel_assum (Name recname,fullarity) env in let impls = if Impargs.is_implicit_args() - then Impargs.compute_implicits env_params sigma fullarity + then Impargs.compute_implicits env_params fullarity else [] in (env', (recname,impls)::ind_impls, (arity::arl))) (env0, [], []) lnamearconstrs in - let ind_env_params = Environ.push_rels_assum params ind_env in + let ind_env_params = push_rel_context params ind_env in let mispecvec = List.map2 (fun ar (name,_,lname_constr) -> @@ -214,7 +221,7 @@ let declare_mutual_with_eliminations mie = List.map (fun e -> e.mind_entry_typename) mie.mind_entry_inds in let sp = declare_mind mie in if_verbose pPNL (minductive_message lrecnames); - declare_eliminations sp; + Indrec.declare_eliminations sp; sp let build_mutual lparams lnamearconstrs finite = @@ -271,8 +278,8 @@ let build_recursive lnameargsardef = let raw_arity = mkProdCit lparams arityc in let arity = interp_type sigma env0 raw_arity in let _ = declare_variable recname - (SectionLocalAssum arity, NeverDischarge) in - (Environ.push_named_assum (recname,arity) env, (arity::arl))) + (Lib.cwd(),SectionLocalAssum arity, NeverDischarge) in + (Environ.push_named_decl (recname,None,arity) env, (arity::arl))) (env0,[]) lnameargsardef with e -> States.unfreeze fs; raise e in @@ -335,8 +342,8 @@ let build_corecursive lnameardef = let arj = type_judgment_of_rawconstr Evd.empty env0 arityc in let arity = arj.utj_val in let _ = declare_variable recname - (SectionLocalAssum arj.utj_val,NeverDischarge) in - (Environ.push_named_assum (recname,arity) env, (arity::arl))) + (Lib.cwd(),SectionLocalAssum arj.utj_val,NeverDischarge) in + (Environ.push_named_decl (recname,None,arity) env, (arity::arl))) (env0,[]) lnameardef with e -> States.unfreeze fs; raise e in @@ -389,7 +396,7 @@ let inductive_of_ident qid = match Nametab.global dummy_loc qid with | IndRef ind -> ind | ref -> errorlabstrm "inductive_of_ident" - [< 'sTR (Global.string_of_global ref); + [< pr_id (id_of_global (Global.env()) ref); 'sPC; 'sTR "is not an inductive type">] let build_scheme lnamedepindsort = @@ -398,8 +405,10 @@ let build_scheme lnamedepindsort = and env0 = Global.env() in let lrecspec = List.map - (fun (_,dep,indid,sort) -> - (inductive_of_ident indid,dep,interp_elimination_sort sort)) + (fun (_,dep,indid,sort) -> + let ind = inductive_of_ident indid in + let (mib,mip) = Global.lookup_inductive ind in + (ind,mib,mip,dep,interp_elimination_sort sort)) lnamedepindsort in let n = NeverDischarge in @@ -420,7 +429,7 @@ let start_proof_com sopt stre com = let id = match sopt with | Some id -> (* We check existence here: it's a bit late at Qed time *) - if Nametab.exists_cci (Lib.make_path id CCI) then + if Nametab.exists_cci (Lib.make_path id) then errorlabstrm "start_proof" [< pr_id id; 'sTR " already exists" >]; id | None -> @@ -428,7 +437,7 @@ let start_proof_com sopt stre com = (Pfedit.get_all_proof_names ()) in let c = interp_type Evd.empty env com in - let _ = Safe_typing.typing_in_unsafe_env env c in + let _ = Typeops.infer_type env c in Pfedit.start_proof id stre sign c let apply_tac_not_declare id pft = function @@ -446,7 +455,7 @@ let save id const strength = begin match strength with | DischargeAt (disch_sp,_) when Lib.is_section_p disch_sp && not opacity -> let c = constr_of_constr_entry const in - let _ = declare_variable id (SectionLocalDef c,strength) + let _ = declare_variable id (Lib.cwd(),SectionLocalDef c,strength) in () | NeverDischarge | DischargeAt _ -> let _ = declare_constant id (ConstantEntry const,strength) diff --git a/toplevel/command.mli b/toplevel/command.mli index f45dc633f..f182812c9 100644 --- a/toplevel/command.mli +++ b/toplevel/command.mli @@ -13,6 +13,7 @@ open Names open Term open Declare open Library +open Nametab (*i*) (*s Declaration functions. The following functions take ASTs, @@ -41,7 +42,8 @@ val build_mutual : (identifier * Coqast.t) list -> (identifier * Coqast.t * (identifier * Coqast.t) list) list -> bool -> unit -val declare_mutual_with_eliminations : Declarations.mutual_inductive_entry -> section_path +val declare_mutual_with_eliminations : + Indtypes.mutual_inductive_entry -> section_path val build_recursive : (identifier * ((identifier * Coqast.t) list) * Coqast.t * Coqast.t) list diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml index cb244786d..8bd52929e 100644 --- a/toplevel/coqinit.ml +++ b/toplevel/coqinit.ml @@ -53,8 +53,8 @@ let add_ml_include s = Mltop.add_ml_dir s (* Puts dir in the path of ML and in the LoadPath *) -let coq_add_path s = Mltop.add_path s (Names.make_dirpath [Nametab.coq_root]) -let coq_add_rec_path s = Mltop.add_rec_path s (Names.make_dirpath [Nametab.coq_root]) +let coq_add_path s = Mltop.add_path s (Names.make_dirpath [Nameops.coq_root]) +let coq_add_rec_path s = Mltop.add_rec_path s (Names.make_dirpath [Nameops.coq_root]) (* By the option -include -I or -R of the command line *) let includes = ref [] @@ -79,23 +79,20 @@ let init_load_path () = (* first user-contrib *) let user_contrib = Filename.concat coqlib "user-contrib" in if Sys.file_exists user_contrib then - Mltop.add_path user_contrib Nametab.default_root_prefix; + Mltop.add_path user_contrib Nameops.default_root_prefix; (* then standard library *) let dirs = "states" :: dev @ [ "theories"; "tactics"; "contrib" ] in List.iter (fun s -> coq_add_rec_path (Filename.concat coqlib s)) dirs; let camlp4 = getenv_else "CAMLP4LIB" Coq_config.camlp4lib in add_ml_include camlp4; (* then current directory *) - Mltop.add_path "." Nametab.default_root_prefix; + Mltop.add_path "." Nameops.default_root_prefix; (* additional loadpath, given with -I -include -R options *) List.iter (fun (s,alias,reci) -> if reci then Mltop.add_rec_path s alias else Mltop.add_path s alias) (List.rev !includes) - -(* Must be done after restoring initial state! *) let init_library_roots () = - List.iter (fun (_,alias,_) -> Nametab.push_library_root alias) !includes; includes := [] (* Initialises the Ocaml toplevel before launching it, so that it can diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 7825b2b1a..864b2fa2c 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -13,6 +13,7 @@ open Util open System open Options open Names +open Nameops open States open Toplevel open Coqinit @@ -47,8 +48,8 @@ let outputstate () = if !outputstate <> "" then extern_state !outputstate let set_include d p = push_include (d,p) let set_rec_include d p = push_rec_include (d,p) -let set_default_include d = set_include d Nametab.default_root_prefix -let set_default_rec_include d = set_rec_include d Nametab.default_root_prefix +let set_default_include d = set_include d Nameops.default_root_prefix +let set_default_rec_include d = set_rec_include d Nameops.default_root_prefix let load_vernacular_list = ref ([] : string list) let add_load_vernacular s = @@ -230,7 +231,6 @@ let start () = exit 1 end; if !batch_mode then (flush_all(); Profile.print_profile ();exit 0); - Lib.init_toplevel_root (); Toplevel.loop(); (* Initialise and launch the Ocaml toplevel *) Coqinit.init_ocaml_path(); diff --git a/toplevel/discharge.ml b/toplevel/discharge.ml index f6d96e292..b49c2004b 100644 --- a/toplevel/discharge.ml +++ b/toplevel/discharge.ml @@ -11,6 +11,7 @@ open Pp open Util open Names +open Nameops open Sign open Term open Declarations @@ -27,13 +28,15 @@ open Classops open Class open Recordops open Library +open Indtypes +open Nametab let recalc_sp dir sp = - let (_,spid,k) = repr_path sp in Names.make_path dir spid k + let (_,spid) = repr_path sp in Names.make_path dir spid let rec find_var id = function | [] -> false - | (sp,b,_)::l -> if basename sp = id then b=None else find_var id l + | (x,b,_)::l -> if x = id then b=None else find_var id l let build_abstract_list hyps ids_to_discard = let l = @@ -104,13 +107,13 @@ let abstract_inductive ids_to_abs hyps inds = let process_inductive osecsp nsecsp oldenv (ids_to_discard,modlist) mib = assert (Array.length mib.mind_packets > 0); - let finite = mib.mind_packets.(0).mind_finite in + let finite = mib.mind_finite in let inds = array_map_to_list (fun mip -> let nparams = mip.mind_nparams in - let arity = expmod_type modlist (mind_user_arity mip) in - let lc = Array.map (expmod_type modlist) (mind_user_lc mip) in + let arity = expmod_type modlist mip.mind_user_arity in + let lc = Array.map (expmod_type modlist) mip.mind_user_lc in (nparams, mip.mind_typename, arity, @@ -118,11 +121,17 @@ let process_inductive osecsp nsecsp oldenv (ids_to_discard,modlist) mib = Array.to_list lc)) mib.mind_packets in - let hyps = List.map (fun (sp,c,t) -> (basename sp,c,t)) mib.mind_hyps in - let hyps' = map_named_context (expmod_constr modlist) hyps in + let hyps = mib.mind_hyps in + let hyps' = + Sign.fold_named_context + (fun (x,b,t) sgn -> + Sign.add_named_decl + (x, option_app (expmod_constr modlist) b,expmod_constr modlist t) + sgn) + mib.mind_hyps empty_named_context in let (inds',abs_vars) = abstract_inductive ids_to_discard hyps' inds in let lmodif_one_mind i = - let nbc = Array.length (mind_nth_type_packet mib i).mind_consnames in + let nbc = Array.length mib.mind_packets.(i).mind_consnames in (((osecsp,i), DO_ABSTRACT ((nsecsp,i),abs_vars)), list_tabulate (function j -> @@ -179,7 +188,8 @@ let process_object oldenv dir sec_sp let tag = object_tag lobj in match tag with | "VARIABLE" -> - let ((id,c,t),cst,stre) = get_variable_with_constraints sp in + let ((id,c,t),cst,stre) = + get_variable_with_constraints (basename sp) in (* VARIABLE means local (entry Variable/Hypothesis/Local and are *) (* always discharged *) (* @@ -259,7 +269,7 @@ let process_object oldenv dir sec_sp let strobj () = let mib = Environ.lookup_mind newsp (Global.env ()) in { s_CONST = info.s_CONST; - s_PARAM = (mind_nth_type_packet mib 0).mind_nparams; + s_PARAM = mib.mind_packets.(0).mind_nparams; s_PROJ = List.map (option_app (recalc_sp dir)) info.s_PROJ } in ((Struc ((newsp,i),strobj))::ops, ids_to_discard, work_alist) @@ -281,7 +291,8 @@ let process_item oldenv dir sec_sp acc = function let process_operation = function | Variable (id,expmod_a,stre,imp) -> (* Warning:parentheses needed to get a side-effect from with_implicits *) - let _ = with_implicits imp (declare_variable id) (expmod_a,stre) in + let _ = + with_implicits imp (declare_variable id) (Lib.cwd(),expmod_a,stre) in () | Parameter (spid,typ,imp) -> let _ = with_implicits imp (declare_parameter spid) typ in diff --git a/toplevel/errors.ml b/toplevel/errors.ml index cf48f0764..623ebbfbb 100644 --- a/toplevel/errors.ml +++ b/toplevel/errors.ml @@ -65,8 +65,8 @@ let rec explain_exn_default = function hOV 0 [< 'fNL; 'sTR"User Interrupt." >] | Univ.UniverseInconsistency -> hOV 0 [< 'sTR "Error: Universe Inconsistency." >] - | TypeError(k,ctx,te) -> - hOV 0 [< 'sTR "Error:"; 'sPC; Himsg.explain_type_error k ctx te >] + | TypeError(ctx,te) -> + hOV 0 [< 'sTR "Error:"; 'sPC; Himsg.explain_type_error ctx te >] | PretypeError(ctx,te) -> hOV 0 [< 'sTR "Error:"; 'sPC; Himsg.explain_pretype_error ctx te >] | InductiveError e -> diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml index c528eba95..da11dddaa 100644 --- a/toplevel/himsg.ml +++ b/toplevel/himsg.ml @@ -13,6 +13,7 @@ open Util open Options open Names open Term +open Termops open Inductive open Indtypes open Sign @@ -27,30 +28,34 @@ open Ast let guill s = "\""^s^"\"" -let explain_unbound_rel k ctx n = +let explain_unbound_rel ctx n = let ctx = make_all_name_different ctx in - let pe = pr_ne_context_of [< 'sTR "In environment" >] k ctx in + let pe = pr_ne_context_of [< 'sTR "In environment" >] ctx in [< 'sTR"Unbound reference: "; pe; 'sTR"The reference "; 'iNT n; 'sTR" is free" >] -let explain_not_type k ctx j = +let explain_not_type ctx j = let ctx = make_all_name_different ctx in - let pe = pr_ne_context_of [< 'sTR"In environment" >] k ctx in + let pe = pr_ne_context_of [< 'sTR"In environment" >] ctx in let pc,pt = prjudge_env ctx j in [< pe; 'sTR "the term"; 'bRK(1,1); pc; 'sPC; 'sTR"has type"; 'sPC; pt; 'sPC; 'sTR"which should be Set, Prop or Type." >];; -let explain_bad_assumption k ctx c = - let pc = prterm_env ctx c in - [< 'sTR "Cannot declare a variable or hypothesis over the term"; - 'bRK(1,1); pc; 'sPC; 'sTR "because this term is not a type." >];; +let explain_bad_assumption ctx j = + let ctx = make_all_name_different ctx in + let pe = pr_ne_context_of [< 'sTR"In environment" >] ctx in + let pc,pt = prjudge_env ctx j in + [< pe; 'sTR "cannot declare a variable or hypothesis over the term"; + 'bRK(1,1); pc; 'sPC; 'sTR"of type"; 'sPC; pt; 'sPC; + 'sTR "because this term is not a type." >];; -let explain_reference_variables id = - [< 'sTR "the constant"; 'sPC; pr_id id; 'sPC; +let explain_reference_variables c = + let pc = prterm c in + [< 'sTR "the constant"; 'sPC; pc; 'sPC; 'sTR "refers to variables which are not in the context" >] -let msg_bad_elimination ctx k = function +let msg_bad_elimination ctx = function | Some(kp,ki,explanation) -> let pki = prterm_env ctx ki in let pkp = prterm_env ctx kp in @@ -62,7 +67,7 @@ let msg_bad_elimination ctx k = function | None -> [<>] -let explain_elim_arity k ctx ind aritylst c pj okinds = +let explain_elim_arity ctx ind aritylst c pj okinds = let pi = pr_inductive ctx ind in let ppar = prlist_with_sep pr_coma (prterm_env ctx) aritylst in let pc = prterm_env ctx c in @@ -73,23 +78,23 @@ let explain_elim_arity k ctx ind aritylst c pj okinds = 'sTR "The elimination predicate"; 'bRK(1,1); pp; 'sPC; 'sTR "has type"; 'bRK(1,1); ppt; 'fNL; 'sTR "It should be one of :"; 'bRK(1,1) ; hOV 0 ppar; 'fNL; - msg_bad_elimination ctx k okinds >] + msg_bad_elimination ctx okinds >] -let explain_case_not_inductive k ctx cj = +let explain_case_not_inductive ctx cj = let pc = prterm_env ctx cj.uj_val in let pct = prterm_env ctx cj.uj_type in [< 'sTR "In Cases expression, the matched term"; 'bRK(1,1); pc; 'sPC; 'sTR "has type"; 'bRK(1,1); pct; 'sPC; 'sTR "which is not a (co-)inductive type" >] -let explain_number_branches k ctx cj expn = +let explain_number_branches ctx cj expn = let pc = prterm_env ctx cj.uj_val in let pct = prterm_env ctx cj.uj_type in [< 'sTR "Cases on term"; 'bRK(1,1); pc; 'sPC ; 'sTR "of type"; 'bRK(1,1); pct; 'sPC; 'sTR "expects "; 'iNT expn; 'sTR " branches" >] -let explain_ill_formed_branch k ctx c i actty expty = +let explain_ill_formed_branch ctx c i actty expty = let pc = prterm_env ctx c in let pa = prterm_env ctx actty in let pe = prterm_env ctx expty in @@ -98,9 +103,9 @@ let explain_ill_formed_branch k ctx c i actty expty = 'sTR " has type"; 'bRK(1,1); pa ; 'sPC; 'sTR "which should be"; 'bRK(1,1); pe >] -let explain_generalization k ctx (name,var) j = +let explain_generalization ctx (name,var) j = let ctx = make_all_name_different ctx in - let pe = pr_ne_context_of [< 'sTR "In environment" >] k ctx in + let pe = pr_ne_context_of [< 'sTR "In environment" >] ctx in let pv = prtype_env ctx var in let (pc,pt) = prjudge_env (push_rel_assum (name,var) ctx) j in [< 'sTR"Illegal generalization: "; pe; @@ -108,20 +113,20 @@ let explain_generalization k ctx (name,var) j = 'sTR"over"; 'bRK(1,1); pc; 'sTR","; 'sPC; 'sTR"it has type"; 'sPC; pt; 'sPC; 'sTR"which should be Set, Prop or Type." >] -let explain_actual_type k ctx c ct pt = +let explain_actual_type ctx j pt = let ctx = make_all_name_different ctx in - let pe = pr_ne_context_of [< 'sTR "In environment" >] k ctx in - let pc = prterm_env ctx c in - let pct = prterm_env ctx ct in + let pe = pr_ne_context_of [< 'sTR "In environment" >] ctx in + let (pc,pct) = prjudge_env ctx j in let pt = prterm_env ctx pt in [< pe; 'sTR "The term"; 'bRK(1,1); pc ; 'sPC ; 'sTR "has type" ; 'bRK(1,1); pct; 'bRK(1,1); 'sTR "while it is expected to have type"; 'bRK(1,1); pt >] -let explain_cant_apply_bad_type k ctx (n,exptyp,actualtyp) rator randl = +let explain_cant_apply_bad_type ctx (n,exptyp,actualtyp) rator randl = + let randl = Array.to_list randl in let ctx = make_all_name_different ctx in -(* let pe = pr_ne_context_of [< 'sTR"in environment" >] k ctx in*) +(* let pe = pr_ne_context_of [< 'sTR"in environment" >] ctx in*) let pr,prt = prjudge_env ctx rator in let term_string1,term_string2 = if List.length randl > 1 then @@ -142,9 +147,10 @@ let explain_cant_apply_bad_type k ctx (n,exptyp,actualtyp) rator randl = 'bRK(1,1); prterm_env ctx actualtyp; 'sPC; 'sTR"which should be coercible to"; 'bRK(1,1); prterm_env ctx exptyp >] -let explain_cant_apply_not_functional k ctx rator randl = +let explain_cant_apply_not_functional ctx rator randl = + let randl = Array.to_list randl in let ctx = make_all_name_different ctx in -(* let pe = pr_ne_context_of [< 'sTR"in environment" >] k ctx in*) +(* let pe = pr_ne_context_of [< 'sTR"in environment" >] ctx in*) let pr = prterm_env ctx rator.uj_val in let prt = prterm_env ctx (body_of_type rator.uj_type) in let term_string = if List.length randl > 1 then "terms" else "term" in @@ -160,14 +166,14 @@ let explain_cant_apply_not_functional k ctx rator randl = 'sTR("cannot be applied to the "^term_string); 'fNL; 'sTR" "; v 0 appl >] -let explain_unexpected_type k ctx actual_type expected_type = +let explain_unexpected_type ctx actual_type expected_type = let ctx = make_all_name_different ctx in let pract = prterm_env ctx actual_type in let prexp = prterm_env ctx expected_type in [< 'sTR"This type is"; 'sPC; pract; 'sPC; 'sTR "but is expected to be"; 'sPC; prexp >] -let explain_not_product k ctx c = +let explain_not_product ctx c = let ctx = make_all_name_different ctx in let pr = prterm_env ctx c in [< 'sTR"The type of this term is a product,"; 'sPC; @@ -176,7 +182,7 @@ let explain_not_product k ctx c = (* TODO: use the names *) (* (co)fixpoints *) -let explain_ill_formed_rec_body k ctx err names i vdefs = +let explain_ill_formed_rec_body ctx err names i vdefs = let str = match err with (* Fixpoint guard errors *) @@ -222,7 +228,7 @@ let explain_ill_formed_rec_body k ctx err names i vdefs = 'sPC ; 'sTR":="; 'sPC ; pvd; 'sPC; 'sTR "is not well-formed" >] -let explain_ill_typed_rec_body k ctx i names vdefj vargs = +let explain_ill_typed_rec_body ctx i names vdefj vargs = let pvd,pvdt = prjudge_env ctx (vdefj.(i)) in let pv = prterm_env ctx (body_of_type vargs.(i)) in [< 'sTR"The " ; @@ -230,12 +236,12 @@ let explain_ill_typed_rec_body k ctx i names vdefj vargs = 'sTR"recursive definition" ; 'sPC; pvd; 'sPC; 'sTR "has type"; 'sPC; pvdt;'sPC; 'sTR "it should be"; 'sPC; pv >] -let explain_not_inductive k ctx c = +let explain_not_inductive ctx c = let pc = prterm_env ctx c in [< 'sTR"The term"; 'bRK(1,1); pc; 'sPC; 'sTR "is not an inductive definition" >] -let explain_ml_case k ctx mes = +let explain_ml_case ctx mes = let expln = match mes with | MlCaseAbsurd -> [< 'sTR "Unable to infer a predicate for an elimination an empty type">] @@ -244,17 +250,17 @@ let explain_ml_case k ctx mes = in hOV 0 [< 'sTR "Cannot infer ML Case predicate:"; 'fNL; expln >] -let explain_cant_find_case_type k ctx c = +let explain_cant_find_case_type ctx c = let pe = prterm_env ctx c in hOV 3 [<'sTR "Cannot infer type of whole Case expression on"; 'wS 1; pe >] -let explain_occur_check k ctx ev rhs = +let explain_occur_check ctx ev rhs = let id = "?" ^ string_of_int ev in let pt = prterm_env ctx rhs in [< 'sTR"Occur check failed: tried to define "; 'sTR id; 'sTR" with term"; 'bRK(1,1); pt >] -let explain_not_clean k ctx ev t = +let explain_not_clean ctx ev t = let c = mkRel (Intset.choose (free_rels t)) in let id = "?" ^ string_of_int ev in let var = prterm_env ctx c in @@ -262,59 +268,73 @@ let explain_not_clean k ctx ev t = 'sTR" with a term using variable "; var; 'sPC; 'sTR"which is not in its scope." >] -let explain_var_not_found k ctx id = +let explain_var_not_found ctx id = [< 'sTR "The variable"; 'sPC; 'sTR (string_of_id id); 'sPC ; 'sTR "was not found"; 'sPC ; 'sTR "in the current"; 'sPC ; 'sTR "environment" >] -let explain_type_error k ctx = function +let explain_wrong_case_info ctx ind ci = + let pi = prterm (mkInd ind) in + if ci.ci_ind = ind then + [< 'sTR"Cases expression on an object of inductive"; 'sPC; pi; + 'sPC; 'sTR"has invalid information" >] + else + let pc = prterm (mkInd ci.ci_ind) in + [< 'sTR"A term of inductive type"; 'sPC; pi; 'sPC; + 'sTR"was given to a Cases expression on the inductive type"; + 'sPC; pc >] + + +let explain_type_error ctx = function | UnboundRel n -> - explain_unbound_rel k ctx n + explain_unbound_rel ctx n | NotAType j -> - explain_not_type k ctx j + explain_not_type ctx j | BadAssumption c -> - explain_bad_assumption k ctx c + explain_bad_assumption ctx c | ReferenceVariables id -> explain_reference_variables id | ElimArity (ind, aritylst, c, pj, okinds) -> - explain_elim_arity k ctx ind aritylst c pj okinds + explain_elim_arity ctx ind aritylst c pj okinds | CaseNotInductive cj -> - explain_case_not_inductive k ctx cj + explain_case_not_inductive ctx cj | NumberBranches (cj, n) -> - explain_number_branches k ctx cj n + explain_number_branches ctx cj n | IllFormedBranch (c, i, actty, expty) -> - explain_ill_formed_branch k ctx c i actty expty + explain_ill_formed_branch ctx c i actty expty | Generalization (nvar, c) -> - explain_generalization k ctx nvar c - | ActualType (c, ct, pt) -> - explain_actual_type k ctx c ct pt + explain_generalization ctx nvar c + | ActualType (j, pt) -> + explain_actual_type ctx j pt | CantApplyBadType (t, rator, randl) -> - explain_cant_apply_bad_type k ctx t rator randl + explain_cant_apply_bad_type ctx t rator randl | CantApplyNonFunctional (rator, randl) -> - explain_cant_apply_not_functional k ctx rator randl + explain_cant_apply_not_functional ctx rator randl | IllFormedRecBody (i, lna, vdefj, vargs) -> - explain_ill_formed_rec_body k ctx i lna vdefj vargs + explain_ill_formed_rec_body ctx i lna vdefj vargs | IllTypedRecBody (i, lna, vdefj, vargs) -> - explain_ill_typed_rec_body k ctx i lna vdefj vargs + explain_ill_typed_rec_body ctx i lna vdefj vargs + | WrongCaseInfo (ind,ci) -> + explain_wrong_case_info ctx ind ci (* | NotInductive c -> - explain_not_inductive k ctx c + explain_not_inductive ctx c *) let explain_pretype_error ctx = function | MlCase (mes,_,_) -> - explain_ml_case CCI ctx mes + explain_ml_case ctx mes | CantFindCaseType c -> - explain_cant_find_case_type CCI ctx c + explain_cant_find_case_type ctx c | OccurCheck (n,c) -> - explain_occur_check CCI ctx n c + explain_occur_check ctx n c | NotClean (n,c) -> - explain_not_clean CCI ctx n c + explain_not_clean ctx n c | VarNotFound id -> - explain_var_not_found CCI ctx id + explain_var_not_found ctx id | UnexpectedType (actual,expected) -> - explain_unexpected_type CCI ctx actual expected + explain_unexpected_type ctx actual expected | NotProduct c -> - explain_not_product CCI ctx c + explain_not_product ctx c (* Refiner errors *) @@ -381,19 +401,19 @@ let explain_refiner_error = function (* Inductive errors *) -let error_non_strictly_positive k env c v = +let error_non_strictly_positive env c v = let pc = prterm_env env c in let pv = prterm_env env v in [< 'sTR "Non strictly positive occurrence of "; pv; 'sTR " in"; 'bRK(1,1); pc >] -let error_ill_formed_inductive k env c v = +let error_ill_formed_inductive env c v = let pc = prterm_env env c in let pv = prterm_env env v in [< 'sTR "Not enough arguments applied to the "; pv; 'sTR " in"; 'bRK(1,1); pc >] -let error_ill_formed_constructor k env c v = +let error_ill_formed_constructor env c v = let pc = prterm_env env c in let pv = prterm_env env v in [< 'sTR "The conclusion of"; 'bRK(1,1); pc; 'bRK(1,1); @@ -407,7 +427,7 @@ let str_of_nth n = | 3 -> "rd" | _ -> "th") -let error_bad_ind_parameters k env c n v1 v2 = +let error_bad_ind_parameters env c n v1 v2 = let pc = prterm_env_at_top env c in let pv1 = prterm_env env v1 in let pv2 = prterm_env env v2 in @@ -446,16 +466,17 @@ let error_not_mutual_in_scheme () = let explain_inductive_error = function (* These are errors related to inductive constructions *) - | NonPos (env,c,v) -> error_non_strictly_positive CCI env c v - | NotEnoughArgs (env,c,v) -> error_ill_formed_inductive CCI env c v - | NotConstructor (env,c,v) -> error_ill_formed_constructor CCI env c v - | NonPar (env,c,n,v1,v2) -> error_bad_ind_parameters CCI env c n v1 v2 + | NonPos (env,c,v) -> error_non_strictly_positive env c v + | NotEnoughArgs (env,c,v) -> error_ill_formed_inductive env c v + | NotConstructor (env,c,v) -> error_ill_formed_constructor env c v + | NonPar (env,c,n,v1,v2) -> error_bad_ind_parameters env c n v1 v2 | SameNamesTypes id -> error_same_names_types id | SameNamesConstructors (id,cid) -> error_same_names_constructors id cid | NotAnArity id -> error_not_an_arity id | BadEntry -> error_bad_entry () (* These are errors related to recursors *) - | NotAllowedCaseAnalysis (dep,k,i) -> error_not_allowed_case_analysis dep k i + | NotAllowedCaseAnalysis (dep,k,i) -> + error_not_allowed_case_analysis dep k i | BadInduction (dep,indid,kind) -> error_bad_induction dep indid kind | NotMutualInScheme -> error_not_mutual_in_scheme () diff --git a/toplevel/himsg.mli b/toplevel/himsg.mli index 0c7c15eab..754d9b588 100644 --- a/toplevel/himsg.mli +++ b/toplevel/himsg.mli @@ -21,7 +21,7 @@ open Logic (* This module provides functions to explain the type errors. *) -val explain_type_error : path_kind -> env -> type_error -> std_ppcmds +val explain_type_error : env -> type_error -> std_ppcmds val explain_pretype_error : env -> pretype_error -> std_ppcmds diff --git a/toplevel/minicoq.ml b/toplevel/minicoq.ml index b4affe6c1..3ad4ab41c 100644 --- a/toplevel/minicoq.ml +++ b/toplevel/minicoq.ml @@ -36,12 +36,12 @@ let lookup_named id = let args sign = Array.of_list (instance_from_section_context sign) let rec globalize bv c = match kind_of_term c with - | IsVar id -> lookup_named id bv - | IsConst (sp, _) -> + | Var id -> lookup_named id bv + | Const (sp, _) -> let cb = lookup_constant sp !env in mkConst (sp, args cb.const_hyps) - | IsMutInd (sp,_ as spi, _) -> + | Ind (sp,_ as spi, _) -> let mib = lookup_mind sp !env in mkMutInd (spi, args mib.mind_hyps) - | IsMutConstruct ((sp,_),_ as spc, _) -> + | Construct ((sp,_),_ as spc, _) -> let mib = lookup_mind sp !env in mkMutConstruct (spc, args mib.mind_hyps) | _ -> map_constr_with_named_binders (fun na l -> na::l) globalize bv c diff --git a/toplevel/mltop.ml4 b/toplevel/mltop.ml4 index 378ab7412..6f2679c8c 100644 --- a/toplevel/mltop.ml4 +++ b/toplevel/mltop.ml4 @@ -170,7 +170,8 @@ let add_rec_path dir coq_dirpath = let prefix = Names.repr_dirpath coq_dirpath in if dirs <> [] then let convert_dirs (lp,cp) = - (lp,Names.make_dirpath (prefix@(List.map convert_string cp))) in + (lp,Names.make_dirpath + ((List.map convert_string (List.rev cp))@prefix)) in let dirs = map_succeed convert_dirs dirs in begin List.iter (fun lpe -> add_ml_dir (fst lpe)) dirs; diff --git a/toplevel/record.ml b/toplevel/record.ml index a8f90e3ec..896a00837 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -12,12 +12,17 @@ open Pp open Util open Names open Term +open Termops open Environ open Declarations open Declare open Coqast open Astterm open Command +open Inductive +open Safe_typing +open Nametab +open Indtypes (********** definition d'un record (structure) **************) @@ -63,7 +68,7 @@ let typecheck_params_and_field ps fs = type record_error = | MissingProj of identifier * identifier list - | BadTypedProj of identifier * path_kind * env * Type_errors.type_error + | BadTypedProj of identifier * env * Type_errors.type_error let warning_or_error coe err = let st = match err with @@ -72,33 +77,33 @@ let warning_or_error coe err = [< 'sTR(string_of_id fi); 'sTR" cannot be defined because the projection"; 'sTR s; 'sPC; prlist_with_sep pr_coma pr_id projs; 'sPC; 'sTR have; 'sTR "n't." >] - | BadTypedProj (fi,k,ctx,te) -> + | BadTypedProj (fi,ctx,te) -> [<'sTR (string_of_id fi); 'sTR" cannot be defined for the following reason:"; - 'fNL; 'sTR " "; hOV 2 (Himsg.explain_type_error k ctx te) >] + 'fNL; 'sTR " "; hOV 2 (Himsg.explain_type_error ctx te) >] in if coe then errorlabstrm "structure" st; pPNL (hOV 0 [< 'sTR"Warning: "; st >]) (* We build projections *) let declare_projections indsp coers fields = - let mispec = Global.lookup_mind_specif indsp in - let paramdecls = Inductive.mis_params_ctxt mispec in + let env = Global.env() in + let (mib,mip) = Global.lookup_inductive indsp in + let paramdecls = mip.mind_params_ctxt in let paramdecls = List.map (fun (na,b,t) -> match na with Name id -> (id,b,t) | _ -> assert false) paramdecls in - let r = mkMutInd indsp in + let r = mkInd indsp in let paramargs = List.rev (List.map (fun (id,_,_) -> mkVar id) paramdecls) in let rp = applist (r, paramargs) in - let x = Environ.named_hd (Global.env()) r Anonymous in + let x = Termops.named_hd (Global.env()) r Anonymous in let proj_args = (* Rel 1 refers to "x" *) paramargs@[mkRel 1] in let (sp_projs,_,_) = List.fold_left2 (fun (sp_projs,ids_not_ok,subst) coe (fi,optci,ti) -> let fv_ti = match optci with - | Some ci -> - global_vars (Global.env()) ci (* Type is then meaningless *) - | None -> global_vars (Global.env()) ti in + | Some ci -> global_vars env ci (* Type is then meaningless *) + | None -> global_vars env ti in let bad_projs = (list_intersect ids_not_ok fv_ti) in if bad_projs <> [] then begin warning_or_error coe (MissingProj (fi,bad_projs)); @@ -109,10 +114,9 @@ let declare_projections indsp coers fields = | None -> let p = mkLambda (x, rp, replace_vars subst ti) in let branch = it_mkNamedLambda_or_LetIn (mkVar fi) fields in - let ci = Inductive.make_case_info - (Global.lookup_mind_specif (destMutInd r)) + let ci = Inductiveops.make_case_info env indsp (Some PrintLet) [| RegularPat |] in - mkMutCase (ci, p, mkRel 1, [|branch|]) in + mkCase (ci, p, mkRel 1, [|branch|]) in let proj = it_mkNamedLambda_or_LetIn (mkLambda (x, rp, body)) paramdecls in let name = @@ -123,8 +127,8 @@ let declare_projections indsp coers fields = let sp = declare_constant fi (ConstantEntry cie,NeverDischarge) in Some sp - with Type_errors.TypeError (k,ctx,te) -> begin - warning_or_error coe (BadTypedProj (fi,k,ctx,te)); + with Type_errors.TypeError (ctx,te) -> begin + warning_or_error coe (BadTypedProj (fi,ctx,te)); None end in match name with @@ -147,8 +151,8 @@ let degenerate_decl env = (List.fold_right (fun (id,c,t) (ids,env) -> let d = match c with - | None -> LocalAssum (subst_vars ids t) - | Some c -> LocalDef (subst_vars ids c) in + | None -> Typeops.LocalAssum (subst_vars ids t) + | Some c -> Typeops.LocalDef (subst_vars ids c) in (id::ids, (id,d)::env)) env ([],[])) diff --git a/toplevel/recordobj.ml b/toplevel/recordobj.ml index ebdf2bce8..3e2ab8c10 100755 --- a/toplevel/recordobj.ml +++ b/toplevel/recordobj.ml @@ -17,37 +17,38 @@ open Lib open Declare open Recordops open Classops +open Nametab (***** object definition ******) let typ_lams_of t = let rec aux acc c = match kind_of_term c with - | IsLambda (x,c1,c2) -> aux (c1::acc) c2 - | IsCast (c,_) -> aux acc c + | Lambda (x,c1,c2) -> aux (c1::acc) c2 + | Cast (c,_) -> aux acc c | t -> acc,t in aux [] t let objdef_err ref = errorlabstrm "object_declare" - [< pr_id (basename (Global.sp_of_global ref)); + [< pr_id (Termops.id_of_global (Global.env()) ref); 'sTR" is not a structure object" >] let objdef_declare ref = let sp = match ref with ConstRef sp -> sp | _ -> objdef_err ref in let env = Global.env () in let v = constr_of_reference ref in - let vc = match constant_opt_value env sp with + let vc = match Environ.constant_opt_value env sp with | Some vc -> vc | None -> objdef_err ref in let lt,t = decompose_lam vc in let lt = List.rev (List.map snd lt) in let f,args = match kind_of_term t with - | IsApp (f,args) -> f,args + | App (f,args) -> f,args | _ -> objdef_err ref in let { s_PARAM = p; s_PROJ = lpj } = try (find_structure (match kind_of_term f with - | IsMutConstruct (indsp,1) -> indsp + | Construct (indsp,1) -> indsp | _ -> objdef_err ref)) with Not_found -> objdef_err ref in let params, projs = @@ -62,7 +63,7 @@ let objdef_declare ref = match spopt with | None -> l | Some proji_sp -> - let c, args = decomp_app t in + let c, args = decompose_app t in try (ConstRef proji_sp, reference_of_constr c, args) :: l with Not_found -> l) [] lps in diff --git a/toplevel/recordobj.mli b/toplevel/recordobj.mli index 90eadf404..10354968f 100755 --- a/toplevel/recordobj.mli +++ b/toplevel/recordobj.mli @@ -8,6 +8,4 @@ (* $Id$ *) -open Names - -val objdef_declare : global_reference -> unit +val objdef_declare : Nametab.global_reference -> unit diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index 98414bf53..8a1186086 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -182,7 +182,7 @@ let compile verbosely f = let m = Names.id_of_string s in let _,longf = find_file_in_path (Library.get_load_path ()) (f^".v") in let ldir0 = Library.find_logical_path (Filename.dirname longf) in - let ldir = Names.extend_dirpath ldir0 m in + let ldir = Nameops.extend_dirpath ldir0 m in Lib.start_module ldir; load_vernac verbosely longf; let mid = Lib.end_module m in diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 187391e24..8ccdd3976 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -16,6 +16,7 @@ open Util open Options open System open Names +open Nameops open Term open Pfedit open Tacmach @@ -34,6 +35,8 @@ open Tactic_debug open Command open Goptions open Declare +open Nametab +open Safe_typing (* Dans join_binders, s'il y a un "?", on perd l'info qu'il est partagé *) let join_binders binders = @@ -119,7 +122,7 @@ let print_located_qualid qid = try let ref = Nametab.locate qid in mSG - [< 'sTR (string_of_path (sp_of_global (Global.env()) ref)); 'fNL >] + [< pr_id (Termops.id_of_global (Global.env()) ref); 'fNL >] with Not_found -> try mSG @@ -193,7 +196,7 @@ let _ = add "ADDPATH" (function | [VARG_STRING dir] -> - (fun () -> Mltop.add_path dir Nametab.default_root_prefix) + (fun () -> Mltop.add_path dir Nameops.default_root_prefix) | [VARG_STRING dir ; VARG_QUALID alias] -> let aliasdir,aliasname = Nametab.repr_qualid alias in (fun () -> Mltop.add_path dir (extend_dirpath aliasdir aliasname)) @@ -210,7 +213,7 @@ let _ = add "RECADDPATH" (function | [VARG_STRING dir] -> - (fun () -> Mltop.add_rec_path dir Nametab.default_root_prefix) + (fun () -> Mltop.add_rec_path dir Nameops.default_root_prefix) | [VARG_STRING dir ; VARG_QUALID alias] -> let aliasdir,aliasname = Nametab.repr_qualid alias in (fun () ->Mltop.add_rec_path dir (extend_dirpath aliasdir aliasname)) @@ -588,7 +591,7 @@ let _ = | VARG_QUALID qid -> (match Nametab.global dummy_loc qid with | ConstRef sp -> Opaque.set_transparent_const sp - | VarRef sp -> Opaque.set_transparent_var (basename sp) + | VarRef id -> Opaque.set_transparent_var id | _ -> error "cannot set an inductive type or a constructor as transparent") | _ -> bad_vernac_args "TRANSPARENT") @@ -602,7 +605,7 @@ let _ = | VARG_QUALID qid -> (match Nametab.global dummy_loc qid with | ConstRef sp -> Opaque.set_opaque_const sp - | VarRef sp -> Opaque.set_opaque_var (basename sp) + | VarRef id -> Opaque.set_opaque_var id | _ -> error "cannot set an inductive type or a constructor as opaque") | _ -> bad_vernac_args "OPAQUE") @@ -686,8 +689,8 @@ let _ = let (pfterm,_) = extract_open_pftreestate pts in let message = try - Typeops.control_only_guard (Evarutil.evar_env pf.goal) - Evd.empty pfterm; + Inductiveops.control_only_guard (Evarutil.evar_env pf.goal) + pfterm; [< 'sTR "The condition holds up to here" >] with UserError(_,s) -> [< 'sTR ("Condition violated : ") ;s >] @@ -845,8 +848,7 @@ let _ = save_named opacity else let csr = interp_type Evd.empty (Global.env ()) com - and (_,({const_entry_body = pft; - const_entry_type = _},_)) = cook_proof () in + and (_,({const_entry_body = pft},_)) = cook_proof () in let cutt = vernac_tactic ("Cut",[Constr csr]) and exat = vernac_tactic ("Exact",[Constr pft]) in delete_proof id; @@ -973,8 +975,9 @@ let _ = (fun () -> let (evmap, env) = get_current_context_of_args g in let c = interp_constr evmap env c in - let j = Safe_typing.typing_in_unsafe_env env c in - mSG (print_safe_judgment env j)) + let (j,cst) = Typeops.infer env c in + let _ = Environ.add_constraints cst env in + mSG (print_judgment env j)) | _ -> bad_vernac_args "Check") @@ -1294,9 +1297,9 @@ let _ = let cl_of_qualid qid = match Nametab.repr_qualid qid with - | d, id when string_of_id id = "FUNCLASS" & is_empty_dirpath d -> + | d, id when string_of_id id = "FUNCLASS" & repr_dirpath d = [] -> Classops.CL_FUN - | d, id when string_of_id id = "SORTCLASS" & is_empty_dirpath d -> + | d, id when string_of_id id = "SORTCLASS" & repr_dirpath d = [] -> Classops.CL_SORT | _ -> Class.class_of_ref (Nametab.global dummy_loc qid) @@ -1316,7 +1319,7 @@ let _ = let source = cl_of_qualid qids in fun () -> if isid then match Nametab.repr_qualid qid with - | d, id when is_empty_dirpath d -> + | d, id when repr_dirpath d = [] -> Class.try_add_new_identity_coercion id stre source target | _ -> bad_vernac_args "COERCION" else |