From e88e0b2140bdd2d194a52bc09f8338b5667d0f92 Mon Sep 17 00:00:00 2001 From: herbelin Date: Thu, 14 Nov 2002 18:37:54 +0000 Subject: Réforme de l'interprétation des termes : - Le parsing se fait maintenant via "constr_expr" au lieu de "Coqast.t" - "Coqast.t" reste pour l'instant pour le pretty-printing. Un deuxième pretty-printer dans ppconstr.ml est basé sur "constr_expr". - Nouveau répertoire "interp" qui hérite de la partie interprétation qui se trouvait avant dans "parsing" (constrintern.ml remplace astterm.ml; constrextern.ml est l'équivalent de termast.ml pour le nouveau printer; topconstr.ml; contient la définition de "constr_expr"; modintern.ml remplace astmod.ml) - Libnames.reference tend à remplacer Libnames.qualid MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/coq/trunk@3235 85f007b7-540e-0410-9357-904b9bb8a0f7 --- .depend | 1636 ++++++++++++++++++----------------- .depend.camlp4 | 24 +- CHANGES | 7 + Makefile | 466 +++++----- contrib/cc/cctac.ml4 | 6 +- contrib/correctness/past.mli | 7 +- contrib/correctness/pcic.ml | 43 +- contrib/correctness/perror.mli | 2 +- contrib/correctness/pmisc.ml | 18 +- contrib/correctness/pmisc.mli | 8 +- contrib/correctness/psyntax.ml4 | 50 +- contrib/correctness/psyntax.mli | 5 +- contrib/correctness/ptyping.ml | 5 +- contrib/correctness/ptyping.mli | 3 +- contrib/extraction/extract_env.mli | 6 +- contrib/extraction/g_extraction.ml4 | 16 +- contrib/extraction/table.mli | 6 +- contrib/field/field.ml4 | 4 +- contrib/fourier/fourierR.ml | 4 +- contrib/interface/blast.ml | 1 - contrib/interface/centaur.ml4 | 10 +- contrib/interface/ctast.ml | 6 +- contrib/interface/dad.ml | 78 +- contrib/interface/dad.mli | 4 +- contrib/interface/debug_tac.ml4 | 4 +- contrib/interface/name_to_ast.ml | 12 +- contrib/interface/name_to_ast.mli | 2 +- contrib/interface/parse.ml | 2 +- contrib/interface/pbp.ml | 38 +- contrib/interface/showproof.ml | 37 +- contrib/interface/showproof.mli | 1 - contrib/interface/xlate.ml | 119 +-- contrib/ring/ring.ml | 2 +- contrib/xml/cic2acic.ml | 2 +- contrib/xml/xmlcommand.ml | 43 +- contrib/xml/xmlcommand.mli | 2 +- contrib/xml/xmlentries.ml4 | 4 +- dev/base_include | 15 +- dev/top_printers.ml | 4 +- doc/newsyntax.tex | 2 + interp/constrextern.ml | 360 ++++++++ interp/constrextern.mli | 49 ++ interp/constrintern.ml | 653 ++++++++++++++ interp/constrintern.mli | 87 ++ interp/coqlib.ml | 285 ++++++ interp/coqlib.mli | 133 +++ interp/genarg.ml | 185 ++++ interp/genarg.mli | 213 +++++ interp/modintern.ml | 103 +++ interp/modintern.mli | 24 + interp/ppextend.ml | 57 ++ interp/ppextend.mli | 47 + interp/symbols.ml | 331 +++++++ interp/symbols.mli | 77 ++ interp/syntax_def.ml | 72 ++ interp/syntax_def.mli | 23 + interp/topconstr.ml | 300 +++++++ interp/topconstr.mli | 133 +++ kernel/closure.ml | 4 - kernel/closure.mli | 4 - kernel/modops.ml | 11 +- kernel/modops.mli | 5 +- kernel/names.ml | 5 + kernel/names.mli | 5 + kernel/term.ml | 4 +- kernel/term.mli | 4 +- lib/bignat.ml | 9 + lib/bignat.mli | 6 + lib/util.ml | 1 + lib/util.mli | 1 + library/declare.ml | 31 +- library/declare.mli | 13 +- library/goptions.ml | 4 +- library/goptions.mli | 12 +- library/lib.ml | 4 +- library/lib.mli | 3 +- library/libnames.ml | 34 + library/libnames.mli | 21 +- library/nameops.ml | 8 +- library/nameops.mli | 3 +- library/nametab.ml | 15 +- library/nametab.mli | 4 +- parsing/argextend.ml4 | 10 +- parsing/ast.ml | 251 +----- parsing/ast.mli | 72 +- parsing/astmod.ml | 133 --- parsing/astmod.mli | 25 - parsing/astterm.ml | 949 -------------------- parsing/astterm.mli | 101 --- parsing/coqast.ml | 86 +- parsing/coqast.mli | 62 +- parsing/coqlib.ml | 285 ------ parsing/coqlib.mli | 133 --- parsing/egrammar.ml | 160 ++-- parsing/egrammar.mli | 9 +- parsing/esyntax.ml | 37 +- parsing/esyntax.mli | 6 +- parsing/extend.ml | 101 ++- parsing/extend.mli | 61 +- parsing/g_basevernac.ml4 | 109 ++- parsing/g_cases.ml4 | 59 +- parsing/g_constr.ml4 | 349 ++++---- parsing/g_ltac.ml4 | 49 +- parsing/g_minicoq.ml4 | 2 - parsing/g_module.ml4 | 66 +- parsing/g_prim.ml4 | 47 +- parsing/g_proofs.ml4 | 33 +- parsing/g_rsyntax.ml | 57 +- parsing/g_tactic.ml4 | 72 +- parsing/g_vernac.ml4 | 157 ++-- parsing/g_zsyntax.ml | 69 +- parsing/g_zsyntax.mli | 5 +- parsing/genarg.ml | 181 ---- parsing/genarg.mli | 208 ----- parsing/pcoq.ml4 | 244 +++--- parsing/pcoq.mli | 106 ++- parsing/ppconstr.ml | 248 +++++- parsing/ppconstr.mli | 28 +- parsing/pptactic.ml | 54 +- parsing/pptactic.mli | 20 +- parsing/prettyp.ml | 6 +- parsing/prettyp.mli | 8 +- parsing/printer.ml | 2 +- parsing/q_coqast.ml4 | 87 +- parsing/search.ml | 1 - parsing/symbols.ml | 320 ------- parsing/symbols.mli | 60 -- parsing/tacextend.ml4 | 8 +- parsing/termast.ml | 19 +- parsing/vernacextend.ml4 | 7 +- pretyping/cases.ml | 6 +- pretyping/coercion.ml | 2 +- pretyping/detyping.ml | 29 +- pretyping/evarconv.ml | 7 +- pretyping/evarutil.ml | 2 +- pretyping/indrec.ml | 4 +- pretyping/inductiveops.ml | 4 +- pretyping/inductiveops.mli | 4 +- pretyping/pattern.ml | 22 +- pretyping/pattern.mli | 3 +- pretyping/pretyping.ml | 29 +- pretyping/pretyping.mli | 4 + pretyping/rawterm.ml | 85 +- pretyping/rawterm.mli | 30 +- pretyping/syntax_def.ml | 81 -- pretyping/syntax_def.mli | 23 - proofs/evar_refiner.ml | 4 +- proofs/evar_refiner.mli | 2 +- proofs/pfedit.ml | 29 +- proofs/pfedit.mli | 9 +- proofs/proof_trees.ml | 119 --- proofs/proof_type.ml | 8 +- proofs/proof_type.mli | 8 +- proofs/refiner.ml | 2 +- proofs/tacexpr.ml | 53 +- proofs/tacmach.ml | 225 +---- proofs/tacmach.mli | 35 +- scripts/coqmktop.ml | 3 +- syntax/PPCases.v | 1 + syntax/PPConstr.v | 17 +- tactics/auto.ml | 14 +- tactics/auto.mli | 2 +- tactics/dhyp.ml | 6 +- tactics/dhyp.mli | 2 +- tactics/eauto.ml4 | 5 +- tactics/elim.ml | 2 +- tactics/equality.ml | 64 +- tactics/extraargs.mli | 5 +- tactics/extratactics.ml4 | 13 +- tactics/hiddentac.ml | 2 +- tactics/leminv.ml | 4 +- tactics/leminv.mli | 3 +- tactics/setoid_replace.ml | 5 +- tactics/setoid_replace.mli | 6 +- tactics/tacinterp.ml | 169 ++-- tactics/tacinterp.mli | 8 +- tactics/tactics.ml | 11 +- tactics/tactics.mli | 9 +- tactics/tauto.ml4 | 2 +- theories/Reals/Rsyntax.v | 11 +- tools/coq_makefile.ml4 | 3 +- toplevel/cerrors.ml | 2 +- toplevel/cerrors.mli | 3 +- toplevel/class.mli | 4 +- toplevel/command.ml | 38 +- toplevel/command.mli | 26 +- toplevel/metasyntax.ml | 459 ++++++---- toplevel/metasyntax.mli | 17 +- toplevel/record.ml | 14 +- toplevel/record.mli | 3 +- toplevel/recordobj.mli | 2 +- toplevel/toplevel.ml | 6 +- toplevel/vernac.ml | 10 +- toplevel/vernac.mli | 6 +- toplevel/vernacentries.ml | 75 +- toplevel/vernacentries.mli | 5 +- toplevel/vernacexpr.ml | 139 ++- 197 files changed, 6791 insertions(+), 6423 deletions(-) create mode 100644 interp/constrextern.ml create mode 100644 interp/constrextern.mli create mode 100644 interp/constrintern.ml create mode 100644 interp/constrintern.mli create mode 100644 interp/coqlib.ml create mode 100644 interp/coqlib.mli create mode 100644 interp/genarg.ml create mode 100644 interp/genarg.mli create mode 100644 interp/modintern.ml create mode 100644 interp/modintern.mli create mode 100644 interp/ppextend.ml create mode 100644 interp/ppextend.mli create mode 100644 interp/symbols.ml create mode 100644 interp/symbols.mli create mode 100644 interp/syntax_def.ml create mode 100644 interp/syntax_def.mli create mode 100644 interp/topconstr.ml create mode 100644 interp/topconstr.mli delete mode 100644 parsing/astmod.ml delete mode 100644 parsing/astmod.mli delete mode 100644 parsing/astterm.ml delete mode 100644 parsing/astterm.mli delete mode 100644 parsing/coqlib.ml delete mode 100644 parsing/coqlib.mli delete mode 100644 parsing/genarg.ml delete mode 100644 parsing/genarg.mli delete mode 100644 parsing/symbols.ml delete mode 100644 parsing/symbols.mli delete mode 100644 pretyping/syntax_def.ml delete mode 100644 pretyping/syntax_def.mli diff --git a/.depend b/.depend index a547d22ce..29310c9ba 100644 --- a/.depend +++ b/.depend @@ -1,3 +1,26 @@ +interp/constrextern.cmi: kernel/environ.cmi library/libnames.cmi \ + kernel/names.cmi library/nametab.cmi pretyping/pattern.cmi \ + pretyping/rawterm.cmi kernel/sign.cmi kernel/term.cmi \ + pretyping/termops.cmi interp/topconstr.cmi +interp/constrintern.cmi: parsing/coqast.cmi kernel/environ.cmi \ + pretyping/evd.cmi library/impargs.cmi library/libnames.cmi \ + kernel/names.cmi pretyping/pattern.cmi pretyping/rawterm.cmi \ + kernel/sign.cmi kernel/term.cmi interp/topconstr.cmi +interp/coqlib.cmi: library/libnames.cmi kernel/names.cmi library/nametab.cmi \ + pretyping/pattern.cmi kernel/term.cmi +interp/genarg.cmi: pretyping/evd.cmi library/libnames.cmi kernel/names.cmi \ + pretyping/rawterm.cmi kernel/term.cmi interp/topconstr.cmi lib/util.cmi +interp/modintern.cmi: kernel/declarations.cmi kernel/entries.cmi \ + kernel/environ.cmi interp/topconstr.cmi +interp/ppextend.cmi: kernel/names.cmi lib/pp.cmi +interp/symbols.cmi: lib/bignat.cmi library/libnames.cmi kernel/names.cmi \ + library/nametab.cmi lib/pp.cmi interp/ppextend.cmi pretyping/rawterm.cmi \ + interp/topconstr.cmi lib/util.cmi +interp/syntax_def.cmi: kernel/names.cmi pretyping/rawterm.cmi \ + interp/topconstr.cmi +interp/topconstr.cmi: lib/bignat.cmi lib/dyn.cmi library/libnames.cmi \ + kernel/names.cmi lib/pp.cmi pretyping/rawterm.cmi kernel/term.cmi \ + lib/util.cmi kernel/closure.cmi: kernel/environ.cmi kernel/esubst.cmi kernel/names.cmi \ lib/pp.cmi kernel/term.cmi kernel/conv_oracle.cmi: kernel/closure.cmi kernel/names.cmi @@ -18,7 +41,7 @@ kernel/inductive.cmi: kernel/declarations.cmi kernel/environ.cmi \ kernel/mod_typing.cmi: kernel/declarations.cmi kernel/entries.cmi \ kernel/environ.cmi kernel/modops.cmi: kernel/declarations.cmi kernel/entries.cmi \ - kernel/environ.cmi kernel/names.cmi kernel/univ.cmi + kernel/environ.cmi kernel/names.cmi kernel/univ.cmi lib/util.cmi kernel/names.cmi: lib/pp.cmi lib/predicate.cmi kernel/reduction.cmi: kernel/environ.cmi kernel/sign.cmi kernel/term.cmi \ kernel/univ.cmi @@ -36,6 +59,7 @@ kernel/type_errors.cmi: kernel/environ.cmi kernel/names.cmi kernel/term.cmi kernel/typeops.cmi: kernel/entries.cmi kernel/environ.cmi kernel/names.cmi \ kernel/sign.cmi kernel/term.cmi kernel/univ.cmi kernel/univ.cmi: kernel/names.cmi lib/pp.cmi +lib/bignat.cmi: lib/pp.cmi lib/pp.cmi: lib/pp_control.cmi lib/rtree.cmi: lib/pp.cmi lib/system.cmi: lib/pp.cmi @@ -59,50 +83,42 @@ library/goptions.cmi: library/libnames.cmi kernel/names.cmi \ library/impargs.cmi: kernel/environ.cmi library/libnames.cmi kernel/names.cmi \ library/nametab.cmi kernel/term.cmi library/lib.cmi: library/libnames.cmi library/libobject.cmi kernel/names.cmi \ - library/summary.cmi -library/libnames.cmi: kernel/names.cmi lib/pp.cmi lib/predicate.cmi + library/summary.cmi lib/util.cmi +library/libnames.cmi: kernel/names.cmi lib/pp.cmi lib/predicate.cmi \ + kernel/term.cmi lib/util.cmi library/libobject.cmi: library/libnames.cmi kernel/names.cmi library/library.cmi: library/libnames.cmi library/libobject.cmi \ kernel/names.cmi lib/pp.cmi lib/system.cmi lib/util.cmi -library/nameops.cmi: kernel/environ.cmi kernel/names.cmi lib/pp.cmi \ - kernel/term.cmi +library/nameops.cmi: kernel/names.cmi lib/pp.cmi library/nametab.cmi: library/libnames.cmi kernel/names.cmi lib/pp.cmi \ kernel/sign.cmi lib/util.cmi library/summary.cmi: library/libnames.cmi kernel/names.cmi -parsing/ast.cmi: parsing/coqast.cmi lib/dyn.cmi parsing/genarg.cmi \ - library/libnames.cmi kernel/names.cmi lib/pp.cmi lib/util.cmi -parsing/astmod.cmi: parsing/coqast.cmi kernel/declarations.cmi \ - kernel/entries.cmi kernel/environ.cmi pretyping/evd.cmi kernel/names.cmi -parsing/astterm.cmi: parsing/coqast.cmi kernel/environ.cmi pretyping/evd.cmi \ - library/impargs.cmi library/libnames.cmi kernel/names.cmi \ - pretyping/pattern.cmi pretyping/rawterm.cmi kernel/sign.cmi \ - kernel/term.cmi lib/util.cmi -parsing/coqast.cmi: lib/bignat.cmi lib/dyn.cmi library/libnames.cmi \ - kernel/names.cmi pretyping/rawterm.cmi kernel/term.cmi lib/util.cmi -parsing/coqlib.cmi: library/libnames.cmi kernel/names.cmi library/nametab.cmi \ - pretyping/pattern.cmi kernel/term.cmi +parsing/ast.cmi: parsing/coqast.cmi lib/dyn.cmi interp/genarg.cmi \ + library/libnames.cmi kernel/names.cmi lib/pp.cmi interp/topconstr.cmi \ + lib/util.cmi +parsing/coqast.cmi: lib/dyn.cmi library/libnames.cmi kernel/names.cmi \ + lib/util.cmi parsing/egrammar.cmi: parsing/ast.cmi parsing/coqast.cmi parsing/extend.cmi \ - parsing/genarg.cmi kernel/names.cmi proofs/tacexpr.cmo \ - toplevel/vernacexpr.cmo + interp/genarg.cmi kernel/names.cmi pretyping/rawterm.cmi \ + proofs/tacexpr.cmo interp/topconstr.cmi toplevel/vernacexpr.cmo parsing/esyntax.cmi: parsing/ast.cmi parsing/coqast.cmi parsing/extend.cmi \ - parsing/genarg.cmi lib/pp.cmi parsing/symbols.cmi toplevel/vernacexpr.cmo -parsing/extend.cmi: parsing/ast.cmi parsing/coqast.cmi kernel/names.cmi \ - lib/pp.cmi + lib/pp.cmi interp/ppextend.cmi interp/symbols.cmi interp/topconstr.cmi \ + toplevel/vernacexpr.cmo +parsing/extend.cmi: parsing/ast.cmi parsing/coqast.cmi interp/genarg.cmi \ + kernel/names.cmi lib/pp.cmi interp/ppextend.cmi interp/topconstr.cmi \ + lib/util.cmi parsing/g_minicoq.cmi: kernel/environ.cmi kernel/names.cmi lib/pp.cmi \ kernel/term.cmi -parsing/g_zsyntax.cmi: parsing/coqast.cmi -parsing/genarg.cmi: kernel/closure.cmi parsing/coqast.cmi pretyping/evd.cmi \ - library/libnames.cmi kernel/names.cmi pretyping/rawterm.cmi \ - kernel/term.cmi lib/util.cmi +parsing/g_zsyntax.cmi: interp/topconstr.cmi lib/util.cmi parsing/pcoq.cmi: parsing/ast.cmi parsing/coqast.cmi library/decl_kinds.cmo \ - parsing/genarg.cmi library/libnames.cmi kernel/names.cmi \ - pretyping/rawterm.cmi proofs/tacexpr.cmo lib/util.cmi \ - toplevel/vernacexpr.cmo + parsing/extend.cmi interp/genarg.cmi library/libnames.cmi \ + kernel/names.cmi pretyping/rawterm.cmi proofs/tacexpr.cmo \ + interp/topconstr.cmi lib/util.cmi toplevel/vernacexpr.cmo parsing/ppconstr.cmi: parsing/coqast.cmi kernel/environ.cmi \ - parsing/extend.cmi parsing/genarg.cmi library/libnames.cmi \ - parsing/pcoq.cmi lib/pp.cmi pretyping/rawterm.cmi proofs/tacexpr.cmo \ - kernel/term.cmi -parsing/pptactic.cmi: parsing/egrammar.cmi parsing/genarg.cmi lib/pp.cmi \ + parsing/extend.cmi library/libnames.cmi kernel/names.cmi parsing/pcoq.cmi \ + lib/pp.cmi pretyping/rawterm.cmi proofs/tacexpr.cmo kernel/term.cmi \ + interp/topconstr.cmi +parsing/pptactic.cmi: parsing/egrammar.cmi interp/genarg.cmi lib/pp.cmi \ proofs/proof_type.cmi proofs/tacexpr.cmo parsing/prettyp.cmi: pretyping/classops.cmi kernel/environ.cmi \ library/impargs.cmi library/lib.cmi library/libnames.cmi kernel/names.cmi \ @@ -116,9 +132,6 @@ parsing/printer.cmi: kernel/environ.cmi library/libnames.cmi kernel/names.cmi \ parsing/printmod.cmi: kernel/names.cmi lib/pp.cmi parsing/search.cmi: kernel/environ.cmi library/libnames.cmi kernel/names.cmi \ library/nametab.cmi pretyping/pattern.cmi lib/pp.cmi kernel/term.cmi -parsing/symbols.cmi: lib/bignat.cmi parsing/extend.cmi library/libnames.cmi \ - kernel/names.cmi library/nametab.cmi lib/pp.cmi pretyping/rawterm.cmi \ - lib/util.cmi parsing/termast.cmi: parsing/coqast.cmi kernel/environ.cmi \ library/libnames.cmi kernel/names.cmi library/nametab.cmi \ pretyping/pattern.cmi pretyping/rawterm.cmi kernel/sign.cmi \ @@ -161,7 +174,8 @@ pretyping/pretyping.cmi: lib/dyn.cmi kernel/environ.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 library/libnames.cmi kernel/names.cmi \ - library/nametab.cmi kernel/sign.cmi kernel/term.cmi kernel/univ.cmi + library/nametab.cmi kernel/sign.cmi kernel/term.cmi kernel/univ.cmi \ + lib/util.cmi pretyping/recordops.cmi: pretyping/classops.cmi library/libnames.cmi \ library/libobject.cmi library/library.cmi kernel/names.cmi \ library/nametab.cmi kernel/term.cmi @@ -170,8 +184,6 @@ pretyping/reductionops.cmi: kernel/closure.cmi kernel/environ.cmi \ kernel/univ.cmi pretyping/retyping.cmi: kernel/environ.cmi pretyping/evd.cmi kernel/names.cmi \ kernel/term.cmi -pretyping/syntax_def.cmi: library/libnames.cmi kernel/names.cmi \ - pretyping/rawterm.cmi pretyping/tacred.cmi: kernel/closure.cmi kernel/environ.cmi pretyping/evd.cmi \ kernel/names.cmi pretyping/rawterm.cmi pretyping/reductionops.cmi \ kernel/term.cmi @@ -182,29 +194,28 @@ proofs/clenv.cmi: kernel/environ.cmi proofs/evar_refiner.cmi \ pretyping/evd.cmi kernel/names.cmi lib/pp.cmi pretyping/pretyping.cmi \ proofs/proof_type.cmi pretyping/rawterm.cmi pretyping/reductionops.cmi \ kernel/sign.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_type.cmi \ - proofs/refiner.cmi kernel/sign.cmi kernel/term.cmi +proofs/evar_refiner.cmi: kernel/environ.cmi pretyping/evd.cmi \ + kernel/names.cmi proofs/proof_type.cmi proofs/refiner.cmi kernel/sign.cmi \ + kernel/term.cmi interp/topconstr.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 library/decl_kinds.cmo \ - kernel/entries.cmi kernel/environ.cmi pretyping/evd.cmi kernel/names.cmi \ - lib/pp.cmi proofs/proof_type.cmi kernel/sign.cmi proofs/tacmach.cmi \ - kernel/term.cmi +proofs/pfedit.cmi: library/decl_kinds.cmo kernel/entries.cmi \ + kernel/environ.cmi pretyping/evd.cmi kernel/names.cmi lib/pp.cmi \ + kernel/sign.cmi proofs/tacexpr.cmo proofs/tacmach.cmi kernel/term.cmi \ + interp/topconstr.cmi lib/util.cmi proofs/proof_trees.cmi: kernel/environ.cmi pretyping/evd.cmi kernel/names.cmi \ lib/pp.cmi proofs/proof_type.cmi kernel/sign.cmi kernel/term.cmi \ lib/util.cmi -proofs/proof_type.cmi: kernel/closure.cmi library/decl_kinds.cmo \ - kernel/environ.cmi pretyping/evd.cmi parsing/genarg.cmi \ +proofs/proof_type.cmi: kernel/environ.cmi pretyping/evd.cmi interp/genarg.cmi \ library/libnames.cmi kernel/names.cmi pretyping/rawterm.cmi \ proofs/tacexpr.cmo kernel/term.cmi lib/util.cmi proofs/refiner.cmi: pretyping/evd.cmi lib/pp.cmi proofs/proof_trees.cmi \ proofs/proof_type.cmi kernel/sign.cmi proofs/tacexpr.cmo kernel/term.cmi -proofs/tacmach.cmi: kernel/closure.cmi parsing/coqast.cmi kernel/environ.cmi \ - pretyping/evd.cmi kernel/names.cmi lib/pp.cmi proofs/proof_trees.cmi \ - proofs/proof_type.cmi pretyping/rawterm.cmi kernel/reduction.cmi \ - proofs/refiner.cmi kernel/sign.cmi proofs/tacexpr.cmo \ - pretyping/tacred.cmi kernel/term.cmi +proofs/tacmach.cmi: kernel/environ.cmi pretyping/evd.cmi kernel/names.cmi \ + lib/pp.cmi proofs/proof_trees.cmi proofs/proof_type.cmi \ + pretyping/rawterm.cmi kernel/reduction.cmi proofs/refiner.cmi \ + kernel/sign.cmi proofs/tacexpr.cmo pretyping/tacred.cmi kernel/term.cmi \ + interp/topconstr.cmi proofs/tactic_debug.cmi: kernel/environ.cmi kernel/names.cmi \ proofs/proof_type.cmi proofs/tacexpr.cmo kernel/term.cmi tactics/auto.cmi: tactics/btermdn.cmi proofs/clenv.cmi kernel/environ.cmi \ @@ -217,8 +228,8 @@ tactics/autorewrite.cmi: proofs/tacexpr.cmo proofs/tacmach.cmi \ tactics/btermdn.cmi: pretyping/pattern.cmi kernel/term.cmi tactics/contradiction.cmi: kernel/names.cmi proofs/proof_type.cmi \ kernel/term.cmi -tactics/dhyp.cmi: parsing/genarg.cmi kernel/names.cmi proofs/tacexpr.cmo \ - proofs/tacmach.cmi +tactics/dhyp.cmi: kernel/names.cmi proofs/tacexpr.cmo proofs/tacmach.cmi \ + interp/topconstr.cmi tactics/elim.cmi: kernel/names.cmi proofs/proof_type.cmi \ pretyping/rawterm.cmi proofs/tacexpr.cmo proofs/tacmach.cmi \ tactics/tacticals.cmi kernel/term.cmi @@ -227,9 +238,9 @@ tactics/equality.cmi: kernel/environ.cmi pretyping/evd.cmi \ proofs/proof_type.cmi pretyping/rawterm.cmi kernel/sign.cmi \ proofs/tacexpr.cmo proofs/tacmach.cmi tactics/tacticals.cmi \ tactics/tactics.cmi kernel/term.cmi tactics/wcclausenv.cmi -tactics/extraargs.cmi: parsing/coqast.cmi parsing/pcoq.cmi \ - proofs/proof_type.cmi proofs/tacexpr.cmo kernel/term.cmi -tactics/extratactics.cmi: parsing/genarg.cmi kernel/names.cmi \ +tactics/extraargs.cmi: parsing/pcoq.cmi proofs/proof_type.cmi \ + proofs/tacexpr.cmo kernel/term.cmi interp/topconstr.cmi +tactics/extratactics.cmi: interp/genarg.cmi kernel/names.cmi \ proofs/proof_type.cmi pretyping/rawterm.cmi kernel/term.cmi tactics/hiddentac.cmi: kernel/names.cmi proofs/proof_type.cmi \ pretyping/rawterm.cmi proofs/tacexpr.cmo proofs/tacmach.cmi \ @@ -239,40 +250,42 @@ tactics/hipattern.cmi: pretyping/evd.cmi kernel/names.cmi \ kernel/term.cmi lib/util.cmi tactics/inv.cmi: kernel/names.cmi pretyping/rawterm.cmi proofs/tacmach.cmi \ kernel/term.cmi -tactics/leminv.cmi: parsing/coqast.cmi kernel/names.cmi proofs/proof_type.cmi \ - pretyping/rawterm.cmi kernel/term.cmi +tactics/leminv.cmi: kernel/names.cmi proofs/proof_type.cmi \ + pretyping/rawterm.cmi kernel/term.cmi interp/topconstr.cmi tactics/nbtermdn.cmi: tactics/btermdn.cmi pretyping/pattern.cmi \ kernel/term.cmi tactics/refine.cmi: pretyping/pretyping.cmi proofs/tacmach.cmi \ kernel/term.cmi -tactics/setoid_replace.cmi: parsing/genarg.cmi kernel/names.cmi \ - proofs/proof_type.cmi kernel/term.cmi +tactics/setoid_replace.cmi: kernel/names.cmi proofs/proof_type.cmi \ + kernel/term.cmi interp/topconstr.cmi tactics/tacinterp.cmi: parsing/coqast.cmi lib/dyn.cmi kernel/environ.cmi \ - pretyping/evd.cmi parsing/genarg.cmi kernel/names.cmi lib/pp.cmi \ + pretyping/evd.cmi interp/genarg.cmi kernel/names.cmi lib/pp.cmi \ proofs/proof_type.cmi proofs/tacexpr.cmo proofs/tacmach.cmi \ - pretyping/tacred.cmi proofs/tactic_debug.cmi kernel/term.cmi lib/util.cmi + pretyping/tacred.cmi proofs/tactic_debug.cmi kernel/term.cmi \ + interp/topconstr.cmi lib/util.cmi tactics/tacticals.cmi: proofs/clenv.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 parsing/coqast.cmi \ - kernel/environ.cmi proofs/evar_refiner.cmi pretyping/evd.cmi \ - library/libnames.cmi kernel/names.cmi library/nametab.cmi \ - proofs/proof_type.cmi pretyping/rawterm.cmi kernel/reduction.cmi \ - kernel/sign.cmi proofs/tacexpr.cmo proofs/tacmach.cmi \ - pretyping/tacred.cmi tactics/tacticals.cmi kernel/term.cmi +tactics/tactics.cmi: proofs/clenv.cmi kernel/environ.cmi \ + proofs/evar_refiner.cmi pretyping/evd.cmi library/libnames.cmi \ + kernel/names.cmi library/nametab.cmi proofs/proof_type.cmi \ + pretyping/rawterm.cmi kernel/reduction.cmi kernel/sign.cmi \ + proofs/tacexpr.cmo proofs/tacmach.cmi pretyping/tacred.cmi \ + tactics/tacticals.cmi kernel/term.cmi interp/topconstr.cmi tactics/termdn.cmi: pretyping/pattern.cmi kernel/term.cmi tactics/wcclausenv.cmi: proofs/clenv.cmi kernel/environ.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/cerrors.cmi: parsing/coqast.cmi lib/pp.cmi +toplevel/cerrors.cmi: lib/pp.cmi lib/util.cmi toplevel/class.cmi: pretyping/classops.cmi library/decl_kinds.cmo \ library/declare.cmi library/libnames.cmi kernel/names.cmi \ - library/nametab.cmi proofs/proof_type.cmi kernel/term.cmi -toplevel/command.cmi: parsing/coqast.cmi library/decl_kinds.cmo \ - library/declare.cmi kernel/entries.cmi kernel/environ.cmi \ - pretyping/evd.cmi library/libnames.cmi library/library.cmi \ - kernel/names.cmi library/nametab.cmi proofs/proof_type.cmi \ - pretyping/tacred.cmi kernel/term.cmi lib/util.cmi toplevel/vernacexpr.cmo + library/nametab.cmi proofs/tacexpr.cmo kernel/term.cmi +toplevel/command.cmi: library/decl_kinds.cmo library/declare.cmi \ + kernel/entries.cmi kernel/environ.cmi pretyping/evd.cmi \ + library/libnames.cmi library/library.cmi kernel/names.cmi \ + library/nametab.cmi pretyping/rawterm.cmi proofs/tacexpr.cmo \ + pretyping/tacred.cmi kernel/term.cmi interp/topconstr.cmi lib/util.cmi \ + toplevel/vernacexpr.cmo toplevel/coqinit.cmi: kernel/names.cmi toplevel/discharge.cmi: kernel/names.cmi toplevel/fhimsg.cmi: kernel/environ.cmi kernel/names.cmi lib/pp.cmi \ @@ -280,27 +293,26 @@ toplevel/fhimsg.cmi: kernel/environ.cmi kernel/names.cmi lib/pp.cmi \ toplevel/himsg.cmi: pretyping/cases.cmi kernel/environ.cmi \ kernel/indtypes.cmi proofs/logic.cmi kernel/names.cmi lib/pp.cmi \ pretyping/pretype_errors.cmi kernel/type_errors.cmi -toplevel/metasyntax.cmi: parsing/coqast.cmi parsing/extend.cmi \ - library/libnames.cmi parsing/symbols.cmi proofs/tacexpr.cmo lib/util.cmi \ - toplevel/vernacexpr.cmo +toplevel/metasyntax.cmi: parsing/extend.cmi library/libnames.cmi \ + interp/ppextend.cmi interp/symbols.cmi proofs/tacexpr.cmo \ + interp/topconstr.cmi lib/util.cmi toplevel/vernacexpr.cmo toplevel/mltop.cmi: library/libobject.cmi kernel/names.cmi toplevel/protectedtoplevel.cmi: lib/pp.cmi -toplevel/record.cmi: parsing/genarg.cmi kernel/names.cmi kernel/sign.cmi \ - kernel/term.cmi toplevel/vernacexpr.cmo -toplevel/recordobj.cmi: library/libnames.cmi proofs/proof_type.cmi +toplevel/record.cmi: kernel/names.cmi kernel/sign.cmi kernel/term.cmi \ + interp/topconstr.cmi toplevel/vernacexpr.cmo +toplevel/recordobj.cmi: library/libnames.cmi proofs/tacexpr.cmo 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/vernacexpr.cmo -toplevel/vernacentries.cmi: parsing/coqast.cmi kernel/environ.cmi \ - pretyping/evd.cmi library/libnames.cmi kernel/names.cmi kernel/term.cmi \ - lib/util.cmi toplevel/vernacexpr.cmo toplevel/vernacinterp.cmi +toplevel/vernac.cmi: parsing/pcoq.cmi lib/util.cmi toplevel/vernacexpr.cmo +toplevel/vernacentries.cmi: kernel/environ.cmi pretyping/evd.cmi \ + library/libnames.cmi kernel/names.cmi kernel/term.cmi \ + interp/topconstr.cmi toplevel/vernacexpr.cmo toplevel/vernacinterp.cmi toplevel/vernacinterp.cmi: proofs/tacexpr.cmo contrib/cc/ccalgo.cmi: kernel/names.cmi kernel/term.cmi contrib/cc/ccproof.cmi: contrib/cc/ccalgo.cmi kernel/names.cmi -contrib/correctness/past.cmi: parsing/coqast.cmi kernel/names.cmi \ - contrib/correctness/ptype.cmi kernel/term.cmi +contrib/correctness/past.cmi: kernel/names.cmi contrib/correctness/ptype.cmi \ + kernel/term.cmi interp/topconstr.cmi lib/util.cmi contrib/correctness/pcic.cmi: contrib/correctness/past.cmi \ pretyping/rawterm.cmi contrib/correctness/pcicenv.cmi: kernel/names.cmi \ @@ -312,12 +324,13 @@ contrib/correctness/peffect.cmi: kernel/names.cmi lib/pp.cmi contrib/correctness/penv.cmi: library/libnames.cmi kernel/names.cmi \ contrib/correctness/past.cmi contrib/correctness/ptype.cmi \ kernel/term.cmi -contrib/correctness/perror.cmi: parsing/coqast.cmi kernel/names.cmi \ - contrib/correctness/past.cmi contrib/correctness/peffect.cmi lib/pp.cmi \ - contrib/correctness/ptype.cmi +contrib/correctness/perror.cmi: kernel/names.cmi contrib/correctness/past.cmi \ + contrib/correctness/peffect.cmi lib/pp.cmi contrib/correctness/ptype.cmi \ + lib/util.cmi contrib/correctness/pextract.cmi: kernel/names.cmi -contrib/correctness/pmisc.cmi: parsing/coqast.cmi kernel/names.cmi lib/pp.cmi \ - contrib/correctness/ptype.cmi kernel/term.cmi +contrib/correctness/pmisc.cmi: kernel/names.cmi lib/pp.cmi \ + contrib/correctness/ptype.cmi kernel/term.cmi interp/topconstr.cmi \ + lib/util.cmi contrib/correctness/pmlize.cmi: kernel/names.cmi contrib/correctness/past.cmi \ contrib/correctness/penv.cmi contrib/correctness/prename.cmi contrib/correctness/pmonad.cmi: kernel/names.cmi contrib/correctness/past.cmi \ @@ -326,17 +339,16 @@ contrib/correctness/pmonad.cmi: kernel/names.cmi contrib/correctness/past.cmi \ kernel/term.cmi contrib/correctness/pred.cmi: contrib/correctness/past.cmi kernel/term.cmi contrib/correctness/prename.cmi: kernel/names.cmi lib/pp.cmi -contrib/correctness/psyntax.cmi: parsing/coqast.cmi \ - contrib/correctness/past.cmi parsing/pcoq.cmi \ - contrib/correctness/ptype.cmi +contrib/correctness/psyntax.cmi: contrib/correctness/past.cmi \ + parsing/pcoq.cmi contrib/correctness/ptype.cmi interp/topconstr.cmi contrib/correctness/ptactic.cmi: contrib/correctness/past.cmi \ proofs/tacmach.cmi contrib/correctness/ptype.cmi: kernel/names.cmi \ contrib/correctness/peffect.cmi kernel/term.cmi -contrib/correctness/ptyping.cmi: parsing/coqast.cmi kernel/names.cmi \ +contrib/correctness/ptyping.cmi: kernel/names.cmi \ contrib/correctness/past.cmi contrib/correctness/penv.cmi \ contrib/correctness/prename.cmi contrib/correctness/ptype.cmi \ - kernel/term.cmi + kernel/term.cmi interp/topconstr.cmi contrib/correctness/putil.cmi: kernel/names.cmi contrib/correctness/past.cmi \ contrib/correctness/penv.cmi contrib/correctness/pmisc.cmi lib/pp.cmi \ contrib/correctness/prename.cmi contrib/correctness/ptype.cmi \ @@ -367,8 +379,8 @@ contrib/extraction/table.cmi: library/libnames.cmi kernel/names.cmi \ lib/util.cmi toplevel/vernacinterp.cmi contrib/interface/blast.cmi: proofs/proof_type.cmi proofs/tacexpr.cmo \ proofs/tacmach.cmi -contrib/interface/dad.cmi: contrib/interface/ctast.cmo proofs/proof_type.cmi \ - proofs/tacexpr.cmo proofs/tacmach.cmi +contrib/interface/dad.cmi: proofs/proof_type.cmi proofs/tacexpr.cmo \ + proofs/tacmach.cmi interp/topconstr.cmi contrib/interface/debug_tac.cmi: proofs/proof_type.cmi proofs/tacexpr.cmo \ proofs/tacmach.cmi contrib/interface/name_to_ast.cmi: parsing/coqast.cmi library/libnames.cmi \ @@ -376,13 +388,13 @@ contrib/interface/name_to_ast.cmi: parsing/coqast.cmi library/libnames.cmi \ contrib/interface/pbp.cmi: kernel/names.cmi proofs/proof_type.cmi \ proofs/tacexpr.cmo 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 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 \ - kernel/term.cmi contrib/interface/translate.cmi pretyping/typing.cmi \ - lib/util.cmi toplevel/vernacinterp.cmi + proofs/clenv.cmi parsing/coqast.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 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 pretyping/evd.cmi proofs/proof_type.cmi \ kernel/term.cmi @@ -396,7 +408,7 @@ contrib/jprover/jlogic.cmi: contrib/jprover/jterm.cmi contrib/jprover/jterm.cmi: contrib/jprover/opname.cmi contrib/xml/doubleTypeInference.cmi: contrib/xml/acic.cmo kernel/environ.cmi \ pretyping/evd.cmi kernel/term.cmi -contrib/xml/xmlcommand.cmi: library/libnames.cmi lib/util.cmi +contrib/xml/xmlcommand.cmi: library/libnames.cmi config/coq_config.cmo: config/coq_config.cmi config/coq_config.cmx: config/coq_config.cmi dev/db_printers.cmo: kernel/names.cmi lib/pp.cmi @@ -413,6 +425,82 @@ dev/top_printers.cmx: parsing/ast.cmx toplevel/cerrors.cmx proofs/clenv.cmx \ parsing/pptactic.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 +interp/constrextern.cmo: pretyping/classops.cmi library/declare.cmi \ + pretyping/detyping.cmi kernel/environ.cmi library/impargs.cmi \ + kernel/inductive.cmi library/libnames.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 interp/topconstr.cmi \ + kernel/univ.cmi lib/util.cmi interp/constrextern.cmi +interp/constrextern.cmx: pretyping/classops.cmx library/declare.cmx \ + pretyping/detyping.cmx kernel/environ.cmx library/impargs.cmx \ + kernel/inductive.cmx library/libnames.cmx 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 interp/topconstr.cmx \ + kernel/univ.cmx lib/util.cmx interp/constrextern.cmi +interp/constrintern.cmo: library/declare.cmi kernel/environ.cmi \ + pretyping/evd.cmi library/global.cmi library/impargs.cmi \ + library/libnames.cmi library/nameops.cmi kernel/names.cmi \ + library/nametab.cmi lib/options.cmi pretyping/pattern.cmi lib/pp.cmi \ + pretyping/pretyping.cmi pretyping/rawterm.cmi pretyping/retyping.cmi \ + kernel/sign.cmi interp/symbols.cmi interp/syntax_def.cmi \ + pretyping/termops.cmi interp/topconstr.cmi lib/util.cmi \ + interp/constrintern.cmi +interp/constrintern.cmx: library/declare.cmx kernel/environ.cmx \ + pretyping/evd.cmx library/global.cmx library/impargs.cmx \ + library/libnames.cmx library/nameops.cmx kernel/names.cmx \ + library/nametab.cmx lib/options.cmx pretyping/pattern.cmx lib/pp.cmx \ + pretyping/pretyping.cmx pretyping/rawterm.cmx pretyping/retyping.cmx \ + kernel/sign.cmx interp/symbols.cmx interp/syntax_def.cmx \ + pretyping/termops.cmx interp/topconstr.cmx lib/util.cmx \ + interp/constrintern.cmi +interp/coqlib.cmo: library/declare.cmi library/libnames.cmi kernel/names.cmi \ + library/nametab.cmi pretyping/pattern.cmi kernel/term.cmi lib/util.cmi \ + interp/coqlib.cmi +interp/coqlib.cmx: library/declare.cmx library/libnames.cmx kernel/names.cmx \ + library/nametab.cmx pretyping/pattern.cmx kernel/term.cmx lib/util.cmx \ + interp/coqlib.cmi +interp/genarg.cmo: pretyping/evd.cmi kernel/names.cmi library/nametab.cmi \ + pretyping/rawterm.cmi kernel/term.cmi interp/topconstr.cmi lib/util.cmi \ + interp/genarg.cmi +interp/genarg.cmx: pretyping/evd.cmx kernel/names.cmx library/nametab.cmx \ + pretyping/rawterm.cmx kernel/term.cmx interp/topconstr.cmx lib/util.cmx \ + interp/genarg.cmi +interp/modintern.cmo: interp/constrintern.cmi kernel/entries.cmi \ + pretyping/evd.cmi library/libnames.cmi kernel/modops.cmi kernel/names.cmi \ + library/nametab.cmi lib/pp.cmi interp/topconstr.cmi lib/util.cmi \ + interp/modintern.cmi +interp/modintern.cmx: interp/constrintern.cmx kernel/entries.cmx \ + pretyping/evd.cmx library/libnames.cmx kernel/modops.cmx kernel/names.cmx \ + library/nametab.cmx lib/pp.cmx interp/topconstr.cmx lib/util.cmx \ + interp/modintern.cmi +interp/ppextend.cmo: kernel/names.cmi lib/pp.cmi lib/util.cmi \ + interp/ppextend.cmi +interp/ppextend.cmx: kernel/names.cmx lib/pp.cmx lib/util.cmx \ + interp/ppextend.cmi +interp/symbols.cmo: lib/bignat.cmi library/lib.cmi library/libnames.cmi \ + library/libobject.cmi kernel/names.cmi library/nametab.cmi \ + lib/options.cmi lib/pp.cmi interp/ppextend.cmi pretyping/rawterm.cmi \ + library/summary.cmi interp/topconstr.cmi lib/util.cmi interp/symbols.cmi +interp/symbols.cmx: lib/bignat.cmx library/lib.cmx library/libnames.cmx \ + library/libobject.cmx kernel/names.cmx library/nametab.cmx \ + lib/options.cmx lib/pp.cmx interp/ppextend.cmx pretyping/rawterm.cmx \ + library/summary.cmx interp/topconstr.cmx lib/util.cmx interp/symbols.cmi +interp/syntax_def.cmo: library/lib.cmi library/libnames.cmi \ + library/libobject.cmi library/nameops.cmi kernel/names.cmi \ + library/nametab.cmi lib/pp.cmi library/summary.cmi interp/topconstr.cmi \ + lib/util.cmi interp/syntax_def.cmi +interp/syntax_def.cmx: library/lib.cmx library/libnames.cmx \ + library/libobject.cmx library/nameops.cmx kernel/names.cmx \ + library/nametab.cmx lib/pp.cmx library/summary.cmx interp/topconstr.cmx \ + lib/util.cmx interp/syntax_def.cmi +interp/topconstr.cmo: lib/bignat.cmi lib/dyn.cmi library/libnames.cmi \ + library/nameops.cmi kernel/names.cmi lib/pp.cmi pretyping/rawterm.cmi \ + kernel/term.cmi lib/util.cmi interp/topconstr.cmi +interp/topconstr.cmx: lib/bignat.cmx lib/dyn.cmx library/libnames.cmx \ + library/nameops.cmx kernel/names.cmx lib/pp.cmx pretyping/rawterm.cmx \ + kernel/term.cmx lib/util.cmx interp/topconstr.cmi kernel/closure.cmo: kernel/declarations.cmi kernel/environ.cmi \ kernel/esubst.cmi kernel/names.cmi lib/pp.cmi kernel/term.cmi \ lib/util.cmi kernel/closure.cmi @@ -466,11 +554,11 @@ kernel/mod_typing.cmx: kernel/declarations.cmx kernel/entries.cmx \ kernel/reduction.cmx kernel/subtyping.cmx kernel/term_typing.cmx \ kernel/typeops.cmx kernel/univ.cmx lib/util.cmx kernel/mod_typing.cmi kernel/modops.cmo: kernel/declarations.cmi kernel/entries.cmi \ - kernel/environ.cmi kernel/names.cmi kernel/term.cmi kernel/univ.cmi \ - lib/util.cmi kernel/modops.cmi + kernel/environ.cmi kernel/names.cmi lib/pp.cmi kernel/term.cmi \ + kernel/univ.cmi lib/util.cmi kernel/modops.cmi kernel/modops.cmx: kernel/declarations.cmx kernel/entries.cmx \ - kernel/environ.cmx kernel/names.cmx kernel/term.cmx kernel/univ.cmx \ - lib/util.cmx kernel/modops.cmi + kernel/environ.cmx kernel/names.cmx lib/pp.cmx kernel/term.cmx \ + kernel/univ.cmx lib/util.cmx kernel/modops.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 \ @@ -541,8 +629,8 @@ 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 \ kernel/univ.cmi -lib/bignat.cmo: lib/bignat.cmi -lib/bignat.cmx: lib/bignat.cmi +lib/bignat.cmo: lib/pp.cmi lib/bignat.cmi +lib/bignat.cmx: lib/pp.cmx lib/bignat.cmi lib/bij.cmo: lib/gmap.cmi lib/bij.cmi lib/bij.cmx: lib/gmap.cmx lib/bij.cmi lib/bstack.cmo: lib/util.cmi lib/bstack.cmi @@ -649,10 +737,10 @@ library/lib.cmo: library/libnames.cmi library/libobject.cmi \ library/lib.cmx: library/libnames.cmx library/libobject.cmx \ library/nameops.cmx kernel/names.cmx library/nametab.cmx lib/pp.cmx \ library/summary.cmx lib/util.cmx library/lib.cmi -library/libnames.cmo: kernel/names.cmi lib/pp.cmi lib/predicate.cmi \ - lib/util.cmi library/libnames.cmi -library/libnames.cmx: kernel/names.cmx lib/pp.cmx lib/predicate.cmx \ - lib/util.cmx library/libnames.cmi +library/libnames.cmo: library/nameops.cmi kernel/names.cmi lib/pp.cmi \ + lib/predicate.cmi kernel/term.cmi lib/util.cmi library/libnames.cmi +library/libnames.cmx: library/nameops.cmx kernel/names.cmx lib/pp.cmx \ + lib/predicate.cmx kernel/term.cmx lib/util.cmx library/libnames.cmi library/libobject.cmo: lib/dyn.cmi library/libnames.cmi kernel/names.cmi \ lib/util.cmi library/libobject.cmi library/libobject.cmx: lib/dyn.cmx library/libnames.cmx kernel/names.cmx \ @@ -667,11 +755,9 @@ library/library.cmx: library/declaremods.cmx library/lib.cmx \ kernel/names.cmx library/nametab.cmx lib/options.cmx lib/pp.cmx \ kernel/safe_typing.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 lib/pp.cmi kernel/term.cmi lib/util.cmi \ +library/nameops.cmo: kernel/names.cmi lib/pp.cmi lib/util.cmi \ library/nameops.cmi -library/nameops.cmx: kernel/declarations.cmx kernel/environ.cmx \ - kernel/names.cmx lib/pp.cmx kernel/term.cmx lib/util.cmx \ +library/nameops.cmx: kernel/names.cmx lib/pp.cmx lib/util.cmx \ library/nameops.cmi library/nametab.cmo: kernel/declarations.cmi library/libnames.cmi \ library/nameops.cmi kernel/names.cmi lib/pp.cmi kernel/sign.cmi \ @@ -685,196 +771,174 @@ library/states.cmx: library/lib.cmx library/library.cmx library/summary.cmx \ lib/system.cmx library/states.cmi library/summary.cmo: lib/dyn.cmi lib/pp.cmi lib/util.cmi library/summary.cmi library/summary.cmx: lib/dyn.cmx lib/pp.cmx lib/util.cmx library/summary.cmi -parsing/argextend.cmo: parsing/ast.cmi parsing/genarg.cmi parsing/pcoq.cmi \ +parsing/argextend.cmo: parsing/ast.cmi interp/genarg.cmi parsing/pcoq.cmi \ parsing/q_coqast.cmo parsing/q_util.cmi lib/util.cmi \ toplevel/vernacexpr.cmo -parsing/argextend.cmx: parsing/ast.cmx parsing/genarg.cmx parsing/pcoq.cmx \ +parsing/argextend.cmx: parsing/ast.cmx interp/genarg.cmx parsing/pcoq.cmx \ parsing/q_coqast.cmx parsing/q_util.cmx lib/util.cmx \ toplevel/vernacexpr.cmx -parsing/ast.cmo: parsing/coqast.cmi lib/dyn.cmi parsing/genarg.cmi \ - library/libnames.cmi kernel/names.cmi lib/pp.cmi lib/util.cmi \ - parsing/ast.cmi -parsing/ast.cmx: parsing/coqast.cmx lib/dyn.cmx parsing/genarg.cmx \ - library/libnames.cmx kernel/names.cmx lib/pp.cmx lib/util.cmx \ - parsing/ast.cmi -parsing/astmod.cmo: parsing/astterm.cmi parsing/coqast.cmi kernel/entries.cmi \ - pretyping/evd.cmi library/libnames.cmi kernel/modops.cmi kernel/names.cmi \ - library/nametab.cmi lib/pp.cmi lib/util.cmi parsing/astmod.cmi -parsing/astmod.cmx: parsing/astterm.cmx parsing/coqast.cmx kernel/entries.cmx \ - pretyping/evd.cmx library/libnames.cmx kernel/modops.cmx kernel/names.cmx \ - library/nametab.cmx lib/pp.cmx lib/util.cmx parsing/astmod.cmi -parsing/astterm.cmo: parsing/ast.cmi lib/bignat.cmi parsing/coqast.cmi \ - library/declare.cmi lib/dyn.cmi kernel/environ.cmi pretyping/evarutil.cmi \ - pretyping/evd.cmi library/global.cmi library/impargs.cmi \ - library/libnames.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 parsing/symbols.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 lib/bignat.cmx parsing/coqast.cmx \ - library/declare.cmx lib/dyn.cmx kernel/environ.cmx pretyping/evarutil.cmx \ - pretyping/evd.cmx library/global.cmx library/impargs.cmx \ - library/libnames.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 parsing/symbols.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/bignat.cmi lib/dyn.cmi lib/hashcons.cmi \ - library/libnames.cmi kernel/names.cmi lib/pp.cmi pretyping/rawterm.cmi \ - kernel/term.cmi lib/util.cmi parsing/coqast.cmi -parsing/coqast.cmx: lib/bignat.cmx lib/dyn.cmx lib/hashcons.cmx \ - library/libnames.cmx kernel/names.cmx lib/pp.cmx pretyping/rawterm.cmx \ - kernel/term.cmx lib/util.cmx parsing/coqast.cmi -parsing/coqlib.cmo: library/declare.cmi library/libnames.cmi kernel/names.cmi \ - library/nametab.cmi pretyping/pattern.cmi kernel/term.cmi lib/util.cmi \ - parsing/coqlib.cmi -parsing/coqlib.cmx: library/declare.cmx library/libnames.cmx kernel/names.cmx \ - library/nametab.cmx pretyping/pattern.cmx kernel/term.cmx lib/util.cmx \ - parsing/coqlib.cmi -parsing/egrammar.cmo: parsing/ast.cmi parsing/coqast.cmi parsing/extend.cmi \ - parsing/genarg.cmi parsing/lexer.cmi parsing/pcoq.cmi lib/pp.cmi \ - proofs/tacexpr.cmo lib/util.cmi toplevel/vernacexpr.cmo \ - parsing/egrammar.cmi -parsing/egrammar.cmx: parsing/ast.cmx parsing/coqast.cmx parsing/extend.cmx \ - parsing/genarg.cmx parsing/lexer.cmx parsing/pcoq.cmx lib/pp.cmx \ - proofs/tacexpr.cmx lib/util.cmx toplevel/vernacexpr.cmx \ - parsing/egrammar.cmi +parsing/ast.cmo: parsing/coqast.cmi lib/dyn.cmi interp/genarg.cmi \ + library/libnames.cmi kernel/names.cmi lib/pp.cmi interp/topconstr.cmi \ + lib/util.cmi parsing/ast.cmi +parsing/ast.cmx: parsing/coqast.cmx lib/dyn.cmx interp/genarg.cmx \ + library/libnames.cmx kernel/names.cmx lib/pp.cmx interp/topconstr.cmx \ + lib/util.cmx parsing/ast.cmi +parsing/coqast.cmo: lib/dyn.cmi lib/hashcons.cmi library/libnames.cmi \ + kernel/names.cmi lib/util.cmi parsing/coqast.cmi +parsing/coqast.cmx: lib/dyn.cmx lib/hashcons.cmx library/libnames.cmx \ + kernel/names.cmx lib/util.cmx parsing/coqast.cmi +parsing/egrammar.cmo: parsing/ast.cmi parsing/extend.cmi interp/genarg.cmi \ + parsing/lexer.cmi library/libnames.cmi kernel/names.cmi parsing/pcoq.cmi \ + lib/pp.cmi proofs/tacexpr.cmo interp/topconstr.cmi lib/util.cmi \ + toplevel/vernacexpr.cmo parsing/egrammar.cmi +parsing/egrammar.cmx: parsing/ast.cmx parsing/extend.cmx interp/genarg.cmx \ + parsing/lexer.cmx library/libnames.cmx kernel/names.cmx parsing/pcoq.cmx \ + lib/pp.cmx proofs/tacexpr.cmx interp/topconstr.cmx lib/util.cmx \ + toplevel/vernacexpr.cmx parsing/egrammar.cmi parsing/esyntax.cmo: parsing/ast.cmi parsing/coqast.cmi parsing/extend.cmi \ - parsing/genarg.cmi lib/gmap.cmi lib/gmapl.cmi library/libnames.cmi \ - kernel/names.cmi library/nametab.cmi lib/options.cmi lib/pp.cmi \ - parsing/symbols.cmi lib/util.cmi toplevel/vernacexpr.cmo \ - parsing/esyntax.cmi + lib/gmap.cmi lib/gmapl.cmi library/libnames.cmi kernel/names.cmi \ + library/nametab.cmi lib/options.cmi lib/pp.cmi interp/ppextend.cmi \ + interp/symbols.cmi interp/topconstr.cmi lib/util.cmi \ + toplevel/vernacexpr.cmo parsing/esyntax.cmi parsing/esyntax.cmx: parsing/ast.cmx parsing/coqast.cmx parsing/extend.cmx \ - parsing/genarg.cmx lib/gmap.cmx lib/gmapl.cmx library/libnames.cmx \ - kernel/names.cmx library/nametab.cmx lib/options.cmx lib/pp.cmx \ - parsing/symbols.cmx lib/util.cmx toplevel/vernacexpr.cmx \ - parsing/esyntax.cmi -parsing/extend.cmo: parsing/ast.cmi parsing/coqast.cmi parsing/genarg.cmi \ - parsing/lexer.cmi lib/pp.cmi lib/util.cmi parsing/extend.cmi -parsing/extend.cmx: parsing/ast.cmx parsing/coqast.cmx parsing/genarg.cmx \ - parsing/lexer.cmx lib/pp.cmx lib/util.cmx parsing/extend.cmi -parsing/g_basevernac.cmo: parsing/ast.cmi parsing/coqast.cmi \ - parsing/extend.cmi library/goptions.cmi parsing/pcoq.cmi lib/pp.cmi \ + lib/gmap.cmx lib/gmapl.cmx library/libnames.cmx kernel/names.cmx \ + library/nametab.cmx lib/options.cmx lib/pp.cmx interp/ppextend.cmx \ + interp/symbols.cmx interp/topconstr.cmx lib/util.cmx \ + toplevel/vernacexpr.cmx parsing/esyntax.cmi +parsing/extend.cmo: parsing/ast.cmi parsing/coqast.cmi interp/genarg.cmi \ + parsing/lexer.cmi kernel/names.cmi lib/pp.cmi interp/ppextend.cmi \ + interp/topconstr.cmi lib/util.cmi parsing/extend.cmi +parsing/extend.cmx: parsing/ast.cmx parsing/coqast.cmx interp/genarg.cmx \ + parsing/lexer.cmx kernel/names.cmx lib/pp.cmx interp/ppextend.cmx \ + interp/topconstr.cmx lib/util.cmx parsing/extend.cmi +parsing/g_basevernac.cmo: parsing/ast.cmi interp/constrintern.cmi \ + parsing/coqast.cmi pretyping/evd.cmi parsing/extend.cmi \ + library/global.cmi library/goptions.cmi kernel/names.cmi parsing/pcoq.cmi \ + lib/pp.cmi interp/ppextend.cmi parsing/termast.cmi lib/util.cmi \ toplevel/vernacexpr.cmo -parsing/g_basevernac.cmx: parsing/ast.cmx parsing/coqast.cmx \ - parsing/extend.cmx library/goptions.cmx parsing/pcoq.cmx lib/pp.cmx \ +parsing/g_basevernac.cmx: parsing/ast.cmx interp/constrintern.cmx \ + parsing/coqast.cmx pretyping/evd.cmx parsing/extend.cmx \ + library/global.cmx library/goptions.cmx kernel/names.cmx parsing/pcoq.cmx \ + lib/pp.cmx interp/ppextend.cmx parsing/termast.cmx lib/util.cmx \ toplevel/vernacexpr.cmx -parsing/g_cases.cmo: parsing/coqast.cmi parsing/g_constr.cmo \ - library/libnames.cmi kernel/names.cmi parsing/pcoq.cmi lib/pp.cmi \ +parsing/g_cases.cmo: lib/bignat.cmi parsing/g_constr.cmo library/libnames.cmi \ + parsing/pcoq.cmi lib/pp.cmi kernel/term.cmi interp/topconstr.cmi \ lib/util.cmi -parsing/g_cases.cmx: parsing/coqast.cmx parsing/g_constr.cmx \ - library/libnames.cmx kernel/names.cmx parsing/pcoq.cmx lib/pp.cmx \ +parsing/g_cases.cmx: lib/bignat.cmx parsing/g_constr.cmx library/libnames.cmx \ + parsing/pcoq.cmx lib/pp.cmx kernel/term.cmx interp/topconstr.cmx \ lib/util.cmx -parsing/g_constr.cmo: parsing/ast.cmi parsing/coqast.cmi kernel/names.cmi \ - parsing/pcoq.cmi -parsing/g_constr.cmx: parsing/ast.cmx parsing/coqast.cmx kernel/names.cmx \ - parsing/pcoq.cmx -parsing/g_ltac.cmo: parsing/ast.cmi parsing/coqast.cmi parsing/genarg.cmi \ - kernel/names.cmi parsing/pcoq.cmi lib/pp.cmi pretyping/rawterm.cmi \ - proofs/tacexpr.cmo lib/util.cmi toplevel/vernacexpr.cmo -parsing/g_ltac.cmx: parsing/ast.cmx parsing/coqast.cmx parsing/genarg.cmx \ - kernel/names.cmx parsing/pcoq.cmx lib/pp.cmx pretyping/rawterm.cmx \ - proofs/tacexpr.cmx lib/util.cmx toplevel/vernacexpr.cmx +parsing/g_constr.cmo: lib/bignat.cmi library/libnames.cmi kernel/names.cmi \ + lib/options.cmi parsing/pcoq.cmi lib/pp.cmi pretyping/rawterm.cmi \ + kernel/term.cmi interp/topconstr.cmi lib/util.cmi +parsing/g_constr.cmx: lib/bignat.cmx library/libnames.cmx kernel/names.cmx \ + lib/options.cmx parsing/pcoq.cmx lib/pp.cmx pretyping/rawterm.cmx \ + kernel/term.cmx interp/topconstr.cmx lib/util.cmx +parsing/g_ltac.cmo: parsing/ast.cmi kernel/names.cmi parsing/pcoq.cmi \ + lib/pp.cmi pretyping/rawterm.cmi proofs/tacexpr.cmo interp/topconstr.cmi \ + lib/util.cmi toplevel/vernacexpr.cmo +parsing/g_ltac.cmx: parsing/ast.cmx kernel/names.cmx parsing/pcoq.cmx \ + lib/pp.cmx pretyping/rawterm.cmx proofs/tacexpr.cmx interp/topconstr.cmx \ + lib/util.cmx toplevel/vernacexpr.cmx parsing/g_minicoq.cmo: kernel/environ.cmi parsing/lexer.cmi kernel/names.cmi \ lib/pp.cmi kernel/term.cmi kernel/univ.cmi lib/util.cmi \ parsing/g_minicoq.cmi parsing/g_minicoq.cmx: kernel/environ.cmx parsing/lexer.cmx kernel/names.cmx \ lib/pp.cmx kernel/term.cmx kernel/univ.cmx lib/util.cmx \ parsing/g_minicoq.cmi -parsing/g_module.cmo: parsing/ast.cmi parsing/coqast.cmi kernel/names.cmi \ - parsing/pcoq.cmi lib/pp.cmi lib/util.cmi -parsing/g_module.cmx: parsing/ast.cmx parsing/coqast.cmx kernel/names.cmx \ - parsing/pcoq.cmx lib/pp.cmx lib/util.cmx +parsing/g_module.cmo: parsing/ast.cmi parsing/pcoq.cmi lib/pp.cmi \ + interp/topconstr.cmi lib/util.cmi +parsing/g_module.cmx: parsing/ast.cmx parsing/pcoq.cmx lib/pp.cmx \ + interp/topconstr.cmx lib/util.cmx parsing/g_natsyntax.cmo: parsing/ast.cmi lib/bignat.cmi parsing/coqast.cmi \ - parsing/coqlib.cmi parsing/esyntax.cmi parsing/extend.cmi \ + interp/coqlib.cmi parsing/esyntax.cmi parsing/extend.cmi \ library/libnames.cmi kernel/names.cmi lib/options.cmi parsing/pcoq.cmi \ - lib/pp.cmi pretyping/rawterm.cmi parsing/symbols.cmi parsing/termast.cmi \ + lib/pp.cmi pretyping/rawterm.cmi interp/symbols.cmi parsing/termast.cmi \ lib/util.cmi parsing/g_natsyntax.cmi parsing/g_natsyntax.cmx: parsing/ast.cmx lib/bignat.cmx parsing/coqast.cmx \ - parsing/coqlib.cmx parsing/esyntax.cmx parsing/extend.cmx \ + interp/coqlib.cmx parsing/esyntax.cmx parsing/extend.cmx \ library/libnames.cmx kernel/names.cmx lib/options.cmx parsing/pcoq.cmx \ - lib/pp.cmx pretyping/rawterm.cmx parsing/symbols.cmx parsing/termast.cmx \ + lib/pp.cmx pretyping/rawterm.cmx interp/symbols.cmx parsing/termast.cmx \ lib/util.cmx parsing/g_natsyntax.cmi parsing/g_prim.cmo: parsing/coqast.cmi library/libnames.cmi kernel/names.cmi \ - library/nametab.cmi parsing/pcoq.cmi + library/nametab.cmi parsing/pcoq.cmi interp/topconstr.cmi parsing/g_prim.cmx: parsing/coqast.cmx library/libnames.cmx kernel/names.cmx \ - library/nametab.cmx parsing/pcoq.cmx -parsing/g_proofs.cmo: parsing/coqast.cmi parsing/genarg.cmi parsing/pcoq.cmi \ - lib/pp.cmi proofs/tacexpr.cmo lib/util.cmi toplevel/vernacexpr.cmo -parsing/g_proofs.cmx: parsing/coqast.cmx parsing/genarg.cmx parsing/pcoq.cmx \ - lib/pp.cmx proofs/tacexpr.cmx lib/util.cmx toplevel/vernacexpr.cmx -parsing/g_rsyntax.cmo: parsing/ast.cmi parsing/astterm.cmi lib/bignat.cmi \ - parsing/coqast.cmi parsing/esyntax.cmi parsing/extend.cmi \ - library/libnames.cmi library/library.cmi kernel/names.cmi lib/options.cmi \ - parsing/pcoq.cmi lib/pp.cmi pretyping/rawterm.cmi parsing/symbols.cmi \ - lib/util.cmi -parsing/g_rsyntax.cmx: parsing/ast.cmx parsing/astterm.cmx lib/bignat.cmx \ - parsing/coqast.cmx parsing/esyntax.cmx parsing/extend.cmx \ - library/libnames.cmx library/library.cmx kernel/names.cmx lib/options.cmx \ - parsing/pcoq.cmx lib/pp.cmx pretyping/rawterm.cmx parsing/symbols.cmx \ - lib/util.cmx -parsing/g_tactic.cmo: parsing/ast.cmi parsing/genarg.cmi kernel/names.cmi \ + library/nametab.cmx parsing/pcoq.cmx interp/topconstr.cmx +parsing/g_proofs.cmo: interp/genarg.cmi parsing/pcoq.cmi lib/pp.cmi \ + proofs/tacexpr.cmo interp/topconstr.cmi lib/util.cmi \ + toplevel/vernacexpr.cmo +parsing/g_proofs.cmx: interp/genarg.cmx parsing/pcoq.cmx lib/pp.cmx \ + proofs/tacexpr.cmx interp/topconstr.cmx lib/util.cmx \ + toplevel/vernacexpr.cmx +parsing/g_rsyntax.cmo: parsing/ast.cmi lib/bignat.cmi parsing/coqast.cmi \ + parsing/esyntax.cmi parsing/extend.cmi library/libnames.cmi \ + library/library.cmi kernel/names.cmi library/nametab.cmi lib/options.cmi \ + parsing/pcoq.cmi lib/pp.cmi pretyping/rawterm.cmi interp/symbols.cmi \ + parsing/termast.cmi interp/topconstr.cmi lib/util.cmi +parsing/g_rsyntax.cmx: parsing/ast.cmx lib/bignat.cmx parsing/coqast.cmx \ + parsing/esyntax.cmx parsing/extend.cmx library/libnames.cmx \ + library/library.cmx kernel/names.cmx library/nametab.cmx lib/options.cmx \ + parsing/pcoq.cmx lib/pp.cmx pretyping/rawterm.cmx interp/symbols.cmx \ + parsing/termast.cmx interp/topconstr.cmx lib/util.cmx +parsing/g_tactic.cmo: parsing/ast.cmi interp/genarg.cmi kernel/names.cmi \ parsing/pcoq.cmi lib/pp.cmi pretyping/rawterm.cmi proofs/tacexpr.cmo \ - lib/util.cmi -parsing/g_tactic.cmx: parsing/ast.cmx parsing/genarg.cmx kernel/names.cmx \ + interp/topconstr.cmi lib/util.cmi +parsing/g_tactic.cmx: parsing/ast.cmx interp/genarg.cmx kernel/names.cmx \ parsing/pcoq.cmx lib/pp.cmx pretyping/rawterm.cmx proofs/tacexpr.cmx \ - lib/util.cmx -parsing/g_vernac.cmo: parsing/ast.cmi toplevel/class.cmi parsing/coqast.cmi \ - library/decl_kinds.cmo parsing/genarg.cmi library/goptions.cmi \ - lib/options.cmi parsing/pcoq.cmi lib/pp.cmi toplevel/recordobj.cmi \ - lib/util.cmi toplevel/vernacexpr.cmo -parsing/g_vernac.cmx: parsing/ast.cmx toplevel/class.cmx parsing/coqast.cmx \ - library/decl_kinds.cmx parsing/genarg.cmx library/goptions.cmx \ - lib/options.cmx parsing/pcoq.cmx lib/pp.cmx toplevel/recordobj.cmx \ - lib/util.cmx toplevel/vernacexpr.cmx -parsing/g_zsyntax.cmo: parsing/ast.cmi parsing/astterm.cmi lib/bignat.cmi \ - parsing/coqast.cmi parsing/esyntax.cmi parsing/extend.cmi \ - library/libnames.cmi library/library.cmi kernel/names.cmi \ - parsing/pcoq.cmi lib/pp.cmi pretyping/rawterm.cmi parsing/symbols.cmi \ - lib/util.cmi parsing/g_zsyntax.cmi -parsing/g_zsyntax.cmx: parsing/ast.cmx parsing/astterm.cmx lib/bignat.cmx \ - parsing/coqast.cmx parsing/esyntax.cmx parsing/extend.cmx \ - library/libnames.cmx library/library.cmx kernel/names.cmx \ - parsing/pcoq.cmx lib/pp.cmx pretyping/rawterm.cmx parsing/symbols.cmx \ - lib/util.cmx parsing/g_zsyntax.cmi -parsing/genarg.cmo: parsing/coqast.cmi pretyping/evd.cmi kernel/names.cmi \ - library/nametab.cmi pretyping/rawterm.cmi kernel/term.cmi lib/util.cmi \ - parsing/genarg.cmi -parsing/genarg.cmx: parsing/coqast.cmx pretyping/evd.cmx kernel/names.cmx \ - library/nametab.cmx pretyping/rawterm.cmx kernel/term.cmx lib/util.cmx \ - parsing/genarg.cmi + interp/topconstr.cmx lib/util.cmx +parsing/g_vernac.cmo: parsing/ast.cmi toplevel/class.cmi \ + library/decl_kinds.cmo interp/genarg.cmi library/goptions.cmi \ + kernel/names.cmi lib/options.cmi parsing/pcoq.cmi lib/pp.cmi \ + toplevel/recordobj.cmi interp/topconstr.cmi lib/util.cmi \ + toplevel/vernacexpr.cmo +parsing/g_vernac.cmx: parsing/ast.cmx toplevel/class.cmx \ + library/decl_kinds.cmx interp/genarg.cmx library/goptions.cmx \ + kernel/names.cmx lib/options.cmx parsing/pcoq.cmx lib/pp.cmx \ + toplevel/recordobj.cmx interp/topconstr.cmx lib/util.cmx \ + toplevel/vernacexpr.cmx +parsing/g_zsyntax.cmo: parsing/ast.cmi lib/bignat.cmi parsing/coqast.cmi \ + parsing/esyntax.cmi parsing/extend.cmi library/libnames.cmi \ + library/library.cmi kernel/names.cmi library/nametab.cmi parsing/pcoq.cmi \ + lib/pp.cmi pretyping/rawterm.cmi interp/symbols.cmi parsing/termast.cmi \ + interp/topconstr.cmi lib/util.cmi parsing/g_zsyntax.cmi +parsing/g_zsyntax.cmx: parsing/ast.cmx lib/bignat.cmx parsing/coqast.cmx \ + parsing/esyntax.cmx parsing/extend.cmx library/libnames.cmx \ + library/library.cmx kernel/names.cmx library/nametab.cmx parsing/pcoq.cmx \ + lib/pp.cmx pretyping/rawterm.cmx interp/symbols.cmx parsing/termast.cmx \ + interp/topconstr.cmx lib/util.cmx parsing/g_zsyntax.cmi parsing/lexer.cmo: parsing/lexer.cmi parsing/lexer.cmx: parsing/lexer.cmi parsing/pcoq.cmo: parsing/ast.cmi parsing/coqast.cmi library/decl_kinds.cmo \ - parsing/genarg.cmi parsing/lexer.cmi lib/options.cmi lib/pp.cmi \ - proofs/tacexpr.cmo lib/util.cmi parsing/pcoq.cmi + parsing/extend.cmi interp/genarg.cmi parsing/lexer.cmi \ + library/libnames.cmi kernel/names.cmi lib/options.cmi lib/pp.cmi \ + pretyping/rawterm.cmi proofs/tacexpr.cmo interp/topconstr.cmi \ + lib/util.cmi parsing/pcoq.cmi parsing/pcoq.cmx: parsing/ast.cmx parsing/coqast.cmx library/decl_kinds.cmx \ - parsing/genarg.cmx parsing/lexer.cmx lib/options.cmx lib/pp.cmx \ - proofs/tacexpr.cmx lib/util.cmx parsing/pcoq.cmi -parsing/ppconstr.cmo: parsing/ast.cmi parsing/coqast.cmi lib/dyn.cmi \ - parsing/esyntax.cmi parsing/extend.cmi parsing/genarg.cmi \ - library/libnames.cmi library/nameops.cmi kernel/names.cmi \ - library/nametab.cmi lib/pp.cmi pretyping/rawterm.cmi parsing/termast.cmi \ - lib/util.cmi parsing/ppconstr.cmi -parsing/ppconstr.cmx: parsing/ast.cmx parsing/coqast.cmx lib/dyn.cmx \ - parsing/esyntax.cmx parsing/extend.cmx parsing/genarg.cmx \ - library/libnames.cmx library/nameops.cmx kernel/names.cmx \ - library/nametab.cmx lib/pp.cmx pretyping/rawterm.cmx parsing/termast.cmx \ - lib/util.cmx parsing/ppconstr.cmi -parsing/pptactic.cmo: kernel/closure.cmi parsing/coqast.cmi lib/dyn.cmi \ - parsing/egrammar.cmi parsing/extend.cmi parsing/genarg.cmi \ - library/libnames.cmi library/nameops.cmi kernel/names.cmi lib/pp.cmi \ - parsing/ppconstr.cmi parsing/printer.cmi pretyping/rawterm.cmi \ - proofs/tacexpr.cmo lib/util.cmi parsing/pptactic.cmi -parsing/pptactic.cmx: kernel/closure.cmx parsing/coqast.cmx lib/dyn.cmx \ - parsing/egrammar.cmx parsing/extend.cmx parsing/genarg.cmx \ - library/libnames.cmx library/nameops.cmx kernel/names.cmx lib/pp.cmx \ - parsing/ppconstr.cmx parsing/printer.cmx pretyping/rawterm.cmx \ - proofs/tacexpr.cmx lib/util.cmx parsing/pptactic.cmi + parsing/extend.cmx interp/genarg.cmx parsing/lexer.cmx \ + library/libnames.cmx kernel/names.cmx lib/options.cmx lib/pp.cmx \ + pretyping/rawterm.cmx proofs/tacexpr.cmx interp/topconstr.cmx \ + lib/util.cmx parsing/pcoq.cmi +parsing/ppconstr.cmo: parsing/ast.cmi lib/bignat.cmi parsing/coqast.cmi \ + lib/dyn.cmi parsing/esyntax.cmi interp/genarg.cmi library/libnames.cmi \ + library/nameops.cmi kernel/names.cmi library/nametab.cmi lib/pp.cmi \ + interp/ppextend.cmi pretyping/rawterm.cmi interp/symbols.cmi \ + kernel/term.cmi parsing/termast.cmi interp/topconstr.cmi lib/util.cmi \ + parsing/ppconstr.cmi +parsing/ppconstr.cmx: parsing/ast.cmx lib/bignat.cmx parsing/coqast.cmx \ + lib/dyn.cmx parsing/esyntax.cmx interp/genarg.cmx library/libnames.cmx \ + library/nameops.cmx kernel/names.cmx library/nametab.cmx lib/pp.cmx \ + interp/ppextend.cmx pretyping/rawterm.cmx interp/symbols.cmx \ + kernel/term.cmx parsing/termast.cmx interp/topconstr.cmx lib/util.cmx \ + parsing/ppconstr.cmi +parsing/pptactic.cmo: kernel/closure.cmi lib/dyn.cmi parsing/egrammar.cmi \ + parsing/extend.cmi interp/genarg.cmi library/libnames.cmi \ + library/nameops.cmi kernel/names.cmi lib/pp.cmi parsing/ppconstr.cmi \ + parsing/printer.cmi pretyping/rawterm.cmi proofs/tacexpr.cmo \ + kernel/term.cmi interp/topconstr.cmi lib/util.cmi parsing/pptactic.cmi +parsing/pptactic.cmx: kernel/closure.cmx lib/dyn.cmx parsing/egrammar.cmx \ + parsing/extend.cmx interp/genarg.cmx library/libnames.cmx \ + library/nameops.cmx kernel/names.cmx lib/pp.cmx parsing/ppconstr.cmx \ + parsing/printer.cmx pretyping/rawterm.cmx proofs/tacexpr.cmx \ + kernel/term.cmx interp/topconstr.cmx lib/util.cmx parsing/pptactic.cmi parsing/prettyp.cmo: pretyping/classops.cmi kernel/declarations.cmi \ library/declare.cmi kernel/environ.cmi pretyping/evd.cmi \ library/global.cmi library/impargs.cmi kernel/inductive.cmi \ @@ -882,7 +946,7 @@ parsing/prettyp.cmo: pretyping/classops.cmi kernel/declarations.cmi \ library/libnames.cmi library/libobject.cmi library/nameops.cmi \ kernel/names.cmi library/nametab.cmi lib/pp.cmi parsing/printer.cmi \ parsing/printmod.cmi kernel/reduction.cmi kernel/safe_typing.cmi \ - kernel/sign.cmi pretyping/syntax_def.cmi kernel/term.cmi \ + kernel/sign.cmi interp/syntax_def.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 pretyping/evd.cmx \ @@ -891,35 +955,37 @@ parsing/prettyp.cmx: pretyping/classops.cmx kernel/declarations.cmx \ library/libnames.cmx library/libobject.cmx library/nameops.cmx \ kernel/names.cmx library/nametab.cmx lib/pp.cmx parsing/printer.cmx \ parsing/printmod.cmx kernel/reduction.cmx kernel/safe_typing.cmx \ - kernel/sign.cmx pretyping/syntax_def.cmx kernel/term.cmx \ + kernel/sign.cmx interp/syntax_def.cmx kernel/term.cmx \ pretyping/termops.cmx lib/util.cmx parsing/prettyp.cmi parsing/printer.cmo: parsing/ast.cmi parsing/coqast.cmi library/declare.cmi \ kernel/environ.cmi parsing/extend.cmi library/global.cmi \ library/libnames.cmi library/nameops.cmi kernel/names.cmi \ library/nametab.cmi lib/options.cmi pretyping/pattern.cmi lib/pp.cmi \ - parsing/ppconstr.cmi kernel/sign.cmi kernel/term.cmi parsing/termast.cmi \ - pretyping/termops.cmi lib/util.cmi parsing/printer.cmi + parsing/ppconstr.cmi interp/ppextend.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 \ kernel/environ.cmx parsing/extend.cmx library/global.cmx \ library/libnames.cmx library/nameops.cmx kernel/names.cmx \ library/nametab.cmx lib/options.cmx pretyping/pattern.cmx lib/pp.cmx \ - parsing/ppconstr.cmx kernel/sign.cmx kernel/term.cmx parsing/termast.cmx \ - pretyping/termops.cmx lib/util.cmx parsing/printer.cmi + parsing/ppconstr.cmx interp/ppextend.cmx kernel/sign.cmx kernel/term.cmx \ + parsing/termast.cmx pretyping/termops.cmx lib/util.cmx \ + parsing/printer.cmi parsing/printmod.cmo: kernel/declarations.cmi library/global.cmi \ library/libnames.cmi library/nameops.cmi kernel/names.cmi \ library/nametab.cmi lib/pp.cmi lib/util.cmi parsing/printmod.cmi parsing/printmod.cmx: kernel/declarations.cmx library/global.cmx \ library/libnames.cmx library/nameops.cmx kernel/names.cmx \ library/nametab.cmx lib/pp.cmx lib/util.cmx parsing/printmod.cmi -parsing/q_coqast.cmo: parsing/coqast.cmi parsing/genarg.cmi \ +parsing/q_coqast.cmo: parsing/coqast.cmi interp/genarg.cmi \ library/libnames.cmi kernel/names.cmi parsing/pcoq.cmi parsing/q_util.cmi \ - pretyping/rawterm.cmi proofs/tacexpr.cmo -parsing/q_coqast.cmx: parsing/coqast.cmx parsing/genarg.cmx \ + pretyping/rawterm.cmi proofs/tacexpr.cmo interp/topconstr.cmi +parsing/q_coqast.cmx: parsing/coqast.cmx interp/genarg.cmx \ library/libnames.cmx kernel/names.cmx parsing/pcoq.cmx parsing/q_util.cmx \ - pretyping/rawterm.cmx proofs/tacexpr.cmx + pretyping/rawterm.cmx proofs/tacexpr.cmx interp/topconstr.cmx parsing/q_util.cmo: parsing/q_util.cmi parsing/q_util.cmx: parsing/q_util.cmi -parsing/search.cmo: parsing/astterm.cmi parsing/coqast.cmi parsing/coqlib.cmi \ +parsing/search.cmo: parsing/coqast.cmi interp/coqlib.cmi \ kernel/declarations.cmi library/declare.cmi library/declaremods.cmi \ kernel/environ.cmi pretyping/evd.cmi library/global.cmi \ library/libnames.cmi library/libobject.cmi library/library.cmi \ @@ -927,7 +993,7 @@ parsing/search.cmo: parsing/astterm.cmi parsing/coqast.cmi parsing/coqlib.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 \ +parsing/search.cmx: parsing/coqast.cmx interp/coqlib.cmx \ kernel/declarations.cmx library/declare.cmx library/declaremods.cmx \ kernel/environ.cmx pretyping/evd.cmx library/global.cmx \ library/libnames.cmx library/libobject.cmx library/library.cmx \ @@ -935,22 +1001,12 @@ parsing/search.cmx: parsing/astterm.cmx parsing/coqast.cmx parsing/coqlib.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/symbols.cmo: lib/bignat.cmi parsing/coqast.cmi parsing/extend.cmi \ - library/lib.cmi library/libnames.cmi library/libobject.cmi \ - kernel/names.cmi library/nametab.cmi lib/options.cmi lib/pp.cmi \ - pretyping/rawterm.cmi library/summary.cmi lib/util.cmi \ - parsing/symbols.cmi -parsing/symbols.cmx: lib/bignat.cmx parsing/coqast.cmx parsing/extend.cmx \ - library/lib.cmx library/libnames.cmx library/libobject.cmx \ - kernel/names.cmx library/nametab.cmx lib/options.cmx lib/pp.cmx \ - pretyping/rawterm.cmx library/summary.cmx lib/util.cmx \ - parsing/symbols.cmi -parsing/tacextend.cmo: parsing/ast.cmi parsing/genarg.cmi parsing/pcoq.cmi \ - lib/pp.cmi lib/pp_control.cmi parsing/q_coqast.cmo parsing/q_util.cmi \ - lib/util.cmi toplevel/vernacexpr.cmo -parsing/tacextend.cmx: parsing/ast.cmx parsing/genarg.cmx parsing/pcoq.cmx \ - lib/pp.cmx lib/pp_control.cmx parsing/q_coqast.cmx parsing/q_util.cmx \ - lib/util.cmx toplevel/vernacexpr.cmx +parsing/tacextend.cmo: interp/genarg.cmi parsing/pcoq.cmi lib/pp.cmi \ + lib/pp_control.cmi parsing/q_coqast.cmo parsing/q_util.cmi lib/util.cmi \ + toplevel/vernacexpr.cmo +parsing/tacextend.cmx: interp/genarg.cmx parsing/pcoq.cmx lib/pp.cmx \ + lib/pp_control.cmx parsing/q_coqast.cmx parsing/q_util.cmx lib/util.cmx \ + toplevel/vernacexpr.cmx 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 \ @@ -967,10 +1023,10 @@ parsing/termast.cmx: parsing/ast.cmx pretyping/classops.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 -parsing/vernacextend.cmo: parsing/ast.cmi parsing/genarg.cmi parsing/pcoq.cmi \ +parsing/vernacextend.cmo: parsing/ast.cmi interp/genarg.cmi parsing/pcoq.cmi \ lib/pp.cmi lib/pp_control.cmi parsing/q_coqast.cmo parsing/q_util.cmi \ lib/util.cmi toplevel/vernacexpr.cmo -parsing/vernacextend.cmx: parsing/ast.cmx parsing/genarg.cmx parsing/pcoq.cmx \ +parsing/vernacextend.cmx: parsing/ast.cmx interp/genarg.cmx parsing/pcoq.cmx \ lib/pp.cmx lib/pp_control.cmx parsing/q_coqast.cmx parsing/q_util.cmx \ lib/util.cmx toplevel/vernacexpr.cmx pretyping/cases.cmo: pretyping/coercion.cmi kernel/declarations.cmi \ @@ -1021,26 +1077,24 @@ pretyping/coercion.cmx: pretyping/classops.cmx kernel/environ.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 pretyping/inductiveops.cmi \ - library/libnames.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 + kernel/inductive.cmi pretyping/inductiveops.cmi library/libnames.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 pretyping/inductiveops.cmx \ - library/libnames.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 + kernel/inductive.cmx pretyping/inductiveops.cmx library/libnames.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 \ - pretyping/evd.cmi pretyping/instantiate.cmi kernel/names.cmi \ + kernel/environ.cmi pretyping/evarutil.cmi pretyping/evd.cmi \ + pretyping/instantiate.cmi library/libnames.cmi kernel/names.cmi \ pretyping/rawterm.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 \ - pretyping/evd.cmx pretyping/instantiate.cmx kernel/names.cmx \ + kernel/environ.cmx pretyping/evarutil.cmx pretyping/evd.cmx \ + pretyping/instantiate.cmx library/libnames.cmx kernel/names.cmx \ pretyping/rawterm.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 pretyping/evd.cmi \ @@ -1095,14 +1149,14 @@ pretyping/instantiate.cmo: kernel/declarations.cmi kernel/environ.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 \ - library/libnames.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 \ - library/libnames.cmx 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/pattern.cmo: kernel/environ.cmi library/libnames.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: kernel/environ.cmx library/libnames.cmx \ + 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 \ @@ -1114,20 +1168,20 @@ pretyping/pretype_errors.cmx: kernel/environ.cmx pretyping/evd.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 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 \ + pretyping/coercion.cmi kernel/declarations.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 library/libnames.cmi \ kernel/names.cmi lib/pp.cmi pretyping/pretype_errors.cmi \ pretyping/rawterm.cmi pretyping/recordops.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/pretyping.cmi pretyping/pretyping.cmx: pretyping/cases.cmx pretyping/classops.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 \ + pretyping/coercion.cmx kernel/declarations.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 library/libnames.cmx \ kernel/names.cmx lib/pp.cmx pretyping/pretype_errors.cmx \ pretyping/rawterm.cmx pretyping/recordops.cmx pretyping/reductionops.cmx \ pretyping/retyping.cmx kernel/sign.cmx kernel/term.cmx \ @@ -1169,14 +1223,6 @@ pretyping/retyping.cmx: kernel/declarations.cmx kernel/environ.cmx \ kernel/inductive.cmx pretyping/inductiveops.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/libnames.cmi \ - library/libobject.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/libnames.cmx \ - library/libobject.cmx 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/conv_oracle.cmi kernel/declarations.cmi kernel/environ.cmi \ pretyping/evd.cmi library/global.cmi kernel/inductive.cmi \ @@ -1223,14 +1269,14 @@ proofs/clenv.cmx: kernel/environ.cmx proofs/evar_refiner.cmx \ pretyping/retyping.cmx kernel/sign.cmx proofs/tacexpr.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 \ +proofs/evar_refiner.cmo: interp/constrintern.cmi kernel/environ.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 \ proofs/tacexpr.cmo 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 \ +proofs/evar_refiner.cmx: interp/constrintern.cmx kernel/environ.cmx \ 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 \ @@ -1253,19 +1299,19 @@ proofs/logic.cmx: parsing/coqast.cmx library/declare.cmx kernel/environ.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 library/decl_kinds.cmo \ - kernel/declarations.cmi library/declare.cmi lib/edit.cmi \ - kernel/entries.cmi kernel/environ.cmi proofs/evar_refiner.cmi \ - pretyping/evd.cmi library/lib.cmi library/nameops.cmi kernel/names.cmi \ - lib/pp.cmi proofs/proof_trees.cmi proofs/proof_type.cmi \ - kernel/safe_typing.cmi kernel/sign.cmi proofs/tacmach.cmi kernel/term.cmi \ +proofs/pfedit.cmo: library/decl_kinds.cmo kernel/declarations.cmi \ + library/declare.cmi lib/edit.cmi kernel/entries.cmi kernel/environ.cmi \ + proofs/evar_refiner.cmi pretyping/evd.cmi library/lib.cmi \ + library/nameops.cmi kernel/names.cmi lib/pp.cmi proofs/proof_trees.cmi \ + proofs/proof_type.cmi kernel/safe_typing.cmi kernel/sign.cmi \ + proofs/tacexpr.cmo proofs/tacmach.cmi kernel/term.cmi \ pretyping/typing.cmi lib/util.cmi proofs/pfedit.cmi -proofs/pfedit.cmx: parsing/astterm.cmx library/decl_kinds.cmx \ - kernel/declarations.cmx library/declare.cmx lib/edit.cmx \ - kernel/entries.cmx kernel/environ.cmx proofs/evar_refiner.cmx \ - pretyping/evd.cmx library/lib.cmx library/nameops.cmx kernel/names.cmx \ - lib/pp.cmx proofs/proof_trees.cmx proofs/proof_type.cmx \ - kernel/safe_typing.cmx kernel/sign.cmx proofs/tacmach.cmx kernel/term.cmx \ +proofs/pfedit.cmx: library/decl_kinds.cmx kernel/declarations.cmx \ + library/declare.cmx lib/edit.cmx kernel/entries.cmx kernel/environ.cmx \ + proofs/evar_refiner.cmx pretyping/evd.cmx library/lib.cmx \ + library/nameops.cmx kernel/names.cmx lib/pp.cmx proofs/proof_trees.cmx \ + proofs/proof_type.cmx kernel/safe_typing.cmx kernel/sign.cmx \ + proofs/tacexpr.cmx proofs/tacmach.cmx kernel/term.cmx \ pretyping/typing.cmx lib/util.cmx proofs/pfedit.cmi proofs/proof_trees.cmo: kernel/closure.cmi pretyping/detyping.cmi \ kernel/environ.cmi pretyping/evarutil.cmi pretyping/evd.cmi \ @@ -1281,12 +1327,10 @@ proofs/proof_trees.cmx: kernel/closure.cmx pretyping/detyping.cmx \ proofs/proof_type.cmx kernel/sign.cmx pretyping/tacred.cmx \ kernel/term.cmx pretyping/termops.cmx pretyping/typing.cmx lib/util.cmx \ proofs/proof_trees.cmi -proofs/proof_type.cmo: kernel/closure.cmi library/decl_kinds.cmo \ - kernel/environ.cmi pretyping/evd.cmi parsing/genarg.cmi \ +proofs/proof_type.cmo: kernel/environ.cmi pretyping/evd.cmi interp/genarg.cmi \ library/libnames.cmi kernel/names.cmi pretyping/rawterm.cmi \ proofs/tacexpr.cmo kernel/term.cmi lib/util.cmi proofs/proof_type.cmi -proofs/proof_type.cmx: kernel/closure.cmx library/decl_kinds.cmx \ - kernel/environ.cmx pretyping/evd.cmx parsing/genarg.cmx \ +proofs/proof_type.cmx: kernel/environ.cmx pretyping/evd.cmx interp/genarg.cmx \ library/libnames.cmx kernel/names.cmx pretyping/rawterm.cmx \ proofs/tacexpr.cmx kernel/term.cmx lib/util.cmx proofs/proof_type.cmi proofs/refiner.cmo: kernel/environ.cmi pretyping/evarutil.cmi \ @@ -1301,13 +1345,13 @@ proofs/refiner.cmx: kernel/environ.cmx pretyping/evarutil.cmx \ proofs/proof_trees.cmx proofs/proof_type.cmx pretyping/reductionops.cmx \ kernel/sign.cmx proofs/tacexpr.cmx kernel/term.cmx pretyping/termops.cmx \ kernel/type_errors.cmx lib/util.cmx proofs/refiner.cmi -proofs/tacexpr.cmo: parsing/coqast.cmi lib/dyn.cmi parsing/genarg.cmi \ +proofs/tacexpr.cmo: library/decl_kinds.cmo lib/dyn.cmi interp/genarg.cmi \ library/libnames.cmi kernel/names.cmi library/nametab.cmi \ - pretyping/rawterm.cmi lib/util.cmi -proofs/tacexpr.cmx: parsing/coqast.cmx lib/dyn.cmx parsing/genarg.cmx \ + pretyping/rawterm.cmi interp/topconstr.cmi lib/util.cmi +proofs/tacexpr.cmx: library/decl_kinds.cmx lib/dyn.cmx interp/genarg.cmx \ library/libnames.cmx kernel/names.cmx library/nametab.cmx \ - pretyping/rawterm.cmx lib/util.cmx -proofs/tacmach.cmo: parsing/astterm.cmi library/declare.cmi \ + pretyping/rawterm.cmx interp/topconstr.cmx lib/util.cmx +proofs/tacmach.cmo: interp/constrintern.cmi library/declare.cmi \ kernel/environ.cmi pretyping/evarutil.cmi pretyping/evd.cmi \ library/global.cmi pretyping/instantiate.cmi proofs/logic.cmi \ library/nameops.cmi kernel/names.cmi lib/pp.cmi parsing/printer.cmi \ @@ -1316,7 +1360,7 @@ proofs/tacmach.cmo: parsing/astterm.cmi library/declare.cmi \ proofs/tacexpr.cmo pretyping/tacred.cmi kernel/term.cmi \ pretyping/termops.cmi pretyping/typing.cmi lib/util.cmi \ proofs/tacmach.cmi -proofs/tacmach.cmx: parsing/astterm.cmx library/declare.cmx \ +proofs/tacmach.cmx: interp/constrintern.cmx library/declare.cmx \ kernel/environ.cmx pretyping/evarutil.cmx pretyping/evd.cmx \ library/global.cmx pretyping/instantiate.cmx proofs/logic.cmx \ library/nameops.cmx kernel/names.cmx lib/pp.cmx parsing/printer.cmx \ @@ -1335,8 +1379,8 @@ scripts/coqc.cmo: config/coq_config.cmi toplevel/usage.cmi 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 \ - kernel/declarations.cmi library/declare.cmi tactics/dhyp.cmi \ +tactics/auto.cmo: tactics/btermdn.cmi proofs/clenv.cmi \ + interp/constrintern.cmi kernel/declarations.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/libnames.cmi library/libobject.cmi \ @@ -1349,8 +1393,8 @@ tactics/auto.cmo: parsing/astterm.cmi tactics/btermdn.cmi proofs/clenv.cmi \ tactics/tactics.cmi kernel/term.cmi pretyping/termops.cmi \ pretyping/typing.cmi lib/util.cmi toplevel/vernacexpr.cmo \ tactics/auto.cmi -tactics/auto.cmx: parsing/astterm.cmx tactics/btermdn.cmx proofs/clenv.cmx \ - kernel/declarations.cmx library/declare.cmx tactics/dhyp.cmx \ +tactics/auto.cmx: tactics/btermdn.cmx proofs/clenv.cmx \ + interp/constrintern.cmx kernel/declarations.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/libnames.cmx library/libobject.cmx \ @@ -1379,37 +1423,35 @@ tactics/btermdn.cmo: tactics/dn.cmi pretyping/pattern.cmi kernel/term.cmi \ tactics/termdn.cmi tactics/btermdn.cmi tactics/btermdn.cmx: tactics/dn.cmx pretyping/pattern.cmx kernel/term.cmx \ tactics/termdn.cmx tactics/btermdn.cmi -tactics/contradiction.cmo: parsing/coqlib.cmi tactics/hipattern.cmi \ +tactics/contradiction.cmo: interp/coqlib.cmi tactics/hipattern.cmi \ proofs/proof_type.cmi proofs/tacmach.cmi tactics/tacticals.cmi \ tactics/tactics.cmi kernel/term.cmi lib/util.cmi \ tactics/contradiction.cmi -tactics/contradiction.cmx: parsing/coqlib.cmx tactics/hipattern.cmx \ +tactics/contradiction.cmx: interp/coqlib.cmx tactics/hipattern.cmx \ proofs/proof_type.cmx proofs/tacmach.cmx tactics/tacticals.cmx \ tactics/tactics.cmx kernel/term.cmx lib/util.cmx \ tactics/contradiction.cmi -tactics/dhyp.cmo: parsing/ast.cmi parsing/astterm.cmi proofs/clenv.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 proofs/refiner.cmi \ - library/summary.cmi proofs/tacexpr.cmo proofs/tacmach.cmi \ - tactics/tacticals.cmi tactics/tactics.cmi kernel/term.cmi lib/util.cmi \ - tactics/dhyp.cmi -tactics/dhyp.cmx: parsing/ast.cmx parsing/astterm.cmx proofs/clenv.cmx \ - 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 proofs/refiner.cmx \ - library/summary.cmx proofs/tacexpr.cmx proofs/tacmach.cmx \ - tactics/tacticals.cmx tactics/tactics.cmx kernel/term.cmx lib/util.cmx \ - tactics/dhyp.cmi +tactics/dhyp.cmo: parsing/ast.cmi proofs/clenv.cmi interp/constrintern.cmi \ + kernel/environ.cmi pretyping/evd.cmi library/global.cmi library/lib.cmi \ + library/libnames.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 proofs/refiner.cmi library/summary.cmi \ + proofs/tacexpr.cmo proofs/tacmach.cmi tactics/tacticals.cmi \ + tactics/tactics.cmi kernel/term.cmi lib/util.cmi tactics/dhyp.cmi +tactics/dhyp.cmx: parsing/ast.cmx proofs/clenv.cmx interp/constrintern.cmx \ + kernel/environ.cmx pretyping/evd.cmx library/global.cmx library/lib.cmx \ + library/libnames.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 proofs/refiner.cmx library/summary.cmx \ + proofs/tacexpr.cmx proofs/tacmach.cmx tactics/tacticals.cmx \ + tactics/tactics.cmx kernel/term.cmx lib/util.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 toplevel/cerrors.cmi proofs/clenv.cmi \ parsing/egrammar.cmi proofs/evar_refiner.cmi lib/explore.cmi \ - parsing/genarg.cmi proofs/logic.cmi library/nameops.cmi kernel/names.cmi \ + interp/genarg.cmi proofs/logic.cmi library/nameops.cmi kernel/names.cmi \ pretyping/pattern.cmi parsing/pcoq.cmi lib/pp.cmi parsing/pptactic.cmi \ proofs/proof_trees.cmi proofs/proof_type.cmi pretyping/rawterm.cmi \ kernel/reduction.cmi proofs/refiner.cmi kernel/sign.cmi \ @@ -1417,7 +1459,7 @@ tactics/eauto.cmo: tactics/auto.cmi toplevel/cerrors.cmi proofs/clenv.cmi \ tactics/tactics.cmi kernel/term.cmi pretyping/termops.cmi lib/util.cmi tactics/eauto.cmx: tactics/auto.cmx toplevel/cerrors.cmx proofs/clenv.cmx \ parsing/egrammar.cmx proofs/evar_refiner.cmx lib/explore.cmx \ - parsing/genarg.cmx proofs/logic.cmx library/nameops.cmx kernel/names.cmx \ + interp/genarg.cmx proofs/logic.cmx library/nameops.cmx kernel/names.cmx \ pretyping/pattern.cmx parsing/pcoq.cmx lib/pp.cmx parsing/pptactic.cmx \ proofs/proof_trees.cmx proofs/proof_type.cmx pretyping/rawterm.cmx \ kernel/reduction.cmx proofs/refiner.cmx kernel/sign.cmx \ @@ -1437,25 +1479,23 @@ tactics/elim.cmx: proofs/clenv.cmx kernel/environ.cmx tactics/hiddentac.cmx \ proofs/tacexpr.cmx proofs/tacmach.cmx tactics/tacticals.cmx \ tactics/tactics.cmx kernel/term.cmx pretyping/termops.cmx lib/util.cmx \ tactics/elim.cmi -tactics/eqdecide.cmo: tactics/auto.cmi toplevel/cerrors.cmi \ - parsing/coqlib.cmi kernel/declarations.cmi parsing/egrammar.cmi \ - tactics/equality.cmi tactics/extratactics.cmi parsing/genarg.cmi \ - library/global.cmi tactics/hiddentac.cmi tactics/hipattern.cmi \ - library/nameops.cmi kernel/names.cmi pretyping/pattern.cmi \ - parsing/pcoq.cmi lib/pp.cmi parsing/pptactic.cmi proofs/proof_trees.cmi \ - proofs/proof_type.cmi pretyping/rawterm.cmi proofs/refiner.cmi \ - proofs/tacmach.cmi tactics/tacticals.cmi tactics/tactics.cmi \ - kernel/term.cmi lib/util.cmi -tactics/eqdecide.cmx: tactics/auto.cmx toplevel/cerrors.cmx \ - parsing/coqlib.cmx kernel/declarations.cmx parsing/egrammar.cmx \ - tactics/equality.cmx tactics/extratactics.cmx parsing/genarg.cmx \ - library/global.cmx tactics/hiddentac.cmx tactics/hipattern.cmx \ - library/nameops.cmx kernel/names.cmx pretyping/pattern.cmx \ - parsing/pcoq.cmx lib/pp.cmx parsing/pptactic.cmx proofs/proof_trees.cmx \ - proofs/proof_type.cmx pretyping/rawterm.cmx proofs/refiner.cmx \ - proofs/tacmach.cmx tactics/tacticals.cmx tactics/tactics.cmx \ - kernel/term.cmx lib/util.cmx -tactics/equality.cmo: proofs/clenv.cmi parsing/coqlib.cmi \ +tactics/eqdecide.cmo: tactics/auto.cmi toplevel/cerrors.cmi interp/coqlib.cmi \ + kernel/declarations.cmi parsing/egrammar.cmi tactics/equality.cmi \ + tactics/extratactics.cmi interp/genarg.cmi library/global.cmi \ + tactics/hiddentac.cmi tactics/hipattern.cmi library/nameops.cmi \ + kernel/names.cmi pretyping/pattern.cmi parsing/pcoq.cmi lib/pp.cmi \ + parsing/pptactic.cmi proofs/proof_trees.cmi proofs/proof_type.cmi \ + pretyping/rawterm.cmi proofs/refiner.cmi proofs/tacmach.cmi \ + tactics/tacticals.cmi tactics/tactics.cmi kernel/term.cmi lib/util.cmi +tactics/eqdecide.cmx: tactics/auto.cmx toplevel/cerrors.cmx interp/coqlib.cmx \ + kernel/declarations.cmx parsing/egrammar.cmx tactics/equality.cmx \ + tactics/extratactics.cmx interp/genarg.cmx library/global.cmx \ + tactics/hiddentac.cmx tactics/hipattern.cmx library/nameops.cmx \ + kernel/names.cmx pretyping/pattern.cmx parsing/pcoq.cmx lib/pp.cmx \ + parsing/pptactic.cmx proofs/proof_trees.cmx proofs/proof_type.cmx \ + pretyping/rawterm.cmx proofs/refiner.cmx proofs/tacmach.cmx \ + tactics/tacticals.cmx tactics/tactics.cmx kernel/term.cmx lib/util.cmx +tactics/equality.cmo: proofs/clenv.cmi interp/coqlib.cmi \ kernel/declarations.cmi kernel/environ.cmi proofs/evar_refiner.cmi \ pretyping/evarutil.cmi tactics/hipattern.cmi pretyping/indrec.cmi \ kernel/inductive.cmi pretyping/inductiveops.cmi pretyping/instantiate.cmi \ @@ -1468,7 +1508,7 @@ tactics/equality.cmo: proofs/clenv.cmi parsing/coqlib.cmi \ kernel/typeops.cmi pretyping/typing.cmi kernel/univ.cmi lib/util.cmi \ toplevel/vernacexpr.cmo toplevel/vernacinterp.cmi tactics/wcclausenv.cmi \ tactics/equality.cmi -tactics/equality.cmx: proofs/clenv.cmx parsing/coqlib.cmx \ +tactics/equality.cmx: proofs/clenv.cmx interp/coqlib.cmx \ kernel/declarations.cmx kernel/environ.cmx proofs/evar_refiner.cmx \ pretyping/evarutil.cmx tactics/hipattern.cmx pretyping/indrec.cmx \ kernel/inductive.cmx pretyping/inductiveops.cmx pretyping/instantiate.cmx \ @@ -1481,32 +1521,30 @@ tactics/equality.cmx: proofs/clenv.cmx parsing/coqlib.cmx \ kernel/typeops.cmx pretyping/typing.cmx kernel/univ.cmx lib/util.cmx \ toplevel/vernacexpr.cmx toplevel/vernacinterp.cmx tactics/wcclausenv.cmx \ tactics/equality.cmi -tactics/extraargs.cmo: parsing/extend.cmi parsing/genarg.cmi \ +tactics/extraargs.cmo: parsing/extend.cmi interp/genarg.cmi \ toplevel/metasyntax.cmi parsing/pcoq.cmi lib/pp.cmi parsing/ppconstr.cmi \ parsing/pptactic.cmi parsing/printer.cmi tactics/tacinterp.cmi \ tactics/extraargs.cmi -tactics/extraargs.cmx: parsing/extend.cmx parsing/genarg.cmx \ +tactics/extraargs.cmx: parsing/extend.cmx interp/genarg.cmx \ toplevel/metasyntax.cmx parsing/pcoq.cmx lib/pp.cmx parsing/ppconstr.cmx \ parsing/pptactic.cmx parsing/printer.cmx tactics/tacinterp.cmx \ tactics/extraargs.cmi -tactics/extratactics.cmo: parsing/astterm.cmi tactics/autorewrite.cmi \ - toplevel/cerrors.cmi tactics/contradiction.cmi parsing/coqast.cmi \ - parsing/egrammar.cmi tactics/equality.cmi pretyping/evd.cmi \ - tactics/extraargs.cmi parsing/genarg.cmi library/global.cmi \ - tactics/inv.cmi tactics/leminv.cmi parsing/pcoq.cmi lib/pp.cmi \ - parsing/pptactic.cmi pretyping/rawterm.cmi tactics/refine.cmi \ - proofs/refiner.cmi tactics/setoid_replace.cmi proofs/tacexpr.cmo \ - tactics/tacinterp.cmi kernel/term.cmi toplevel/vernacinterp.cmi \ - tactics/extratactics.cmi -tactics/extratactics.cmx: parsing/astterm.cmx tactics/autorewrite.cmx \ - toplevel/cerrors.cmx tactics/contradiction.cmx parsing/coqast.cmx \ - parsing/egrammar.cmx tactics/equality.cmx pretyping/evd.cmx \ - tactics/extraargs.cmx parsing/genarg.cmx library/global.cmx \ - tactics/inv.cmx tactics/leminv.cmx parsing/pcoq.cmx lib/pp.cmx \ - parsing/pptactic.cmx pretyping/rawterm.cmx tactics/refine.cmx \ - proofs/refiner.cmx tactics/setoid_replace.cmx proofs/tacexpr.cmx \ - tactics/tacinterp.cmx kernel/term.cmx toplevel/vernacinterp.cmx \ - tactics/extratactics.cmi +tactics/extratactics.cmo: tactics/autorewrite.cmi toplevel/cerrors.cmi \ + interp/constrintern.cmi tactics/contradiction.cmi parsing/egrammar.cmi \ + tactics/equality.cmi pretyping/evd.cmi tactics/extraargs.cmi \ + interp/genarg.cmi library/global.cmi tactics/inv.cmi tactics/leminv.cmi \ + parsing/pcoq.cmi lib/pp.cmi parsing/pptactic.cmi pretyping/rawterm.cmi \ + tactics/refine.cmi proofs/refiner.cmi tactics/setoid_replace.cmi \ + proofs/tacexpr.cmo tactics/tacinterp.cmi kernel/term.cmi \ + toplevel/vernacinterp.cmi tactics/extratactics.cmi +tactics/extratactics.cmx: tactics/autorewrite.cmx toplevel/cerrors.cmx \ + interp/constrintern.cmx tactics/contradiction.cmx parsing/egrammar.cmx \ + tactics/equality.cmx pretyping/evd.cmx tactics/extraargs.cmx \ + interp/genarg.cmx library/global.cmx tactics/inv.cmx tactics/leminv.cmx \ + parsing/pcoq.cmx lib/pp.cmx parsing/pptactic.cmx pretyping/rawterm.cmx \ + tactics/refine.cmx proofs/refiner.cmx tactics/setoid_replace.cmx \ + proofs/tacexpr.cmx tactics/tacinterp.cmx kernel/term.cmx \ + toplevel/vernacinterp.cmx tactics/extratactics.cmi tactics/hiddentac.cmo: proofs/evar_refiner.cmi kernel/names.cmi \ proofs/proof_type.cmi pretyping/rawterm.cmi proofs/refiner.cmi \ proofs/tacexpr.cmo proofs/tacmach.cmi tactics/tactics.cmi kernel/term.cmi \ @@ -1515,19 +1553,19 @@ tactics/hiddentac.cmx: proofs/evar_refiner.cmx kernel/names.cmx \ proofs/proof_type.cmx pretyping/rawterm.cmx proofs/refiner.cmx \ proofs/tacexpr.cmx proofs/tacmach.cmx tactics/tactics.cmx kernel/term.cmx \ lib/util.cmx tactics/hiddentac.cmi -tactics/hipattern.cmo: proofs/clenv.cmi parsing/coqlib.cmi \ +tactics/hipattern.cmo: proofs/clenv.cmi interp/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 \ +tactics/hipattern.cmx: proofs/clenv.cmx interp/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: proofs/clenv.cmi parsing/coqlib.cmi tactics/elim.cmi \ +tactics/inv.cmo: proofs/clenv.cmi interp/coqlib.cmi tactics/elim.cmi \ kernel/environ.cmi tactics/equality.cmi proofs/evar_refiner.cmi \ library/global.cmi pretyping/inductiveops.cmi library/nameops.cmi \ kernel/names.cmi pretyping/pattern.cmi lib/pp.cmi parsing/printer.cmi \ @@ -1536,7 +1574,7 @@ tactics/inv.cmo: proofs/clenv.cmi parsing/coqlib.cmi tactics/elim.cmi \ proofs/tacexpr.cmo proofs/tacmach.cmi tactics/tacticals.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: proofs/clenv.cmx parsing/coqlib.cmx tactics/elim.cmx \ +tactics/inv.cmx: proofs/clenv.cmx interp/coqlib.cmx tactics/elim.cmx \ kernel/environ.cmx tactics/equality.cmx proofs/evar_refiner.cmx \ library/global.cmx pretyping/inductiveops.cmx library/nameops.cmx \ kernel/names.cmx pretyping/pattern.cmx lib/pp.cmx parsing/printer.cmx \ @@ -1545,26 +1583,28 @@ tactics/inv.cmx: proofs/clenv.cmx parsing/coqlib.cmx tactics/elim.cmx \ proofs/tacexpr.cmx proofs/tacmach.cmx tactics/tacticals.cmx \ 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 \ +tactics/leminv.cmo: proofs/clenv.cmi interp/constrintern.cmi \ library/decl_kinds.cmo kernel/declarations.cmi library/declare.cmi \ kernel/entries.cmi kernel/environ.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/vernacexpr.cmo tactics/wcclausenv.cmi tactics/leminv.cmi -tactics/leminv.cmx: parsing/astterm.cmx proofs/clenv.cmx \ + lib/pp.cmi pretyping/pretyping.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/vernacexpr.cmo \ + tactics/wcclausenv.cmi tactics/leminv.cmi +tactics/leminv.cmx: proofs/clenv.cmx interp/constrintern.cmx \ library/decl_kinds.cmx kernel/declarations.cmx library/declare.cmx \ kernel/entries.cmx kernel/environ.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/vernacexpr.cmx tactics/wcclausenv.cmx tactics/leminv.cmi + lib/pp.cmx pretyping/pretyping.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/vernacexpr.cmx \ + tactics/wcclausenv.cmx tactics/leminv.cmi tactics/nbtermdn.cmo: tactics/btermdn.cmi lib/gmap.cmi library/libobject.cmi \ library/library.cmi kernel/names.cmi pretyping/pattern.cmi \ kernel/term.cmi tactics/termdn.cmi lib/util.cmi tactics/nbtermdn.cmi @@ -1583,8 +1623,8 @@ tactics/refine.cmx: proofs/clenv.cmx kernel/environ.cmx pretyping/evd.cmx \ tactics/tacticals.cmx 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 library/decl_kinds.cmo library/declare.cmi \ +tactics/setoid_replace.cmo: tactics/auto.cmi toplevel/command.cmi \ + interp/constrintern.cmi library/decl_kinds.cmo library/declare.cmi \ kernel/entries.cmi kernel/environ.cmi pretyping/evd.cmi \ library/global.cmi lib/gmap.cmi library/lib.cmi library/libnames.cmi \ library/libobject.cmi library/nameops.cmi kernel/names.cmi \ @@ -1595,8 +1635,8 @@ tactics/setoid_replace.cmo: parsing/astterm.cmi tactics/auto.cmi \ pretyping/termops.cmi pretyping/typing.cmi lib/util.cmi \ toplevel/vernacentries.cmi toplevel/vernacexpr.cmo \ toplevel/vernacinterp.cmi tactics/setoid_replace.cmi -tactics/setoid_replace.cmx: parsing/astterm.cmx tactics/auto.cmx \ - toplevel/command.cmx library/decl_kinds.cmx library/declare.cmx \ +tactics/setoid_replace.cmx: tactics/auto.cmx toplevel/command.cmx \ + interp/constrintern.cmx library/decl_kinds.cmx library/declare.cmx \ kernel/entries.cmx kernel/environ.cmx pretyping/evd.cmx \ library/global.cmx lib/gmap.cmx library/lib.cmx library/libnames.cmx \ library/libobject.cmx library/nameops.cmx kernel/names.cmx \ @@ -1607,11 +1647,11 @@ tactics/setoid_replace.cmx: parsing/astterm.cmx tactics/auto.cmx \ pretyping/termops.cmx pretyping/typing.cmx lib/util.cmx \ toplevel/vernacentries.cmx toplevel/vernacexpr.cmx \ toplevel/vernacinterp.cmx tactics/setoid_replace.cmi -tactics/tacinterp.cmo: parsing/ast.cmi parsing/astterm.cmi tactics/auto.cmi \ - kernel/closure.cmi parsing/coqast.cmi library/decl_kinds.cmo \ +tactics/tacinterp.cmo: parsing/ast.cmi tactics/auto.cmi kernel/closure.cmi \ + interp/constrintern.cmi parsing/coqast.cmi library/decl_kinds.cmo \ kernel/declarations.cmi library/declare.cmi tactics/dhyp.cmi lib/dyn.cmi \ tactics/elim.cmi kernel/entries.cmi kernel/environ.cmi pretyping/evd.cmi \ - parsing/genarg.cmi library/global.cmi lib/gmap.cmi tactics/hiddentac.cmi \ + interp/genarg.cmi library/global.cmi lib/gmap.cmi tactics/hiddentac.cmi \ library/lib.cmi library/libnames.cmi library/libobject.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 \ @@ -1620,13 +1660,13 @@ tactics/tacinterp.cmo: parsing/ast.cmi parsing/astterm.cmi tactics/auto.cmi \ proofs/refiner.cmi kernel/safe_typing.cmi kernel/sign.cmi \ library/summary.cmi proofs/tacexpr.cmo proofs/tacmach.cmi \ pretyping/tacred.cmi proofs/tactic_debug.cmi tactics/tactics.cmi \ - kernel/term.cmi parsing/termast.cmi pretyping/termops.cmi \ + kernel/term.cmi pretyping/termops.cmi interp/topconstr.cmi \ pretyping/typing.cmi lib/util.cmi tactics/tacinterp.cmi -tactics/tacinterp.cmx: parsing/ast.cmx parsing/astterm.cmx tactics/auto.cmx \ - kernel/closure.cmx parsing/coqast.cmx library/decl_kinds.cmx \ +tactics/tacinterp.cmx: parsing/ast.cmx tactics/auto.cmx kernel/closure.cmx \ + interp/constrintern.cmx parsing/coqast.cmx library/decl_kinds.cmx \ kernel/declarations.cmx library/declare.cmx tactics/dhyp.cmx lib/dyn.cmx \ tactics/elim.cmx kernel/entries.cmx kernel/environ.cmx pretyping/evd.cmx \ - parsing/genarg.cmx library/global.cmx lib/gmap.cmx tactics/hiddentac.cmx \ + interp/genarg.cmx library/global.cmx lib/gmap.cmx tactics/hiddentac.cmx \ library/lib.cmx library/libnames.cmx library/libobject.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 \ @@ -1635,7 +1675,7 @@ tactics/tacinterp.cmx: parsing/ast.cmx parsing/astterm.cmx tactics/auto.cmx \ proofs/refiner.cmx kernel/safe_typing.cmx kernel/sign.cmx \ library/summary.cmx proofs/tacexpr.cmx proofs/tacmach.cmx \ pretyping/tacred.cmx proofs/tactic_debug.cmx tactics/tactics.cmx \ - kernel/term.cmx parsing/termast.cmx pretyping/termops.cmx \ + kernel/term.cmx pretyping/termops.cmx interp/topconstr.cmx \ pretyping/typing.cmx lib/util.cmx tactics/tacinterp.cmi tactics/tacticals.cmo: proofs/clenv.cmi kernel/declarations.cmi \ library/declare.cmi kernel/environ.cmi proofs/evar_refiner.cmi \ @@ -1651,8 +1691,8 @@ tactics/tacticals.cmx: proofs/clenv.cmx kernel/declarations.cmx \ kernel/reduction.cmx proofs/refiner.cmx kernel/sign.cmx \ proofs/tacmach.cmx kernel/term.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 library/decl_kinds.cmo kernel/declarations.cmi \ +tactics/tactics.cmo: proofs/clenv.cmi interp/constrintern.cmi \ + interp/coqlib.cmi library/decl_kinds.cmo kernel/declarations.cmi \ library/declare.cmi kernel/entries.cmi kernel/environ.cmi \ proofs/evar_refiner.cmi pretyping/evd.cmi library/global.cmi \ tactics/hipattern.cmi pretyping/indrec.cmi kernel/inductive.cmi \ @@ -1663,8 +1703,8 @@ tactics/tactics.cmo: parsing/astterm.cmi proofs/clenv.cmi kernel/closure.cmi \ kernel/sign.cmi proofs/tacexpr.cmo 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 library/decl_kinds.cmx kernel/declarations.cmx \ +tactics/tactics.cmx: proofs/clenv.cmx interp/constrintern.cmx \ + interp/coqlib.cmx library/decl_kinds.cmx kernel/declarations.cmx \ library/declare.cmx kernel/entries.cmx kernel/environ.cmx \ proofs/evar_refiner.cmx pretyping/evd.cmx library/global.cmx \ tactics/hipattern.cmx pretyping/indrec.cmx kernel/inductive.cmx \ @@ -1676,17 +1716,19 @@ tactics/tactics.cmx: parsing/astterm.cmx proofs/clenv.cmx kernel/closure.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 toplevel/cerrors.cmi parsing/coqast.cmi \ - parsing/egrammar.cmi parsing/genarg.cmi tactics/hipattern.cmi \ + parsing/egrammar.cmi interp/genarg.cmi tactics/hipattern.cmi \ library/libnames.cmi kernel/names.cmi parsing/pcoq.cmi lib/pp.cmi \ parsing/pptactic.cmi proofs/proof_type.cmi pretyping/rawterm.cmi \ proofs/refiner.cmi proofs/tacexpr.cmo tactics/tacinterp.cmi \ - tactics/tacticals.cmi tactics/tactics.cmi lib/util.cmi + tactics/tacticals.cmi tactics/tactics.cmi interp/topconstr.cmi \ + lib/util.cmi tactics/tauto.cmx: parsing/ast.cmx toplevel/cerrors.cmx parsing/coqast.cmx \ - parsing/egrammar.cmx parsing/genarg.cmx tactics/hipattern.cmx \ + parsing/egrammar.cmx interp/genarg.cmx tactics/hipattern.cmx \ library/libnames.cmx kernel/names.cmx parsing/pcoq.cmx lib/pp.cmx \ parsing/pptactic.cmx proofs/proof_type.cmx pretyping/rawterm.cmx \ proofs/refiner.cmx proofs/tacexpr.cmx tactics/tacinterp.cmx \ - tactics/tacticals.cmx tactics/tactics.cmx lib/util.cmx + tactics/tacticals.cmx tactics/tactics.cmx interp/topconstr.cmx \ + lib/util.cmx tactics/termdn.cmo: tactics/dn.cmi library/libnames.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 @@ -1739,34 +1781,36 @@ toplevel/class.cmx: pretyping/classops.cmx library/decl_kinds.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 toplevel/class.cmi \ - parsing/coqast.cmi library/decl_kinds.cmo kernel/declarations.cmi \ - library/declare.cmi kernel/entries.cmi kernel/environ.cmi \ - pretyping/evarutil.cmi pretyping/evd.cmi library/global.cmi \ - tactics/hiddentac.cmi library/impargs.cmi pretyping/indrec.cmi \ - kernel/indtypes.cmi kernel/inductive.cmi library/lib.cmi \ - library/libnames.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 \ +toplevel/command.cmo: toplevel/class.cmi interp/constrintern.cmi \ + library/decl_kinds.cmo kernel/declarations.cmi library/declare.cmi \ + kernel/entries.cmi kernel/environ.cmi pretyping/evarutil.cmi \ + pretyping/evd.cmi library/global.cmi tactics/hiddentac.cmi \ + library/impargs.cmi pretyping/indrec.cmi kernel/indtypes.cmi \ + kernel/inductive.cmi library/lib.cmi library/libnames.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 pretyping/pretyping.cmi parsing/printer.cmi \ proofs/proof_type.cmi kernel/reduction.cmi proofs/refiner.cmi \ pretyping/retyping.cmi kernel/safe_typing.cmi library/states.cmi \ - pretyping/syntax_def.cmi proofs/tacmach.cmi pretyping/tacred.cmi \ - kernel/term.cmi pretyping/termops.cmi kernel/typeops.cmi lib/util.cmi \ - toplevel/vernacexpr.cmo toplevel/command.cmi -toplevel/command.cmx: parsing/ast.cmx parsing/astterm.cmx toplevel/class.cmx \ - parsing/coqast.cmx library/decl_kinds.cmx kernel/declarations.cmx \ - library/declare.cmx kernel/entries.cmx kernel/environ.cmx \ - pretyping/evarutil.cmx pretyping/evd.cmx library/global.cmx \ - tactics/hiddentac.cmx library/impargs.cmx pretyping/indrec.cmx \ - kernel/indtypes.cmx kernel/inductive.cmx library/lib.cmx \ - library/libnames.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 \ + interp/syntax_def.cmi proofs/tacmach.cmi pretyping/tacred.cmi \ + kernel/term.cmi pretyping/termops.cmi interp/topconstr.cmi \ + kernel/typeops.cmi lib/util.cmi toplevel/vernacexpr.cmo \ + toplevel/command.cmi +toplevel/command.cmx: toplevel/class.cmx interp/constrintern.cmx \ + library/decl_kinds.cmx kernel/declarations.cmx library/declare.cmx \ + kernel/entries.cmx kernel/environ.cmx pretyping/evarutil.cmx \ + pretyping/evd.cmx library/global.cmx tactics/hiddentac.cmx \ + library/impargs.cmx pretyping/indrec.cmx kernel/indtypes.cmx \ + kernel/inductive.cmx library/lib.cmx library/libnames.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 pretyping/pretyping.cmx parsing/printer.cmx \ proofs/proof_type.cmx kernel/reduction.cmx proofs/refiner.cmx \ pretyping/retyping.cmx kernel/safe_typing.cmx library/states.cmx \ - pretyping/syntax_def.cmx proofs/tacmach.cmx pretyping/tacred.cmx \ - kernel/term.cmx pretyping/termops.cmx kernel/typeops.cmx lib/util.cmx \ - toplevel/vernacexpr.cmx toplevel/command.cmi + interp/syntax_def.cmx proofs/tacmach.cmx pretyping/tacred.cmx \ + kernel/term.cmx pretyping/termops.cmx interp/topconstr.cmx \ + kernel/typeops.cmx lib/util.cmx toplevel/vernacexpr.cmx \ + toplevel/command.cmi toplevel/coqinit.cmo: config/coq_config.cmi toplevel/mltop.cmi \ library/nameops.cmi kernel/names.cmi lib/options.cmi lib/pp.cmi \ lib/system.cmi toplevel/toplevel.cmi toplevel/vernac.cmi \ @@ -1831,22 +1875,22 @@ toplevel/himsg.cmx: parsing/ast.cmx pretyping/cases.cmx kernel/environ.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 \ +toplevel/metasyntax.cmo: parsing/ast.cmi interp/constrintern.cmi \ parsing/coqast.cmi parsing/egrammar.cmi parsing/esyntax.cmi \ - pretyping/evd.cmi parsing/extend.cmi parsing/genarg.cmi \ - library/global.cmi library/lib.cmi library/libobject.cmi \ - library/library.cmi kernel/names.cmi parsing/pcoq.cmi lib/pp.cmi \ - pretyping/rawterm.cmi library/summary.cmi parsing/symbols.cmi \ - parsing/termast.cmi lib/util.cmi toplevel/vernacexpr.cmo \ - toplevel/metasyntax.cmi -toplevel/metasyntax.cmx: parsing/ast.cmx parsing/astterm.cmx \ + pretyping/evd.cmi parsing/extend.cmi interp/genarg.cmi library/global.cmi \ + library/lib.cmi library/libnames.cmi library/libobject.cmi \ + library/library.cmi library/nameops.cmi kernel/names.cmi parsing/pcoq.cmi \ + lib/pp.cmi interp/ppextend.cmi pretyping/rawterm.cmi library/summary.cmi \ + interp/symbols.cmi parsing/termast.cmi interp/topconstr.cmi lib/util.cmi \ + toplevel/vernacexpr.cmo toplevel/metasyntax.cmi +toplevel/metasyntax.cmx: parsing/ast.cmx interp/constrintern.cmx \ parsing/coqast.cmx parsing/egrammar.cmx parsing/esyntax.cmx \ - pretyping/evd.cmx parsing/extend.cmx parsing/genarg.cmx \ - library/global.cmx library/lib.cmx library/libobject.cmx \ - library/library.cmx kernel/names.cmx parsing/pcoq.cmx lib/pp.cmx \ - pretyping/rawterm.cmx library/summary.cmx parsing/symbols.cmx \ - parsing/termast.cmx lib/util.cmx toplevel/vernacexpr.cmx \ - toplevel/metasyntax.cmi + pretyping/evd.cmx parsing/extend.cmx interp/genarg.cmx library/global.cmx \ + library/lib.cmx library/libnames.cmx library/libobject.cmx \ + library/library.cmx library/nameops.cmx kernel/names.cmx parsing/pcoq.cmx \ + lib/pp.cmx interp/ppextend.cmx pretyping/rawterm.cmx library/summary.cmx \ + interp/symbols.cmx parsing/termast.cmx interp/topconstr.cmx lib/util.cmx \ + toplevel/vernacexpr.cmx toplevel/metasyntax.cmi toplevel/minicoq.cmo: kernel/declarations.cmi toplevel/fhimsg.cmi \ parsing/g_minicoq.cmi kernel/inductive.cmi kernel/names.cmi lib/pp.cmi \ kernel/safe_typing.cmi kernel/sign.cmi kernel/term.cmi \ @@ -1869,26 +1913,26 @@ toplevel/protectedtoplevel.cmx: toplevel/cerrors.cmx \ toplevel/line_oriented_parser.cmx parsing/pcoq.cmx lib/pp.cmx \ toplevel/vernac.cmx toplevel/vernacexpr.cmx \ toplevel/protectedtoplevel.cmi -toplevel/record.cmo: parsing/ast.cmi parsing/astterm.cmi toplevel/class.cmi \ - toplevel/command.cmi parsing/coqast.cmi library/decl_kinds.cmo \ +toplevel/record.cmo: toplevel/class.cmi toplevel/command.cmi \ + interp/constrintern.cmi parsing/coqast.cmi library/decl_kinds.cmo \ kernel/declarations.cmi library/declare.cmi kernel/entries.cmi \ kernel/environ.cmi pretyping/evd.cmi library/global.cmi \ kernel/indtypes.cmi kernel/inductive.cmi pretyping/inductiveops.cmi \ library/libnames.cmi library/nameops.cmi kernel/names.cmi \ library/nametab.cmi lib/options.cmi lib/pp.cmi parsing/printer.cmi \ pretyping/recordops.cmi kernel/safe_typing.cmi kernel/term.cmi \ - pretyping/termops.cmi kernel/type_errors.cmi lib/util.cmi \ - toplevel/vernacexpr.cmo toplevel/record.cmi -toplevel/record.cmx: parsing/ast.cmx parsing/astterm.cmx toplevel/class.cmx \ - toplevel/command.cmx parsing/coqast.cmx library/decl_kinds.cmx \ + pretyping/termops.cmi interp/topconstr.cmi kernel/type_errors.cmi \ + lib/util.cmi toplevel/vernacexpr.cmo toplevel/record.cmi +toplevel/record.cmx: toplevel/class.cmx toplevel/command.cmx \ + interp/constrintern.cmx parsing/coqast.cmx library/decl_kinds.cmx \ kernel/declarations.cmx library/declare.cmx kernel/entries.cmx \ kernel/environ.cmx pretyping/evd.cmx library/global.cmx \ kernel/indtypes.cmx kernel/inductive.cmx pretyping/inductiveops.cmx \ library/libnames.cmx library/nameops.cmx kernel/names.cmx \ library/nametab.cmx lib/options.cmx lib/pp.cmx parsing/printer.cmx \ pretyping/recordops.cmx kernel/safe_typing.cmx kernel/term.cmx \ - pretyping/termops.cmx kernel/type_errors.cmx lib/util.cmx \ - toplevel/vernacexpr.cmx toplevel/record.cmi + pretyping/termops.cmx interp/topconstr.cmx kernel/type_errors.cmx \ + lib/util.cmx toplevel/vernacexpr.cmx toplevel/record.cmi toplevel/recordobj.cmo: pretyping/classops.cmi library/declare.cmi \ kernel/environ.cmi library/global.cmi pretyping/instantiate.cmi \ library/lib.cmi library/libnames.cmi library/nameops.cmi kernel/names.cmi \ @@ -1899,74 +1943,72 @@ toplevel/recordobj.cmx: pretyping/classops.cmx library/declare.cmx \ library/lib.cmx library/libnames.cmx library/nameops.cmx kernel/names.cmx \ library/nametab.cmx lib/pp.cmx pretyping/recordops.cmx kernel/term.cmx \ lib/util.cmx toplevel/recordobj.cmi -toplevel/toplevel.cmo: parsing/ast.cmi toplevel/cerrors.cmi library/lib.cmi \ +toplevel/toplevel.cmo: toplevel/cerrors.cmi library/lib.cmi \ toplevel/mltop.cmi kernel/names.cmi lib/options.cmi parsing/pcoq.cmi \ proofs/pfedit.cmi lib/pp.cmi toplevel/protectedtoplevel.cmi lib/util.cmi \ toplevel/vernac.cmi toplevel/vernacexpr.cmo toplevel/toplevel.cmi -toplevel/toplevel.cmx: parsing/ast.cmx toplevel/cerrors.cmx library/lib.cmx \ +toplevel/toplevel.cmx: toplevel/cerrors.cmx library/lib.cmx \ toplevel/mltop.cmx kernel/names.cmx lib/options.cmx parsing/pcoq.cmx \ proofs/pfedit.cmx lib/pp.cmx toplevel/protectedtoplevel.cmx lib/util.cmx \ toplevel/vernac.cmx toplevel/vernacexpr.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/vernacentries.cmi toplevel/vernacexpr.cmo \ - 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/vernacentries.cmx toplevel/vernacexpr.cmx \ - toplevel/vernacinterp.cmx toplevel/vernac.cmi -toplevel/vernacentries.cmo: parsing/ast.cmi parsing/astmod.cmi \ - parsing/astterm.cmi tactics/auto.cmi toplevel/class.cmi \ - pretyping/classops.cmi toplevel/command.cmi parsing/coqast.cmi \ +toplevel/vernac.cmo: 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/vernacentries.cmi \ + toplevel/vernacexpr.cmo toplevel/vernacinterp.cmi toplevel/vernac.cmi +toplevel/vernac.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/vernacentries.cmx \ + toplevel/vernacexpr.cmx toplevel/vernacinterp.cmx toplevel/vernac.cmi +toplevel/vernacentries.cmo: tactics/auto.cmi toplevel/class.cmi \ + pretyping/classops.cmi toplevel/command.cmi interp/constrintern.cmi \ library/decl_kinds.cmo library/declaremods.cmi tactics/dhyp.cmi \ toplevel/discharge.cmi kernel/entries.cmi kernel/environ.cmi \ pretyping/evarutil.cmi pretyping/evd.cmi library/global.cmi \ library/goptions.cmi library/impargs.cmi pretyping/inductiveops.cmi \ library/lib.cmi library/libnames.cmi library/library.cmi \ - toplevel/metasyntax.cmi toplevel/mltop.cmi library/nameops.cmi \ - kernel/names.cmi library/nametab.cmi lib/options.cmi proofs/pfedit.cmi \ - lib/pp.cmi lib/pp_control.cmi parsing/prettyp.cmi parsing/printer.cmi \ - parsing/printmod.cmi proofs/proof_trees.cmi proofs/proof_type.cmi \ - toplevel/record.cmi toplevel/recordobj.cmi proofs/refiner.cmi \ - kernel/safe_typing.cmi parsing/search.cmi library/states.cmi \ - parsing/symbols.cmi lib/system.cmi tactics/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/vernacexpr.cmo \ + toplevel/metasyntax.cmi toplevel/mltop.cmi interp/modintern.cmi \ + library/nameops.cmi kernel/names.cmi library/nametab.cmi lib/options.cmi \ + proofs/pfedit.cmi lib/pp.cmi lib/pp_control.cmi parsing/prettyp.cmi \ + pretyping/pretyping.cmi parsing/printer.cmi parsing/printmod.cmi \ + proofs/proof_trees.cmi proofs/proof_type.cmi toplevel/record.cmi \ + toplevel/recordobj.cmi proofs/refiner.cmi kernel/safe_typing.cmi \ + parsing/search.cmi library/states.cmi interp/symbols.cmi lib/system.cmi \ + tactics/tacinterp.cmi proofs/tacmach.cmi pretyping/tacred.cmi \ + proofs/tactic_debug.cmi tactics/tactics.cmi kernel/term.cmi \ + parsing/termast.cmi interp/topconstr.cmi kernel/typeops.cmi \ + kernel/univ.cmi lib/util.cmi toplevel/vernacexpr.cmo \ toplevel/vernacinterp.cmi toplevel/vernacentries.cmi -toplevel/vernacentries.cmx: parsing/ast.cmx parsing/astmod.cmx \ - parsing/astterm.cmx tactics/auto.cmx toplevel/class.cmx \ - pretyping/classops.cmx toplevel/command.cmx parsing/coqast.cmx \ +toplevel/vernacentries.cmx: tactics/auto.cmx toplevel/class.cmx \ + pretyping/classops.cmx toplevel/command.cmx interp/constrintern.cmx \ library/decl_kinds.cmx library/declaremods.cmx tactics/dhyp.cmx \ toplevel/discharge.cmx kernel/entries.cmx kernel/environ.cmx \ pretyping/evarutil.cmx pretyping/evd.cmx library/global.cmx \ library/goptions.cmx library/impargs.cmx pretyping/inductiveops.cmx \ library/lib.cmx library/libnames.cmx library/library.cmx \ - toplevel/metasyntax.cmx toplevel/mltop.cmx library/nameops.cmx \ - kernel/names.cmx library/nametab.cmx lib/options.cmx proofs/pfedit.cmx \ - lib/pp.cmx lib/pp_control.cmx parsing/prettyp.cmx parsing/printer.cmx \ - parsing/printmod.cmx proofs/proof_trees.cmx proofs/proof_type.cmx \ - toplevel/record.cmx toplevel/recordobj.cmx proofs/refiner.cmx \ - kernel/safe_typing.cmx parsing/search.cmx library/states.cmx \ - parsing/symbols.cmx lib/system.cmx tactics/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/vernacexpr.cmx \ + toplevel/metasyntax.cmx toplevel/mltop.cmx interp/modintern.cmx \ + library/nameops.cmx kernel/names.cmx library/nametab.cmx lib/options.cmx \ + proofs/pfedit.cmx lib/pp.cmx lib/pp_control.cmx parsing/prettyp.cmx \ + pretyping/pretyping.cmx parsing/printer.cmx parsing/printmod.cmx \ + proofs/proof_trees.cmx proofs/proof_type.cmx toplevel/record.cmx \ + toplevel/recordobj.cmx proofs/refiner.cmx kernel/safe_typing.cmx \ + parsing/search.cmx library/states.cmx interp/symbols.cmx lib/system.cmx \ + tactics/tacinterp.cmx proofs/tacmach.cmx pretyping/tacred.cmx \ + proofs/tactic_debug.cmx tactics/tactics.cmx kernel/term.cmx \ + parsing/termast.cmx interp/topconstr.cmx kernel/typeops.cmx \ + kernel/univ.cmx lib/util.cmx toplevel/vernacexpr.cmx \ toplevel/vernacinterp.cmx toplevel/vernacentries.cmi -toplevel/vernacexpr.cmo: parsing/ast.cmi parsing/coqast.cmi \ - library/decl_kinds.cmo parsing/extend.cmi parsing/genarg.cmi \ - library/goptions.cmi library/libnames.cmi kernel/names.cmi \ - library/nametab.cmi proofs/proof_type.cmi parsing/symbols.cmi \ - proofs/tacexpr.cmo lib/util.cmi -toplevel/vernacexpr.cmx: parsing/ast.cmx parsing/coqast.cmx \ - library/decl_kinds.cmx parsing/extend.cmx parsing/genarg.cmx \ - library/goptions.cmx library/libnames.cmx kernel/names.cmx \ - library/nametab.cmx proofs/proof_type.cmx parsing/symbols.cmx \ - proofs/tacexpr.cmx lib/util.cmx +toplevel/vernacexpr.cmo: library/decl_kinds.cmo parsing/extend.cmi \ + interp/genarg.cmi library/goptions.cmi library/libnames.cmi \ + kernel/names.cmi library/nametab.cmi interp/ppextend.cmi \ + pretyping/rawterm.cmi proofs/tacexpr.cmo interp/topconstr.cmi \ + lib/util.cmi +toplevel/vernacexpr.cmx: library/decl_kinds.cmx parsing/extend.cmx \ + interp/genarg.cmx library/goptions.cmx library/libnames.cmx \ + kernel/names.cmx library/nametab.cmx interp/ppextend.cmx \ + pretyping/rawterm.cmx proofs/tacexpr.cmx interp/topconstr.cmx \ + lib/util.cmx toplevel/vernacinterp.cmo: parsing/ast.cmi parsing/coqast.cmi \ parsing/extend.cmi toplevel/himsg.cmi library/libnames.cmi \ kernel/names.cmi lib/options.cmi lib/pp.cmi proofs/proof_type.cmi \ @@ -1984,35 +2026,35 @@ contrib/cc/ccproof.cmo: contrib/cc/ccalgo.cmi kernel/names.cmi \ contrib/cc/ccproof.cmx: contrib/cc/ccalgo.cmx kernel/names.cmx \ contrib/cc/ccproof.cmi contrib/cc/cctac.cmo: contrib/cc/ccalgo.cmi contrib/cc/ccproof.cmi \ - toplevel/cerrors.cmi parsing/coqlib.cmi library/declare.cmi \ - parsing/egrammar.cmi pretyping/evd.cmi library/libnames.cmi \ - library/library.cmi library/nameops.cmi kernel/names.cmi \ - library/nametab.cmi parsing/pcoq.cmi lib/pp.cmi parsing/pptactic.cmi \ - proofs/proof_type.cmi proofs/refiner.cmi tactics/tacinterp.cmi \ - proofs/tacmach.cmi tactics/tacticals.cmi tactics/tactics.cmi \ - kernel/term.cmi lib/util.cmi + toplevel/cerrors.cmi interp/coqlib.cmi parsing/egrammar.cmi \ + pretyping/evd.cmi library/libnames.cmi library/library.cmi \ + library/nameops.cmi kernel/names.cmi library/nametab.cmi parsing/pcoq.cmi \ + lib/pp.cmi parsing/pptactic.cmi proofs/proof_type.cmi proofs/refiner.cmi \ + tactics/tacinterp.cmi proofs/tacmach.cmi tactics/tacticals.cmi \ + tactics/tactics.cmi kernel/term.cmi lib/util.cmi contrib/cc/cctac.cmx: contrib/cc/ccalgo.cmx contrib/cc/ccproof.cmx \ - toplevel/cerrors.cmx parsing/coqlib.cmx library/declare.cmx \ - parsing/egrammar.cmx pretyping/evd.cmx library/libnames.cmx \ - library/library.cmx library/nameops.cmx kernel/names.cmx \ - library/nametab.cmx parsing/pcoq.cmx lib/pp.cmx parsing/pptactic.cmx \ - proofs/proof_type.cmx proofs/refiner.cmx tactics/tacinterp.cmx \ - proofs/tacmach.cmx tactics/tacticals.cmx tactics/tactics.cmx \ - kernel/term.cmx lib/util.cmx -contrib/correctness/pcic.cmo: parsing/ast.cmi kernel/declarations.cmi \ - library/declare.cmi pretyping/detyping.cmi kernel/entries.cmi \ - library/global.cmi kernel/indtypes.cmi library/libnames.cmi \ + toplevel/cerrors.cmx interp/coqlib.cmx parsing/egrammar.cmx \ + pretyping/evd.cmx library/libnames.cmx library/library.cmx \ + library/nameops.cmx kernel/names.cmx library/nametab.cmx parsing/pcoq.cmx \ + lib/pp.cmx parsing/pptactic.cmx proofs/proof_type.cmx proofs/refiner.cmx \ + tactics/tacinterp.cmx proofs/tacmach.cmx tactics/tacticals.cmx \ + tactics/tactics.cmx kernel/term.cmx lib/util.cmx +contrib/correctness/pcic.cmo: kernel/declarations.cmi library/declare.cmi \ + pretyping/detyping.cmi kernel/entries.cmi library/global.cmi \ + kernel/indtypes.cmi library/libnames.cmi library/nameops.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 toplevel/vernacexpr.cmo contrib/correctness/pcic.cmi -contrib/correctness/pcic.cmx: parsing/ast.cmx kernel/declarations.cmx \ - library/declare.cmx pretyping/detyping.cmx kernel/entries.cmx \ - library/global.cmx kernel/indtypes.cmx library/libnames.cmx \ + kernel/sign.cmi kernel/term.cmi pretyping/termops.cmi \ + interp/topconstr.cmi kernel/typeops.cmi lib/util.cmi \ + toplevel/vernacexpr.cmo contrib/correctness/pcic.cmi +contrib/correctness/pcic.cmx: kernel/declarations.cmx library/declare.cmx \ + pretyping/detyping.cmx kernel/entries.cmx library/global.cmx \ + kernel/indtypes.cmx library/libnames.cmx library/nameops.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 toplevel/vernacexpr.cmx contrib/correctness/pcic.cmi + kernel/sign.cmx kernel/term.cmx pretyping/termops.cmx \ + interp/topconstr.cmx kernel/typeops.cmx lib/util.cmx \ + toplevel/vernacexpr.cmx contrib/correctness/pcic.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 \ @@ -2081,17 +2123,17 @@ contrib/correctness/pextract.cmx: parsing/ast.cmx pretyping/evd.cmx \ contrib/correctness/ptype.cmi contrib/correctness/putil.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 library/libnames.cmi \ - library/nameops.cmi kernel/names.cmi lib/options.cmi lib/pp.cmi \ - contrib/correctness/ptype.cmi kernel/term.cmi lib/util.cmi \ +contrib/correctness/pmisc.cmo: library/declare.cmi pretyping/evarutil.cmi \ + library/global.cmi library/libnames.cmi library/nameops.cmi \ + kernel/names.cmi lib/options.cmi lib/pp.cmi contrib/correctness/ptype.cmi \ + kernel/term.cmi interp/topconstr.cmi lib/util.cmi \ contrib/correctness/pmisc.cmi -contrib/correctness/pmisc.cmx: parsing/coqast.cmx library/declare.cmx \ - pretyping/evarutil.cmx library/global.cmx library/libnames.cmx \ - library/nameops.cmx kernel/names.cmx lib/options.cmx lib/pp.cmx \ - contrib/correctness/ptype.cmi kernel/term.cmx lib/util.cmx \ +contrib/correctness/pmisc.cmx: library/declare.cmx pretyping/evarutil.cmx \ + library/global.cmx library/libnames.cmx library/nameops.cmx \ + kernel/names.cmx lib/options.cmx lib/pp.cmx contrib/correctness/ptype.cmi \ + kernel/term.cmx interp/topconstr.cmx lib/util.cmx \ contrib/correctness/pmisc.cmi -contrib/correctness/pmlize.cmo: parsing/coqlib.cmi pretyping/evd.cmi \ +contrib/correctness/pmlize.cmo: interp/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 \ @@ -2100,7 +2142,7 @@ contrib/correctness/pmlize.cmo: parsing/coqlib.cmi pretyping/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 pretyping/evd.cmx \ +contrib/correctness/pmlize.cmx: interp/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 \ @@ -2133,11 +2175,12 @@ contrib/correctness/prename.cmo: toplevel/himsg.cmi library/nameops.cmi \ contrib/correctness/prename.cmx: toplevel/himsg.cmx library/nameops.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/decl_kinds.cmo library/declare.cmi \ - kernel/entries.cmi pretyping/evd.cmi parsing/extend.cmi \ - parsing/g_zsyntax.cmi parsing/genarg.cmi library/global.cmi \ - toplevel/himsg.cmi library/nameops.cmi kernel/names.cmi lib/options.cmi \ +contrib/correctness/psyntax.cmo: interp/constrextern.cmi \ + interp/constrintern.cmi parsing/coqast.cmi library/decl_kinds.cmo \ + library/declare.cmi kernel/entries.cmi pretyping/evd.cmi \ + parsing/extend.cmi parsing/g_zsyntax.cmi interp/genarg.cmi \ + library/global.cmi toplevel/himsg.cmi library/libnames.cmi \ + library/nameops.cmi kernel/names.cmi lib/options.cmi \ contrib/correctness/past.cmi contrib/correctness/pcicenv.cmi \ parsing/pcoq.cmi contrib/correctness/pdb.cmi \ contrib/correctness/peffect.cmi contrib/correctness/penv.cmi \ @@ -2145,14 +2188,15 @@ contrib/correctness/psyntax.cmo: parsing/ast.cmi parsing/astterm.cmi \ contrib/correctness/prename.cmi contrib/correctness/ptactic.cmi \ contrib/correctness/ptype.cmi contrib/correctness/ptyping.cmi \ contrib/correctness/putil.cmi kernel/reduction.cmi tactics/tacinterp.cmi \ - kernel/term.cmi parsing/termast.cmi lib/util.cmi toplevel/vernac.cmi \ + kernel/term.cmi interp/topconstr.cmi lib/util.cmi toplevel/vernac.cmi \ toplevel/vernacentries.cmi toplevel/vernacexpr.cmo \ toplevel/vernacinterp.cmi contrib/correctness/psyntax.cmi -contrib/correctness/psyntax.cmx: parsing/ast.cmx parsing/astterm.cmx \ - parsing/coqast.cmx library/decl_kinds.cmx library/declare.cmx \ - kernel/entries.cmx pretyping/evd.cmx parsing/extend.cmx \ - parsing/g_zsyntax.cmx parsing/genarg.cmx library/global.cmx \ - toplevel/himsg.cmx library/nameops.cmx kernel/names.cmx lib/options.cmx \ +contrib/correctness/psyntax.cmx: interp/constrextern.cmx \ + interp/constrintern.cmx parsing/coqast.cmx library/decl_kinds.cmx \ + library/declare.cmx kernel/entries.cmx pretyping/evd.cmx \ + parsing/extend.cmx parsing/g_zsyntax.cmx interp/genarg.cmx \ + library/global.cmx toplevel/himsg.cmx library/libnames.cmx \ + library/nameops.cmx kernel/names.cmx lib/options.cmx \ contrib/correctness/past.cmi contrib/correctness/pcicenv.cmx \ parsing/pcoq.cmx contrib/correctness/pdb.cmx \ contrib/correctness/peffect.cmx contrib/correctness/penv.cmx \ @@ -2160,7 +2204,7 @@ contrib/correctness/psyntax.cmx: parsing/ast.cmx parsing/astterm.cmx \ contrib/correctness/prename.cmx contrib/correctness/ptactic.cmx \ contrib/correctness/ptype.cmi contrib/correctness/ptyping.cmx \ contrib/correctness/putil.cmx kernel/reduction.cmx tactics/tacinterp.cmx \ - kernel/term.cmx parsing/termast.cmx lib/util.cmx toplevel/vernac.cmx \ + kernel/term.cmx interp/topconstr.cmx lib/util.cmx toplevel/vernac.cmx \ toplevel/vernacentries.cmx toplevel/vernacexpr.cmx \ toplevel/vernacinterp.cmx contrib/correctness/psyntax.cmi contrib/correctness/ptactic.cmo: library/decl_kinds.cmo tactics/equality.cmi \ @@ -2195,34 +2239,34 @@ contrib/correctness/ptactic.cmx: library/decl_kinds.cmx tactics/equality.cmx \ tactics/tacticals.cmx tactics/tactics.cmx kernel/term.cmx \ pretyping/termops.cmx lib/util.cmx toplevel/vernacentries.cmx \ contrib/correctness/ptactic.cmi -contrib/correctness/ptyping.cmo: parsing/ast.cmi parsing/astterm.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 \ - 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 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 \ - 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 \ +contrib/correctness/ptyping.cmo: interp/constrintern.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 pretyping/reductionops.cmi kernel/term.cmi \ + pretyping/termops.cmi interp/topconstr.cmi pretyping/typing.cmi \ + lib/util.cmi contrib/correctness/ptyping.cmi +contrib/correctness/ptyping.cmx: interp/constrintern.cmx 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 pretyping/reductionops.cmx kernel/term.cmx \ + pretyping/termops.cmx interp/topconstr.cmx pretyping/typing.cmx \ + lib/util.cmx contrib/correctness/ptyping.cmi +contrib/correctness/putil.cmo: interp/coqlib.cmi kernel/environ.cmi \ library/global.cmi library/nameops.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 \ pretyping/termops.cmi lib/util.cmi contrib/correctness/putil.cmi -contrib/correctness/putil.cmx: parsing/coqlib.cmx kernel/environ.cmx \ +contrib/correctness/putil.cmx: interp/coqlib.cmx kernel/environ.cmx \ library/global.cmx library/nameops.cmx kernel/names.cmx \ contrib/correctness/past.cmi pretyping/pattern.cmx \ contrib/correctness/peffect.cmx contrib/correctness/penv.cmx \ @@ -2297,12 +2341,12 @@ contrib/extraction/extraction.cmx: kernel/closure.cmx kernel/declarations.cmx \ pretyping/termops.cmx lib/util.cmx contrib/extraction/extraction.cmi contrib/extraction/g_extraction.cmo: toplevel/cerrors.cmi \ parsing/egrammar.cmi parsing/extend.cmi \ - contrib/extraction/extract_env.cmi parsing/genarg.cmi parsing/pcoq.cmi \ + contrib/extraction/extract_env.cmi interp/genarg.cmi parsing/pcoq.cmi \ lib/pp.cmi contrib/extraction/table.cmi toplevel/vernacexpr.cmo \ toplevel/vernacinterp.cmi contrib/extraction/g_extraction.cmx: toplevel/cerrors.cmx \ parsing/egrammar.cmx parsing/extend.cmx \ - contrib/extraction/extract_env.cmx parsing/genarg.cmx parsing/pcoq.cmx \ + contrib/extraction/extract_env.cmx interp/genarg.cmx parsing/pcoq.cmx \ lib/pp.cmx contrib/extraction/table.cmx toplevel/vernacexpr.cmx \ toplevel/vernacinterp.cmx contrib/extraction/haskell.cmo: contrib/extraction/miniml.cmi \ @@ -2353,37 +2397,37 @@ contrib/extraction/table.cmx: kernel/declarations.cmx kernel/environ.cmx \ kernel/names.cmx library/nametab.cmx lib/pp.cmx parsing/printer.cmx \ kernel/reduction.cmx library/summary.cmx kernel/term.cmx lib/util.cmx \ toplevel/vernacinterp.cmx contrib/extraction/table.cmi -contrib/field/field.cmo: parsing/astterm.cmi toplevel/cerrors.cmi \ - parsing/coqast.cmi library/declare.cmi parsing/egrammar.cmi \ - pretyping/evd.cmi parsing/extend.cmi parsing/genarg.cmi \ - library/global.cmi lib/gmap.cmi library/lib.cmi library/libnames.cmi \ - library/libobject.cmi library/library.cmi kernel/names.cmi \ - parsing/pcoq.cmi lib/pp.cmi parsing/pptactic.cmi proofs/proof_type.cmi \ - contrib/ring/quote.cmo pretyping/rawterm.cmi pretyping/reductionops.cmi \ - proofs/refiner.cmi contrib/ring/ring.cmo library/summary.cmi \ - proofs/tacexpr.cmo tactics/tacinterp.cmi proofs/tacmach.cmi \ - tactics/tacticals.cmi kernel/term.cmi pretyping/typing.cmi lib/util.cmi \ +contrib/field/field.cmo: toplevel/cerrors.cmi interp/constrintern.cmi \ + library/declare.cmi parsing/egrammar.cmi pretyping/evd.cmi \ + parsing/extend.cmi interp/genarg.cmi library/global.cmi lib/gmap.cmi \ + library/lib.cmi library/libnames.cmi library/libobject.cmi \ + library/library.cmi kernel/names.cmi parsing/pcoq.cmi lib/pp.cmi \ + parsing/pptactic.cmi proofs/proof_type.cmi contrib/ring/quote.cmo \ + pretyping/rawterm.cmi pretyping/reductionops.cmi proofs/refiner.cmi \ + contrib/ring/ring.cmo library/summary.cmi proofs/tacexpr.cmo \ + tactics/tacinterp.cmi proofs/tacmach.cmi tactics/tacticals.cmi \ + kernel/term.cmi interp/topconstr.cmi pretyping/typing.cmi lib/util.cmi \ toplevel/vernacexpr.cmo toplevel/vernacinterp.cmi -contrib/field/field.cmx: parsing/astterm.cmx toplevel/cerrors.cmx \ - parsing/coqast.cmx library/declare.cmx parsing/egrammar.cmx \ - pretyping/evd.cmx parsing/extend.cmx parsing/genarg.cmx \ - library/global.cmx lib/gmap.cmx library/lib.cmx library/libnames.cmx \ - library/libobject.cmx library/library.cmx kernel/names.cmx \ - parsing/pcoq.cmx lib/pp.cmx parsing/pptactic.cmx proofs/proof_type.cmx \ - contrib/ring/quote.cmx pretyping/rawterm.cmx pretyping/reductionops.cmx \ - proofs/refiner.cmx contrib/ring/ring.cmx library/summary.cmx \ - proofs/tacexpr.cmx tactics/tacinterp.cmx proofs/tacmach.cmx \ - tactics/tacticals.cmx kernel/term.cmx pretyping/typing.cmx lib/util.cmx \ +contrib/field/field.cmx: toplevel/cerrors.cmx interp/constrintern.cmx \ + library/declare.cmx parsing/egrammar.cmx pretyping/evd.cmx \ + parsing/extend.cmx interp/genarg.cmx library/global.cmx lib/gmap.cmx \ + library/lib.cmx library/libnames.cmx library/libobject.cmx \ + library/library.cmx kernel/names.cmx parsing/pcoq.cmx lib/pp.cmx \ + parsing/pptactic.cmx proofs/proof_type.cmx contrib/ring/quote.cmx \ + pretyping/rawterm.cmx pretyping/reductionops.cmx proofs/refiner.cmx \ + contrib/ring/ring.cmx library/summary.cmx proofs/tacexpr.cmx \ + tactics/tacinterp.cmx proofs/tacmach.cmx tactics/tacticals.cmx \ + kernel/term.cmx interp/topconstr.cmx pretyping/typing.cmx lib/util.cmx \ toplevel/vernacexpr.cmx toplevel/vernacinterp.cmx -contrib/fourier/fourierR.cmo: parsing/astterm.cmi proofs/clenv.cmi \ - tactics/contradiction.cmi parsing/coqlib.cmi tactics/equality.cmi \ +contrib/fourier/fourierR.cmo: proofs/clenv.cmi interp/constrintern.cmi \ + tactics/contradiction.cmi interp/coqlib.cmi tactics/equality.cmi \ pretyping/evd.cmi contrib/fourier/fourier.cmo library/global.cmi \ library/libnames.cmi library/library.cmi kernel/names.cmi \ parsing/pcoq.cmi contrib/ring/ring.cmo proofs/tacmach.cmi \ tactics/tacticals.cmi tactics/tactics.cmi kernel/term.cmi \ toplevel/vernacexpr.cmo -contrib/fourier/fourierR.cmx: parsing/astterm.cmx proofs/clenv.cmx \ - tactics/contradiction.cmx parsing/coqlib.cmx tactics/equality.cmx \ +contrib/fourier/fourierR.cmx: proofs/clenv.cmx interp/constrintern.cmx \ + tactics/contradiction.cmx interp/coqlib.cmx tactics/equality.cmx \ pretyping/evd.cmx contrib/fourier/fourier.cmx library/global.cmx \ library/libnames.cmx library/library.cmx kernel/names.cmx \ parsing/pcoq.cmx contrib/ring/ring.cmx proofs/tacmach.cmx \ @@ -2395,45 +2439,45 @@ contrib/fourier/g_fourier.cmo: toplevel/cerrors.cmi parsing/egrammar.cmi \ contrib/fourier/g_fourier.cmx: toplevel/cerrors.cmx parsing/egrammar.cmx \ contrib/fourier/fourierR.cmx parsing/pcoq.cmx lib/pp.cmx \ parsing/pptactic.cmx proofs/refiner.cmx -contrib/interface/blast.cmo: parsing/astterm.cmi tactics/auto.cmi \ - proofs/clenv.cmi toplevel/command.cmi contrib/interface/ctast.cmo \ - kernel/declarations.cmi library/declare.cmi tactics/eauto.cmo \ - kernel/environ.cmi tactics/equality.cmi proofs/evar_refiner.cmi \ - pretyping/evd.cmi lib/explore.cmi library/global.cmi \ - tactics/hipattern.cmi kernel/inductive.cmi proofs/logic.cmi \ - library/nameops.cmi kernel/names.cmi pretyping/pattern.cmi \ - contrib/interface/pbp.cmi parsing/pcoq.cmi proofs/pfedit.cmi lib/pp.cmi \ - parsing/pptactic.cmi parsing/printer.cmi proofs/proof_trees.cmi \ - proofs/proof_type.cmi pretyping/rawterm.cmi kernel/reduction.cmi \ - proofs/refiner.cmi kernel/sign.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 \ +contrib/interface/blast.cmo: tactics/auto.cmi proofs/clenv.cmi \ + toplevel/command.cmi contrib/interface/ctast.cmo kernel/declarations.cmi \ + library/declare.cmi tactics/eauto.cmo kernel/environ.cmi \ + tactics/equality.cmi proofs/evar_refiner.cmi pretyping/evd.cmi \ + lib/explore.cmi library/global.cmi tactics/hipattern.cmi \ + kernel/inductive.cmi proofs/logic.cmi library/nameops.cmi \ + kernel/names.cmi pretyping/pattern.cmi contrib/interface/pbp.cmi \ + parsing/pcoq.cmi proofs/pfedit.cmi lib/pp.cmi parsing/pptactic.cmi \ + parsing/printer.cmi proofs/proof_trees.cmi proofs/proof_type.cmi \ + pretyping/rawterm.cmi kernel/reduction.cmi proofs/refiner.cmi \ + kernel/sign.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/vernacentries.cmi toplevel/vernacinterp.cmi \ contrib/interface/blast.cmi -contrib/interface/blast.cmx: parsing/astterm.cmx tactics/auto.cmx \ - proofs/clenv.cmx toplevel/command.cmx contrib/interface/ctast.cmx \ - kernel/declarations.cmx library/declare.cmx tactics/eauto.cmx \ - kernel/environ.cmx tactics/equality.cmx proofs/evar_refiner.cmx \ - pretyping/evd.cmx lib/explore.cmx library/global.cmx \ - tactics/hipattern.cmx kernel/inductive.cmx proofs/logic.cmx \ - library/nameops.cmx kernel/names.cmx pretyping/pattern.cmx \ - contrib/interface/pbp.cmx parsing/pcoq.cmx proofs/pfedit.cmx lib/pp.cmx \ - parsing/pptactic.cmx parsing/printer.cmx proofs/proof_trees.cmx \ - proofs/proof_type.cmx pretyping/rawterm.cmx kernel/reduction.cmx \ - proofs/refiner.cmx kernel/sign.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 \ +contrib/interface/blast.cmx: tactics/auto.cmx proofs/clenv.cmx \ + toplevel/command.cmx contrib/interface/ctast.cmx kernel/declarations.cmx \ + library/declare.cmx tactics/eauto.cmx kernel/environ.cmx \ + tactics/equality.cmx proofs/evar_refiner.cmx pretyping/evd.cmx \ + lib/explore.cmx library/global.cmx tactics/hipattern.cmx \ + kernel/inductive.cmx proofs/logic.cmx library/nameops.cmx \ + kernel/names.cmx pretyping/pattern.cmx contrib/interface/pbp.cmx \ + parsing/pcoq.cmx proofs/pfedit.cmx lib/pp.cmx parsing/pptactic.cmx \ + parsing/printer.cmx proofs/proof_trees.cmx proofs/proof_type.cmx \ + pretyping/rawterm.cmx kernel/reduction.cmx proofs/refiner.cmx \ + kernel/sign.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/vernacentries.cmx toplevel/vernacinterp.cmx \ contrib/interface/blast.cmi contrib/interface/centaur.cmo: contrib/interface/ascent.cmi parsing/ast.cmi \ - parsing/astterm.cmi contrib/interface/blast.cmi toplevel/cerrors.cmi \ - pretyping/classops.cmi toplevel/command.cmi parsing/coqast.cmi \ + contrib/interface/blast.cmi toplevel/cerrors.cmi pretyping/classops.cmi \ + toplevel/command.cmi interp/constrintern.cmi parsing/coqast.cmi \ contrib/interface/ctast.cmo contrib/interface/dad.cmi \ contrib/interface/debug_tac.cmi kernel/declarations.cmi \ library/declare.cmi parsing/egrammar.cmi kernel/environ.cmi \ - pretyping/evd.cmi parsing/extend.cmi parsing/genarg.cmi \ - library/global.cmi contrib/interface/history.cmi library/lib.cmi \ - library/libnames.cmi library/libobject.cmi library/library.cmi \ + pretyping/evd.cmi parsing/extend.cmi interp/genarg.cmi library/global.cmi \ + contrib/interface/history.cmi library/lib.cmi library/libnames.cmi \ + library/libobject.cmi library/library.cmi \ toplevel/line_oriented_parser.cmi toplevel/mltop.cmi \ contrib/interface/name_to_ast.cmi library/nameops.cmi kernel/names.cmi \ library/nametab.cmi contrib/interface/pbp.cmi parsing/pcoq.cmi \ @@ -2448,14 +2492,14 @@ contrib/interface/centaur.cmo: contrib/interface/ascent.cmi parsing/ast.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 contrib/interface/blast.cmx toplevel/cerrors.cmx \ - pretyping/classops.cmx toplevel/command.cmx parsing/coqast.cmx \ + contrib/interface/blast.cmx toplevel/cerrors.cmx pretyping/classops.cmx \ + toplevel/command.cmx interp/constrintern.cmx parsing/coqast.cmx \ contrib/interface/ctast.cmx contrib/interface/dad.cmx \ contrib/interface/debug_tac.cmx kernel/declarations.cmx \ library/declare.cmx parsing/egrammar.cmx kernel/environ.cmx \ - pretyping/evd.cmx parsing/extend.cmx parsing/genarg.cmx \ - library/global.cmx contrib/interface/history.cmx library/lib.cmx \ - library/libnames.cmx library/libobject.cmx library/library.cmx \ + pretyping/evd.cmx parsing/extend.cmx interp/genarg.cmx library/global.cmx \ + contrib/interface/history.cmx library/lib.cmx library/libnames.cmx \ + library/libobject.cmx library/library.cmx \ toplevel/line_oriented_parser.cmx toplevel/mltop.cmx \ contrib/interface/name_to_ast.cmx library/nameops.cmx kernel/names.cmx \ library/nametab.cmx contrib/interface/pbp.cmx parsing/pcoq.cmx \ @@ -2469,37 +2513,37 @@ contrib/interface/centaur.cmx: contrib/interface/ascent.cmi parsing/ast.cmx \ toplevel/vernac.cmx toplevel/vernacentries.cmx toplevel/vernacexpr.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 \ - library/libnames.cmi kernel/names.cmi -contrib/interface/ctast.cmx: parsing/ast.cmx parsing/coqast.cmx lib/dyn.cmx \ - library/libnames.cmx kernel/names.cmx -contrib/interface/dad.cmo: parsing/astterm.cmi parsing/coqast.cmi \ +contrib/interface/ctast.cmo: parsing/coqast.cmi lib/dyn.cmi \ + library/libnames.cmi kernel/names.cmi lib/util.cmi +contrib/interface/ctast.cmx: parsing/coqast.cmx lib/dyn.cmx \ + library/libnames.cmx kernel/names.cmx lib/util.cmx +contrib/interface/dad.cmo: interp/constrextern.cmi interp/constrintern.cmi \ contrib/interface/ctast.cmo kernel/environ.cmi pretyping/evd.cmi \ - parsing/genarg.cmi library/global.cmi library/libnames.cmi \ + interp/genarg.cmi library/global.cmi library/libnames.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/tacexpr.cmo proofs/tacmach.cmi tactics/tacticals.cmi \ - tactics/tactics.cmi kernel/term.cmi parsing/termast.cmi \ + tactics/tactics.cmi kernel/term.cmi interp/topconstr.cmi \ pretyping/typing.cmi lib/util.cmi toplevel/vernacexpr.cmo \ toplevel/vernacinterp.cmi contrib/interface/dad.cmi -contrib/interface/dad.cmx: parsing/astterm.cmx parsing/coqast.cmx \ +contrib/interface/dad.cmx: interp/constrextern.cmx interp/constrintern.cmx \ contrib/interface/ctast.cmx kernel/environ.cmx pretyping/evd.cmx \ - parsing/genarg.cmx library/global.cmx library/libnames.cmx \ + interp/genarg.cmx library/global.cmx library/libnames.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/tacexpr.cmx proofs/tacmach.cmx tactics/tacticals.cmx \ - tactics/tactics.cmx kernel/term.cmx parsing/termast.cmx \ + tactics/tactics.cmx kernel/term.cmx interp/topconstr.cmx \ pretyping/typing.cmx lib/util.cmx toplevel/vernacexpr.cmx \ toplevel/vernacinterp.cmx contrib/interface/dad.cmi contrib/interface/debug_tac.cmo: parsing/ast.cmi toplevel/cerrors.cmi \ - parsing/coqast.cmi parsing/genarg.cmi lib/pp.cmi parsing/pptactic.cmi \ + parsing/coqast.cmi interp/genarg.cmi lib/pp.cmi parsing/pptactic.cmi \ proofs/proof_trees.cmi proofs/proof_type.cmi proofs/refiner.cmi \ proofs/tacexpr.cmo tactics/tacinterp.cmi proofs/tacmach.cmi \ tactics/tacticals.cmi lib/util.cmi contrib/interface/debug_tac.cmi contrib/interface/debug_tac.cmx: parsing/ast.cmx toplevel/cerrors.cmx \ - parsing/coqast.cmx parsing/genarg.cmx lib/pp.cmx parsing/pptactic.cmx \ + parsing/coqast.cmx interp/genarg.cmx lib/pp.cmx parsing/pptactic.cmx \ proofs/proof_trees.cmx proofs/proof_type.cmx proofs/refiner.cmx \ proofs/tacexpr.cmx tactics/tacinterp.cmx proofs/tacmach.cmx \ tactics/tacticals.cmx lib/util.cmx contrib/interface/debug_tac.cmi @@ -2510,21 +2554,23 @@ contrib/interface/history.cmx: contrib/interface/paths.cmx \ contrib/interface/line_parser.cmo: contrib/interface/line_parser.cmi contrib/interface/line_parser.cmx: contrib/interface/line_parser.cmi contrib/interface/name_to_ast.cmo: parsing/ast.cmi pretyping/classops.cmi \ - parsing/coqast.cmi library/decl_kinds.cmo kernel/declarations.cmi \ - library/declare.cmi kernel/environ.cmi library/global.cmi \ - library/impargs.cmi kernel/inductive.cmi library/lib.cmi \ - library/libnames.cmi library/libobject.cmi library/nameops.cmi \ - kernel/names.cmi library/nametab.cmi lib/pp.cmi parsing/prettyp.cmi \ - kernel/reduction.cmi kernel/sign.cmi kernel/term.cmi parsing/termast.cmi \ - lib/util.cmi toplevel/vernacexpr.cmo contrib/interface/name_to_ast.cmi + interp/constrextern.cmi parsing/coqast.cmi library/decl_kinds.cmo \ + kernel/declarations.cmi library/declare.cmi kernel/environ.cmi \ + library/global.cmi library/impargs.cmi kernel/inductive.cmi \ + library/lib.cmi library/libnames.cmi library/libobject.cmi \ + library/nameops.cmi kernel/names.cmi library/nametab.cmi lib/pp.cmi \ + parsing/prettyp.cmi kernel/reduction.cmi kernel/sign.cmi kernel/term.cmi \ + parsing/termast.cmi lib/util.cmi toplevel/vernacexpr.cmo \ + contrib/interface/name_to_ast.cmi contrib/interface/name_to_ast.cmx: parsing/ast.cmx pretyping/classops.cmx \ - parsing/coqast.cmx library/decl_kinds.cmx kernel/declarations.cmx \ - library/declare.cmx kernel/environ.cmx library/global.cmx \ - library/impargs.cmx kernel/inductive.cmx library/lib.cmx \ - library/libnames.cmx library/libobject.cmx library/nameops.cmx \ - kernel/names.cmx library/nametab.cmx lib/pp.cmx parsing/prettyp.cmx \ - kernel/reduction.cmx kernel/sign.cmx kernel/term.cmx parsing/termast.cmx \ - lib/util.cmx toplevel/vernacexpr.cmx contrib/interface/name_to_ast.cmi + interp/constrextern.cmx parsing/coqast.cmx library/decl_kinds.cmx \ + kernel/declarations.cmx library/declare.cmx kernel/environ.cmx \ + library/global.cmx library/impargs.cmx kernel/inductive.cmx \ + library/lib.cmx library/libnames.cmx library/libobject.cmx \ + library/nameops.cmx kernel/names.cmx library/nametab.cmx lib/pp.cmx \ + parsing/prettyp.cmx kernel/reduction.cmx kernel/sign.cmx kernel/term.cmx \ + parsing/termast.cmx lib/util.cmx toplevel/vernacexpr.cmx \ + contrib/interface/name_to_ast.cmi contrib/interface/parse.cmo: contrib/interface/ascent.cmi \ toplevel/cerrors.cmi config/coq_config.cmi contrib/interface/ctast.cmo \ library/declaremods.cmi parsing/esyntax.cmi library/libnames.cmi \ @@ -2543,45 +2589,43 @@ contrib/interface/parse.cmx: contrib/interface/ascent.cmi \ contrib/interface/vtp.cmx contrib/interface/xlate.cmx contrib/interface/paths.cmo: contrib/interface/paths.cmi contrib/interface/paths.cmx: contrib/interface/paths.cmi -contrib/interface/pbp.cmo: parsing/astterm.cmi parsing/coqast.cmi \ - parsing/coqlib.cmi contrib/interface/ctast.cmo library/declare.cmi \ +contrib/interface/pbp.cmo: interp/coqlib.cmi contrib/interface/ctast.cmo \ kernel/environ.cmi pretyping/evd.cmi library/global.cmi \ tactics/hipattern.cmi library/libnames.cmi proofs/logic.cmi \ kernel/names.cmi library/nametab.cmi pretyping/pattern.cmi lib/pp.cmi \ pretyping/pretyping.cmi proofs/proof_trees.cmi proofs/proof_type.cmi \ pretyping/rawterm.cmi kernel/reduction.cmi proofs/tacexpr.cmo \ tactics/tacinterp.cmi proofs/tacmach.cmi tactics/tacticals.cmi \ - tactics/tactics.cmi kernel/term.cmi parsing/termast.cmi \ + tactics/tactics.cmi kernel/term.cmi interp/topconstr.cmi \ pretyping/typing.cmi lib/util.cmi contrib/interface/pbp.cmi -contrib/interface/pbp.cmx: parsing/astterm.cmx parsing/coqast.cmx \ - parsing/coqlib.cmx contrib/interface/ctast.cmx library/declare.cmx \ +contrib/interface/pbp.cmx: interp/coqlib.cmx contrib/interface/ctast.cmx \ kernel/environ.cmx pretyping/evd.cmx library/global.cmx \ tactics/hipattern.cmx library/libnames.cmx proofs/logic.cmx \ kernel/names.cmx library/nametab.cmx pretyping/pattern.cmx lib/pp.cmx \ pretyping/pretyping.cmx proofs/proof_trees.cmx proofs/proof_type.cmx \ pretyping/rawterm.cmx kernel/reduction.cmx proofs/tacexpr.cmx \ tactics/tacinterp.cmx proofs/tacmach.cmx tactics/tacticals.cmx \ - tactics/tactics.cmx kernel/term.cmx parsing/termast.cmx \ + tactics/tactics.cmx kernel/term.cmx interp/topconstr.cmx \ pretyping/typing.cmx lib/util.cmx contrib/interface/pbp.cmi -contrib/interface/showproof.cmo: parsing/ast.cmi parsing/astterm.cmi \ - proofs/clenv.cmi parsing/coqast.cmi kernel/declarations.cmi \ - kernel/environ.cmi pretyping/evd.cmi parsing/genarg.cmi \ - library/global.cmi kernel/inductive.cmi pretyping/inductiveops.cmi \ - library/libnames.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/rawterm.cmi pretyping/reductionops.cmi \ +contrib/interface/showproof.cmo: proofs/clenv.cmi interp/constrintern.cmi \ + parsing/coqast.cmi kernel/declarations.cmi kernel/environ.cmi \ + pretyping/evd.cmi interp/genarg.cmi library/global.cmi \ + kernel/inductive.cmi pretyping/inductiveops.cmi library/libnames.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/rawterm.cmi pretyping/reductionops.cmi \ contrib/interface/showproof_ct.cmo kernel/sign.cmi proofs/tacexpr.cmo \ proofs/tacmach.cmi kernel/term.cmi parsing/termast.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 pretyping/evd.cmx parsing/genarg.cmx \ - library/global.cmx kernel/inductive.cmx pretyping/inductiveops.cmx \ - library/libnames.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/rawterm.cmx pretyping/reductionops.cmx \ +contrib/interface/showproof.cmx: proofs/clenv.cmx interp/constrintern.cmx \ + parsing/coqast.cmx kernel/declarations.cmx kernel/environ.cmx \ + pretyping/evd.cmx interp/genarg.cmx library/global.cmx \ + kernel/inductive.cmx pretyping/inductiveops.cmx library/libnames.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/rawterm.cmx pretyping/reductionops.cmx \ contrib/interface/showproof_ct.cmx kernel/sign.cmx proofs/tacexpr.cmx \ proofs/tacmach.cmx kernel/term.cmx parsing/termast.cmx \ pretyping/termops.cmx contrib/interface/translate.cmx \ @@ -2614,17 +2658,17 @@ contrib/interface/vtp.cmo: contrib/interface/ascent.cmi \ contrib/interface/vtp.cmx: contrib/interface/ascent.cmi \ contrib/interface/vtp.cmi contrib/interface/xlate.cmo: contrib/interface/ascent.cmi parsing/ast.cmi \ - parsing/astterm.cmi parsing/coqast.cmi contrib/interface/ctast.cmo \ - library/decl_kinds.cmo tactics/eauto.cmo tactics/extraargs.cmi \ - parsing/genarg.cmi library/libnames.cmi kernel/names.cmi \ - pretyping/rawterm.cmi proofs/tacexpr.cmo lib/util.cmi \ - toplevel/vernacexpr.cmo contrib/interface/xlate.cmi + contrib/interface/ctast.cmo library/decl_kinds.cmo tactics/eauto.cmo \ + tactics/extraargs.cmi interp/genarg.cmi library/libnames.cmi \ + kernel/names.cmi pretyping/rawterm.cmi proofs/tacexpr.cmo kernel/term.cmi \ + interp/topconstr.cmi lib/util.cmi toplevel/vernacexpr.cmo \ + contrib/interface/xlate.cmi contrib/interface/xlate.cmx: contrib/interface/ascent.cmi parsing/ast.cmx \ - parsing/astterm.cmx parsing/coqast.cmx contrib/interface/ctast.cmx \ - library/decl_kinds.cmx tactics/eauto.cmx tactics/extraargs.cmx \ - parsing/genarg.cmx library/libnames.cmx kernel/names.cmx \ - pretyping/rawterm.cmx proofs/tacexpr.cmx lib/util.cmx \ - toplevel/vernacexpr.cmx contrib/interface/xlate.cmi + contrib/interface/ctast.cmx library/decl_kinds.cmx tactics/eauto.cmx \ + tactics/extraargs.cmx interp/genarg.cmx library/libnames.cmx \ + kernel/names.cmx pretyping/rawterm.cmx proofs/tacexpr.cmx kernel/term.cmx \ + interp/topconstr.cmx lib/util.cmx toplevel/vernacexpr.cmx \ + contrib/interface/xlate.cmi contrib/jprover/jall.cmo: contrib/jprover/jlogic.cmi \ contrib/jprover/jterm.cmi contrib/jprover/jtunify.cmi \ contrib/jprover/opname.cmi contrib/jprover/jall.cmi @@ -2636,7 +2680,7 @@ contrib/jprover/jlogic.cmo: contrib/jprover/jterm.cmi \ contrib/jprover/jlogic.cmx: contrib/jprover/jterm.cmx \ contrib/jprover/opname.cmx contrib/jprover/jlogic.cmi contrib/jprover/jprover.cmo: toplevel/cerrors.cmi proofs/clenv.cmi \ - parsing/egrammar.cmi parsing/genarg.cmi library/global.cmi \ + parsing/egrammar.cmi interp/genarg.cmi library/global.cmi \ tactics/hiddentac.cmi tactics/hipattern.cmi contrib/jprover/jall.cmi \ contrib/jprover/jlogic.cmi contrib/jprover/jterm.cmi kernel/names.cmi \ pretyping/pattern.cmi parsing/pcoq.cmi lib/pp.cmi parsing/pptactic.cmi \ @@ -2645,7 +2689,7 @@ contrib/jprover/jprover.cmo: toplevel/cerrors.cmi proofs/clenv.cmi \ proofs/tacmach.cmi tactics/tacticals.cmi tactics/tactics.cmi \ kernel/term.cmi pretyping/termops.cmi lib/util.cmi contrib/jprover/jprover.cmx: toplevel/cerrors.cmx proofs/clenv.cmx \ - parsing/egrammar.cmx parsing/genarg.cmx library/global.cmx \ + parsing/egrammar.cmx interp/genarg.cmx library/global.cmx \ tactics/hiddentac.cmx tactics/hipattern.cmx contrib/jprover/jall.cmx \ contrib/jprover/jlogic.cmx contrib/jprover/jterm.cmx kernel/names.cmx \ pretyping/pattern.cmx parsing/pcoq.cmx lib/pp.cmx parsing/pptactic.cmx \ @@ -2662,7 +2706,7 @@ contrib/jprover/jtunify.cmx: contrib/jprover/jtunify.cmi contrib/jprover/opname.cmo: contrib/jprover/opname.cmi contrib/jprover/opname.cmx: contrib/jprover/opname.cmi contrib/omega/coq_omega.cmo: parsing/ast.cmi proofs/clenv.cmi \ - kernel/closure.cmi tactics/contradiction.cmi parsing/coqlib.cmi \ + kernel/closure.cmi tactics/contradiction.cmi interp/coqlib.cmi \ kernel/declarations.cmi library/declare.cmi kernel/environ.cmi \ tactics/equality.cmi proofs/evar_refiner.cmi library/goptions.cmi \ kernel/inductive.cmi library/libnames.cmi library/library.cmi \ @@ -2672,7 +2716,7 @@ contrib/omega/coq_omega.cmo: parsing/ast.cmi proofs/clenv.cmi \ kernel/sign.cmi proofs/tacmach.cmi tactics/tacticals.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 tactics/contradiction.cmx parsing/coqlib.cmx \ + kernel/closure.cmx tactics/contradiction.cmx interp/coqlib.cmx \ kernel/declarations.cmx library/declare.cmx kernel/environ.cmx \ tactics/equality.cmx proofs/evar_refiner.cmx library/goptions.cmx \ kernel/inductive.cmx library/libnames.cmx library/library.cmx \ @@ -2690,17 +2734,17 @@ contrib/omega/g_omega.cmx: toplevel/cerrors.cmx contrib/omega/coq_omega.cmx \ contrib/omega/omega.cmo: lib/util.cmi contrib/omega/omega.cmx: lib/util.cmx contrib/ring/g_quote.cmo: toplevel/cerrors.cmi parsing/egrammar.cmi \ - parsing/genarg.cmi parsing/pcoq.cmi lib/pp.cmi parsing/pptactic.cmi \ + interp/genarg.cmi parsing/pcoq.cmi lib/pp.cmi parsing/pptactic.cmi \ contrib/ring/quote.cmo proofs/refiner.cmi contrib/ring/g_quote.cmx: toplevel/cerrors.cmx parsing/egrammar.cmx \ - parsing/genarg.cmx parsing/pcoq.cmx lib/pp.cmx parsing/pptactic.cmx \ + interp/genarg.cmx parsing/pcoq.cmx lib/pp.cmx parsing/pptactic.cmx \ contrib/ring/quote.cmx proofs/refiner.cmx contrib/ring/g_ring.cmo: toplevel/cerrors.cmi parsing/egrammar.cmi \ - parsing/genarg.cmi parsing/pcoq.cmi lib/pp.cmi parsing/pptactic.cmi \ + interp/genarg.cmi parsing/pcoq.cmi lib/pp.cmi parsing/pptactic.cmi \ contrib/ring/quote.cmo proofs/refiner.cmi contrib/ring/ring.cmo \ toplevel/vernacinterp.cmi contrib/ring/g_ring.cmx: toplevel/cerrors.cmx parsing/egrammar.cmx \ - parsing/genarg.cmx parsing/pcoq.cmx lib/pp.cmx parsing/pptactic.cmx \ + interp/genarg.cmx parsing/pcoq.cmx lib/pp.cmx parsing/pptactic.cmx \ contrib/ring/quote.cmx proofs/refiner.cmx contrib/ring/ring.cmx \ toplevel/vernacinterp.cmx contrib/ring/quote.cmo: library/declare.cmi kernel/environ.cmi \ @@ -2713,8 +2757,8 @@ contrib/ring/quote.cmx: library/declare.cmx kernel/environ.cmx \ library/library.cmx kernel/names.cmx pretyping/pattern.cmx lib/pp.cmx \ proofs/proof_trees.cmx proofs/tacexpr.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 \ +contrib/ring/ring.cmo: kernel/closure.cmi interp/constrintern.cmi \ + interp/coqlib.cmi library/declare.cmi tactics/equality.cmi \ pretyping/evd.cmi library/global.cmi tactics/hiddentac.cmi \ tactics/hipattern.cmi library/lib.cmi library/libnames.cmi \ library/libobject.cmi library/library.cmi library/nameops.cmi \ @@ -2725,8 +2769,8 @@ contrib/ring/ring.cmo: parsing/astterm.cmi kernel/closure.cmi \ proofs/tacmach.cmi pretyping/tacred.cmi tactics/tacticals.cmi \ tactics/tactics.cmi kernel/term.cmi pretyping/typing.cmi lib/util.cmi \ toplevel/vernacexpr.cmo toplevel/vernacinterp.cmi -contrib/ring/ring.cmx: parsing/astterm.cmx kernel/closure.cmx \ - parsing/coqlib.cmx library/declare.cmx tactics/equality.cmx \ +contrib/ring/ring.cmx: kernel/closure.cmx interp/constrintern.cmx \ + interp/coqlib.cmx library/declare.cmx tactics/equality.cmx \ pretyping/evd.cmx library/global.cmx tactics/hiddentac.cmx \ tactics/hipattern.cmx library/lib.cmx library/libnames.cmx \ library/libobject.cmx library/library.cmx library/nameops.cmx \ @@ -2844,15 +2888,15 @@ contrib/xml/xmlcommand.cmx: contrib/xml/acic.cmx contrib/xml/acic2Xml.cmx \ proofs/tacmach.cmx kernel/term.cmx contrib/xml/unshare.cmx lib/util.cmx \ contrib/xml/xml.cmx contrib/xml/xmlcommand.cmi contrib/xml/xmlentries.cmo: toplevel/cerrors.cmi parsing/egrammar.cmi \ - parsing/extend.cmi parsing/genarg.cmi parsing/pcoq.cmi lib/pp.cmi \ + parsing/extend.cmi interp/genarg.cmi parsing/pcoq.cmi lib/pp.cmi \ parsing/pptactic.cmi tactics/tacinterp.cmi lib/util.cmi \ toplevel/vernacinterp.cmi contrib/xml/xmlcommand.cmi contrib/xml/xmlentries.cmx: toplevel/cerrors.cmx parsing/egrammar.cmx \ - parsing/extend.cmx parsing/genarg.cmx parsing/pcoq.cmx lib/pp.cmx \ + parsing/extend.cmx interp/genarg.cmx parsing/pcoq.cmx lib/pp.cmx \ parsing/pptactic.cmx tactics/tacinterp.cmx lib/util.cmx \ toplevel/vernacinterp.cmx contrib/xml/xmlcommand.cmx -tactics/tauto.cmo: parsing/grammar.cma kernel/names.cmo parsing/ast.cmo parsing/g_tactic.cmo parsing/g_ltac.cmo parsing/g_constr.cmo -tactics/tauto.cmx: parsing/grammar.cma kernel/names.cmo parsing/ast.cmo parsing/g_tactic.cmo parsing/g_ltac.cmo parsing/g_constr.cmo +tactics/tauto.cmo: parsing/grammar.cma +tactics/tauto.cmx: parsing/grammar.cma tactics/eqdecide.cmo: parsing/grammar.cma tactics/eqdecide.cmx: parsing/grammar.cma tactics/extraargs.cmo: parsing/grammar.cma @@ -2875,8 +2919,8 @@ contrib/ring/g_quote.cmo: parsing/grammar.cma contrib/ring/g_quote.cmx: parsing/grammar.cma contrib/ring/g_ring.cmo: parsing/grammar.cma contrib/ring/g_ring.cmx: 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 -contrib/field/field.cmx: parsing/grammar.cma kernel/names.cmo parsing/ast.cmo parsing/g_tactic.cmo parsing/g_ltac.cmo parsing/g_constr.cmo +contrib/field/field.cmo: parsing/grammar.cma +contrib/field/field.cmx: parsing/grammar.cma contrib/fourier/g_fourier.cmo: parsing/grammar.cma contrib/fourier/g_fourier.cmx: parsing/grammar.cma contrib/extraction/g_extraction.cmo: parsing/grammar.cma @@ -2885,8 +2929,8 @@ contrib/xml/xmlentries.cmo: parsing/grammar.cma contrib/xml/xmlentries.cmx: parsing/grammar.cma contrib/jprover/jprover.cmo: parsing/grammar.cma contrib/jprover/jprover.cmx: parsing/grammar.cma -contrib/cc/cctac.cmo: parsing/grammar.cma kernel/names.cmo parsing/ast.cmo parsing/g_tactic.cmo parsing/g_ltac.cmo parsing/g_constr.cmo -contrib/cc/cctac.cmx: parsing/grammar.cma kernel/names.cmo parsing/ast.cmo parsing/g_tactic.cmo parsing/g_ltac.cmo parsing/g_constr.cmo +contrib/cc/cctac.cmo: parsing/grammar.cma +contrib/cc/cctac.cmx: parsing/grammar.cma parsing/lexer.cmo: parsing/lexer.cmx: parsing/q_util.cmo: @@ -2897,24 +2941,24 @@ parsing/g_prim.cmo: parsing/g_prim.cmx: parsing/pcoq.cmo: parsing/pcoq.cmx: -parsing/g_basevernac.cmo: parsing/grammar.cma -parsing/g_basevernac.cmx: parsing/grammar.cma -parsing/g_minicoq.cmo: parsing/grammar.cma -parsing/g_minicoq.cmx: parsing/grammar.cma -parsing/g_vernac.cmo: parsing/grammar.cma -parsing/g_vernac.cmx: parsing/grammar.cma -parsing/g_proofs.cmo: parsing/grammar.cma -parsing/g_proofs.cmx: parsing/grammar.cma -parsing/g_cases.cmo: parsing/grammar.cma -parsing/g_cases.cmx: parsing/grammar.cma -parsing/g_constr.cmo: parsing/grammar.cma -parsing/g_constr.cmx: parsing/grammar.cma -parsing/g_module.cmo: parsing/grammar.cma -parsing/g_module.cmx: parsing/grammar.cma -parsing/g_tactic.cmo: parsing/grammar.cma -parsing/g_tactic.cmx: parsing/grammar.cma -parsing/g_ltac.cmo: parsing/grammar.cma -parsing/g_ltac.cmx: parsing/grammar.cma +parsing/g_basevernac.cmo: +parsing/g_basevernac.cmx: +parsing/g_minicoq.cmo: +parsing/g_minicoq.cmx: +parsing/g_vernac.cmo: +parsing/g_vernac.cmx: +parsing/g_proofs.cmo: +parsing/g_proofs.cmx: +parsing/g_cases.cmo: +parsing/g_cases.cmx: +parsing/g_constr.cmo: +parsing/g_constr.cmx: +parsing/g_module.cmo: +parsing/g_module.cmx: +parsing/g_tactic.cmo: +parsing/g_tactic.cmx: +parsing/g_ltac.cmo: +parsing/g_ltac.cmx: parsing/argextend.cmo: parsing/argextend.cmx: parsing/tacextend.cmo: diff --git a/.depend.camlp4 b/.depend.camlp4 index 6b741f752..39e933dcf 100644 --- a/.depend.camlp4 +++ b/.depend.camlp4 @@ -1,4 +1,4 @@ -tactics/tauto.ml: parsing/grammar.cma kernel/names.cmo parsing/ast.cmo parsing/g_tactic.cmo parsing/g_ltac.cmo parsing/g_constr.cmo +tactics/tauto.ml: parsing/grammar.cma tactics/eqdecide.ml: parsing/grammar.cma tactics/extraargs.ml: parsing/grammar.cma tactics/extratactics.ml: parsing/grammar.cma @@ -10,26 +10,26 @@ contrib/omega/g_omega.ml: parsing/grammar.cma contrib/romega/g_romega.ml: parsing/grammar.cma contrib/ring/g_quote.ml: parsing/grammar.cma contrib/ring/g_ring.ml: parsing/grammar.cma -contrib/field/field.ml: parsing/grammar.cma kernel/names.cmo parsing/ast.cmo parsing/g_tactic.cmo parsing/g_ltac.cmo parsing/g_constr.cmo +contrib/field/field.ml: parsing/grammar.cma contrib/fourier/g_fourier.ml: parsing/grammar.cma contrib/extraction/g_extraction.ml: parsing/grammar.cma contrib/xml/xmlentries.ml: parsing/grammar.cma contrib/jprover/jprover.ml: parsing/grammar.cma -contrib/cc/cctac.ml: parsing/grammar.cma kernel/names.cmo parsing/ast.cmo parsing/g_tactic.cmo parsing/g_ltac.cmo parsing/g_constr.cmo +contrib/cc/cctac.ml: parsing/grammar.cma parsing/lexer.ml: parsing/q_util.ml: parsing/q_coqast.ml: parsing/g_prim.ml: parsing/pcoq.ml: -parsing/g_basevernac.ml: parsing/grammar.cma -parsing/g_minicoq.ml: parsing/grammar.cma -parsing/g_vernac.ml: parsing/grammar.cma -parsing/g_proofs.ml: parsing/grammar.cma -parsing/g_cases.ml: parsing/grammar.cma -parsing/g_constr.ml: parsing/grammar.cma -parsing/g_module.ml: parsing/grammar.cma -parsing/g_tactic.ml: parsing/grammar.cma -parsing/g_ltac.ml: parsing/grammar.cma +parsing/g_basevernac.ml: +parsing/g_minicoq.ml: +parsing/g_vernac.ml: +parsing/g_proofs.ml: +parsing/g_cases.ml: +parsing/g_constr.ml: +parsing/g_module.ml: +parsing/g_tactic.ml: +parsing/g_ltac.ml: parsing/argextend.ml: parsing/tacextend.ml: parsing/vernacextend.ml: diff --git a/CHANGES b/CHANGES index 0900445c9..5be095ab8 100644 --- a/CHANGES +++ b/CHANGES @@ -3,6 +3,13 @@ Changes from V7.3.1 to ???? TODO: unification 2eme ordre avec NewDestruct +Grammar extension + +- In old syntax, the only predefined non-terminal entries are ident, + global, constr and pattern (e.g. nvar, numarg disappears); the only + allowed grammar types are constr and pattern; ast and ast list are no + longer supported. + Symbolic notations - Introduction of a notion of scope gathering notations in a consistent set; diff --git a/Makefile b/Makefile index 8a6db9109..2c492ed75 100644 --- a/Makefile +++ b/Makefile @@ -38,7 +38,8 @@ noargument: ########################################################################### LOCALINCLUDES=-I config -I tools -I scripts -I lib -I kernel -I library \ - -I proofs -I tactics -I pretyping -I parsing -I toplevel \ + -I proofs -I tactics -I pretyping \ + -I interp -I toplevel -I parsing \ -I contrib/omega -I contrib/romega \ -I contrib/ring -I contrib/xml \ -I contrib/extraction -I contrib/correctness \ @@ -70,85 +71,99 @@ CLIBS=unix.cma CAMLP4OBJS=gramlib.cma -CONFIG=config/coq_config.cmo - -LIBREP=lib/pp_control.cmo lib/pp.cmo lib/util.cmo lib/bignat.cmo \ - lib/hashcons.cmo lib/dyn.cmo lib/system.cmo lib/options.cmo \ - lib/bstack.cmo lib/edit.cmo lib/gset.cmo lib/gmap.cmo \ - lib/tlm.cmo lib/bij.cmo lib/gmapl.cmo lib/profile.cmo lib/explore.cmo \ - lib/predicate.cmo lib/rtree.cmo # Rem: Cygwin already uses variable LIB - -KERNEL=kernel/names.cmo kernel/univ.cmo \ - kernel/esubst.cmo kernel/term.cmo kernel/sign.cmo \ - kernel/declarations.cmo kernel/environ.cmo kernel/closure.cmo \ - kernel/conv_oracle.cmo kernel/reduction.cmo kernel/entries.cmo \ - kernel/modops.cmo \ - kernel/type_errors.cmo kernel/inductive.cmo kernel/typeops.cmo \ - kernel/indtypes.cmo kernel/cooking.cmo kernel/term_typing.cmo \ - kernel/subtyping.cmo kernel/mod_typing.cmo kernel/safe_typing.cmo - -LIBRARY=library/libnames.cmo library/nameops.cmo library/libobject.cmo \ - library/summary.cmo \ - library/nametab.cmo library/global.cmo library/lib.cmo \ - library/declaremods.cmo library/library.cmo library/states.cmo \ - library/impargs.cmo library/decl_kinds.cmo \ - library/dischargedhypsmap.cmo library/declare.cmo \ - library/goptions.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/indrec.cmo \ - pretyping/evarutil.cmo pretyping/evarconv.cmo \ - pretyping/coercion.cmo pretyping/cases.cmo pretyping/pretyping.cmo \ - pretyping/syntax_def.cmo pretyping/pattern.cmo - -PARSING=parsing/lexer.cmo parsing/coqast.cmo \ - parsing/genarg.cmo proofs/tacexpr.cmo parsing/ast.cmo \ - parsing/termast.cmo parsing/symbols.cmo parsing/astterm.cmo \ - parsing/astmod.cmo parsing/extend.cmo parsing/esyntax.cmo \ - parsing/ppconstr.cmo parsing/printer.cmo parsing/pptactic.cmo \ - parsing/coqlib.cmo parsing/printmod.cmo parsing/prettyp.cmo \ - parsing/search.cmo - -HIGHPARSING= 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/g_module.cmo \ - parsing/g_natsyntax.cmo parsing/g_zsyntax.cmo parsing/g_rsyntax.cmo - -ARITHSYNTAX=parsing/g_natsyntax.cmo parsing/g_zsyntax.cmo parsing/g_rsyntax.cmo - -PROOFS=proofs/proof_type.cmo proofs/proof_trees.cmo proofs/logic.cmo \ - proofs/refiner.cmo proofs/evar_refiner.cmo proofs/tacmach.cmo \ - proofs/clenv.cmo proofs/pfedit.cmo \ - proofs/tactic_debug.cmo - -TACTICS=tactics/dn.cmo tactics/termdn.cmo tactics/btermdn.cmo \ - tactics/nbtermdn.cmo tactics/hipattern.cmo tactics/wcclausenv.cmo \ - tactics/tacticals.cmo tactics/tactics.cmo \ - tactics/hiddentac.cmo tactics/elim.cmo \ - tactics/dhyp.cmo tactics/auto.cmo tactics/tacinterp.cmo - -TOPLEVEL=toplevel/himsg.cmo toplevel/cerrors.cmo toplevel/class.cmo \ - toplevel/command.cmo toplevel/record.cmo toplevel/recordobj.cmo \ - toplevel/discharge.cmo toplevel/vernacexpr.cmo \ - toplevel/vernacinterp.cmo toplevel/mltop.cmo \ - parsing/pcoq.cmo parsing/egrammar.cmo toplevel/metasyntax.cmo \ - toplevel/vernacentries.cmo toplevel/vernac.cmo \ - toplevel/line_oriented_parser.cmo toplevel/protectedtoplevel.cmo \ - toplevel/toplevel.cmo toplevel/usage.cmo \ - toplevel/coqinit.cmo toplevel/coqtop.cmo - -HIGHTACTICS=tactics/setoid_replace.cmo tactics/equality.cmo \ - tactics/contradiction.cmo tactics/inv.cmo tactics/leminv.cmo \ - tactics/autorewrite.cmo tactics/refine.cmo \ - tactics/extraargs.cmo tactics/extratactics.cmo tactics/eauto.cmo - -QUOTIFY=parsing/qast.cmo parsing/q_prim.cmo parsing/q_tactic.cmo +CONFIG=\ + config/coq_config.cmo + +LIBREP=\ + lib/pp_control.cmo lib/pp.cmo lib/util.cmo lib/bignat.cmo \ + lib/hashcons.cmo lib/dyn.cmo lib/system.cmo lib/options.cmo \ + lib/bstack.cmo lib/edit.cmo lib/gset.cmo lib/gmap.cmo \ + lib/tlm.cmo lib/bij.cmo lib/gmapl.cmo lib/profile.cmo lib/explore.cmo \ + lib/predicate.cmo lib/rtree.cmo # Rem: Cygwin already uses variable LIB + +KERNEL=\ + kernel/names.cmo kernel/univ.cmo \ + kernel/esubst.cmo kernel/term.cmo kernel/sign.cmo \ + kernel/declarations.cmo kernel/environ.cmo kernel/closure.cmo \ + kernel/conv_oracle.cmo kernel/reduction.cmo kernel/entries.cmo \ + kernel/modops.cmo \ + kernel/type_errors.cmo kernel/inductive.cmo kernel/typeops.cmo \ + kernel/indtypes.cmo kernel/cooking.cmo kernel/term_typing.cmo \ + kernel/subtyping.cmo kernel/mod_typing.cmo kernel/safe_typing.cmo + +LIBRARY=\ + library/nameops.cmo library/libnames.cmo library/libobject.cmo \ + library/summary.cmo \ + library/nametab.cmo library/global.cmo library/lib.cmo \ + library/declaremods.cmo library/library.cmo library/states.cmo \ + library/impargs.cmo library/decl_kinds.cmo \ + library/dischargedhypsmap.cmo library/declare.cmo library/goptions.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/indrec.cmo \ + pretyping/evarutil.cmo pretyping/evarconv.cmo \ + pretyping/coercion.cmo pretyping/cases.cmo pretyping/pretyping.cmo \ + pretyping/pattern.cmo + +INTERP=\ + interp/topconstr.cmo interp/ppextend.cmo interp/symbols.cmo \ + interp/genarg.cmo interp/syntax_def.cmo interp/constrintern.cmo \ + interp/modintern.cmo interp/constrextern.cmo interp/coqlib.cmo + +PARSING=\ + parsing/lexer.cmo parsing/coqast.cmo parsing/ast.cmo \ + parsing/termast.cmo parsing/extend.cmo parsing/esyntax.cmo \ + parsing/ppconstr.cmo parsing/printer.cmo parsing/pptactic.cmo \ + parsing/printmod.cmo parsing/prettyp.cmo parsing/search.cmo + +HIGHPARSING=\ + 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/g_module.cmo \ + parsing/g_natsyntax.cmo parsing/g_zsyntax.cmo parsing/g_rsyntax.cmo + +ARITHSYNTAX=\ + parsing/g_natsyntax.cmo parsing/g_zsyntax.cmo parsing/g_rsyntax.cmo + +PROOFS=\ + proofs/tacexpr.cmo proofs/proof_type.cmo \ + proofs/proof_trees.cmo proofs/logic.cmo \ + proofs/refiner.cmo proofs/evar_refiner.cmo proofs/tacmach.cmo \ + proofs/clenv.cmo proofs/pfedit.cmo \ + proofs/tactic_debug.cmo + +TACTICS=\ + tactics/dn.cmo tactics/termdn.cmo tactics/btermdn.cmo \ + tactics/nbtermdn.cmo tactics/hipattern.cmo tactics/wcclausenv.cmo \ + tactics/tacticals.cmo tactics/tactics.cmo \ + tactics/hiddentac.cmo tactics/elim.cmo \ + tactics/dhyp.cmo tactics/auto.cmo tactics/tacinterp.cmo + +TOPLEVEL=\ + toplevel/himsg.cmo toplevel/cerrors.cmo toplevel/class.cmo \ + toplevel/command.cmo toplevel/record.cmo toplevel/recordobj.cmo \ + toplevel/discharge.cmo toplevel/vernacexpr.cmo \ + toplevel/vernacinterp.cmo toplevel/mltop.cmo \ + parsing/pcoq.cmo parsing/egrammar.cmo toplevel/metasyntax.cmo \ + toplevel/vernacentries.cmo toplevel/vernac.cmo \ + toplevel/line_oriented_parser.cmo toplevel/protectedtoplevel.cmo \ + toplevel/toplevel.cmo toplevel/usage.cmo \ + toplevel/coqinit.cmo toplevel/coqtop.cmo + +HIGHTACTICS=\ + tactics/setoid_replace.cmo tactics/equality.cmo \ + tactics/contradiction.cmo tactics/inv.cmo tactics/leminv.cmo \ + tactics/autorewrite.cmo tactics/refine.cmo \ + tactics/extraargs.cmo tactics/extratactics.cmo tactics/eauto.cmo + +QUOTIFY=\ + parsing/qast.cmo parsing/q_prim.cmo parsing/q_tactic.cmo parsing/q_prim.ml4: parsing/g_prim.ml4 camlp4o -I parsing grammar.cma pa_ifdef.cmo pa_extend.cmo pr_o.cmo pr_extend.cmo -quotify -DQuotify -o parsing/q_prim.ml4 -impl parsing/g_prim.ml4 @@ -167,124 +182,136 @@ ML4FILES += $(USERTAC) tactics/extraargs.ml4 tactics/extratactics.ml4 \ USERTACCMO=$(USERTAC:.ml4=.cmo) USERTACCMX=$(USERTAC:.ml4=.cmx) -INTERFACE=contrib/interface/vtp.cmo \ - contrib/interface/ctast.cmo contrib/interface/xlate.cmo \ - contrib/interface/paths.cmo contrib/interface/translate.cmo \ - contrib/interface/pbp.cmo \ - contrib/interface/dad.cmo \ - contrib/interface/history.cmo \ - contrib/interface/name_to_ast.cmo contrib/interface/debug_tac.cmo \ - contrib/interface/showproof_ct.cmo contrib/interface/showproof.cmo \ - contrib/interface/blast.cmo contrib/interface/centaur.cmo +INTERFACE=\ + contrib/interface/vtp.cmo \ + contrib/interface/ctast.cmo contrib/interface/xlate.cmo \ + contrib/interface/paths.cmo contrib/interface/translate.cmo \ + contrib/interface/pbp.cmo \ + contrib/interface/dad.cmo \ + contrib/interface/history.cmo \ + contrib/interface/name_to_ast.cmo contrib/interface/debug_tac.cmo \ + contrib/interface/showproof_ct.cmo contrib/interface/showproof.cmo \ + contrib/interface/blast.cmo contrib/interface/centaur.cmo ML4FILES += contrib/interface/debug_tac.ml4 contrib/interface/centaur.ml4 PARSERREQUIRES=config/coq_config.cmo lib/pp_control.cmo lib/pp.cmo \ - lib/util.cmo lib/bignat.cmo lib/dyn.cmo lib/gmap.cmo lib/gmapl.cmo \ - lib/predicate.cmo lib/hashcons.cmo lib/profile.cmo \ - lib/system.cmo lib/bstack.cmo lib/edit.cmo lib/options.cmo \ - lib/rtree.cmo lib/gset.cmo lib/tlm.cmo \ - kernel/names.cmo kernel/univ.cmo kernel/esubst.cmo \ - kernel/term.cmo kernel/sign.cmo kernel/declarations.cmo \ - kernel/environ.cmo \ - kernel/closure.cmo kernel/conv_oracle.cmo kernel/reduction.cmo \ - kernel/modops.cmo \ - kernel/type_errors.cmo kernel/inductive.cmo kernel/typeops.cmo \ - kernel/indtypes.cmo kernel/cooking.cmo kernel/term_typing.cmo \ - kernel/subtyping.cmo kernel/mod_typing.cmo kernel/safe_typing.cmo \ - library/libnames.cmo \ - library/nameops.cmo library/libobject.cmo library/summary.cmo \ - library/nametab.cmo library/lib.cmo library/global.cmo \ - library/declaremods.cmo \ - library/library.cmo lib/options.cmo library/impargs.cmo \ - library/dischargedhypsmap.cmo library/goptions.cmo \ - pretyping/evd.cmo pretyping/instantiate.cmo \ - pretyping/termops.cmo pretyping/reductionops.cmo \ - pretyping/inductiveops.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/cases.cmo \ - pretyping/indrec.cmo \ - pretyping/pretyping.cmo pretyping/syntax_def.cmo \ - parsing/lexer.cmo parsing/coqast.cmo parsing/genarg.cmo \ - proofs/tacexpr.cmo toplevel/vernacexpr.cmo \ - parsing/pcoq.cmo parsing/ast.cmo \ - parsing/g_prim.cmo parsing/g_basevernac.cmo \ - parsing/extend.cmo parsing/symbols.cmo \ - parsing/coqlib.cmo pretyping/detyping.cmo \ - parsing/termast.cmo parsing/astterm.cmo parsing/astmod.cmo \ - parsing/egrammar.cmo parsing/esyntax.cmo toplevel/metasyntax.cmo \ - parsing/ppconstr.cmo parsing/printer.cmo parsing/pptactic.cmo \ - lib/stamps.cmo pretyping/typing.cmo \ - proofs/proof_trees.cmo proofs/logic.cmo proofs/refiner.cmo \ - proofs/evar_refiner.cmo proofs/tacmach.cmo toplevel/himsg.cmo \ - parsing/g_natsyntax.cmo parsing/g_zsyntax.cmo parsing/g_rsyntax.cmo \ - toplevel/class.cmo toplevel/recordobj.cmo toplevel/cerrors.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 \ - proofs/tactic_debug.cmo \ - proofs/pfedit.cmo proofs/clenv.cmo tactics/wcclausenv.cmo \ - tactics/tacticals.cmo tactics/hipattern.cmo \ - tactics/tactics.cmo tactics/hiddentac.cmo \ - tactics/dn.cmo tactics/termdn.cmo tactics/btermdn.cmo \ - tactics/nbtermdn.cmo tactics/dhyp.cmo tactics/elim.cmo \ - tactics/auto.cmo tactics/tacinterp.cmo tactics/extraargs.cmo \ - $(CMO) # Solution de facilité... + lib/util.cmo lib/bignat.cmo lib/dyn.cmo lib/gmap.cmo lib/gmapl.cmo \ + lib/predicate.cmo lib/hashcons.cmo lib/profile.cmo \ + lib/system.cmo lib/bstack.cmo lib/edit.cmo lib/options.cmo \ + lib/rtree.cmo lib/gset.cmo lib/tlm.cmo \ + kernel/names.cmo kernel/univ.cmo kernel/esubst.cmo \ + kernel/term.cmo kernel/sign.cmo kernel/declarations.cmo \ + kernel/environ.cmo \ + kernel/closure.cmo kernel/conv_oracle.cmo kernel/reduction.cmo \ + kernel/modops.cmo \ + kernel/type_errors.cmo kernel/inductive.cmo kernel/typeops.cmo \ + kernel/indtypes.cmo kernel/cooking.cmo kernel/term_typing.cmo \ + kernel/subtyping.cmo kernel/mod_typing.cmo kernel/safe_typing.cmo \ + library/nameops.cmo library/libnames.cmo \ + library/libobject.cmo library/summary.cmo \ + library/nametab.cmo library/lib.cmo library/global.cmo \ + library/declaremods.cmo \ + library/library.cmo lib/options.cmo library/impargs.cmo \ + library/dischargedhypsmap.cmo library/goptions.cmo \ + pretyping/evd.cmo pretyping/instantiate.cmo \ + pretyping/termops.cmo pretyping/reductionops.cmo \ + pretyping/inductiveops.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/cases.cmo \ + pretyping/indrec.cmo pretyping/pretyping.cmo \ + parsing/lexer.cmo parsing/coqast.cmo interp/genarg.cmo \ + proofs/tacexpr.cmo toplevel/vernacexpr.cmo \ + interp/topconstr.cmo interp/syntax_def.cmo \ + interp/ppextend.cmo interp/symbols.cmo \ + interp/constrintern.cmo interp/coqlib.cmo \ + parsing/pcoq.cmo parsing/ast.cmo \ + parsing/extend.cmo pretyping/detyping.cmo \ + parsing/termast.cmo interp/modintern.cmo \ + parsing/g_prim.cmo parsing/g_basevernac.cmo \ + parsing/egrammar.cmo parsing/esyntax.cmo toplevel/metasyntax.cmo \ + parsing/ppconstr.cmo parsing/printer.cmo parsing/pptactic.cmo \ + lib/stamps.cmo pretyping/typing.cmo \ + proofs/proof_trees.cmo proofs/logic.cmo proofs/refiner.cmo \ + proofs/evar_refiner.cmo proofs/tacmach.cmo toplevel/himsg.cmo \ + parsing/g_natsyntax.cmo parsing/g_zsyntax.cmo parsing/g_rsyntax.cmo \ + toplevel/class.cmo toplevel/recordobj.cmo toplevel/cerrors.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 \ + proofs/tactic_debug.cmo \ + proofs/pfedit.cmo proofs/clenv.cmo tactics/wcclausenv.cmo \ + tactics/tacticals.cmo tactics/hipattern.cmo \ + tactics/tactics.cmo tactics/hiddentac.cmo \ + tactics/dn.cmo tactics/termdn.cmo tactics/btermdn.cmo \ + tactics/nbtermdn.cmo tactics/dhyp.cmo tactics/elim.cmo \ + tactics/auto.cmo tactics/tacinterp.cmo tactics/extraargs.cmo \ + $(CMO) # Solution de facilité... ML4FILES += contrib/correctness/psyntax.ml4 contrib/omega/g_omega.ml4 \ - contrib/romega/g_romega.ml4 contrib/ring/g_quote.ml4 \ - contrib/ring/g_ring.ml4 \ - contrib/field/field.ml4 contrib/fourier/g_fourier.ml4 \ - contrib/extraction/g_extraction.ml4 contrib/xml/xmlentries.ml4 - -OMEGACMO=contrib/omega/omega.cmo contrib/omega/coq_omega.cmo \ - contrib/omega/g_omega.cmo - -ROMEGACMO=contrib/romega/const_omega.cmo contrib/romega/refl_omega.cmo \ - contrib/romega/g_romega.cmo - -RINGCMO=contrib/ring/quote.cmo contrib/ring/g_quote.cmo \ - contrib/ring/ring.cmo contrib/ring/g_ring.cmo - -FIELDCMO=contrib/field/field.cmo - -XMLCMO=contrib/xml/unshare.cmo contrib/xml/xml.cmo contrib/xml/acic.cmo \ - contrib/xml/doubleTypeInference.cmo \ - contrib/xml/cic2acic.cmo contrib/xml/acic2Xml.cmo \ - contrib/xml/proof2aproof.cmo contrib/xml/proofTree2Xml.cmo \ - contrib/xml/xmlcommand.cmo contrib/xml/xmlentries.cmo - -FOURIERCMO=contrib/fourier/fourier.cmo contrib/fourier/fourierR.cmo \ - contrib/fourier/g_fourier.cmo - -EXTRACTIONCMO=contrib/extraction/table.cmo\ - contrib/extraction/mlutil.cmo\ - contrib/extraction/ocaml.cmo \ - contrib/extraction/haskell.cmo \ - contrib/extraction/scheme.cmo \ - contrib/extraction/extraction.cmo \ - contrib/extraction/common.cmo \ - contrib/extraction/extract_env.cmo \ - contrib/extraction/g_extraction.cmo - -CORRECTNESSCMO=contrib/correctness/pmisc.cmo \ - contrib/correctness/peffect.cmo contrib/correctness/prename.cmo \ - contrib/correctness/perror.cmo contrib/correctness/penv.cmo \ - contrib/correctness/putil.cmo contrib/correctness/pdb.cmo \ - contrib/correctness/pcic.cmo contrib/correctness/pmonad.cmo \ - contrib/correctness/pcicenv.cmo \ - contrib/correctness/pred.cmo contrib/correctness/ptyping.cmo \ - contrib/correctness/pwp.cmo contrib/correctness/pmlize.cmo \ - contrib/correctness/ptactic.cmo contrib/correctness/psyntax.cmo - -JPROVERCMO=contrib/jprover/opname.cmo \ - contrib/jprover/jterm.cmo contrib/jprover/jlogic.cmo \ - contrib/jprover/jtunify.cmo contrib/jprover/jall.cmo \ - contrib/jprover/jprover.cmo - -CCCMO=contrib/cc/ccalgo.cmo contrib/cc/ccproof.cmo contrib/cc/cctac.cmo + contrib/romega/g_romega.ml4 contrib/ring/g_quote.ml4 \ + contrib/ring/g_ring.ml4 \ + contrib/field/field.ml4 contrib/fourier/g_fourier.ml4 \ + contrib/extraction/g_extraction.ml4 contrib/xml/xmlentries.ml4 + +OMEGACMO=\ + contrib/omega/omega.cmo contrib/omega/coq_omega.cmo \ + contrib/omega/g_omega.cmo + +ROMEGACMO=\ + contrib/romega/const_omega.cmo contrib/romega/refl_omega.cmo \ + contrib/romega/g_romega.cmo + +RINGCMO=\ + contrib/ring/quote.cmo contrib/ring/g_quote.cmo \ + contrib/ring/ring.cmo contrib/ring/g_ring.cmo + +FIELDCMO=\ + contrib/field/field.cmo + +XMLCMO=\ + contrib/xml/unshare.cmo contrib/xml/xml.cmo contrib/xml/acic.cmo \ + contrib/xml/doubleTypeInference.cmo \ + contrib/xml/cic2acic.cmo contrib/xml/acic2Xml.cmo \ + contrib/xml/proof2aproof.cmo contrib/xml/proofTree2Xml.cmo \ + contrib/xml/xmlcommand.cmo contrib/xml/xmlentries.cmo + +FOURIERCMO=\ + contrib/fourier/fourier.cmo contrib/fourier/fourierR.cmo \ + contrib/fourier/g_fourier.cmo + +EXTRACTIONCMO=\ + contrib/extraction/table.cmo\ + contrib/extraction/mlutil.cmo\ + contrib/extraction/ocaml.cmo \ + contrib/extraction/haskell.cmo \ + contrib/extraction/scheme.cmo \ + contrib/extraction/extraction.cmo \ + contrib/extraction/common.cmo \ + contrib/extraction/extract_env.cmo \ + contrib/extraction/g_extraction.cmo + +CORRECTNESSCMO=\ + contrib/correctness/pmisc.cmo \ + contrib/correctness/peffect.cmo contrib/correctness/prename.cmo \ + contrib/correctness/perror.cmo contrib/correctness/penv.cmo \ + contrib/correctness/putil.cmo contrib/correctness/pdb.cmo \ + contrib/correctness/pcic.cmo contrib/correctness/pmonad.cmo \ + contrib/correctness/pcicenv.cmo \ + contrib/correctness/pred.cmo contrib/correctness/ptyping.cmo \ + contrib/correctness/pwp.cmo contrib/correctness/pmlize.cmo \ + contrib/correctness/ptactic.cmo contrib/correctness/psyntax.cmo + +JPROVERCMO=\ + contrib/jprover/opname.cmo \ + contrib/jprover/jterm.cmo contrib/jprover/jlogic.cmo \ + contrib/jprover/jtunify.cmo contrib/jprover/jall.cmo \ + contrib/jprover/jprover.cmo + +CCCMO=\ + contrib/cc/ccalgo.cmo contrib/cc/ccproof.cmo contrib/cc/cctac.cmo ML4FILES += contrib/jprover/jprover.ml4 contrib/cc/cctac.ml4 @@ -295,8 +322,8 @@ CONTRIB=$(OMEGACMO) $(ROMEGACMO) $(RINGCMO) $(FIELDCMO) \ CMA=$(CLIBS) $(CAMLP4OBJS) CMXA=$(CMA:.cma=.cmxa) -CMO=$(CONFIG) $(LIBREP) $(KERNEL) $(LIBRARY) $(PRETYPING) \ - $(PROOFS) $(TACTICS) $(PARSING) $(TOPLEVEL) \ +CMO=$(CONFIG) $(LIBREP) $(KERNEL) $(LIBRARY) $(PRETYPING) \ + $(PROOFS) $(TACTICS) $(INTERP) $(PARSING) $(TOPLEVEL) \ $(HIGHPARSING) $(HIGHTACTICS) $(CONTRIB) CMX=$(CMO:.cmo=.cmx) @@ -342,9 +369,10 @@ scripts/tolink.ml: Makefile echo "let kernel = \""$(KERNEL)"\"" >> $@ echo "let library = \""$(LIBRARY)"\"" >> $@ echo "let pretyping = \""$(PRETYPING)"\"" >> $@ - echo "let parsing = \""$(PARSING)"\"" >> $@ echo "let proofs = \""$(PROOFS)"\"" >> $@ echo "let tactics = \""$(TACTICS)"\"" >> $@ + echo "let interp = \""$(INTERP)"\"" >> $@ + echo "let parsing = \""$(PARSING)"\"" >> $@ echo "let toplevel = \""$(TOPLEVEL)"\"" >> $@ echo "let highparsing = \""$(HIGHPARSING)"\"" >> $@ echo "let hightactics = \""$(HIGHTACTICS)" "$(USERTACCMO)"\"" >> $@ @@ -373,6 +401,7 @@ kernel: $(KERNEL) library: $(LIBRARY) proofs: $(PROOFS) tactics: $(TACTICS) +interp: $(INTERP) parsing: $(PARSING) pretyping: $(PRETYPING) highparsing: $(HIGHPARSING) @@ -793,7 +822,8 @@ LPLIB = lib/doc.tex $(LIBREP:.cmo=.mli) LPKERNEL = kernel/doc.tex $(KERNEL:.cmo=.mli) LPLIBRARY = library/doc.tex $(LIBRARY:.cmo=.mli) LPPRETYPING = pretyping/doc.tex pretyping/rawterm.mli $(PRETYPING:.cmo=.mli) -LPPARSING =$(PARSING:.cmo=.mli) $(HIGHPARSING:.cmo=.mli) +LPINTERP = $(INTERP:.cmo=.mli) +LPPARSING = $(PARSING:.cmo=.mli) $(HIGHPARSING:.cmo=.mli) LPPROOFS = proofs/doc.tex $(PROOFS:.cmo=.mli) LPTACTICS = tactics/doc.tex $(TACTICS:.cmo=.mli) $(HIGHTACTICS:.cmo=.mli) LPTOPLEVEL = toplevel/doc.tex $(TOPLEVEL:.cmo=.mli) @@ -847,23 +877,31 @@ otags: ML4FILES += parsing/lexer.ml4 parsing/q_util.ml4 parsing/q_coqast.ml4 \ parsing/g_prim.ml4 parsing/pcoq.ml4 -CAMLP4EXTENSIONS= parsing/argextend.cmo parsing/tacextend.cmo \ - parsing/vernacextend.cmo - -GRAMMARCMO=lib/pp_control.cmo lib/pp.cmo lib/util.cmo lib/bignat.cmo \ - lib/dyn.cmo lib/options.cmo \ - lib/hashcons.cmo lib/predicate.cmo lib/rtree.cmo \ - $(KERNEL) \ - library/libnames.cmo library/summary.cmo library/nameops.cmo \ - library/nametab.cmo library/libobject.cmo library/lib.cmo \ - library/goptions.cmo library/decl_kinds.cmo \ - pretyping/rawterm.cmo pretyping/evd.cmo \ - parsing/coqast.cmo parsing/genarg.cmo \ - proofs/tacexpr.cmo proofs/proof_type.cmo parsing/ast.cmo \ - parsing/lexer.cmo parsing/q_util.cmo parsing/extend.cmo \ - parsing/symbols.cmo \ - toplevel/vernacexpr.cmo parsing/pcoq.cmo parsing/q_coqast.cmo \ - parsing/egrammar.cmo parsing/g_prim.cmo $(CAMLP4EXTENSIONS) +GRAMMARNEEDEDCMO=\ + lib/pp_control.cmo lib/pp.cmo lib/util.cmo lib/bignat.cmo \ + lib/dyn.cmo lib/options.cmo \ + lib/hashcons.cmo lib/predicate.cmo lib/rtree.cmo \ + kernel/names.cmo kernel/univ.cmo kernel/esubst.cmo kernel/term.cmo \ + kernel/sign.cmo kernel/declarations.cmo kernel/environ.cmo\ + library/nameops.cmo library/libnames.cmo library/summary.cmo \ + library/nametab.cmo library/libobject.cmo library/lib.cmo \ + library/goptions.cmo library/decl_kinds.cmo \ + pretyping/rawterm.cmo pretyping/evd.cmo \ + interp/topconstr.cmo interp/genarg.cmo \ + interp/ppextend.cmo parsing/coqast.cmo parsing/ast.cmo \ + proofs/tacexpr.cmo parsing/ast.cmo \ + parsing/lexer.cmo parsing/q_util.cmo parsing/extend.cmo \ + toplevel/vernacexpr.cmo parsing/pcoq.cmo parsing/q_coqast.cmo \ + parsing/egrammar.cmo + +CAMLP4EXTENSIONSCMO=\ + parsing/argextend.cmo parsing/tacextend.cmo parsing/vernacextend.cmo + +GRAMMARSCMO=\ + parsing/g_prim.cmo parsing/g_tactic.cmo \ + parsing/g_ltac.cmo parsing/g_constr.cmo + +GRAMMARCMO=$(GRAMMARNEEDEDCMO) $(CAMLP4EXTENSIONSCMO) $(GRAMMARSCMO) parsing/grammar.cma: $(GRAMMARCMO) $(OCAMLC) $(BYTEFLAGS) $(GRAMMARCMO) -linkall -a -o $@ @@ -975,6 +1013,7 @@ archclean:: rm -f library/*.cmx library/*.[so] rm -f proofs/*.cmx proofs/*.[so] rm -f tactics/*.cmx tactics/*.[so] + rm -f interp/*.cmx interp/*.[so] rm -f parsing/*.cmx parsing/*.[so] rm -f pretyping/*.cmx pretyping/*.[so] rm -f toplevel/*.cmx toplevel/*.[so] @@ -991,6 +1030,7 @@ clean:: archclean rm -f library/*.cm[io] rm -f proofs/*.cm[io] rm -f tactics/*.cm[io] + rm -f interp/*.cm[io] rm -f parsing/*.cm[io] parsing/*.ppo rm -f pretyping/*.cm[io] rm -f toplevel/*.cm[io] diff --git a/contrib/cc/cctac.ml4 b/contrib/cc/cctac.ml4 index f7a9e723f..ca4a24968 100644 --- a/contrib/cc/cctac.ml4 +++ b/contrib/cc/cctac.ml4 @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(*i camlp4deps: "parsing/grammar.cma kernel/names.cmo parsing/ast.cmo parsing/g_tactic.cmo parsing/g_ltac.cmo parsing/g_constr.cmo" i*) +(*i camlp4deps: "parsing/grammar.cma" i*) (* $Id$ *) @@ -33,7 +33,7 @@ exception Not_an_eq let fail()=raise Not_an_eq let constr_of_string s () = - Declare.constr_of_reference (Nametab.locate (qualid_of_string s)) + constr_of_reference (Nametab.locate (qualid_of_string s)) let eq2eqT_theo = constr_of_string "Coq.Logic.Eqdep_dec.eq2eqT" let eqT2eq_theo = constr_of_string "Coq.Logic.Eqdep_dec.eqT2eq" @@ -58,7 +58,7 @@ let eq_type_of_term term= match kind_of_term term with App (f,args)-> (try - let ref = Declare.reference_of_constr f in + let ref = reference_of_constr f in if (ref=Coqlib.glob_eq || ref=Coqlib.glob_eqT) && (Array.length args)=3 then (args.(0),args.(1),args.(2)) diff --git a/contrib/correctness/past.mli b/contrib/correctness/past.mli index 3c5a56c1d..b761da60e 100644 --- a/contrib/correctness/past.mli +++ b/contrib/correctness/past.mli @@ -14,10 +14,11 @@ open Names open Ptype +open Topconstr type termination = | RecArg of int - | Wf of Coqast.t * Coqast.t + | Wf of constr_expr * constr_expr type variable = identifier @@ -43,7 +44,7 @@ type ('a, 'b) t = { desc : ('a, 'b) t_desc; pre : 'b Ptype.precondition list; post : 'b Ptype.postcondition option; - loc : Coqast.loc; + loc : Util.loc; info : 'a } @@ -73,7 +74,7 @@ and ('a, 'b) arg = | Refarg of variable | Type of 'b Ptype.ml_type_v -type program = (unit, Coqast.t) t +type program = (unit, Topconstr.constr_expr) t (*s Intermediate type for CC terms. *) diff --git a/contrib/correctness/pcic.ml b/contrib/correctness/pcic.ml index 30959acda..488819bc2 100644 --- a/contrib/correctness/pcic.ml +++ b/contrib/correctness/pcic.ml @@ -10,7 +10,9 @@ (* $Id$ *) +open Util open Names +open Nameops open Libnames open Term open Termops @@ -21,6 +23,7 @@ open Sign open Rawterm open Typeops open Entries +open Topconstr open Pmisc open Past @@ -39,26 +42,21 @@ let tuple_exists id = try let _ = Nametab.locate (make_short_qualid id) in true with Not_found -> false -let ast_set = Ast.ope ("SET", []) +let ast_set = CSort (dummy_loc,RProp Pos) let tuple_n n = - let name = "tuple_" ^ string_of_int n in - let id = id_of_string name in + let id = make_ident "tuple_" (Some n) in let l1n = Util.interval 1 n in - let params = - List.map - (fun i -> let id = id_of_string ("T" ^ string_of_int i) in (id, ast_set)) - l1n - in + let params = List.map (fun i -> (make_ident "T" (Some i), ast_set)) l1n in let fields = List.map (fun i -> - let id = id_of_string - ("proj_" ^ string_of_int n ^ "_" ^ string_of_int i) in - (false, Vernacexpr.AssumExpr (id, Ast.nvar (id_of_string ("T" ^ string_of_int i))))) + let id = make_ident ("proj_" ^ string_of_int n ^ "_") (Some i) in + let id' = make_ident "T" (Some i) in + (false, Vernacexpr.AssumExpr (id, mkIdentC id'))) l1n in - let cons = id_of_string ("Build_tuple_" ^ string_of_int n) in + let cons = make_ident "Build_tuple_" (Some n) in Record.definition_structure ((false, id), params, fields, cons, mk_Set) (*s [(sig_n n)] generates the inductive @@ -68,12 +66,11 @@ let tuple_n n = \end{verbatim} *) let sig_n n = - let name = "sig_" ^ string_of_int n in - let id = id_of_string name in + let id = make_ident "sig_" (Some n) in let l1n = Util.interval 1 n in - let lT = List.map (fun i -> id_of_string ("T" ^ string_of_int i)) l1n in - let lx = List.map (fun i -> id_of_string ("x" ^ string_of_int i)) l1n in - let idp = id_of_string "P" in + let lT = List.map (fun i -> make_ident "T" (Some i)) l1n in + let lx = List.map (fun i -> make_ident "x" (Some i)) l1n in + let idp = make_ident "P" None in let params = let typ = List.fold_right (fun _ c -> mkArrow (mkRel n) c) lT mkProp in (idp, LocalAssum typ) :: @@ -87,7 +84,7 @@ let sig_n n = let c = mkArrow app_p app_sig in List.fold_right (fun id c -> mkProd (Name id, mkRel (n+1), c)) lx c in - let cname = id_of_string ("exist_" ^ string_of_int n) in + let cname = make_ident "exist_" (Some n) in Declare.declare_mind { mind_entry_finite = true; mind_entry_inds = @@ -123,14 +120,12 @@ let tuple_ref dep n = if n = 1 then exist else begin - let name = Printf.sprintf "exist_%d" n in - let id = id_of_string name in + let id = make_ident "exist_" (Some n) in if not (tuple_exists id) then ignore (sig_n n); Nametab.locate (make_short_qualid id) end else begin - let name = Printf.sprintf "Build_tuple_%d" n in - let id = id_of_string name in + let id = make_ident "Build_tuple_%d" (Some n) in if not (tuple_exists id) then tuple_n n; Nametab.locate (make_short_qualid id) end @@ -185,7 +180,7 @@ let rawconstr_of_prog p = let (bl',avoid',nenv') = push_vars avoid nenv bl in let c1 = trad avoid nenv e1 and c2 = trad avoid' nenv' e2 in - ROldCase (dummy_loc, false, None, c1, [| raw_lambda bl' c2 |]) + ROrderedCase (dummy_loc, LetStyle, None, c1, [| raw_lambda bl' c2 |]) | CC_lam (bl,e) -> let bl',avoid',nenv' = push_vars avoid nenv bl in @@ -219,7 +214,7 @@ let rawconstr_of_prog p = let c = trad avoid nenv b in let cl = List.map (trad avoid nenv) el in let ty = Detyping.detype (Global.env()) avoid nenv ty in - ROldCase (dummy_loc, false, Some ty, c, Array.of_list cl) + ROrderedCase (dummy_loc, RegularStyle, Some ty, c, Array.of_list cl) | CC_expr c -> Detyping.detype (Global.env()) avoid nenv c diff --git a/contrib/correctness/perror.mli b/contrib/correctness/perror.mli index 81bed4404..3664ebf78 100644 --- a/contrib/correctness/perror.mli +++ b/contrib/correctness/perror.mli @@ -11,10 +11,10 @@ (* $Id$ *) open Pp +open Util open Names open Ptype open Past -open Coqast val unbound_variable : identifier -> loc option -> 'a val unbound_reference : identifier -> loc option -> 'a diff --git a/contrib/correctness/pmisc.ml b/contrib/correctness/pmisc.ml index bb660ddb4..60f7306ac 100644 --- a/contrib/correctness/pmisc.ml +++ b/contrib/correctness/pmisc.ml @@ -12,10 +12,11 @@ open Pp open Util -open Coqast open Names open Nameops open Term +open Libnames +open Topconstr (* debug *) @@ -122,6 +123,7 @@ let subst_in_constr alist = let alist' = List.map (fun (id,id') -> (id, mkVar id')) alist in replace_vars alist' +(* let subst_in_ast alist ast = let rec subst = function Nvar(l,s) -> Nvar(l,try List.assoc s alist with Not_found -> s) @@ -130,7 +132,8 @@ let subst_in_ast alist ast = | x -> x in subst ast - +*) +(* let subst_ast_in_ast alist ast = let rec subst = function Nvar(l,s) as x -> (try List.assoc s alist with Not_found -> x) @@ -139,6 +142,17 @@ let subst_ast_in_ast alist ast = | x -> x in subst ast +*) + +let rec subst_in_ast alist = function + | CRef (Ident (loc,id)) -> + CRef (Ident (loc,(try List.assoc id alist with Not_found -> id))) + | x -> map_constr_expr_with_binders subst_in_ast List.remove_assoc alist x + +let rec subst_ast_in_ast alist = function + | CRef (Ident (_,id)) as x -> (try List.assoc id alist with Not_found -> x) + | x -> + map_constr_expr_with_binders subst_ast_in_ast List.remove_assoc alist x (* subst. of variables by constr *) let real_subst_in_constr = replace_vars diff --git a/contrib/correctness/pmisc.mli b/contrib/correctness/pmisc.mli index 207e74b2b..a07eed565 100644 --- a/contrib/correctness/pmisc.mli +++ b/contrib/correctness/pmisc.mli @@ -13,10 +13,11 @@ open Names open Term open Ptype +open Topconstr (* Some misc. functions *) -val reraise_with_loc : Coqast.loc -> ('a -> 'b) -> 'a -> 'b +val reraise_with_loc : Util.loc -> ('a -> 'b) -> 'a -> 'b val list_of_some : 'a option -> 'a list val difference : 'a list -> 'a list -> 'a list @@ -49,8 +50,9 @@ val id_of_name : name -> identifier val isevar : constr val subst_in_constr : (identifier * identifier) list -> constr -> constr -val subst_in_ast : (identifier * identifier) list -> Coqast.t -> Coqast.t -val subst_ast_in_ast : (identifier * Coqast.t) list -> Coqast.t -> Coqast.t +val subst_in_ast : (identifier * identifier) list -> constr_expr -> constr_expr +val subst_ast_in_ast : + (identifier * constr_expr) list -> constr_expr -> constr_expr val real_subst_in_constr : (identifier * constr) list -> constr -> constr val constant : string -> constr diff --git a/contrib/correctness/psyntax.ml4 b/contrib/correctness/psyntax.ml4 index 591076bdd..8e4c9b2bd 100644 --- a/contrib/correctness/psyntax.ml4 +++ b/contrib/correctness/psyntax.ml4 @@ -13,11 +13,14 @@ (*i camlp4deps: "parsing/grammar.cma" i*) open Options +open Util open Names open Nameops open Vernacentries open Reduction open Term +open Libnames +open Topconstr open Prename open Pmisc @@ -92,17 +95,23 @@ module Programs = open Programs let ast_of_int n = - G_zsyntax.z_of_string true n Ast.dummy_loc + G_zsyntax.z_of_string true n dummy_loc let constr_of_int n = - Astterm.interp_constr Evd.empty (Global.env ()) (ast_of_int n) + Constrintern.interp_constr Evd.empty (Global.env ()) (ast_of_int n) + +open Util +open Coqast -let ast_constant loc s = <:ast< (QUALID ($VAR $s)) >> +let mk_id loc id = mkRefC (Ident (loc, id)) +let mk_ref loc s = mk_id loc (id_of_string s) +let mk_appl loc1 loc2 f args = + CApp (join_loc loc1 loc2, mk_ref loc1 f, List.map (fun a -> a,None) args) let conj_assert {a_name=n;a_value=a} {a_value=b} = - let loc = Ast.loc a in - let et = ast_constant loc "and" in - { a_value = <:ast< (APPLIST $et $a $b) >>; a_name = n } + let loc1 = constr_loc a in + let loc2 = constr_loc a in + { a_value = mk_appl loc1 loc2 "and" [a;b]; a_name = n } let conj = function None,None -> None @@ -137,28 +146,26 @@ let bool_not loc a = let d = SApp ( [Variable connective_not ], [a]) in w d -let ast_zwf_zero loc = - let zwf = ast_constant loc "Zwf" and zero = ast_constant loc "ZERO" in - <:ast< (APPLIST $zwf $zero) >> +let ast_zwf_zero loc = mk_appl loc loc "Zwf" [mk_ref loc "ZERO"] (* program -> Coq AST *) -let bdize c = +let bdize c = let env = Global.env_of_context (Pcicenv.cci_sign_of Prename.empty_ren Penv.empty) in - Termast.ast_of_constr true env c + Constrextern.extern_constr true env c let rec coqast_of_program loc = function - | Variable id -> let s = string_of_id id in <:ast< ($VAR $s) >> - | Acc id -> let s = string_of_id id in <:ast< ($VAR $s) >> + | Variable id -> mk_id loc id + | Acc id -> mk_id loc id | 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 + (function Term t -> (coqast_of_program t.loc t.desc,None) | _ -> invalid_arg "coqast_of_program") l in - <:ast< (APPLIST $f ($LIST $args)) >> + CApp (dummy_loc, f, args) | Expression c -> bdize c | _ -> invalid_arg "coqast_of_program" @@ -174,9 +181,8 @@ let rec coqast_of_program loc = function *) let ast_plus_un loc ast = - let zplus = ast_constant loc "Zplus" in let un = ast_of_int "1" in - <:ast< (APPLIST $zplus $ast $un) >> + mk_appl loc loc "Zplus" [ast;un] let make_ast_for loc i v1 v2 inv block = let f = for_name() in @@ -197,22 +203,20 @@ let make_ast_for loc i v1 v2 inv block = without_effect loc (Seq (block @ [Statement f_succ_i])) in let inv' = - let zle = ast_constant loc "Zle" in - let i_le_sv2 = <:ast< (APPLIST $zle ($VAR $i) $succ_v2) >> in + let i_le_sv2 = mk_appl loc loc "Zle" [mk_ref loc i; succ_v2] in conj_assert {a_value=i_le_sv2;a_name=inv.a_name} inv in { desc = If(test,br_t,br_f); loc = loc; pre = [pre_of_assert false inv']; post = Some post; info = () } in let bl = - let typez = ast_constant loc "Z" in + let typez = mk_ref loc "Z" in [(id_of_string i, BindType (TypePure typez))] in let fv1 = without_effect loc (Apply (var_f, [Term v1])) in - let v = TypePure (ast_constant loc "unit") in + let v = TypePure (mk_ref loc "unit") in let var = - let zminus = ast_constant loc "Zminus" in - let a = <:ast< (APPLIST $zminus $succ_v2 ($VAR $i)) >> in + let a = mk_appl loc loc "Zminus" [succ_v2;mk_ref loc i] in (a, ast_zwf_zero loc) in Let (f, without_effect loc (LetRec (f,bl,v,var,e1)), fv1) diff --git a/contrib/correctness/psyntax.mli b/contrib/correctness/psyntax.mli index f5128fdef..dac571de5 100644 --- a/contrib/correctness/psyntax.mli +++ b/contrib/correctness/psyntax.mli @@ -13,13 +13,14 @@ open Pcoq open Ptype open Past +open Topconstr (* Grammar for the programs and the tactic Correctness *) module Programs : sig val program : program Gram.Entry.e - val type_v : Coqast.t ml_type_v Gram.Entry.e - val type_c : Coqast.t ml_type_c Gram.Entry.e + val type_v : constr_expr ml_type_v Gram.Entry.e + val type_c : constr_expr ml_type_c Gram.Entry.e end diff --git a/contrib/correctness/ptyping.ml b/contrib/correctness/ptyping.ml index a6f7a0ae9..6c870c85a 100644 --- a/contrib/correctness/ptyping.ml +++ b/contrib/correctness/ptyping.ml @@ -16,9 +16,10 @@ open Names open Term open Termops open Environ -open Astterm +open Constrintern open Himsg open Proof_trees +open Topconstr open Pmisc open Putil @@ -110,7 +111,7 @@ let effect_app ren env f args = let state_coq_ast sign a = let env = Global.env_of_context sign in let j = - reraise_with_loc (Ast.loc a) (judgment_of_rawconstr Evd.empty env) a in + reraise_with_loc (constr_loc a) (judgment_of_rawconstr Evd.empty env) a in let ids = global_vars env j.uj_val in j.uj_val, j.uj_type, ids diff --git a/contrib/correctness/ptyping.mli b/contrib/correctness/ptyping.mli index bfb7a9a86..968f4fd31 100644 --- a/contrib/correctness/ptyping.mli +++ b/contrib/correctness/ptyping.mli @@ -12,6 +12,7 @@ open Names open Term +open Topconstr open Ptype open Past @@ -19,7 +20,7 @@ open Penv (* This module realizes type and effect inference *) -val cic_type_v : local_env -> Prename.t -> Coqast.t ml_type_v -> type_v +val cic_type_v : local_env -> Prename.t -> constr_expr ml_type_v -> type_v val effect_app : Prename.t -> local_env -> (typing_info,'b) Past.t diff --git a/contrib/extraction/extract_env.mli b/contrib/extraction/extract_env.mli index 215161898..a49b3b4ff 100644 --- a/contrib/extraction/extract_env.mli +++ b/contrib/extraction/extract_env.mli @@ -14,8 +14,8 @@ open Util open Names open Libnames -val extraction : qualid located -> unit -val extraction_rec : qualid located list -> unit -val extraction_file : string -> qualid located list -> unit +val extraction : reference -> unit +val extraction_rec : reference list -> unit +val extraction_file : string -> reference list -> unit val extraction_module : identifier -> unit val recursive_extraction_module : identifier -> unit diff --git a/contrib/extraction/g_extraction.ml4 b/contrib/extraction/g_extraction.ml4 index 1ae18f77e..46021af73 100644 --- a/contrib/extraction/g_extraction.ml4 +++ b/contrib/extraction/g_extraction.ml4 @@ -34,11 +34,11 @@ END VERNAC COMMAND EXTEND Extraction (* Extraction in the Coq toplevel *) -| [ "Extraction" qualid(x) ] -> [ extraction x ] -| [ "Recursive" "Extraction" ne_qualid_list(l) ] -> [ extraction_rec l ] +| [ "Extraction" global(x) ] -> [ extraction x ] +| [ "Recursive" "Extraction" ne_global_list(l) ] -> [ extraction_rec l ] (* Monolithic extraction to a file *) -| [ "Extraction" string(f) ne_qualid_list(l) ] +| [ "Extraction" string(f) ne_global_list(l) ] -> [ extraction_file f l ] END @@ -61,12 +61,12 @@ END VERNAC COMMAND EXTEND ExtractionInline (* Custom inlining directives *) -| [ "Extraction" "Inline" ne_qualid_list(l) ] +| [ "Extraction" "Inline" ne_global_list(l) ] -> [ extraction_inline true l ] END VERNAC COMMAND EXTEND ExtractionNoInline -| [ "Extraction" "NoInline" ne_qualid_list(l) ] +| [ "Extraction" "NoInline" ne_global_list(l) ] -> [ extraction_inline false l ] END @@ -82,16 +82,16 @@ END (* Overriding of a Coq object by an ML one *) VERNAC COMMAND EXTEND ExtractionConstant -| [ "Extract" "Constant" qualid(x) "=>" mlname(y) ] +| [ "Extract" "Constant" global(x) "=>" mlname(y) ] -> [ extract_constant_inline false x y ] END VERNAC COMMAND EXTEND ExtractionInlinedConstant -| [ "Extract" "Inlined" "Constant" qualid(x) "=>" mlname(y) ] +| [ "Extract" "Inlined" "Constant" global(x) "=>" mlname(y) ] -> [ extract_constant_inline true x y ] END VERNAC COMMAND EXTEND ExtractionInductive -| [ "Extract" "Inductive" qualid(x) "=>" mlname(id) "[" mlname_list(idl) "]" ] +| [ "Extract" "Inductive" global(x) "=>" mlname(id) "[" mlname_list(idl) "]" ] -> [ extract_inductive x (id,idl) ] END diff --git a/contrib/extraction/table.mli b/contrib/extraction/table.mli index 7931dba01..c951116ba 100644 --- a/contrib/extraction/table.mli +++ b/contrib/extraction/table.mli @@ -57,14 +57,14 @@ open Util val extraction_language : lang -> unit -val extraction_inline : bool -> qualid located list -> unit +val extraction_inline : bool -> reference list -> unit val print_extraction_inline : unit -> unit val reset_extraction_inline : unit -> unit -val extract_constant_inline : bool -> qualid located -> string -> unit +val extract_constant_inline : bool -> reference -> string -> unit -val extract_inductive : qualid located -> string * string list -> unit +val extract_inductive : reference -> string * string list -> unit diff --git a/contrib/field/field.ml4 b/contrib/field/field.ml4 index d5c50f9d3..12be9a651 100644 --- a/contrib/field/field.ml4 +++ b/contrib/field/field.ml4 @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(*i camlp4deps: "parsing/grammar.cma kernel/names.cmo parsing/ast.cmo parsing/g_tactic.cmo parsing/g_ltac.cmo parsing/g_constr.cmo" i*) +(*i camlp4deps: "parsing/grammar.cma" i*) (* $Id$ *) @@ -23,7 +23,7 @@ open Vernacexpr open Tacexpr (* Interpretation of constr's *) -let constr_of com = Astterm.interp_constr Evd.empty (Global.env()) com +let constr_of c = Constrintern.interp_constr Evd.empty (Global.env()) c (* Construction of constants *) let constant dir s = diff --git a/contrib/fourier/fourierR.ml b/contrib/fourier/fourierR.ml index aac632de9..1398499cf 100644 --- a/contrib/fourier/fourierR.ml +++ b/contrib/fourier/fourierR.ml @@ -73,9 +73,9 @@ let flin_emult a f = (*****************************************************************************) open Vernacexpr let parse_ast = Pcoq.parse_string Pcoq.Constr.constr;; -let parse s = Astterm.interp_constr Evd.empty (Global.env()) (parse_ast s);; +let parse s = Constrintern.interp_constr Evd.empty (Global.env()) (parse_ast s);; let pf_parse_constr gl s = - Astterm.interp_constr Evd.empty (pf_env gl) (parse_ast s);; + Constrintern.interp_constr Evd.empty (pf_env gl) (parse_ast s);; let string_of_R_constant kn = match Names.repr_kn kn with diff --git a/contrib/interface/blast.ml b/contrib/interface/blast.ml index 4c57760de..d5715fd3d 100755 --- a/contrib/interface/blast.ml +++ b/contrib/interface/blast.ml @@ -4,7 +4,6 @@ open Ctast;; open Termops;; open Nameops;; -open Astterm;; open Auto;; open Clenv;; open Command;; diff --git a/contrib/interface/centaur.ml4 b/contrib/interface/centaur.ml4 index b917f24d4..3a4806924 100644 --- a/contrib/interface/centaur.ml4 +++ b/contrib/interface/centaur.ml4 @@ -40,7 +40,7 @@ open Blast;; open Dad;; open Debug_tac;; open Search;; -open Astterm;; +open Constrintern;; open Nametab;; open Showproof;; open Showproof_ct;; @@ -494,9 +494,9 @@ let pcoq_reset_initial() = let pcoq_reset x = if refining() then output_results (ctf_AbortedAllMessage ()) None; - Vernacentries.abort_refine Lib.reset_name x; + Vernacentries.abort_refine Lib.reset_name (dummy_loc,x); output_results - (ctf_ResetIdentMessage !global_request_id (string_of_id x)) None;; + (ctf_ResetIdentMessage !global_request_id (string_of_id x)) None;; VERNAC ARGUMENT EXTEND text_mode @@ -568,8 +568,8 @@ let pcoq_search s l = end; search_output_results() -let pcoq_print_name (_,qid) = - let results = xlate_vernac_list (name_to_ast qid) in +let pcoq_print_name ref = + let results = xlate_vernac_list (name_to_ast ref) in output_results (fnl () ++ str "message" ++ fnl () ++ str "PRINT_VALUE" ++ fnl ()) (Some (P_cl results)) diff --git a/contrib/interface/ctast.ml b/contrib/interface/ctast.ml index 2345ff471..17bd6ef4e 100644 --- a/contrib/interface/ctast.ml +++ b/contrib/interface/ctast.ml @@ -44,7 +44,8 @@ let rec ct_to_ast = function | Path (loc,sl) -> Coqast.Path (loc,section_path sl) | Dynamic (loc,a) -> Coqast.Dynamic (loc,a) -let rec ast_to_ct = function +let rec ast_to_ct = function x -> failwith "ast_to_ct: not TODO?" +(* | Coqast.Node (loc,a,b) -> Node (loc,a,List.map ast_to_ct b) | Coqast.Nvar (loc,a) -> Nvar (loc,string_of_id a) | Coqast.Nmeta (loc,a) -> Nvar (loc,"$"^a) @@ -60,6 +61,7 @@ let rec ast_to_ct = function 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 | Node (loc,_,_) -> loc @@ -71,4 +73,4 @@ let loc = function | Path (loc,_) -> loc | Dynamic (loc,_) -> loc -let str s = Str(Ast.dummy_loc,s) +let str s = Str(Util.dummy_loc,s) diff --git a/contrib/interface/dad.ml b/contrib/interface/dad.ml index 3be5d8a36..00a4bb07e 100644 --- a/contrib/interface/dad.ml +++ b/contrib/interface/dad.ml @@ -12,8 +12,8 @@ open Tacticals;; open Pattern;; open Reduction;; open Ctast;; -open Termast;; -open Astterm;; +open Constrextern;; +open Constrintern;; open Vernacinterp;; open Libnames;; open Nametab @@ -26,6 +26,7 @@ open Pp;; open Paths;; +open Topconstr;; open Genarg;; open Tacexpr;; open Rawterm;; @@ -43,7 +44,8 @@ open Rawterm;; type dad_rule = - Ctast.t * int list * int list * int * int list * raw_atomic_tactic_expr;; + constr_expr * int list * int list * int * int list + * raw_atomic_tactic_expr;; (* This value will be used systematically when constructing objects of type Ctast.t, the value is stupid and meaningless, but it is needed @@ -68,6 +70,7 @@ let rec get_subterm (depth:int) (path: int list) (constr:constr) = first argument, an object of type env, is necessary to transform constr terms into abstract syntax trees. The second argument is the substitution, a list of pairs linking an integer and a constr term. *) +(* let map_subst (env :env) (subst:(int * Term.constr) list) = let rec map_subst_aux = function @@ -77,13 +80,19 @@ let map_subst (env :env) | Coqast.Node(loc, s, l) -> Coqast.Node(loc, s, List.map map_subst_aux l) | ast -> ast in map_subst_aux;; +*) +let rec map_subst (env :env) (subst:(int * Term.constr) list) = function + | CMeta (_,i) -> + let constr = List.assoc i subst in + extern_constr false env constr + | x -> map_constr_expr_with_binders (map_subst env) (fun _ x -> x) subst x;; let map_subst_tactic env subst = function - | TacExtend ("Rewrite" as x,[b;cbl]) -> + | TacExtend (loc,("Rewrite" as x),[b;cbl]) -> let c,bl = out_gen rawwit_constr_with_bindings cbl in assert (bl = NoBindings); let c = (map_subst env subst c,NoBindings) in - TacExtend (x,[b;in_gen rawwit_constr_with_bindings c]) + TacExtend (loc,x,[b;in_gen rawwit_constr_with_bindings c]) | _ -> failwith "map_subst_tactic: unsupported tactic" (* This function is really the one that is important. *) @@ -103,7 +112,7 @@ let rec find_cmd (l:(string * dad_rule) list) env constr p p1 p2 = Failure s -> failwith "internal" in let _, constr_pat = interp_constrpattern Evd.empty (Global.env()) - (ct_to_ast pat) in + ((*ct_to_ast*) pat) in let subst = matches constr_pat term_to_match in if (is_prefix p_f (p_r@p1)) & (is_prefix p_l (p_r@p2)) then TacAtom (zz, map_subst_tactic env subst cmd) @@ -251,11 +260,11 @@ let rec sort_list = function [] -> [] | a::l -> add_in_list_sorting a (sort_list l);; -let mk_dad_meta n = Node(zz,"META",[Num(zz, n)]);; +let mk_dad_meta n = CMeta (zz,n);; let mk_rewrite lr ast = let b = in_gen rawwit_bool lr in - let cb = in_gen rawwit_constr_with_bindings (Ctast.ct_to_ast ast,NoBindings) in - TacExtend ("Rewrite",[b;cb]) + let cb = in_gen rawwit_constr_with_bindings ((*Ctast.ct_to_ast*) ast,NoBindings) in + TacExtend (zz,"Rewrite",[b;cb]) open Vernacexpr @@ -279,101 +288,104 @@ END *) +let mk_id s = mkIdentC (id_of_string s);; +let mkMetaC = mk_dad_meta;; + add_dad_rule "distributivity-inv" -(Node(zz,"APPLIST",[Nvar(zz,"mult");Node(zz,"APPLIST",[Nvar(zz,"plus");Node(zz,"META",[Num(zz,4)]);Node(zz,"META",[Num(zz,3)])]);Node(zz,"META",[Num(zz,2)])])) +(mkAppC(mk_id("mult"),[mkAppC(mk_id("plus"),[mkMetaC(4);mkMetaC(3)]);mkMetaC(2)])) [2; 2] [2; 1] 1 [2] -(mk_rewrite true (Node(zz, "APPLIST", [Nvar(zz, "mult_plus_distr");(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ]))); +(mk_rewrite true (mkAppC(mk_id( "mult_plus_distr"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ]))); add_dad_rule "distributivity1-r" -(Node(zz,"APPLIST",[Nvar(zz,"plus");Node(zz,"APPLIST",[Nvar(zz,"mult");Node(zz,"META",[Num(zz,4)]);Node(zz,"META",[Num(zz,2)])]);Node(zz,"APPLIST",[Nvar(zz,"mult");Node(zz,"META",[Num(zz,3)]);Node(zz,"META",[Num(zz,2)])])])) +(mkAppC(mk_id("plus"),[mkAppC(mk_id("mult"),[mkMetaC(4);mkMetaC(2)]);mkAppC(mk_id("mult"),[mkMetaC(3);mkMetaC(2)])])) [2; 2; 2; 2] [] 0 [] -(mk_rewrite false (Node(zz, "APPLIST", [Nvar(zz, "mult_plus_distr");(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ]))); +(mk_rewrite false (mkAppC(mk_id("mult_plus_distr"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ]))); add_dad_rule "distributivity1-l" -(Node(zz,"APPLIST",[Nvar(zz,"plus");Node(zz,"APPLIST",[Nvar(zz,"mult");Node(zz,"META",[Num(zz,4)]);Node(zz,"META",[Num(zz,2)])]);Node(zz,"APPLIST",[Nvar(zz,"mult");Node(zz,"META",[Num(zz,3)]);Node(zz,"META",[Num(zz,2)])])])) +(mkAppC(mk_id("plus"),[mkAppC(mk_id("mult"),[mkMetaC(4);mkMetaC(2)]);mkAppC(mk_id("mult"),[mkMetaC(3);mkMetaC(2)])])) [2; 1; 2; 2] [] 0 [] -(mk_rewrite false (Node(zz, "APPLIST", [Nvar(zz, "mult_plus_distr");(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ]))); +(mk_rewrite false (mkAppC(mk_id( "mult_plus_distr"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ]))); add_dad_rule "associativity" -(Node(zz,"APPLIST",[Nvar(zz,"plus");Node(zz,"APPLIST",[Nvar(zz,"plus");Node(zz,"META",[Num(zz,4)]);Node(zz,"META",[Num(zz,3)])]);Node(zz,"META",[Num(zz,2)])])) +(mkAppC(mk_id("plus"),[mkAppC(mk_id("plus"),[mkMetaC(4);mkMetaC(3)]);mkMetaC(2)])) [2; 1] [] 0 [] -(mk_rewrite true (Node(zz, "APPLIST", [Nvar(zz, "plus_assoc_r");(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ]))); +(mk_rewrite true (mkAppC(mk_id( "plus_assoc_r"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ]))); add_dad_rule "minus-identity-lr" -(Node(zz,"APPLIST",[Nvar(zz,"minus");Node(zz,"META",[Num(zz,2)]);Node(zz,"META",[Num(zz,2)])])) +(mkAppC(mk_id("minus"),[mkMetaC(2);mkMetaC(2)])) [2; 1] [2; 2] 1 [2] -(mk_rewrite false (Node(zz, "APPLIST", [Nvar(zz, "minus_n_n");(mk_dad_meta 2) ]))); +(mk_rewrite false (mkAppC(mk_id( "minus_n_n"),[(mk_dad_meta 2) ]))); add_dad_rule "minus-identity-rl" -(Node(zz,"APPLIST",[Nvar(zz,"minus");Node(zz,"META",[Num(zz,2)]);Node(zz,"META",[Num(zz,2)])])) +(mkAppC(mk_id("minus"),[mkMetaC(2);mkMetaC(2)])) [2; 2] [2; 1] 1 [2] -(mk_rewrite false (Node(zz, "APPLIST", [Nvar(zz, "minus_n_n");(mk_dad_meta 2) ]))); +(mk_rewrite false (mkAppC(mk_id( "minus_n_n"),[(mk_dad_meta 2) ]))); add_dad_rule "plus-sym-rl" -(Node(zz,"APPLIST",[Nvar(zz,"plus");Node(zz,"META",[Num(zz,3)]);Node(zz,"META",[Num(zz,2)])])) +(mkAppC(mk_id("plus"),[mkMetaC(3);mkMetaC(2)])) [2; 2] [2; 1] 1 [2] -(mk_rewrite true (Node(zz, "APPLIST", [Nvar(zz, "plus_sym");(mk_dad_meta 3) ;(mk_dad_meta 2) ]))); +(mk_rewrite true (mkAppC(mk_id( "plus_sym"),[(mk_dad_meta 3) ;(mk_dad_meta 2) ]))); add_dad_rule "plus-sym-lr" -(Node(zz,"APPLIST",[Nvar(zz,"plus");Node(zz,"META",[Num(zz,3)]);Node(zz,"META",[Num(zz,2)])])) +(mkAppC(mk_id("plus"),[mkMetaC(3);mkMetaC(2)])) [2; 1] [2; 2] 1 [2] -(mk_rewrite true (Node(zz, "APPLIST", [Nvar(zz, "plus_sym");(mk_dad_meta 3) ;(mk_dad_meta 2) ]))); +(mk_rewrite true (mkAppC(mk_id( "plus_sym"),[(mk_dad_meta 3) ;(mk_dad_meta 2) ]))); add_dad_rule "absorb-0-r-rl" -(Node(zz,"APPLIST",[Nvar(zz,"plus");Node(zz,"META",[Num(zz,2)]);Nvar(zz,"O")])) +(mkAppC(mk_id("plus"),[mkMetaC(2);mk_id("O")])) [2; 2] [1] 0 [] -(mk_rewrite false (Node(zz, "APPLIST", [Nvar(zz, "plus_n_O");(mk_dad_meta 2) ]))); +(mk_rewrite false (mkAppC(mk_id( "plus_n_O"),[(mk_dad_meta 2) ]))); add_dad_rule "absorb-0-r-lr" -(Node(zz,"APPLIST",[Nvar(zz,"plus");Node(zz,"META",[Num(zz,2)]);Nvar(zz,"O")])) +(mkAppC(mk_id("plus"),[mkMetaC(2);mk_id("O")])) [1] [2; 2] 0 [] -(mk_rewrite false (Node(zz, "APPLIST", [Nvar(zz, "plus_n_O");(mk_dad_meta 2) ]))); +(mk_rewrite false (mkAppC(mk_id( "plus_n_O"),[(mk_dad_meta 2) ]))); add_dad_rule "plus-permute-lr" -(Node(zz,"APPLIST",[Nvar(zz,"plus");Node(zz,"META",[Num(zz,4)]);Node(zz,"APPLIST",[Nvar(zz,"plus");Node(zz,"META",[Num(zz,3)]);Node(zz,"META",[Num(zz,2)])])])) +(mkAppC(mk_id("plus"),[mkMetaC(4);mkAppC(mk_id("plus"),[mkMetaC(3);mkMetaC(2)])])) [2; 1] [2; 2; 2; 1] 1 [2] -(mk_rewrite true (Node(zz, "APPLIST", [Nvar(zz, "plus_permute");(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ]))); +(mk_rewrite true (mkAppC(mk_id( "plus_permute"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ]))); add_dad_rule "plus-permute-rl" -(Node(zz,"APPLIST",[Nvar(zz,"plus");Node(zz,"META",[Num(zz,4)]);Node(zz,"APPLIST",[Nvar(zz,"plus");Node(zz,"META",[Num(zz,3)]);Node(zz,"META",[Num(zz,2)])])])) +(mkAppC(mk_id("plus"),[mkMetaC(4);mkAppC(mk_id("plus"),[mkMetaC(3);mkMetaC(2)])])) [2; 2; 2; 1] [2; 1] 1 [2] -(mk_rewrite true (Node(zz, "APPLIST", [Nvar(zz, "plus_permute");(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ])));; +(mk_rewrite true (mkAppC(mk_id( "plus_permute"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ])));; vinterp_add "StartDad" (function diff --git a/contrib/interface/dad.mli b/contrib/interface/dad.mli index dc2b2734c..f556c1926 100644 --- a/contrib/interface/dad.mli +++ b/contrib/interface/dad.mli @@ -1,10 +1,10 @@ open Proof_type;; open Tacmach;; - +open Topconstr;; val dad_rule_names : unit -> string list;; val start_dad : unit -> unit;; val dad_tac : (Tacexpr.raw_tactic_expr -> 'a) -> int list -> int list -> goal sigma -> goal list sigma * validation;; -val add_dad_rule : string -> Ctast.t -> (int list) -> (int list) -> +val add_dad_rule : string -> constr_expr -> (int list) -> (int list) -> int -> (int list) -> Tacexpr.raw_atomic_tactic_expr -> unit;; diff --git a/contrib/interface/debug_tac.ml4 b/contrib/interface/debug_tac.ml4 index b4db22803..343f90d6e 100644 --- a/contrib/interface/debug_tac.ml4 +++ b/contrib/interface/debug_tac.ml4 @@ -279,7 +279,7 @@ let mkOnThen t1 t2 selected_indices = let a = in_gen rawwit_tactic t1 in let b = in_gen rawwit_tactic t2 in let l = in_gen (wit_list0 rawwit_int) selected_indices in - TacAtom (dummy_loc, TacExtend ("OnThen", [a;b;l]));; + TacAtom (dummy_loc, TacExtend (dummy_loc, "OnThen", [a;b;l]));; (* Analyzing error reports *) @@ -363,7 +363,7 @@ let rec reconstruct_success_tac tac = Report_node(true, n, l) -> tac | Report_node(false, n, rl) -> let selected_indices = select_success 1 rl in - TacAtom (Ast.dummy_loc,TacExtend ("OnThen", + TacAtom (dummy_loc,TacExtend (dummy_loc,"OnThen", [in_gen rawwit_tactic a; in_gen rawwit_tactic b; in_gen (wit_list0 rawwit_int) selected_indices])) diff --git a/contrib/interface/name_to_ast.ml b/contrib/interface/name_to_ast.ml index ec600d21d..a7e1f3444 100644 --- a/contrib/interface/name_to_ast.ml +++ b/contrib/interface/name_to_ast.ml @@ -20,6 +20,7 @@ open Declare;; open Nametab open Vernacexpr;; open Decl_kinds;; +open Constrextern;; (* This function converts the parameter binders of an inductive definition, in particular you have to be careful to handle each element in the @@ -28,7 +29,7 @@ open Decl_kinds;; let convert_env = let convert_binder env (na, _, c) = match na with - | Name id -> (id, ast_of_constr true env c) + | Name id -> (id, extern_constr true env c) | Anonymous -> failwith "anomaly: Anonymous variables in inductives" in let rec cvrec env = function [] -> [] @@ -102,7 +103,7 @@ let convert_constructors envpar names types = array_map2 (fun n t -> let coercion_flag = false (* arbitrary *) in - (coercion_flag, (n, ast_of_constr true envpar t))) + (coercion_flag, (n, extern_constr true envpar t))) names types in Array.to_list array_idC;; @@ -116,7 +117,7 @@ let convert_one_inductive sp tyi = let sp = sp_of_global None (IndRef (sp, tyi)) in (basename sp, convert_env(List.rev params), - (ast_of_constr true envpar arity), + (extern_constr true envpar arity), convert_constructors envpar cstrnames cstrtypes);; (* This function converts a Mutual inductive definition to a Coqast.t. @@ -132,7 +133,7 @@ let mutual_to_ast_list sp mib = :: (implicit_args_to_ast_list sp mipv);; let constr_to_ast v = - ast_of_constr true (Global.env()) v;; + extern_constr true (Global.env()) v;; let implicits_to_ast_list implicits = match (impl_args_to_string implicits) with @@ -215,7 +216,8 @@ let leaf_entry_to_ast_list ((sp,kn),lobj) = (* this function is inspired by print_name *) -let name_to_ast qid = +let name_to_ast ref = + let (loc,qid) = qualid_of_reference ref in let l = try let sp = Nametab.locate_obj qid in diff --git a/contrib/interface/name_to_ast.mli b/contrib/interface/name_to_ast.mli index 600ec5f91..0eca0a1e7 100644 --- a/contrib/interface/name_to_ast.mli +++ b/contrib/interface/name_to_ast.mli @@ -1,2 +1,2 @@ -val name_to_ast : Libnames.qualid -> Vernacexpr.vernac_expr;; +val name_to_ast : Libnames.reference -> Vernacexpr.vernac_expr;; val convert_qualid : Libnames.qualid -> Coqast.t;; diff --git a/contrib/interface/parse.ml b/contrib/interface/parse.ml index 61fd06072..a8d74c30e 100644 --- a/contrib/interface/parse.ml +++ b/contrib/interface/parse.ml @@ -112,7 +112,7 @@ let execute_when_necessary v = (try Vernacentries.interp v with _ -> - let l=prlist_with_sep spc (fun (_,qid) -> pr_qualid qid) l in + let l=prlist_with_sep spc pr_reference l in msgnl (str "Reinterning of " ++ l ++ str " failed")) | VernacRequireFrom (_,_,name,_) -> (try diff --git a/contrib/interface/pbp.ml b/contrib/interface/pbp.ml index 7bd29a958..469a067f4 100644 --- a/contrib/interface/pbp.ml +++ b/contrib/interface/pbp.ml @@ -17,6 +17,10 @@ open Tacmach;; open Tacexpr;; open Typing;; open Pp;; +open Libnames;; +open Topconstr;; + +let zz = (0,0);; (* get_hyp_by_name : goal sigma -> string -> constr, looks up for an hypothesis (or a global constant), from its name *) @@ -25,13 +29,12 @@ let get_hyp_by_name g name = let env = pf_env g in try (let judgment = Pretyping.understand_judgment - evd env (RVar(dummy_loc, name)) in + evd env (RVar(zz, name)) in ("hyp",judgment.uj_type)) (* je sais, c'est pas beau, mais je ne sais pas trop me servir de look_up... Loïc *) - with _ -> (let ast = Termast.ast_of_qualid (Libnames.make_short_qualid name)in - let c = Astterm.interp_constr evd env ast in - ("cste",type_of (Global.env()) Evd.empty c)) + with _ -> (let c = Nametab.global (Ident (zz,name)) in + ("cste",type_of (Global.env()) Evd.empty (constr_of_reference c))) ;; type pbp_atom = @@ -85,8 +88,6 @@ type pbp_rule = (identifier list * identifier option -> (types, constr) kind_of_term -> int list -> pbp_sequence)) -> pbp_sequence option;; -let zz = (0,0);; - (* let make_named_intro s = Node(zz, "Intros", @@ -164,10 +165,13 @@ let (imply_intro1: pbp_rule) = function (kind_of_term prem) path)) | _ -> None;; +let make_var id = CRef (Ident(zz, id)) + +let make_app f l = CApp (zz,f,List.map (fun x -> (x,None)) l) + let make_pbp_pattern x = - Coqast.Node(zz,"APPLIST", - [Coqast.Nvar (zz, id_of_string "PBP_META"); - Coqast.Nvar (zz, id_of_string ("Value_for_" ^ (string_of_id x)))]) + make_app (make_var (id_of_string "PBP_META")) + [make_var (id_of_string ("Value_for_" ^ (string_of_id x)))] let rec make_then = function | [] -> TacId @@ -177,26 +181,26 @@ let rec make_then = function let make_pbp_atomic_tactic = function | PbpTryAssumption None -> TacTry (TacAtom (zz, TacAssumption)) | PbpTryAssumption (Some a) -> - TacTry (TacAtom (zz, TacExact (Coqast.Nvar (zz,a)))) + TacTry (TacAtom (zz, TacExact (make_var a))) | PbpExists x -> TacAtom (zz, TacSplit (ImplicitBindings [make_pbp_pattern x])) | PbpGeneralize (h,args) -> - let l = Coqast.Nvar (zz, h)::List.map make_pbp_pattern args in - TacAtom (zz, TacGeneralize [Coqast.Node (zz, "APPLIST", l)]) + let l = List.map make_pbp_pattern args in + TacAtom (zz, TacGeneralize [make_app (make_var h) l]) | PbpLeft -> TacAtom (zz, TacLeft NoBindings) | PbpRight -> TacAtom (zz, TacRight NoBindings) | PbpReduce -> TacAtom (zz, TacReduce (Red false, [])) | PbpIntros l -> let l = List.map (fun id -> IntroIdentifier id) l in TacAtom (zz, TacIntroPattern l) - | PbpLApply h -> TacAtom (zz, TacLApply (Coqast.Nvar (zz, h))) - | PbpApply h -> TacAtom (zz, TacApply (Coqast.Nvar(zz, h),NoBindings)) + | PbpLApply h -> TacAtom (zz, TacLApply (make_var h)) + | PbpApply h -> TacAtom (zz, TacApply (make_var h,NoBindings)) | PbpElim (hyp_name, names) -> let bind = List.map (fun s -> (NamedHyp s,make_pbp_pattern s)) names in TacAtom - (zz, TacElim ((Coqast.Nvar(zz,hyp_name),ExplicitBindings bind),None)) + (zz, TacElim ((make_var hyp_name,ExplicitBindings bind),None)) | PbpTryClear l -> - TacTry (TacAtom (zz, TacClear (List.map (fun s -> AN (zz,s)) l))) + TacTry (TacAtom (zz, TacClear (List.map (fun s -> AN s) l))) | PbpSplit -> TacAtom (zz, TacSplit NoBindings);; let rec make_pbp_tactic = function @@ -254,7 +258,7 @@ let reference dir s = anomaly ("Coqlib: cannot find "^ (Libnames.string_of_qualid (Libnames.make_qualid dir id))) -let constant dir s = Declare.constr_of_reference (reference dir s);; +let constant dir s = constr_of_reference (reference dir s);; let andconstr: unit -> constr = Coqlib.build_coq_and;; let prodconstr () = constant "Datatypes" "prod";; diff --git a/contrib/interface/showproof.ml b/contrib/interface/showproof.ml index c7e6be131..4ae1f280d 100644 --- a/contrib/interface/showproof.ml +++ b/contrib/interface/showproof.ml @@ -17,7 +17,6 @@ open Translate open Term open Reductionops open Clenv -open Astterm open Typing open Inductive open Inductiveops @@ -188,8 +187,8 @@ let rule_to_ntactic r = let rt = (match r with Tactic (t,_) -> t - | Prim (Refine h) -> TacAtom (Ast.dummy_loc,TacExact h) - | _ -> TacAtom (Ast.dummy_loc, TacIntroPattern [])) in + | Prim (Refine h) -> TacAtom (dummy_loc,TacExact h) + | _ -> TacAtom (dummy_loc, TacIntroPattern [])) in if rule_is_complex r then (match rt with TacArg (Tacexp _) as t -> t @@ -198,12 +197,13 @@ let rule_to_ntactic r = else rt ;; - +(* let term_of_command x = match x with Node(_,_,y::_) -> y | _ -> x ;; +*) (* Attribue les preuves de la liste l aux sous-buts non-prouvés de nt *) @@ -270,7 +270,7 @@ let to_nproof sigma osign pf = t_concl=concl ntree; t_full_concl=ntree.t_goal.t_full_concl; t_full_env=ntree.t_goal.t_full_env}; - t_proof= Proof (TacAtom (Ast.dummy_loc,TacExtend ("InfoAuto",[])), [ntree])} + t_proof= Proof (TacAtom (dummy_loc,TacExtend (dummy_loc,"InfoAuto",[])), [ntree])} else ntree | _ -> ntree)) else @@ -415,7 +415,7 @@ let enumerate f ln = ;; -let constr_of_ast = Astterm.interp_constr Evd.empty (Global.env());; +let constr_of_ast = Constrintern.interp_constr Evd.empty (Global.env());; (* let sp_tac tac = @@ -1139,7 +1139,7 @@ let eq_term = eq_constr;; let is_equality_tac = function | TacAtom (_, (TacExtend - (("ERewriteLR"|"ERewriteRL"|"ERewriteLRocc"|"ERewriteRLocc" + (_,("ERewriteLR"|"ERewriteRL"|"ERewriteLRocc"|"ERewriteRLocc" |"ERewriteParallel"|"ERewriteNormal" |"RewriteLR"|"RewriteRL"|"Replace"),_) | TacReduce _ @@ -1196,7 +1196,7 @@ let list_to_eq l o= let stde = Global.env;; -let dbize env = Astterm.interp_constr Evd.empty env;; +let dbize env = Constrintern.interp_constr Evd.empty env;; (**********************************************************************) let rec natural_ntree ig ntree = @@ -1214,8 +1214,7 @@ let rec natural_ntree ig ntree = (fun (_,ntree) -> let lemma = match (proof ntree) with Proof (tac,ltree) -> - (try (sph [spt (dbize (gLOB ge) - (term_of_command (arg1_tactic tac)));(* TODO *) + (try (sph [spt (dbize (gLOB ge) (arg1_tactic tac));(* TODO *) (match ltree with [] ->spe | [_] -> spe @@ -1279,39 +1278,39 @@ let rec natural_ntree ig ntree = | TacLeft _ -> natural_left ig lh g gs ltree | (* "Simpl" *)TacReduce (r,cl) -> natural_reduce ig lh g gs ge r cl ltree - | TacExtend ("InfoAuto",[]) -> natural_infoauto ig lh g gs ltree + | TacExtend (_,"InfoAuto",[]) -> natural_infoauto ig lh g gs ltree | TacAuto _ -> natural_auto ig lh g gs ltree - | TacExtend ("EAuto",_) -> natural_auto ig lh g gs ltree + | TacExtend (_,"EAuto",_) -> natural_auto ig lh g gs ltree | TacTrivial _ -> natural_trivial ig lh g gs ltree | TacAssumption -> natural_trivial ig lh g gs ltree | TacClear _ -> natural_clear ig lh g gs ltree (* Besoin de l'argument de la tactique *) | TacOldInduction (NamedHyp id) -> natural_induction ig lh g gs ge id ltree false - | TacExtend ("InductionIntro",[a]) -> + | TacExtend (_,"InductionIntro",[a]) -> let id=(out_gen wit_ident a) in natural_induction ig lh g gs ge id ltree true | TacApply (c,_) -> natural_apply ig lh g gs c ltree | TacExact c -> natural_exact ig lh g gs c ltree | TacCut c -> natural_cut ig lh g gs c ltree - | TacExtend ("CutIntro",[a]) -> + | TacExtend (_,"CutIntro",[a]) -> let c = out_gen wit_constr a in natural_cutintro ig lh g gs a ltree | TacCase (c,_) -> natural_case ig lh g gs ge c ltree false - | TacExtend ("CaseIntro",[a]) -> + | TacExtend (_,"CaseIntro",[a]) -> let c = out_gen wit_constr a in natural_case ig lh g gs ge c ltree true | TacElim ((c,_),_) -> natural_elim ig lh g gs ge c ltree false - | TacExtend ("ElimIntro",[a]) -> + | TacExtend (_,"ElimIntro",[a]) -> let c = out_gen wit_constr a in natural_elim ig lh g gs ge c ltree true - | TacExtend ("Rewrite",[_;a]) -> + | TacExtend (_,"Rewrite",[_;a]) -> let (c,_) = out_gen wit_constr_with_bindings a in natural_rewrite ig lh g gs c ltree - | TacExtend ("ERewriteRL",[a]) -> + | TacExtend (_,"ERewriteRL",[a]) -> let c = out_gen wit_constr a in (* TODO *) natural_rewrite ig lh g gs c ltree - | TacExtend ("ERewriteLR",[a]) -> + | TacExtend (_,"ERewriteLR",[a]) -> let c = out_gen wit_constr a in (* TODO *) natural_rewrite ig lh g gs c ltree |_ -> natural_generic ig lh g gs (sps (name_tactic tac)) (prl sp_tac [tac]) ltree diff --git a/contrib/interface/showproof.mli b/contrib/interface/showproof.mli index c84642d77..ee2694585 100755 --- a/contrib/interface/showproof.mli +++ b/contrib/interface/showproof.mli @@ -10,7 +10,6 @@ open Translate open Term open Reduction open Clenv -open Astterm open Typing open Inductive open Vernacinterp diff --git a/contrib/interface/xlate.ml b/contrib/interface/xlate.ml index 92a35b892..a5a153bdb 100644 --- a/contrib/interface/xlate.ml +++ b/contrib/interface/xlate.ml @@ -13,6 +13,8 @@ open Rawterm;; open Tacexpr;; open Vernacexpr;; open Decl_kinds;; +open Topconstr;; +open Libnames;; let in_coq_ref = ref false;; @@ -297,23 +299,25 @@ let qualid_to_ct_ID = | Node(_, "QUALIDMETA",[Num(_,n)]) -> Some(CT_metac (CT_int n)) | _ -> None;; -let tac_qualid_to_ct_ID qid = CT_ident (Libnames.string_of_qualid qid) +let tac_qualid_to_ct_ID ref = + CT_ident (Libnames.string_of_qualid (snd (qualid_of_reference ref))) -let loc_qualid_to_ct_ID (_,qid) = CT_ident (Libnames.string_of_qualid qid) +let loc_qualid_to_ct_ID ref = + CT_ident (Libnames.string_of_qualid (snd (qualid_of_reference ref))) let qualid_or_meta_to_ct_ID = function - | AN (_,qid) -> tac_qualid_to_ct_ID qid + | AN qid -> tac_qualid_to_ct_ID qid | MetaNum (_,n) -> CT_metac (CT_int n) let ident_or_meta_to_ct_ID = function - | AN (_,id) -> xlate_ident id + | AN id -> xlate_ident id | MetaNum (_,n) -> CT_metac (CT_int n) let xlate_qualid_list l = CT_id_list (List.map loc_qualid_to_ct_ID l) let reference_to_ct_ID = function - | Coqast.RIdent (_,id) -> CT_ident (Names.string_of_id id) - | Coqast.RQualid (_,qid) -> CT_ident (Libnames.string_of_qualid qid) + | Ident (_,id) -> CT_ident (Names.string_of_id id) + | Qualid (_,qid) -> CT_ident (Libnames.string_of_qualid qid) let xlate_class = function | FunClass -> CT_ident "FUNCLASS" @@ -755,10 +759,10 @@ let xlate_special_cases cont_function arg = let xlate_sort = function - | Coqast.Node (_, "SET", []) -> CT_sortc "Set" - | Coqast.Node (_, "PROP", []) -> CT_sortc "Prop" - | Coqast.Node (_, "TYPE", []) -> CT_sortc "Type" - | _ -> xlate_error "xlate_sort";; + | RProp Term.Pos -> CT_sortc "Set" + | RProp Term.Null -> CT_sortc "Prop" + | RType None -> CT_sortc "Type" + | RType (Some u) -> xlate_error "xlate_sort";; let xlate_formula a = !set_flags (); @@ -986,7 +990,7 @@ and (xlate_call_or_tacarg:raw_tactic_arg -> ct_TACTIC_COM) = CT_simple_user_tac (reference_to_ct_ID r, CT_tactic_arg_list(xlate_tacarg a,List.map xlate_tacarg l)) - | Reference (Coqast.RIdent (_,s)) -> ident_tac s + | Reference (Ident (_,s)) -> ident_tac s | t -> xlate_error "TODO: result other than tactic or constr" and xlate_red_tactic = @@ -1103,21 +1107,21 @@ and xlate_tactic = and xlate_tac = function - | TacExtend ("Absurd",[c]) -> + | TacExtend (_,"Absurd",[c]) -> CT_absurd (xlate_constr (out_gen rawwit_constr c)) | TacChange (f, b) -> CT_change (xlate_constr f, xlate_clause b) - | TacExtend ("Contradiction",[]) -> CT_contradiction + | TacExtend (_,"Contradiction",[]) -> CT_contradiction | TacDoubleInduction (AnonHyp n1, AnonHyp n2) -> CT_tac_double (CT_int n1, CT_int n2) | TacDoubleInduction _ -> xlate_error "TODO: Double Induction id1 id2" - | TacExtend ("Discriminate", [idopt]) -> + | TacExtend (_,"Discriminate", [idopt]) -> CT_discriminate_eq (xlate_quantified_hypothesis_opt (out_gen (wit_opt rawwit_quant_hyp) idopt)) - | TacExtend ("DEq", [idopt]) -> + | TacExtend (_,"DEq", [idopt]) -> CT_simplify_eq (xlate_ident_opt (out_gen (wit_opt rawwit_ident) idopt)) - | TacExtend ("Injection", [idopt]) -> + | TacExtend (_,"Injection", [idopt]) -> CT_injection_eq (xlate_quantified_hypothesis_opt (out_gen (wit_opt rawwit_quant_hyp) idopt)) @@ -1153,32 +1157,32 @@ and xlate_tac = | TacLeft bindl -> CT_left (xlate_bindings bindl) | TacRight bindl -> CT_right (xlate_bindings bindl) | TacSplit bindl -> CT_split (xlate_bindings bindl) - | TacExtend ("Replace", [c1; c2]) -> + | TacExtend (_,"Replace", [c1; c2]) -> let c1 = xlate_constr (out_gen rawwit_constr c1) in let c2 = xlate_constr (out_gen rawwit_constr c2) in CT_replace_with (c1, c2) | - TacExtend ("Rewrite", [b; cbindl]) -> + TacExtend (_,"Rewrite", [b; cbindl]) -> let b = out_gen Extraargs.rawwit_orient b in let (c,bindl) = out_gen rawwit_constr_with_bindings cbindl in let c = xlate_constr c and bindl = xlate_bindings bindl in if b then CT_rewrite_lr (c, bindl, ctv_ID_OPT_NONE) else CT_rewrite_rl (c, bindl, ctv_ID_OPT_NONE) - | TacExtend ("RewriteIn", [b; cbindl; id]) -> + | TacExtend (_,"RewriteIn", [b; cbindl; id]) -> let b = out_gen Extraargs.rawwit_orient b in let (c,bindl) = out_gen rawwit_constr_with_bindings cbindl in let c = xlate_constr c and bindl = xlate_bindings bindl in let id = ctf_ID_OPT_SOME (xlate_ident (out_gen rawwit_ident id)) in if b then CT_rewrite_lr (c, bindl, id) else CT_rewrite_rl (c, bindl, id) - | TacExtend ("ConditionalRewrite", [t; b; cbindl]) -> + | TacExtend (_,"ConditionalRewrite", [t; b; cbindl]) -> let t = out_gen rawwit_tactic t in let b = out_gen Extraargs.rawwit_orient b in let (c,bindl) = out_gen rawwit_constr_with_bindings cbindl in let c = xlate_constr c and bindl = xlate_bindings bindl in if b then CT_condrewrite_lr (xlate_tactic t, c, bindl, ctv_ID_OPT_NONE) else CT_condrewrite_rl (xlate_tactic t, c, bindl, ctv_ID_OPT_NONE) - | TacExtend ("ConditionalRewriteIn", [t; b; cbindl; id]) -> + | TacExtend (_,"ConditionalRewriteIn", [t; b; cbindl; id]) -> let t = out_gen rawwit_tactic t in let b = out_gen Extraargs.rawwit_orient b in let (c,bindl) = out_gen rawwit_constr_with_bindings cbindl in @@ -1186,7 +1190,7 @@ and xlate_tac = let id = ctf_ID_OPT_SOME (xlate_ident (out_gen rawwit_ident id)) in if b then CT_condrewrite_lr (xlate_tactic t, c, bindl, id) else CT_condrewrite_rl (xlate_tactic t, c, bindl, id) - | TacExtend ("DependentRewrite", [b; id_or_constr]) -> + | TacExtend (_,"DependentRewrite", [b; id_or_constr]) -> let b = out_gen Extraargs.rawwit_orient b in (match genarg_tag id_or_constr with | IdentArgType -> (*Dependent Rewrite/SubstHypInConcl*) @@ -1197,7 +1201,7 @@ and xlate_tac = if b then CT_cutrewrite_lr (c, ctv_ID_OPT_NONE) else CT_cutrewrite_rl (c, ctv_ID_OPT_NONE) | _ -> xlate_error "") - | TacExtend ("DependentRewrite", [b; c; id]) -> (*CutRewrite in/SubstHyp*) + | TacExtend (_,"DependentRewrite", [b; c; id]) -> (*CutRewrite in/SubstHyp*) let b = out_gen Extraargs.rawwit_orient b in let c = xlate_constr (out_gen rawwit_constr c) in let id = xlate_ident (out_gen rawwit_ident id) in @@ -1224,7 +1228,7 @@ and xlate_tac = CT_auto_with(xlate_int_opt nopt, CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STAR( CT_id_ne_list(CT_ident id1, List.map (fun x -> CT_ident x) idl))) - | TacExtend ("EAuto", [nopt; popt; idl]) -> + | TacExtend (_,"EAuto", [nopt; popt; idl]) -> let first_n = match out_gen (wit_opt rawwit_int_or_var) nopt with | Some (ArgVar(_, s)) -> xlate_id_to_id_or_int_opt s @@ -1245,12 +1249,12 @@ and xlate_tac = (CT_id_ne_list (CT_ident a, List.map (fun x -> CT_ident x) l)))) - | TacExtend ("Prolog", [cl; n]) -> + | TacExtend (_,"Prolog", [cl; n]) -> let cl = List.map xlate_constr (out_gen (wit_list0 rawwit_constr) cl) in (match out_gen wit_int_or_var n with | ArgVar _ -> xlate_error "" | ArgArg n -> CT_prolog (CT_formula_list cl, CT_int n)) - | TacExtend ("EApply", [cbindl]) -> + | TacExtend (_,"EApply", [cbindl]) -> let (c,bindl) = out_gen rawwit_constr_with_bindings cbindl in let c = xlate_constr c and bindl = xlate_bindings bindl in CT_eapply (c, bindl) @@ -1302,11 +1306,12 @@ and xlate_tac = let idl' = List.map ident_or_meta_to_ct_ID idl in CT_clear (CT_id_ne_list (ident_or_meta_to_ct_ID id, idl')) | (*For translating tactics/Inv.v *) - TacExtend ("SimpleInversion"|"Inversion"|"InversionClear" as s, [id]) -> + TacExtend (_,("SimpleInversion"|"Inversion"|"InversionClear" as s), [id]) + -> let quant_hyp = out_gen rawwit_quant_hyp id in CT_inversion(compute_INV_TYPE_from_string s, xlate_quantified_hypothesis quant_hyp, CT_id_list []) - | TacExtend ("SimpleInversion"|"Inversion"|"InversionClear" as s, + | TacExtend (_,("SimpleInversion"|"Inversion"|"InversionClear" as s), [id;copt_or_idl]) -> let quant_hyp = (out_gen rawwit_quant_hyp id) in let id = xlate_quantified_hypothesis quant_hyp in @@ -1320,17 +1325,17 @@ and xlate_tac = CT_depinversion (compute_INV_TYPE_from_string s, id, xlate_constr_opt copt) | _ -> xlate_error "") - | TacExtend ("InversionUsing", [id; c]) -> + | TacExtend (_,"InversionUsing", [id; c]) -> let id = xlate_quantified_hypothesis (out_gen rawwit_quant_hyp id) in let c = out_gen rawwit_constr c in CT_use_inversion (id, xlate_constr c, CT_id_list []) - | TacExtend ("InversionUsing", [id; c; idlist]) -> + | TacExtend (_,"InversionUsing", [id; c; idlist]) -> let id = xlate_quantified_hypothesis (out_gen rawwit_quant_hyp id) in let c = out_gen rawwit_constr c in let idlist = out_gen (wit_list1 rawwit_ident) idlist in CT_use_inversion (id, xlate_constr c, CT_id_list (List.map xlate_ident idlist)) - | TacExtend ("Omega", []) -> CT_omega + | TacExtend (_,"Omega", []) -> CT_omega | TacRename (_, _) -> xlate_error "TODO: Rename id into id'" | TacClearBody _ -> xlate_error "TODO: Clear Body H" | TacDAuto (_, _) -> xlate_error "TODO: DAuto" @@ -1341,7 +1346,7 @@ and xlate_tac = | TacForward (_, _, _) -> xlate_error "TODO: Assert/Pose id:=c" | TacTrueCut (_, _) -> xlate_error "TODO: Assert id:t" | TacAnyConstructor tacopt -> xlate_error "TODO: Constructor tac" - | TacExtend (id, l) -> + | TacExtend (_,id, l) -> CT_user_tac (CT_ident id, CT_targ_list (List.map coerce_genarg_to_TARG l)) | TacAlias (_, _, _) -> xlate_error "TODO: aliases" @@ -1366,10 +1371,13 @@ and coerce_genarg_to_TARG x = | IdentArgType -> let id = xlate_ident (out_gen rawwit_ident x) in CT_coerce_ID_OR_INT_to_TARG (CT_coerce_ID_to_ID_OR_INT id) - | QualidArgType -> - let id = tac_qualid_to_ct_ID (snd (out_gen rawwit_qualid x)) in + | RefArgType -> + let id = tac_qualid_to_ct_ID (out_gen rawwit_ref x) in CT_coerce_ID_OR_INT_to_TARG (CT_coerce_ID_to_ID_OR_INT id) (* Specific types *) + | SortArgType -> + CT_coerce_FORMULA_to_TARG + (CT_coerce_SORT_TYPE_to_FORMULA (xlate_sort (out_gen rawwit_sort x))) | ConstrArgType -> CT_coerce_FORMULA_to_TARG (xlate_constr (out_gen rawwit_constr x)) | ConstrMayEvalArgType -> xlate_error"TODO: generic constr-may-eval argument" @@ -1440,12 +1448,16 @@ let coerce_genarg_to_VARG x = CT_coerce_ID_OPT_OR_ALL_to_VARG (CT_coerce_ID_OPT_to_ID_OPT_OR_ALL (CT_coerce_ID_to_ID_OPT id)) - | QualidArgType -> - let id = tac_qualid_to_ct_ID (snd (out_gen rawwit_qualid x)) in + | RefArgType -> + let id = tac_qualid_to_ct_ID (out_gen rawwit_ref x) in CT_coerce_ID_OPT_OR_ALL_to_VARG (CT_coerce_ID_OPT_to_ID_OPT_OR_ALL (CT_coerce_ID_to_ID_OPT id)) (* Specific types *) + | SortArgType -> + CT_coerce_FORMULA_OPT_to_VARG + (CT_coerce_FORMULA_to_FORMULA_OPT + (CT_coerce_SORT_TYPE_to_FORMULA (xlate_sort (out_gen rawwit_sort x)))) | ConstrArgType -> CT_coerce_FORMULA_OPT_to_VARG (CT_coerce_FORMULA_to_FORMULA_OPT (xlate_constr (out_gen rawwit_constr x))) @@ -1580,6 +1592,18 @@ let cvt_vernac_binder = function let cvt_vernac_binders args = CT_binder_list(List.map cvt_vernac_binder args) +let cvt_name = function + | (_,Name id) -> xlate_ident_opt (Some id) + | (_,Anonymous) -> xlate_ident_opt None + +let cvt_fixpoint_binder = function + | (na::l,c) -> + CT_binder(CT_id_opt_ne_list (cvt_name na,List.map cvt_name l), + xlate_constr c) + | [],c -> xlate_error "Shouldn't occur" + +let cvt_fixpoint_binders args = + CT_binder_list(List.map cvt_fixpoint_binder args) let xlate_vernac = function @@ -1642,7 +1666,8 @@ let xlate_vernac = (CT_string_ne_list (CT_string str, List.map (fun x -> CT_string x) l)) | VernacGoal c -> CT_coerce_THEOREM_GOAL_to_COMMAND (CT_goal (xlate_constr c)) - | VernacAbort (Some id) -> CT_abort(ctf_ID_OPT_OR_ALL_SOME(xlate_ident id)) + | VernacAbort (Some (_,id)) -> + CT_abort(ctf_ID_OPT_OR_ALL_SOME(xlate_ident id)) | VernacAbort None -> CT_abort ctv_ID_OPT_OR_ALL_NONE | VernacAbortAll -> CT_abort ctv_ID_OPT_OR_ALL_ALL | VernacRestart -> CT_restart @@ -1681,10 +1706,7 @@ let xlate_vernac = CT_hint(xlate_ident id_name, dblist, CT_extern(CT_int n, xlate_constr c, xlate_tactic t)) | HintsResolve l -> (* = Old HintsResolve *) - let l = List.map - (function - (None,Coqast.Node(_,"QUALID",l)) -> Astterm.interp_qualid l - | _ -> failwith "") l in + let l = List.map (function (None,CRef r) -> r | _ -> failwith "") l in let n1, names = match List.map tac_qualid_to_ct_ID l with n1 :: names -> n1, names | _ -> failwith "" in @@ -1692,10 +1714,7 @@ let xlate_vernac = CT_id_ne_list(n1, names), dblist) | HintsImmediate l -> (* = Old HintsImmediate *) - let l = List.map - (function - (None,Coqast.Node(_,"QUALID",l)) -> Astterm.interp_qualid l - | _ -> failwith "") l in + let l = List.map (function (None,CRef r) -> r | _ -> failwith "") l in let n1, names = match List.map tac_qualid_to_ct_ID l with n1 :: names -> n1, names | _ -> failwith "" in @@ -1705,7 +1724,7 @@ let xlate_vernac = | HintsUnfold l -> (* = Old HintsUnfold *) let l = List.map (function - (None,qid) -> loc_qualid_to_ct_ID qid + (None,ref) -> loc_qualid_to_ct_ID ref | _ -> failwith "") l in let n1, names = match l with n1 :: names -> n1, names @@ -1780,7 +1799,7 @@ let xlate_vernac = | VernacStartTheoremProof (k, s, (bl,c), _, _) -> xlate_error "TODO: VernacStartTheoremProof" | VernacSuspend -> CT_suspend - | VernacResume idopt -> CT_resume (xlate_ident_opt idopt) + | VernacResume idopt -> CT_resume (xlate_ident_opt (option_app snd idopt)) | VernacDefinition (k,s,ProveBody (bl,typ),_) -> if bl <> [] then xlate_error "TODO: Def bindings"; CT_coerce_THEOREM_GOAL_to_COMMAND( @@ -1854,7 +1873,7 @@ let xlate_vernac = | VernacFixpoint [] -> xlate_error "mutual recursive" | VernacFixpoint (lm :: lmi) -> let strip_mutrec (fid, bl, arf, ardef) = - match cvt_vernac_binders bl with + match cvt_fixpoint_binders bl with | CT_binder_list (b :: bl) -> CT_fix_rec (xlate_ident fid, CT_binder_ne_list (b, bl), xlate_constr arf, xlate_constr ardef) @@ -1907,6 +1926,8 @@ let xlate_vernac = | VernacNotation _ -> xlate_error "TODO: Notation" + | VernacSyntaxExtension _ -> xlate_error "Syntax Extension not implemented" + | VernacInfix (str_assoc, n, str, id, None) -> CT_infix ( (match str_assoc with @@ -1936,7 +1957,7 @@ let xlate_vernac = | Local -> CT_local in CT_coercion (local_opt, id_opt, xlate_ident id1, xlate_class id2, xlate_class id3) - | VernacResetName id -> CT_reset (xlate_ident id) + | VernacResetName id -> CT_reset (xlate_ident (snd id)) | VernacResetInitial -> CT_restore_state (CT_ident "Initial") | VernacExtend (s, l) -> CT_user_vernac diff --git a/contrib/ring/ring.ml b/contrib/ring/ring.ml index db9b00c38..f4848c729 100644 --- a/contrib/ring/ring.ml +++ b/contrib/ring/ring.ml @@ -36,7 +36,7 @@ open Nametab open Quote let mt_evd = Evd.empty -let constr_of c = Astterm.interp_constr mt_evd (Global.env()) c +let constr_of c = Constrintern.interp_constr mt_evd (Global.env()) c let constant dir s = let dir = make_dirpath (List.map id_of_string (List.rev ("Coq"::dir))) in diff --git a/contrib/xml/cic2acic.ml b/contrib/xml/cic2acic.ml index 19dfc940a..1cd33f53c 100644 --- a/contrib/xml/cic2acic.ml +++ b/contrib/xml/cic2acic.ml @@ -249,7 +249,7 @@ print_endline "PASSATO" ; flush stdout ; let subst,residual_args,uninst_vars = let variables,basedir = try - let g = Declare.reference_of_constr h in + let g = Libnames.reference_of_constr h in let sp = match g with Libnames.ConstructRef ((induri,_),_) diff --git a/contrib/xml/xmlcommand.ml b/contrib/xml/xmlcommand.ml index 151d4582b..07df70a0c 100644 --- a/contrib/xml/xmlcommand.ml +++ b/contrib/xml/xmlcommand.ml @@ -393,7 +393,7 @@ let mk_inductive_obj sp packs variables hyps finite = (* 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 (_,qid as locqid) fn = +let print r fn = let module D = Declarations in let module De = Declare in let module G = Global in @@ -402,14 +402,16 @@ let print (_,qid as locqid) fn = let module T = Term in let module X = Xml in let module Ln = Libnames in - let (_,id) = Libnames.repr_qualid qid in + let (_,id) = Ln.repr_qualid (snd (Ln.qualid_of_reference r)) in let glob_ref = (*CSC: ask Hugo why Nametab.global does not work with variables and *) (*CSC: we have to do this hugly try ... with *) try - Nt.global locqid + Nt.global r with - _ -> let (_,id) = Ln.repr_qualid qid in Ln.VarRef id + _ -> + let (_,id) = Ln.repr_qualid (snd (Ln.qualid_of_reference r)) in + Ln.VarRef id in (* Variables are the identifiers of the variables in scope *) let variables = search_variables () in @@ -761,14 +763,17 @@ let filename_of_path ?(keep_sections=false) xml_library_root kn tag = ;; (*CSC: Ask Hugo for a better solution *) -let qualid_of_kernel_name kn = +(* +let ref_of_kernel_name kn = let module N = Names in + let module Ln = Libnames in let (modpath,_,label) = N.repr_kn kn in match modpath with - N.MPself _ -> Libnames.make_qualid (Lib.cwd ()) (N.id_of_label label) + N.MPself _ -> Ln.Qualid (Ln.qualid_of_sp (Nametab.sp_of_global None kn)) | _ -> - Util.anomaly ("qualid_of_kernel_name: the module path is not MPself") + Util.anomaly ("ref_of_kernel_name: the module path is not MPself") ;; +*) (* Let's register the callbacks *) let xml_library_root = @@ -787,37 +792,37 @@ let _ = let _ = Declare.set_xml_declare_variable - (function kn -> + (function (sp,kn) -> let filename = filename_of_path ~keep_sections:true xml_library_root kn Cic2acic.Variable in - let qualid = qualid_of_kernel_name kn in let dummy_location = -1,-1 in - print (dummy_location,qualid) filename) + let ref = Libnames.Qualid (dummy_location,Libnames.qualid_of_sp sp) in + print ref filename) ;; let _ = Declare.set_xml_declare_constant - (function kn -> + (function (sp,kn) -> let filename = filename_of_path xml_library_root kn Cic2acic.Constant in - let qualid = qualid_of_kernel_name kn in + let dummy_location = -1,-1 in + let ref = Libnames.Qualid (dummy_location,Libnames.qualid_of_sp sp) in match !proof_to_export with None -> - let dummy_location = -1,-1 in - print (dummy_location,qualid) filename + print ref filename | Some pftreestate -> (* It is a proof. Let's export it starting from the proof-tree *) (* I saved in the Pfedit.set_xml_cook_proof callback. *) - show_pftreestate filename pftreestate - (Names.id_of_label (Names.label kn)) ; + show_pftreestate filename pftreestate + (Names.id_of_label (Names.label kn)) ; proof_to_export := None) ;; let _ = Declare.set_xml_declare_inductive - (function kn -> + (function (sp,kn) -> let filename = filename_of_path xml_library_root kn Cic2acic.Inductive in - let qualid = qualid_of_kernel_name kn in let dummy_location = -1,-1 in - print (dummy_location,qualid) filename) + let ref = Libnames.Qualid (dummy_location,Libnames.qualid_of_sp sp) in + print ref filename) ;; diff --git a/contrib/xml/xmlcommand.mli b/contrib/xml/xmlcommand.mli index 4690e21c1..6e43be9c2 100644 --- a/contrib/xml/xmlcommand.mli +++ b/contrib/xml/xmlcommand.mli @@ -28,7 +28,7 @@ (* 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) *) -val print : Libnames.qualid Util.located -> string option -> unit +val print : Libnames.reference -> string option -> unit (* show dest *) (* where dest is either None (for stdout) or (Some filename) *) diff --git a/contrib/xml/xmlentries.ml4 b/contrib/xml/xmlentries.ml4 index fbb9944d3..6988f789e 100644 --- a/contrib/xml/xmlentries.ml4 +++ b/contrib/xml/xmlentries.ml4 @@ -81,14 +81,14 @@ let _ = (wit_diskname, pr_diskname) VERNAC COMMAND EXTEND Xml -| [ "Print" "XML" filename(fn) qualid(id) ] -> [ Xmlcommand.print id fn ] +| [ "Print" "XML" filename(fn) global(id) ] -> [ Xmlcommand.print id fn ] | [ "Show" "XML" filename(fn) "Proof" ] -> [ Xmlcommand.show fn ] (* | [ "Print" "XML" "All" ] -> [ Xmlcommand.printAll () ] -| [ "Print" "XML" "Module" diskname(dn) qualid(id) ] -> +| [ "Print" "XML" "Module" diskname(dn) global(id) ] -> [ Xmlcommand.printLibrary id dn ] | [ "Print" "XML" "Section" diskname(dn) ident(id) ] -> diff --git a/dev/base_include b/dev/base_include index 83d967ce4..cadbc5cf1 100644 --- a/dev/base_include +++ b/dev/base_include @@ -3,6 +3,15 @@ This file is loaded by include *) #cd".";; +#directory "parsing";; +#directory "interp";; +#directory "toplevel";; +#directory "library";; +#directory "kernel";; +#directory "pretyping";; +#directory "lib";; +#directory "proofs";; +#directory "tactics";; #use "top_printers.ml";; #install_printer (* identifier *) prid;; @@ -32,7 +41,7 @@ let parse_ast = parse_com;; (* build a term of type rawconstr without type-checking or resolution of implicit syntax *) -let e s = Astterm.interp_rawconstr Evd.empty (Global.env()) (parse_ast s);; +let e s = Constrintern.interp_rawconstr Evd.empty (Global.env()) (parse_ast s);; (* For compatibility *) let raw_constr_of_string = e;; @@ -41,7 +50,7 @@ let raw_constr_of_string = e;; implicit syntax *) let constr_of_string s = - Astterm.interp_constr Evd.empty (Global.env()) (parse_ast s);; + Constrintern.interp_constr Evd.empty (Global.env()) (parse_ast s);; (* get the body of a constant *) @@ -59,7 +68,7 @@ let get_nth_goal n = nth_goal_of_pftreestate n (Pfedit.get_pftreestate ());; let current_goal () = get_nth_goal 1;; let pf_e gl s = - Astterm.interp_constr (project gl) (pf_env gl) (parse_ast s);; + Constrintern.interp_constr (project gl) (pf_env gl) (parse_ast s);; open Toplevel let go = loop diff --git a/dev/top_printers.ml b/dev/top_printers.ml index b74cd395a..e936fc40f 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -277,7 +277,7 @@ let _ = | [VARG_CONSTR c] -> (fun () -> let (evmap,sign) = Command.get_current_context () in - constr_display (Astterm.interp_constr evmap sign c)) + constr_display (Constrintern.interp_constr evmap sign c)) | _ -> bad_vernac_args "PrintConstr") let _ = @@ -286,7 +286,7 @@ let _ = | [VARG_CONSTR c] -> (fun () -> let (evmap,sign) = Command.get_current_context () in - print_pure_constr (Astterm.interp_constr evmap sign c)) + print_pure_constr (Constrintern.interp_constr evmap sign c)) | _ -> bad_vernac_args "PrintPureConstr") *) diff --git a/doc/newsyntax.tex b/doc/newsyntax.tex index a8622445f..ea4b8c59a 100644 --- a/doc/newsyntax.tex +++ b/doc/newsyntax.tex @@ -707,6 +707,8 @@ l'ajouter \item Remplacer AddPath par Add LoadPath (ou + court) +\item Unify + and \{\}+\{\} and +\{\} using Prop $\leq$ Set ?? + \item Remplacer Implicit Arguments On/Off par Set/Unset Implicit Arguments. \item La syntaxe \verb=Intros (a,b)= est inutile, \verb=Intros [a b]= fait l'affaire. diff --git a/interp/constrextern.ml b/interp/constrextern.ml new file mode 100644 index 000000000..b9f22ff00 --- /dev/null +++ b/interp/constrextern.ml @@ -0,0 +1,360 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* o := old; raise e + +let with_arguments f = with_option print_arguments f +let with_casts f = with_option print_casts f +let with_implicits f = with_option print_implicits f +let with_coercions f = with_option print_coercions f +let with_universes f = with_option print_universes f + +(**********************************************************************) +(* conversion of references *) + +let ids_of_ctxt ctxt = + Array.to_list + (Array.map + (function c -> match kind_of_term c with + | Var id -> id + | _ -> + error + "Termast: arbitrary substitution of references not yet implemented") + ctxt) + +let idopt_of_name = function + | Name id -> Some id + | Anonymous -> None + +let extern_evar loc n = warning "No notation for Meta"; CMeta (loc,n) + +let extern_ref r = Qualid (dummy_loc,shortest_qualid_of_global None r) + +(**********************************************************************) +(* conversion of patterns *) + +let rec extern_cases_pattern = function (* loc is thrown away for printing *) + | PatVar (loc,Name id) -> CPatAtom (loc,Some (Ident (loc,id))) + | PatVar (loc,Anonymous) -> CPatAtom (loc, None) + | PatCstr(loc,cstrsp,args,na) -> + let args = List.map extern_cases_pattern args in + let p = CPatCstr (loc,extern_ref (ConstructRef cstrsp),args) in + (match na with + | Name id -> CPatAlias (loc,p,id) + | Anonymous -> p) + +let occur_name na aty = + match na with + | Name id -> occur_var_constr_expr id aty + | Anonymous -> false + +(* Implicit args indexes are in ascending order *) +let explicitize impl f args = + let n = List.length args in + let rec exprec q = function + | a::args, imp::impl when is_status_implicit imp -> + let tail = exprec (q+1) (args,impl) in + let visible = + (!print_implicits & !print_implicits_explicit_args) + or not (is_inferable_implicit n imp) in + if visible then (a,Some q) :: tail else tail + | a::args, _::impl -> (a,None) :: exprec (q+1) (args,impl) + | args, [] -> List.map (fun a -> (a,None)) args (*In case of polymorphism*) + | [], _ -> [] in + let args = exprec 1 (args,impl) in + if args = [] then f else CApp (dummy_loc, f, args) + +let rec skip_coercion dest_ref (f,args as app) = + if !print_coercions then app + else + try + match dest_ref f with + | Some r -> + (match Classops.hide_coercion r with + | Some n -> + if n >= List.length args then app + else (* We skip a coercion *) + let _,fargs = list_chop n args in + skip_coercion dest_ref (List.hd fargs,List.tl fargs) + | None -> app) + | None -> app + with Not_found -> app + +let extern_app impl f args = + if !print_implicits & not !print_implicits_explicit_args then + CAppExpl (dummy_loc, f, args) + else + explicitize impl (CRef f) args + +let loc = dummy_loc + +let rec extern = function + | RRef (_,ref) -> CRef (extern_ref ref) + + | RVar (_,id) -> CRef (Ident (loc,id)) + + | REvar (_,n) -> extern_evar loc n + + | RMeta (_,n) -> CMeta (loc,n) + + | RApp (_,f,args) -> + let (f,args) = + skip_coercion (function RRef(_,r) -> Some r | _ -> None) (f,args) in + let args = List.map extern args in + (match f with + | REvar (loc,ev) -> extern_evar loc ev (* we drop args *) + | RRef (loc,ref) -> + extern_app (implicits_of_global ref) (extern_ref ref) args + | _ -> explicitize [] (extern f) args) + + | RProd (_,Anonymous,t,c) -> + (* Anonymous product are never factorized *) + CArrow (loc,extern t,extern c) + + | RLetIn (_,na,t,c) -> + CLetIn (loc,(loc,na),extern t,extern c) + + | RProd (_,na,t,c) -> + let t = extern t in + let (idl,c) = factorize_prod t c in + CProdN (loc,[(loc,na)::idl,t],c) + + | RLambda (_,na,t,c) -> + let t = extern t in + let (idl,c) = factorize_lambda t c in + CLambdaN (loc,[(loc,na)::idl,t],c) + + | RCases (_,typopt,tml,eqns) -> + let pred = option_app extern typopt in + let tml = List.map extern tml in + let eqns = List.map extern_eqn eqns in + CCases (loc,pred,tml,eqns) + + | ROrderedCase (_,cs,typopt,tm,bv) -> + let bv = Array.to_list (Array.map extern bv) in + COrderedCase (loc,cs,option_app extern typopt,extern tm,bv) + + | RRec (_,fk,idv,tyv,bv) -> + (match fk with + | RFix (nv,n) -> + let rec split_lambda binds = function + | (0, t) -> (List.rev binds,extern t) + | (n, RLambda (_,na,t,b)) -> + split_lambda (([loc,na],extern t)::binds) (n-1,b) + | _ -> anomaly "extern: ill-formed fixpoint body" in + let rec split_product = function + | (0, t) -> extern t + | (n, RProd (_,na,t,b)) -> split_product (n-1,b) + | _ -> anomaly "extern: ill-formed fixpoint type" in + let listdecl = + Array.mapi + (fun i fi -> + let (lparams,def) = split_lambda [] (nv.(i)+1,bv.(i)) in + let typ = split_product (nv.(i)+1,tyv.(i)) in + (fi, lparams, typ, def)) + idv + in + CFix (loc,(loc,idv.(n)),Array.to_list listdecl) + | RCoFix n -> + let listdecl = + Array.mapi (fun i fi -> (fi,extern tyv.(i),extern bv.(i))) idv + in + CCoFix (loc,(loc,idv.(n)),Array.to_list listdecl)) + + | RSort (_,s) -> + let s = match s with + | RProp _ -> s + | RType (Some _) when !print_universes -> s + | RType _ -> RType None in + CSort (loc,s) + + | RHole (_,e) -> CHole loc + + | RCast (_,c,t) -> CCast (loc,extern c,extern t) + + | RDynamic (_,d) -> CDynamic (loc,d) + +and factorize_prod aty = function + | RProd (_,Name id,ty,c) + when aty = extern ty + & not (occur_var_constr_expr id aty) (*To avoid na in ty escapes scope*) + -> let (nal,c) = factorize_prod aty c in ((loc,Name id)::nal,c) + | c -> ([],extern c) + +and factorize_lambda aty = function + | RLambda (_,na,ty,c) + when aty = extern ty + & not (occur_name na aty) (* To avoid na in ty' escapes scope *) + -> let (nal,c) = factorize_lambda aty c in ((loc,na)::nal,c) + | c -> ([],extern c) + +and extern_eqn (loc,ids,pl,c) = + (loc,List.map extern_cases_pattern pl,extern c) +(* +and extern_numerals r = + on_numeral (fun p -> + match filter p r with + | Some f + +and extern_symbols r = +*) + +let extern_rawconstr = extern + +(******************************************************************) +(* Main translation function from constr -> constr_expr *) + +let extern_constr at_top env t = + let t' = + if !print_casts then t + else Reductionops.local_strong strip_outer_cast t in + let avoid = if at_top then ids_of_context env else [] in + extern (Detyping.detype env avoid (names_of_rel_context env) t') + +(******************************************************************) +(* Main translation function from pattern -> constr_expr *) + +let rec extern_pattern tenv env = function + | PRef ref -> CRef (extern_ref ref) + + | PVar id -> CRef (Ident (loc,id)) + + | PEvar n -> extern_evar loc n + + | PRel n -> + CRef (Ident (loc, + try match lookup_name_of_rel n env with + | Name id -> id + | Anonymous -> + anomaly "ast_of_pattern: index to an anonymous variable" + with Not_found -> + id_of_string ("[REL "^(string_of_int n)^"]"))) + + | PMeta None -> CHole loc + + | PMeta (Some n) -> CMeta (loc,n) + + | PApp (f,args) -> + let (f,args) = + skip_coercion (function PRef r -> Some r | _ -> None) + (f,Array.to_list args) in + let args = List.map (extern_pattern tenv env) args in + (match f with + | PRef ref -> + extern_app (implicits_of_global ref) (extern_ref ref) args + | _ -> explicitize [] (extern_pattern tenv env f) args) + + | PSoApp (n,args) -> + let args = List.map (extern_pattern tenv env) args in + (* [-n] is the trick to embed a so patten into a regular application *) + (* see constrintern.ml and g_constr.ml4 *) + explicitize [] (CMeta (loc,-n)) args + + | PProd (Anonymous,t,c) -> + (* Anonymous product are never factorized *) + CArrow (loc,extern_pattern tenv env t,extern_pattern tenv env c) + + | PLetIn (na,t,c) -> + CLetIn (loc,(loc,na),extern_pattern tenv env t,extern_pattern tenv env c) + + | PProd (na,t,c) -> + let t = extern_pattern tenv env t in + let (idl,c) = factorize_prod_pattern tenv (add_name na env) t c in + CProdN (loc,[(loc,na)::idl,t],c) + + | PLambda (na,t,c) -> + let t = extern_pattern tenv env t in + let (idl,c) = factorize_lambda_pattern tenv (add_name na env) t c in + CLambdaN (loc,[(loc,na)::idl,t],c) + + | PCase (cs,typopt,tm,bv) -> + let bv = Array.to_list (Array.map (extern_pattern tenv env) bv) in + COrderedCase + (loc,cs,option_app (extern_pattern tenv env) typopt, + extern_pattern tenv env tm,bv) + + | PFix f -> extern (Detyping.detype tenv [] env (mkFix f)) + + | PCoFix c -> extern (Detyping.detype tenv [] env (mkCoFix c)) + + | PSort s -> + let s = match s with + | RProp _ -> s + | RType (Some _) when !print_universes -> s + | RType _ -> RType None in + CSort (loc,s) + +and factorize_prod_pattern tenv env aty = function + | PProd (Name id as na,ty,c) + when aty = extern_pattern tenv env ty + & not (occur_var_constr_expr id aty) (*To avoid na in ty escapes scope*) + -> let (nal,c) = factorize_prod_pattern tenv (na::env) aty c in + ((loc,Name id)::nal,c) + | c -> ([],extern_pattern tenv env c) + +and factorize_lambda_pattern tenv env aty = function + | PLambda (na,ty,c) + when aty = extern_pattern tenv env ty + & not (occur_name na aty) (* To avoid na in ty' escapes scope *) + -> let (nal,c) = factorize_lambda_pattern tenv (add_name na env) aty c + in ((loc,na)::nal,c) + | c -> ([],extern_pattern tenv env c) diff --git a/interp/constrextern.mli b/interp/constrextern.mli new file mode 100644 index 000000000..cfa00c006 --- /dev/null +++ b/interp/constrextern.mli @@ -0,0 +1,49 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* cases_pattern_expr +val extern_rawconstr : rawconstr -> constr_expr +val extern_pattern : env -> names_context -> constr_pattern -> constr_expr + +(* If [b=true] in [extern_constr b env c] then the variables in the first + level of quantification clashing with the variables in [env] are renamed *) + +val extern_constr : bool -> env -> constr -> constr_expr +val extern_ref : global_reference -> reference + +(* For debugging *) +val print_implicits : bool ref +val print_casts : bool ref +val print_arguments : bool ref +val print_evar_arguments : bool ref +val print_coercions : bool ref +val print_universes : bool ref + +val with_casts : ('a -> 'b) -> 'a -> 'b +val with_implicits : ('a -> 'b) -> 'a -> 'b +val with_arguments : ('a -> 'b) -> 'a -> 'b +val with_coercions : ('a -> 'b) -> 'a -> 'b +val with_universes : ('a -> 'b) -> 'a -> 'b diff --git a/interp/constrintern.ml b/interp/constrintern.ml new file mode 100644 index 000000000..2ce1a4db0 --- /dev/null +++ b/interp/constrintern.ml @@ -0,0 +1,653 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 1 then "s" else "" in + str "Expecting " ++ int n1 ++ str " pattern" ++ str s ++ str " but found " + ++ int n2 + +let explain_bad_explicitation_number n po = + let s = match po with + | None -> "a regular argument" + | Some p -> string_of_int p in + str "Bad explicitation number: found " ++ int n ++ + str" but was expecting " ++ str s + +let explain_internalisation_error = function + | VariableCapture id -> explain_variable_capture id + | WrongExplicitImplicit -> explain_wrong_explicit_implicit + | NegativeMetavariable -> explain_negative_metavariable + | NotAConstructor ref -> explain_not_a_constructor ref + | UnboundFixName (iscofix,id) -> explain_unbound_fix_name iscofix id + | NonLinearPattern id -> explain_non_linear_pattern id + | BadPatternsNumber (n1,n2) -> explain_bad_patterns_number n1 n2 + | BadExplicitationNumber (n,po) -> explain_bad_explicitation_number n po + +(**********************************************************************) +(* Dump of globalization (to be used by coqdoc) *) + +let add_glob loc ref = +(*i + let sp = Nametab.sp_of_global (Global.env ()) ref in + let dir,_ = repr_path sp in + let rec find_module d = + try + let qid = let dir,id = split_dirpath d in make_qualid dir id in + let _ = Nametab.locate_loaded_library qid in d + with Not_found -> find_module (dirpath_prefix d) + in + let s = string_of_dirpath (find_module dir) in + i*) + let sp = Nametab.sp_of_global None ref in + let id = let _,id = repr_path sp in string_of_id id in + let dp = string_of_dirpath (Declare.library_part ref) in + dump_string (Printf.sprintf "R%d %s.%s\n" (fst loc) dp id) + +(**********************************************************************) +(* Discriminating between bound variables and global references *) + +(* [vars1] is a set of name to avoid (used for the tactic language); + [vars2] is the set of global variables, env is the set of variables + abstracted until this point *) + +(* Is it a bound variables? *) +let intern_var (env,impls,_) (vars1,vars2) loc id = + let imps, args_scopes = + (* Is [id] bound in *) + if Idset.mem id env or List.mem id vars1 + then + try List.assoc id impls, [] + with Not_found -> [], [] + else + (* Is [id] a section variable *) + let _ = Sign.lookup_named id vars2 in + (* Car Fixpoint met les fns définies temporairement comme vars de sect *) + try + let ref = VarRef id in + implicits_of_global ref, find_arguments_scope ref + with _ -> [], [] + in RVar (loc, id), imps, args_scopes + +(* Is it a global reference or a syntactic definition? *) +let intern_qualid env vars loc qid = + try match Nametab.extended_locate qid with + | TrueGlobal ref -> + if !dump then add_glob loc ref; + RRef (loc, ref), implicits_of_global ref, find_arguments_scope ref + | SyntacticDef sp -> + (Syntax_def.search_syntactic_definition loc sp),[],[] + with Not_found -> + error_global_not_found_loc loc qid + +let intern_reference env lvar = function + | Qualid (loc, qid) -> + intern_qualid env lvar loc qid + | Ident (loc, id) -> + (* For old ast syntax compatibility *) + if (string_of_id id).[0] = '$' then RVar (loc,id),[],[] else + (* End old ast syntax compatibility *) + try intern_var env lvar loc id + with Not_found -> + try intern_qualid env lvar loc (make_short_qualid id) + with e -> + (* Extra allowance for grammars *) + if !interning_grammar then begin + if_verbose warning ("Could not globalize " ^ (string_of_id id)); + RVar (loc, id), [], [] + end + else raise e + +let apply_scope_env (ids,impls,scopes as env) = function + | [] -> env, [] + | (Some sc)::scl -> (ids,impls,sc::scopes), scl + | None::scl -> env, scl + +(**********************************************************************) +(* Cases *) + +(* Check linearity of pattern-matching *) +let rec has_duplicate = function + | [] -> None + | x::l -> if List.mem x l then (Some x) else has_duplicate l + +let loc_of_lhs lhs = + join_loc (cases_pattern_loc (List.hd lhs)) (cases_pattern_loc (list_last lhs)) + +let check_linearity lhs ids = + match has_duplicate ids with + | Some id -> + raise (InternalisationError (loc_of_lhs lhs,NonLinearPattern id)) + | None -> + () + +(* Warns if some pattern variable starts with uppercase *) +let check_uppercase loc ids = +(* A quoi ça sert ? Pour l'extraction vers ML ? Maintenant elle est externe + let is_uppercase_var v = + match (string_of_id v).[0] with 'A'..'Z' -> true | _ -> false + in + let warning_uppercase loc uplid = + let vars = h 0 (prlist_with_sep pr_coma pr_id uplid) in + let (s1,s2) = if List.length uplid = 1 then (" ","s ") else ("s "," ") in + warn (str ("the variable"^s1) ++ vars ++ + str (" start"^s2^"with an upper case letter in pattern")) in + let uplid = List.filter is_uppercase_var ids in + if uplid <> [] then warning_uppercase loc uplid +*) + () + +(* Match the number of pattern against the number of matched args *) +let check_number_of_pattern loc n l = + let p = List.length l in + if n<>p then raise (InternalisationError (loc,BadPatternsNumber (n,p))) + +(* Manage multiple aliases *) + + (* [merge_aliases] returns the sets of all aliases encountered at this + point and a substitution mapping extra aliases to the first one *) +let merge_aliases (ids,subst as aliases) id = + ids@[id], if ids=[] then subst else (id, List.hd ids)::subst + +let alias_of = function + | ([],_) -> Anonymous + | (id::_,_) -> Name id + +let message_redundant_alias (id1,id2) = + if_verbose warning + ("Alias variable "^(string_of_id id1)^" is merged with "^(string_of_id id2)) + +(* Differentiating between constructors and matching variables *) +type pattern_qualid_kind = + | ConstrPat of constructor + | VarPat of identifier + +let find_constructor ref = + let (loc,qid) = qualid_of_reference ref in + try match extended_locate qid with + | SyntacticDef sp -> + (match Syntax_def.search_syntactic_definition loc sp with + | RRef (_,(ConstructRef c as x)) -> + if !dump then add_glob loc x; + c + | _ -> + raise (InternalisationError (loc,NotAConstructor ref))) + | TrueGlobal r -> + let rec unf = function + | ConstRef cst -> + (try + let v = Environ.constant_value (Global.env()) cst in + unf (reference_of_constr v) + with + Environ.NotEvaluableConst _ | Not_found -> + raise (InternalisationError (loc,NotAConstructor ref))) + | ConstructRef c -> + if !dump then add_glob loc r; + c + | _ -> raise (InternalisationError (loc,NotAConstructor ref)) + in unf r + with Not_found -> + raise (InternalisationError (loc,NotAConstructor ref)) + +let find_pattern_variable = function + | Ident (loc,id) -> id + | Qualid (loc,_) as x -> raise (InternalisationError(loc,NotAConstructor x)) + +let maybe_constructor ref = + try ConstrPat (find_constructor ref) + with InternalisationError _ -> VarPat (find_pattern_variable ref) + +let rec intern_cases_pattern scopes aliases = function + | CPatAlias (loc, p, id) -> + let aliases' = merge_aliases aliases id in + intern_cases_pattern scopes aliases' p + | CPatCstr (loc, head, pl) -> + let c = find_constructor head in + let (idsl,pl') = + List.split (List.map (intern_cases_pattern scopes ([],[])) pl) + in + (aliases::(List.flatten idsl), PatCstr (loc,c,pl',alias_of aliases)) + | CPatNumeral (loc, n) -> + ([aliases], + Symbols.interp_numeral_as_pattern loc n (alias_of aliases) scopes) + | CPatDelimiters (_, sc, e) -> + intern_cases_pattern (sc::scopes) aliases e + | CPatAtom (loc, Some head) -> + (match maybe_constructor head with + | ConstrPat c -> + ([aliases], PatCstr (loc,c,[],alias_of aliases)) + | VarPat id -> + let aliases = merge_aliases aliases id in + ([aliases], PatVar (loc,alias_of aliases))) + | CPatAtom (loc, None) -> + ([aliases], PatVar (loc,alias_of aliases)) + +(**********************************************************************) +(* Fix and CoFix *) + +let rec intern_fix = function + | [] -> ([],[],[],[]) + | (fi, bl, c, t)::rest-> + let ni = List.length (List.flatten (List.map fst bl)) - 1 in + let (lf,ln,lc,lt) = intern_fix rest in + (fi::lf, ni::ln, + CProdN (dummy_loc, bl, c)::lc, + CLambdaN (dummy_loc, bl, t)::lt) + +let rec intern_cofix = function + | [] -> ([],[],[]) + | (fi, c, t)::rest -> + let (lf,lc,lt) = intern_cofix rest in + (fi::lf, c::lc, t::lt) + +(**********************************************************************) +(* Utilities for binders *) + +let check_capture loc ty = function + | Name id when occur_var_constr_expr id ty -> + raise (InternalisationError (loc,VariableCapture id)) + | _ -> + () + +let locate_if_isevar loc id = function + | RHole _ -> RHole (loc, AbstractionType id) + | x -> x + +(**********************************************************************) +(* Utilities for application *) + +let set_hole_implicit i = function + | RRef (loc,r) -> (loc,ImplicitArg (r,i)) + | RVar (loc,id) -> (loc,ImplicitArg (VarRef id,i)) + | _ -> anomaly "Only refs have implicits" + +(**********************************************************************) +(* Syntax extensions *) + +let coerce_to_id = function + | CRef (Ident (_,id)) -> id + | c -> + user_err_loc (constr_loc c, "subst_rawconstr", + str"This expression should be a simple identifier") + +let traverse_binder id (subst,(ids,impls,scopes as env)) = + try + let id' = coerce_to_id (List.assoc id subst) in + id', (subst,(Idset.add id' ids,impls,scopes)) + with Not_found -> + id, (List.remove_assoc id subst,env) + +let rec subst_rawconstr loc interp (subst,env as senv) = function + | AVar id -> + let a = try List.assoc id subst + with Not_found -> CRef (Ident (dummy_loc,id)) in + interp env a + | t -> + map_aconstr_with_binders_loc loc traverse_binder + (subst_rawconstr loc interp) senv t + +(**********************************************************************) +(* Main loop *) + +let internalise sigma env allow_soapp lvar c = + let rec intern (ids,impls,scopes as env) = function + | CRef ref as x -> + let (c,imp,subscopes) = intern_reference env lvar ref in + (match intern_impargs c env imp subscopes [] with + | [] -> c + | l -> RApp (constr_loc x, c, l)) + | CFix (loc, (locid,iddef), ldecl) -> + let (lf,ln,lc,lt) = intern_fix ldecl in + let n = + try + (list_index iddef lf) -1 + with Not_found -> + raise (InternalisationError (locid,UnboundFixName (false,iddef))) + in + let ids' = List.fold_right Idset.add lf ids in + let defl = Array.of_list (List.map (intern (ids',impls,scopes)) lt) in + let arityl = Array.of_list (List.map (intern env) lc) in + RRec (loc,RFix (Array.of_list ln,n), Array.of_list lf, arityl, defl) + | CCoFix (loc, (locid,iddef), ldecl) -> + let (lf,lc,lt) = intern_cofix ldecl in + let n = + try + (list_index iddef lf) -1 + with Not_found -> + raise (InternalisationError (locid,UnboundFixName (true,iddef))) + in + let ids' = List.fold_right Idset.add lf ids in + let defl = Array.of_list (List.map (intern (ids',impls,scopes)) lt) in + let arityl = Array.of_list (List.map (intern env) lc) in + RRec (loc,RCoFix n, Array.of_list lf, arityl, defl) + | CArrow (loc,c1,c2) -> + RProd (loc, Anonymous, intern env c1, intern env c2) + | CProdN (loc,[],c2) -> + intern env c2 + | CProdN (loc,(nal,ty)::bll,c2) -> + iterate_prod loc env ty (CProdN (loc, bll, c2)) nal + | CLambdaN (loc,[],c2) -> + intern env c2 + | CLambdaN (loc,(nal,ty)::bll,c2) -> + iterate_lam loc env ty (CLambdaN (loc, bll, c2)) nal + | CLetIn (loc,(_,na),c1,c2) -> + RLetIn (loc, na, intern env c1, + intern (name_fold Idset.add na ids,impls,scopes) c2) + | CNotation (loc,ntn,args) -> + subst_rawconstr loc intern (args,env) + (Symbols.interp_notation ntn scopes) + | CNumeral (loc, n) -> + Symbols.interp_numeral loc n scopes + | CDelimiters (loc, sc, e) -> + intern (ids,impls,sc::scopes) e + | CAppExpl (loc, ref, args) -> + let (f,_,args_scopes) = intern_reference env lvar ref in + RApp (loc, f, intern_args env args_scopes args) + | CApp (loc, f, args) -> + let (c, impargs, args_scopes) = + match f with + | CRef ref -> intern_reference env lvar ref + | _ -> (intern env f, [], []) + in + RApp (loc, c, intern_impargs c env impargs args_scopes args) + | CCases (loc, po, tms, eqns) -> + RCases (loc, option_app (intern env) po, + List.map (intern env) tms, + List.map (intern_eqn (List.length tms) env) eqns) + | COrderedCase (loc, tag, po, c, cl) -> + ROrderedCase (loc, tag, option_app (intern env) po, intern env c, + Array.of_list (List.map (intern env) cl)) + | CHole loc -> + RHole (loc, QuestionMark) + | CMeta (loc, n) when n >=0 or allow_soapp -> + RMeta (loc, n) + | CMeta (loc, _) -> + raise (InternalisationError (loc,NegativeMetavariable)) + | CSort (loc, s) -> + RSort(loc,s) + | CCast (loc, c1, c2) -> + RCast (loc,intern env c1,intern env c2) + + | CGrammar (loc,c,subst) -> + subst_rawconstr loc intern (subst,env) c + + | CDynamic (loc,d) -> RDynamic (loc,d) + + and intern_eqn n (ids,impls,scopes as env) (loc,lhs,rhs) = + let (idsl_substl_list,pl) = + List.split (List.map (intern_cases_pattern scopes ([],[])) lhs) in + let idsl, substl = List.split (List.flatten idsl_substl_list) in + let eqn_ids = List.flatten idsl in + let subst = List.flatten substl in + (* Linearity implies the order in ids is irrelevant *) + check_linearity lhs eqn_ids; + check_uppercase loc eqn_ids; + check_number_of_pattern loc n pl; + let rhs = replace_vars_constr_expr subst rhs in + List.iter message_redundant_alias subst; + let env_ids = List.fold_right Idset.add eqn_ids ids in + (loc, eqn_ids,pl,intern (env_ids,impls,scopes) rhs) + + and iterate_prod loc2 (ids,impls,scopes as env) ty body = function + | (loc1,na)::nal -> + if nal <> [] then check_capture loc1 ty na; + let ids' = name_fold Idset.add na ids in + let body = iterate_prod loc2 (ids',impls,scopes) ty body nal in + RProd (join_loc loc1 loc2, na, intern env ty, body) + | [] -> intern env body + + and iterate_lam loc2 (ids,impls,scopes as env) ty body = function + | (loc1,na)::nal -> + if nal <> [] then check_capture loc1 ty na; + let ids' = name_fold Idset.add na ids in + let body = iterate_lam loc2 (ids',impls,scopes) ty body nal in + let ty = locate_if_isevar loc1 na (intern env ty) in + RLambda (join_loc loc1 loc2, na, ty, body) + | [] -> intern env body + + and intern_impargs c env l subscopes args = + let rec aux n l subscopes args = + let (enva,subscopes') = apply_scope_env env subscopes in + match (l,args) with + | (imp::l', (a,Some j)::args') -> + if is_status_implicit imp & j>=n then + if j=n then + (intern enva a)::(aux (n+1) l' subscopes' args') + else + (RHole (set_hole_implicit n c))::(aux (n+1) l' subscopes' args) + else + let e = if is_status_implicit imp then Some n else None in + raise + (InternalisationError(constr_loc a,BadExplicitationNumber (j,e))) + | (imp::l',(a,None)::args') -> + if is_status_implicit imp then + (RHole (set_hole_implicit n c))::(aux (n+1) l' subscopes' args) + else + (intern enva a)::(aux (n+1) l' subscopes' args') + | ([],args) -> intern_tailargs env subscopes args + | (_::l',[]) -> + if List.for_all is_status_implicit l then + (RHole (set_hole_implicit n c))::(aux (n+1) l' subscopes args) + else [] + in + aux 1 l subscopes args + + and intern_tailargs env subscopes = function + | (a,Some _)::args' -> + raise (InternalisationError (constr_loc a, WrongExplicitImplicit)) + | (a,None)::args -> + let (enva,subscopes) = apply_scope_env env subscopes in + (intern enva a) :: (intern_tailargs env subscopes args) + | [] -> [] + + and intern_args env subscopes = function + | [] -> [] + | a::args -> + let (enva,subscopes) = apply_scope_env env subscopes in + (intern enva a) :: (intern_args env subscopes args) + + in + try + intern env c + with + InternalisationError (loc,e) -> + user_err_loc (loc,"internalize",explain_internalisation_error e) + +(**************************************************************************) +(* Functions to translate constr_expr into rawconstr *) +(**************************************************************************) + +let extract_ids env = + List.fold_right Idset.add + (Termops.ids_of_rel_context (Environ.rel_context env)) + Idset.empty + +let interp_rawconstr_gen sigma env impls allow_soapp lvar c = + internalise sigma (extract_ids env, impls, Symbols.current_scopes ()) + allow_soapp (lvar,Environ.named_context env) c + +let interp_rawconstr sigma env c = + interp_rawconstr_gen sigma env [] false [] c + +let interp_rawconstr_with_implicits sigma env impls c = + interp_rawconstr_gen sigma env impls false [] c + +(* The same as interp_rawconstr but with a list of variables which must not be + globalized *) + +let interp_rawconstr_wo_glob sigma env lvar c = + interp_rawconstr_gen sigma env [] false lvar c + +(*********************************************************************) +(* Functions to parse and interpret constructions *) + +let interp_constr sigma env c = + understand sigma env (interp_rawconstr sigma env c) + +let interp_openconstr sigma env c = + understand_gen_tcc sigma env [] [] None (interp_rawconstr sigma env c) + +let interp_casted_openconstr sigma env c typ = + understand_gen_tcc sigma env [] [] (Some typ) (interp_rawconstr sigma env c) + +let interp_type sigma env c = + understand_type sigma env (interp_rawconstr sigma env c) + +let interp_type_with_implicits sigma env impls c = + understand_type sigma env (interp_rawconstr_with_implicits sigma env impls c) + +let judgment_of_rawconstr sigma env c = + understand_judgment sigma env (interp_rawconstr sigma env c) + +let type_judgment_of_rawconstr sigma env c = + understand_type_judgment sigma env (interp_rawconstr sigma env c) + +(* To retype a list of key*constr with undefined key *) +let retype_list sigma env lst = + List.fold_right (fun (x,csr) a -> + try (x,Retyping.get_judgment_of env sigma csr)::a with + | Anomaly _ -> a) lst [] + +(* List.map (fun (x,csr) -> (x,Retyping.get_judgment_of env sigma csr)) lst*) + +(* Interprets a constr according to two lists *) +(* of instantiations (variables and metas) *) +(* Note: typ is retyped *) +let interp_constr_gen sigma env lvar lmeta c exptyp = + let c = interp_rawconstr_gen sigma env [] false (List.map fst lvar) c + and rtype lst = retype_list sigma env lst in + understand_gen sigma env (rtype lvar) (rtype lmeta) exptyp c;; + +(*Interprets a casted constr according to two lists of instantiations + (variables and metas)*) +let interp_openconstr_gen sigma env lvar lmeta c exptyp = + let c = interp_rawconstr_gen sigma env [] false (List.map fst lvar) c + and rtype lst = retype_list sigma env lst in + understand_gen_tcc sigma env (rtype lvar) (rtype lmeta) exptyp c;; + +let interp_casted_constr sigma env c typ = + understand_gen sigma env [] [] (Some typ) (interp_rawconstr sigma env c) + +(* To process patterns, we need a translation without typing at all. *) + +let rec pat_of_raw metas vars lvar = function + | RVar (_,id) -> + (try PRel (list_index (Name id) vars) + with Not_found -> + try List.assoc id lvar + with Not_found -> PVar id) + | RMeta (_,n) -> + metas := n::!metas; PMeta (Some n) + | RRef (_,r) -> + PRef r + (* Hack pour ne pas réécrire une interprétation complète des patterns*) + | RApp (_, RMeta (_,n), cl) when n<0 -> + PSoApp (- n, List.map (pat_of_raw metas vars lvar) cl) + | RApp (_,c,cl) -> + PApp (pat_of_raw metas vars lvar c, + Array.of_list (List.map (pat_of_raw metas vars lvar) cl)) + | RLambda (_,na,c1,c2) -> + PLambda (na, pat_of_raw metas vars lvar c1, + pat_of_raw metas (na::vars) lvar c2) + | RProd (_,na,c1,c2) -> + PProd (na, pat_of_raw metas vars lvar c1, + pat_of_raw metas (na::vars) lvar c2) + | RLetIn (_,na,c1,c2) -> + PLetIn (na, pat_of_raw metas vars lvar c1, + pat_of_raw metas (na::vars) lvar c2) + | RSort (_,s) -> + PSort s + | RHole _ -> + PMeta None + | RCast (_,c,t) -> + if_verbose warning "Cast not taken into account in constr pattern"; + pat_of_raw metas vars lvar c + | ROrderedCase (_,st,po,c,br) -> + PCase (st,option_app (pat_of_raw metas vars lvar) po, + pat_of_raw metas vars lvar c, + Array.map (pat_of_raw metas vars lvar) br) + | r -> + let loc = loc_of_rawconstr r in + user_err_loc (loc,"pattern_of_rawconstr", str "Not supported pattern") + +let pattern_of_rawconstr lvar c = + let metas = ref [] in + let p = pat_of_raw metas [] lvar c in + (!metas,p) + +let interp_constrpattern_gen sigma env lvar c = + let c = interp_rawconstr_gen sigma env [] true (List.map fst lvar) c in + let nlvar = List.map (fun (id,c) -> (id,pattern_of_constr c)) lvar in + pattern_of_rawconstr nlvar c + +let interp_constrpattern sigma env c = + interp_constrpattern_gen sigma env [] c + +let interp_aconstr a = + aconstr_of_rawconstr (interp_rawconstr Evd.empty (Global.env()) a) diff --git a/interp/constrintern.mli b/interp/constrintern.mli new file mode 100644 index 000000000..ce8c6f5ee --- /dev/null +++ b/interp/constrintern.mli @@ -0,0 +1,87 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* env -> constr_expr -> rawconstr +val interp_rawconstr_gen : evar_map -> env -> implicits_env -> + bool -> identifier list -> constr_expr -> rawconstr + +(*s Composing the translation with typing *) +val interp_constr : evar_map -> env -> constr_expr -> constr +val interp_casted_constr : evar_map -> env -> constr_expr -> types -> constr +val interp_type : evar_map -> env -> constr_expr -> types +val interp_openconstr : evar_map -> env -> constr_expr -> evar_map * constr +val interp_casted_openconstr : + evar_map -> env -> constr_expr -> constr -> evar_map * constr + +(* [interp_type_with_implicits] extends [interp_type] by allowing + implicits arguments in the ``rel'' part of [env]; the extra + argument associates a list of implicit positions to identifiers + declared in the rel_context of [env] *) +val interp_type_with_implicits : + evar_map -> env -> implicits_env -> constr_expr -> types + +(*s Build a judgement from *) +val judgment_of_rawconstr : evar_map -> env -> constr_expr -> unsafe_judgment +val type_judgment_of_rawconstr : + evar_map -> env -> constr_expr -> unsafe_type_judgment + +(* Interprets a constr according to two lists of instantiations (variables and + metas), possibly casting it*) +val interp_constr_gen : + evar_map -> env -> (identifier * constr) list -> + (int * constr) list -> constr_expr -> constr option -> constr + +(* Interprets a constr according to two lists of instantiations (variables and + metas), possibly casting it, and turning unresolved evar into metas*) +val interp_openconstr_gen : + evar_map -> env -> (identifier * constr) list -> + (int * constr) list -> constr_expr -> constr option -> evar_map * constr + +(* Interprets constr patterns according to a list of instantiations + (variables)*) +val interp_constrpattern_gen : + evar_map -> env -> (identifier * constr) list -> constr_expr -> + int list * constr_pattern + +val interp_constrpattern : + evar_map -> env -> constr_expr -> int list * constr_pattern + +(* Interprets into a abbreviatable constr *) +val interp_aconstr : constr_expr -> aconstr + +(* Globalization leak for Grammar *) +val for_grammar : ('a -> 'b) -> 'a -> 'b diff --git a/interp/coqlib.ml b/interp/coqlib.ml new file mode 100644 index 000000000..d06f6ac52 --- /dev/null +++ b/interp/coqlib.ml @@ -0,0 +1,285 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + anomaly ("Coqlib: cannot find "^(string_of_qualid (make_qualid dir id))) + +let constant dir s = constr_of_reference (reference dir s) + +type coq_sigma_data = { + proj1 : constr; + proj2 : constr; + elim : constr; + intro : constr; + typ : constr } + +type 'a delayed = unit -> 'a + +let build_sigma_set () = + { proj1 = constant "Specif" "projS1"; + proj2 = constant "Specif" "projS2"; + elim = constant "Specif" "sigS_rec"; + intro = constant "Specif" "existS"; + typ = constant "Specif" "sigS" } + +let build_sigma_type () = + { proj1 = constant "Specif" "projT1"; + proj2 = constant "Specif" "projT2"; + elim = constant "Specif" "sigT_rec"; + intro = constant "Specif" "existT"; + typ = constant "Specif" "sigT" } + +(* Equalities *) +type coq_leibniz_eq_data = { + eq : constr delayed; + ind : constr delayed; + rrec : constr delayed option; + rect : constr delayed option; + congr: constr delayed; + sym : constr delayed } + +let constant dir id = lazy (constant dir id) + +(* Equality on Set *) +let coq_eq_eq = constant "Logic" "eq" +let coq_eq_ind = constant "Logic" "eq_ind" +let coq_eq_rec = constant "Logic" "eq_rec" +let coq_eq_rect = constant "Logic" "eq_rect" +let coq_eq_congr = constant "Logic" "f_equal" +let coq_eq_sym = constant "Logic" "sym_eq" +let coq_f_equal2 = constant "Logic" "f_equal2" + +let build_coq_eq_data = { + eq = (fun () -> Lazy.force coq_eq_eq); + ind = (fun () -> Lazy.force coq_eq_ind); + rrec = Some (fun () -> Lazy.force coq_eq_rec); + rect = Some (fun () -> Lazy.force coq_eq_rect); + congr = (fun () -> Lazy.force coq_eq_congr); + sym = (fun () -> Lazy.force coq_eq_sym) } + +let build_coq_eq = build_coq_eq_data.eq +let build_coq_f_equal2 () = Lazy.force coq_f_equal2 + +(* Specif *) +let coq_sumbool = constant "Specif" "sumbool" + +let build_coq_sumbool () = Lazy.force coq_sumbool + +(* Equality on Type *) +let coq_eqT_eq = constant "Logic_Type" "eqT" +let coq_eqT_ind = constant "Logic_Type" "eqT_ind" +let coq_eqT_congr =constant "Logic_Type" "congr_eqT" +let coq_eqT_sym = constant "Logic_Type" "sym_eqT" + +let build_coq_eqT_data = { + eq = (fun () -> Lazy.force coq_eqT_eq); + ind = (fun () -> Lazy.force coq_eqT_ind); + rrec = None; + rect = None; + congr = (fun () -> Lazy.force coq_eqT_congr); + sym = (fun () -> Lazy.force coq_eqT_sym) } + +let build_coq_eqT = build_coq_eqT_data.eq +let build_coq_sym_eqT = build_coq_eqT_data.sym + +(* Equality on Type as a Type *) +let coq_idT_eq = constant "Logic_Type" "identityT" +let coq_idT_ind = constant "Logic_Type" "identityT_ind" +let coq_idT_rec = constant "Logic_Type" "identityT_rec" +let coq_idT_rect = constant "Logic_Type" "identityT_rect" +let coq_idT_congr = constant "Logic_Type" "congr_idT" +let coq_idT_sym = constant "Logic_Type" "sym_idT" + +let build_coq_idT_data = { + eq = (fun () -> Lazy.force coq_idT_eq); + ind = (fun () -> Lazy.force coq_idT_ind); + rrec = Some (fun () -> Lazy.force coq_idT_rec); + rect = Some (fun () -> Lazy.force coq_idT_rect); + congr = (fun () -> Lazy.force coq_idT_congr); + sym = (fun () -> Lazy.force coq_idT_sym) } + +(* Empty Type *) +let coq_EmptyT = constant "Logic_Type" "EmptyT" + +(* Unit Type and its unique inhabitant *) +let coq_UnitT = constant "Logic_Type" "UnitT" +let coq_IT = constant "Logic_Type" "IT" + +(* The False proposition *) +let coq_False = constant "Logic" "False" + +(* The True proposition and its unique proof *) +let coq_True = constant "Logic" "True" +let coq_I = constant "Logic" "I" + +(* Connectives *) +let coq_not = constant "Logic" "not" +let coq_and = constant "Logic" "and" +let coq_or = constant "Logic" "or" +let coq_ex = constant "Logic" "ex" + +(* Runtime part *) +let build_coq_EmptyT () = Lazy.force coq_EmptyT +let build_coq_UnitT () = Lazy.force coq_UnitT +let build_coq_IT () = Lazy.force coq_IT + +let build_coq_True () = Lazy.force coq_True +let build_coq_I () = Lazy.force coq_I + +let build_coq_False () = Lazy.force coq_False +let build_coq_not () = Lazy.force coq_not +let build_coq_and () = Lazy.force coq_and +let build_coq_or () = Lazy.force coq_or +let build_coq_ex () = Lazy.force coq_ex + +(****************************************************************************) +(* Patterns *) +(* This needs to have interp_constrpattern available ... +let parse_astconstr s = + try + Pcoq.parse_string Pcoq.Constr.constr_eoi s + with Stdpp.Exc_located (_ , (Stream.Failure | Stream.Error _)) -> + error "Syntax error : not a construction" + +let parse_pattern s = + Constrintern.interp_constrpattern Evd.empty (Global.env()) (parse_astconstr s) + +let coq_eq_pattern = + lazy (snd (parse_pattern "(Coq.Init.Logic.eq ?1 ?2 ?3)")) +let coq_eqT_pattern = + lazy (snd (parse_pattern "(Coq.Init.Logic_Type.eqT ?1 ?2 ?3)")) +let coq_idT_pattern = + lazy (snd (parse_pattern "(Coq.Init.Logic_Type.identityT ?1 ?2 ?3)")) +let coq_existS_pattern = + lazy (snd (parse_pattern "(Coq.Init.Specif.existS ?1 ?2 ?3 ?4)")) +let coq_existT_pattern = + lazy (snd (parse_pattern "(Coq.Init.Specif.existT ?1 ?2 ?3 ?4)")) +let coq_not_pattern = + lazy (snd (parse_pattern "(Coq.Init.Logic.not ?)")) +let coq_imp_False_pattern = + lazy (snd (parse_pattern "? -> Coq.Init.Logic.False")) +let coq_imp_False_pattern = + lazy (snd (parse_pattern "? -> Coq.Init.Logic.False")) +let coq_eqdec_partial_pattern + lazy (snd (parse_pattern "(sumbool (eq ?1 ?2 ?3) ?4)")) +let coq_eqdec_pattern + lazy (snd (parse_pattern "(x,y:?1){x=y}+{~(x=y)}")) +*) + +(* The following is less readable but does not depend on parsing *) +let coq_eq_ref = lazy (reference "Logic" "eq") +let coq_eqT_ref = lazy (reference "Logic_Type" "eqT") +let coq_idT_ref = lazy (reference "Logic_Type" "identityT") +let coq_existS_ref = lazy (reference "Specif" "existS") +let coq_existT_ref = lazy (reference "Specif" "existT") +let coq_not_ref = lazy (reference "Logic" "not") +let coq_False_ref = lazy (reference "Logic" "False") +let coq_sumbool_ref = lazy (reference "Specif" "sumbool") +let coq_sig_ref = lazy (reference "Specif" "sig") + +(* Pattern "(sig ?1 ?2)" *) +let coq_sig_pattern = + lazy (PApp (PRef (Lazy.force coq_sig_ref), + [| PMeta (Some 1); PMeta (Some 2) |])) + +(* Patterns "(eq ?1 ?2 ?3)", "(eqT ?1 ?2 ?3)" and "(idT ?1 ?2 ?3)" *) +let coq_eq_pattern_gen eq = + lazy (PApp(PRef (Lazy.force eq), Array.init 3 (fun i -> PMeta (Some (i+1))))) +let coq_eq_pattern = coq_eq_pattern_gen coq_eq_ref +let coq_eqT_pattern = coq_eq_pattern_gen coq_eqT_ref +let coq_idT_pattern = coq_eq_pattern_gen coq_idT_ref + +(* Patterns "(existS ?1 ?2 ?3 ?4)" and "(existT ?1 ?2 ?3 ?4)" *) +let coq_ex_pattern_gen ex = + lazy (PApp(PRef (Lazy.force ex), Array.init 4 (fun i -> PMeta (Some (i+1))))) +let coq_existS_pattern = coq_ex_pattern_gen coq_existS_ref +let coq_existT_pattern = coq_ex_pattern_gen coq_existT_ref + +(* Patterns "~ ?" and "? -> False" *) +let coq_not_pattern = lazy(PApp(PRef (Lazy.force coq_not_ref), [|PMeta None|])) +let imp a b = PProd (Anonymous, a, b) +let coq_imp_False_pattern = + lazy (imp (PMeta None) (PRef (Lazy.force coq_False_ref))) + +(* Pattern "(sumbool (eq ?1 ?2 ?3) ?4)" *) +let coq_eqdec_partial_pattern = + lazy + (PApp + (PRef (Lazy.force coq_sumbool_ref), + [| Lazy.force coq_eq_pattern; PMeta (Some 4) |])) + +(* The expected form of the goal for the tactic Decide Equality *) + +(* Pattern "(x,y:?1){x=y}+{~(x=y)}" *) +(* i.e. "(x,y:?1)(sumbool (eq ?1 x y) ~(eq ?1 x y))" *) +let x = Name (id_of_string "x") +let y = Name (id_of_string "y") +let coq_eqdec_pattern = + lazy + (PProd (x, PMeta (Some 1), PProd (y, PMeta (Some 1), + PApp (PRef (Lazy.force coq_sumbool_ref), + [| PApp (PRef (Lazy.force coq_eq_ref), + [| PMeta (Some 1); PRel 2; PRel 1 |]); + PApp (PRef (Lazy.force coq_not_ref), + [|PApp (PRef (Lazy.force coq_eq_ref), + [| PMeta (Some 1); PRel 2; PRel 1 |])|]) |])))) + +let build_coq_eq_pattern () = Lazy.force coq_eq_pattern +let build_coq_eqT_pattern () = Lazy.force coq_eqT_pattern +let build_coq_idT_pattern () = Lazy.force coq_idT_pattern +let build_coq_existS_pattern () = Lazy.force coq_existS_pattern +let build_coq_existT_pattern () = Lazy.force coq_existT_pattern +let build_coq_not_pattern () = Lazy.force coq_not_pattern +let build_coq_imp_False_pattern () = Lazy.force coq_imp_False_pattern +let build_coq_eqdec_partial_pattern () = Lazy.force coq_eqdec_partial_pattern +let build_coq_eqdec_pattern () = Lazy.force coq_eqdec_pattern +let build_coq_sig_pattern () = Lazy.force coq_sig_pattern diff --git a/interp/coqlib.mli b/interp/coqlib.mli new file mode 100644 index 000000000..dbe99e399 --- /dev/null +++ b/interp/coqlib.mli @@ -0,0 +1,133 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 'a + +(*s For Equality tactics *) +type coq_sigma_data = { + proj1 : constr; + proj2 : constr; + elim : constr; + intro : constr; + typ : constr } + +val build_sigma_set : unit -> coq_sigma_data +val build_sigma_type : unit -> coq_sigma_data + +type coq_leibniz_eq_data = { + eq : constr delayed; + ind : constr delayed; + rrec : constr delayed option; + rect : constr delayed option; + congr: constr delayed; + sym : constr delayed } + +val build_coq_eq_data : coq_leibniz_eq_data +val build_coq_eqT_data : coq_leibniz_eq_data +val build_coq_idT_data : coq_leibniz_eq_data + +val build_coq_f_equal2 : constr delayed +val build_coq_eqT : constr delayed +val build_coq_sym_eqT : constr delayed + +(* Empty Type *) +val build_coq_EmptyT : constr delayed + +(* Unit Type and its unique inhabitant *) +val build_coq_UnitT : constr delayed +val build_coq_IT : constr delayed + +(* Specif *) +val build_coq_sumbool : constr delayed + +(*s Connectives *) +(* The False proposition *) +val build_coq_False : constr delayed + +(* The True proposition and its unique proof *) +val build_coq_True : constr delayed +val build_coq_I : constr delayed + +(* Negation *) +val build_coq_not : constr delayed + +(* Conjunction *) +val build_coq_and : constr delayed + +(* Disjunction *) +val build_coq_or : constr delayed + +(* Existential quantifier *) +val build_coq_ex : constr delayed + +(**************************** Patterns ************************************) +(* ["(eq ?1 ?2 ?3)"] *) +val build_coq_eq_pattern : constr_pattern delayed + +(* ["(eqT ?1 ?2 ?3)"] *) +val build_coq_eqT_pattern : constr_pattern delayed + +(* ["(identityT ?1 ?2 ?3)"] *) +val build_coq_idT_pattern : constr_pattern delayed + +(* ["(existS ?1 ?2 ?3 ?4)"] *) +val build_coq_existS_pattern : constr_pattern delayed + +(* ["(existT ?1 ?2 ?3 ?4)"] *) +val build_coq_existT_pattern : constr_pattern delayed + +(* ["(not ?)"] *) +val build_coq_not_pattern : constr_pattern delayed + +(* ["? -> False"] *) +val build_coq_imp_False_pattern : constr_pattern delayed + +(* ["(sumbool (eq ?1 ?2 ?3) ?4)"] *) +val build_coq_eqdec_partial_pattern : constr_pattern delayed + +(* ["! (x,y:?1). (sumbool (eq ?1 x y) ~(eq ?1 x y))"] *) +val build_coq_eqdec_pattern : constr_pattern delayed + +(* ["(sig ?1 ?2)"] *) +val build_coq_sig_pattern : constr_pattern delayed diff --git a/interp/genarg.ml b/interp/genarg.ml new file mode 100644 index 000000000..b25908b42 --- /dev/null +++ b/interp/genarg.ml @@ -0,0 +1,185 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + List.fold_right (fun x -> f (in_gen t x)) (Obj.magic l) + | _ -> failwith "Genarg: not a list0" + +let fold_list1 f = function + | (List1ArgType t as u, l) -> + List.fold_right (fun x -> f (in_gen t x)) (Obj.magic l) + | _ -> failwith "Genarg: not a list1" + +let fold_opt f a = function + | (OptArgType t as u, l) -> + (match Obj.magic l with + | None -> a + | Some x -> f (in_gen t x)) + | _ -> failwith "Genarg: not a opt" + +let fold_pair f = function + | (PairArgType (t1,t2) as u, l) -> + let (x1,x2) = Obj.magic l in + f (in_gen t1 x1) (in_gen t2 x2) + | _ -> failwith "Genarg: not a pair" + +let app_list0 f = function + | (List0ArgType t as u, l) -> + let o = Obj.magic l in + (u, Obj.repr (List.map (fun x -> out_gen t (f (in_gen t x))) o)) + | _ -> failwith "Genarg: not a list0" + +let app_list1 f = function + | (List1ArgType t as u, l) -> + let o = Obj.magic l in + (u, Obj.repr (List.map (fun x -> out_gen t (f (in_gen t x))) o)) + | _ -> failwith "Genarg: not a list1" + +let app_opt f = function + | (OptArgType t as u, l) -> + let o = Obj.magic l in + (u, Obj.repr (option_app (fun x -> out_gen t (f (in_gen t x))) o)) + | _ -> failwith "Genarg: not an opt" + +let app_pair f1 f2 = function + | (PairArgType (t1,t2) as u, l) -> + let (o1,o2) = Obj.magic l in + let o1 = out_gen t1 (f1 (in_gen t1 o1)) in + let o2 = out_gen t2 (f2 (in_gen t2 o2)) in + (u, Obj.repr (o1,o2)) + | _ -> failwith "Genarg: not a pair" + +let or_var_app f = function + | ArgArg x -> ArgArg (f x) + | ArgVar _ as x -> x + +let smash_var_app t f g = function + | ArgArg x -> f x + | ArgVar (_,id) -> + let (u, _ as x) = g id in + if t <> u then failwith "Genarg: a variable bound to a wrong type"; + x + +let unquote x = x + +type an_arg_of_this_type = Obj.t + +let in_generic t x = (t, Obj.repr x) diff --git a/interp/genarg.mli b/interp/genarg.mli new file mode 100644 index 000000000..f1246b2cc --- /dev/null +++ b/interp/genarg.mli @@ -0,0 +1,213 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* rawtype ----> rawconstr generic_argument ----> + | + | interp + V + type <---- constr generic_argument <---- + out in + +To distinguish between the uninterpreted (raw) and the interpreted +worlds, we annotate the type generic_argument by a phantom argument +which is either constr_expr or constr (actually we add also a second +argument raw_tactic_expr and tactic, but this is only for technical +reasons, because these types are undefined at the type of compilation +of Genarg). + +Transformation for each type : +tag f raw open type cooked closed type + +BoolArgType bool bool +IntArgType int int +IntOrVarArgType int or_var int +StringArgType string (parsed w/ "") string +IdentArgType identifier identifier +PreIdentArgType string (parsed w/o "") string +RefArgType reference global_reference +ConstrArgType constr_expr constr +ConstrMayEvalArgType constr_expr may_eval constr +QuantHypArgType quantified_hypothesis quantified_hypothesis +TacticArgType raw_tactic_expr tactic +CastedOpenConstrArgType constr_expr open_constr +ConstrWithBindingsArgType constr_expr with_bindings constr with_bindings +List0ArgType of argument_type +List1ArgType of argument_type +OptArgType of argument_type +ExtraArgType of string '_a '_b +*) + +type ('a,'co,'ta) abstract_argument_type + +val rawwit_bool : (bool,'co,'ta) abstract_argument_type +val wit_bool : (bool,'co,'ta) abstract_argument_type + +val rawwit_int : (int,'co,'ta) abstract_argument_type +val wit_int : (int,'co,'ta) abstract_argument_type + +val rawwit_int_or_var : (int or_var,'co,'ta) abstract_argument_type +val wit_int_or_var : (int or_var,'co,'ta) abstract_argument_type + +val rawwit_string : (string,'co,'ta) abstract_argument_type +val wit_string : (string,'co,'ta) abstract_argument_type + +val rawwit_ident : (identifier,'co,'ta) abstract_argument_type +val wit_ident : (identifier,'co,'ta) abstract_argument_type + +val rawwit_pre_ident : (string,'co,'ta) abstract_argument_type +val wit_pre_ident : (string,'co,'ta) abstract_argument_type + +val rawwit_ref : (reference,constr_expr,'ta) abstract_argument_type +val wit_ref : (global_reference,constr,'ta) abstract_argument_type + +val rawwit_quant_hyp : (quantified_hypothesis,'co,'ta) abstract_argument_type +val wit_quant_hyp : (quantified_hypothesis,'co,'ta) abstract_argument_type + +val rawwit_sort : (rawsort,constr_expr,'ta) abstract_argument_type +val wit_sort : (sorts,constr,'ta) abstract_argument_type + +val rawwit_constr : (constr_expr,constr_expr,'ta) abstract_argument_type +val wit_constr : (constr,constr,'ta) abstract_argument_type + +val rawwit_constr_may_eval : (constr_expr may_eval,constr_expr,'ta) abstract_argument_type +val wit_constr_may_eval : (constr,constr,'ta) abstract_argument_type + +val rawwit_casted_open_constr : (open_rawconstr,constr_expr,'ta) abstract_argument_type +val wit_casted_open_constr : (open_constr,constr,'ta) abstract_argument_type + +val rawwit_constr_with_bindings : (constr_expr with_bindings,constr_expr,'ta) abstract_argument_type +val wit_constr_with_bindings : (constr with_bindings,constr,'ta) abstract_argument_type + +val rawwit_red_expr : ((constr_expr,reference or_metanum) red_expr_gen,constr_expr,'ta) abstract_argument_type +val wit_red_expr : ((constr,evaluable_global_reference) red_expr_gen,constr,'ta) abstract_argument_type + +(* TODO: transformer tactic en extra arg *) +val rawwit_tactic : ('ta,constr_expr,'ta) abstract_argument_type +val wit_tactic : ('ta,constr,'ta) abstract_argument_type + +val wit_list0 : + ('a,'co,'ta) abstract_argument_type -> ('a list,'co,'ta) abstract_argument_type + +val wit_list1 : + ('a,'co,'ta) abstract_argument_type -> ('a list,'co,'ta) abstract_argument_type + +val wit_opt : + ('a,'co,'ta) abstract_argument_type -> ('a option,'co,'ta) abstract_argument_type + +val wit_pair : + ('a,'co,'ta) abstract_argument_type -> + ('b,'co,'ta) abstract_argument_type -> + ('a * 'b,'co,'ta) abstract_argument_type + +(* 'a generic_argument = (Sigma t:type. t[constr/'a]) *) +type ('a,'b) generic_argument + +val fold_list0 : + (('a,'b) generic_argument -> 'c -> 'c) -> ('a,'b) generic_argument -> 'c -> 'c + +val fold_list1 : + (('a,'b) generic_argument -> 'c -> 'c) -> ('a,'b) generic_argument -> 'c -> 'c + +val fold_opt : + (('a,'b) generic_argument -> 'c) -> 'c -> ('a,'b) generic_argument -> 'c + +val fold_pair : + (('a,'b) generic_argument -> ('a,'b) generic_argument -> 'c) -> + ('a,'b) generic_argument -> 'c + +(* [app_list0] fails if applied to an argument not of tag [List0 t] + for some [t]; it's the responsability of the caller to ensure it *) + +val app_list0 : (('a,'b) generic_argument -> ('c,'d) generic_argument) -> +('a,'b) generic_argument -> ('c,'d) generic_argument + +val app_list1 : (('a,'b) generic_argument -> ('c,'d) generic_argument) -> +('a,'b) generic_argument -> ('c,'d) generic_argument + +val app_opt : (('a,'b) generic_argument -> ('c,'d) generic_argument) -> +('a,'b) generic_argument -> ('c,'d) generic_argument + +val app_pair : + (('a,'b) generic_argument -> ('c,'d) generic_argument) -> + (('a,'b) generic_argument -> ('c,'d) generic_argument) + -> ('a,'b) generic_argument -> ('c,'d) generic_argument + +(* Manque l'ordre supérieur, on aimerait ('co,'ta) 'a; manque aussi le + polymorphism, on aimerait que 'b et 'c restent polymorphes à l'appel + de create *) +val create_arg : string -> + ('rawa,'rawco,'rawta) abstract_argument_type + * ('a,'co,'ta) abstract_argument_type + +val exists_argtype : string -> bool + +type argument_type = + (* Basic types *) + | BoolArgType + | IntArgType + | IntOrVarArgType + | StringArgType + | PreIdentArgType + | IdentArgType + | RefArgType + (* Specific types *) + | SortArgType + | ConstrArgType + | ConstrMayEvalArgType + | QuantHypArgType + | TacticArgType + | CastedOpenConstrArgType + | ConstrWithBindingsArgType + | RedExprArgType + | List0ArgType of argument_type + | List1ArgType of argument_type + | OptArgType of argument_type + | PairArgType of argument_type * argument_type + | ExtraArgType of string + +val genarg_tag : ('a,'b) generic_argument -> argument_type + +val unquote : ('a,'co,'ta) abstract_argument_type -> argument_type + +(* We'd like + + [in_generic: !b:type, !a:argument_type -> (f a) -> b generic_argument] + + with f a = b if a is Constr, f a = c if a is Tactic, otherwise f a = |a| + + in_generic is not typable; we replace the second argument by an absurd + type (with no introduction rule) +*) +type an_arg_of_this_type + +val in_generic : + argument_type -> an_arg_of_this_type -> ('a,'b) generic_argument + +val in_gen : + ('a,'co,'ta) abstract_argument_type -> 'a -> ('co,'ta) generic_argument +val out_gen : + ('a,'co,'ta) abstract_argument_type -> ('co,'ta) generic_argument -> 'a + diff --git a/interp/modintern.ml b/interp/modintern.ml new file mode 100644 index 000000000..8a0c8e545 --- /dev/null +++ b/interp/modintern.ml @@ -0,0 +1,103 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* mp + | h::tl -> make_mp (MPdot(mp, label_of_id h)) tl + +(* +(* Since module components are not put in the nametab we try to locate +the module prefix *) +exception BadRef + +let lookup_qualid (modtype:bool) qid = + let rec make_mp mp = function + [] -> mp + | h::tl -> make_mp (MPdot(mp, label_of_id h)) tl + in + let rec find_module_prefix dir n = + if n<0 then raise Not_found; + let dir',dir'' = list_chop n dir in + let id',dir''' = + match dir'' with + | hd::tl -> hd,tl + | _ -> anomaly "This list should not be empty!" + in + let qid' = make_qualid dir' id' in + try + match Nametab.locate qid' with + | ModRef mp -> mp,dir''' + | _ -> raise BadRef + with + Not_found -> find_module_prefix dir (pred n) + in + try Nametab.locate qid + with Not_found -> + let (dir,id) = repr_qualid qid in + let pref_mp,dir' = find_module_prefix dir (List.length dir - 1) in + let mp = + List.fold_left (fun mp id -> MPdot (mp, label_of_id id)) pref_mp dir' + in + if modtype then + ModTypeRef (make_ln mp (label_of_id id)) + else + ModRef (MPdot (mp,label_of_id id)) + +*) + +(* Search for the head of [qid] in [binders]. + If found, returns the module_path/kernel_name created from the dirpath + and the basename. Searches Nametab otherwise. +*) + +let lookup_module (loc,qid) = + try + Nametab.locate_module qid + with + | Not_found -> Modops.error_not_a_module_loc loc (string_of_qualid qid) + +let lookup_modtype (loc,qid) = + try + Nametab.locate_modtype qid + with + | Not_found -> + Modops.error_not_a_modtype_loc loc (string_of_qualid qid) + +let transl_with_decl env = function + | CWith_Module (id,qid) -> + With_Module (id,lookup_module qid) + | CWith_Definition (id,c) -> + With_Definition (id,interp_constr Evd.empty env c) + +let rec interp_modtype env = function + | CMTEident qid -> + MTEident (lookup_modtype qid) + | CMTEwith (mty,decl) -> + let mty = interp_modtype env mty in + let decl = transl_with_decl env decl in + MTEwith(mty,decl) + + +let rec interp_modexpr env = function + | CMEident qid -> + MEident (lookup_module qid) + | CMEapply (me1,me2) -> + let me1 = interp_modexpr env me1 in + let me2 = interp_modexpr env me2 in + MEapply(me1,me2) + diff --git a/interp/modintern.mli b/interp/modintern.mli new file mode 100644 index 000000000..2f9935674 --- /dev/null +++ b/interp/modintern.mli @@ -0,0 +1,24 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* module_type_ast -> module_type_entry + +val interp_modexpr : env -> module_ast -> module_expr + diff --git a/interp/ppextend.ml b/interp/ppextend.ml new file mode 100644 index 000000000..e2e60dc15 --- /dev/null +++ b/interp/ppextend.ml @@ -0,0 +1,57 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* h n + | PpHOVB n -> hov n + | PpHVB n -> hv n + | PpVB n -> v n + | PpTB -> t + +let ppcmd_of_cut = function + | PpTab -> tab () + | PpFnl -> fnl () + | PpBrk(n1,n2) -> brk(n1,n2) + | PpTbrk(n1,n2) -> tbrk(n1,n2) + +type unparsing = + | UnpMetaVar of identifier * tolerability + | UnpTerminal of string + | UnpBox of ppbox * unparsing list + | UnpCut of ppcut diff --git a/interp/ppextend.mli b/interp/ppextend.mli new file mode 100644 index 000000000..890422de8 --- /dev/null +++ b/interp/ppextend.mli @@ -0,0 +1,47 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* std_ppcmds -> std_ppcmds + +val ppcmd_of_cut : ppcut -> std_ppcmds + +type unparsing = + | UnpMetaVar of identifier * tolerability + | UnpTerminal of string + | UnpBox of ppbox * unparsing list + | UnpCut of ppcut diff --git a/interp/symbols.ml b/interp/symbols.ml new file mode 100644 index 000000000..c6eff9ab9 --- /dev/null +++ b/interp/symbols.ml @@ -0,0 +1,331 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* symbol_interpretation *) +let scope_map = ref Stringmap.empty + +let empty_scope = { + notations = Stringmap.empty; + delimiters = None +} + +let default_scope = "core_scope" + +let _ = Stringmap.add default_scope empty_scope !scope_map + +let scope_stack = ref [default_scope] + +let current_scopes () = !scope_stack + +(* TODO: push nat_scope, z_scope, ... in scopes summary *) + +(**********************************************************************) +(* Interpreting numbers (not in summary because functional objects) *) + +type numeral_interpreter_name = string +type numeral_interpreter = + (loc -> bigint -> rawconstr) + * (loc -> bigint -> name -> cases_pattern) option + +let numeral_interpreter_tab = + (Hashtbl.create 17 : (numeral_interpreter_name,numeral_interpreter)Hashtbl.t) + +let declare_numeral_interpreter sc t = + Hashtbl.add numeral_interpreter_tab sc t + +let lookup_numeral_interpreter s = + try + Hashtbl.find numeral_interpreter_tab s + with Not_found -> + error ("No interpretation for numerals in scope "^s) + +(* For loading without opening *) +let declare_scope scope = + try let _ = Stringmap.find scope !scope_map in () + with Not_found -> +(* Options.if_verbose message ("Creating scope "^scope);*) + scope_map := Stringmap.add scope empty_scope !scope_map + +let find_scope scope = + try Stringmap.find scope !scope_map + with Not_found -> error ("Scope "^scope^" is not declared") + +let check_scope sc = let _ = find_scope sc in () + +let declare_delimiters scope dlm = + let sc = find_scope scope in + if sc.delimiters <> None && Options.is_verbose () then + warning ("Overwriting previous delimiters in "^scope); + let sc = { sc with delimiters = Some dlm } in + scope_map := Stringmap.add scope sc !scope_map + +(* The mapping between notations and production *) + +let declare_notation nt scope (c,prec as info) = + let sc = find_scope scope in + if Stringmap.mem nt sc.notations && Options.is_verbose () then + warning ("Notation "^nt^" is already used in scope "^scope); + let sc = { sc with notations = Stringmap.add nt info sc.notations } in + scope_map := Stringmap.add scope sc !scope_map + +let rec find_interpretation f = function + | scope::scopes -> + (try f (find_scope scope) + with Not_found -> find_interpretation f scopes) + | [] -> raise Not_found + +let rec interp_notation ntn scopes = + let f scope = fst (Stringmap.find ntn scope.notations) in + try find_interpretation f scopes + with Not_found -> anomaly ("Unknown interpretation for notation "^ntn) + +let find_notation_with_delimiters scope = + match (Stringmap.find scope !scope_map).delimiters with + | Some dlm -> Some (Some dlm) + | None -> None + +let rec find_notation_without_delimiters ntn_scope ntn = function + | scope::scopes -> + (* Is the expected printer attached to the most recently open scope? *) + if scope = ntn_scope then + Some None + else + (* If the most recently open scope has a printer for this pattern + but not the expected one then we need delimiters *) + if Stringmap.mem ntn (Stringmap.find scope !scope_map).notations then + find_notation_with_delimiters ntn_scope + else + find_notation_without_delimiters ntn_scope ntn scopes + | [] -> + find_notation_with_delimiters ntn_scope + +let find_notation ntn_scope ntn scopes = + match + find_notation_without_delimiters ntn_scope ntn scopes + with + | None -> None + | Some None -> Some (None,scopes) + | Some x -> Some (x,ntn_scope::scopes) + +let exists_notation_in_scope scope prec ntn r = + try Stringmap.find ntn (Stringmap.find scope !scope_map).notations = (r,prec) + with Not_found -> false + +let exists_notation_prec prec nt sc = + try snd (Stringmap.find nt sc.notations) = prec with Not_found -> false + +let exists_notation prec nt = + Stringmap.fold (fun scn sc b -> b or exists_notation_prec prec nt sc) + !scope_map false + +(* We have to print delimiters; look for the more recent defined one *) +(* Do we need to print delimiters? To know it, we look for a numeral *) +(* printer available in the current stack of scopes *) +let find_numeral_with_delimiters scope = + match (Stringmap.find scope !scope_map).delimiters with + | Some dlm -> Some (Some dlm) + | None -> None + +let rec find_numeral_without_delimiters printer_scope = function + | scope :: scopes -> + (* Is the expected printer attached to the most recently open scope? *) + if scope = printer_scope then + Some None + else + (* If the most recently open scope has a printer for numerals + but not the expected one then we need delimiters *) + if not (Hashtbl.mem numeral_interpreter_tab scope) then + find_numeral_without_delimiters printer_scope scopes + else + find_numeral_with_delimiters printer_scope + | [] -> + (* Can we switch to [scope]? Yes if it has defined delimiters *) + find_numeral_with_delimiters printer_scope + +let find_numeral_printer printer_scope scopes = + match + find_numeral_without_delimiters printer_scope scopes + with + | None -> None + | Some None -> Some (None,scopes) + | Some x -> Some (x,printer_scope::scopes) + +(* This is the map associating the scope a numeral printer belongs to *) +(* +let numeral_printer_map = ref (Stringmap.empty : scope_name Stringmap.t) +*) + +let rec interp_numeral loc n = function + | scope :: scopes -> + (try fst (lookup_numeral_interpreter scope) loc n + with Not_found -> interp_numeral loc n scopes) + | [] -> + user_err_loc (loc,"interp_numeral", + str "No interpretation for numeral " ++ pr_bigint n) + +let rec interp_numeral_as_pattern loc n name = function + | scope :: scopes -> + (try + match snd (lookup_numeral_interpreter scope) with + | None -> raise Not_found + | Some g -> g loc n name + with Not_found -> interp_numeral_as_pattern loc n name scopes) + | [] -> + user_err_loc (loc,"interp_numeral_as_pattern", + str "No interpretation for numeral " ++ pr_bigint n) + +(* Exportation of scopes *) +let cache_scope (_,sc) = + check_scope sc; + scope_stack := sc :: !scope_stack + +let subst_scope (_,subst,sc) = sc + +open Libobject + +let (inScope,outScope) = + declare_object {(default_object "SCOPE") with + cache_function = cache_scope; + open_function = (fun i o -> if i=1 then cache_scope o); + subst_function = subst_scope; + classify_function = (fun (_,o) -> Substitute o); + export_function = (fun x -> Some x) } + +let open_scope sc = Lib.add_anonymous_leaf (inScope sc) + + +(* Special scopes associated to arguments of a global reference *) + +open Libnames + +module RefOrdered = + struct + type t = global_reference + let compare = Pervasives.compare + end + +module Refmap = Map.Make(RefOrdered) + +let arguments_scope = ref Refmap.empty + +let cache_arguments_scope (_,(r,scl)) = + List.iter (option_iter check_scope) scl; + arguments_scope := Refmap.add r scl !arguments_scope + +let subst_arguments_scope (_,subst,(r,scl)) = (subst_global subst r,scl) + +let (inArgumentsScope,outArgumentsScope) = + declare_object {(default_object "ARGUMENTS-SCOPE") with + cache_function = cache_arguments_scope; + open_function = (fun i o -> if i=1 then cache_arguments_scope o); + subst_function = subst_arguments_scope; + classify_function = (fun (_,o) -> Substitute o); + export_function = (fun x -> Some x) } + +let declare_arguments_scope r scl = + Lib.add_anonymous_leaf (inArgumentsScope (r,scl)) + +let find_arguments_scope r = + try Refmap.find r !arguments_scope + with Not_found -> [] + +(* Printing *) + +let pr_delimiters = function + | None -> str "No delimiters" + | Some (l,r) -> str "Delimiters are " ++ str l ++ str " and " ++ str r + +let pr_notation prraw ntn r = + str ntn ++ str " stands for " ++ prraw r + +let pr_named_scope prraw scope sc = + str "Scope " ++ str scope ++ fnl () + ++ pr_delimiters sc.delimiters ++ fnl () + ++ Stringmap.fold + (fun ntn (r,_) strm -> pr_notation prraw ntn r ++ fnl () ++ strm) + sc.notations (mt ()) + +let pr_scope prraw scope = pr_named_scope prraw scope (find_scope scope) + +let pr_scopes prraw = + Stringmap.fold + (fun scope sc strm -> pr_named_scope prraw scope sc ++ fnl () ++ strm) + !scope_map (mt ()) + +(* Synchronisation with reset *) + +let freeze () = (!scope_map, !scope_stack, !arguments_scope) + +let unfreeze (scm,scs,asc) = + scope_map := scm; + scope_stack := scs; + arguments_scope := asc + +let init () = () +(* + scope_map := Strinmap.empty; + scope_stack := Stringmap.empty +*) + +let _ = + declare_summary "symbols" + { freeze_function = freeze; + unfreeze_function = unfreeze; + init_function = init; + survive_section = false } + + +let printing_rules = + ref (Stringmap.empty : (unparsing list * precedence) Stringmap.t) + +let declare_printing_rule ntn unpl = + printing_rules := Stringmap.add ntn unpl !printing_rules + +let find_notation_printing_rule ntn = + try Stringmap.find ntn !printing_rules + with Not_found -> anomaly ("No printing rule found for "^ntn) diff --git a/interp/symbols.mli b/interp/symbols.mli new file mode 100644 index 000000000..3c082b2ce --- /dev/null +++ b/interp/symbols.mli @@ -0,0 +1,77 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* bigint -> rawconstr) + * (loc -> bigint -> name -> cases_pattern) option + +(* A scope is a set of interpreters for symbols + optional + interpreter and printers for integers + optional delimiters *) + +type level = precedence * precedence list +type delimiters = string * string +type scope +type scopes = scope_name list + +val default_scope : scope_name +val current_scopes : unit -> scopes +val open_scope : scope_name -> unit +val declare_scope : scope_name -> unit + +(* Declare delimiters for printing *) +val declare_delimiters : scope_name -> delimiters -> unit + +(* Declare, interpret, and look for a printer for numeral *) +val declare_numeral_interpreter : + numeral_interpreter_name -> numeral_interpreter -> unit +val interp_numeral : loc -> bigint -> scopes -> rawconstr +val interp_numeral_as_pattern : loc -> bigint -> name -> scopes ->cases_pattern +val find_numeral_printer : string -> scopes -> + (delimiters option * scopes) option + +(* Declare, interpret, and look for a printer for symbolic notations *) +val declare_notation : notation -> scope_name -> aconstr * level -> unit +val interp_notation : notation -> scopes -> aconstr +val find_notation : scope_name -> notation -> scopes -> + (delimiters option * scopes) option +val exists_notation_in_scope : + scope_name -> level -> notation -> aconstr -> bool +val exists_notation : level -> notation -> bool + +(* Declare and look for scopes associated to arguments of a global ref *) +open Libnames +val declare_arguments_scope: global_reference -> scope_name option list -> unit +val find_arguments_scope : global_reference -> scope_name option list + +(* Printing scopes *) +val pr_scope : (aconstr -> std_ppcmds) -> scope_name -> std_ppcmds +val pr_scopes : (aconstr -> std_ppcmds) -> std_ppcmds + + +val declare_printing_rule : notation -> unparsing list * precedence -> unit +val find_notation_printing_rule : notation -> unparsing list * precedence + diff --git a/interp/syntax_def.ml b/interp/syntax_def.ml new file mode 100644 index 000000000..a49352da3 --- /dev/null +++ b/interp/syntax_def.ml @@ -0,0 +1,72 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* !syntax_table); + Summary.unfreeze_function = (fun ft -> syntax_table := ft); + Summary.init_function = (fun () -> syntax_table := KNmap.empty); + Summary.survive_section = false } + +let add_syntax_constant kn c = + syntax_table := KNmap.add kn c !syntax_table + +let cache_syntax_constant ((sp,kn),c) = + if Nametab.exists_cci sp then + errorlabstrm "cache_syntax_constant" + (pr_id (basename sp) ++ str " already exists"); + add_syntax_constant kn c; + Nametab.push_syntactic_definition (Nametab.Until 1) sp kn + +let load_syntax_constant i ((sp,kn),c) = + if Nametab.exists_cci sp then + errorlabstrm "cache_syntax_constant" + (pr_id (basename sp) ++ str " already exists"); + add_syntax_constant kn c; + Nametab.push_syntactic_definition (Nametab.Until i) sp kn + +let open_syntax_constant i ((sp,kn),c) = + Nametab.push_syntactic_definition (Nametab.Exactly i) sp kn + +let subst_syntax_constant ((sp,kn),subst,c) = + subst_aconstr subst c + +let classify_syntax_constant (_,c) = Substitute c + +let (in_syntax_constant, out_syntax_constant) = + declare_object {(default_object "SYNTAXCONSTANT") with + cache_function = cache_syntax_constant; + load_function = load_syntax_constant; + open_function = open_syntax_constant; + subst_function = subst_syntax_constant; + classify_function = classify_syntax_constant; + export_function = (fun x -> Some x) } + +let declare_syntactic_definition id c = + let _ = add_leaf id (in_syntax_constant c) in () + +let rec set_loc loc _ a = + map_aconstr_with_binders_loc loc (fun id e -> (id,e)) (set_loc loc) () a + +let search_syntactic_definition loc kn = + set_loc loc () (KNmap.find kn !syntax_table) diff --git a/interp/syntax_def.mli b/interp/syntax_def.mli new file mode 100644 index 000000000..f4600d8db --- /dev/null +++ b/interp/syntax_def.mli @@ -0,0 +1,23 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* aconstr -> unit + +val search_syntactic_definition : loc -> kernel_name -> rawconstr + + diff --git a/interp/topconstr.ml b/interp/topconstr.ml new file mode 100644 index 000000000..8569c414b --- /dev/null +++ b/interp/topconstr.ml @@ -0,0 +1,300 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* let (id, e) = f id e in (Name id, e) + | Anonymous -> Anonymous, e + +let map_aconstr_with_binders_loc loc g f e = function + | AVar (id) -> RVar (loc,id) + | AApp (a,args) -> RApp (loc,f e a, List.map (f e) args) + | ALambda (na,ty,c) -> + let na,e = name_app g e na in RLambda (loc,na,f e ty,f e c) + | AProd (na,ty,c) -> + let na,e = name_app g e na in RProd (loc,na,f e ty,f e c) + | ALetIn (na,b,c) -> + let na,e = name_app g e na in RLetIn (loc,na,f e b,f e c) + | AOldCase (b,tyopt,tm,bv) -> + ROrderedCase (loc,b,option_app (f e) tyopt,f e tm,Array.map (f e) bv) + | ACast (c,t) -> RCast (loc,f e c,f e t) + | ASort x -> RSort (loc,x) + | AHole x -> RHole (loc,x) + | AMeta n -> RMeta (loc,n) + | ARef x -> RRef (loc,x) + +let rec subst_aconstr subst raw = + match raw with + | ARef ref -> + let ref' = subst_global subst ref in + if ref' == ref then raw else + ARef ref' + + | AVar _ -> raw + + | AApp (r,rl) -> + let r' = subst_aconstr subst r + and rl' = list_smartmap (subst_aconstr subst) rl in + if r' == r && rl' == rl then raw else + AApp(r',rl') + + | ALambda (n,r1,r2) -> + let r1' = subst_aconstr subst r1 and r2' = subst_aconstr subst r2 in + if r1' == r1 && r2' == r2 then raw else + ALambda (n,r1',r2') + + | AProd (n,r1,r2) -> + let r1' = subst_aconstr subst r1 and r2' = subst_aconstr subst r2 in + if r1' == r1 && r2' == r2 then raw else + AProd (n,r1',r2') + + | ALetIn (n,r1,r2) -> + let r1' = subst_aconstr subst r1 and r2' = subst_aconstr subst r2 in + if r1' == r1 && r2' == r2 then raw else + ALetIn (n,r1',r2') + + | AOldCase (b,ro,r,ra) -> + let ro' = option_smartmap (subst_aconstr subst) ro + and r' = subst_aconstr subst r + and ra' = array_smartmap (subst_aconstr subst) ra in + if ro' == ro && r' == r && ra' == ra then raw else + AOldCase (b,ro',r',ra') + + | AMeta _ | ASort _ -> raw + + | AHole (ImplicitArg (ref,i)) -> + let ref' = subst_global subst ref in + if ref' == ref then raw else + AHole (ImplicitArg (ref',i)) + | AHole ( (AbstractionType _ | QuestionMark | CasesType | + InternalHole | TomatchTypeParameter _)) -> raw + + | ACast (r1,r2) -> + let r1' = subst_aconstr subst r1 and r2' = subst_aconstr subst r2 in + if r1' == r1 && r2' == r2 then raw else + ACast (r1',r2') + +let rec aux = function + | RVar (_,id) -> AVar id + | RApp (_,g,args) -> AApp (aux g, List.map aux args) + | RLambda (_,na,ty,c) -> ALambda (na,aux ty,aux c) + | RProd (_,na,ty,c) -> AProd (na,aux ty,aux c) + | RLetIn (_,na,b,c) -> ALetIn (na,aux b,aux c) + | ROrderedCase (_,b,tyopt,tm,bv) -> + AOldCase (b,option_app aux tyopt,aux tm, Array.map aux bv) + | RCast (_,c,t) -> ACast (aux c,aux t) + | RSort (_,s) -> ASort s + | RHole (_,w) -> AHole w + | RRef (_,r) -> ARef r + | RMeta (_,n) -> AMeta n + | RDynamic _ | RRec _ | RCases _ | REvar _ -> + error "Fixpoints, cofixpoints, existential variables and pattern-matching not \ +allowed in abbreviatable expressions" + +let aconstr_of_rawconstr = aux + +(*s Concrete syntax for terms *) + +type scope_name = string + +type notation = string + +type explicitation = int + +type cases_pattern_expr = + | CPatAlias of loc * cases_pattern_expr * identifier + | CPatCstr of loc * reference * cases_pattern_expr list + | CPatAtom of loc * reference option + | CPatNumeral of loc * Bignat.bigint + | CPatDelimiters of loc * scope_name * cases_pattern_expr + +type constr_expr = + | CRef of reference + | CFix of loc * identifier located * fixpoint_expr list + | CCoFix of loc * identifier located * cofixpoint_expr list + | CArrow of loc * constr_expr * constr_expr + | CProdN of loc * (name located list * constr_expr) list * constr_expr + | CLambdaN of loc * (name located list * constr_expr) list * constr_expr + | CLetIn of loc * name located * constr_expr * constr_expr + | CAppExpl of loc * reference * constr_expr list + | CApp of loc * constr_expr * (constr_expr * explicitation option) list + | CCases of loc * constr_expr option * constr_expr list * + (loc * cases_pattern_expr list * constr_expr) list + | COrderedCase of loc * case_style * constr_expr option * constr_expr + * constr_expr list + | CHole of loc + | CMeta of loc * int + | CSort of loc * rawsort + | CCast of loc * constr_expr * constr_expr + | CNotation of loc * notation * (identifier * constr_expr) list + | CGrammar of loc * aconstr * (identifier * constr_expr) list + | CNumeral of loc * Bignat.bigint + | CDelimiters of loc * scope_name * constr_expr + | CDynamic of loc * Dyn.t + +and fixpoint_binder = name located list * constr_expr + +and fixpoint_expr = identifier * fixpoint_binder list * constr_expr * constr_expr + +and cofixpoint_expr = identifier * constr_expr * constr_expr + +let constr_loc = function + | CRef (Ident (loc,_)) -> loc + | CRef (Qualid (loc,_)) -> loc + | CFix (loc,_,_) -> loc + | CCoFix (loc,_,_) -> loc + | CArrow (loc,_,_) -> loc + | CProdN (loc,_,_) -> loc + | CLambdaN (loc,_,_) -> loc + | CLetIn (loc,_,_,_) -> loc + | CAppExpl (loc,_,_) -> loc + | CApp (loc,_,_) -> loc + | CCases (loc,_,_,_) -> loc + | COrderedCase (loc,_,_,_,_) -> loc + | CHole loc -> loc + | CMeta (loc,_) -> loc + | CSort (loc,_) -> loc + | CCast (loc,_,_) -> loc + | CNotation (loc,_,_) -> loc + | CGrammar (loc,_,_) -> loc + | CNumeral (loc,_) -> loc + | CDelimiters (loc,_,_) -> loc + | CDynamic _ -> dummy_loc + +let cases_pattern_loc = function + | CPatAlias (loc,_,_) -> loc + | CPatCstr (loc,_,_) -> loc + | CPatAtom (loc,_) -> loc + | CPatNumeral (loc,_) -> loc + | CPatDelimiters (loc,_,_) -> loc + +let replace_vars_constr_expr l t = + if l = [] then t else failwith "replace_constr_expr: TODO" + +let occur_var_constr_ref id = function + | Ident (loc,id') -> id = id' + | Qualid _ -> false + +let rec occur_var_constr_expr id = function + | CRef r -> occur_var_constr_ref id r + | CArrow (loc,a,b) -> occur_var_constr_expr id a or occur_var_constr_expr id b + | CAppExpl (loc,r,l) -> + occur_var_constr_ref id r or List.exists (occur_var_constr_expr id) l + | CApp (loc,f,l) -> + occur_var_constr_expr id f or + List.exists (fun (a,_) -> occur_var_constr_expr id a) l + | CProdN (_,l,b) -> occur_var_binders id b l + | CLambdaN (_,l,b) -> occur_var_binders id b l + | CLetIn (_,na,a,b) -> occur_var_binders id b [[na],a] + | CCast (loc,a,b) -> occur_var_constr_expr id a or occur_var_constr_expr id b + | CNotation (_,_,l) -> List.exists (fun (_,x) -> occur_var_constr_expr id x) l + | CGrammar (loc,_,l) -> List.exists (fun (_,x) -> occur_var_constr_expr id x)l + | CDelimiters (loc,_,a) -> occur_var_constr_expr id a + | CHole _ | CMeta _ | CSort _ | CNumeral _ | CDynamic _ -> false + | CCases (loc,_,_,_) + | COrderedCase (loc,_,_,_,_) + | CFix (loc,_,_) + | CCoFix (loc,_,_) -> + Pp.warning "Capture check in multiple binders not done"; false + +and occur_var_binders id b = function + | (idl,a)::l -> + occur_var_constr_expr id a or + (not (List.mem (Name id) (snd (List.split idl))) + & occur_var_binders id b l) + | [] -> occur_var_constr_expr id b + +let mkIdentC id = CRef (Ident (dummy_loc, id)) +let mkRefC r = CRef r +let mkAppC (f,l) = CApp (dummy_loc, f, List.map (fun x -> (x,None)) l) +let mkCastC (a,b) = CCast (dummy_loc,a,b) +let mkLambdaC (idl,a,b) = CLambdaN (dummy_loc,[idl,a],b) +let mkLetInC (id,a,b) = CLetIn (dummy_loc,id,a,b) +let mkProdC (idl,a,b) = CProdN (dummy_loc,[idl,a],b) + +(* Used in correctness and interface *) + +let map_binders f g e bl = + (* TODO: avoid variable capture in [t] by some [na] in [List.tl nal] *) + let h (nal,t) (e,bl) = + (List.fold_right (fun (_,na) -> name_fold g na) nal e,(nal,f e t)::bl) in + List.fold_right h bl (e,[]) + +let map_constr_expr_with_binders f g e = function + | CArrow (loc,a,b) -> CArrow (loc,f e a,f e b) + | CAppExpl (loc,r,l) -> CAppExpl (loc,r,List.map (f e) l) + | CApp (loc,a,l) -> CApp (loc,f e a,List.map (fun (a,i) -> (f e a,i)) l) + | CProdN (loc,bl,b) -> + let (e,bl) = map_binders f g e bl in CProdN (loc,bl,f e b) + | CLambdaN (loc,bl,b) -> + let (e,bl) = map_binders f g e bl in CLambdaN (loc,bl,f e b) + | CLetIn (loc,na,a,b) -> CLetIn (loc,na,f e a,f (name_fold g (snd na) e) b) + | CCast (loc,a,b) -> CCast (loc,f e a,f e b) + | CNotation (loc,n,l) -> CNotation (loc,n,List.map (fun (x,t) ->(x,f e t)) l) + | CGrammar (loc,r,l) -> CGrammar (loc,r,List.map (fun (x,t) ->(x,f e t)) l) + | CDelimiters (loc,s,a) -> CDelimiters (loc,s,f e a) + | CHole _ | CMeta _ | CSort _ | CNumeral _ | CDynamic _ | CRef _ as x -> x + | CCases (loc,po,a,bl) -> + (* TODO: apply g on the binding variables in pat... *) + (* hard because no syntactic diff between a constructor and a var *) + let bl = List.map (fun (loc,pat,rhs) -> (loc,pat,f e rhs)) bl in + CCases (loc,option_app (f e) po,List.map (f e) a,bl) + | COrderedCase (loc,s,po,a,bl) -> + COrderedCase (loc,s,option_app (f e) po,f e a,List.map (f e) bl) + | CFix (loc,id,dl) -> + let k (id,bl,t,d) = + let (e,bl) = map_binders f g e bl in (id,bl,f e t,f e d) in + CFix (loc,id,List.map k dl) + | CCoFix (loc,id,dl) -> + CCoFix (loc,id,List.map (fun (id,t,d) -> (id,f e t,f e d)) dl) + +(* For binders parsing *) + +type local_binder = + | LocalRawDef of name located * constr_expr + | LocalRawAssum of name located list * constr_expr + +(* Concrete syntax for modules and modules types *) + +type with_declaration_ast = + | CWith_Module of identifier * qualid located + | CWith_Definition of identifier * constr_expr + +type module_type_ast = + | CMTEident of qualid located + | CMTEwith of module_type_ast * with_declaration_ast + +type module_ast = + | CMEident of qualid located + | CMEapply of module_ast * module_ast diff --git a/interp/topconstr.mli b/interp/topconstr.mli new file mode 100644 index 000000000..72845f896 --- /dev/null +++ b/interp/topconstr.mli @@ -0,0 +1,133 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + (identifier -> 'a -> identifier * 'a) -> + ('a -> aconstr -> rawconstr) -> 'a -> aconstr -> rawconstr + +val subst_aconstr : Names.substitution -> aconstr -> aconstr + +val aconstr_of_rawconstr : rawconstr -> aconstr + +(*s Concrete syntax for terms *) + +type scope_name = string + +type notation = string + +type explicitation = int + +type cases_pattern_expr = + | CPatAlias of loc * cases_pattern_expr * identifier + | CPatCstr of loc * reference * cases_pattern_expr list + | CPatAtom of loc * reference option + | CPatNumeral of loc * Bignat.bigint + | CPatDelimiters of loc * scope_name * cases_pattern_expr + +type constr_expr = + | CRef of reference + | CFix of loc * identifier located * fixpoint_expr list + | CCoFix of loc * identifier located * cofixpoint_expr list + | CArrow of loc * constr_expr * constr_expr + | CProdN of loc * (name located list * constr_expr) list * constr_expr + | CLambdaN of loc * (name located list * constr_expr) list * constr_expr + | CLetIn of loc * name located * constr_expr * constr_expr + | CAppExpl of loc * reference * constr_expr list + | CApp of loc * constr_expr * (constr_expr * explicitation option) list + | CCases of loc * constr_expr option * constr_expr list * + (loc * cases_pattern_expr list * constr_expr) list + | COrderedCase of loc * case_style * constr_expr option * constr_expr + * constr_expr list + | CHole of loc + | CMeta of loc * int + | CSort of loc * rawsort + | CCast of loc * constr_expr * constr_expr + | CNotation of loc * notation * (identifier * constr_expr) list + | CGrammar of loc * aconstr * (identifier * constr_expr) list + | CNumeral of loc * Bignat.bigint + | CDelimiters of loc * scope_name * constr_expr + | CDynamic of loc * Dyn.t + +and fixpoint_binder = name located list * constr_expr + +and fixpoint_expr = identifier * fixpoint_binder list * constr_expr * constr_expr + +and cofixpoint_expr = identifier * constr_expr * constr_expr + +val constr_loc : constr_expr -> loc + +val cases_pattern_loc : cases_pattern_expr -> loc + +val replace_vars_constr_expr : + (identifier * identifier) list -> constr_expr -> constr_expr + +val occur_var_constr_expr : identifier -> constr_expr -> bool + +val mkIdentC : identifier -> constr_expr +val mkRefC : reference -> constr_expr +val mkAppC : constr_expr * constr_expr list -> constr_expr +val mkCastC : constr_expr * constr_expr -> constr_expr +val mkLambdaC : name located list * constr_expr * constr_expr -> constr_expr +val mkLetInC : name located * constr_expr * constr_expr -> constr_expr +val mkProdC : name located list * constr_expr * constr_expr -> constr_expr + +(* Used in correctness and interface; absence of var capture not guaranteed *) +(* in pattern-matching clauses and in binders of the form [x,y:T(x)] *) + +val map_constr_expr_with_binders : + ('a -> constr_expr -> constr_expr) -> + (identifier -> 'a -> 'a) -> 'a -> constr_expr -> constr_expr + +(* For binders parsing *) + +type local_binder = + | LocalRawDef of name located * constr_expr + | LocalRawAssum of name located list * constr_expr + +(* Concrete syntax for modules and modules types *) + +type with_declaration_ast = + | CWith_Module of identifier * qualid located + | CWith_Definition of identifier * constr_expr + +type module_type_ast = + | CMTEident of qualid located + | CMTEwith of module_type_ast * with_declaration_ast + +type module_ast = + | CMEident of qualid located + | CMEapply of module_ast * module_ast diff --git a/kernel/closure.ml b/kernel/closure.ml index 078f46b8d..c3b828a39 100644 --- a/kernel/closure.ml +++ b/kernel/closure.ml @@ -52,10 +52,6 @@ let with_stats c = end else Lazy.force c -type evaluable_global_reference = - | EvalVarRef of identifier - | EvalConstRef of constant - type transparent_state = Idpred.t * KNpred.t let all_opaque = (Idpred.empty, KNpred.empty) diff --git a/kernel/closure.mli b/kernel/closure.mli index d3c5e5c59..4442e49f9 100644 --- a/kernel/closure.mli +++ b/kernel/closure.mli @@ -22,10 +22,6 @@ val share : bool ref val with_stats: 'a Lazy.t -> 'a -type evaluable_global_reference = - | EvalVarRef of identifier - | EvalConstRef of kernel_name - (*s Delta implies all consts (both global (= by [kernel_name]) and local (= by [Rel] or [Var])), all evars, and letin's. Rem: reduction of a Rel/Var bound to a term is Delta, but reduction of diff --git a/kernel/modops.ml b/kernel/modops.ml index 758bf2159..a75f2d483 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -10,6 +10,7 @@ (*i*) open Util +open Pp open Names open Univ open Term @@ -51,11 +52,13 @@ let error_no_module_to_end _ = let error_no_modtype_to_end _ = error "No open module type to end" -let error_not_a_modtype s = - error ("\""^s^"\" is not a module type") +let error_not_a_modtype_loc loc s = + user_err_loc (loc,"",str ("\""^s^"\" is not a module type")) -let error_not_a_module s = - error ("\""^s^"\" is not a module") +let error_not_a_module_loc loc s = + user_err_loc (loc,"",str ("\""^s^"\" is not a module")) + +let error_not_a_module s = error_not_a_module_loc dummy_loc s let error_not_a_constant l = error ("\""^(string_of_label l)^"\" is not a constant") diff --git a/kernel/modops.mli b/kernel/modops.mli index 68f8ea38a..e865159c5 100644 --- a/kernel/modops.mli +++ b/kernel/modops.mli @@ -9,6 +9,7 @@ (*i $Id$ i*) (*i*) +open Util open Names open Univ open Environ @@ -80,7 +81,9 @@ val error_no_module_to_end : unit -> 'a val error_no_modtype_to_end : unit -> 'a -val error_not_a_modtype : string -> 'a +val error_not_a_modtype_loc : loc -> string -> 'a + +val error_not_a_module_loc : loc -> string -> 'a val error_not_a_module : string -> 'a diff --git a/kernel/names.ml b/kernel/names.ml index 402e321d0..c9a1aa2ae 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -260,6 +260,11 @@ let ith_constructor_of_inductive ind i = (ind,i) let inductive_of_constructor (ind,i) = ind let index_of_constructor (ind,i) = i +(* Better to have it here that in closure, since used in grammar.cma *) +type evaluable_global_reference = + | EvalVarRef of identifier + | EvalConstRef of constant + (* Hash-consing of name objects *) module Hname = Hashcons.Make( struct diff --git a/kernel/names.mli b/kernel/names.mli index d9b9ddc9c..2ecdd602d 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -157,6 +157,11 @@ val ith_constructor_of_inductive : inductive -> int -> constructor val inductive_of_constructor : constructor -> inductive val index_of_constructor : constructor -> int +(* Better to have it here that in Closure, since required in grammar.cma *) +type evaluable_global_reference = + | EvalVarRef of identifier + | EvalConstRef of constant + (* Hash-consing *) val hcons_names : unit -> (kernel_name -> kernel_name) * (dir_path -> dir_path) * diff --git a/kernel/term.ml b/kernel/term.ml index cc6404631..47bd656ae 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -22,11 +22,11 @@ type existential_key = int (* This defines Cases annotations *) type pattern_source = DefaultPat of int | RegularPat -type case_style = PrintLet | PrintIf | PrintCases +type case_style = LetStyle | IfStyle | MatchStyle | RegularStyle type case_printing = { cnames : identifier array; ind_nargs : int; (* number of real args of the inductive type *) - style : case_style option; + style : case_style; source : pattern_source array } type case_info = { ci_ind : inductive; diff --git a/kernel/term.mli b/kernel/term.mli index 6da9d1f5f..1867cc450 100644 --- a/kernel/term.mli +++ b/kernel/term.mli @@ -37,11 +37,11 @@ type existential_key = int (*s Case annotation *) type pattern_source = DefaultPat of int | RegularPat -type case_style = PrintLet | PrintIf | PrintCases +type case_style = LetStyle | IfStyle | MatchStyle | RegularStyle type case_printing = { cnames : identifier array; ind_nargs : int; (* number of real args of the inductive type *) - style : case_style option; + style : case_style; source : pattern_source array } (* the integer is the number of real args, needed for reduction *) type case_info = diff --git a/lib/bignat.ml b/lib/bignat.ml index 7859a780d..0cbd7bd54 100644 --- a/lib/bignat.ml +++ b/lib/bignat.ml @@ -8,6 +8,10 @@ (* $Id$ *) +(*i*) +open Pp +(*i*) + (* Arbitrary big natural numbers *) type bignat = int array @@ -101,3 +105,8 @@ let less_than m n = (um < un) || (um = un && lt 0) type bigint = POS of bignat | NEG of bignat + +let pr_bigint = function + | POS n -> str (to_string n) + | NEG n -> str "-" ++ str (to_string n) + diff --git a/lib/bignat.mli b/lib/bignat.mli index 173d43e4c..4d45d2ba2 100644 --- a/lib/bignat.mli +++ b/lib/bignat.mli @@ -8,6 +8,10 @@ (* $Id$ *) +(*i*) +open Pp +(*i*) + (* Arbitrary big natural numbers *) type bignat @@ -27,3 +31,5 @@ val mult_2 : bignat -> bignat val less_than : bignat -> bignat -> bool type bigint = POS of bignat | NEG of bignat + +val pr_bigint : bigint -> std_ppcmds diff --git a/lib/util.ml b/lib/util.ml index 689f12558..a8dd17e8f 100644 --- a/lib/util.ml +++ b/lib/util.ml @@ -29,6 +29,7 @@ let dummy_loc = (0,0) let anomaly_loc (loc,s,strm) = Stdpp.raise_with_loc loc (Anomaly (s,strm)) let user_err_loc (loc,s,strm) = Stdpp.raise_with_loc loc (UserError (s,strm)) let invalid_arg_loc (loc,s) = Stdpp.raise_with_loc loc (Invalid_argument s) +let join_loc (deb1,_) (_,fin2) = (deb1,fin2) (* Characters *) diff --git a/lib/util.mli b/lib/util.mli index 068ea256f..d7194e389 100644 --- a/lib/util.mli +++ b/lib/util.mli @@ -39,6 +39,7 @@ val dummy_loc : loc val anomaly_loc : loc * string * std_ppcmds -> 'a val user_err_loc : loc * string * std_ppcmds -> 'a val invalid_arg_loc : loc * string -> 'a +val join_loc : loc -> loc -> loc (*s Chars. *) diff --git a/library/declare.ml b/library/declare.ml index b67dbc6e2..504f38b82 100644 --- a/library/declare.ml +++ b/library/declare.ml @@ -108,9 +108,9 @@ let declare_variable_common id obj = (* for initial declaration *) let declare_variable id obj = - let (_,kn as oname) = declare_variable_common id obj in - !xml_declare_variable kn; - Dischargedhypsmap.set_discharged_hyps (fst oname) []; + let (sp,kn as oname) = declare_variable_common id obj in + !xml_declare_variable oname; + Dischargedhypsmap.set_discharged_hyps sp []; oname (* when coming from discharge: no xml output *) @@ -185,10 +185,10 @@ let hcons_constant_declaration = function let declare_constant id (cd,kind) = (* let cd = hcons_constant_declaration cd in *) - let (_,kn as oname) = add_leaf id (in_constant (ConstantEntry cd,kind)) in + let (sp,kn as oname) = add_leaf id (in_constant (ConstantEntry cd,kind)) in if is_implicit_args() then declare_constant_implicits kn; - Dischargedhypsmap.set_discharged_hyps (fst oname) [] ; - !xml_declare_constant kn; + Dischargedhypsmap.set_discharged_hyps sp [] ; + !xml_declare_constant oname; oname (* when coming from discharge *) @@ -285,9 +285,9 @@ let declare_inductive_common mie = (* for initial declaration *) let declare_mind mie = - let (_,kn as oname) = declare_inductive_common mie in - Dischargedhypsmap.set_discharged_hyps (fst oname) [] ; - !xml_declare_inductive kn; + let (sp,kn as oname) = declare_inductive_common mie in + Dischargedhypsmap.set_discharged_hyps sp [] ; + !xml_declare_inductive oname; oname (* when coming from discharge: no xml output *) @@ -361,13 +361,6 @@ let context_of_global_reference = function | IndRef (sp,_) -> (Global.lookup_mind sp).mind_hyps | ConstructRef ((sp,_),_) -> (Global.lookup_mind sp).mind_hyps -let reference_of_constr c = match kind_of_term c with - | 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 = fold_named_context (fun (id,_,_) sec_ids -> @@ -378,12 +371,6 @@ let last_section_hyps dir = (Environ.named_context (Global.env())) ~init:[] -let constr_of_reference = function - | VarRef id -> mkVar id - | ConstRef sp -> mkConst sp - | ConstructRef sp -> mkConstruct sp - | IndRef sp -> mkInd sp - let construct_absolute_reference sp = constr_of_reference (Nametab.absolute_reference sp) diff --git a/library/declare.mli b/library/declare.mli index 3c04ddf57..3a7849232 100644 --- a/library/declare.mli +++ b/library/declare.mli @@ -92,13 +92,6 @@ val clear_proofs : named_context -> named_context val context_of_global_reference : global_reference -> section_context -(* Turn a global reference into a construction *) -val constr_of_reference : global_reference -> constr - -(* Turn a construction denoting a global into a reference; - raise [Not_found] if not a global *) -val reference_of_constr : constr -> global_reference - val global_qualified_reference : qualid -> constr val global_absolute_reference : section_path -> constr val global_reference_in_absolute_module : dir_path -> identifier -> constr @@ -120,6 +113,6 @@ val strength_of_global : global_reference -> strength val library_part : global_reference -> dir_path (* hooks for XML output *) -val set_xml_declare_variable : (kernel_name -> unit) -> unit -val set_xml_declare_constant : (kernel_name -> unit) -> unit -val set_xml_declare_inductive : (kernel_name -> unit) -> unit +val set_xml_declare_variable : (object_name -> unit) -> unit +val set_xml_declare_constant : (object_name -> unit) -> unit +val set_xml_declare_inductive : (object_name -> unit) -> unit diff --git a/library/goptions.ml b/library/goptions.ml index 4d505b5aa..4c2d15206 100644 --- a/library/goptions.ml +++ b/library/goptions.ml @@ -177,7 +177,7 @@ let get_ref_table k = List.assoc (nickname k) !ref_table module type RefConvertArg = sig type t - val encode : qualid located -> t + val encode : reference -> t val subst : substitution -> t -> t val printer : t -> std_ppcmds val key : option_name @@ -189,7 +189,7 @@ end module RefConvert = functor (A : RefConvertArg) -> struct type t = A.t - type key = qualid located + type key = reference let table = ref_table let encode = A.encode let subst = A.subst diff --git a/library/goptions.mli b/library/goptions.mli index 28da69ea6..f19d99aaa 100644 --- a/library/goptions.mli +++ b/library/goptions.mli @@ -94,8 +94,8 @@ sig end (* The functor [MakeRefTable] declares a new table of objects of type - [A.t] practically denoted by [qualid]; the encoding function - [encode : qualid -> A.t] is typically a globalization function, + [A.t] practically denoted by [reference]; the encoding function + [encode : reference -> A.t] is typically a globalization function, possibly with some restriction checks; the function [member_message] say what to print when invoking the "Test Toto Titi foo." command; at the end [title] is the table name printed @@ -107,7 +107,7 @@ module MakeRefTable : functor (A : sig type t - val encode : qualid located -> t + val encode : reference -> t val subst : substitution -> t -> t val printer : t -> std_ppcmds val key : option_name @@ -156,9 +156,9 @@ val get_string_table : val get_ref_table : option_name -> - < add : qualid located -> unit; - remove : qualid located -> unit; - mem : qualid located -> unit; + < add : reference -> unit; + remove : reference -> unit; + mem : reference -> unit; print : unit > val set_int_option_value : option_name -> int option -> unit diff --git a/library/lib.ml b/library/lib.ml index 323ca60de..243fc1aca 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -471,12 +471,12 @@ let reset_to sp = let (after,_,_) = split_lib spf in recache_context after -let reset_name id = +let reset_name (loc,id) = let (sp,_) = try find_entry_p (fun (sp,_) -> let (_,spi) = repr_path (fst sp) in id = spi) with Not_found -> - error (string_of_id id ^ ": no such entry") + user_err_loc (loc,"reset_name",pr_id id ++ str ": no such entry") in reset_to sp diff --git a/library/lib.mli b/library/lib.mli index 56e79b661..022ddb5cd 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -9,6 +9,7 @@ (*i $Id$ i*) (*i*) +open Util open Names open Libnames open Libobject @@ -141,7 +142,7 @@ val current_prefix : unit -> module_path * dir_path (*s Backtracking (undo). *) val reset_to : object_name -> unit -val reset_name : identifier -> unit +val reset_name : identifier located -> unit (* [back n] resets to the place corresponding to the $n$-th call of [mark_end_of_command] (counting backwards) *) diff --git a/library/libnames.ml b/library/libnames.ml index 19e7d2833..79acb7231 100644 --- a/library/libnames.ml +++ b/library/libnames.ml @@ -11,6 +11,8 @@ open Pp open Util open Names +open Nameops +open Term type global_reference = | VarRef of variable @@ -30,6 +32,18 @@ let subst_global subst ref = match ref with let kn' = subst_kn subst kn in if kn==kn' then ref else ConstructRef ((kn',i),j) +let reference_of_constr c = match kind_of_term c with + | Const sp -> ConstRef sp + | Ind ind_sp -> IndRef ind_sp + | Construct cstr_cp -> ConstructRef cstr_cp + | Var id -> VarRef id + | _ -> raise Not_found + +let constr_of_reference = function + | VarRef id -> mkVar id + | ConstRef sp -> mkConst sp + | ConstructRef sp -> mkConstruct sp + | IndRef sp -> mkInd sp (**********************************************) @@ -205,3 +219,23 @@ type global_dir_reference = let kn' = subst_kernel_name subst kn in if kn==kn' then ref else ModTypeRef kn' *) + +type reference = + | Qualid of qualid located + | Ident of identifier located + +let qualid_of_reference = function + | Qualid (loc,qid) -> loc, qid + | Ident (loc,id) -> loc, make_short_qualid id + +let string_of_reference = function + | Qualid (loc,qid) -> string_of_qualid qid + | Ident (loc,id) -> string_of_id id + +let pr_reference = function + | Qualid (_,qid) -> pr_qualid qid + | Ident (_,id) -> pr_id id + +let loc_of_reference = function + | Qualid (loc,qid) -> loc + | Ident (loc,id) -> loc diff --git a/library/libnames.mli b/library/libnames.mli index 04e552f4d..e8dd2a5ff 100644 --- a/library/libnames.mli +++ b/library/libnames.mli @@ -10,7 +10,9 @@ (*i*) open Pp +open Util open Names +open Term (*i*) (*s Global reference is a kernel side type for all references together *) @@ -22,7 +24,14 @@ type global_reference = val subst_global : substitution -> global_reference -> global_reference -(* dirpaths *) +(* Turn a global reference into a construction *) +val constr_of_reference : global_reference -> constr + +(* Turn a construction denoting a global into a reference; + raise [Not_found] if not a global *) +val reference_of_constr : constr -> global_reference + +(*s Dirpaths *) val pr_dirpath : dir_path -> Pp.std_ppcmds val dirpath_of_string : string -> dir_path @@ -111,3 +120,13 @@ type global_dir_reference = | DirModule of object_prefix | DirClosedSection of dir_path (* this won't last long I hope! *) + +type reference = + | Qualid of qualid located + | Ident of identifier located + +val qualid_of_reference : reference -> qualid located +val string_of_reference : reference -> string +val pr_reference : reference -> std_ppcmds +val loc_of_reference : reference -> loc + diff --git a/library/nameops.ml b/library/nameops.ml index 0fd9ec0d1..a61ba754b 100644 --- a/library/nameops.ml +++ b/library/nameops.ml @@ -11,9 +11,6 @@ open Pp open Util open Names -open Declarations -open Environ -open Term (* Identifiers *) @@ -133,6 +130,11 @@ let out_name = function | Name id -> id | Anonymous -> anomaly "out_name: expects a defined name" +let name_fold f na a = + match na with + | Name id -> f id a + | Anonymous -> a + let next_name_away_with_default default name l = match name with | Name str -> next_ident_away str l diff --git a/library/nameops.mli b/library/nameops.mli index 591e9030d..50260d731 100644 --- a/library/nameops.mli +++ b/library/nameops.mli @@ -9,8 +9,6 @@ (* $Id$ *) open Names -open Term -open Environ (* Identifiers and names *) val pr_id : identifier -> Pp.std_ppcmds @@ -34,6 +32,7 @@ val next_name_away_with_default : val out_name : name -> identifier +val name_fold : (identifier -> 'a -> 'a) -> name -> 'a -> 'a val pr_lab : label -> Pp.std_ppcmds diff --git a/library/nametab.ml b/library/nametab.ml index e50a0e6b9..d4707ecbc 100755 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -387,7 +387,8 @@ let absolute_reference sp = let locate_in_absolute_module dir id = absolute_reference (make_path dir id) -let global (loc,qid) = +let global r = + let (loc,qid) = qualid_of_reference r in try match extended_locate qid with | TrueGlobal ref -> ref | SyntacticDef _ -> @@ -397,9 +398,6 @@ let global (loc,qid) = with Not_found -> error_global_not_found_loc loc qid - - - (* Exists functions ********************************************************) let exists_cci sp = SpTab.exists sp !the_ccitab @@ -452,12 +450,12 @@ let pr_global_env env ref = let s = string_of_qualid (shortest_qualid_of_global env ref) in (str s) -let global_inductive (loc,qid as locqid) = - match global locqid with +let global_inductive r = + match global r with | IndRef ind -> ind | ref -> - user_err_loc (loc,"global_inductive", - pr_qualid qid ++ spc () ++ str "is not an inductive type") + user_err_loc (loc_of_reference r,"global_inductive", + pr_reference r ++ spc () ++ str "is not an inductive type") (********************************************************************) @@ -500,4 +498,3 @@ let _ = Summary.unfreeze_function = unfreeze; Summary.init_function = init; Summary.survive_section = false } - diff --git a/library/nametab.mli b/library/nametab.mli index 2790e1536..d18a6c69d 100755 --- a/library/nametab.mli +++ b/library/nametab.mli @@ -85,10 +85,10 @@ val locate : qualid -> global_reference (* This function is used to transform a qualified identifier into a global reference, with a nice error message in case of failure *) -val global : qualid located -> global_reference +val global : reference -> global_reference (* The same for inductive types *) -val global_inductive : qualid located -> inductive +val global_inductive : reference -> inductive (* This locates also syntactic definitions *) val extended_locate : qualid -> extended_global_reference diff --git a/parsing/argextend.ml4 b/parsing/argextend.ml4 index 54eeca754..320774836 100644 --- a/parsing/argextend.ml4 +++ b/parsing/argextend.ml4 @@ -24,7 +24,8 @@ let rec make_rawwit loc = function | StringArgType -> <:expr< Genarg.rawwit_string >> | PreIdentArgType -> <:expr< Genarg.rawwit_pre_ident >> | IdentArgType -> <:expr< Genarg.rawwit_ident >> - | QualidArgType -> <:expr< Genarg.rawwit_qualid >> + | RefArgType -> <:expr< Genarg.rawwit_ref >> + | SortArgType -> <:expr< Genarg.rawwit_sort >> | ConstrArgType -> <:expr< Genarg.rawwit_constr >> | ConstrMayEvalArgType -> <:expr< Genarg.rawwit_constr_may_eval >> | QuantHypArgType -> <:expr< Genarg.rawwit_quant_hyp >> @@ -46,8 +47,9 @@ let rec make_wit loc = function | StringArgType -> <:expr< Genarg.wit_string >> | PreIdentArgType -> <:expr< Genarg.wit_pre_ident >> | IdentArgType -> <:expr< Genarg.wit_ident >> - | QualidArgType -> <:expr< Genarg.wit_qualid >> + | RefArgType -> <:expr< Genarg.wit_ref >> | QuantHypArgType -> <:expr< Genarg.wit_quant_hyp >> + | SortArgType -> <:expr< Genarg.wit_sort >> | ConstrArgType -> <:expr< Genarg.wit_constr >> | ConstrMayEvalArgType -> <:expr< Genarg.wit_constr_may_eval >> | TacticArgType -> <:expr< Genarg.wit_tactic >> @@ -148,9 +150,7 @@ let rec interp_entry_name loc s = | None -> None, <:expr< $lid:s$ >> in let t = match t with - | Some (GenAstType t) -> t - | Some _ -> - failwith "Only entries of generic type can be used in extension" + | Some t -> t | None -> (* Pp.warning_with Pp_control.err_ft ("Unknown primitive grammar entry: "^s);*) diff --git a/parsing/ast.ml b/parsing/ast.ml index 52a390af1..ae677979f 100755 --- a/parsing/ast.ml +++ b/parsing/ast.ml @@ -13,12 +13,11 @@ open Util open Names open Libnames open Coqast +open Topconstr open Genarg let isMeta s = String.length s <> 0 & s.[0]='$' -let dummy_loc = (0,0) - let loc = function | Node (loc,_,_) -> loc | Nvar (loc,_) -> loc @@ -31,17 +30,6 @@ let loc = function | Path (loc,_) -> loc | Dynamic (loc,_) -> loc -type entry_type = - | PureAstType - | IntAstType - | IdentAstType - | AstListType - | TacticAtomAstType - | ThmTokenAstType - | DynamicAstType - | ReferenceAstType - | GenAstType of Genarg.argument_type - (* patterns of ast *) type astpat = | Pquote of t @@ -107,19 +95,28 @@ let id_of_ast = function (* semantic actions of grammar rules *) type act = - | Act of pat + | Act of constr_expr | ActCase of act * (pat * act) list | ActCaseList of act * (pat * act) list (* values associated to variables *) +(* +type typed_ast = + | AstListNode of Coqast.t list + | PureAstNode of Coqast.t +*) type typed_ast = | AstListNode of Coqast.t list | PureAstNode of Coqast.t type ast_action_type = ETast | ETastl +type dynamic_grammar = + | ConstrNode of constr_expr + | CasesPatternNode of cases_pattern_expr + type grammar_action = - | SimpleAction of loc * typed_ast + | SimpleAction of loc * dynamic_grammar | CaseAction of loc * grammar_action * ast_action_type * (t list * grammar_action) list @@ -211,56 +208,25 @@ let rec coerce_to_var = function (loc ast,"Ast.coerce_to_var", (str"This expression should be a simple identifier")) -let coerce_to_id a = match coerce_to_var a with +let coerce_to_id_ast a = match coerce_to_var a with | Nvar (_,id) -> id | ast -> user_err_loc (loc ast,"Ast.coerce_to_id", str"This expression should be a simple identifier") -let coerce_qualid_to_id (loc,qid) = match repr_qualid qid with - | dir, id when dir = empty_dirpath -> id - | _ -> - user_err_loc (loc, "Ast.coerce_qualid_to_id", - str"This expression should be a simple identifier") +let coerce_to_id = function + | CRef (Ident (_,id)) -> id + | a -> user_err_loc + (constr_loc a,"Ast.coerce_to_id", + str"This expression should be a simple identifier") let coerce_reference_to_id = function - | RIdent (_,id) -> id - | RQualid (loc,_) -> + | Ident (_,id) -> id + | Qualid (loc,_) -> user_err_loc (loc, "Ast.coerce_reference_to_id", str"This expression should be a simple identifier") -(* This is to interpret the macro $ABSTRACT used in binders *) -(* $ABSTRACT should occur in this configuration : *) -(* ($ABSTRACT name (s1 a1 ($LIST l1)) ... (s2 an ($LIST ln)) b) *) -(* where li is id11::...::id1p1 and it produces the ast *) -(* (s1' a1 [id11]...[id1p1](... (sn' an [idn1]...[idnpn]b)...)) *) -(* where s1' is overwritten by name if s1 is $BINDER otherwise s1 *) - -let slam_ast (_,fin) id ast = - match id with - | Coqast.Nvar ((deb,_), s) -> - let name = if s = id_of_string "_" then None else Some s in - Coqast.Slam ((deb,fin), name, ast) - | Coqast.Nmeta ((deb,_), s) -> Coqast.Smetalam ((deb,fin), s, ast) - | _ -> invalid_arg "Ast.slam_ast" - -let abstract_binder_ast (_,fin as loc) name a b = - match a with - | Coqast.Node((deb,_),s,d::l) -> - let s' = if s="BINDER" then name else s in - Coqast.Node((deb,fin),s', [d; List.fold_right (slam_ast loc) l b]) - | _ -> invalid_arg "Bad usage of $ABSTRACT macro" - -let abstract_binders_ast loc name a b = - match a with - | Coqast.Node(_,"BINDERS",l) -> - List.fold_right (abstract_binder_ast loc name) l b - | _ -> invalid_arg "Bad usage of $ABSTRACT macro" - -let mkCastC(a,b) = ope("CAST",[a;b]) -let mkLambdaC(x,a,b) = ope("LAMBDA",[a;slam(Some x,b)]) -let mkLetInC(x,a,b) = ope("LETIN",[a;slam(Some x,b)]) -let mkProdC (x,a,b) = ope("PROD",[a;slam(Some x,b)]) +let coerce_global_to_id = coerce_reference_to_id (* Pattern-matching on ast *) @@ -284,8 +250,8 @@ let env_assoc sigma k (loc,v) = let env_assoc_nvars sigma (dloc,v) = match env_assoc_value dloc v sigma with - | AstListNode al -> List.map coerce_to_id al - | PureAstNode ast -> [coerce_to_id ast] + | AstListNode al -> List.map coerce_to_id_ast al + | PureAstNode ast -> [coerce_to_id_ast ast] let build_lams dloc idl ast = List.fold_right (fun id lam -> Slam(dloc,Some id,lam)) idl ast @@ -488,7 +454,9 @@ let rec pat_of_ast env ast = | Node(_,op,args) -> let (pargs, env') = patl_of_astl env args in (Pnode(op,pargs), env') - | (Path _|Num _|Id _|Str _|Nvar _) -> (Pquote (set_loc dummy_loc ast), env) +(* Compatibility with new parsing mode *) + | Nvar(loc,id) when (string_of_id id).[0] = '$' -> make_astvar env loc (string_of_id id) Tany + | (Path _|Num _|Id _|Str _ |Nvar _) -> (Pquote (set_loc dummy_loc ast), env) | Dynamic(loc,_) -> invalid_arg_loc(loc,"pat_of_ast: dynamic") @@ -505,27 +473,15 @@ and patl_of_astl env astl = type entry_env = (string * ast_action_type) list -(* -let to_pat env = function - | AstListNode al -> let p,e = patl_of_astl env al in AstListPat p, e - | PureAstNode a -> let p,e = pat_of_ast env a in PureAstPat p, e -*) - let to_pat = pat_of_ast -(* - match ast with - | Node(_,"ASTPAT",[p]) -> pat_of_ast env p - | _ -> invalid_arg_loc (loc ast,"Ast.to_pat") -*) - - (* Substitution *) (* Locations in quoted ast are wrong (they refer to the right hand side of a grammar rule). A default location dloc is used whenever we create an ast constructor. Locations in the binding list are trusted. *) +(* For old ast printer *) let rec pat_sub dloc sigma pat = match pat with | Pmeta(pv,c) -> env_assoc sigma c (dloc,pv) @@ -549,6 +505,7 @@ and patl_sub dloc sigma pl = (* Converting and checking free meta-variables *) +(* For old ast printer *) let type_of_meta env loc pv = try List.assoc pv env @@ -556,6 +513,7 @@ let type_of_meta env loc pv = user_err_loc (loc,"Ast.type_of_meta", (str"variable " ++ str pv ++ str" is unbound")) +(* For old ast printer *) let check_ast_meta env loc pv = match type_of_meta env loc pv with | ETast -> () @@ -563,6 +521,7 @@ let check_ast_meta env loc pv = user_err_loc (loc,"Ast.check_ast_meta", (str"variable " ++ str pv ++ str" is not of ast type")) +(* For old ast printer *) let rec val_of_ast env = function | Nmeta(loc,pv) -> check_ast_meta env loc pv; @@ -593,48 +552,8 @@ and vall_of_astl env = function str"variable " ++ str pv ++ str" is not a List") | ast::asttl -> Pcons (val_of_ast env ast, vall_of_astl env asttl) | [] -> Pnil -(* -let rec val_of_ast_constr env = function -(* - | ConstrEval (r,c) -> ConstrEvalPat (r,val_of_ast_constr env c) - | ConstrContext (x,c) -> ConstrContextPat (x,val_of_ast_constr env c) -*) - | ConstrTerm c -> ConstrTermPat (val_of_ast env c) -*) -(* -let rec check_pat_meta env = function - | Pquote _ -> () - | Pmeta(s,Tany) -> check_ast_meta env loc s - | Pmeta(s,_) -> anomaly "not well-formed pattern" - | Pmeta_slam(s,b) -> - let _ = type_of_meta env loc s in (* ids are coerced to id lists *) - check_pat_meta env b - | Pslam(_,b) -> check_pat_meta env b - | Pnode(op,Plmeta (locv,pv)) -> - if type_of_meta env locv pv <> ETastl then - user_err_loc (locv,"Ast.vall_of_astl", - [< 'sTR"variable "; 'sTR pv; 'sTR" is not a List" >]) - | Pnode(op,l) -> check_patlist_meta env l - -and check_patlist_meta env = function - | Plmeta (locv,pv) -> - if type_of_meta env locv pv <> ETastl then - user_err_loc (locv,"Ast.vall_of_astl", - [< 'sTR"variable "; 'sTR pv; 'sTR" is not a List" >]) - | Pcons(Pmeta(pv,Tlist),l) -> - if l = Pnil then anomaly "not well-formed pattern list"; - if type_of_meta env locv pv <> ETastl then - user_err_loc (locv,"Ast.vall_of_astl", - [< 'sTR"variable "; 'sTR pv; 'sTR" is not a List" >]) - else check_patlist_meta env l - | Pcons(p,l) -> check_pat_meta env p; check_patlist_meta env l - | Pnil -> () - -let check_typed_pat_meta env = function - | AstListPat cl -> check_patlist_meta env cl - | PureAstPat c -> check_pat_meta env c -*) +(* For old ast printer *) let rec occur_var_ast s = function | Node(_,"QUALID",_::_::_) -> false | Node(_,"QUALID",[Nvar(_,s2)]) -> s = s2 @@ -645,104 +564,9 @@ let rec occur_var_ast s = function | Id _ | Str _ | Num _ | Path _ -> false | Dynamic _ -> (* Hum... what to do here *) false -let rec replace_vars_ast l = function - | Node(loc,op,args) -> Node (loc,op, List.map (replace_vars_ast l) args) - | Nvar(loc,s) as a -> (try Nvar (loc, List.assoc s l) with Not_found -> a) - | Smetalam _ | Nmeta _ -> anomaly "replace_var: metas should not occur here" - | Slam(loc,None,body) -> Slam(loc,None,replace_vars_ast l body) - | Slam(loc,Some s,body) as a -> - if List.mem_assoc s l then a else - Slam(loc,Some s,replace_vars_ast l body) - | Id _ | Str _ | Num _ | Path _ as a -> a - | Dynamic _ as a -> (* Hum... what to do here *) a - -(* Ast with cases and metavariables *) - -let print_sig = function - | [] -> - mt () - | sigma -> - str"with constraints :" ++ brk(1,1) ++ - v 0 (prlist_with_sep pr_spc - (fun (x,v) -> str x ++ str" = " ++ hov 0 (print_val v)) - sigma) - -let case_failed loc sigma e pats = - user_err_loc - (loc,"Ast.eval_act", - str"Grammar case failure. The ast" ++ spc () ++ print_ast e ++ - spc () ++ str"does not match any of the patterns :" ++ - brk(1,1) ++ v 0 (prlist_with_sep pr_spc print_astpat pats) ++ fnl () ++ - print_sig sigma) - -let caselist_failed loc sigma el pats = - user_err_loc - (loc,"Ast.eval_act", - str"Grammar case failure. The ast list" ++ brk(1,1) ++ print_astl el ++ - spc () ++ str"does not match any of the patterns :" ++ - brk(1,1) ++ v 0 (prlist_with_sep pr_spc print_astlpat pats) ++ fnl () ++ - print_sig sigma) - -let myfst = function - | PureAstPat p, a -> p - | _ -> error "Expects a pure ast" - -let myfstl = function - | AstListPat p, a -> p - | _ -> error "Expects an ast list" - -let rec eval_act dloc sigma = function - | Act (AstListPat patl) -> AstListNode (patl_sub dloc sigma patl) - | Act (PureAstPat pat) -> PureAstNode (pat_sub dloc sigma pat) - | ActCase(e,ml) -> - (match eval_act dloc sigma e with - | (PureAstNode esub) -> - (match first_match myfst sigma esub ml with - | Some((_,a),sigma_pat) -> eval_act dloc sigma_pat a - | _ -> case_failed dloc sigma esub (List.map myfst ml)) - | _ -> grammar_type_error (dloc,"Ast.eval_act")) - | ActCaseList(e,ml) -> - (match eval_act dloc sigma e with - | AstListNode elsub -> - (match first_matchl myfstl sigma elsub ml with - | Some((_,a),sigma_pat) -> eval_act dloc sigma_pat a - | _ -> caselist_failed dloc sigma elsub (List.map myfstl ml)) - | _ -> grammar_type_error (dloc,"Ast.eval_act")) - -let val_of_typed_ast loc env = function - | ETast, PureAstNode c -> PureAstPat (val_of_ast env c) - | ETastl, AstListNode cl -> AstListPat (vall_of_astl env cl) - | (ETast|ETastl), _ -> - invalid_arg_loc (loc,"Ast.act_of_ast: ill-typed") - -(* TODO: case sur des variables uniquement -> pas de pb de conflit Ast/List *) -let rec act_of_ast vars etyp = function - | CaseAction (loc,a,atyp,cl) -> - let pa = act_of_ast vars atyp a in - (match atyp with - | ETastl -> - let acl = List.map (caselist vars etyp) cl in - ActCaseList (pa,acl) - | _ -> - let acl = List.map (case loc vars etyp) cl in - ActCase (pa,acl)) - | SimpleAction (loc,a) -> Act (val_of_typed_ast loc vars (etyp,a)) - -and case loc vars etyp = function - | [p],a -> - let (apl,penv) = pat_of_ast vars p in - let aa = act_of_ast penv etyp a in - (PureAstPat apl,aa) - | _ -> - user_err_loc - (loc, "Ast.case", str"case pattern for an ast should be a single ast") - -and caselist vars etyp (pl,a) = - let (apl,penv) = patl_of_astl vars pl in - let aa = act_of_ast penv etyp a in - (AstListPat apl,aa) -let to_act_check_vars = act_of_ast +(**********************************************************************) +(* Object substitution in modules *) let rec subst_astpat subst = function | Pquote a -> Pquote (subst_ast subst a) @@ -758,12 +582,3 @@ and subst_astpatlist subst = function let subst_pat subst = function | AstListPat pl -> AstListPat (subst_astpatlist subst pl) | PureAstPat p -> PureAstPat (subst_astpat subst p) - -let rec subst_act subst = function - | Act p -> Act (subst_pat subst p) - | ActCase (a,l) -> - ActCase (subst_act subst a, - List.map (fun (p,a) -> subst_pat subst p, subst_act subst a) l) - | ActCaseList (a,l) -> - ActCaseList (subst_act subst a, - List.map (fun (p,a) -> subst_pat subst p, subst_act subst a) l) diff --git a/parsing/ast.mli b/parsing/ast.mli index 9fd8e9cc9..1faaf78a7 100755 --- a/parsing/ast.mli +++ b/parsing/ast.mli @@ -10,19 +10,17 @@ (*i*) open Pp +open Util open Names open Libnames open Coqast +open Topconstr open Genarg (*i*) (* Abstract syntax trees. *) -val dummy_loc : Coqast.loc -val loc : Coqast.t -> Coqast.loc -(* -val vernac_loc : Coqast.vernac_ast -> Coqast.loc -*) +val loc : Coqast.t -> loc (* ast constructors with dummy location *) val ope : string * Coqast.t list -> Coqast.t @@ -34,9 +32,9 @@ val string : string -> Coqast.t val path : kernel_name -> Coqast.t val dynamic : Dyn.t -> Coqast.t -val set_loc : Coqast.loc -> Coqast.t -> Coqast.t +val set_loc : loc -> Coqast.t -> Coqast.t -val path_section : Coqast.loc -> kernel_name -> Coqast.t +val path_section : loc -> kernel_name -> Coqast.t val section_path : kernel_name -> kernel_name (* ast destructors *) @@ -45,19 +43,6 @@ val id_of_ast : Coqast.t -> string val nvar_of_ast : Coqast.t -> identifier val meta_of_ast : Coqast.t -> string -(* ast processing datatypes *) - -type entry_type = - | PureAstType - | IntAstType - | IdentAstType - | AstListType - | TacticAtomAstType - | ThmTokenAstType - | DynamicAstType - | ReferenceAstType - | GenAstType of Genarg.argument_type - (* patterns of ast *) type astpat = | Pquote of t @@ -79,7 +64,7 @@ type pat = (* semantic actions of grammar rules *) type act = - | Act of pat + | Act of constr_expr | ActCase of act * (pat * act) list | ActCaseList of act * (pat * act) list @@ -90,28 +75,21 @@ type typed_ast = type ast_action_type = ETast | ETastl +type dynamic_grammar = + | ConstrNode of constr_expr + | CasesPatternNode of cases_pattern_expr + type grammar_action = - | SimpleAction of loc * typed_ast + | SimpleAction of loc * dynamic_grammar | CaseAction of loc * grammar_action * ast_action_type * (t list * grammar_action) list type env = (string * typed_ast) list -val coerce_to_var : Coqast.t -> Coqast.t - -val coerce_to_id : Coqast.t -> identifier - -val coerce_qualid_to_id : qualid Util.located -> identifier - -val coerce_reference_to_id : reference_expr -> identifier - -val abstract_binders_ast : - Coqast.loc -> string -> Coqast.t -> Coqast.t -> Coqast.t +val coerce_to_id : constr_expr -> identifier -val mkCastC : Coqast.t * Coqast.t -> Coqast.t -val mkLambdaC : identifier * Coqast.t * Coqast.t -> Coqast.t -val mkLetInC : identifier * Coqast.t * Coqast.t -> Coqast.t -val mkProdC : identifier * Coqast.t * Coqast.t -> Coqast.t +val coerce_global_to_id : reference -> identifier +val coerce_reference_to_id : reference -> identifier exception No_match of string @@ -126,32 +104,20 @@ val print_astlpat : patlist -> std_ppcmds type entry_env = (string * ast_action_type) list -val grammar_type_error : Coqast.loc * string -> 'a +val grammar_type_error : loc * string -> 'a (* Converting and checking free meta-variables *) -val pat_sub : Coqast.loc -> env -> astpat -> Coqast.t -val val_of_ast : entry_env -> Coqast.t -> astpat -val vall_of_astl : entry_env -> Coqast.t list -> patlist - -val pat_of_ast : entry_env -> Coqast.t -> astpat * entry_env +(* For old ast printer *) +val pat_sub : loc -> env -> astpat -> Coqast.t +val val_of_ast : entry_env -> Coqast.t -> astpat val alpha_eq : Coqast.t * Coqast.t -> bool val alpha_eq_val : typed_ast * typed_ast -> bool - val occur_var_ast : identifier -> Coqast.t -> bool -val replace_vars_ast : (identifier * identifier) list -> Coqast.t -> Coqast.t - -val bind_env : env -> string -> typed_ast -> env -val ast_match : env -> astpat -> Coqast.t -> env -val astl_match : env -> patlist -> Coqast.t list -> env val find_all_matches : ('a -> astpat) -> env -> t -> 'a list -> ('a * env) list val first_matchl : ('a -> patlist) -> env -> Coqast.t list -> 'a list -> ('a * env) option - val to_pat : entry_env -> Coqast.t -> (astpat * entry_env) -val eval_act : Coqast.loc -> env -> act -> typed_ast -val to_act_check_vars : entry_env -> ast_action_type -> grammar_action -> act - +(* Object substitution in modules *) val subst_astpat : Names.substitution -> astpat -> astpat -val subst_act : Names.substitution -> act -> act diff --git a/parsing/astmod.ml b/parsing/astmod.ml deleted file mode 100644 index cbb19fa0b..000000000 --- a/parsing/astmod.ml +++ /dev/null @@ -1,133 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* mp - | h::tl -> make_mp (MPdot(mp, label_of_id h)) tl - -(* -(* Since module components are not put in the nametab we try to locate -the module prefix *) -exception BadRef - -let lookup_qualid (modtype:bool) qid = - let rec make_mp mp = function - [] -> mp - | h::tl -> make_mp (MPdot(mp, label_of_id h)) tl - in - let rec find_module_prefix dir n = - if n<0 then raise Not_found; - let dir',dir'' = list_chop n dir in - let id',dir''' = - match dir'' with - | hd::tl -> hd,tl - | _ -> anomaly "This list should not be empty!" - in - let qid' = make_qualid dir' id' in - try - match Nametab.locate qid' with - | ModRef mp -> mp,dir''' - | _ -> raise BadRef - with - Not_found -> find_module_prefix dir (pred n) - in - try Nametab.locate qid - with Not_found -> - let (dir,id) = repr_qualid qid in - let pref_mp,dir' = find_module_prefix dir (List.length dir - 1) in - let mp = - List.fold_left (fun mp id -> MPdot (mp, label_of_id id)) pref_mp dir' - in - if modtype then - ModTypeRef (make_ln mp (label_of_id id)) - else - ModRef (MPdot (mp,label_of_id id)) - -*) - -(* Search for the head of [qid] in [binders]. - If found, returns the module_path/kernel_name created from the dirpath - and the basename. Searches Nametab otherwise. -*) - -let lookup_module qid = - Nametab.locate_module qid - -let lookup_modtype qid = - Nametab.locate_modtype qid - -let transl_with_decl env = function - | Node(loc,"WITHMODULE",[id_ast;qid_ast]) -> - let id = match id_ast with - Nvar(_,id) -> id - | _ -> anomaly "Identifier AST expected" - in - let qid = match qid_ast with - | Node (loc, "QUALID", astl) -> - interp_qualid astl - | _ -> anomaly "QUALID expected" - in - With_Module (id,lookup_module qid) - | Node(loc,"WITHDEFINITION",[id_ast;cast]) -> - let id = match id_ast with - Nvar(_,id) -> id - | _ -> anomaly "Identifier AST expected" - in - let c = interp_constr Evd.empty env cast in - With_Definition (id,c) - | _ -> anomaly "Unexpected AST" - -let rec interp_modtype env = function - | Node(loc,"MODTYPEQID",qid_ast) -> begin match qid_ast with - | [Node (loc, "QUALID", astl)] -> - let qid = interp_qualid astl in begin - try - MTEident (lookup_modtype qid) - with - | Not_found -> - Modops.error_not_a_modtype (*loc*) (string_of_qualid qid) - end - | _ -> anomaly "QUALID expected" - end - | Node(loc,"MODTYPEWITH",[mty_ast;decl_ast]) -> - let mty = interp_modtype env mty_ast in - let decl = transl_with_decl env decl_ast in - MTEwith(mty,decl) - | _ -> anomaly "TODO: transl_modtype: I can handle qualid module types only" - - -let rec interp_modexpr env = function - | Node(loc,"MODEXPRQID",qid_ast) -> begin match qid_ast with - | [Node (loc, "QUALID", astl)] -> - let qid = interp_qualid astl in begin - try - MEident (lookup_module qid) - with - | Not_found -> - Modops.error_not_a_module (*loc*) (string_of_qualid qid) - end - | _ -> anomaly "QUALID expected" - end - | Node(_,"MODEXPRAPP",[ast1;ast2]) -> - let me1 = interp_modexpr env ast1 in - let me2 = interp_modexpr env ast2 in - MEapply(me1,me2) - | Node(_,"MODEXPRAPP",_) -> - anomaly "transl_modexpr: MODEXPRAPP must have two arguments" - | _ -> anomaly "transl_modexpr: I can handle MODEXPRQID or MODEXPRAPP only..." - diff --git a/parsing/astmod.mli b/parsing/astmod.mli deleted file mode 100644 index 49e061a0b..000000000 --- a/parsing/astmod.mli +++ /dev/null @@ -1,25 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Coqast.t -> module_type_entry - -val interp_modexpr : env -> Coqast.t -> module_expr - diff --git a/parsing/astterm.ml b/parsing/astterm.ml deleted file mode 100644 index bbd9b49e6..000000000 --- a/parsing/astterm.ml +++ /dev/null @@ -1,949 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* None - | x::l -> if List.mem x l then (Some x) else has_duplicate l - -let loc_of_lhs lhs = join_loc (loc (List.hd lhs)) (loc (list_last lhs)) - -let check_linearity lhs ids = - match has_duplicate ids with - | Some id -> - user_err_loc (loc_of_lhs lhs,"ast_to_eqn",non_linearl_mssg id) - | None -> () - -let mal_formed_mssg () = - (str "malformed macro of multiple case") - -(* determines if some pattern variable starts with uppercase *) -let warning_uppercase loc uplid = (* Comment afficher loc ?? *) - let vars = - prlist_with_sep - (fun () -> (str ", ")) (* We avoid spc (), else it breaks the line *) - (fun v -> (str (string_of_id v))) uplid in - let (s1,s2) = if List.length uplid = 1 then (" ","s ") else ("s "," ") in - warn (str ("the variable"^s1) ++ vars ++ - str (" start"^s2^"with an upper case letter in pattern")) - -let is_uppercase_var v = - match (string_of_id v).[0] with - 'A'..'Z' -> true - | _ -> false - -let check_uppercase loc ids = -(* A quoi ça sert ? Pour l'extraction vers ML ? Maintenant elle est externe - let uplid = List.filter is_uppercase_var ids in - if uplid <> [] then warning_uppercase loc uplid -*) - () - -(* check that the number of pattern matches the number of matched args *) -let mssg_number_of_patterns n pl = - str"Expecting " ++ int n ++ str" pattern(s) but found " ++ - int (List.length pl) ++ str" in " - -let check_number_of_pattern loc n l = - if n<>(List.length l) then - user_err_loc (loc,"check_number_of_pattern",mssg_number_of_patterns n l) - -(****************************************************************) -(* Arguments normally implicit in the "Implicit Arguments mode" *) -(* but explicitely given *) - -(* Dump of globalization (to be used by coqdoc) *) - -let add_glob loc ref = -(*i - let sp = Nametab.sp_of_global (Global.env ()) ref in - let dir,_ = repr_path sp in - let rec find_module d = - try - let qid = let dir,id = split_dirpath d in make_qualid dir id in - let _ = Nametab.locate_loaded_library qid in d - with Not_found -> find_module (dirpath_prefix d) - in - let s = string_of_dirpath (find_module dir) in - i*) - let sp = Nametab.sp_of_global None ref in - let id = let _,id = repr_path sp in string_of_id id in - let dp = string_of_dirpath (Declare.library_part ref) in - dump_string (Printf.sprintf "R%d %s.%s\n" (fst loc) dp id) - -(* Translation of references *) - -let ast_to_sp = function - | Path(loc,sp) -> - (try - section_path sp - with Invalid_argument _ | Failure _ -> - anomaly_loc(loc,"Astterm.ast_to_sp", - (str"ill-formed section-path"))) - | ast -> anomaly_loc(Ast.loc ast,"Astterm.ast_to_sp", - (str"not a section-path")) - -let is_underscore id = (id = wildcard) - -let name_of_nvar s = - if is_underscore s then Anonymous else Name s - -let ident_of_nvar loc s = - if is_underscore s then - user_err_loc (loc,"ident_of_nvar", (str "Unexpected wildcard")) - else s - -let interp_qualid p = - let outnvar = function - | Nvar (loc,s) -> s - | _ -> anomaly "interp_qualid: ill-formed qualified identifier" in - match p with - | [] -> 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 (List.rev p)) (List.hd r) - -let maybe_variable = function - | [Nvar (_,s)] -> Some s - | _ -> None - -let ids_of_ctxt ctxt = - Array.to_list - (Array.map - (function c -> match kind_of_term c with - | Var id -> id - | _ -> - error - "Astterm: arbitrary substitution of references not yet implemented") - ctxt) - -type pattern_qualid_kind = - | ConstrPat of loc * constructor - | VarPat of loc * identifier - -let may_allow_variable loc allow_var l = - match maybe_variable l with - | Some s when allow_var -> - (* Why a warning since there is no warning when writing [globname:T]... - warning ("Defined reference "^(string_of_qualid qid) - ^" is here considered as a matching variable"); - *) - VarPat (loc,s) - | _ -> - user_err_loc (loc,"maybe_constructor", - str "This reference does not denote a constructor: " ++ - str (string_of_qualid (interp_qualid l))) - -let maybe_constructor allow_var = function - | Node(loc,"QUALID",l) -> - let qid = interp_qualid l in - (try match extended_locate qid with - | SyntacticDef sp -> - (match Syntax_def.search_syntactic_definition loc sp with - | RRef (_,(ConstructRef c as x)) -> - if !dump then add_glob loc x; - ConstrPat (loc,c) - | _ -> - user_err_loc (loc,"maybe_constructor", - str "This syntactic definition should be aliased to a constructor")) - | TrueGlobal r -> - let rec unf = function - | ConstRef cst -> - (try - unf - (reference_of_constr (constant_value (Global.env()) cst)) - with - NotEvaluableConst _ | Not_found -> - may_allow_variable loc allow_var l) - | ConstructRef c -> - if !dump then add_glob loc r; - ConstrPat (loc,c) - | _ -> may_allow_variable loc allow_var l - in unf r - with Not_found -> - match maybe_variable l with - | Some s when allow_var -> 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 *) - let c = (ast_to_sp sp,ti),n in - if !dump then add_glob loc (ConstructRef c); - ConstrPat (loc,c) - - | Path(loc,kn) -> - (let dir,id = decode_kn kn in - let sp = make_path dir id in - match absolute_reference sp with - | ConstructRef c as r -> - if !dump then add_glob loc (ConstructRef c); - ConstrPat (loc,c) - | _ -> - error ("Unknown absolute constructor name: "^(string_of_path sp))) - | Node(loc,("CONST"|"SECVAR"|"EVAR"|"MUTIND"|"SYNCONST" as key), l) -> - user_err_loc (loc,"ast_to_pattern", - (str "Found a pattern involving global references which are not constructors" -)) - - | _ -> anomaly "ast_to_pattern: badly-formed ast for Cases pattern" - -let ast_to_global loc = function - | ("SYNCONST", [sp]) -> - Syntax_def.search_syntactic_definition loc (ast_to_sp sp), [], [] - | ("EVAR", [(Num (_,ev))]) -> - REvar (loc, ev), [], [] - | ast -> - let ref = match ast with - | ("CONST", [sp]) -> ConstRef (ast_to_sp sp) - | ("SECVAR", [Nvar (_,s)]) -> VarRef s - | ("MUTIND", [sp;Num(_,tyi)]) -> IndRef (ast_to_sp sp, tyi) - | ("MUTCONSTRUCT", [sp;Num(_,ti);Num(_,n)]) -> - ConstructRef ((ast_to_sp sp,ti),n) - | _ -> anomaly_loc (loc,"ast_to_global", - (str "Bad ast for this global a reference")) - in - RRef (loc, ref), implicits_of_global ref, find_arguments_scope ref - -(* -let ref_from_constr c = match kind_of_term c with - | 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" -*) - -(* [vars1] is a set of name to avoid (used for the tactic language); - [vars2] is the set of global variables, env is the set of variables - abstracted until this point *) - -let ast_to_var (env,impls,_) (vars1,vars2) loc id = - let imps, subscopes = - if Idset.mem id env or List.mem id vars1 - then - try List.assoc id impls, [] - with Not_found -> [], [] - else - let _ = lookup_named id vars2 in - (* Car Fixpoint met les fns définies tmporairement comme vars de sect *) - try - let ref = VarRef id in - implicits_of_global ref, find_arguments_scope ref - with _ -> [], [] - in RVar (loc, id), imps, subscopes - -(**********************************************************************) - -let rawconstr_of_var env vars loc id = - try - let (r,_,_) = ast_to_var env vars loc id in r - with Not_found -> - Pretype_errors.error_var_not_found_loc loc id - -let rawconstr_of_qualid_gen env vars loc qid = - (* Is it a bound variable? *) - try - match repr_qualid qid with - | 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? *) - try match Nametab.extended_locate qid with - | TrueGlobal ref -> - if !dump then add_glob loc ref; - RRef (loc, ref), implicits_of_global ref, find_arguments_scope ref - | SyntacticDef sp -> - Syntax_def.search_syntactic_definition loc sp, [], [] - with Not_found -> - error_global_not_found_loc loc qid - -let rawconstr_of_qualid env vars loc qid = - let (r,_,_) = rawconstr_of_qualid_gen env vars loc qid in r - -let mkLambdaC (x,a,b) = ope("LAMBDA",[a;slam(Some x,b)]) -let mkLambdaCit = List.fold_right (fun (x,a) b -> mkLambdaC(x,a,b)) -let mkProdC (x,a,b) = ope("PROD",[a;slam(Some x,b)]) -let mkProdCit = List.fold_right (fun (x,a) b -> mkProdC(x,a,b)) - -let destruct_binder = function - | Node(_,"BINDER",c::idl) -> List.map (fun id -> (nvar_of_ast id,c)) idl - | _ -> anomaly "BINDER is expected" - -let apply_scope_env (ids,impls,scopes as env) = function - | [] -> env, [] - | (Some sc)::scl -> (ids,impls,sc::scopes), scl - | None::scl -> env, scl - -(* [merge_aliases] returns the sets of all aliases encountered at this - point and a substitution mapping extra aliases to the first one *) -let merge_aliases (ids,subst as aliases) = function - | Anonymous -> aliases - | Name id -> - ids@[id], - if ids=[] then subst - else (id, List.hd ids)::subst - -let alias_of = function - | ([],_) -> Anonymous - | (id::_,_) -> Name id - -let message_redundant_alias (s1,s2) = - warning ("Alias variable "^(string_of_id s1) - ^" is merged with "^(string_of_id s2)) - -let rec ast_to_pattern scopes aliases = function - | Node(_,"PATTAS",[Nvar (loc,s); p]) -> - let aliases' = merge_aliases aliases (name_of_nvar s) in - ast_to_pattern scopes aliases' p - - | Node(_,"PATTCONSTRUCT", head::((_::_) as pl)) -> - (match maybe_constructor false head with - | ConstrPat (loc,c) -> - let (idsl,pl') = - List.split (List.map (ast_to_pattern scopes ([],[])) pl) in - (aliases::(List.flatten idsl), - PatCstr (loc,c,pl',alias_of aliases)) - | VarPat (loc,s) -> -(* - user_err_loc (loc,"ast_to_pattern",mssg_hd_is_not_constructor s) -*) - assert false) - | Node(_,"PATTNUMERAL", [Str(loc,n)]) -> - ([aliases], - Symbols.interp_numeral_as_pattern loc (Bignat.POS (Bignat.of_string n)) - (alias_of aliases) scopes) - - | Node(_,"PATTNEGNUMERAL", [Str(loc,n)]) -> - ([aliases], - Symbols.interp_numeral_as_pattern loc (Bignat.NEG (Bignat.of_string n)) - (alias_of aliases) scopes) - - | Node(_,"PATTDELIMITERS", [Str(_,sc);e]) -> - ast_to_pattern (sc::scopes) aliases e - - | ast -> - (match maybe_constructor true ast with - | 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))) - -let rec ast_to_fix = function - | [] -> ([],[],[],[]) - | Node(_,"NUMFDECL", [Nvar(_,fi); Num(_,ni); astA; astT])::rest -> - let (lf,ln,lA,lt) = ast_to_fix rest in - (fi::lf, (ni-1)::ln, astA::lA, astT::lt) - | Node(_,"FDECL", [Nvar(_,fi); Node(_,"BINDERS",bl); astA; astT])::rest-> - let binders = List.flatten (List.map destruct_binder bl) in - let ni = List.length binders - 1 in - let (lf,ln,lA,lt) = ast_to_fix rest in - (fi::lf, ni::ln, (mkProdCit binders astA)::lA, - (mkLambdaCit binders astT)::lt) - | _ -> anomaly "FDECL or NUMFDECL is expected" - -let rec ast_to_cofix = function - | [] -> ([],[],[]) - | Node(_,"CFDECL", [Nvar(_,fi); astA; astT])::rest -> - let (lf,lA,lt) = ast_to_cofix rest in - (fi::lf, astA::lA, astT::lt) - | _ -> anomaly "CFDECL is expected" - -let error_fixname_unbound s is_cofix loc name = - user_err_loc - (loc,"ast_to (COFIX)", - str "The name" ++ spc () ++ pr_id name ++ - spc () ++ str "is not bound in the corresponding" ++ spc () ++ - str ((if is_cofix then "co" else "")^"fixpoint definition")) -(* -let rec collapse_env n env = if n=0 then env else - add_rel_decl (Anonymous,()) (collapse_env (n-1) (snd (uncons_rel_env env))) -*) - -let check_capture loc s ty = function - | Slam _ when occur_var_ast s ty -> error_capture_loc loc s - | _ -> () - -let locate_if_isevar loc id = function - | RHole _ -> RHole (loc, AbstractionType id) - | x -> x - -let set_hole_implicit i = function - | RRef (loc,r) -> (loc,ImplicitArg (r,i)) - | RVar (loc,id) -> (loc,ImplicitArg (VarRef id,i)) - | _ -> anomaly "Only refs have implicits" - -(* -let check_only_implicits t imp = - let rec aux env n t = - match kind_of_term (whd_betadeltaiota env t) with - | Prod (x,a,b) -> (aux (push_rel (x,None,a) env) (n+1) b) - | _ -> n - in - let env = Global.env () in - imp = interval 1 (aux env 0 (get_type_of env Evd.empty t)) -*) - -let build_expression loc1 loc2 (ref,impls) args = - let rec add_args n = function - | imp::impls,args when is_status_implicit imp -> - (RHole (set_hole_implicit n (RRef (loc2,ref)))) - ::add_args (n+1) (impls,args) - | _::impls,a::args -> a::add_args (n+1) (impls,args) - | [], args -> args - | _ -> anomalylabstrm "astterm" - (str "Incorrect signature " ++ pr_global_env None ref ++ str " as an infix") in - RApp (loc1,RRef (loc2,ref),add_args 1 (impls,args)) - -let ast_to_rawconstr sigma env allow_soapp lvar = - let rec dbrec (ids,impls,scopes as env) = function - | Nvar(loc,s) -> - rawconstr_of_var env lvar loc s - - | Node(loc,"QUALID", l) -> - let (c,imp,subscopes) = - rawconstr_of_qualid_gen env lvar loc (interp_qualid l) - in - (match ast_to_impargs c env imp subscopes [] with - [] -> c - | l -> RApp (loc, c, l)) - - | Node(loc,"FIX", (Nvar (locid,iddef))::ldecl) -> - let (lf,ln,lA,lt) = ast_to_fix ldecl in - let n = - try - (list_index (ident_of_nvar locid iddef) lf) -1 - with Not_found -> - error_fixname_unbound "ast_to_rawconstr (FIX)" false locid iddef in - let ext_ids = List.fold_right Idset.add lf ids in - let defl = Array.of_list (List.map (dbrec (ext_ids,impls,scopes)) lt) in - let arityl = Array.of_list (List.map (dbrec env) lA) in - RRec (loc,RFix (Array.of_list ln,n), Array.of_list lf, arityl, defl) - - | Node(loc,"COFIX", (Nvar(locid,iddef))::ldecl) -> - let (lf,lA,lt) = ast_to_cofix ldecl in - let n = - try - (list_index (ident_of_nvar locid iddef) lf) -1 - with Not_found -> - error_fixname_unbound "ast_to_rawconstr (COFIX)" true locid iddef - in - let ext_ids = List.fold_right Idset.add lf ids in - let defl = Array.of_list (List.map (dbrec (ext_ids,impls,scopes)) lt) in - let arityl = Array.of_list (List.map (dbrec env) lA) in - RRec (loc,RCoFix n, Array.of_list lf, arityl, defl) - - | Node(loc,("PROD"|"LAMBDA"|"LETIN" as k), [c1;Slam(locna,ona,c2)]) -> - let na,ids' = match ona with - | Some id -> Name id, Idset.add id ids - | _ -> Anonymous, ids in - let c1' = dbrec env c1 and c2' = dbrec (ids',impls,scopes) c2 in - (match k with - | "PROD" -> RProd (loc, na, c1', c2') - | "LAMBDA" -> RLambda (loc, na, locate_if_isevar locna na c1', c2') - | "LETIN" -> RLetIn (loc, na, c1', c2') - | _ -> assert false) - - | Node(_,("PRODLIST"|"LAMBDALIST" as s), [c1;(Slam _ as c2)]) -> - iterated_binder s 0 c1 env c2 - - | Node(loc1,"NOTATION", Str(loc2,ntn)::args) -> - Symbols.interp_notation ntn scopes (List.map (dbrec env) args) - - | Node(_,"NUMERAL", [Str(loc,n)]) -> - Symbols.interp_numeral loc (Bignat.POS (Bignat.of_string n)) - scopes - - | Node(_,"NEGNUMERAL", [Str(loc,n)]) -> - Symbols.interp_numeral loc (Bignat.NEG (Bignat.of_string n)) - scopes - - | Node(_,"DELIMITERS", [Str(_,sc);e]) -> - dbrec (ids,impls,sc::scopes) e - - | Node(loc,"APPLISTEXPL", f::args) -> - let (f,_,subscopes) = match f with - | Node(locs,"QUALID",p) -> - rawconstr_of_qualid_gen env lvar locs (interp_qualid p) - | _ -> - (dbrec env f, [], []) in - RApp (loc,f,ast_to_args env subscopes args) - - | Node(loc,"APPLIST", f::args) -> - let (c, impargs, subscopes) = - match f with - | Node(locs,"QUALID",p) -> - rawconstr_of_qualid_gen env lvar locs (interp_qualid p) - (* For globalized references (e.g. in Infix) *) - | Node(loc, - ("CONST"|"SECVAR"|"EVAR"|"MUTIND"|"MUTCONSTRUCT"|"SYNCONST" as key), - l) -> - ast_to_global loc (key,l) - | _ -> (dbrec env f, [], []) - in - RApp (loc, c, ast_to_impargs c env impargs subscopes args) - - | Node(loc,"CASES", p:: Node(_,"TOMATCH",tms):: eqns) -> - let po = match p with - | Str(_,"SYNTH") -> None - | _ -> Some(dbrec env p) in - RCases (loc,PrintCases,po, - List.map (dbrec env) tms, - List.map (ast_to_eqn (List.length tms) env) eqns) - - | Node(loc,(("CASE"|"IF"|"LET"|"MATCH")as tag), p::c::cl) -> - let po = match p with - | Str(_,"SYNTH") -> None - | _ -> Some(dbrec env p) in - let isrec = match tag with - | "MATCH" -> true | ("LET"|"CASE"|"IF") -> false - | _ -> anomaly "ast_to: wrong tag in old case expression" in - ROldCase (loc,isrec,po,dbrec env c, - Array.of_list (List.map (dbrec env) cl)) - - | Node(loc,"ISEVAR",[]) -> RHole (loc, QuestionMark) - | Node(loc,"META",[Num(_,n)]) -> - if n<0 then error_metavar_loc loc else RMeta (loc, n) - - | Node(loc,"PROP", []) -> RSort(loc,RProp Null) - | Node(loc,"SET", []) -> RSort(loc,RProp Pos) - | Node(loc,"TYPE", _) -> RSort(loc,RType None) - - (* This case mainly parses things build in a quotation *) - | Node(loc,("CONST"|"SECVAR"|"EVAR"|"MUTIND"|"MUTCONSTRUCT"|"SYNCONST" as key),l) -> - let (r,_,_) = ast_to_global loc (key,l) in r - - | Node(loc,"CAST", [c1;c2]) -> - RCast (loc,dbrec env c1,dbrec env c2) - - | Node(loc,"SOAPP", args) when allow_soapp -> - (match List.map (dbrec env) args with - (* Hack special pour l'interprétation des constr_pattern *) - | RMeta (locn,n) :: args -> RApp (loc,RMeta (locn,- n), args) - | RHole _ :: _ -> anomaly "Metavariable for 2nd-order pattern-matching cannot be anonymous" - | _ -> anomaly "Bad arguments for second-order pattern-matching") - - | Node(loc,"SQUASH",_) -> - user_err_loc(loc,"ast_to_rawconstr", - (str "Ill-formed specification")) - - | Node(loc,opn,tl) -> - anomaly ("ast_to_rawconstr found operator "^opn^" with "^ - (string_of_int (List.length tl))^" arguments") - - | Dynamic (loc,d) -> RDynamic (loc,d) - - | _ -> anomaly "ast_to_rawconstr: unexpected ast" - - and ast_to_eqn n (ids,impls,scopes as env) = function - | Node(loc,"EQN",rhs::lhs) -> - let (idsl_substl_list,pl) = - List.split (List.map (ast_to_pattern scopes ([],[])) lhs) in - let idsl, substl = List.split (List.flatten idsl_substl_list) in - let eqn_ids = List.flatten idsl in - let subst = List.flatten substl in - (* Linearity implies the order in ids is irrelevant *) - check_linearity lhs eqn_ids; - check_uppercase loc eqn_ids; - check_number_of_pattern loc n pl; - let rhs = replace_vars_ast subst rhs in - List.iter message_redundant_alias subst; - let env_ids = List.fold_right Idset.add eqn_ids ids in - (loc, eqn_ids,pl,dbrec (env_ids,impls,scopes) rhs) - | _ -> anomaly "ast_to_rawconstr: ill-formed ast for Cases equation" - - and iterated_binder oper n ty (ids,impls,scopes as env) = function - | Slam(loc,ona,body) -> - let na,ids' = match ona with - | Some id -> - if n>0 then check_capture loc id ty body; - Name id, Idset.add id ids - | _ -> Anonymous, ids - in - let r = iterated_binder oper (n+1) ty (ids',impls,scopes) body in - (match oper with - | "PRODLIST" -> RProd(loc, na, dbrec env ty, r) - | "LAMBDALIST" -> - RLambda(loc, na, locate_if_isevar loc na (dbrec env ty), r) - | _ -> assert false) - | body -> dbrec env body - - and ast_to_impargs c env l subscopes args = - let rec aux n l subscopes args = - let (enva,subscopes') = apply_scope_env env subscopes in - match (l,args) with - | (imp::l',Node(loc, "EXPL", [Num(_,j);a])::args') -> - if is_status_implicit imp & j>=n then - if j=n then - (dbrec enva a)::(aux (n+1) l' subscopes' args') - else - (RHole (set_hole_implicit n c))::(aux (n+1) l' subscopes' args) - else - if not (is_status_implicit imp) then - error ("Bad explicitation number: found "^ - (string_of_int j)^" but was expecting a regular argument") - else - error ("Bad explicitation number: found "^ - (string_of_int j)^" but was expecting "^(string_of_int n)) - | (imp::l',a::args') -> - if is_status_implicit imp then - (RHole (set_hole_implicit n c))::(aux (n+1) l' subscopes' args) - else - (dbrec enva a)::(aux (n+1) l' subscopes' args') - | ([],args) -> ast_to_args env subscopes args - | (_::l',[]) -> - if List.for_all is_status_implicit l then - (RHole (set_hole_implicit n c))::(aux (n+1) l' subscopes args) - else [] - in - aux 1 l subscopes args - - and ast_to_args env subscopes = function - | Node(loc, "EXPL", _)::args' -> - (* To deal with errors *) - error_expl_impl_loc loc - | a::args -> - let enva, subscopes = apply_scope_env env subscopes in - (dbrec enva a) :: (ast_to_args env subscopes args) - | [] -> [] - - and interp_binding env = function - | Node(_,"BINDING", [Num(_,n);Node(loc,"CONSTR",[c])]) -> - (AnonHyp n,dbrec env c) - | Node(_,"BINDING", [Nvar(loc0,s); Node(loc1,"CONSTR",[c])]) -> - (NamedHyp (ident_of_nvar loc0 s), dbrec env c) - | x -> - errorlabstrm "bind_interp" - (str "Not the expected form in binding" ++ print_ast x) - - in - dbrec env - -(**************************************************************************) -(* Globalization of AST quotations (mainly used to get statically *) -(* bound idents in grammar or pretty-printing rules) *) -(**************************************************************************) - -let ast_of_ref_loc loc ref = set_loc loc (Termast.ast_of_ref ref) - -let ast_of_syndef loc sp = Node (loc, "SYNCONST", [path_section loc sp]) - -let ast_of_extended_ref_loc loc = function - | TrueGlobal ref -> ast_of_ref_loc loc ref - | SyntacticDef kn -> ast_of_syndef loc kn - -let ast_of_extended_ref = ast_of_extended_ref_loc dummy_loc - -let ast_of_var env ast id = - if isMeta (string_of_id id) or Idset.mem id env then ast - else raise Not_found - -let ast_hole = Node (dummy_loc, "ISEVAR", []) - -let implicits_of_extended_reference = function - | TrueGlobal ref -> implicits_of_global ref - | SyntacticDef _ -> [] - -let warning_globalize qid = - warning ("Could not globalize " ^ (string_of_qualid qid)) - -let globalize_qualid (loc,qid) = - try - let ref = Nametab.extended_locate qid in - ast_of_extended_ref_loc loc ref - with Not_found -> - if_verbose warning_globalize qid; - Termast.ast_of_qualid qid - -let adjust_qualid env loc ast qid = - (* Is it a bound variable? *) - try - match repr_qualid qid with - | 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? *) - try - let ref = Nametab.extended_locate qid in - ast_of_extended_ref_loc loc ref - with Not_found -> - if_verbose warning_globalize qid; - ast - -let ast_adjust_consts sigma = - let rec dbrec env = function - | Node(loc, ("APPLIST" as key), (Node(locs,"QUALID",p) as ast)::args) -> - let f = adjust_qualid env loc ast (interp_qualid p) in - Node(loc, key, f :: List.map (dbrec env) args) - | Nmeta (loc, s) as ast -> ast - | Nvar (loc, id) as ast -> - if Idset.mem id env then ast - else adjust_qualid env loc ast (make_short_qualid id) - | Node (loc, "QUALID", p) as ast -> - adjust_qualid env loc ast (interp_qualid p) - | Slam (loc, None, t) -> Slam (loc, None, dbrec env t) - | Slam (loc, Some na, t) -> - let env' = Idset.add na env in - Slam (loc, Some na, dbrec env' t) - | Node (loc, opn, tl) -> Node (loc, opn, List.map (dbrec env) tl) - | x -> x - - in - dbrec - -let globalize_constr ast = - let sign = Global.named_context () in - ast_adjust_consts Evd.empty (from_list (ids_of_named_context sign)) ast - -(* Globalizes ast expressing constructions in tactics or vernac *) -(* Actually, it is incomplete, see vernacinterp.ml and tacinterp.ml *) -(* Used mainly to parse Grammar and Syntax expressions *) -let rec glob_ast sigma env = - function - Node (loc, "CONSTR", [c]) -> - Node (loc, "CONSTR", [ast_adjust_consts sigma env c]) - | Node (loc, "CONSTRLIST", l) -> - Node (loc, "CONSTRLIST", List.map (ast_adjust_consts sigma env) l) - | Slam (loc, None, t) -> Slam (loc, None, glob_ast sigma env t) - | Slam (loc, Some na, t) -> - let env' = Idset.add na env in - Slam (loc, Some na, glob_ast sigma env' t) - | Node (loc, opn, tl) -> Node (loc, opn, List.map (glob_ast sigma env) tl) - | x -> x - -let globalize_ast ast = - let sign = Global.named_context () in - glob_ast Evd.empty (from_list (ids_of_named_context sign)) ast - -(**************************************************************************) -(* Functions to translate ast into rawconstr *) -(**************************************************************************) - -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, Symbols.current_scopes ()) - allow_soapp (lvar,env) com - -let interp_rawconstr sigma env com = - interp_rawconstr_gen sigma env [] false [] com - -let interp_rawconstr_with_implicits sigma env impls com = - interp_rawconstr_gen sigma env impls false [] com - -(*The same as interp_rawconstr but with a list of variables which must not be - globalized*) - -let interp_rawconstr_wo_glob sigma env lvar com = - interp_rawconstr_gen sigma env [] false lvar com - -(*********************************************************************) -(* V6 compat: Functions before in ex-trad *) - -(* Functions to parse and interpret constructions *) - -(* To embed constr in Coqast.t *) -let constrIn t = Dynamic (dummy_loc,constr_in t) -let constrOut = function - | Dynamic (_,d) -> - if (Dyn.tag d) = "constr" then - constr_out d - else - anomalylabstrm "constrOut" (str "Dynamic tag should be constr") - | ast -> - anomalylabstrm "constrOut" - (str "Not a Dynamic ast: " ++ print_ast ast) - -let interp_global_constr env (loc,qid) = - let c = - rawconstr_of_qualid (Idset.empty,[],current_scopes()) ([],env) loc qid - in - understand Evd.empty env c - -let interp_constr sigma env c = - understand sigma env (interp_rawconstr sigma env c) - -let interp_openconstr sigma env c = - understand_gen_tcc sigma env [] [] None (interp_rawconstr sigma env c) - -let interp_casted_openconstr sigma env c typ = - understand_gen_tcc sigma env [] [] (Some typ) (interp_rawconstr sigma env c) - -let interp_type sigma env c = - understand_type sigma env (interp_rawconstr sigma env c) - -let interp_type_with_implicits sigma env impls c = - understand_type sigma env (interp_rawconstr_with_implicits sigma env impls c) - -let interp_sort = function - | Node(loc,"PROP", []) -> Prop Null - | Node(loc,"SET", []) -> Prop Pos - | Node(loc,"TYPE", _) -> new_Type_sort () - | a -> user_err_loc (Ast.loc a,"interp_sort", (str "Not a sort")) - -let interp_elimination_sort = function - | Node(loc,"PROP", []) -> InProp - | Node(loc,"SET", []) -> InSet - | Node(loc,"TYPE", _) -> InType - | a -> user_err_loc (Ast.loc a,"interp_sort", (str "Not a sort")) - -let judgment_of_rawconstr sigma env c = - understand_judgment sigma env (interp_rawconstr sigma env c) - -let type_judgment_of_rawconstr sigma env c = - understand_type_judgment sigma env (interp_rawconstr sigma env c) - -(*To retype a list of key*constr with undefined key*) -let retype_list sigma env lst = - List.fold_right (fun (x,csr) a -> - try (x,Retyping.get_judgment_of env sigma csr)::a with - | Anomaly _ -> a) lst [] - -(* List.map (fun (x,csr) -> (x,Retyping.get_judgment_of env sigma csr)) lst*) - -(* Interprets a constr according to two lists *) -(* of instantiations (variables and metas) *) -(* Note: typ is retyped *) -let interp_constr_gen sigma env lvar lmeta com exptyp = - let c = interp_rawconstr_gen sigma env [] false (List.map fst lvar) com - and rtype lst = retype_list sigma env lst in - understand_gen sigma env (rtype lvar) (rtype lmeta) exptyp c;; - -(*Interprets a casted constr according to two lists of instantiations - (variables and metas)*) -let interp_openconstr_gen sigma env lvar lmeta com exptyp = - let c = interp_rawconstr_gen sigma env [] false (List.map fst lvar) com - and rtype lst = retype_list sigma env lst in - understand_gen_tcc sigma env (rtype lvar) (rtype lmeta) exptyp c;; - -let interp_casted_constr sigma env com typ = - understand_gen sigma env [] [] (Some typ) (interp_rawconstr sigma env com) - -(* To process patterns, we need a translation from AST to term - without typing at all. *) - -let ctxt_of_ids ids = Array.of_list (List.map mkVar ids) -(* -let rec pat_of_ref metas vars = function - | RConst (sp,ctxt) -> RConst (sp, ast_to_rawconstr_ctxt ctxt) - | RInd (ip,ctxt) -> RInd (ip, ast_to_rawconstr_ctxt ctxt) - | RConstruct(cp,ctxt) ->RConstruct(cp, ast_to_rawconstr_ctxt ctxt) - | REVar (n,ctxt) -> REVar (n, ast_to_rawconstr_ctxt ctxt) - | RVar _ -> assert false (* Capturé dans pattern_of_raw *) -*) -let rec pat_of_raw metas vars lvar = function - | RVar (_,id) -> - (try PRel (list_index (Name id) vars) - with Not_found -> - try List.assoc id lvar - with Not_found -> PVar id) - | RMeta (_,n) -> - metas := n::!metas; PMeta (Some n) - | RRef (_,r) -> - PRef r - (* Hack pour ne pas réécrire une interprétation complète des patterns*) - | RApp (_, RMeta (_,n), cl) when n<0 -> - PSoApp (- n, List.map (pat_of_raw metas vars lvar) cl) - | RApp (_,c,cl) -> - PApp (pat_of_raw metas vars lvar c, - Array.of_list (List.map (pat_of_raw metas vars lvar) cl)) - | RLambda (_,na,c1,c2) -> - PLambda (na, pat_of_raw metas vars lvar c1, - pat_of_raw metas (na::vars) lvar c2) - | RProd (_,na,c1,c2) -> - PProd (na, pat_of_raw metas vars lvar c1, - pat_of_raw metas (na::vars) lvar c2) - | RLetIn (_,na,c1,c2) -> - PLetIn (na, pat_of_raw metas vars lvar c1, - pat_of_raw metas (na::vars) lvar c2) - | RSort (_,s) -> - PSort s - | RHole _ -> - PMeta None - | RCast (_,c,t) -> - warning "Cast not taken into account in constr pattern"; - pat_of_raw metas vars lvar c - | ROldCase (_,false,po,c,br) -> - PCase (option_app (pat_of_raw metas vars lvar) po, - pat_of_raw metas vars lvar c, - Array.map (pat_of_raw metas vars lvar) br) - | _ -> - error "pattern_of_rawconstr: not implemented" - -let pattern_of_rawconstr lvar c = - let metas = ref [] in - let p = pat_of_raw metas [] lvar c in - (!metas,p) - -let interp_constrpattern_gen sigma env lvar com = - let c = - ast_to_rawconstr sigma - (from_list (ids_of_rel_context (rel_context env)), [], Symbols.current_scopes ()) - 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 - with e -> - Stdpp.raise_with_loc (Ast.loc com) e - -let interp_constrpattern sigma env com = - interp_constrpattern_gen sigma env [] com diff --git a/parsing/astterm.mli b/parsing/astterm.mli deleted file mode 100644 index 3a871cd53..000000000 --- a/parsing/astterm.mli +++ /dev/null @@ -1,101 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* Coqast.t -val constrOut : Coqast.t -> constr - -(* Interprets global names, including syntactic defs and section variables *) -val interp_global_constr : env -> qualid Util.located -> constr - -val interp_rawconstr : evar_map -> env -> Coqast.t -> rawconstr -val interp_rawconstr_gen : - evar_map -> env -> (identifier * Impargs.implicits_list) list -> - bool -> identifier list -> Coqast.t -> rawconstr -val interp_constr : evar_map -> env -> Coqast.t -> constr -val interp_casted_constr : evar_map -> env -> Coqast.t -> types -> constr -val interp_type : evar_map -> env -> Coqast.t -> types -val interp_sort : Coqast.t -> sorts - -val interp_elimination_sort : Coqast.t -> sorts_family - -val interp_openconstr : - evar_map -> env -> Coqast.t -> evar_map * constr -val interp_casted_openconstr : - evar_map -> env -> Coqast.t -> constr -> evar_map * constr - -(* [interp_type_with_implicits] extends [interp_type] by allowing - implicits arguments in the ``rel'' part of [env]; the extra - argument associates a list of implicit positions to identifiers - declared in the rel_context of [env] *) -val interp_type_with_implicits : - evar_map -> env -> - (identifier * Impargs.implicits_list) list -> Coqast.t -> types - -val judgment_of_rawconstr : evar_map -> env -> Coqast.t -> unsafe_judgment -val type_judgment_of_rawconstr : - evar_map -> env -> Coqast.t -> unsafe_type_judgment - -(*Interprets a constr according to two lists of instantiations (variables and - metas), possibly casting it*) -val interp_constr_gen : - evar_map -> env -> (identifier * constr) list -> - (int * constr) list -> Coqast.t -> constr option -> constr - -(*Interprets a constr according to two lists of instantiations (variables and - metas), possibly casting it, and turning unresolved evar into metas*) -val interp_openconstr_gen : - evar_map -> env -> (identifier * constr) list -> - (int * constr) list -> Coqast.t -> constr option - -> evar_map * constr - -(*Interprets constr patterns according to a list of instantiations - (variables)*) -val interp_constrpattern_gen : - evar_map -> env -> (identifier * constr) list -> Coqast.t -> - int list * constr_pattern - -val interp_constrpattern : - evar_map -> env -> Coqast.t -> int list * constr_pattern - -(*s Globalization of AST quotations (mainly used to get statically - bound idents in grammar or pretty-printing rules) *) -val globalize_constr : Coqast.t -> Coqast.t -val globalize_ast : Coqast.t -> Coqast.t -val globalize_qualid : qualid Util.located -> Coqast.t - -val ast_of_extended_ref_loc : loc -> Libnames.extended_global_reference -> Coqast.t - -(* This transforms args of a qualid keyword into a qualified ident *) -(* it does no relocation *) -val interp_qualid : Coqast.t list -> qualid - -(*i Translation rules from V6 to V7: - -constr_of_com_casted -> interp_casted_constr -constr_of_com_sort -> interp_type -constr_of_com -> interp_constr -rawconstr_of_com -> interp_rawconstr [+ env instead of sign] -type_of_com -> types_of_com Evd.empty -constr_of_com1 true -> interp_type -i*) diff --git a/parsing/coqast.ml b/parsing/coqast.ml index c0ecc618b..65519b673 100644 --- a/parsing/coqast.ml +++ b/parsing/coqast.ml @@ -9,12 +9,11 @@ (* $Id$ *) (*i*) +open Util open Names open Libnames (*i*) -type loc = int * int - type t = | Node of loc * string * t list | Nmeta of loc * string @@ -122,86 +121,3 @@ let rec subst_ast subst ast = match ast with | Str _ | Id _ | Dynamic _ -> ast - -open Util -open Rawterm -open Term - -type scope_name = string - -type reference_expr = - | RQualid of qualid located - | RIdent of identifier located - -type explicitation = int - -type cases_pattern = - | CPatAlias of loc * cases_pattern * identifier - | CPatCstr of loc * reference_expr * cases_pattern list - | CPatAtom of loc * reference_expr option - | CPatNumeral of loc * Bignat.bigint - | CPatDelimiters of loc * scope_name * cases_pattern - -type ordered_case_style = CIf | CLet | CMatch | CCase - -type constr_ast = - | CRef of reference_expr - | CFix of loc * identifier located * fixpoint_expr list - | CCoFix of loc * identifier located * cofixpoint_expr list - | CArrow of loc * constr_ast * constr_ast - | CProdN of loc * (name located list * constr_ast) list * constr_ast - | CLambdaN of loc * (name located list * constr_ast) list * constr_ast - | CLetIn of loc * identifier located * constr_ast * constr_ast - | CAppExpl of loc * reference_expr * constr_ast list - | CApp of loc * constr_ast * (constr_ast * explicitation option) list - | CCases of loc * case_style * constr_ast option * constr_ast list * - (loc * cases_pattern list * constr_ast) list - | COrderedCase of loc * ordered_case_style * constr_ast option * constr_ast * constr_ast list - | CHole of loc - | CMeta of loc * int - | CSort of loc * rawsort - | CCast of loc * constr_ast * constr_ast - | CNotation of loc * string * constr_ast list - | CNumeral of loc * Bignat.bigint - | CDelimiters of loc * scope_name * constr_ast - | CDynamic of loc * Dyn.t - -and local_binder = name located list * constr_ast - -and fixpoint_expr = identifier * local_binder list * constr_ast * constr_ast - -and cofixpoint_expr = identifier * constr_ast * constr_ast - -let constr_loc = function - | CRef (RIdent (loc,_)) -> loc - | CRef (RQualid (loc,_)) -> loc - | CFix (loc,_,_) -> loc - | CCoFix (loc,_,_) -> loc - | CArrow (loc,_,_) -> loc - | CProdN (loc,_,_) -> loc - | CLambdaN (loc,_,_) -> loc - | CLetIn (loc,_,_,_) -> loc - | CAppExpl (loc,_,_) -> loc - | CApp (loc,_,_) -> loc - | CCases (loc,_,_,_,_) -> loc - | COrderedCase (loc,_,_,_,_) -> loc - | CHole loc -> loc - | CMeta (loc,_) -> loc - | CSort (loc,_) -> loc - | CCast (loc,_,_) -> loc - | CNotation (loc,_,_) -> loc - | CNumeral (loc,_) -> loc - | CDelimiters (loc,_,_) -> loc - | CDynamic _ -> dummy_loc - -let cases_pattern_loc = function - | CPatAlias (loc,_,_) -> loc - | CPatCstr (loc,_,_) -> loc - | CPatAtom (loc,_) -> loc - | CPatNumeral (loc,_) -> loc - | CPatDelimiters (loc,_,_) -> loc - -let replace_vars_constr_ast l t = - if l = [] then t else failwith "replace_constr_ast: TODO" - -let occur_var_constr_ast id t = Pp.warning "occur_var_constr_ast:TODO"; true diff --git a/parsing/coqast.mli b/parsing/coqast.mli index 52b19c6bc..5b8c9d7d7 100644 --- a/parsing/coqast.mli +++ b/parsing/coqast.mli @@ -9,14 +9,13 @@ (*i $Id$ i*) (*i*) +open Util open Names open Libnames (*i*) (* Abstract syntax trees. *) -type loc = int * int - type t = | Node of loc * string * t list | Nmeta of loc * string @@ -50,62 +49,3 @@ val fold_tactic_expr : ('a -> t -> 'a) -> ('a -> tactic_expr -> 'a) -> 'a -> tactic_expr -> 'a val iter_tactic_expr : (tactic_expr -> unit) -> tactic_expr -> unit *) - - -open Util -open Rawterm -open Term - -type scope_name = string - -type reference_expr = - | RQualid of qualid located - | RIdent of identifier located - -type explicitation = int - -type cases_pattern = - | CPatAlias of loc * cases_pattern * identifier - | CPatCstr of loc * reference_expr * cases_pattern list - | CPatAtom of loc * reference_expr option - | CPatNumeral of loc * Bignat.bigint - | CPatDelimiters of loc * scope_name * cases_pattern - -type ordered_case_style = CIf | CLet | CMatch | CCase - -type constr_ast = - | CRef of reference_expr - | CFix of loc * identifier located * fixpoint_expr list - | CCoFix of loc * identifier located * cofixpoint_expr list - | CArrow of loc * constr_ast * constr_ast - | CProdN of loc * (name located list * constr_ast) list * constr_ast - | CLambdaN of loc * (name located list * constr_ast) list * constr_ast - | CLetIn of loc * identifier located * constr_ast * constr_ast - | CAppExpl of loc * reference_expr * constr_ast list - | CApp of loc * constr_ast * (constr_ast * explicitation option) list - | CCases of loc * case_style * constr_ast option * constr_ast list * - (loc * cases_pattern list * constr_ast) list - | COrderedCase of loc * ordered_case_style * constr_ast option * constr_ast * constr_ast list - | CHole of loc - | CMeta of loc * int - | CSort of loc * rawsort - | CCast of loc * constr_ast * constr_ast - | CNotation of loc * string * constr_ast list - | CNumeral of loc * Bignat.bigint - | CDelimiters of loc * scope_name * constr_ast - | CDynamic of loc * Dyn.t - -and local_binder = name located list * constr_ast - -and fixpoint_expr = identifier * local_binder list * constr_ast * constr_ast - -and cofixpoint_expr = identifier * constr_ast * constr_ast - -val constr_loc : constr_ast -> loc - -val cases_pattern_loc : cases_pattern -> loc - -val replace_vars_constr_ast : - (identifier * identifier) list -> constr_ast -> constr_ast - -val occur_var_constr_ast : identifier -> constr_ast -> bool diff --git a/parsing/coqlib.ml b/parsing/coqlib.ml deleted file mode 100644 index 5c0fef4aa..000000000 --- a/parsing/coqlib.ml +++ /dev/null @@ -1,285 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* - anomaly ("Coqlib: cannot find "^(string_of_qualid (make_qualid dir id))) - -let constant dir s = Declare.constr_of_reference (reference dir s) - -type coq_sigma_data = { - proj1 : constr; - proj2 : constr; - elim : constr; - intro : constr; - typ : constr } - -type 'a delayed = unit -> 'a - -let build_sigma_set () = - { proj1 = constant "Specif" "projS1"; - proj2 = constant "Specif" "projS2"; - elim = constant "Specif" "sigS_rec"; - intro = constant "Specif" "existS"; - typ = constant "Specif" "sigS" } - -let build_sigma_type () = - { proj1 = constant "Specif" "projT1"; - proj2 = constant "Specif" "projT2"; - elim = constant "Specif" "sigT_rec"; - intro = constant "Specif" "existT"; - typ = constant "Specif" "sigT" } - -(* Equalities *) -type coq_leibniz_eq_data = { - eq : constr delayed; - ind : constr delayed; - rrec : constr delayed option; - rect : constr delayed option; - congr: constr delayed; - sym : constr delayed } - -let constant dir id = lazy (constant dir id) - -(* Equality on Set *) -let coq_eq_eq = constant "Logic" "eq" -let coq_eq_ind = constant "Logic" "eq_ind" -let coq_eq_rec = constant "Logic" "eq_rec" -let coq_eq_rect = constant "Logic" "eq_rect" -let coq_eq_congr = constant "Logic" "f_equal" -let coq_eq_sym = constant "Logic" "sym_eq" -let coq_f_equal2 = constant "Logic" "f_equal2" - -let build_coq_eq_data = { - eq = (fun () -> Lazy.force coq_eq_eq); - ind = (fun () -> Lazy.force coq_eq_ind); - rrec = Some (fun () -> Lazy.force coq_eq_rec); - rect = Some (fun () -> Lazy.force coq_eq_rect); - congr = (fun () -> Lazy.force coq_eq_congr); - sym = (fun () -> Lazy.force coq_eq_sym) } - -let build_coq_eq = build_coq_eq_data.eq -let build_coq_f_equal2 () = Lazy.force coq_f_equal2 - -(* Specif *) -let coq_sumbool = constant "Specif" "sumbool" - -let build_coq_sumbool () = Lazy.force coq_sumbool - -(* Equality on Type *) -let coq_eqT_eq = constant "Logic_Type" "eqT" -let coq_eqT_ind = constant "Logic_Type" "eqT_ind" -let coq_eqT_congr =constant "Logic_Type" "congr_eqT" -let coq_eqT_sym = constant "Logic_Type" "sym_eqT" - -let build_coq_eqT_data = { - eq = (fun () -> Lazy.force coq_eqT_eq); - ind = (fun () -> Lazy.force coq_eqT_ind); - rrec = None; - rect = None; - congr = (fun () -> Lazy.force coq_eqT_congr); - sym = (fun () -> Lazy.force coq_eqT_sym) } - -let build_coq_eqT = build_coq_eqT_data.eq -let build_coq_sym_eqT = build_coq_eqT_data.sym - -(* Equality on Type as a Type *) -let coq_idT_eq = constant "Logic_Type" "identityT" -let coq_idT_ind = constant "Logic_Type" "identityT_ind" -let coq_idT_rec = constant "Logic_Type" "identityT_rec" -let coq_idT_rect = constant "Logic_Type" "identityT_rect" -let coq_idT_congr = constant "Logic_Type" "congr_idT" -let coq_idT_sym = constant "Logic_Type" "sym_idT" - -let build_coq_idT_data = { - eq = (fun () -> Lazy.force coq_idT_eq); - ind = (fun () -> Lazy.force coq_idT_ind); - rrec = Some (fun () -> Lazy.force coq_idT_rec); - rect = Some (fun () -> Lazy.force coq_idT_rect); - congr = (fun () -> Lazy.force coq_idT_congr); - sym = (fun () -> Lazy.force coq_idT_sym) } - -(* Empty Type *) -let coq_EmptyT = constant "Logic_Type" "EmptyT" - -(* Unit Type and its unique inhabitant *) -let coq_UnitT = constant "Logic_Type" "UnitT" -let coq_IT = constant "Logic_Type" "IT" - -(* The False proposition *) -let coq_False = constant "Logic" "False" - -(* The True proposition and its unique proof *) -let coq_True = constant "Logic" "True" -let coq_I = constant "Logic" "I" - -(* Connectives *) -let coq_not = constant "Logic" "not" -let coq_and = constant "Logic" "and" -let coq_or = constant "Logic" "or" -let coq_ex = constant "Logic" "ex" - -(* Runtime part *) -let build_coq_EmptyT () = Lazy.force coq_EmptyT -let build_coq_UnitT () = Lazy.force coq_UnitT -let build_coq_IT () = Lazy.force coq_IT - -let build_coq_True () = Lazy.force coq_True -let build_coq_I () = Lazy.force coq_I - -let build_coq_False () = Lazy.force coq_False -let build_coq_not () = Lazy.force coq_not -let build_coq_and () = Lazy.force coq_and -let build_coq_or () = Lazy.force coq_or -let build_coq_ex () = Lazy.force coq_ex - -(****************************************************************************) -(* Patterns *) -(* This needs to have interp_constrpattern available ... -let parse_astconstr s = - try - Pcoq.parse_string Pcoq.Constr.constr_eoi s - with Stdpp.Exc_located (_ , (Stream.Failure | Stream.Error _)) -> - error "Syntax error : not a construction" - -let parse_pattern s = - Astterm.interp_constrpattern Evd.empty (Global.env()) (parse_astconstr s) - -let coq_eq_pattern = - lazy (snd (parse_pattern "(Coq.Init.Logic.eq ?1 ?2 ?3)")) -let coq_eqT_pattern = - lazy (snd (parse_pattern "(Coq.Init.Logic_Type.eqT ?1 ?2 ?3)")) -let coq_idT_pattern = - lazy (snd (parse_pattern "(Coq.Init.Logic_Type.identityT ?1 ?2 ?3)")) -let coq_existS_pattern = - lazy (snd (parse_pattern "(Coq.Init.Specif.existS ?1 ?2 ?3 ?4)")) -let coq_existT_pattern = - lazy (snd (parse_pattern "(Coq.Init.Specif.existT ?1 ?2 ?3 ?4)")) -let coq_not_pattern = - lazy (snd (parse_pattern "(Coq.Init.Logic.not ?)")) -let coq_imp_False_pattern = - lazy (snd (parse_pattern "? -> Coq.Init.Logic.False")) -let coq_imp_False_pattern = - lazy (snd (parse_pattern "? -> Coq.Init.Logic.False")) -let coq_eqdec_partial_pattern - lazy (snd (parse_pattern "(sumbool (eq ?1 ?2 ?3) ?4)")) -let coq_eqdec_pattern - lazy (snd (parse_pattern "(x,y:?1){x=y}+{~(x=y)}")) -*) - -(* The following is less readable but does not depend on parsing *) -let coq_eq_ref = lazy (reference "Logic" "eq") -let coq_eqT_ref = lazy (reference "Logic_Type" "eqT") -let coq_idT_ref = lazy (reference "Logic_Type" "identityT") -let coq_existS_ref = lazy (reference "Specif" "existS") -let coq_existT_ref = lazy (reference "Specif" "existT") -let coq_not_ref = lazy (reference "Logic" "not") -let coq_False_ref = lazy (reference "Logic" "False") -let coq_sumbool_ref = lazy (reference "Specif" "sumbool") -let coq_sig_ref = lazy (reference "Specif" "sig") - -(* Pattern "(sig ?1 ?2)" *) -let coq_sig_pattern = - lazy (PApp (PRef (Lazy.force coq_sig_ref), - [| PMeta (Some 1); PMeta (Some 2) |])) - -(* Patterns "(eq ?1 ?2 ?3)", "(eqT ?1 ?2 ?3)" and "(idT ?1 ?2 ?3)" *) -let coq_eq_pattern_gen eq = - lazy (PApp(PRef (Lazy.force eq), Array.init 3 (fun i -> PMeta (Some (i+1))))) -let coq_eq_pattern = coq_eq_pattern_gen coq_eq_ref -let coq_eqT_pattern = coq_eq_pattern_gen coq_eqT_ref -let coq_idT_pattern = coq_eq_pattern_gen coq_idT_ref - -(* Patterns "(existS ?1 ?2 ?3 ?4)" and "(existT ?1 ?2 ?3 ?4)" *) -let coq_ex_pattern_gen ex = - lazy (PApp(PRef (Lazy.force ex), Array.init 4 (fun i -> PMeta (Some (i+1))))) -let coq_existS_pattern = coq_ex_pattern_gen coq_existS_ref -let coq_existT_pattern = coq_ex_pattern_gen coq_existT_ref - -(* Patterns "~ ?" and "? -> False" *) -let coq_not_pattern = lazy(PApp(PRef (Lazy.force coq_not_ref), [|PMeta None|])) -let imp a b = PProd (Anonymous, a, b) -let coq_imp_False_pattern = - lazy (imp (PMeta None) (PRef (Lazy.force coq_False_ref))) - -(* Pattern "(sumbool (eq ?1 ?2 ?3) ?4)" *) -let coq_eqdec_partial_pattern = - lazy - (PApp - (PRef (Lazy.force coq_sumbool_ref), - [| Lazy.force coq_eq_pattern; PMeta (Some 4) |])) - -(* The expected form of the goal for the tactic Decide Equality *) - -(* Pattern "(x,y:?1){x=y}+{~(x=y)}" *) -(* i.e. "(x,y:?1)(sumbool (eq ?1 x y) ~(eq ?1 x y))" *) -let x = Name (id_of_string "x") -let y = Name (id_of_string "y") -let coq_eqdec_pattern = - lazy - (PProd (x, PMeta (Some 1), PProd (y, PMeta (Some 1), - PApp (PRef (Lazy.force coq_sumbool_ref), - [| PApp (PRef (Lazy.force coq_eq_ref), - [| PMeta (Some 1); PRel 2; PRel 1 |]); - PApp (PRef (Lazy.force coq_not_ref), - [|PApp (PRef (Lazy.force coq_eq_ref), - [| PMeta (Some 1); PRel 2; PRel 1 |])|]) |])))) - -let build_coq_eq_pattern () = Lazy.force coq_eq_pattern -let build_coq_eqT_pattern () = Lazy.force coq_eqT_pattern -let build_coq_idT_pattern () = Lazy.force coq_idT_pattern -let build_coq_existS_pattern () = Lazy.force coq_existS_pattern -let build_coq_existT_pattern () = Lazy.force coq_existT_pattern -let build_coq_not_pattern () = Lazy.force coq_not_pattern -let build_coq_imp_False_pattern () = Lazy.force coq_imp_False_pattern -let build_coq_eqdec_partial_pattern () = Lazy.force coq_eqdec_partial_pattern -let build_coq_eqdec_pattern () = Lazy.force coq_eqdec_pattern -let build_coq_sig_pattern () = Lazy.force coq_sig_pattern diff --git a/parsing/coqlib.mli b/parsing/coqlib.mli deleted file mode 100644 index dbe99e399..000000000 --- a/parsing/coqlib.mli +++ /dev/null @@ -1,133 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* 'a - -(*s For Equality tactics *) -type coq_sigma_data = { - proj1 : constr; - proj2 : constr; - elim : constr; - intro : constr; - typ : constr } - -val build_sigma_set : unit -> coq_sigma_data -val build_sigma_type : unit -> coq_sigma_data - -type coq_leibniz_eq_data = { - eq : constr delayed; - ind : constr delayed; - rrec : constr delayed option; - rect : constr delayed option; - congr: constr delayed; - sym : constr delayed } - -val build_coq_eq_data : coq_leibniz_eq_data -val build_coq_eqT_data : coq_leibniz_eq_data -val build_coq_idT_data : coq_leibniz_eq_data - -val build_coq_f_equal2 : constr delayed -val build_coq_eqT : constr delayed -val build_coq_sym_eqT : constr delayed - -(* Empty Type *) -val build_coq_EmptyT : constr delayed - -(* Unit Type and its unique inhabitant *) -val build_coq_UnitT : constr delayed -val build_coq_IT : constr delayed - -(* Specif *) -val build_coq_sumbool : constr delayed - -(*s Connectives *) -(* The False proposition *) -val build_coq_False : constr delayed - -(* The True proposition and its unique proof *) -val build_coq_True : constr delayed -val build_coq_I : constr delayed - -(* Negation *) -val build_coq_not : constr delayed - -(* Conjunction *) -val build_coq_and : constr delayed - -(* Disjunction *) -val build_coq_or : constr delayed - -(* Existential quantifier *) -val build_coq_ex : constr delayed - -(**************************** Patterns ************************************) -(* ["(eq ?1 ?2 ?3)"] *) -val build_coq_eq_pattern : constr_pattern delayed - -(* ["(eqT ?1 ?2 ?3)"] *) -val build_coq_eqT_pattern : constr_pattern delayed - -(* ["(identityT ?1 ?2 ?3)"] *) -val build_coq_idT_pattern : constr_pattern delayed - -(* ["(existS ?1 ?2 ?3 ?4)"] *) -val build_coq_existS_pattern : constr_pattern delayed - -(* ["(existT ?1 ?2 ?3 ?4)"] *) -val build_coq_existT_pattern : constr_pattern delayed - -(* ["(not ?)"] *) -val build_coq_not_pattern : constr_pattern delayed - -(* ["? -> False"] *) -val build_coq_imp_False_pattern : constr_pattern delayed - -(* ["(sumbool (eq ?1 ?2 ?3) ?4)"] *) -val build_coq_eqdec_partial_pattern : constr_pattern delayed - -(* ["! (x,y:?1). (sumbool (eq ?1 x y) ~(eq ?1 x y))"] *) -val build_coq_eqdec_pattern : constr_pattern delayed - -(* ["(sig ?1 ?2)"] *) -val build_coq_sig_pattern : constr_pattern delayed diff --git a/parsing/egrammar.ml b/parsing/egrammar.ml index 731bb5e64..cec7e4458 100644 --- a/parsing/egrammar.ml +++ b/parsing/egrammar.ml @@ -12,20 +12,25 @@ open Pp open Util open Extend open Pcoq -open Coqast +open Topconstr open Ast open Genarg +open Libnames (* State of the grammar extensions *) type all_grammar_command = - | AstGrammar of grammar_command + | Notation of (string * notation * prod_item list) + | Delimiters of (scope_name * prod_item list * prod_item list) + | Grammar of grammar_command | TacticGrammar of (string * (string * grammar_production list) * Tacexpr.raw_tactic_expr) list let subst_all_grammar_command subst = function - | AstGrammar gc -> AstGrammar (subst_grammar_command subst gc) + | Notation _ -> anomaly "Notation not in GRAMMAR summary" + | Delimiters _ -> anomaly "Delimiters not in GRAMMAR summary" + | Grammar gc -> Grammar (subst_grammar_command subst gc) | TacticGrammar g -> TacticGrammar g (* TODO ... *) let (grammar_state : all_grammar_command list ref) = ref [] @@ -45,24 +50,8 @@ let specify_name name e = Failure("during interpretation of grammar rule "^name^", "^s) | e -> e -let gram_action (name, etyp) env act dloc = - try - let v = Ast.eval_act dloc env act in - match etyp, v with - | (PureAstType, PureAstNode ast) -> Obj.repr ast - | (AstListType, AstListNode astl) -> Obj.repr astl - | (GenAstType ConstrArgType, PureAstNode ast) -> Obj.repr ast - | _ -> grammar_type_error (dloc, "Egrammar.gram_action") - with e -> - let (loc, exn) = - match e with - | Stdpp.Exc_located (loce, lexn) -> (loce, lexn) - | e -> (dloc, e) - in - Stdpp.raise_with_loc loc (specify_name name exn) - (* Translation of environments: a production - * [ nt1($x1) ... nti($xi) ] -> act($x1..$xi) + * [ nt1(x1) ... nti(xi) ] -> act(x1..xi) * is written (with camlp4 conventions): * (fun vi -> .... (fun v1 -> act(v1 .. vi) )..) * where v1..vi are the values generated by non-terminals nt1..nti. @@ -75,23 +64,42 @@ let gram_action (name, etyp) env act dloc = * * (fun v1 -> * (fun env -> gram_action .. env act) - * (($x1,v1)::env)) + * ((x1,v1)::env)) * ...) - * (($xi,vi)::env))) + * ((xi,vi)::env))) * []) *) -let make_act name_typ a pil = - let act_without_arg env = Gramext.action (gram_action name_typ env a) - and make_prod_item act_tl = function - | None -> (* parse a non-binding item *) - (fun env -> Gramext.action (fun _ -> act_tl env)) - | Some (p, ETast) -> (* non-terminal *) - (fun env -> Gramext.action (fun v -> act_tl((p,PureAstNode v)::env))) - | Some (p, ETastl) -> (* non-terminal *) - (fun env -> Gramext.action (fun v -> act_tl((p,AstListNode v)::env))) - in - (List.fold_left make_prod_item act_without_arg pil) [] +open Names + +let make_act f pil = + let rec make env = function + | [] -> + Gramext.action (fun loc -> f loc env) + | None :: tl -> (* parse a non-binding item *) + Gramext.action (fun _ -> make env tl) + | Some (p, ETConstr) :: tl -> (* non-terminal *) + Gramext.action (fun (v:constr_expr) -> make ((p,v) :: env) tl) + | Some (p, ETReference) :: tl -> (* non-terminal *) + Gramext.action (fun (v:reference) -> make ((p,CRef v) :: env) tl) + | Some (p, ETIdent) :: tl -> (* non-terminal *) + Gramext.action (fun (v:identifier) -> + make ((p,CRef (Ident (dummy_loc,v))) :: env) tl) in + make [] (List.rev pil) + +let make_cases_pattern_act f pil = + let rec make env = function + | [] -> + Gramext.action (fun loc -> f loc env) + | None :: tl -> (* parse a non-binding item *) + Gramext.action (fun _ -> make env tl) + | Some (p, ETConstr) :: tl -> (* non-terminal *) + Gramext.action (fun v -> make ((p,v) :: env) tl) + | Some (p, ETReference) :: tl -> (* non-terminal *) + Gramext.action (fun v -> make ((p,CPatAtom (dummy_loc,Some v)) :: env) tl) + | Some (p, ETIdent) :: tl -> + error "ident entry not admitted in patterns cases syntax extensions" in + make [] (List.rev pil) (* Grammar extension command. Rules are assumed correct. * Type-checking of grammar rules is done during the translation of @@ -101,7 +109,8 @@ let make_act name_typ a pil = * Extend.of_ast) *) let get_entry_type (u,n) = - Gram.Entry.obj (object_of_typed_entry (get_entry (get_univ u) n)) + if u = "constr" & n = "pattern" then Gram.Entry.obj Constr.pattern + else Gram.Entry.obj (object_of_typed_entry (get_entry (get_univ u) n)) let rec build_prod_item univ = function | ProdList0 s -> Gramext.Slist0 (build_prod_item univ s) @@ -117,26 +126,36 @@ let symbol_of_prod_item univ = function let eobj = build_prod_item univ nt in (eobj, ovar) +(* let make_rule univ etyp rule = let pil = List.map (symbol_of_prod_item univ) rule.gr_production in let (symbs,ntl) = List.split pil in let act = make_act (rule.gr_name,etyp) rule.gr_action ntl in (symbs, act) +*) + +let make_rule univ etyp rule = + let pil = List.map (symbol_of_prod_item univ) rule.gr_production in + let (symbs,ntl) = List.split pil in + let f loc env = CGrammar (loc, rule.gr_action, env) in + let act = make_act f ntl in + (symbs, act) + (* Rules of a level are entered in reverse order, so that the first rules are applied before the last ones *) let extend_entry univ (te, etyp, ass, rls) = let rules = List.rev (List.map (make_rule univ etyp) rls) in - grammar_extend te None [(None, ass, rules)] + grammar_extend (object_of_typed_entry te) None [(None, ass, rules)] (* Defines new entries. If the entry already exists, check its type *) let define_entry univ {ge_name=n; ge_type=typ; gl_assoc=ass; gl_rules=rls} = - let typ = if typ = ETast then GenAstType ConstrArgType else AstListType in + let typ = entry_type_of_constr_entry_type typ in let e = force_entry_type univ n typ in (e,typ,ass,rls) (* Add a bunch of grammar rules. Does not check if it is well formed *) -let extend_grammar gram = +let extend_grammar_rules gram = let univ = get_univ gram.gc_univ in let tl = List.map (define_entry univ) gram.gc_entries in List.iter (extend_entry univ) tl @@ -154,32 +173,56 @@ let make_prod_item = function let make_gen_act f pil = let rec make env = function | [] -> - Gramext.action (fun loc -> f env) + Gramext.action (fun loc -> f loc env) | None :: tl -> (* parse a non-binding item *) Gramext.action (fun _ -> make env tl) | Some (p, t) :: tl -> (* non-terminal *) Gramext.action (fun v -> make ((p,in_generic t v) :: env) tl) in make [] (List.rev pil) -let make_rule univ f g (s',pt) = - let hd = Gramext.Stoken ("IDENT", s') in +let extend_constr entry make_act pt = + let univ = get_univ "constr" in + let pil = List.map (symbol_of_prod_item univ) pt in + let (symbs,ntl) = List.split pil in + let act = make_act ntl in + grammar_extend entry None [(None, None, [symbs, act])] + +let constr_entry name = + object_of_typed_entry (get_entry (get_univ "constr") name) + +let extend_constr_notation (name,ntn,rule) = + let mkact loc env = CNotation (loc,ntn,env) in + extend_constr (constr_entry name) (make_act mkact) rule + +let extend_constr_grammar (name,c,rule) = + let mkact loc env = CGrammar (loc,c,env) in + extend_constr (constr_entry name) (make_act mkact) rule + +let extend_constr_delimiters (sc,rule,pat_rule) = + let mkact loc env = CDelimiters (loc,sc,snd (List.hd env)) in + extend_constr (constr_entry "constr8") (make_act mkact) rule; + let mkact loc env = CPatDelimiters (loc,sc,snd (List.hd env)) in + extend_constr Constr.pattern (make_cases_pattern_act mkact) pat_rule + +(* These grammars are not a removable *) +let make_rule univ f g (s,pt) = + let hd = Gramext.Stoken ("IDENT", s) in let pil = (hd,None) :: List.map g pt in let (symbs,ntl) = List.split pil in let act = make_gen_act f ntl in (symbs, act) -(* These grammars are not a removable *) let extend_tactic_grammar s gl = let univ = get_univ "tactic" in - let make_act l = Tacexpr.TacExtend (s,List.map snd l) in - let rules = List.rev (List.map (make_rule univ make_act make_prod_item) gl) - in Gram.extend Tactic.simple_tactic None [(None, None, rules)] + let make_act loc l = Tacexpr.TacExtend (loc,s,List.map snd l) in + let rules = List.map (make_rule univ make_act make_prod_item) gl in + Gram.extend Tactic.simple_tactic None [(None, None, List.rev rules)] let extend_vernac_command_grammar s gl = let univ = get_univ "vernac" in - let make_act l = Vernacexpr.VernacExtend (s,List.map snd l) in - let rules = List.rev (List.map (make_rule univ make_act make_prod_item) gl) - in Gram.extend Vernac_.command None [(None, None, rules)] + let make_act loc l = Vernacexpr.VernacExtend (s,List.map snd l) in + let rules = List.map (make_rule univ make_act make_prod_item) gl in + Gram.extend Vernac_.command None [(None, None, List.rev rules)] let rec interp_entry_name u s = let l = String.length s in @@ -196,9 +239,7 @@ let rec interp_entry_name u s = let n = Extend.rename_command s in let e = get_entry (get_univ u) n in let o = object_of_typed_entry e in - let t = match type_of_typed_entry e with - | GenAstType t -> t - | _ -> failwith "Only entries of generic type can be used in alias" in + let t = type_of_typed_entry e in t, Gramext.Snterm (Pcoq.Gram.Entry.obj o) let qualified_nterm current_univ = function @@ -214,16 +255,17 @@ let make_vprod_item univ = function let add_tactic_entries gl = let univ = get_univ "tactic" in - let make_act s tac l = Tacexpr.TacAlias (s,l,tac) in - let rules = - List.rev (List.map (fun (s,l,tac) -> make_rule univ (make_act s tac) (make_vprod_item "tactic") l) gl) - in - let tacentry = get_entry (get_univ "tactic") "simple_tactic" in - grammar_extend tacentry None [(None, None, rules)] + let make_act s tac loc l = Tacexpr.TacAlias (s,l,tac) in + let f (s,l,tac) = + make_rule univ (make_act s tac) (make_vprod_item "tactic") l in + let rules = List.map f gl in + grammar_extend Tactic.simple_tactic None [(None, None, List.rev rules)] let extend_grammar gram = (match gram with - | AstGrammar g -> extend_grammar g + | Notation a -> extend_constr_notation a + | Delimiters a -> extend_constr_delimiters a + | Grammar g -> extend_grammar_rules g | TacticGrammar l -> add_tactic_entries l); grammar_state := gram :: !grammar_state @@ -243,7 +285,9 @@ let factorize_grams l1 l2 = let number_of_entries gcl = List.fold_left (fun n -> function - | AstGrammar gc -> n + (List.length gc.gc_entries) + | Notation _ -> n + 1 + | Delimiters _ -> n + 2 (* One rule for constr, one for pattern *) + | Grammar gc -> n + (List.length gc.gc_entries) | TacticGrammar l -> n + 1) 0 gcl diff --git a/parsing/egrammar.mli b/parsing/egrammar.mli index 73f9e424e..ff3f6284b 100644 --- a/parsing/egrammar.mli +++ b/parsing/egrammar.mli @@ -9,11 +9,12 @@ (*i $Id$ i*) (*i*) -open Coqast +open Topconstr open Ast open Coqast open Vernacexpr open Extend +open Rawterm (*i*) type frozen_t @@ -23,11 +24,15 @@ val unfreeze : frozen_t -> unit val init : unit -> unit type all_grammar_command = - | AstGrammar of grammar_command + | Notation of (string * notation * prod_item list) + | Delimiters of (scope_name * prod_item list * prod_item list) + | Grammar of grammar_command | TacticGrammar of (string * (string * grammar_production list) * Tacexpr.raw_tactic_expr) list val extend_grammar : all_grammar_command -> unit +val extend_constr_grammar : string * aconstr * prod_item list -> unit + (* Add grammar rules for tactics *) type grammar_tactic_production = | TacTerm of string diff --git a/parsing/esyntax.ml b/parsing/esyntax.ml index 9f802563b..76f4b3f19 100644 --- a/parsing/esyntax.ml +++ b/parsing/esyntax.ml @@ -15,11 +15,13 @@ open Libnames open Coqast open Ast open Extend +open Ppextend open Vernacexpr open Names open Nametab +open Topconstr open Symbols - + (*** Syntax keys ***) (* We define keys for ast and astpats. This is a kind of hash @@ -84,30 +86,20 @@ let se_key se = spat_key se.syn_astpat let from_name_table = ref Gmap.empty let from_key_table = ref Gmapl.empty -let infix_symbols_map = ref Stringmap.empty -let infix_names_map = ref Spmap.empty - (* Summary operations *) type frozen_t = (string * string, astpat syntax_entry) Gmap.t * - (string * key, astpat syntax_entry) Gmapl.t * - section_path Stringmap.t * string list Spmap.t + (string * key, astpat syntax_entry) Gmapl.t let freeze () = - (!from_name_table, !from_key_table, !infix_symbols_map, !infix_names_map) + (!from_name_table, !from_key_table) -let unfreeze (fnm,fkm,infs,infn) = +let unfreeze (fnm,fkm) = from_name_table := fnm; - from_key_table := fkm; - infix_symbols_map := infs; - infix_names_map := infn + from_key_table := fkm let init () = from_name_table := Gmap.empty; from_key_table := Gmapl.empty -(* - infix_symbols_map := Stringmap.empty; - infix_names_map := Spmap.empty -*) let find_syntax_entry whatfor gt = let gt_keys = ast_keys gt in @@ -140,9 +132,9 @@ let add_ppobject {sc_univ=wf;sc_entries=sel} = List.iter (add_rule wf) sel (* Pretty-printing machinery *) -type std_printer = Genarg.constr_ast -> std_ppcmds +type std_printer = Coqast.t -> std_ppcmds type unparsing_subfunction = string -> tolerability option -> std_printer -type primitive_printer = Genarg.constr_ast -> std_ppcmds option +type primitive_printer = Coqast.t -> std_ppcmds option (* Module of primitive printers *) module Ppprim = @@ -187,9 +179,7 @@ let _ = declare_primitive_printer "print_as" default_scope print_as_printer (* Handle infix symbols *) let pr_parenthesis inherited se strm = - let rule_prec = (se.syn_id, se.syn_prec) in - let no_paren = tolerable_prec inherited rule_prec in - if no_paren then + if tolerable_prec inherited se.syn_prec then strm else (str"(" ++ strm ++ str")") @@ -212,7 +202,7 @@ let print_delimiters inh se strm = function let print_syntax_entry sub_pr scopes env se = let rec print_hunk rule_prec scopes = function | PH(e,externpr,reln) -> - let node = Ast.pat_sub Ast.dummy_loc env e in + let node = Ast.pat_sub dummy_loc env e in let printer = match externpr with (* May branch to an other printer *) | Some c -> @@ -228,8 +218,7 @@ let print_syntax_entry sub_pr scopes env se = | UNP_BOX (b,sub) -> ppcmd_of_box b (prlist (print_hunk rule_prec scopes) sub) | UNP_SYMBOLIC _ -> anomaly "handled by call_primitive_parser" in - let rule_prec = (se.syn_id, se.syn_prec) in - prlist (print_hunk rule_prec scopes) se.syn_hunks + prlist (print_hunk se.syn_prec scopes) se.syn_hunks let call_primitive_parser rec_pr otherwise inherited scopes (se,env) = try ( @@ -242,7 +231,7 @@ let call_primitive_parser rec_pr otherwise inherited scopes (se,env) = | None -> otherwise () | Some (dlm,scopes) -> (* We can use this printer *) - let node = Ast.pat_sub Ast.dummy_loc env e in + let node = Ast.pat_sub dummy_loc env e in match pr node with | Some strm -> print_delimiters inherited se strm dlm | None -> otherwise ()) diff --git a/parsing/esyntax.mli b/parsing/esyntax.mli index cf1b0de3f..9ee6b9f0a 100644 --- a/parsing/esyntax.mli +++ b/parsing/esyntax.mli @@ -13,6 +13,8 @@ open Pp open Extend open Vernacexpr open Symbols +open Ppextend +open Topconstr (*i*) (* Syntax entry tables. *) @@ -33,9 +35,9 @@ val warning_verbose : bool ref (* Pretty-printing *) -type std_printer = Genarg.constr_ast -> std_ppcmds +type std_printer = Coqast.t -> std_ppcmds type unparsing_subfunction = string -> tolerability option -> std_printer -type primitive_printer = Genarg.constr_ast -> std_ppcmds option +type primitive_printer = Coqast.t -> std_ppcmds option (* Module of constr primitive printers [old style - no scope] *) module Ppprim : diff --git a/parsing/extend.ml b/parsing/extend.ml index a469a648f..0e1f72536 100644 --- a/parsing/extend.ml +++ b/parsing/extend.ml @@ -10,9 +10,16 @@ (*i $Id$ i*) open Util -open Gramext open Pp +open Gramext +open Names open Ast +open Ppextend +open Topconstr +open Genarg + +type entry_type = argument_type +type constr_entry_type = ETConstr | ETIdent | ETReference type nonterm_prod = | ProdList0 of nonterm_prod @@ -22,16 +29,16 @@ type nonterm_prod = type prod_item = | Term of Token.pattern - | NonTerm of nonterm_prod * (string * ast_action_type) option + | NonTerm of nonterm_prod * (Names.identifier * constr_entry_type) option type grammar_rule = { gr_name : string; gr_production : prod_item list; - gr_action : act } + gr_action : aconstr } type grammar_entry = { ge_name : string; - ge_type : ast_action_type; + ge_type : constr_entry_type; gl_assoc : Gramext.g_assoc option; gl_rules : grammar_rule list } @@ -40,18 +47,40 @@ type grammar_command = { gc_entries : grammar_entry list } type grammar_associativity = Gramext.g_assoc option + +(**********************************************************************) +(* Globalisation and type-checking of Grammar actions *) + +type entry_context = (identifier * constr_entry_type) list + +let ast_to_rawconstr = ref (fun _ _ -> AVar (id_of_string "Z")) +let set_ast_to_rawconstr f = ast_to_rawconstr := f + +let act_of_ast vars = function + | SimpleAction (loc,ConstrNode a) -> !ast_to_rawconstr vars a + | SimpleAction (loc,CasesPatternNode a) -> failwith "TODO:act_of_ast: cases_pattern" + | CaseAction _ -> failwith "case/let not supported" + +let to_act_check_vars = act_of_ast + +type syntax_modifier = + | SetItemLevel of string * int + | SetLevel of int + | SetAssoc of Gramext.g_assoc + | SetEntryType of string * constr_entry_type + type nonterm = | NtShort of string | NtQual of string * string type grammar_production = | VTerm of string - | VNonTerm of loc * nonterm * string option + | VNonTerm of loc * nonterm * Names.identifier option type raw_grammar_rule = string * grammar_production list * grammar_action type raw_grammar_entry = - string * ast_action_type * grammar_associativity * raw_grammar_rule list + string * constr_entry_type * grammar_associativity * raw_grammar_rule list let subst_grammar_rule subst gr = - { gr with gr_action = subst_act subst gr.gr_action } + { gr with gr_action = subst_aconstr subst gr.gr_action } let subst_grammar_entry subst ge = { ge with gl_rules = List.map (subst_grammar_rule subst) ge.gl_rules } @@ -116,15 +145,20 @@ let qualified_nterm current_univ = function | NtQual (univ, en) -> (rename_command univ, rename_command en) | NtShort en -> (current_univ, rename_command en) +let entry_type_of_constr_entry_type = function + | ETConstr -> ConstrArgType + | ETIdent -> IdentArgType + | ETReference -> RefArgType + +let constr_entry_of_entry = function + | ConstrArgType -> ETConstr + | IdentArgType -> ETIdent + | RefArgType -> ETReference + | _ -> error "Cannot arbitrarily extend non constr/ident/ref entries" + let nterm loc (get_entry_type,univ) nont = let nt = qualified_nterm univ nont in - try - let et = match get_entry_type nt with - | PureAstType -> ETast - | GenAstType Genarg.ConstrArgType -> ETast - | AstListType -> ETastl - | _ -> error "Cannot arbitrarily extend non ast entries" - in (nt,et) + try (nt,constr_entry_of_entry (get_entry_type nt)) with Not_found -> let (s,n) = nt in user_err_loc(loc,"Externd.nterm",str("unknown grammar entry: "^s^":"^n)) @@ -132,7 +166,7 @@ let nterm loc (get_entry_type,univ) nont = let prod_item univ env = function | VTerm s -> env, Term (terminal s) | VNonTerm (loc, nt, Some p) -> - let (nont, etyp) = nterm loc univ nt in + let (nont, etyp) = nterm loc univ nt in ((p, etyp) :: env, NonTerm (ProdPrimitive nont, Some (p,etyp))) | VNonTerm (loc, nt, None) -> let (nont, etyp) = nterm loc univ nt in @@ -148,7 +182,7 @@ let rec prod_item_list univ penv pil = let gram_rule univ etyp (name,pil,act) = let (pilc, act_env) = prod_item_list univ [] pil in - let a = Ast.to_act_check_vars act_env etyp act in + let a = to_act_check_vars act_env act in { gr_name = name; gr_production = pilc; gr_action = a } let gram_entry univ (nt, etyp, ass, rl) = @@ -162,21 +196,6 @@ let interp_grammar_command univ ge entryl = { gc_univ = univ; gc_entries = List.map (gram_entry (ge,univ)) entryl } -(*s Pretty-print. *) - -(* Dealing with precedences *) - -type precedence = int * int * int - -type parenRelation = L | E | Any | Prec of precedence - -type ppbox = - | PpHB of int - | PpHOVB of int - | PpHVB of int - | PpVB of int - | PpTB - (* unparsing objects *) type 'pat unparsing_hunk = @@ -212,29 +231,23 @@ let rec subst_hunk subst_pat subst hunk = match hunk with highest precedence), and the child's one, follow the given relation. *) -type tolerability = (string * precedence) * parenRelation - +(* let compare_prec (a1,b1,c1) (a2,b2,c2) = match (a1=a2),(b1=b2),(c1=c2) with | true,true,true -> 0 | true,true,false -> c1-c2 | true,false,_ -> b1-b2 | false,_,_ -> a1-a2 +*) +let compare_prec a1 a2 = a1-a2 -let tolerable_prec oparent_prec_reln (_,child_prec) = +let tolerable_prec oparent_prec_reln child_prec = match oparent_prec_reln with - | Some ((_,pprec), L) -> (compare_prec child_prec pprec) < 0 - | Some ((_,pprec), E) -> (compare_prec child_prec pprec) <= 0 + | Some (pprec, L) -> (compare_prec child_prec pprec) < 0 + | Some (pprec, E) -> (compare_prec child_prec pprec) <= 0 | Some (_, Prec level) -> (compare_prec child_prec level) <= 0 | _ -> true -let ppcmd_of_box = function - | PpHB n -> h n - | PpHOVB n -> hov n - | PpHVB n -> hv n - | PpVB n -> v n - | PpTB -> t - type 'pat syntax_entry = { syn_id : string; syn_prec: precedence; @@ -265,7 +278,7 @@ let subst_syntax_command subst_pat subst scomm = { scomm with sc_entries = sc_entries' } type syntax_rule = string * Coqast.t * Coqast.t unparsing_hunk list -type syntax_entry_ast = precedence * syntax_rule list +type raw_syntax_entry = precedence * syntax_rule list let rec interp_unparsing env = function | PH (ast,ext,pr) -> PH (Ast.val_of_ast env ast,ext,pr) diff --git a/parsing/extend.mli b/parsing/extend.mli index 7294a2bb0..13e3ee067 100644 --- a/parsing/extend.mli +++ b/parsing/extend.mli @@ -9,10 +9,20 @@ (*i $Id$ i*) (*i*) - open Pp +open Util +open Names open Ast open Coqast +open Ppextend +open Topconstr +open Genarg +(*i*) + +type entry_type = argument_type +type constr_entry_type = ETConstr | ETIdent | ETReference + +val entry_type_of_constr_entry_type : constr_entry_type -> entry_type type nonterm_prod = | ProdList0 of nonterm_prod @@ -22,16 +32,16 @@ type nonterm_prod = type prod_item = | Term of Token.pattern - | NonTerm of nonterm_prod * (string * ast_action_type) option + | NonTerm of nonterm_prod * (Names.identifier * constr_entry_type) option type grammar_rule = { gr_name : string; gr_production : prod_item list; - gr_action : Ast.act } + gr_action : aconstr } type grammar_entry = { ge_name : string; - ge_type : ast_action_type; + ge_type : constr_entry_type; gl_assoc : Gramext.g_assoc option; gl_rules : grammar_rule list } @@ -40,15 +50,27 @@ type grammar_command = { gc_entries : grammar_entry list } type grammar_associativity = Gramext.g_assoc option + +(* Globalisation and type-checking of Grammar actions *) +type entry_context = (identifier * constr_entry_type) list +val to_act_check_vars : entry_context -> grammar_action -> aconstr +val set_ast_to_rawconstr : (entry_context -> constr_expr -> aconstr) -> unit + +type syntax_modifier = + | SetItemLevel of string * int + | SetLevel of int + | SetAssoc of Gramext.g_assoc + | SetEntryType of string * constr_entry_type + type nonterm = | NtShort of string | NtQual of string * string type grammar_production = | VTerm of string - | VNonTerm of loc * nonterm * string option + | VNonTerm of loc * nonterm * Names.identifier option type raw_grammar_rule = string * grammar_production list * grammar_action type raw_grammar_entry = - string * ast_action_type * grammar_associativity * raw_grammar_rule list + string * constr_entry_type * grammar_associativity * raw_grammar_rule list val terminal : string -> string * string @@ -57,21 +79,6 @@ val rename_command : string -> string val subst_grammar_command : Names.substitution -> grammar_command -> grammar_command -(*s Pretty-print. *) - -(* Dealing with precedences *) - -type precedence = int * int * int - -type parenRelation = L | E | Any | Prec of precedence - -type ppbox = - | PpHB of int - | PpHOVB of int - | PpHVB of int - | PpVB of int - | PpTB - (* unparsing objects *) type 'pat unparsing_hunk = @@ -97,11 +104,7 @@ type 'pat unparsing_hunk = highest precedence), and the child's one, follow the given relation. *) -type tolerability = (string * precedence) * parenRelation - -val tolerable_prec : tolerability option -> (string * precedence) -> bool - -val ppcmd_of_box : ppbox -> std_ppcmds -> std_ppcmds +val tolerable_prec : tolerability option -> precedence -> bool type 'pat syntax_entry = { syn_id : string; @@ -123,11 +126,11 @@ val subst_syntax_command : Names.substitution -> 'pat syntax_command -> 'pat syntax_command type syntax_rule = string * Coqast.t * Coqast.t unparsing_hunk list -type syntax_entry_ast = precedence * syntax_rule list +type raw_syntax_entry = precedence * syntax_rule list val interp_grammar_command : - string -> (string * string -> entry_type) -> + string -> (string * string -> Genarg.argument_type) -> raw_grammar_entry list -> grammar_command val interp_syntax_entry : - string -> syntax_entry_ast list -> Ast.astpat syntax_command + string -> raw_syntax_entry list -> Ast.astpat syntax_command diff --git a/parsing/g_basevernac.ml4 b/parsing/g_basevernac.ml4 index 1d056cf5b..77f587894 100644 --- a/parsing/g_basevernac.ml4 +++ b/parsing/g_basevernac.ml4 @@ -6,12 +6,11 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(*i camlp4deps: "parsing/grammar.cma" i*) - (* $Id$ *) open Coqast open Extend +open Ppextend open Vernacexpr open Pcoq open Vernac_ @@ -25,7 +24,7 @@ GEXTEND Gram class_rawexpr: [ [ IDENT "FUNCLASS" -> FunClass | IDENT "SORTCLASS" -> SortClass - | qid = Prim.qualid -> RefClass qid ] ] + | qid = global -> RefClass qid ] ] ; END; @@ -54,9 +53,9 @@ GEXTEND Gram | IDENT "Dump"; IDENT "Universes"; fopt = OPT STRING -> VernacPrint (PrintUniverses fopt) - | IDENT "Locate"; qid = qualid -> VernacLocate (LocateTerm qid) + | IDENT "Locate"; qid = global -> VernacLocate (LocateTerm qid) | IDENT "Locate"; IDENT "File"; f = STRING -> VernacLocate (LocateFile f) - | IDENT "Locate"; IDENT "Library"; qid = qualid -> + | IDENT "Locate"; IDENT "Library"; qid = global -> VernacLocate (LocateLibrary qid) (* Managing load paths *) @@ -77,16 +76,16 @@ GEXTEND Gram (* Printing (careful factorization of entries) *) | IDENT "Print"; p = printable -> VernacPrint p - | IDENT "Print"; qid = qualid -> VernacPrint (PrintName qid) + | IDENT "Print"; qid = global -> VernacPrint (PrintName qid) | IDENT "Print" -> VernacPrint PrintLocalContext - | IDENT "Print"; IDENT "Module"; "Type"; qid = qualid -> + | IDENT "Print"; IDENT "Module"; "Type"; qid = global -> VernacPrint (PrintModuleType qid) - | IDENT "Print"; IDENT "Module"; qid = qualid -> + | IDENT "Print"; IDENT "Module"; qid = global -> VernacPrint (PrintModule qid) | IDENT "Inspect"; n = natural -> VernacPrint (PrintInspect n) (* Searching the environment *) - | IDENT "Search"; qid = Prim.qualid; l = in_or_out_modules -> + | IDENT "Search"; qid = global; l = in_or_out_modules -> VernacSearch (SearchHead qid, l) | IDENT "SearchPattern"; c = constr_pattern; l = in_or_out_modules -> VernacSearch (SearchPattern c, l) @@ -135,7 +134,7 @@ GEXTEND Gram | IDENT "Add"; table = IDENT; field = IDENT; v = LIST1 option_ref_value -> VernacAddOption (SecondaryTable (table,field), v) - (* Un value qualid ci-dessous va être caché par un field au dessus! *) + (* Un value global ci-dessous va être caché par un field au dessus! *) | IDENT "Add"; table = IDENT; v = LIST1 option_ref_value -> VernacAddOption (PrimaryTable table, v) @@ -155,7 +154,7 @@ GEXTEND Gram ; printable: [ [ IDENT "All" -> PrintFullContext - | IDENT "Section"; s = qualid -> PrintSectionContext s + | IDENT "Section"; s = global -> PrintSectionContext s | "Grammar"; uni = IDENT; ent = IDENT -> (* This should be in "syntax" section but is here for factorization*) PrintGrammar (uni, ent) @@ -170,9 +169,9 @@ GEXTEND Gram | IDENT "Coercion"; IDENT "Paths"; s = class_rawexpr; t = class_rawexpr -> PrintCoercionPaths (s,t) | IDENT "Tables" -> PrintTables - | "Proof"; qid = qualid -> PrintOpaqueName qid + | "Proof"; qid = global -> PrintOpaqueName qid | IDENT "Hint" -> PrintHintGoal - | IDENT "Hint"; qid = qualid -> PrintHint qid + | IDENT "Hint"; qid = global -> PrintHint qid | IDENT "Hint"; "*" -> PrintHintDb | IDENT "HintDb"; s = IDENT -> PrintHintDbName s ] ] ; @@ -181,15 +180,15 @@ GEXTEND Gram | s = STRING -> StringValue s ] ] ; option_ref_value: - [ [ id = qualid -> QualidRefValue id + [ [ id = global -> QualidRefValue id | s = STRING -> StringRefValue s ] ] ; as_dirpath: [ [ d = OPT [ "as"; d = dirpath -> d ] -> d ] ] ; in_or_out_modules: - [ [ IDENT "inside"; l = LIST1 qualid -> SearchInside l - | IDENT "outside"; l = LIST1 qualid -> SearchOutside l + [ [ IDENT "inside"; l = LIST1 global -> SearchInside l + | IDENT "outside"; l = LIST1 global -> SearchOutside l | -> SearchOutside [] ] ] ; END; @@ -218,48 +217,57 @@ GEXTEND Gram | "Syntax"; u = univ; el = LIST1 syntax_entry SEP ";" -> VernacSyntax (u,el) + | "Syntax"; IDENT "Extension"; s = STRING; + l = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ] + -> VernacSyntaxExtension (s,l) + | IDENT "Open"; IDENT "Scope"; sc = IDENT -> VernacOpenScope sc | IDENT "Delimiters"; left = STRING; sc = IDENT; right = STRING -> VernacDelimiters (sc,(left,right)) - | IDENT "Arguments"; IDENT "Scope"; qid = qualid; + | IDENT "Arguments"; IDENT "Scope"; qid = global; "["; scl = LIST0 opt_scope; "]" -> VernacArgumentsScope (qid,scl) - (* Faudrait une version de qualidarg dans Prim pour respecter l'ordre *) - | IDENT "Infix"; a = entry_prec; n = natural; op = STRING; p = qualid; + | IDENT "Infix"; a = entry_prec; n = natural; op = STRING; p = global; sc = OPT [ ":"; sc = IDENT -> sc ] -> VernacInfix (a,n,op,p,sc) - | IDENT "Distfix"; a = entry_prec; n = natural; s = STRING; p = qualid; + | IDENT "Distfix"; a = entry_prec; n = natural; s = STRING; p = global; sc = OPT [ ":"; sc = IDENT -> sc ] -> VernacDistfix (a,n,s,p,sc) | IDENT "Notation"; a = entry_prec; n = natural; s = STRING; c = constr; - precl = [ "("; l = LIST1 var_precedence SEP ","; ")" -> l | -> [] ]; - sc = OPT [ ":"; sc = IDENT -> sc ] -> - VernacNotation (a,n,s,c,precl,sc) + modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ]; + sc = OPT [ ":"; sc = IDENT -> sc ] -> + let a = match a with None -> Gramext.LeftA | Some a -> a in + VernacNotation (s,c,(SetAssoc a)::(SetLevel n)::modl,sc) (* "Print" "Grammar" should be here but is in "command" entry in order to factorize with other "Print"-based vernac entries *) ] ] ; - var_precedence: - [ [ x = IDENT; IDENT "at"; IDENT "level"; n = natural -> (x,n) ] ] + syntax_modifier: + [ [ x = IDENT; IDENT "at"; IDENT "level"; n = natural -> SetItemLevel (x,n) + | IDENT "at"; IDENT "level"; n = natural -> SetLevel n + | IDENT "left"; IDENT "associativity" -> SetAssoc Gramext.LeftA + | IDENT "right"; IDENT "associativity" -> SetAssoc Gramext.RightA + | IDENT "no"; IDENT "associativity" -> SetAssoc Gramext.NonA + | x = IDENT; typ = syntax_extension_type -> SetEntryType (x,typ) ] ] + ; + syntax_extension_type: + [ [ IDENT "ident" -> ETIdent | IDENT "global" -> ETReference ] ] ; opt_scope: [ [ IDENT "_" -> None | sc = IDENT -> Some sc ] ] ; (* Syntax entries for Grammar. Only grammar_entry is exported *) grammar_entry: - [[ nont = located_ident; etyp = set_entry_type; ":="; + [[ nont = IDENT; etyp = set_entry_type; ":="; ep = entry_prec; OPT "|"; rl = LIST0 grammar_rule SEP "|" -> (nont,etyp,ep,rl) ]] ; - located_ident: - [[ id = IDENT -> (loc,id) ]] - ; entry_prec: [[ IDENT "LEFTA" -> Some Gramext.LeftA | IDENT "RIGHTA" -> Some Gramext.RightA | IDENT "NONA" -> Some Gramext.NonA - | -> None ]] + | -> None ]] ; grammar_tactic_rule: [[ name = rule_name; "["; s = STRING; pil = LIST0 production_item; "]"; @@ -274,9 +282,9 @@ GEXTEND Gram ; production_item: [[ s = STRING -> VTerm s - | nt = non_terminal; po = OPT [ "("; p = Prim.metaident; ")" -> p ] -> + | nt = non_terminal; po = OPT [ "("; p = METAIDENT; ")" -> p ] -> match po with - | Some p -> VNonTerm (loc,nt,Some (Ast.meta_of_ast p)) + | Some p -> VNonTerm (loc,nt,Some (Names.id_of_string p)) | _ -> VNonTerm (loc,nt,None) ]] ; non_terminal: @@ -294,8 +302,9 @@ GEXTEND Gram [ [ nm = IDENT; "["; s = astpat; "]"; "->"; u = unparsing -> (nm,s,u) ] ] ; precedence: - [ [ a = natural -> (a,0,0) - | "["; a1 = natural; a2 = natural; a3 = natural; "]" -> (a1,a2,a3) ] ] + [ [ a = natural -> a +(* | "["; a1 = natural; a2 = natural; a3 = natural; "]" -> (a1,a2,a3)*) + ] ] ; unparsing: [ [ "["; ll = LIST0 next_hunks; "]" -> ll ] ] @@ -313,7 +322,8 @@ GEXTEND Gram | e = Prim.ast; oprec = OPT [ ":"; pr = paren_reln_or_extern -> pr ] -> match oprec with | Some (ext,pr) -> PH (e,ext,pr) - | None -> PH (e,None,Any) ]] + | None -> PH (e,None,Any) + ]] ; box: [ [ "<"; bk = box_kind; ">" -> bk ] ] @@ -335,11 +345,11 @@ GEXTEND Gram ; (* meta-syntax entries *) astpat: - [ [ "<<" ; a = Prim.ast; ">>" -> a - | a = default_action_parser -> - match a with - | Ast.PureAstNode a -> a - | _ -> failwith "Cannot deal with non pure ast expression" ] ] + [ [ "<<" ; a = Prim.ast; ">>" -> a + | a = Constr.constr -> + Termast.ast_of_rawconstr + (Constrintern.interp_rawconstr Evd.empty (Global.env()) a) + ] ] ; action: [ [ IDENT "let"; p = Prim.astlist; et = set_internal_entry_type; @@ -356,15 +366,20 @@ GEXTEND Gram | [ ":"; IDENT "ast" -> () | -> () ] -> Ast.ETast ]] ; set_entry_type: - [[ ":"; et = entry_type -> set_default_action_parser et; entry_type_of_parser et - | -> None ]] + [[ ":"; et = entry_type -> set_default_action_parser et; + let a = match et with + | ConstrParser -> ETConstr + | CasesPatternParser -> + failwith "entry_type_of_parser: cases_pattern, TODO" in + a + | -> ETConstr ]] ; entry_type: - [[ IDENT "ast"; IDENT "list" -> AstListParser - | IDENT "ast" -> AstParser + [[ IDENT "ast"; IDENT "list" -> Util.error "type ast list no longer supported" + | IDENT "ast" -> Util.error "type ast no longer supported" | IDENT "constr" -> ConstrParser - | IDENT "cases_pattern" -> CasesPatternParser - | IDENT "tactic" -> TacticParser - | IDENT "vernac" -> VernacParser ]] + | IDENT "pattern" -> CasesPatternParser + | IDENT "tactic" -> assert false + | IDENT "vernac" -> Util.error "vernac extensions no longer supported" ] ] ; END diff --git a/parsing/g_cases.ml4 b/parsing/g_cases.ml4 index e84a89092..67b6165da 100644 --- a/parsing/g_cases.ml4 +++ b/parsing/g_cases.ml4 @@ -6,66 +6,63 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(*i camlp4deps: "parsing/grammar.cma" i*) - (* $Id$ *) open Pcoq open Constr +open Topconstr +open Term +open Libnames + +open Prim + +let pair loc = + Qualid (loc, Libnames.qualid_of_string "Coq.Init.Datatypes.pair") GEXTEND Gram GLOBAL: constr1 pattern; pattern: - [ [ qid = global -> qid + [ [ r = Prim.reference -> CPatAtom (loc,Some r) + | IDENT "_" -> CPatAtom (loc,None) (* Hack to parse syntax "(n)" as a natural number *) | "("; G_constr.test_int_rparen; n = INT; ")" -> - let n = Coqast.Str (loc,n) in - <:ast< (PATTDELIMITERS "nat_scope" (PATTNUMERAL $n)) >> + let n = CPatNumeral (loc,Bignat.POS (Bignat.of_string n)) in + CPatDelimiters (loc,"nat_scope",n) | "("; p = compound_pattern; ")" -> p - | n = INT -> - let n = Coqast.Str (loc,n) in <:ast< (PATTNUMERAL $n) >> - | "-"; n = INT -> - let n = Coqast.Str (loc,n) in <:ast< (PATTNEGNUMERAL $n) >> + | n = INT -> CPatNumeral (loc,Bignat.POS (Bignat.of_string n)) + | "-"; n = INT -> CPatNumeral (loc,Bignat.NEG (Bignat.of_string n)) ] ] ; compound_pattern: - [ [ p = pattern ; lp = ne_pattern_list -> + [ [ p = pattern ; lp = LIST1 pattern -> (match p with - | Coqast.Node(_,"QUALID",_) -> () + | CPatAtom (_, Some r) -> CPatCstr (loc, r, lp) | _ -> Util.user_err_loc - (loc, "compound_pattern", Pp.str "Constructor expected")); - <:ast< (PATTCONSTRUCT $p ($LIST $lp)) >> - | p = pattern; "as"; id = Prim.var -> - <:ast< (PATTAS $id $p)>> + (loc, "compound_pattern", Pp.str "Constructor expected")) + | p = pattern; "as"; id = base_ident -> + CPatAlias (loc, p, id) | p1 = pattern; ","; p2 = pattern -> - <:ast< (PATTCONSTRUCT Coq.Init.Datatypes.pair $p1 $p2) >> + CPatCstr (loc, pair loc, [p1; p2]) | p = pattern -> p ] ] ; - ne_pattern_list: - [ [ c1 = pattern; cl = ne_pattern_list -> c1 :: cl - | c1 = pattern -> [c1] ] ] - ; equation: - [ [ lhs = ne_pattern_list; "=>"; rhs = constr9 -> - <:ast< (EQN $rhs ($LIST $lhs)) >> ] ] + [ [ lhs = LIST1 pattern; "=>"; rhs = constr9 -> (loc,lhs,rhs) ] ] ; ne_eqn_list: - [ [ e = equation; "|"; leqn = ne_eqn_list -> e :: leqn - | e = equation -> [e] ] ] + [ [ leqn = LIST1 equation SEP "|" -> leqn ] ] ; constr1: - [ [ "<"; l1 = lconstr; ">"; "Cases"; lc = ne_constr_list; "of"; + [ [ "<"; p = lconstr; ">"; "Cases"; lc = LIST1 constr; "of"; OPT "|"; eqs = ne_eqn_list; "end" -> - <:ast< (CASES $l1 (TOMATCH ($LIST $lc)) ($LIST $eqs)) >> + CCases (loc, Some p, lc, eqs) | "Cases"; lc = ne_constr_list; "of"; OPT "|"; eqs = ne_eqn_list; "end" -> - <:ast< (CASES "SYNTH" (TOMATCH ($LIST $lc)) ($LIST $eqs)) >> - | "<"; l1 = lconstr; ">"; "Cases"; lc = ne_constr_list; "of"; - "end" -> - <:ast< (CASES $l1 (TOMATCH ($LIST $lc))) >> + CCases (loc, None, lc, eqs) + | "<"; p = lconstr; ">"; "Cases"; lc = ne_constr_list; "of"; "end" -> + CCases (loc, Some p, lc, []) | "Cases"; lc = ne_constr_list; "of"; "end" -> - <:ast< (CASES "SYNTH" (TOMATCH ($LIST $lc))) >> ] ] + CCases (loc, None, lc, []) ] ] ; END; diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index 620b6a800..057494597 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -6,12 +6,60 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(*i camlp4deps: "parsing/grammar.cma" i*) - (* $Id$ *) open Pcoq open Constr +open Rawterm +open Term +open Names +open Libnames +open Prim +open Topconstr + +(* For the very old syntax of fixpoints *) +let split_lambda = function + | CLambdaN (loc,[[na],t],c) -> (na,t,c) + | CLambdaN (loc,([na],t)::bl,c) -> (na,t,CLambdaN(loc,bl,c)) + | CLambdaN (loc,(na::nal,t)::bl,c) -> (na,t,CLambdaN(loc,(nal,t)::bl,c)) + | _ -> Util.error "ill-formed fixpoint body" + +let split_product = function + | CArrow (loc,t,c) -> c + | CProdN (loc,[[na],t],c) -> c + | CProdN (loc,([na],t)::bl,c) -> CProdN(loc,bl,c) + | CProdN (loc,(na::nal,t)::bl,c) -> CProdN(loc,(nal,t)::bl,c) + | _ -> Util.error "ill-formed fixpoint body" + +let rec split_fix n typ def = + if n = 0 then ([],typ,def) + else + let (na,t,def) = split_lambda def in + let typ = split_product typ in + let (bl,typ,def) = split_fix (n-1) typ def in + (([na],t)::bl,typ,def) + +let coerce_to_var = function + | CRef (Ident (_,id)) -> id + | ast -> Util.user_err_loc + (constr_loc ast,"Ast.coerce_to_var", + (Pp.str"This expression should be a simple identifier")) + +let coerce_to_name = function + | CRef (Ident (loc,id)) -> (loc, Name id) + | ast -> Util.user_err_loc + (constr_loc ast,"Ast.coerce_to_var", + (Pp.str"This expression should be a simple identifier")) + +open Util + +let rec abstract_constr loc c = function + | [] -> c + | LocalRawDef ((loc',x),b)::bl -> + CLetIn (join_loc loc' loc, (loc', x), b, abstract_constr loc c bl) + | LocalRawAssum (nal,t)::bl -> + let loc' = join_loc (fst (List.hd nal)) loc in + CLambdaN(loc', [nal, t], abstract_constr loc c bl) (* Hack to parse "(n)" as nat without conflicts with the (useless) *) (* admissible notation "(n)" *) @@ -30,40 +78,22 @@ let test_int_rparen = GEXTEND Gram GLOBAL: constr0 constr1 constr2 constr3 lassoc_constr4 constr5 constr6 constr7 constr8 constr9 constr10 lconstr constr - ne_ident_comma_list ne_constr_list sort ne_binders_list qualid - global constr_pattern ident numarg; - ident: - [ [ id = Prim.var -> id + ne_name_comma_list ne_constr_list sort + global constr_pattern Constr.ident; + Constr.ident: + [ [ id = Prim.ident -> id - (* This is used in quotations *) - | id = Prim.metaident -> id ] ] + (* This is used in quotations and Syntax *) + | id = METAIDENT -> id_of_string id ] ] ; global: - [ [ l = qualid -> l + [ [ r = Prim.reference -> r (* This is used in quotations *) - | id = Prim.metaident -> id ] ] - ; - qualid: - [ [ id = Prim.var; l = fields -> <:ast< (QUALID $id ($LIST $l)) >> - | id = Prim.var -> <:ast< (QUALID $id) >> - ] ] - ; - fields: - [ [ id = FIELD; l = fields -> <:ast< ($VAR $id) >> :: l - | id = FIELD -> [ <:ast< ($VAR $id) >> ] - ] ] - ; - raw_constr: - [ [ c = Prim.ast -> c ] ] + | id = METAIDENT -> Ident (loc,id_of_string id) ] ] ; constr: - [ [ c = constr8 -> (* Genarg.ConstrTerm *) c -(* | IDENT "Inst"; id = Prim.rawident; "["; c = constr; "]" -> - Genarg.ConstrContext (id, c) - | IDENT "Eval"; rtc = Tactic.raw_red_tactic; "in"; c = constr -> - Genarg.ConstrEval (rtc,c) - | IDENT "Check"; c = constr8 -> <:ast<(CHECK $c)>> *)] ] + [ [ c = constr8 -> c ] ] ; lconstr: [ [ c = constr10 -> c ] ] @@ -72,101 +102,85 @@ GEXTEND Gram [ [ c = constr -> c ] ] ; ne_constr_list: - [ [ c1 = constr; cl = ne_constr_list -> c1::cl - | c1 = constr -> [c1] ] ] + [ [ cl = LIST1 constr -> cl ] ] ; sort: - [ [ "Set" -> <:ast< (SET) >> - | "Prop" -> <:ast< (PROP) >> - | "Type" -> <:ast< (TYPE) >> ] ] + [ [ "Set" -> RProp Pos + | "Prop" -> RProp Null + | "Type" -> RType None ] ] ; constr0: - [ [ "?" -> <:ast< (ISEVAR) >> - | "?"; n = Prim.natural -> - let n = Coqast.Num (loc,n) in <:ast< (META $n) >> - | bl = binders; c = constr -> <:ast< ($ABSTRACT "LAMBDALIST" $bl $c) >> + [ [ "?" -> CHole loc + | "?"; n = Prim.natural -> CMeta (loc, n) + | bll = binders; c = constr -> abstract_constr loc c bll (* Hack to parse syntax "(n)" as a natural number *) | "("; test_int_rparen; n = INT; ")" -> - let n = Coqast.Str (loc,n) in - <:ast< (DELIMITERS "nat_scope" (NUMERAL $n)) >> - | "("; lc1 = lconstr; ":"; c = constr; body = product_tail -> - let id = Ast.coerce_to_var lc1 in - <:ast< (PROD $c [$id]$body) >> + let n = CNumeral (loc,Bignat.POS (Bignat.of_string n)) in + CDelimiters (loc,"nat_scope",n) + | "("; lc1 = lconstr; ":"; c = constr; (bl,body) = product_tail -> + let id = coerce_to_name lc1 in + CProdN (loc, ([id], c)::bl, body) +(* TODO: Syntaxe (_:t...)t et (_,x...)t *) | "("; lc1 = lconstr; ","; lc2 = lconstr; ":"; c = constr; - body = product_tail -> - let id1 = Ast.coerce_to_var lc1 in - let id2 = Ast.coerce_to_var lc2 in - <:ast< (PRODLIST $c [$id1][$id2]$body) >> + (bl,body) = product_tail -> + let id1 = coerce_to_name lc1 in + let id2 = coerce_to_name lc2 in + CProdN (loc, ([id1; id2], c)::bl, body) | "("; lc1 = lconstr; ","; lc2 = lconstr; ","; - idl = ne_ident_comma_list; ":"; c = constr; body = product_tail -> - let id1 = Ast.coerce_to_var lc1 in - let id2 = Ast.coerce_to_var lc2 in -(* <:ast< (PRODLIST $c [$id1][$id2]($SLAM $idl $body)) >>*) - <:ast< ($ABSTRACT "PRODLIST" (BINDERS (BINDER $c $id1 $id2 ($LIST $idl))) $body) >> + idl = ne_name_comma_list; ":"; c = constr; (bl,body) = product_tail -> + let id1 = coerce_to_name lc1 in + let id2 = coerce_to_name lc2 in + CProdN (loc, (id1::id2::idl, c)::bl, body) | "("; lc1 = lconstr; ")" -> lc1 | "("; lc1 = lconstr; ")"; "@"; "["; cl = ne_constr_list; "]" -> - <:ast< (SOAPP $lc1 ($LIST $cl)) >> - | IDENT "Fix"; id = ident; "{"; fbinders = fixbinders; "}" -> - <:ast< (FIX $id ($LIST $fbinders)) >> - | IDENT "CoFix"; id = ident; "{"; fbinders = cofixbinders; "}" -> - <:ast< (COFIX $id ($LIST $fbinders)) >> - | s = sort -> s - | v = global -> v - | n = INT -> - let n = Coqast.Str (loc,n) in <:ast< (NUMERAL $n) >> - | "-"; n = INT -> - let n = Coqast.Str (loc,n) in <:ast< (NEGNUMERAL $n) >> - | "!"; f = global -> - <:ast< (APPLISTEXPL $f) >> - ] ] + (match lc1 with + | CMeta (loc2,n) -> + CApp (loc,CMeta (loc2, -n), List.map (fun c -> c, None) cl) + | _ -> + Util.error "Second-order pattern-matching expects a head metavariable") + | IDENT "Fix"; id = identref; "{"; fbinders = fixbinders; "}" -> + CFix (loc, id, fbinders) + | IDENT "CoFix"; id = identref; "{"; fbinders = cofixbinders; "}" -> + CCoFix (loc, id, fbinders) + | s = sort -> CSort (loc, s) + | v = global -> CRef v + | n = INT -> CNumeral (loc,Bignat.POS (Bignat.of_string n)) + | "-"; n = INT -> CNumeral (loc,Bignat.NEG (Bignat.of_string n)) + | "!"; f = global -> CAppExpl (loc,f,[]) + ] ] ; constr1: - [ [ "<"; ":"; IDENT "ast"; ":"; "<"; c = raw_constr; ">>" -> c - | "<"; l1 = lconstr; ">"; IDENT "Match"; c = constr; "with"; - cl = ne_constr_list; "end" -> - <:ast< (MATCH $l1 $c ($LIST $cl)) >> - | "<"; l1 = lconstr; ">"; IDENT "Match"; c = constr; "with"; "end" - -> - <:ast< (MATCH $l1 $c) >> - | "<"; l1 = lconstr; ">"; IDENT "Case"; c = constr; "of"; - cl = ne_constr_list; "end" -> - <:ast< (CASE $l1 $c ($LIST $cl)) >> - | "<"; l1 = lconstr; ">"; IDENT "Case"; c = constr; "of"; "end" -> - <:ast< (CASE $l1 $c) >> - | IDENT "Case"; c = constr; "of"; cl = ne_constr_list; "end" -> - <:ast< (CASE "SYNTH" $c ($LIST $cl)) >> - | IDENT "Case"; c = constr; "of"; "end" -> - <:ast< (CASE "SYNTH" $c) >> - | IDENT "Match"; c = constr; "with"; cl = ne_constr_list; "end" -> - <:ast< (MATCH "SYNTH" $c ($LIST $cl)) >> - | IDENT "let"; "("; b = ne_ident_comma_list; ")"; "="; + [ [ "<"; p = lconstr; ">"; IDENT "Match"; c = constr; "with"; + cl = LIST0 constr; "end" -> + COrderedCase (loc, MatchStyle, Some p, c, cl) + | "<"; p = lconstr; ">"; IDENT "Case"; c = constr; "of"; + cl = LIST0 constr; "end" -> + COrderedCase (loc, RegularStyle, Some p, c, cl) + | IDENT "Case"; c = constr; "of"; cl = LIST0 constr; "end" -> + COrderedCase (loc, RegularStyle, None, c, cl) + | IDENT "Match"; c = constr; "with"; cl = LIST1 constr; "end" -> + COrderedCase (loc, MatchStyle, None, c, cl) + | IDENT "let"; "("; b = ne_name_comma_list; ")"; "="; c = constr; "in"; c1 = constr-> - <:ast< (LET "SYNTH" $c ($ABSTRACT "LAMBDALIST" - (BINDERS (BINDER (ISEVAR) ($LIST $b))) $c1)) >> - | IDENT "let"; id1 = ident ; "="; c = opt_casted_constr; - "in"; c1 = constr -> - <:ast< (LETIN $c [$id1]$c1) >> -(* - | IDENT "let"; id1 = ident ; "="; c = opt_casted_constr; - "in"; c1 = constr -> - <:ast< (LETIN $c [$id1]$c1) >> -*) + (* TODO: right loc *) + COrderedCase + (loc, LetStyle, None, c, [CLambdaN (loc, [b, CHole loc], c1)]) + | IDENT "let"; na = name; "="; c = opt_casted_constr; "in"; c1 = constr + -> CLetIn (loc, na, c, c1) | IDENT "if"; c1 = constr; IDENT "then"; c2 = constr; IDENT "else"; c3 = constr -> - <:ast< ( IF "SYNTH" $c1 $c2 $c3) >> -(* EN ATTENTE DE REMPLACER CE QUI EST DANS Program.v ... *) - | "<"; l1 = lconstr; ">"; - IDENT "let"; "("; b = ne_ident_comma_list; ")"; "="; + COrderedCase (loc, IfStyle, None, c1, [c2; c3]) + | "<"; p = lconstr; ">"; + IDENT "let"; "("; b = ne_name_comma_list; ")"; "="; c = constr; "in"; c1 = constr -> -(* <:ast< (CASE "NOREC" $l1 $c (LAMBDALIST (ISEVAR) ($SLAM $b $c1))) >>*) - <:ast< (LET $l1 $c ($ABSTRACT "LAMBDALIST" (BINDERS - (BINDER (ISEVAR) ($LIST $b))) $c1)) >> - | "<"; l1 = lconstr; ">"; + (* TODO: right loc *) + COrderedCase (loc, LetStyle, Some p, c, + [CLambdaN (loc, [b, CHole loc], c1)]) + | "<"; p = lconstr; ">"; IDENT "if"; c1 = constr; IDENT "then"; c2 = constr; IDENT "else"; c3 = constr -> - <:ast< (IF $l1 $c1 $c2 $c3) >> - | c = constr0 -> c - ] ] + COrderedCase (loc, IfStyle, Some p, c1, [c2; c3]) + | c = constr0 -> c ] ] ; constr2: (* ~ will be here *) [ [ c = constr1 -> c ] ] @@ -188,113 +202,98 @@ GEXTEND Gram ; constr8: (* <-> will be here *) [ [ c1 = constr7 -> c1 - | c1 = constr7; "->"; c2 = constr8 -> <:ast< (PROD $c1 [<>]$c2) >> ] ] + | c1 = constr7; "->"; c2 = constr8 -> CArrow (loc, c1, c2) ] ] ; constr9: [ [ c1 = constr8 -> c1 - | c1 = constr8; "::"; c2 = constr8 -> <:ast< (CAST $c1 $c2) >> ] ] - ; - numarg: - [ [ n = Prim.natural -> Coqast.Num (loc, n) ] ] - ; - simple_binding: - [ [ id = ident; ":="; c = constr -> <:ast< (BINDING $id $c) >> - | n = numarg; ":="; c = constr -> <:ast< (BINDING $n $c) >> ] ] - ; - simple_binding_list: - [ [ b = simple_binding; l = simple_binding_list -> b :: l | -> [] ] ] - ; - binding_list: - [ [ c1 = constr; ":="; c2 = constr; bl = simple_binding_list -> - Coqast.Node - (loc, "EXPLICITBINDINGS", - (Coqast.Node (loc, "BINDING", [Ast.coerce_to_var c1; c2]) :: bl)) - | n = numarg; ":="; c = constr; bl = simple_binding_list -> - <:ast<(EXPLICITBINDINGS (BINDING $n $c) ($LIST $bl))>> - | c1 = constr; bl = LIST0 constr -> - <:ast<(IMPLICITBINDINGS $c1 ($LIST $bl))>> ] ] + | c1 = constr8; "::"; c2 = constr8 -> CCast (loc, c1, c2) ] ] ; constr10: - [ [ "!"; f = global; args = LIST0 constr9 -> - <:ast< (APPLISTEXPL $f ($LIST $args)) >> + [ [ "!"; f = global; args = LIST0 constr9 -> CAppExpl (loc, f, args) +(* | "!"; f = global; "with"; b = binding_list -> <:ast< (APPLISTWITH $f $b) >> - | f = constr9; args = LIST1 constr91 -> - <:ast< (APPLIST $f ($LIST $args)) >> +*) + | f = constr9; args = LIST1 constr91 -> CApp (loc, f, args) | f = constr9 -> f ] ] ; - ne_ident_comma_list: - [ [ id = ident; ","; idl = ne_ident_comma_list -> id :: idl - | id = ident -> [id] ] ] + ne_name_comma_list: + [ [ nal = LIST1 name SEP "," -> nal ] ] ; - ident_comma_list_tail: - [ [ ","; idl = ne_ident_comma_list -> idl + name_comma_list_tail: + + [ [ ","; idl = ne_name_comma_list -> idl | -> [] ] ] ; opt_casted_constr: - [ [ c = constr; ":"; t = constr -> <:ast< (CAST $c $t) >> + [ [ c = constr; ":"; t = constr -> CCast (loc, c, t) | c = constr -> c ] ] ; - vardecls: (* This is interpreted by Pcoq.abstract_binder *) - [ [ id = ident; idl = ident_comma_list_tail; c = type_option -> - <:ast< (BINDER $c $id ($LIST $idl)) >> - | id = ident; ":="; c = opt_casted_constr -> - <:ast< (LETIN $c $id) >> - | id = ident; "="; c = opt_casted_constr -> - <:ast< (LETIN $c $id) >> ] ] + vardecls: + [ [ na = name; nal = name_comma_list_tail; c = type_option -> + LocalRawAssum (na::nal,c) + | na = name; "="; c = opt_casted_constr -> + LocalRawDef (na, c) + | na = name; ":="; c = opt_casted_constr -> + LocalRawDef (na, c) + + (* This is used in quotations *) + | id = METAIDENT; c = type_option -> LocalRawAssum ([loc, Name (id_of_string id)], c) + ] ] ; ne_vardecls_list: [ [ id = vardecls; ";"; idl = ne_vardecls_list -> id :: idl | id = vardecls -> [id] ] ] ; binders: - [ [ "["; bl = ne_vardecls_list; "]" -> <:ast< (BINDERS ($LIST $bl)) >> ] ] - ; - rawbinders: [ [ "["; bl = ne_vardecls_list; "]" -> bl ] ] ; - ne_binders_list: - [ [ bl = rawbinders; bll = ne_binders_list -> bl @ bll - | bl = rawbinders -> bl ] ] + simple_params: + [ [ idl = LIST1 name SEP ","; ":"; c = constr -> (idl, c) + | idl = LIST1 name SEP "," -> (idl, CHole loc) + ] ] + ; + simple_binders: + [ [ "["; bll = LIST1 simple_params SEP ";"; "]" -> bll ] ] + ; + ne_simple_binders_list: + [ [ bll = LIST1 simple_binders -> List.flatten bll ] ] ; type_option: [ [ ":"; c = constr -> c - | -> <:ast< (ISEVAR) >> ] ] + | -> CHole loc ] ] ; constr91: - [ [ n = INT; "!"; c1 = constr9 -> - let n = Coqast.Num (loc,int_of_string n) in <:ast< (EXPL $n $c1) >> - | n = INT -> - let n = Coqast.Str (loc,n) in <:ast< (NUMERAL $n) >> - | c1 = constr9 -> c1 ] ] + [ [ n = natural; "!"; c = constr9 -> (c, Some n) + | n = natural -> + (CNumeral (loc, Bignat.POS (Bignat.of_string (string_of_int n))), None) + | c = constr9 -> (c, None) ] ] ; fixbinder: - [ [ id = ident; "/"; recarg = Prim.natural; ":"; type_ = constr; - ":="; def = constr -> - let recarg = Coqast.Num (loc,recarg) in - <:ast< (NUMFDECL $id $recarg $type_ $def) >> - | id = ident; bl = ne_binders_list; ":"; type_ = constr; + [ [ id = base_ident; "/"; recarg = natural; ":"; type_ = constr; ":="; def = constr -> - <:ast< (FDECL $id (BINDERS ($LIST $bl)) $type_ $def) >> ] ] + Options.if_verbose Pp.warning + "Checking of the fixpoint type not done for very-old-style fixpoint"; + let (bl, typ, def) = split_fix recarg type_ def in (id, bl, typ, def) + | id = base_ident; bl = ne_simple_binders_list; ":"; type_ = constr; + ":="; def = constr -> + (id, bl, type_, def) ] ] ; fixbinders: - [ [ fb = fixbinder; "with"; fbs = fixbinders -> fb::fbs - | fb = fixbinder -> [fb] ] ] + [ [ fbs = LIST1 fixbinder SEP "with" -> fbs ] ] ; cofixbinder: - [ [ id = ident; ":"; type_ = constr; ":="; def = constr -> - <:ast< (CFDECL $id $type_ $def) >> ] ] + [ [ id = base_ident; ":"; type_ = constr; ":="; def = constr -> + (id, type_, def) ] ] ; cofixbinders: - [ [ fb = cofixbinder; "with"; fbs = cofixbinders -> fb::fbs - | fb = cofixbinder -> [fb] ] ] + [ [ fbs = LIST1 cofixbinder SEP "with" -> fbs ] ] ; product_tail: - [ [ ";"; idl = ne_ident_comma_list; - ":"; c = constr; c2 = product_tail -> - <:ast< ($ABSTRACT "PRODLIST" (BINDERS (BINDER $c ($LIST $idl))) $c2) >> - | ";"; idl = ne_ident_comma_list; c2 = product_tail -> - <:ast< ($ABSTRACT "PRODLIST" (BINDERS (BINDER (ISEVAR) ($LIST $idl))) $c2) >> - | ")"; c = constr -> c ] ] + [ [ ";"; idl = ne_name_comma_list; ":"; c = constr; + (bl,c2) = product_tail -> ((idl, c)::bl, c2) + | ";"; idl = ne_name_comma_list; (bl,c2) = product_tail -> + ((idl, CHole (fst (List.hd idl)))::bl, c2) + | ")"; c = constr -> ([], c) ] ] ; END;; diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4 index a7c37160a..21206e6db 100644 --- a/parsing/g_ltac.ml4 +++ b/parsing/g_ltac.ml4 @@ -6,14 +6,12 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(*i camlp4deps: "parsing/grammar.cma" i*) - (* $Id$ *) open Pp open Util open Ast -open Coqast +open Topconstr open Rawterm open Tacexpr open Ast @@ -23,15 +21,16 @@ open Qast else open Pcoq +open Prim open Tactic ifdef Quotify then open Q type let_clause_kind = - | LETTOPCLAUSE of Names.identifier * Genarg.constr_ast + | LETTOPCLAUSE of Names.identifier * constr_expr | LETCLAUSE of - (Names.identifier Util.located * Genarg.constr_ast may_eval option * raw_tactic_arg) + (Names.identifier Util.located * constr_expr may_eval option * raw_tactic_arg) ifdef Quotify then module Prelude = struct @@ -69,20 +68,20 @@ GEXTEND Gram GLOBAL: tactic_atom tactic_atom0 tactic_expr input_fun; *) input_fun: - [ [ l = Prim.ident -> Some l + [ [ l = base_ident -> Some l | "()" -> None ] ] ; let_clause: - [ [ id = Prim.rawident; "="; te = tactic_letarg -> LETCLAUSE (id, None, te) - | id = Prim.ident; ":"; c = Constr.constr; ":="; "Proof" -> + [ [ id = identref; "="; te = tactic_letarg -> LETCLAUSE (id, None, te) + | id = base_ident; ":"; c = Constr.constr; ":="; "Proof" -> LETTOPCLAUSE (id, c) - | id = Prim.rawident; ":"; c = constrarg; ":="; te = tactic_letarg -> + | id = identref; ":"; c = constrarg; ":="; te = tactic_letarg -> LETCLAUSE (id, Some c, te) - | id = Prim.ident; ":"; c = Constr.constr -> + | id = base_ident; ":"; c = Constr.constr -> LETTOPCLAUSE (id, c) ] ] ; rec_clause: - [ [ name = Prim.rawident; it = LIST1 input_fun; "->"; body = tactic_expr -> + [ [ name = identref; it = LIST1 input_fun; "->"; body = tactic_expr -> (name,(it,body)) ] ] ; match_pattern: @@ -92,7 +91,7 @@ GEXTEND Gram | pc = Constr.constr_pattern -> Term pc ] ] ; match_hyps: - [ [ id = Prim.rawident; ":"; mp = match_pattern -> Hyp (id, mp) + [ [ id = identref; ":"; mp = match_pattern -> Hyp (id, mp) | IDENT "_"; ":"; mp = match_pattern -> NoHypId mp ] ] ; match_context_rule: @@ -126,7 +125,7 @@ GEXTEND Gram ; tactic_expr3: [ [ IDENT "Try"; ta = tactic_expr3 -> TacTry ta - | IDENT "Do"; n = Prim.natural; ta = tactic_expr3 -> TacDo (n,ta) + | IDENT "Do"; n = natural; ta = tactic_expr3 -> TacDo (n,ta) | IDENT "Repeat"; ta = tactic_expr3 -> TacRepeat ta | IDENT "Progress"; ta = tactic_expr3 -> TacProgress ta | IDENT "Info"; tc = tactic_expr3 -> TacInfo tc @@ -179,7 +178,7 @@ GEXTEND Gram TacMatch (c,mrl) (*To do: put Abstract in Refiner*) | IDENT "Abstract"; tc = tactic_expr -> TacAbstract (tc,None) - | IDENT "Abstract"; tc = tactic_expr; "using"; s = Prim.ident -> + | IDENT "Abstract"; tc = tactic_expr; "using"; s = base_ident -> TacAbstract (tc,Some s) (*End of To do*) | IDENT "First" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> @@ -188,7 +187,7 @@ GEXTEND Gram TacSolve l | IDENT "Idtac" -> TacId | IDENT "Fail" -> TacFail fail_default_value - | IDENT "Fail"; n = Prim.natural -> TacFail n + | IDENT "Fail"; n = natural -> TacFail n | st = simple_tactic -> TacAtom (loc,st) | "("; a = tactic_expr; ")" -> a | a = tactic_arg -> TacArg a @@ -203,7 +202,7 @@ GEXTEND Gram parsed as lqualid! *) [ [ IDENT "Eval"; rtc = red_expr; "in"; c = Constr.constr -> ConstrMayEval (ConstrEval (rtc,c)) - | IDENT "Inst"; id = Prim.rawident; "["; c = Constr.constr; "]" -> + | IDENT "Inst"; id = identref; "["; c = Constr.constr; "]" -> ConstrMayEval (ConstrContext (id,c)) | IDENT "Check"; c = Constr.constr -> ConstrMayEval (ConstrTypeOf c) @@ -213,7 +212,7 @@ GEXTEND Gram tactic_arg1: [ [ IDENT "Eval"; rtc = red_expr; "in"; c = Constr.constr -> ConstrMayEval (ConstrEval (rtc,c)) - | IDENT "Inst"; id = Prim.rawident; "["; c = Constr.constr; "]" -> + | IDENT "Inst"; id = identref; "["; c = Constr.constr; "]" -> ConstrMayEval (ConstrContext (id,c)) | IDENT "Check"; c = Constr.constr -> ConstrMayEval (ConstrTypeOf c) @@ -225,14 +224,14 @@ GEXTEND Gram [ [ "("; a = tactic_expr; ")" -> Tacexp a | "()" -> TacVoid | qid = lqualid -> Reference qid - | n = Prim.integer -> Integer n + | n = integer -> Integer n | id = METAIDENT -> MetaIdArg (loc,id) - | "?" -> ConstrMayEval (ConstrTerm <:ast< (ISEVAR) >>) - | "?"; n = Prim.natural -> MetaNumArg (loc,n) + | "?" -> ConstrMayEval (ConstrTerm (CHole loc)) + | "?"; n = natural -> MetaNumArg (loc,n) | "'"; c = Constr.constr -> ConstrMayEval (ConstrTerm c) ] ] ; lqualid: - [ [ ref = Prim.reference -> ref ] ] + [ [ ref = reference -> ref ] ] ; (* Definitions for tactics *) @@ -241,18 +240,18 @@ GEXTEND Gram | IDENT "Tactic" ] ] ; vrec_clause: - [ [ name = Prim.rawident; it=LIST1 input_fun; ":="; body = tactic_expr -> + [ [ name = identref; it=LIST1 input_fun; ":="; body = tactic_expr -> (name, TacFunRec (name, (it, body))) - | name = Prim.rawident; ":="; body = tactic_expr -> + | name = identref; ":="; body = tactic_expr -> (name, body) ] ] ; tactic: [ [ tac = tactic_expr -> tac ] ] ; Vernac_.command: - [ [ deftok; "Definition"; name = Prim.rawident; ":="; body = tactic -> + [ [ deftok; "Definition"; name = identref; ":="; body = tactic -> Vernacexpr.VernacDeclareTacticDefinition (loc, [name, body]) - | deftok; "Definition"; name = Prim.rawident; largs=LIST1 input_fun; + | deftok; "Definition"; name = identref; largs=LIST1 input_fun; ":="; body=tactic_expr -> Vernacexpr.VernacDeclareTacticDefinition (loc, [name, TacFun (largs,body)]) diff --git a/parsing/g_minicoq.ml4 b/parsing/g_minicoq.ml4 index 8c5df17a7..5ea97ae7d 100644 --- a/parsing/g_minicoq.ml4 +++ b/parsing/g_minicoq.ml4 @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(*i camlp4deps: "parsing/grammar.cma" i*) - (* $Id$ *) open Pp diff --git a/parsing/g_module.ml4 b/parsing/g_module.ml4 index 56db0cb59..a3714c43b 100644 --- a/parsing/g_module.ml4 +++ b/parsing/g_module.ml4 @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(*i camlp4deps: "parsing/grammar.cma" i*) - (* $Id$ *) open Pp @@ -16,75 +14,33 @@ open Pcoq open Prim open Module open Util +open Topconstr (* Grammar rules for module expressions and types *) GEXTEND Gram - GLOBAL: ne_binders_list module_expr - module_type; + GLOBAL: module_expr module_type; - ident: - [ [ id = Prim.var -> id ] ] - ; - - ident_comma_list_tail: - [ [ ","; idl = LIST0 ident SEP "," -> idl - | -> [] ] ] - ; - - qualid: - [ [ id = Prim.var; l = fields -> <:ast< (QUALID $id ($LIST $l)) >> - | id = Prim.var -> <:ast< (QUALID $id) >> - ] ] - ; - fields: - [ [ id = FIELD; l = fields -> <:ast< ($VAR $id) >> :: l - | id = FIELD -> [ <:ast< ($VAR $id) >> ] - ] ] - ; - - vardecls: (* This is interpreted by Pcoq.abstract_binder *) - [ [ id = ident; idl = ident_comma_list_tail; - ":"; mty = module_type -> - <:ast< (BINDER $mty $id ($LIST $idl)) >> ] ] - ; - - ne_vardecls_list: - [ [ id = vardecls; ";"; idl = ne_vardecls_list -> id :: idl - | id = vardecls -> [id] ] ] - ; - - rawbinders: - [ [ "["; bl = ne_vardecls_list; "]" -> bl ] ] - ; - - ne_binders_list: - [ [ bl = rawbinders; bll = ne_binders_list -> bl @ bll - | bl = rawbinders -> bl ] ] - ; - module_expr: - [ [ qid = qualid -> <:ast< (MODEXPRQID $qid) >> - | me1 = module_expr; me2 = module_expr -> - <:ast< (MODEXPRAPP $me1 $me2) >> - | "("; me = module_expr; ")" -> - me + [ [ qid = qualid -> CMEident qid + | me1 = module_expr; me2 = module_expr -> CMEapply (me1,me2) + | "("; me = module_expr; ")" -> me (* ... *) ] ] ; with_declaration: - [ [ "Definition"; id = ident; ":="; c = Constr.constr -> - <:ast< (WITHDEFINITION $id $c) >> - | IDENT "Module"; id = ident; ":="; qid = qualid -> - <:ast< (WITHMODULE $id $qid) >> + [ [ "Definition"; id = base_ident; ":="; c = Constr.constr -> + CWith_Definition (id,c) + | IDENT "Module"; id = base_ident; ":="; qid = qualid -> + CWith_Module (id,qid) ] ] ; module_type: - [ [ qid = qualid -> <:ast< (MODTYPEQID $qid) >> + [ [ qid = qualid -> CMTEident qid (* ... *) | mty = module_type; "with"; decl = with_declaration -> - <:ast< (MODTYPEWITH $mty $decl)>> ] ] + CMTEwith (mty,decl) ] ] ; END diff --git a/parsing/g_prim.ml4 b/parsing/g_prim.ml4 index 5363be633..f65ebd64d 100644 --- a/parsing/g_prim.ml4 +++ b/parsing/g_prim.ml4 @@ -8,14 +8,11 @@ (*i $Id$ i*) -(* -camlp4o pa_ifdef.cmo pa_extend.cmo pr_o.cmo pr_extend.cmo -quotify -DQuotify -impl parsing/g_prim.ml4 -*) - open Coqast open Pcoq open Names open Libnames +open Topconstr ifdef Quotify then open Qast @@ -72,23 +69,30 @@ ifdef Quotify then open Q GEXTEND Gram - GLOBAL: var ident natural metaident integer string preident ast astpat - astact astlist qualid reference dirpath rawident; + GLOBAL: ident natural integer string preident ast + astlist qualid reference dirpath identref name base_ident var; + (* Compatibility: Prim.var is a synonym of Prim.ident *) + var: + [ [ id = ident -> id ] ] + ; metaident: [ [ s = METAIDENT -> Nmeta (loc,s) ] ] ; - var: - [ [ id = ident -> Nvar(loc, id) ] ] - ; preident: [ [ s = IDENT -> s ] ] ; - ident: + base_ident: [ [ s = IDENT -> local_id_of_string s ] ] ; - rawident: - [ [ id = ident -> (loc,id) ] ] + name: + [ [ IDENT "_" -> (loc, Anonymous) | id = base_ident -> (loc, Name id) ] ] + ; + identref: + [ [ id = base_ident -> (loc,id) ] ] + ; + ident: + [ [ id = base_ident -> id ] ] ; natural: [ [ i = INT -> local_make_posint i ] ] @@ -101,7 +105,8 @@ GEXTEND Gram [ [ s = FIELD -> local_id_of_string s ] ] ; dirpath: - [ [ id = ident; l = LIST0 field -> local_make_dirpath (local_append l id) ] ] + [ [ id = base_ident; l = LIST0 field -> + local_make_dirpath (local_append l id) ] ] ; fields: [ [ id = field; (l,id') = fields -> (local_append l id,id') @@ -109,26 +114,26 @@ GEXTEND Gram ] ] ; basequalid: - [ [ id = ident; (l,id')=fields -> local_make_qualid (local_append l id) id' - | id = ident -> local_make_short_qualid id + [ [ id = base_ident; (l,id')=fields -> local_make_qualid (local_append l id) id' + | id = base_ident -> local_make_short_qualid id ] ] ; qualid: [ [ qid = basequalid -> loc, qid ] ] ; reference: - [ [ id = ident; (l,id') = fields -> - Coqast.RQualid (loc, local_make_qualid (local_append l id) id') - | id = ident -> Coqast.RIdent (loc,id) + [ [ id = base_ident; (l,id') = fields -> + Qualid (loc, local_make_qualid (local_append l id) id') + | id = base_ident -> Ident (loc,id) ] ] ; string: [ [ s = STRING -> s ] ] ; astpath: - [ [ id = ident; (l,a) = fields -> + [ [ id = base_ident; (l,a) = fields -> Path(loc, local_make_path (local_append l id) a) - | id = ident -> Nvar(loc, id) + | id = base_ident -> Nvar(loc, id) ] ] ; (* ast *) @@ -156,6 +161,6 @@ GEXTEND Gram | "'"; a = ast -> Node(loc,"$QUOTE",[a]) ] ] ; astlist: - [ [ l = LIST0 Prim.ast -> l ] ] + [ [ l = LIST0 ast -> l ] ] ; END diff --git a/parsing/g_proofs.ml4 b/parsing/g_proofs.ml4 index d4a00346b..52100764d 100644 --- a/parsing/g_proofs.ml4 +++ b/parsing/g_proofs.ml4 @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(*i camlp4deps: "parsing/grammar.cma" i*) - (* $Id$ *) open Pcoq @@ -15,9 +13,10 @@ open Pp open Tactic open Util open Vernac_ -open Coqast +open Topconstr open Vernacexpr open Prim +open Constr (* Proof commands *) GEXTEND Gram @@ -42,17 +41,17 @@ GEXTEND Gram *) | IDENT "Abort" -> VernacAbort None | IDENT "Abort"; IDENT "All" -> VernacAbortAll - | IDENT "Abort"; id = ident -> VernacAbort (Some id) + | IDENT "Abort"; id = identref -> VernacAbort (Some id) | "Qed" -> VernacEndProof (true,None) | IDENT "Save" -> VernacEndProof (true,None) | IDENT "Defined" -> VernacEndProof (false,None) - | IDENT "Defined"; id = ident -> VernacEndProof (false,Some (id,None)) - | IDENT "Save"; tok = thm_token; id = ident -> + | IDENT "Defined"; id=base_ident -> VernacEndProof (false,Some (id,None)) + | IDENT "Save"; tok = thm_token; id = base_ident -> VernacEndProof (true,Some (id,Some tok)) - | IDENT "Save"; id = ident -> VernacEndProof (true,Some (id,None)) + | IDENT "Save"; id = base_ident -> VernacEndProof (true,Some (id,None)) | IDENT "Suspend" -> VernacSuspend | IDENT "Resume" -> VernacResume None - | IDENT "Resume"; id = ident -> VernacResume (Some id) + | IDENT "Resume"; id = identref -> VernacResume (Some id) | IDENT "Restart" -> VernacRestart | "Proof"; c = Constr.constr -> VernacExactProof c | IDENT "Undo" -> VernacUndo 1 @@ -86,13 +85,13 @@ GEXTEND Gram | IDENT "HintDestruct"; dloc = destruct_location; - id = ident; + id = base_ident; hyptyp = Constr.constr_pattern; pri = natural; "["; tac = tactic; "]" -> VernacHintDestruct (id,dloc,hyptyp,pri,tac) - | IDENT "Hint"; hintname = ident; dbnames = opt_hintbases; ":="; h = hint + | IDENT "Hint"; hintname = base_ident; dbnames = opt_hintbases; ":="; h = hint -> VernacHints (dbnames, h hintname) | IDENT "Hints"; (dbnames,h) = hints -> VernacHints (dbnames, h) @@ -107,17 +106,17 @@ GEXTEND Gram hint: [ [ IDENT "Resolve"; c = Constr.constr -> fun name -> HintsResolve [Some name, c] | IDENT "Immediate"; c = Constr.constr -> fun name -> HintsImmediate [Some name, c] - | IDENT "Unfold"; qid = qualid -> fun name -> HintsUnfold [Some name,qid] - | IDENT "Constructors"; c = qualid -> fun n -> HintsConstructors (n,c) + | IDENT "Unfold"; qid = global -> fun name -> HintsUnfold [Some name,qid] + | IDENT "Constructors"; c = global -> fun n -> HintsConstructors (n,c) | IDENT "Extern"; n = natural; c = Constr.constr8 ; tac = tactic -> fun name -> HintsExtern (name,n,c,tac) ] ] ; hints: - [ [ IDENT "Resolve"; l = LIST1 Constr.qualid; dbnames = opt_hintbases -> - (dbnames, HintsResolve (List.map (fun qid -> (None, qid)) l)) - | IDENT "Immediate"; l = LIST1 Constr.qualid; dbnames = opt_hintbases -> - (dbnames, HintsImmediate (List.map (fun qid -> (None, qid)) l)) - | IDENT "Unfold"; l = LIST1 qualid; dbnames = opt_hintbases -> + [ [ IDENT "Resolve"; l = LIST1 global; dbnames = opt_hintbases -> + (dbnames, HintsResolve (List.map (fun qid -> (None, CRef qid)) l)) + | IDENT "Immediate"; l = LIST1 global; dbnames = opt_hintbases -> + (dbnames, HintsImmediate (List.map (fun qid -> (None, CRef qid)) l)) + | IDENT "Unfold"; l = LIST1 global; dbnames = opt_hintbases -> (dbnames, HintsUnfold (List.map (fun qid -> (None,qid)) l)) ] ] ; END diff --git a/parsing/g_rsyntax.ml b/parsing/g_rsyntax.ml index 6c5829627..e39b8125c 100644 --- a/parsing/g_rsyntax.ml +++ b/parsing/g_rsyntax.ml @@ -13,24 +13,37 @@ open Util open Names open Pcoq open Extend +open Topconstr +open Libnames let get_r_sign loc = - let ast_of_id id = Astterm.globalize_constr (Nvar(loc,id)) in - ((ast_of_id (id_of_string "R0"), - ast_of_id (id_of_string "R1"), - ast_of_id (id_of_string "Rplus"), - ast_of_id (id_of_string "NRplus"))) + let mkid id = + mkRefC (Qualid (loc,Libnames.make_short_qualid id)) + in + ((mkid (id_of_string "R0"), + mkid (id_of_string "R1"), + mkid (id_of_string "Rplus"), + mkid (id_of_string "NRplus"))) + +let get_r_sign_ast loc = + let mkid id = + Termast.ast_of_ref (Nametab.locate (Libnames.make_short_qualid id)) + in + ((mkid (id_of_string "R0"), + mkid (id_of_string "R1"), + mkid (id_of_string "Rplus"), + mkid (id_of_string "NRplus"))) (* Parsing via Grammar *) let r_of_int n dloc = - let (ast0,ast1,astp,_) = get_r_sign dloc in + let (a0,a1,plus,_) = get_r_sign dloc in let rec mk_r n = - if n <= 0 then - ast0 + if n <= 0 then + a0 else if n = 1 then - ast1 + a1 else - Node(dloc,"APPLIST", [astp; ast1; mk_r (n-1)]) + mkAppC (plus, [a1; mk_r (n-1)]) in mk_r n @@ -49,33 +62,33 @@ let _ = exception Non_closed_number -let rec int_of_r_rec ast1 astp p = +let rec int_of_r_rec a1 plus p = match p with - | Node (_,"APPLIST", [b; a; c]) when alpha_eq(b,astp) && - alpha_eq(a,ast1) -> - (int_of_r_rec ast1 astp c)+1 - | a when alpha_eq(a,ast1) -> 1 + | Node (_,"APPLIST", [b; a; c]) when alpha_eq(b,plus) && + alpha_eq(a,a1) -> + (int_of_r_rec a1 plus c)+1 + | a when alpha_eq(a,a1) -> 1 | _ -> raise Non_closed_number let int_of_r p = - let (_,ast1,astp,_) = get_r_sign dummy_loc in + let (_,a1,plus,_) = get_r_sign_ast dummy_loc in try - Some (int_of_r_rec ast1 astp p) + Some (int_of_r_rec a1 plus p) with Non_closed_number -> None let replace_plus p = - let (_,ast1,_,astnr) = get_r_sign dummy_loc in - ope ("REXPR",[ope("APPLIST", [astnr; ast1; p])]) + let (_,a1,_,astnr) = get_r_sign_ast dummy_loc in + ope ("REXPR",[ope("APPLIST", [astnr; a1; p])]) let r_printer std_pr p = - let (_,ast1,astp,_) = get_r_sign dummy_loc in + let (_,a1,plus,_) = get_r_sign dummy_loc in match (int_of_r p) with | Some i -> str (string_of_int (i+1)) | None -> std_pr (replace_plus p) let r_printer_outside std_pr p = - let (_,ast1,astp,_) = get_r_sign dummy_loc in + let (_,a1,plus,_) = get_r_sign dummy_loc in match (int_of_r p) with | Some i -> str "``" ++ str (string_of_int (i+1)) ++ str "``" | None -> std_pr (replace_plus p) @@ -144,7 +157,7 @@ let _ = Symbols.declare_numeral_interpreter "R_scope" (r_of_int,None) exception Non_closed_number let bignat_of_pos p = - let (_,one,plus,_) = get_r_sign dummy_loc in + let (_,one,plus,_) = get_r_sign_ast dummy_loc in let rec transl = function | Node (_,"APPLIST",[p; o; a]) when alpha_eq(p,plus) & alpha_eq(o,one) -> add_1(transl a) diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index 286642375..341752f45 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(*i camlp4deps: "parsing/grammar.cma" i*) - (* $Id$ *) open Pp @@ -27,7 +25,7 @@ open Tactic (* Functions overloaded by quotifier *) let induction_arg_of_constr c = - try ElimOnIdent (Ast.loc c,coerce_to_id c) with _ -> ElimOnConstr c + try ElimOnIdent (Topconstr.constr_loc c,coerce_to_id c) with _ -> ElimOnConstr c let local_compute = [FBeta;FIota;FDeltaBut [];FZeta] @@ -80,13 +78,13 @@ GEXTEND Gram int_or_var: [ [ n = integer -> Genarg.ArgArg n - | id = ident -> Genarg.ArgVar (loc,id) ] ] + | id = identref -> Genarg.ArgVar id ] ] ; autoarg_depth: [ [ n = OPT natural -> n ] ] ; autoarg_adding: - [ [ IDENT "Adding" ; "["; l = LIST1 qualid; "]" -> l | -> [] ] ] + [ [ IDENT "Adding" ; "["; l = LIST1 global; "]" -> l | -> [] ] ] ; autoarg_destructing: [ [ IDENT "Destructing" -> true | -> false ] ] @@ -100,17 +98,17 @@ GEXTEND Gram ; (* Either an hypothesis or a ltac ref (variable or pattern metavariable) *) id_or_ltac_ref: - [ [ id = ident -> AN (loc,id) + [ [ id = base_ident -> AN id | "?"; n = natural -> MetaNum (loc,n) ] ] ; (* Either a global ref or a ltac ref (variable or pattern metavariable) *) - qualid_or_ltac_ref: - [ [ (loc,qid) = qualid -> AN (loc,qid) + global_or_ltac_ref: + [ [ qid = global -> AN qid | "?"; n = natural -> MetaNum (loc,n) ] ] ; (* An identifier or a quotation meta-variable *) id_or_meta: - [ [ id = rawident -> AI id + [ [ id = identref -> AI id (* This is used in quotations *) | id = METAIDENT -> MetaId (loc,id) ] ] @@ -122,7 +120,7 @@ GEXTEND Gram ] ] ; constrarg: - [ [ IDENT "Inst"; id = rawident; "["; c = constr; "]" -> + [ [ IDENT "Inst"; id = identref; "["; c = constr; "]" -> ConstrContext (id, c) | IDENT "Eval"; rtc = Tactic.red_expr; "in"; c = constr -> ConstrEval (rtc,c) @@ -138,7 +136,7 @@ GEXTEND Gram ] ] ; quantified_hypothesis: - [ [ id = ident -> NamedHyp id + [ [ id = base_ident -> NamedHyp id | n = natural -> AnonHyp n ] ] ; pattern_occ: @@ -161,11 +159,11 @@ GEXTEND Gram [ [ "["; tc = LIST1 intropatterns SEP "|" ; "]" -> IntroOrAndPattern tc | "("; tc = LIST1 simple_intropattern SEP "," ; ")" -> IntroOrAndPattern [tc] | IDENT "_" -> IntroWildcard - | id = ident -> IntroIdentifier id + | id = base_ident -> IntroIdentifier id ] ] ; simple_binding: - [ [ id = ident; ":="; c = constr -> (NamedHyp id, c) + [ [ id = base_ident; ":="; c = constr -> (NamedHyp id, c) | n = natural; ":="; c = constr -> (AnonHyp n, c) ] ] ; binding_list: @@ -183,15 +181,15 @@ GEXTEND Gram [ [ "with"; bl = binding_list -> bl | -> NoBindings ] ] ; unfold_occ: - [ [ nl = LIST0 integer; c = qualid_or_ltac_ref -> (nl,c) ] ] + [ [ nl = LIST0 integer; c = global_or_ltac_ref -> (nl,c) ] ] ; red_flag: [ [ IDENT "Beta" -> FBeta | IDENT "Delta" -> FDeltaBut [] | IDENT "Iota" -> FIota | IDENT "Zeta" -> FZeta - | IDENT "Delta"; "["; idl = LIST1 qualid_or_ltac_ref; "]" -> FConst idl - | IDENT "Delta"; "-"; "["; idl = LIST1 qualid_or_ltac_ref; "]" -> FDeltaBut idl + | IDENT "Delta"; "["; idl = LIST1 global_or_ltac_ref; "]" -> FConst idl + | IDENT "Delta"; "-"; "["; idl = LIST1 global_or_ltac_ref; "]" -> FDeltaBut idl ] ] ; red_tactic: @@ -227,10 +225,10 @@ GEXTEND Gram | -> [] ] ] ; fixdecl: - [ [ id = ident; "/"; n = natural; ":"; c = constr -> (id,n,c) ] ] + [ [ id = base_ident; "/"; n = natural; ":"; c = constr -> (id,n,c) ] ] ; cofixdecl: - [ [ id = ident; ":"; c = constr -> (id,c) ] ] + [ [ id = base_ident; ":"; c = constr -> (id,c) ] ] ; hintbases: [ [ "with"; "*" -> None @@ -241,7 +239,7 @@ GEXTEND Gram [ [ "using"; el = constr_with_bindings -> el ] ] ; with_names: - [ [ "as"; "["; ids = LIST1 (LIST0 Prim.ident) SEP "|"; "]" -> ids + [ [ "as"; "["; ids = LIST1 (LIST0 base_ident) SEP "|"; "]" -> ids | -> [] ] ] ; simple_tactic: @@ -250,11 +248,11 @@ GEXTEND Gram IDENT "Intros"; IDENT "until"; id = quantified_hypothesis -> TacIntrosUntil id | IDENT "Intros"; pl = intropatterns -> TacIntroPattern pl - | IDENT "Intro"; id = ident; IDENT "after"; id2 = rawident -> + | IDENT "Intro"; id = base_ident; IDENT "after"; id2 = identref -> TacIntroMove (Some id, Some id2) - | IDENT "Intro"; IDENT "after"; id2 = rawident -> + | IDENT "Intro"; IDENT "after"; id2 = identref -> TacIntroMove (None, Some id2) - | IDENT "Intro"; id = ident -> TacIntroMove (Some id, None) + | IDENT "Intro"; id = base_ident -> TacIntroMove (Some id, None) | IDENT "Intro" -> TacIntroMove (None, None) | IDENT "Assumption" -> TacAssumption @@ -269,12 +267,12 @@ GEXTEND Gram | IDENT "Case"; cl = constr_with_bindings -> TacCase cl | IDENT "CaseType"; c = constr -> TacCaseType c | IDENT "Fix"; n = natural -> TacFix (None,n) - | IDENT "Fix"; id = ident; n = natural -> TacFix (Some id,n) - | IDENT "Fix"; id = ident; n = natural; "with"; fd = LIST0 fixdecl -> + | IDENT "Fix"; id = base_ident; n = natural -> TacFix (Some id,n) + | IDENT "Fix"; id = base_ident; n = natural; "with"; fd = LIST0 fixdecl -> TacMutualFix (id,n,fd) | IDENT "Cofix" -> TacCofix None - | IDENT "Cofix"; id = ident -> TacCofix (Some id) - | IDENT "Cofix"; id = ident; "with"; fd = LIST0 cofixdecl -> + | IDENT "Cofix"; id = base_ident -> TacCofix (Some id) + | IDENT "Cofix"; id = base_ident; "with"; fd = LIST0 cofixdecl -> TacMutualCofix (id,fd) | IDENT "Cut"; c = constr -> TacCut c @@ -288,7 +286,7 @@ GEXTEND Gram | IDENT "Pose"; b = constr -> TacForward (true,Names.Anonymous,b) | IDENT "Generalize"; lc = LIST1 constr -> TacGeneralize lc | IDENT "Generalize"; IDENT "Dependent"; c = constr -> TacGeneralizeDep c - | IDENT "LetTac"; id = ident; ":="; c = constr; p = clause_pattern + | IDENT "LetTac"; id = base_ident; ":="; c = constr; p = clause_pattern -> TacLetTac (id,c,p) | IDENT "Instantiate"; n = natural; c = constr -> TacInstantiate (n,c) @@ -307,7 +305,7 @@ GEXTEND Gram ids = with_names -> TacNewDestruct (c,el,ids) | IDENT "Decompose"; IDENT "Record" ; c = constr -> TacDecomposeAnd c | IDENT "Decompose"; IDENT "Sum"; c = constr -> TacDecomposeOr c - | IDENT "Decompose"; "["; l = LIST1 qualid_or_ltac_ref; "]"; c = constr + | IDENT "Decompose"; "["; l = LIST1 global_or_ltac_ref; "]"; c = constr -> TacDecompose (l,c) (* Automation tactic *) @@ -315,8 +313,8 @@ GEXTEND Gram | IDENT "Auto"; n = OPT natural; db = hintbases -> TacAuto (n, db) | IDENT "AutoTDB"; n = OPT natural -> TacAutoTDB n - | IDENT "CDHyp"; id = rawident -> TacDestructHyp (true,id) - | IDENT "DHyp"; id = rawident -> TacDestructHyp (false,id) + | IDENT "CDHyp"; id = identref -> TacDestructHyp (true,id) + | IDENT "DHyp"; id = identref -> TacDestructHyp (false,id) | IDENT "DConcl" -> TacDestructConcl | IDENT "SuperAuto"; l = autoargs -> TacSuperAuto l | IDENT "Auto"; n = OPT natural; IDENT "Decomp"; p = OPT natural -> @@ -325,9 +323,9 @@ GEXTEND Gram (* Context management *) | IDENT "Clear"; l = LIST1 id_or_ltac_ref -> TacClear l | IDENT "ClearBody"; l = LIST1 id_or_ltac_ref -> TacClearBody l - | IDENT "Move"; id1 = rawident; IDENT "after"; id2 = rawident -> + | IDENT "Move"; id1 = identref; IDENT "after"; id2 = identref -> TacMove (true,id1,id2) - | IDENT "Rename"; id1 = rawident; IDENT "into"; id2 = rawident -> + | IDENT "Rename"; id1 = identref; IDENT "into"; id2 = identref -> TacRename (id1,id2) (* Constructors *) @@ -353,14 +351,6 @@ GEXTEND Gram (* Unused ?? | IDENT "ML"; s = string -> ExtraTactic<:ast< (MLTACTIC $s) >> *) - - (* | [ id = identarg; l = constrarg_list -> - match (isMeta (nvar_of_ast id), l) with - | (true, []) -> id - | (false, _) -> <:ast< (CALL $id ($LIST $l)) >> - | _ -> Util.user_err_loc - (loc, "G_tactic.meta_tactic", - (str"Cannot apply arguments to a meta-tactic.")) - ] *)] ] + ] ] ; END;; diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 1a582b293..f347ac20e 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -6,11 +6,10 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(*i camlp4deps: "parsing/grammar.cma" i*) - (* $Id$ *) -open Coqast +open Names +open Topconstr open Vernacexpr open Pcoq open Pp @@ -26,7 +25,7 @@ let join_binders (idl,c) = List.map (fun id -> (id,c)) idl open Genarg -let evar_constr loc = <:ast< (ISEVAR) >> +let evar_constr loc = CHole loc (* Rem: do not join the different GEXTEND into one, it breaks native *) (* compilation on PowerPC and Sun architectures *) @@ -40,10 +39,10 @@ GEXTEND Gram | g = gallina_ext; "." -> g | c = command; "." -> c | c = syntax; "." -> c - | n = Prim.natural; ":"; v = goal_vernac; "." -> v n + | n = natural; ":"; v = goal_vernac; "." -> v n | "["; l = vernac_list_tail -> VernacList l (* This is for "Grammar vernac" rules *) - | id = Prim.metaident -> VernacVar (Ast.nvar_of_ast id) ] ] + | id = METAIDENT -> VernacVar (Names.id_of_string id) ] ] ; goal_vernac: [ [ tac = Tactic.tactic -> fun n -> VernacSolve (n,tac) @@ -71,8 +70,8 @@ GEXTEND Gram ] ] ; constr_body: - [ [ ":="; c = constr; ":"; t = constr -> <:ast< (CAST $c $t) >> - | ":"; t = constr; ":="; c = constr -> <:ast< (CAST $c $t) >> + [ [ ":="; c = constr; ":"; t = constr -> CCast(loc,c,t) + | ":"; t = constr; ":="; c = constr -> CCast(loc,c,t) | ":="; c = constr -> c ] ] ; vernac_list_tail: @@ -123,31 +122,34 @@ GEXTEND Gram | ":" -> false ] ] ; params: - [ [ idl = LIST1 ident SEP ","; coe = of_type_with_opt_coercion; c = constr + [ [ idl = LIST1 base_ident SEP ","; coe = of_type_with_opt_coercion; c = constr -> List.map (fun c -> (coe,c)) (join_binders (idl,c)) ] ] ; ne_params_list: [ [ ll = LIST1 params SEP ";" -> List.flatten ll ] ] ; -ident_comma_list_tail: - [ [ ","; idl = LIST1 ident SEP "," -> idl | -> [] ] ] + name_comma_list_tail: + [ [ ","; nal = LIST1 name SEP "," -> nal | -> [] ] ] + ; + ident_comma_list_tail: + [ [ ","; nal = LIST1 base_ident SEP "," -> nal | -> [] ] ] ; type_option: [ [ ":"; c = constr -> c | -> evar_constr loc ] ] ; opt_casted_constr: - [ [ c = constr; ":"; t = constr -> <:ast< (CAST $c $t) >> + [ [ c = constr; ":"; t = constr -> CCast(loc,c,t) | c = constr -> c ] ] ; vardecls: - [ [ id = ident; idl = ident_comma_list_tail; c = type_option -> - LocalRawAssum (id::idl,c) - | id = ident; "="; c = opt_casted_constr -> - LocalRawDef (id,c) - | id = ident; ":="; c = opt_casted_constr -> - LocalRawDef (id,c) + [ [ na = name; nal = name_comma_list_tail; c = type_option + -> LocalRawAssum (na::nal,c) + | na = name; "="; c = opt_casted_constr -> + LocalRawDef (na,c) + | na = name; ":="; c = opt_casted_constr -> + LocalRawDef (na,c) ] ] ; binders: @@ -172,9 +174,9 @@ ident_comma_list_tail: ; gallina: (* Definition, Theorem, Variable, Axiom, ... *) - [ [ thm = thm_token; id = ident; bl = binders_list; ":"; c = constr -> + [ [ thm = thm_token; id = base_ident; bl = binders_list; ":"; c = constr -> VernacStartTheoremProof (thm, id, (bl, c), false, (fun _ _ -> ())) - | (f,d) = def_token; id = ident; b = def_body -> + | (f,d) = def_token; id = base_ident; b = def_body -> VernacDefinition (d, id, b, f) | stre = assumption_token; bl = ne_params_list -> VernacAssumption (stre, bl) @@ -192,7 +194,7 @@ ident_comma_list_tail: [ [ IDENT "Record" -> () | IDENT "Structure" -> () ] ] ; constructor: - [ [ id = ident; coe = of_type_with_opt_coercion; c = constr -> + [ [ id = base_ident; coe = of_type_with_opt_coercion; c = constr -> (coe,(id,c)) ] ] ; ne_constructor_list: @@ -209,7 +211,7 @@ ident_comma_list_tail: | ind = oneind_old_style -> [ind] ] ] ; oneind_old_style: - [ [ id = ident; ":"; c = constr; ":="; lc = constructor_list -> + [ [ id = base_ident; ":"; c = constr; ":="; lc = constructor_list -> (id,c,lc) ] ] ; block: @@ -217,7 +219,7 @@ ident_comma_list_tail: | ind = oneind -> [ind] ] ] ; oneind: - [ [ id = ident; indpar = indpar; ":"; c = constr; ":="; + [ [ id = base_ident; indpar = indpar; ":"; c = constr; ":="; lc = constructor_list -> (id,indpar,c,lc) ] ] ; indpar: @@ -229,7 +231,7 @@ ident_comma_list_tail: | -> false ] ] ; onescheme: - [ [ id = ident; ":="; dep = dep; ind = qualid; IDENT "Sort"; + [ [ id = base_ident; ":="; dep = dep; ind = global; IDENT "Sort"; s = sort -> (id,dep,ind,s) ] ] ; schemes: @@ -240,34 +242,34 @@ ident_comma_list_tail: | IDENT "Minimality"; IDENT "for" -> false ] ] ; onerec: - [ [ id = ident; idl = ne_simple_binders_list; ":"; c = constr; + [ [ id = base_ident; idl = ne_fix_binders; ":"; c = constr; ":="; def = constr -> (id,idl,c,def) ] ] ; specifrec: [ [ l = LIST1 onerec SEP "with" -> l ] ] ; onecorec: - [ [ id = ident; ":"; c = constr; ":="; def = constr -> + [ [ id = base_ident; ":"; c = constr; ":="; def = constr -> (id,c,def) ] ] ; specifcorec: [ [ l = LIST1 onecorec SEP "with" -> l ] ] ; record_field: - [ [ id = ident; oc = of_type_with_opt_coercion; t = constr -> + [ [ id = base_ident; oc = of_type_with_opt_coercion; t = constr -> (oc,AssumExpr (id,t)) - | id = ident; oc = of_type_with_opt_coercion; t = constr; + | id = base_ident; oc = of_type_with_opt_coercion; t = constr; ":="; b = constr -> (oc,DefExpr (id,b,Some t)) - | id = ident; ":="; b = constr -> + | id = base_ident; ":="; b = constr -> (false,DefExpr (id,b,None)) ] ] ; fields: [ [ fs = LIST0 record_field SEP ";" -> fs ] ] ; simple_params: - [ [ idl = LIST1 ident SEP ","; ":"; c = constr -> join_binders (idl, c) - | idl = LIST1 ident SEP "," -> join_binders (idl, evar_constr dummy_loc) + [ [ idl = LIST1 base_ident SEP ","; ":"; c = constr -> join_binders (idl, c) + | idl = LIST1 base_ident SEP "," -> join_binders (idl, evar_constr dummy_loc) ] ] ; simple_binders: @@ -276,8 +278,19 @@ ident_comma_list_tail: ne_simple_binders_list: [ [ bll = LIST1 simple_binders -> List.flatten bll ] ] ; + fix_params: + [ [ idl = LIST1 name SEP ","; ":"; c = constr -> (idl, c) + | idl = LIST1 name SEP "," -> (idl, evar_constr dummy_loc) + ] ] + ; + fix_binders: + [ [ "["; bll = LIST1 fix_params SEP ";"; "]" -> bll ] ] + ; + ne_fix_binders: + [ [ bll = LIST1 fix_binders -> List.flatten bll ] ] + ; rec_constructor: - [ [ c = ident -> Some c + [ [ c = base_ident -> Some c | -> None ] ] ; gallina_ext: @@ -285,7 +298,7 @@ ident_comma_list_tail: indl = block_old_style -> let indl' = List.map (fun (id,ar,c) -> (id,bl,ar,c)) indl in VernacInductive (f,indl') - | record_token; oc = opt_coercion; name = ident; ps = indpar; ":"; + | record_token; oc = opt_coercion; name = base_ident; ps = indpar; ":"; s = sort; ":="; c = rec_constructor; "{"; fs = fields; "}" -> VernacRecord ((oc,name),ps,s,c,fs) ] ] @@ -296,25 +309,25 @@ ident_comma_list_tail: | "Fixpoint"; recs = specifrec -> VernacFixpoint recs | "CoFixpoint"; corecs = specifcorec -> VernacCoFixpoint corecs | IDENT "Scheme"; l = schemes -> VernacScheme l - | f = finite_token; s = sort; id = ident; indpar = indpar; ":="; + | f = finite_token; s = csort; id = base_ident; indpar = indpar; ":="; lc = constructor_list -> VernacInductive (f,[id,indpar,s,lc]) | f = finite_token; indl = block -> VernacInductive (f,indl) ] ] ; + csort: + [ [ s = sort -> CSort (loc,s) ] ] + ; gallina_ext: [ [ (* Sections *) - IDENT "Section"; id = ident -> VernacBeginSection id - | IDENT "Chapter"; id = ident -> VernacBeginSection id ] ] -(* | IDENT "Module"; id = ident -> - warning "Module is currently unsupported"; VernacNop *) + IDENT "Section"; id = base_ident -> VernacBeginSection id + | IDENT "Chapter"; id = base_ident -> VernacBeginSection id ] ] ; module_vardecls: (* This is interpreted by Pcoq.abstract_binder *) - [ [ id = ident; idl = ident_comma_list_tail; - ":"; mty = Module.module_type -> - (id::idl,mty) ] ] + [ [ id = base_ident; idl = ident_comma_list_tail; ":"; mty = Module.module_type + -> (id::idl,mty) ] ] ; module_binders: [ [ "["; bl = LIST1 module_vardecls SEP ";"; "]" -> bl ] ] @@ -334,64 +347,64 @@ ident_comma_list_tail: gallina_ext: [ [ (* Interactive module declaration *) - IDENT "Module"; id = ident; bl = module_binders_list; + IDENT "Module"; id = base_ident; bl = module_binders_list; mty_o = OPT of_module_type; mexpr_o = OPT is_module_expr -> VernacDeclareModule (id, bl, mty_o, mexpr_o) - | IDENT "Module"; "Type"; id = ident; + | IDENT "Module"; "Type"; id = base_ident; bl = module_binders_list; mty_o = OPT is_module_type -> VernacDeclareModuleType (id, bl, mty_o) (* This end a Section a Module or a Module Type *) - | IDENT "End"; id = ident -> VernacEndSegment id + | IDENT "End"; id = base_ident -> VernacEndSegment id (* Transparent and Opaque *) - | IDENT "Transparent"; l = LIST1 qualid -> VernacSetOpacity (false, l) - | IDENT "Opaque"; l = LIST1 qualid -> VernacSetOpacity (true, l) + | IDENT "Transparent"; l = LIST1 global -> VernacSetOpacity (false, l) + | IDENT "Opaque"; l = LIST1 global -> VernacSetOpacity (true, l) (* Canonical structure *) - | IDENT "Canonical"; IDENT "Structure"; qid = qualid -> + | IDENT "Canonical"; IDENT "Structure"; qid = global -> VernacCanonical qid - | IDENT "Canonical"; IDENT "Structure"; qid = qualid; d = def_body -> - let s = Ast.coerce_qualid_to_id qid in + | IDENT "Canonical"; IDENT "Structure"; qid = global; d = def_body -> + let s = Ast.coerce_global_to_id qid in VernacDefinition (Global,s,d,Recordobj.add_object_hook) (* Rem: LOBJECT, OBJCOERCION, LOBJCOERCION have been removed (they were unused and undocumented) *) (* Coercions *) - | IDENT "Coercion"; qid = qualid; d = def_body -> - let s = Ast.coerce_qualid_to_id qid in + | IDENT "Coercion"; qid = global; d = def_body -> + let s = Ast.coerce_global_to_id qid in VernacDefinition (Global,s,d,Class.add_coercion_hook) - | IDENT "Coercion"; IDENT "Local"; qid = qualid; d = def_body -> - let s = Ast.coerce_qualid_to_id qid in + | IDENT "Coercion"; IDENT "Local"; qid = global; d = def_body -> + let s = Ast.coerce_global_to_id qid in VernacDefinition (Local,s,d,Class.add_coercion_hook) - | IDENT "Identity"; IDENT "Coercion"; IDENT "Local"; f = Prim.ident; + | IDENT "Identity"; IDENT "Coercion"; IDENT "Local"; f = base_ident; ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> VernacIdentityCoercion (Local, f, s, t) - | IDENT "Identity"; IDENT "Coercion"; f = Prim.ident; ":"; + | IDENT "Identity"; IDENT "Coercion"; f = base_ident; ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> VernacIdentityCoercion (Global, f, s, t) - | IDENT "Coercion"; IDENT "Local"; qid = qualid; ":"; + | IDENT "Coercion"; IDENT "Local"; qid = global; ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> VernacCoercion (Local, qid, s, t) - | IDENT "Coercion"; qid = qualid; ":"; s = class_rawexpr; ">->"; + | IDENT "Coercion"; qid = global; ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> VernacCoercion (Global, qid, s, t) - | IDENT "Class"; IDENT "Local"; c = qualid -> + | IDENT "Class"; IDENT "Local"; c = global -> Pp.warning "Class is obsolete"; VernacNop - | IDENT "Class"; c = qualid -> + | IDENT "Class"; c = global -> Pp.warning "Class is obsolete"; VernacNop (* Implicit *) - | IDENT "Syntactic"; "Definition"; id = ident; ":="; c = constr; + | IDENT "Syntactic"; "Definition"; id = base_ident; ":="; c = constr; n = OPT [ "|"; n = natural -> n ] -> VernacSyntacticDefinition (id,c,n) - | IDENT "Implicits"; qid = qualid; "["; l = LIST0 natural; "]" -> + | IDENT "Implicits"; qid = global; "["; l = LIST0 natural; "]" -> VernacDeclareImplicits (qid,Some l) - | IDENT "Implicits"; qid = qualid -> VernacDeclareImplicits (qid,None) + | IDENT "Implicits"; qid = global -> VernacDeclareImplicits (qid,None) (* For compatibility *) | IDENT "Implicit"; IDENT "Arguments"; IDENT "On" -> @@ -436,23 +449,17 @@ GEXTEND Gram <:ast< (CompileFile ($STR $verbosely) ($STR $only_spec) ($STR $mname) ($STR $fname))>> *) - | IDENT "Read"; IDENT "Module"; qidl = LIST1 qualid -> + | IDENT "Read"; IDENT "Module"; qidl = LIST1 global -> VernacRequire (None, None, qidl) | IDENT "Require"; export = export_token; specif = specif_token; - qidl = LIST1 qualid -> VernacRequire (Some export, specif, qidl) + qidl = LIST1 global -> VernacRequire (Some export, specif, qidl) | IDENT "Require"; export = export_token; specif = specif_token; - id = Prim.ident; filename = STRING -> + id = base_ident; filename = STRING -> VernacRequireFrom (export, specif, id, filename) -(* - | IDENT "Write"; IDENT "Module"; id = identarg -> ExtraVernac - <:ast< (WriteModule $id) >> - | IDENT "Write"; IDENT "Module"; id = identarg; s = stringarg -> ExtraVernac - <:ast< (WriteModule $id $s) >> -*) | IDENT "Declare"; IDENT "ML"; IDENT "Module"; l = LIST1 STRING -> VernacDeclareMLModule l - | IDENT "Import"; qidl = LIST1 qualid -> VernacImport (false,qidl) - | IDENT "Export"; qidl = LIST1 qualid -> VernacImport (true,qidl) + | IDENT "Import"; qidl = LIST1 global -> VernacImport (false,qidl) + | IDENT "Export"; qidl = LIST1 global -> VernacImport (true,qidl) ] ] ; @@ -471,10 +478,10 @@ GEXTEND Gram | IDENT "Restore"; IDENT "State"; s = STRING -> VernacRestoreState s (* Resetting *) - | IDENT "Reset"; id = Prim.ident -> VernacResetName id + | IDENT "Reset"; id = identref -> VernacResetName id | IDENT "Reset"; IDENT "Initial" -> VernacResetInitial | IDENT "Back" -> VernacBack 1 - | IDENT "Back"; n = Prim.natural -> VernacBack n + | IDENT "Back"; n = natural -> VernacBack n (* Tactic Debugger *) | IDENT "Debug"; IDENT "On" -> VernacDebug true diff --git a/parsing/g_zsyntax.ml b/parsing/g_zsyntax.ml index 56ded0837..7b3c3e391 100644 --- a/parsing/g_zsyntax.ml +++ b/parsing/g_zsyntax.ml @@ -15,40 +15,55 @@ open Util open Names open Ast open Extend +open Topconstr +open Libnames let get_z_sign loc = - let ast_of_id id = Astterm.globalize_constr (Nvar(loc,id)) in - ((ast_of_id (id_of_string "xI"), - ast_of_id (id_of_string "xO"), - ast_of_id (id_of_string "xH")), - (ast_of_id (id_of_string "ZERO"), - ast_of_id (id_of_string "POS"), - ast_of_id (id_of_string "NEG"))) + let mkid id = + mkRefC (Qualid (loc,Libnames.make_short_qualid id)) + in + ((mkid (id_of_string "xI"), + mkid (id_of_string "xO"), + mkid (id_of_string "xH")), + (mkid (id_of_string "ZERO"), + mkid (id_of_string "POS"), + mkid (id_of_string "NEG"))) open Bignat -let pos_of_bignat astxI astxO astxH x = +let pos_of_bignat xI xO xH x = let rec pos_of x = match div2_with_rest x with - | (q, true) when is_nonzero q -> ope("APPLIST", [astxI; pos_of q]) - | (q, false) -> ope("APPLIST", [astxO; pos_of q]) - | (_, true) -> astxH + | (q, true) when is_nonzero q -> mkAppC (xI, [pos_of q]) + | (q, false) -> mkAppC (xO, [pos_of q]) + | (_, true) -> xH in pos_of x let z_of_string pos_or_neg s dloc = - let ((astxI,astxO,astxH),(astZERO,astPOS,astNEG)) = get_z_sign dloc in + let ((xI,xO,xH),(aZERO,aPOS,aNEG)) = get_z_sign dloc in let v = Bignat.of_string s in if is_nonzero v then if pos_or_neg then - ope("APPLIST",[astPOS; pos_of_bignat astxI astxO astxH v]) + mkAppC (aPOS, [pos_of_bignat xI xO xH v]) else - ope("APPLIST",[astNEG; pos_of_bignat astxI astxO astxH v]) + mkAppC (aNEG, [pos_of_bignat xI xO xH v]) else - astZERO + aZERO exception Non_closed_number +let get_z_sign_ast loc = + let ast_of_id id = + Termast.ast_of_ref (Nametab.locate (Libnames.make_short_qualid id)) + in + ((ast_of_id (id_of_string "xI"), + ast_of_id (id_of_string "xO"), + ast_of_id (id_of_string "xH")), + (ast_of_id (id_of_string "ZERO"), + ast_of_id (id_of_string "POS"), + ast_of_id (id_of_string "NEG"))) + let rec bignat_of_pos c1 c2 c3 p = match p with | Node (_,"APPLIST", [b; a]) when alpha_eq(b,c1) -> @@ -58,9 +73,9 @@ let rec bignat_of_pos c1 c2 c3 p = | a when alpha_eq(a,c3) -> Bignat.one | _ -> raise Non_closed_number -let bignat_option_of_pos astxI astxO astxH p = +let bignat_option_of_pos xI xO xH p = try - Some (bignat_of_pos astxO astxI astxH p) + Some (bignat_of_pos xO xI xH p) with Non_closed_number -> None @@ -68,8 +83,8 @@ let pr_pos a = hov 0 (str "POS" ++ brk (1,1) ++ a) let pr_neg a = hov 0 (str "NEG" ++ brk (1,1) ++ a) let inside_printer posneg std_pr p = - let ((astxI,astxO,astxH),_) = get_z_sign dummy_loc in - match (bignat_option_of_pos astxI astxO astxH p) with + let ((xI,xO,xH),_) = get_z_sign_ast dummy_loc in + match (bignat_option_of_pos xI xO xH p) with | Some n -> if posneg then (str (Bignat.to_string n)) @@ -82,8 +97,8 @@ let inside_printer posneg std_pr p = let outside_zero_printer std_pr p = str "`0`" let outside_printer posneg std_pr p = - let ((astxI,astxO,astxH),_) = get_z_sign dummy_loc in - match (bignat_option_of_pos astxI astxO astxH p) with + let ((xI,xO,xH),_) = get_z_sign_ast dummy_loc in + match (bignat_option_of_pos xI xO xH p) with | Some n -> if posneg then (str "`" ++ str (Bignat.to_string n) ++ str "`") @@ -176,16 +191,20 @@ let z_of_int dloc z = let _ = Symbols.declare_numeral_interpreter "Z_scope" (z_of_int,None) +(***********************************************************************) +(* Printer for positive *) + + (***********************************************************************) (* Printers *) exception Non_closed_number let bignat_of_pos p = - let ((astxI,astxO,astxH),_) = get_z_sign dummy_loc in - let c1 = astxO in - let c2 = astxI in - let c3 = astxH in + let ((xI,xO,xH),_) = get_z_sign_ast dummy_loc in + let c1 = xO in + let c2 = xI in + let c3 = xH in let rec transl = function | Node (_,"APPLIST",[b; a]) when alpha_eq(b,c1) -> mult_2(transl a) | Node (_,"APPLIST",[b; a]) when alpha_eq(b,c2) -> add_1(mult_2(transl a)) diff --git a/parsing/g_zsyntax.mli b/parsing/g_zsyntax.mli index afda96bd9..93b40191c 100644 --- a/parsing/g_zsyntax.mli +++ b/parsing/g_zsyntax.mli @@ -10,4 +10,7 @@ (* Nice syntax for integers. *) -val z_of_string : bool -> string -> Coqast.loc -> Coqast.t +open Util +open Topconstr + +val z_of_string : bool -> string -> loc -> constr_expr diff --git a/parsing/genarg.ml b/parsing/genarg.ml deleted file mode 100644 index e0d3b8019..000000000 --- a/parsing/genarg.ml +++ /dev/null @@ -1,181 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* - List.fold_right (fun x -> f (in_gen t x)) (Obj.magic l) - | _ -> failwith "Genarg: not a list0" - -let fold_list1 f = function - | (List1ArgType t as u, l) -> - List.fold_right (fun x -> f (in_gen t x)) (Obj.magic l) - | _ -> failwith "Genarg: not a list1" - -let fold_opt f a = function - | (OptArgType t as u, l) -> - (match Obj.magic l with - | None -> a - | Some x -> f (in_gen t x)) - | _ -> failwith "Genarg: not a opt" - -let fold_pair f = function - | (PairArgType (t1,t2) as u, l) -> - let (x1,x2) = Obj.magic l in - f (in_gen t1 x1) (in_gen t2 x2) - | _ -> failwith "Genarg: not a pair" - -let app_list0 f = function - | (List0ArgType t as u, l) -> - let o = Obj.magic l in - (u, Obj.repr (List.map (fun x -> out_gen t (f (in_gen t x))) o)) - | _ -> failwith "Genarg: not a list0" - -let app_list1 f = function - | (List1ArgType t as u, l) -> - let o = Obj.magic l in - (u, Obj.repr (List.map (fun x -> out_gen t (f (in_gen t x))) o)) - | _ -> failwith "Genarg: not a list1" - -let app_opt f = function - | (OptArgType t as u, l) -> - let o = Obj.magic l in - (u, Obj.repr (option_app (fun x -> out_gen t (f (in_gen t x))) o)) - | _ -> failwith "Genarg: not an opt" - -let app_pair f1 f2 = function - | (PairArgType (t1,t2) as u, l) -> - let (o1,o2) = Obj.magic l in - let o1 = out_gen t1 (f1 (in_gen t1 o1)) in - let o2 = out_gen t2 (f2 (in_gen t2 o2)) in - (u, Obj.repr (o1,o2)) - | _ -> failwith "Genarg: not a pair" - -let or_var_app f = function - | ArgArg x -> ArgArg (f x) - | ArgVar _ as x -> x - -let smash_var_app t f g = function - | ArgArg x -> f x - | ArgVar (_,id) -> - let (u, _ as x) = g id in - if t <> u then failwith "Genarg: a variable bound to a wrong type"; - x - -let unquote x = x - -type an_arg_of_this_type = Obj.t - -let in_generic t x = (t, Obj.repr x) diff --git a/parsing/genarg.mli b/parsing/genarg.mli deleted file mode 100644 index 2991d237a..000000000 --- a/parsing/genarg.mli +++ /dev/null @@ -1,208 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* rawtype ----> rawconstr generic_argument ----> - | - | interp - V - type <---- constr generic_argument <---- - out in - -To distinguish between the uninterpreted (raw) and the interpreted -worlds, we annotate the type generic_argument by a phantom argument -which is either constr_ast or constr (actually we add also a second -argument raw_tactic_expr and tactic, but this is only for technical -reasons, because these types are undefined at the type of compilation -of Genarg). - -Transformation for each type : -tag f raw open type cooked closed type - -BoolArgType bool bool -IntArgType int int -IntOrVarArgType int or_var int -StringArgType string (parsed w/ "") string -IdentArgType identifier identifier -PreIdentArgType string (parsed w/o "") string -QualidArgType qualid located global_reference -ConstrArgType constr_ast constr -ConstrMayEvalArgType constr_ast may_eval constr -QuantHypArgType quantified_hypothesis quantified_hypothesis -TacticArgType raw_tactic_expr tactic -CastedOpenConstrArgType constr_ast open_constr -ConstrWithBindingsArgType constr_ast with_bindings constr with_bindings -List0ArgType of argument_type -List1ArgType of argument_type -OptArgType of argument_type -ExtraArgType of string '_a '_b -*) - -type ('a,'co,'ta) abstract_argument_type - -val rawwit_bool : (bool,'co,'ta) abstract_argument_type -val wit_bool : (bool,'co,'ta) abstract_argument_type - -val rawwit_int : (int,'co,'ta) abstract_argument_type -val wit_int : (int,'co,'ta) abstract_argument_type - -val rawwit_int_or_var : (int or_var,'co,'ta) abstract_argument_type -val wit_int_or_var : (int or_var,'co,'ta) abstract_argument_type - -val rawwit_string : (string,'co,'ta) abstract_argument_type -val wit_string : (string,'co,'ta) abstract_argument_type - -val rawwit_ident : (identifier,'co,'ta) abstract_argument_type -val wit_ident : (identifier,'co,'ta) abstract_argument_type - -val rawwit_pre_ident : (string,'co,'ta) abstract_argument_type -val wit_pre_ident : (string,'co,'ta) abstract_argument_type - -val rawwit_qualid : (qualid located,constr_ast,'ta) abstract_argument_type -val wit_qualid : (global_reference,constr,'ta) abstract_argument_type - -val rawwit_quant_hyp : (quantified_hypothesis,'co,'ta) abstract_argument_type -val wit_quant_hyp : (quantified_hypothesis,'co,'ta) abstract_argument_type - -val rawwit_constr : (constr_ast,constr_ast,'ta) abstract_argument_type -val wit_constr : (constr,constr,'ta) abstract_argument_type - -val rawwit_constr_may_eval : (constr_ast may_eval,constr_ast,'ta) abstract_argument_type -val wit_constr_may_eval : (constr,constr,'ta) abstract_argument_type - -val rawwit_casted_open_constr : (open_rawconstr,constr_ast,'ta) abstract_argument_type -val wit_casted_open_constr : (open_constr,constr,'ta) abstract_argument_type - -val rawwit_constr_with_bindings : (constr_ast with_bindings,constr_ast,'ta) abstract_argument_type -val wit_constr_with_bindings : (constr with_bindings,constr,'ta) abstract_argument_type - -val rawwit_red_expr : ((constr_ast,qualid or_metanum) red_expr_gen,constr_ast,'ta) abstract_argument_type -val wit_red_expr : ((constr,Closure.evaluable_global_reference) red_expr_gen,constr,'ta) abstract_argument_type - -(* TODO: transformer tactic en extra arg *) -val rawwit_tactic : ('ta,constr_ast,'ta) abstract_argument_type -val wit_tactic : ('ta,constr,'ta) abstract_argument_type - -val wit_list0 : - ('a,'co,'ta) abstract_argument_type -> ('a list,'co,'ta) abstract_argument_type - -val wit_list1 : - ('a,'co,'ta) abstract_argument_type -> ('a list,'co,'ta) abstract_argument_type - -val wit_opt : - ('a,'co,'ta) abstract_argument_type -> ('a option,'co,'ta) abstract_argument_type - -val wit_pair : - ('a,'co,'ta) abstract_argument_type -> - ('b,'co,'ta) abstract_argument_type -> - ('a * 'b,'co,'ta) abstract_argument_type - -(* 'a generic_argument = (Sigma t:type. t[constr/'a]) *) -type ('a,'b) generic_argument - -val fold_list0 : - (('a,'b) generic_argument -> 'c -> 'c) -> ('a,'b) generic_argument -> 'c -> 'c - -val fold_list1 : - (('a,'b) generic_argument -> 'c -> 'c) -> ('a,'b) generic_argument -> 'c -> 'c - -val fold_opt : - (('a,'b) generic_argument -> 'c) -> 'c -> ('a,'b) generic_argument -> 'c - -val fold_pair : - (('a,'b) generic_argument -> ('a,'b) generic_argument -> 'c) -> - ('a,'b) generic_argument -> 'c - -(* [app_list0] fails if applied to an argument not of tag [List0 t] - for some [t]; it's the responsability of the caller to ensure it *) - -val app_list0 : (('a,'b) generic_argument -> ('c,'d) generic_argument) -> -('a,'b) generic_argument -> ('c,'d) generic_argument - -val app_list1 : (('a,'b) generic_argument -> ('c,'d) generic_argument) -> -('a,'b) generic_argument -> ('c,'d) generic_argument - -val app_opt : (('a,'b) generic_argument -> ('c,'d) generic_argument) -> -('a,'b) generic_argument -> ('c,'d) generic_argument - -val app_pair : - (('a,'b) generic_argument -> ('c,'d) generic_argument) -> - (('a,'b) generic_argument -> ('c,'d) generic_argument) - -> ('a,'b) generic_argument -> ('c,'d) generic_argument - -(* Manque l'ordre supérieur, on aimerait ('co,'ta) 'a; manque aussi le - polymorphism, on aimerait que 'b et 'c restent polymorphes à l'appel - de create *) -val create_arg : string -> - ('rawa,'rawco,'rawta) abstract_argument_type - * ('a,'co,'ta) abstract_argument_type - -val exists_argtype : string -> bool - -type argument_type = - | BoolArgType - | IntArgType - | IntOrVarArgType - | StringArgType - | PreIdentArgType - | IdentArgType - | QualidArgType - | ConstrArgType - | ConstrMayEvalArgType - | QuantHypArgType - | TacticArgType - | CastedOpenConstrArgType - | ConstrWithBindingsArgType - | RedExprArgType - | List0ArgType of argument_type - | List1ArgType of argument_type - | OptArgType of argument_type - | PairArgType of argument_type * argument_type - | ExtraArgType of string - -val genarg_tag : ('a,'b) generic_argument -> argument_type - -val unquote : ('a,'co,'ta) abstract_argument_type -> argument_type - -(* We'd like - - [in_generic: !b:type, !a:argument_type -> (f a) -> b generic_argument] - - with f a = b if a is Constr, f a = c if a is Tactic, otherwise f a = |a| - - in_generic is not typable; we replace the second argument by an absurd - type (with no introduction rule) -*) -type an_arg_of_this_type - -val in_generic : - argument_type -> an_arg_of_this_type -> ('a,'b) generic_argument - -val in_gen : - ('a,'co,'ta) abstract_argument_type -> 'a -> ('co,'ta) generic_argument -val out_gen : - ('a,'co,'ta) abstract_argument_type -> ('co,'ta) generic_argument -> 'a - diff --git a/parsing/pcoq.ml4 b/parsing/pcoq.ml4 index 67322863a..9c206565e 100644 --- a/parsing/pcoq.ml4 +++ b/parsing/pcoq.ml4 @@ -10,9 +10,14 @@ open Pp open Util +open Names +open Libnames +open Rawterm +open Topconstr open Ast open Genarg open Tacexpr +open Extend (* The lexer of Coq *) @@ -46,59 +51,39 @@ let grammar_delete e rls = List.iter (fun (pil,_) -> G.delete_rule e pil) (List.rev lev)) (List.rev rls) +(* grammar_object is the superclass of all grammar entry *) module type Gramobj = sig type grammar_object - type 'a entry - - val in_entry : 'a -> 'b G.Entry.e -> 'a entry - val object_of_entry : 'a entry -> grammar_object G.Entry.e - val type_of_entry : 'a entry -> 'a + val weaken_entry : 'a G.Entry.e -> grammar_object G.Entry.e end module Gramobj : Gramobj = struct type grammar_object = Obj.t - type 'a entry = 'a * grammar_object G.Entry.e - - let in_entry t e = (t,Obj.magic e) - let object_of_entry (t,e) = e - let type_of_entry (t,e) = t + let weaken_entry e = Obj.magic e end type grammar_object = Gramobj.grammar_object -let in_typed_entry = Gramobj.in_entry -let type_of_typed_entry = Gramobj.type_of_entry -let object_of_typed_entry = Gramobj.object_of_entry -type typed_entry = entry_type Gramobj.entry +type typed_entry = entry_type * grammar_object G.Entry.e +let in_typed_entry t e = (t,Gramobj.weaken_entry e) +let type_of_typed_entry (t,e) = t +let object_of_typed_entry (t,e) = e module type Gramtypes = sig open Decl_kinds - val inAstListType : Coqast.t list G.Entry.e -> typed_entry - val inTacticAtomAstType : raw_atomic_tactic_expr G.Entry.e -> typed_entry - val inThmTokenAstType : theorem_kind G.Entry.e -> typed_entry - val inDynamicAstType : typed_ast G.Entry.e -> typed_entry - val inReferenceAstType : Coqast.reference_expr G.Entry.e -> typed_entry - val inPureAstType : constr_ast G.Entry.e -> typed_entry - val inGenAstType : 'a raw_abstract_argument_type -> - 'a G.Entry.e -> typed_entry - val outGenAstType : 'a raw_abstract_argument_type -> typed_entry -> 'a G.Entry.e + val inGramObj : 'a raw_abstract_argument_type -> 'a G.Entry.e -> typed_entry + val outGramObj : 'a raw_abstract_argument_type -> typed_entry -> 'a G.Entry.e end module Gramtypes : Gramtypes = struct - let inAstListType = in_typed_entry AstListType - let inTacticAtomAstType = in_typed_entry TacticAtomAstType - let inThmTokenAstType = in_typed_entry ThmTokenAstType - let inDynamicAstType = in_typed_entry DynamicAstType - let inReferenceAstType = in_typed_entry ReferenceAstType - let inPureAstType = in_typed_entry (GenAstType ConstrArgType) - let inGenAstType rawwit = in_typed_entry (GenAstType (unquote rawwit)) - - let outGenAstType (a:'a raw_abstract_argument_type) o = - if type_of_typed_entry o <> GenAstType (unquote a) - then anomaly "outGenAstType: wrong type"; + let inGramObj rawwit = in_typed_entry (unquote rawwit) + let outGramObj (a:'a raw_abstract_argument_type) o = + if type_of_typed_entry o <> unquote a + then anomaly "outGramObj: wrong type"; + (* downcast from grammar_object *) Obj.magic (object_of_typed_entry o) end @@ -106,7 +91,7 @@ open Gramtypes type ext_kind = | ByGrammar of - typed_entry * Gramext.position option * + grammar_object G.Entry.e * Gramext.position option * (string option * Gramext.g_assoc option * (Token.t Gramext.g_symbol list * Gramext.g_action) list) list | ByGEXTEND of (unit -> unit) * (unit -> unit) @@ -138,22 +123,20 @@ module Gram = (* This extension command is used by the Grammar constr *) let grammar_extend te pos rls = - camlp4_state := ByGrammar (te,pos,rls) :: !camlp4_state; + camlp4_state := ByGrammar (Gramobj.weaken_entry te,pos,rls) :: !camlp4_state; let a = !Gramext.warning_verbose in Gramext.warning_verbose := Options.is_verbose (); - G.extend (object_of_typed_entry te) pos rls; + G.extend te pos rls; Gramext.warning_verbose := a (* n is the number of extended entries (not the number of Grammar commands!) to remove. *) -let remove_grammar rls te = grammar_delete (object_of_typed_entry te) rls - let rec remove_grammars n = if n>0 then (match !camlp4_state with | [] -> anomaly "Pcoq.remove_grammars: too many rules to remove" | ByGrammar(g,_,rls)::t -> - remove_grammar rls g; + grammar_delete g rls; camlp4_state := t; remove_grammars (n-1) | ByGEXTEND (undo,redo)::t -> @@ -186,14 +169,6 @@ let map_entry f en = let parse_string f x = let strm = Stream.of_string x in Gram.Entry.parse f (Gram.parsable strm) -(* -let slam_ast (_,fin) id ast = - match id with - | Coqast.Nvar (loc, s) -> Coqast.Slam (loc, Some s, ast) - | Coqast.Nmeta (loc, s) -> Coqast.Smetalam (loc, s, ast) - | _ -> invalid_arg "Ast.slam_ast" -*) - (* let entry_type ast = match ast with @@ -216,7 +191,7 @@ let trace = ref false (* The univ_tab is not part of the state. It contains all the grammar that exist or have existed before in the session. *) -let univ_tab = Hashtbl.create 7 +let univ_tab = (Hashtbl.create 7 : (string, string * gram_universe) Hashtbl.t) let create_univ s = let u = s, Hashtbl.create 29 in Hashtbl.add univ_tab s u; u @@ -283,22 +258,22 @@ let create_entry (u, utab) s etyp = new_entry etyp (u, utab) s let create_constr_entry u s = - outGenAstType rawwit_constr (create_entry u s (GenAstType ConstrArgType)) + outGramObj rawwit_constr (create_entry u s ConstrArgType) let create_generic_entry s wit = let (u,utab) = utactic in let etyp = unquote wit in try let e = Hashtbl.find utab s in - if type_of_typed_entry e <> GenAstType etyp then + if type_of_typed_entry e <> etyp then failwith ("Entry " ^ u ^ ":" ^ s ^ " already exists with another type"); - outGenAstType wit e + outGramObj wit e with Not_found -> if !trace then begin Printf.eprintf "[Creating entry %s:%s]\n" u s; flush stderr; () end; let e = Gram.Entry.create s in - Hashtbl.add utab s (inGenAstType wit e); e + Hashtbl.add utab s (inGramObj wit e); e let get_generic_entry s = let (u,utab) = utactic in @@ -308,10 +283,7 @@ let get_generic_entry s = error ("unknown grammar entry "^u^":"^s) let get_generic_entry_type (u,utab) s = - try - match type_of_typed_entry (Hashtbl.find utab s) with - | GenAstType t -> t - | _ -> error "Not a generic type" + try type_of_typed_entry (Hashtbl.find utab s) with Not_found -> error ("unknown grammar entry "^u^":"^s) @@ -319,8 +291,6 @@ let force_entry_type (u, utab) s etyp = try let entry = Hashtbl.find utab s in let extyp = type_of_typed_entry entry in - if etyp = PureAstType && extyp = GenAstType ConstrArgType then - entry else if etyp = extyp then entry else begin @@ -333,45 +303,55 @@ let force_entry_type (u, utab) s etyp = with Not_found -> new_entry etyp (u, utab) s -(* Grammar entries *) +(* [make_gen_entry] builds entries extensible by giving its name (a string) *) +(* For entries extensible only via the ML name, Gram.Entry.create is enough *) -let make_entry (u,univ) in_fun s = +let make_gen_entry (u,univ) rawwit s = let e = Gram.Entry.create (u ^ ":" ^ s) in - Hashtbl.add univ s (in_fun e); e + Hashtbl.add univ s (inGramObj rawwit e); e -let make_gen_entry u rawwit = make_entry u (inGenAstType rawwit) +(* Grammar entries *) module Prim = struct let gec_gen x = make_gen_entry uprim x - let gec = make_entry uprim inPureAstType - let gec_list = make_entry uprim inAstListType + (* Entries that can be refered via the string -> Gram.Entry.e table *) + (* Typically for tactic or vernac extensions *) let preident = gec_gen rawwit_pre_ident "preident" let ident = gec_gen rawwit_ident "ident" - let rawident = Gram.Entry.create "Prim.rawident" let natural = gec_gen rawwit_int "natural" let integer = gec_gen rawwit_int "integer" let string = gec_gen rawwit_string "string" - let qualid = gec_gen rawwit_qualid "qualid" - let reference = make_entry uprim inReferenceAstType "reference" + let reference = make_gen_entry uprim rawwit_ref "reference" + + (* A synonym of ident, for compatibility *) + let var = gec_gen rawwit_ident "var" + + let name = Gram.Entry.create "Prim.name" + let identref = Gram.Entry.create "Prim.identref" + + (* A synonym of ident - maybe ident will be located one day *) + let base_ident = Gram.Entry.create "Prim.base_ident" + + let qualid = Gram.Entry.create "Prim.qualid" let dirpath = Gram.Entry.create "Prim.dirpath" - let astpat = make_entry uprim inDynamicAstType "astpat" - let ast = gec "ast" - let astlist = gec_list "astlist" + + (* For old ast printer *) + let astpat = Gram.Entry.create "Prim.astpat" + let ast = Gram.Entry.create "Prim.ast" + let astlist = Gram.Entry.create "Prim.astlist" let ast_eoi = eoi_entry ast - let astact = gec "astact" - let metaident = gec "metaident" - let var = gec "var" + let astact = Gram.Entry.create "Prim.astact" end module Constr = struct - let gec = make_entry uconstr inPureAstType let gec_constr = make_gen_entry uconstr rawwit_constr - let gec_list = make_entry uconstr inAstListType + let gec_constr_list = make_gen_entry uconstr (wit_list0 rawwit_constr) + (* Entries that can be refered via the string -> Gram.Entry.e table *) let constr = gec_constr "constr" let constr0 = gec_constr "constr0" let constr1 = gec_constr "constr1" @@ -387,35 +367,30 @@ module Constr = let constr10 = gec_constr "constr10" let constr_eoi = eoi_entry constr let lconstr = gec_constr "lconstr" - let ident = gec "ident" - let qualid = gec "qualid" - let global = gec "global" - let ne_ident_comma_list = gec_list "ne_ident_comma_list" - let ne_constr_list = gec_list "ne_constr_list" - let sort = gec_constr "sort" - let pattern = gec "pattern" - let constr_pattern = gec "constr_pattern" - let ne_binders_list = gec_list "ne_binders_list" - let numarg = gec "numarg" - end + let sort = make_gen_entry uconstr rawwit_sort "sort" + let ident = make_gen_entry uconstr rawwit_ident "ident" + let global = make_gen_entry uconstr rawwit_ref "global" + + let ne_name_comma_list = Gram.Entry.create "constr:ne_name_comma_list" + let ne_constr_list = gec_constr_list "ne_constr_list" + let pattern = Gram.Entry.create "constr:pattern" + let constr_pattern = gec_constr "constr_pattern" + end module Module = struct - let gec = make_entry umodule inPureAstType - let gec_list = make_entry umodule inAstListType - - let ident = gec "ident" - let qualid = gec_list "qualid" - let ne_binders_list = gec_list "ne_binders_list" - let module_expr = gec "module_expr" - let module_type = gec "module_type" + let module_expr = Gram.Entry.create "module_expr" + let module_type = Gram.Entry.create "module_type" end module Tactic = struct - let gec = make_entry utactic inPureAstType - let gec_list = make_entry utactic inAstListType + (* Main entry for extensions *) + let simple_tactic = Gram.Entry.create "tactic:simple_tactic" + + (* Entries that can be refered via the string -> Gram.Entry.e table *) + (* Typically for tactic user extensions *) let castedopenconstr = make_gen_entry utactic rawwit_casted_open_constr "castedopenconstr" let constr_with_bindings = @@ -425,23 +400,31 @@ module Tactic = make_gen_entry utactic rawwit_quant_hyp "quantified_hypothesis" let int_or_var = make_gen_entry utactic rawwit_int_or_var "int_or_var" let red_expr = make_gen_entry utactic rawwit_red_expr "red_expr" - let simple_tactic = make_entry utactic inTacticAtomAstType "simple_tactic" + + (* Main entries for ltac *) let tactic_arg = Gram.Entry.create "tactic:tactic_arg" let tactic = make_gen_entry utactic rawwit_tactic "tactic" + + (* Main entry for quotations *) let tactic_eoi = eoi_entry tactic end module Vernac_ = struct - let thm_token = make_entry uvernac inThmTokenAstType "thm_token" - let class_rawexpr = Gram.Entry.create "vernac:class_rawexpr" let gec_vernac s = Gram.Entry.create ("vernac:" ^ s) + + (* The different kinds of vernacular commands *) let gallina = gec_vernac "gallina" let gallina_ext = gec_vernac "gallina_ext" let command = gec_vernac "command" let syntax = gec_vernac "syntax_command" let vernac = gec_vernac "Vernac_.vernac" + + (* Various vernacular entries needed to be exported *) + let thm_token = Gram.Entry.create "vernac:thm_token" + let class_rawexpr = Gram.Entry.create "vernac:class_rawexpr" + let vernac_eoi = eoi_entry vernac end @@ -462,8 +445,12 @@ open Tactic open Vernac_ (* current file and toplevel/vernac.ml *) +let globalizer = ref (fun x -> failwith "No globalizer") +let set_globalizer f = globalizer := f -let define_quotation default s e = +let f = (ast : Coqast.t G.Entry.e) + +let define_ast_quotation default s (e:Coqast.t G.Entry.e) = (if default then GEXTEND Gram ast: [ [ "<<"; c = e; ">>" -> c ] ]; @@ -487,31 +474,16 @@ let define_quotation default s e = *) END) -let _ = define_quotation false "ast" ast in () - -let gecdyn s = - let e = Gram.Entry.create ("Dyn." ^ s) in - Hashtbl.add (snd uconstr) s (inDynamicAstType e); e +(* +let _ = define_ast_quotation false "ast" ast in () +*) -let dynconstr = gecdyn "dynconstr" -let dyncasespattern = gecdyn "dyncasespattern" -let dyntactic = gecdyn "dyntactic" -let dynvernac = gecdyn "dynvernac" -let dynastlist = gecdyn "dynastlist" -let dynast = gecdyn "dynast" - -let globalizer = ref (fun x -> x) -let set_globalizer f = globalizer := f +let dynconstr = Gram.Entry.create "Constr.dynconstr" +let dyncasespattern = Gram.Entry.create "Constr.dyncasespattern" GEXTEND Gram - dynconstr: [ [ a = Constr.constr -> !globalizer (PureAstNode a) ] ]; - dyncasespattern: [ [ a = Constr.pattern -> !globalizer (PureAstNode a) ] ]; -(* - dyntactic: [ [ a = Tactic.tactic -> !globalizer (TacticAstNode a) ] ]; - dynvernac: [ [ a = Vernac_.vernac -> !globalizer(VernacAstNode a) ] ]; -*) - dynastlist: [ [ a = Prim.astlist -> AstListNode a ] ]; - dynast: [ [ a = ast -> PureAstNode a ] ]; + dynconstr: [ [ a = Constr.constr -> ConstrNode a ] ]; + dyncasespattern: [ [ a = Constr.pattern -> CasesPatternNode a ] ]; END (**********************************************************************) @@ -519,41 +491,27 @@ END (* and Syntax pattern, according to the universe of the rule defined *) type parser_type = - | AstListParser - | AstParser | ConstrParser | CasesPatternParser - | TacticParser - | VernacParser -let default_action_parser_ref = ref dynast +let default_action_parser_ref = ref dynconstr let get_default_action_parser () = !default_action_parser_ref -let entry_type_from_name = function - | "constr" -> GenAstType ConstrArgType - | "tactic" -> failwith "Not supported" - | "vernac" -> failwith "Not supported" - | s -> GenAstType ConstrArgType - let entry_type_of_parser = function - | AstListParser -> Some AstListType - | _ -> None + | ConstrParser -> Some ConstrArgType + | CasesPatternParser -> failwith "entry_type_of_parser: cases_pattern, TODO" let parser_type_from_name = function | "constr" -> ConstrParser | "cases_pattern" -> CasesPatternParser - | "tactic" -> TacticParser - | "vernac" -> VernacParser - | s -> AstParser + | "tactic" -> assert false + | "vernac" -> error "No longer supported" + | s -> ConstrParser let set_default_action_parser = function - | AstListParser -> default_action_parser_ref := dynastlist - | AstParser -> default_action_parser_ref := dynast | ConstrParser -> default_action_parser_ref := dynconstr | CasesPatternParser -> default_action_parser_ref := dyncasespattern - | TacticParser -> default_action_parser_ref := dyntactic - | VernacParser -> default_action_parser_ref := dynvernac let default_action_parser = Gram.Entry.of_parser "default_action_parser" diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index b4a5bc9a7..a0f5a55c0 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -8,12 +8,16 @@ (*i $Id$ i*) +open Util open Names -open Tacexpr +open Rawterm open Ast open Genarg +open Topconstr open Tacexpr open Vernacexpr +open Libnames +open Extend (* The lexer and parser of Coq. *) @@ -24,11 +28,11 @@ module Gram : Grammar.S with type te = Token.t type grammar_object type typed_entry -val type_of_typed_entry : typed_entry -> entry_type +val type_of_typed_entry : typed_entry -> Extend.entry_type val object_of_typed_entry : typed_entry -> grammar_object Gram.Entry.e val grammar_extend : - typed_entry -> Gramext.position option -> + 'a Gram.Entry.e -> Gramext.position option -> (string option * Gramext.g_assoc option * (Token.t Gramext.g_symbol list * Gramext.g_action) list) list -> unit @@ -41,12 +45,6 @@ val parse_string : 'a Gram.Entry.e -> string -> 'a val eoi_entry : 'a Gram.Entry.e -> 'a Gram.Entry.e val map_entry : ('a -> 'b) -> 'a Gram.Entry.e -> 'b Gram.Entry.e -(* -val slam_ast : Coqast.loc -> Coqast.t -> Coqast.t -> Coqast.t -val abstract_binders_ast : - Coqast.loc -> string -> Coqast.t -> Coqast.t -> Coqast.t -*) - (* Entry types *) (* Table of Coq's grammar entries *) @@ -67,35 +65,30 @@ val force_entry_type : string * gram_universe -> string -> entry_type -> typed_entry val create_constr_entry : - string * gram_universe -> string -> Coqast.t Gram.Entry.e -val create_generic_entry : string -> ('a, constr_ast,raw_tactic_expr) abstract_argument_type -> 'a Gram.Entry.e + string * gram_universe -> string -> constr_expr Gram.Entry.e +val create_generic_entry : string -> ('a, constr_expr,raw_tactic_expr) abstract_argument_type -> 'a Gram.Entry.e val get_generic_entry : string -> grammar_object Gram.Entry.e val get_generic_entry_type : string * gram_universe -> string -> Genarg.argument_type type parser_type = - | AstListParser - | AstParser | ConstrParser | CasesPatternParser - | TacticParser - | VernacParser -val entry_type_from_name : string -> entry_type val entry_type_of_parser : parser_type -> entry_type option val parser_type_from_name : string -> parser_type -(* Quotations *) -val define_quotation : bool -> string -> (Coqast.t Gram.Entry.e) -> unit -val set_globalizer : (typed_ast -> typed_ast) -> unit +(* Quotations in ast parser *) +val define_ast_quotation : bool -> string -> (Coqast.t Gram.Entry.e) -> unit +val set_globalizer : (constr_expr -> Coqast.t) -> unit (* The default parser for actions in grammar rules *) -val default_action_parser : typed_ast Gram.Entry.e +val default_action_parser : dynamic_grammar Gram.Entry.e val set_default_action_parser : parser_type -> unit (* The main entry: reads an optional vernac command *) -val main_entry : (Coqast.loc * vernac_expr) option Gram.Entry.e +val main_entry : (loc * vernac_expr) option Gram.Entry.e (* Initial state of the grammar *) @@ -106,64 +99,63 @@ module Prim : open Libnames val preident : string Gram.Entry.e val ident : identifier Gram.Entry.e - val rawident : identifier located Gram.Entry.e + val name : name located Gram.Entry.e + val identref : identifier located Gram.Entry.e + val base_ident : identifier Gram.Entry.e val natural : int Gram.Entry.e val integer : int Gram.Entry.e val string : string Gram.Entry.e val qualid : qualid located Gram.Entry.e - val reference : Coqast.reference_expr Gram.Entry.e + val reference : reference Gram.Entry.e val dirpath : dir_path Gram.Entry.e val astpat: typed_ast Gram.Entry.e val ast : Coqast.t Gram.Entry.e val astlist : Coqast.t list Gram.Entry.e val ast_eoi : Coqast.t Gram.Entry.e - val astact : Coqast.t Gram.Entry.e - val metaident : Coqast.t Gram.Entry.e - val var : Coqast.t Gram.Entry.e + val var : identifier Gram.Entry.e end module Constr : sig - val constr : Coqast.t Gram.Entry.e - val constr0 : Coqast.t Gram.Entry.e - val constr1 : Coqast.t Gram.Entry.e - val constr2 : Coqast.t Gram.Entry.e - val constr3 : Coqast.t Gram.Entry.e - val lassoc_constr4 : Coqast.t Gram.Entry.e - val constr5 : Coqast.t Gram.Entry.e - val constr6 : Coqast.t Gram.Entry.e - val constr7 : Coqast.t Gram.Entry.e - val constr8 : Coqast.t Gram.Entry.e - val constr9 : Coqast.t Gram.Entry.e - val constr91 : Coqast.t Gram.Entry.e - val constr10 : Coqast.t Gram.Entry.e - val constr_eoi : constr_ast Gram.Entry.e - val lconstr : Coqast.t Gram.Entry.e - val ident : Coqast.t Gram.Entry.e - val qualid : Coqast.t Gram.Entry.e - val global : Coqast.t Gram.Entry.e - val ne_ident_comma_list : Coqast.t list Gram.Entry.e - val ne_constr_list : Coqast.t list Gram.Entry.e - val sort : Coqast.t Gram.Entry.e - val pattern : Coqast.t Gram.Entry.e - val constr_pattern : Coqast.t Gram.Entry.e - val ne_binders_list : Coqast.t list Gram.Entry.e - val numarg : Coqast.t Gram.Entry.e + val constr : constr_expr Gram.Entry.e + val constr0 : constr_expr Gram.Entry.e + val constr1 : constr_expr Gram.Entry.e + val constr2 : constr_expr Gram.Entry.e + val constr3 : constr_expr Gram.Entry.e + val lassoc_constr4 : constr_expr Gram.Entry.e + val constr5 : constr_expr Gram.Entry.e + val constr6 : constr_expr Gram.Entry.e + val constr7 : constr_expr Gram.Entry.e + val constr8 : constr_expr Gram.Entry.e + val constr9 : constr_expr Gram.Entry.e + val constr91 : constr_expr Gram.Entry.e + val constr10 : constr_expr Gram.Entry.e + val constr_eoi : constr_expr Gram.Entry.e + val lconstr : constr_expr Gram.Entry.e + val ident : identifier Gram.Entry.e + val global : reference Gram.Entry.e + val ne_name_comma_list : name located list Gram.Entry.e + val ne_constr_list : constr_expr list Gram.Entry.e + val sort : rawsort Gram.Entry.e + val pattern : cases_pattern_expr Gram.Entry.e + val constr_pattern : constr_expr Gram.Entry.e +(* + val ne_binders_list : local_binder list Gram.Entry.e +*) end module Module : sig - val ne_binders_list : Coqast.t list Gram.Entry.e - val module_expr : Coqast.t Gram.Entry.e - val module_type : Coqast.t Gram.Entry.e + val module_expr : module_ast Gram.Entry.e + val module_type : module_type_ast Gram.Entry.e end module Tactic : sig open Rawterm - val castedopenconstr : constr_ast Gram.Entry.e - val constr_with_bindings : constr_ast with_bindings Gram.Entry.e - val constrarg : constr_ast may_eval Gram.Entry.e + val castedopenconstr : constr_expr Gram.Entry.e + val constr_with_bindings : constr_expr with_bindings Gram.Entry.e + val constrarg : constr_expr may_eval Gram.Entry.e val quantified_hypothesis : quantified_hypothesis Gram.Entry.e val int_or_var : int or_var Gram.Entry.e val red_expr : raw_red_expr Gram.Entry.e diff --git a/parsing/ppconstr.ml b/parsing/ppconstr.ml index 76430e1c4..6dd9211bb 100644 --- a/parsing/ppconstr.ml +++ b/parsing/ppconstr.ml @@ -1,25 +1,26 @@ -(****************************************************************************) -(* *) -(* The Coq Proof Assistant *) -(* *) -(* Projet Coq *) -(* *) -(* INRIA LRI-CNRS ENS-CNRS *) -(* Rocquencourt Orsay Lyon *) -(* *) -(****************************************************************************) - -(* $:Id$ *) +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* " | s -> raise s -let constr_syntax_universe = "constr" -(* This is starting precedence for printing constructions or tactics *) -(* Level 9 means no parentheses except for applicative terms (at level 10) *) -let constr_initial_prec = Some ((constr_syntax_universe,(9,0,0)),Extend.L) +let latom = 0 +let lannot = 1 +let lprod = 8 +let lcast = 9 +let lapp = 10 +let ltop = (8,E) -let gentermpr_fail gt = - Esyntax.genprint globpr constr_syntax_universe constr_initial_prec gt +let prec_less child (parent,assoc) = + (if assoc = E then (<=) else (<)) child parent -let gentermpr gt = - try gentermpr_fail gt - with s -> wrap_exception s +let env_assoc_value v env = + try List.assoc v env + with Not_found -> + anomaly ("Printing metavariable "^(string_of_id v)^" is unbound") -(* [at_top] means ids of env must be avoided in bound variables *) -let gentermpr_core at_top env t = - gentermpr (Termast.ast_of_constr at_top env t) +open Symbols + +let rec print_hunk pr env = function + | UnpMetaVar (e,prec) -> pr prec (env_assoc_value e env) + | UnpTerminal s -> str s + | UnpBox (b,sub) -> ppcmd_of_box b (prlist (print_hunk pr env) sub) + | UnpCut cut -> ppcmd_of_cut cut + +let pr_notation pr s env = + let unpl, level = find_notation_printing_rule s in + prlist (print_hunk pr env) unpl, level + +let pr_delimiters x = failwith "pr_delimiters: TODO" + +open Rawterm + +let pr_opt pr = function + | None -> mt () + | Some x -> spc () ++ pr x + +let pr_universe u = str "" + +let pr_sort = function + | RProp Term.Null -> str "Prop" + | RProp Term.Pos -> str "Set" + | RType u -> str "Type" ++ pr_opt pr_universe u + +let pr_explicitation = function + | None -> mt () + | Some n -> int n ++ str "!" + +let pr_expl_args pr (a,expl) = + pr_explicitation expl ++ pr (latom,E) a + +let pr_opt_type pr = function + | CHole _ -> mt () + | t -> cut () ++ str ":" ++ pr ltop t + +let pr_tight_coma () = str "," ++ cut () + +let pr_name = function + | Anonymous -> mt () + | Name id -> pr_id id + +let pr_located pr (loc,x) = pr x -let pr_constr = gentermpr +let pr_let_binder pr x a = + hv 0 ( + str "[" ++ brk(0,1) ++ + pr_name x ++ brk(0,1) ++ + str ":=" ++ brk(0,1) ++ + pr ltop a ++ brk(0,1) ++ + str "]") -let pr_pattern = gentermpr +let pr_binder pr (nal,t) = + hov 0 ( + prlist_with_sep pr_tight_coma (pr_located pr_name) nal ++ + pr_opt_type pr t) + +let pr_binders pr bl = + hv 0 (prlist_with_sep pr_semicolon (pr_binder pr) bl) + +let pr_recursive_decl pr id b t c = + pr_id id ++ + brk (1,2) ++ str ": " ++ pr ltop t ++ str ":=" ++ + brk (1,2) ++ pr ltop c + +let pr_fixdecl pr (id,bl,t,c) = + pr_recursive_decl pr id + (brk (1,2) ++ str "[" ++ pr_binders pr bl ++ str "]") t c + +let pr_cofixdecl pr (id,t,c) = + pr_recursive_decl pr id (mt ()) t c + +let pr_recursive s pr_decl id = function + | [] -> anomaly "(co)fixpoint with no definition" + | d1::dl -> + hov 0 ( + str "Fix " ++ pr_id id ++ brk (0,2) ++ str "{" ++ + (v 0 ( + (hov 0 (pr_decl d1)) ++ + (prlist (fun fix -> fnl () ++ hov 0 (str "with" ++ pr_decl fix)) + dl))) ++ + str "}") + +let pr_fix pr = pr_recursive "Fix" (pr_fixdecl pr) +let pr_cofix pr = pr_recursive "Fix" (pr_cofixdecl pr) + +let rec pr_arrow pr = function + | CArrow (_,a,b) -> pr (lprod,L) a ++ cut () ++ str "->" ++ pr_arrow pr b + | a -> pr (lprod,E) a + +let pr_annotation pr t = str "<" ++ pr ltop t ++ str ">" + +let pr_cases _ _ _ = str "" + +let rec pr inherited a = + let (strm,prec) = match a with + | CRef r -> pr_reference r, latom + | CFix (_,id,fix) -> pr_fix pr (snd id) fix, latom + | CCoFix (_,id,cofix) -> pr_cofix pr (snd id) cofix, latom + | CArrow _ -> hv 0 (pr_arrow pr a), lprod + | CProdN (_,bl,a) -> + hov 0 ( + str "(" ++ pr_binders pr bl ++ str ")" ++ brk(0,1) ++ pr ltop a), lprod + | CLambdaN (_,bl,a) -> + hov 0 ( + str "[" ++ pr_binders pr bl ++ str "]" ++ brk(0,1) ++ pr ltop a), lprod + | CLetIn (_,x,a,b) -> + hov 0 (pr_let_binder pr (snd x) a ++ cut () ++ pr ltop b), lprod + | CAppExpl (_,f,l) -> + hov 0 ( + str "!" ++ pr_reference f ++ + prlist (fun a -> brk (1,1) ++ pr (latom,E) a) l), lapp + | CApp (_,a,l) -> + hov 0 ( + pr (latom,E) a ++ + prlist (fun a -> brk (1,1) ++ pr_expl_args pr a) l), lapp + | CCases (_,po,c,eqns) -> + pr_cases po c eqns, lannot + | COrderedCase (_,IfStyle,po,c,[b1;b2]) -> + (* On force les parenthèses autour d'un "if" sous-terme (même si le + parsing est lui plus tolérant) *) + hov 0 ( + pr_opt (pr_annotation pr) po ++ + hv 0 ( + str "if" ++ pr ltop c ++ spc () ++ + hov 0 (str "then" ++ brk (1,1) ++ pr ltop b1) ++ spc () ++ + hov 0 (str "else" ++ brk (1,1) ++ pr ltop b2))), lapp + | COrderedCase (_,LetStyle,po,c,[CLambdaN(_,[_,_ as bd],b)]) -> + hov 0 ( + pr_opt (pr_annotation pr) po ++ + hv 0 ( + str "let" ++ brk (1,1) ++ + hov 0 (str "(" ++ pr_binder pr bd ++ str ")") ++ + str "=" ++ brk (1,1) ++ + pr ltop c ++ spc () ++ + str "in " ++ pr ltop b)), lapp + | COrderedCase (_,(MatchStyle|RegularStyle as style),po,c,bl) -> + hov 0 ( + hov 0 ( + pr_opt (pr_annotation pr) po ++ brk (0,2) ++ + hov 0 ( + str (if style=RegularStyle then "Case" else "Match") ++ + brk (1,1) ++ pr ltop c ++ spc () ++ + str (if style=RegularStyle then "of" else "with") ++ + brk (1,3) ++ + hov 0 (prlist (fun b -> pr ltop b ++ fnl ()) bl)) ++ + str "end")), lannot + | COrderedCase (_,_,_,_,_) -> + anomaly "malformed if or destructuring let" + | CHole _ -> str "?", latom + | CMeta (_,p) -> str "?" ++ int p, latom + | CSort (_,s) -> pr_sort s, latom + | CCast (_,a,b) -> + hv 0 (pr (lcast,L) a ++ cut () ++ str "::" ++ pr (lcast,E) b), lcast + | CNotation (_,s,env) -> pr_notation pr s env + | CGrammar _ -> failwith "CGrammar: TODO" + | CNumeral (_,p) -> Bignat.pr_bigint p, latom + | CDelimiters (_,sc,a) -> failwith "pr_delim: TODO" +(* pr_delimiters (find_delimiters) (pr_constr_expr a)*) + | CDynamic _ -> str "", latom + in + if prec_less prec inherited then strm + else str"(" ++ strm ++ str")" + +let pr_constr = pr ltop + +let pr_pattern x = (* gentermpr*) failwith "pr_pattern: TODO" let pr_qualid qid = str (string_of_qualid qid) @@ -110,7 +276,7 @@ let pr_red_flag pr r = open Genarg let pr_metanum pr = function - | AN (_,x) -> pr x + | AN x -> pr x | MetaNum (_,n) -> str "?" ++ int n let pr_red_expr (pr_constr,pr_ref) = function @@ -139,7 +305,7 @@ let pr_red_expr (pr_constr,pr_ref) = function let rec pr_may_eval pr = function | ConstrEval (r,c) -> hov 0 - (str "Eval" ++ brk (1,1) ++ pr_red_expr (pr,pr_metanum pr_qualid) r ++ + (str "Eval" ++ brk (1,1) ++ pr_red_expr (pr,pr_metanum pr_reference) r ++ spc () ++ str "in" ++ brk (1,1) ++ pr c) | ConstrContext ((_,id),c) -> hov 0 @@ -147,3 +313,25 @@ let rec pr_may_eval pr = function str "[" ++ pr c ++ str "]") | ConstrTypeOf c -> hov 0 (str "Check " ++ brk (1,1) ++ pr c) | ConstrTerm c -> pr c + +(**********************************************************************) +let constr_syntax_universe = "constr" +(* This is starting precedence for printing constructions or tactics *) +(* Level 9 means no parentheses except for applicative terms (at level 10) *) +let constr_initial_prec = Some (9,Ppextend.L) + +let gentermpr_fail gt = + Esyntax.genprint globpr constr_syntax_universe constr_initial_prec gt + +let gentermpr gt = + try gentermpr_fail gt + with s -> wrap_exception s + +(* [at_top] means ids of env must be avoided in bound variables *) +let gentermpr_core at_top env t = + gentermpr (Termast.ast_of_constr at_top env t) +(* +let gentermpr_core at_top env t = + pr_constr (Constrextern.extern_constr at_top env t) +*) + diff --git a/parsing/ppconstr.mli b/parsing/ppconstr.mli index 04225ef7a..bd95637fa 100644 --- a/parsing/ppconstr.mli +++ b/parsing/ppconstr.mli @@ -1,13 +1,10 @@ -(****************************************************************************) -(* *) -(* The Coq Proof Assistant *) -(* *) -(* Projet Coq *) -(* *) -(* INRIA LRI-CNRS ENS-CNRS *) -(* Rocquencourt Orsay Lyon *) -(* *) -(****************************************************************************) +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* std_ppcmds + val gentermpr : Coqast.t -> std_ppcmds val gentermpr_core : bool -> env -> constr -> std_ppcmds +val pr_opt : ('a -> std_ppcmds) -> 'a option -> std_ppcmds +val pr_name : name -> std_ppcmds val pr_qualid : qualid -> std_ppcmds val pr_red_expr : ('a -> std_ppcmds) * ('b -> std_ppcmds) -> ('a,'b) red_expr_gen -> std_ppcmds -val pr_pattern : Tacexpr.pattern_ast -> std_ppcmds -val pr_constr : Genarg.constr_ast -> std_ppcmds +val pr_sort : rawsort -> std_ppcmds +val pr_pattern : Tacexpr.pattern_expr -> std_ppcmds +val pr_constr : constr_expr -> std_ppcmds val pr_may_eval : ('a -> std_ppcmds) -> 'a may_eval -> std_ppcmds diff --git a/parsing/pptactic.ml b/parsing/pptactic.ml index 2abdc6813..6571e0af8 100644 --- a/parsing/pptactic.ml +++ b/parsing/pptactic.ml @@ -1,13 +1,10 @@ -(****************************************************************************) -(* *) -(* The Coq Proof Assistant *) -(* *) -(* Projet Coq *) -(* *) -(* INRIA LRI-CNRS ENS-CNRS *) -(* Rocquencourt Orsay Lyon *) -(* *) -(****************************************************************************) +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* mt () - | Name id -> spc () ++ pr_id id - let pr_metanum pr = function - | AN (_,x) -> pr x + | AN x -> pr x | MetaNum (_,n) -> str "?" ++ int n let pr_or_var pr = function | ArgArg x -> pr x | ArgVar (_,s) -> pr_id s -let pr_opt pr = function - | None -> mt () - | Some x -> spc () ++ pr x - let pr_or_meta pr = function | AI x -> pr x | _ -> failwith "pr_hyp_location: unexpected quotation meta-variable" @@ -189,7 +179,7 @@ let pr_autoarg_adding = function | [] -> mt () | l -> spc () ++ str "Adding [" ++ - hv 0 (prlist_with_sep spc (fun (_,x) -> pr_qualid x) l) ++ str "]" + hv 0 (prlist_with_sep spc pr_reference l) ++ str "]" let pr_autoarg_destructing = function | true -> spc () ++ str "Destructing" @@ -207,14 +197,15 @@ let rec pr_rawgen prtac x = | StringArgType -> spc () ++ str "\"" ++ str (out_gen rawwit_string x) ++ str "\"" | PreIdentArgType -> pr_arg str (out_gen rawwit_pre_ident x) | IdentArgType -> pr_arg pr_id (out_gen rawwit_ident x) - | QualidArgType -> pr_arg pr_qualid (snd (out_gen rawwit_qualid x)) + | RefArgType -> pr_arg pr_reference (out_gen rawwit_ref x) + | SortArgType -> pr_arg pr_sort (out_gen rawwit_sort x) | ConstrArgType -> pr_arg pr_constr (out_gen rawwit_constr x) | ConstrMayEvalArgType -> pr_arg (pr_may_eval pr_constr) (out_gen rawwit_constr_may_eval x) | QuantHypArgType -> pr_arg pr_quantified_hypothesis (out_gen rawwit_quant_hyp x) | RedExprArgType -> - pr_arg (pr_red_expr (pr_constr,pr_metanum pr_qualid)) (out_gen rawwit_red_expr x) + pr_arg (pr_red_expr (pr_constr,pr_metanum pr_reference)) (out_gen rawwit_red_expr x) | TacticArgType -> pr_arg prtac (out_gen rawwit_tactic x) | CastedOpenConstrArgType -> pr_arg pr_casted_open_constr (out_gen rawwit_casted_open_constr x) @@ -264,7 +255,8 @@ let rec pr_generic prtac x = | StringArgType -> spc () ++ str "\"" ++ str (out_gen wit_string x) ++ str "\"" | PreIdentArgType -> pr_arg str (out_gen wit_pre_ident x) | IdentArgType -> pr_arg pr_id (out_gen wit_ident x) - | QualidArgType -> pr_arg pr_global (out_gen wit_qualid x) + | RefArgType -> pr_arg pr_global (out_gen wit_ref x) + | SortArgType -> pr_arg Printer.prterm (Term.mkSort (out_gen wit_sort x)) | ConstrArgType -> pr_arg Printer.prterm (out_gen wit_constr x) | ConstrMayEvalArgType -> pr_arg Printer.prterm (out_gen wit_constr_may_eval x) @@ -329,7 +321,7 @@ let rec pr_atom0 = function (* Main tactic printer *) and pr_atom1 = function - | TacExtend (s,l) -> pr_extend !pr_rawtac s l + | TacExtend (_,s,l) -> pr_extend !pr_rawtac s l | TacAlias (s,l,_) -> pr_extend !pr_rawtac s (List.map snd l) (* Basic tactics *) @@ -372,9 +364,9 @@ and pr_atom1 = function | TacTrueCut (Some id,c) -> hov 1 (str "Assert" ++ spc () ++ pr_id id ++ str ":" ++ pr_constr c) | TacForward (false,na,c) -> - hov 1 (str "Assert" ++ pr_name na ++ str ":=" ++ pr_constr c) + hov 1 (str "Assert" ++ pr_arg pr_name na ++ str ":=" ++ pr_constr c) | TacForward (true,na,c) -> - hov 1 (str "Pose" ++ pr_name na ++ str ":=" ++ pr_constr c) + hov 1 (str "Pose" ++ pr_arg pr_name na ++ str ":=" ++ pr_constr c) | TacGeneralize l -> hov 1 (str "Generalize" ++ spc () ++ prlist_with_sep spc pr_constr l) | TacGeneralizeDep c -> @@ -566,10 +558,6 @@ and pr6 = function | TacArg c -> pr_tacarg c -and pr_reference = function - | RQualid (_,qid) -> pr_qualid qid - | RIdent (_,id) -> pr_id id - and pr_tacarg0 = function | TacDynamic (_,t) -> str ("") | MetaNumArg (_,n) -> str ("?" ^ string_of_int n ) @@ -596,8 +584,8 @@ in (prtac,pr0,pr_match_rule) let (pr_raw_tactic,pr_raw_tactic0,pr_match_rule) = make_pr_tac (Ppconstr.pr_constr, - pr_metanum pr_qualid, - pr_qualid, + pr_metanum pr_reference, + pr_reference, pr_or_meta (fun (loc,id) -> pr_id id), pr_raw_extend) diff --git a/parsing/pptactic.mli b/parsing/pptactic.mli index b049a6c47..a3963571c 100644 --- a/parsing/pptactic.mli +++ b/parsing/pptactic.mli @@ -1,13 +1,10 @@ -(****************************************************************************) -(* *) -(* The Coq Proof Assistant *) -(* *) -(* Projet Coq *) -(* *) -(* INRIA LRI-CNRS ENS-CNRS *) -(* Rocquencourt Orsay Lyon *) -(* *) -(****************************************************************************) +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* unit -val pr_match_rule : bool -> (raw_tactic_expr -> std_ppcmds) -> (pattern_ast,raw_tactic_expr) match_rule -> std_ppcmds +val pr_match_rule : bool -> (raw_tactic_expr -> std_ppcmds) -> + (pattern_expr,raw_tactic_expr) match_rule -> std_ppcmds val pr_raw_tactic : raw_tactic_expr -> std_ppcmds diff --git a/parsing/prettyp.ml b/parsing/prettyp.ml index 0f1157f1d..d963d8644 100644 --- a/parsing/prettyp.ml +++ b/parsing/prettyp.ml @@ -398,7 +398,8 @@ let list_filter_vec f vec = frec (Array.length vec -1) [] (* This is designed to print the contents of an opened section *) -let read_sec_context (loc,qid) = +let read_sec_context r = + let loc,qid = qualid_of_reference r in let dir = try Nametab.locate_section qid with Not_found -> @@ -430,7 +431,8 @@ let print_eval red_fun env {uj_val=trm;uj_type=typ} = let ntrm = red_fun env Evd.empty trm in (str " = " ++ print_judgment env {uj_val = ntrm; uj_type = typ}) -let print_name (loc,qid) = +let print_name r = + let loc,qid = qualid_of_reference r in try let sp = Nametab.locate_obj qid in let (oname,lobj) = diff --git a/parsing/prettyp.mli b/parsing/prettyp.mli index 2d175f1f9..54d952ed5 100644 --- a/parsing/prettyp.mli +++ b/parsing/prettyp.mli @@ -30,8 +30,8 @@ val print_context : bool -> Lib.library_segment -> std_ppcmds val print_library_entry : bool -> (object_name * Lib.node) -> std_ppcmds val print_full_context : unit -> std_ppcmds val print_full_context_typ : unit -> std_ppcmds -val print_sec_context : qualid located -> std_ppcmds -val print_sec_context_typ : qualid located -> std_ppcmds +val print_sec_context : reference -> std_ppcmds +val print_sec_context_typ : reference -> std_ppcmds val print_judgment : env -> unsafe_judgment -> std_ppcmds val print_safe_judgment : env -> Safe_typing.judgment -> std_ppcmds val print_eval : @@ -40,8 +40,8 @@ val print_eval : val build_inductive : mutual_inductive -> int -> global_reference * rel_context * types * identifier array * types array val print_mutual : mutual_inductive -> std_ppcmds -val print_name : qualid located -> std_ppcmds -val print_opaque_name : qualid located -> std_ppcmds +val print_name : reference -> std_ppcmds +val print_opaque_name : reference -> std_ppcmds val print_local_context : unit -> std_ppcmds (*i diff --git a/parsing/printer.ml b/parsing/printer.ml index 5867d8143..6305cd650 100644 --- a/parsing/printer.ml +++ b/parsing/printer.ml @@ -35,7 +35,7 @@ let tactic_syntax_universe = "tactic" (* This is starting precedence for printing constructions or tactics *) (* Level 9 means no parentheses except for applicative terms (at level 10) *) -let tactic_initial_prec = Some ((tactic_syntax_universe,(9,0,0)),Extend.L) +let tactic_initial_prec = Some ((tactic_syntax_universe,(9,0,0)),Ppextend.L) let prterm_env_at_top env = gentermpr_core true env let prterm_env env = gentermpr_core false env diff --git a/parsing/q_coqast.ml4 b/parsing/q_coqast.ml4 index 9b1977f0e..06ccc6bea 100644 --- a/parsing/q_coqast.ml4 +++ b/parsing/q_coqast.ml4 @@ -110,13 +110,15 @@ and expr_list_of_var_list sl = (* We don't give location for tactic quotation! *) let loc = dummy_loc +let dloc = <:expr< (0,0) >> + let mlexpr_of_ident id = <:expr< Names.id_of_string $str:Names.string_of_id id$ >> let mlexpr_of_name = function | Names.Anonymous -> <:expr< Names.Anonymous >> | Names.Name id -> - <:expr< Names.Names (Names.id_of_string $str:Names.string_of_id id$) >> + <:expr< Names.Name (Names.id_of_string $str:Names.string_of_id id$) >> let mlexpr_of_dirpath dir = let l = Names.repr_dirpath dir in @@ -127,8 +129,8 @@ let mlexpr_of_qualid qid = <:expr< make_qualid $mlexpr_of_dirpath dir$ $mlexpr_of_ident id$ >> let mlexpr_of_reference = function - | Coqast.RQualid (loc,qid) -> <:expr< Coqast.RQualid loc $mlexpr_of_qualid qid$ >> - | Coqast.RIdent (loc,id) -> <:expr< Coqast.RIdent loc $mlexpr_of_ident id$ >> + | Libnames.Qualid (loc,qid) -> <:expr< Libnames.Qualid $dloc$ $mlexpr_of_qualid qid$ >> + | Libnames.Ident (loc,id) -> <:expr< Libnames.Ident $dloc$ $mlexpr_of_ident id$ >> let mlexpr_of_bool = function | true -> <:expr< True >> @@ -138,14 +140,14 @@ let mlexpr_of_intro_pattern = function | Tacexpr.IntroOrAndPattern _ -> failwith "mlexpr_of_intro_pattern: TODO" | Tacexpr.IntroWildcard -> <:expr< Tacexpr.IntroWildcard >> | Tacexpr.IntroIdentifier id -> - <:expr< Tacexpr.IntroIdentifier (mlexpr_of_ident loc id) >> + <:expr< Tacexpr.IntroIdentifier (mlexpr_of_ident $dloc$ id) >> let mlexpr_of_ident_option = mlexpr_of_option (mlexpr_of_ident) let mlexpr_of_or_metanum f = function - | Rawterm.AN (_,a) -> <:expr< Rawterm.AN loc $f a$ >> + | Rawterm.AN a -> <:expr< Rawterm.AN $f a$ >> | Rawterm.MetaNum (_,n) -> - <:expr< Rawterm.MetaNum loc $mlexpr_of_int n$ >> + <:expr< Rawterm.MetaNum $dloc$ $mlexpr_of_int n$ >> let mlexpr_of_or_metaid f = function | Tacexpr.AI a -> <:expr< Tacexpr.AI $f a$ >> @@ -155,7 +157,7 @@ let mlexpr_of_quantified_hypothesis = function | Rawterm.AnonHyp n -> <:expr< Rawterm.AnonHyp $mlexpr_of_int n$ >> | Rawterm.NamedHyp id -> <:expr< Rawterm.NamedHyp $mlexpr_of_ident id$ >> -let mlexpr_of_located f (loc,x) = <:expr< (loc, $f x$) >> +let mlexpr_of_located f (loc,x) = <:expr< ($dloc$, $f x$) >> let mlexpr_of_hyp_location = function | Tacexpr.InHyp id -> @@ -181,10 +183,25 @@ let mlexpr_of_red_flags { Rawterm.rIota = $mlexpr_of_bool bi$; Rawterm.rZeta = $mlexpr_of_bool bz$; Rawterm.rDelta = $mlexpr_of_bool bd$; - Rawterm.rConst = $mlexpr_of_list (mlexpr_of_or_metanum mlexpr_of_qualid) l$ + Rawterm.rConst = $mlexpr_of_list (mlexpr_of_or_metanum mlexpr_of_reference) l$ } >> -let mlexpr_of_constr = mlexpr_of_ast +let rec mlexpr_of_constr = function + | Topconstr.CRef r -> <:expr< Topconstr.CRef $mlexpr_of_reference r$ >> + | Topconstr.CFix (loc,_,_) -> failwith "mlexpr_of_constr: TODO" + | Topconstr.CCoFix (loc,_,_) -> failwith "mlexpr_of_constr: TODO" + | Topconstr.CArrow (loc,a,b) -> + <:expr< Topconstr.CArrow $dloc$ $mlexpr_of_constr a$ $mlexpr_of_constr b$ >> + | Topconstr.CProdN (loc,l,a) -> <:expr< Topconstr.CProdN $dloc$ $mlexpr_of_list (mlexpr_of_pair (mlexpr_of_list (mlexpr_of_pair (fun _ -> dloc) mlexpr_of_name)) mlexpr_of_constr) l$ $mlexpr_of_constr a$ >> + | Topconstr.CLambdaN (loc,l,a) -> <:expr< Topconstr.CLambdaN $dloc$ $mlexpr_of_list (mlexpr_of_pair (mlexpr_of_list (mlexpr_of_pair (fun _ -> dloc) mlexpr_of_name)) mlexpr_of_constr) l$ $mlexpr_of_constr a$ >> + | Topconstr.CLetIn (loc,_,_,_) -> failwith "mlexpr_of_constr: TODO" + | Topconstr.CAppExpl (loc,a,l) -> <:expr< Topconstr.CAppExpl $dloc$ $mlexpr_of_reference a$ $mlexpr_of_list mlexpr_of_constr l$ >> + | Topconstr.CApp (loc,a,l) -> <:expr< Topconstr.CApp $dloc$ $mlexpr_of_constr a$ $mlexpr_of_list (mlexpr_of_pair mlexpr_of_constr (mlexpr_of_option mlexpr_of_int)) l$ >> + | Topconstr.CCases (loc,_,_,_) -> failwith "mlexpr_of_constr: TODO" + | Topconstr.COrderedCase (loc,_,_,_,_) -> failwith "mlexpr_of_constr: TODO" + | Topconstr.CHole loc -> <:expr< Topconstr.CHole $dloc$ >> + | Topconstr.CMeta (loc,n) -> <:expr< Topconstr.CMeta $dloc$ $mlexpr_of_int n$ >> + | _ -> failwith "mlexpr_of_constr: TODO" let mlexpr_of_red_expr = function | Rawterm.Red b -> <:expr< Rawterm.Red $mlexpr_of_bool b$ >> @@ -196,7 +213,7 @@ let mlexpr_of_red_expr = function <:expr< Rawterm.Lazy $mlexpr_of_red_flags f$ >> | Rawterm.Unfold l -> let f1 = mlexpr_of_list mlexpr_of_int in - let f2 = mlexpr_of_or_metanum mlexpr_of_qualid in + let f2 = mlexpr_of_or_metanum mlexpr_of_reference in let f = mlexpr_of_list (mlexpr_of_pair f1 f2) in <:expr< Rawterm.Unfold $f l$ >> | Rawterm.Fold l -> @@ -213,7 +230,7 @@ let rec mlexpr_of_argtype loc = function | Genarg.BoolArgType -> <:expr< Genarg.BoolArgType >> | Genarg.IntArgType -> <:expr< Genarg.IntArgType >> | Genarg.IntOrVarArgType -> <:expr< Genarg.IntOrVarArgType >> - | Genarg.QualidArgType -> <:expr< Genarg.QualidArgType >> + | Genarg.RefArgType -> <:expr< Genarg.RefArgType >> | Genarg.PreIdentArgType -> <:expr< Genarg.PreIdentArgType >> | Genarg.IdentArgType -> <:expr< Genarg.IdentArgType >> | Genarg.StringArgType -> <:expr< Genarg.StringArgType >> @@ -222,6 +239,7 @@ let rec mlexpr_of_argtype loc = function | Genarg.ConstrWithBindingsArgType -> <:expr< Genarg.ConstrWithBindingsArgType >> | Genarg.RedExprArgType -> <:expr< Genarg.RedExprArgType >> | Genarg.TacticArgType -> <:expr< Genarg.TacticArgType >> + | Genarg.SortArgType -> <:expr< Genarg.SortArgType >> | Genarg.ConstrArgType -> <:expr< Genarg.ConstrArgType >> | Genarg.ConstrMayEvalArgType -> <:expr< Genarg.ConstrMayEvalArgType >> | Genarg.List0ArgType t -> <:expr< Genarg.List0ArgType $mlexpr_of_argtype loc t$ >> @@ -258,7 +276,7 @@ let mlexpr_of_induction_arg = function | Tacexpr.ElimOnConstr c -> <:expr< Tacexpr.ElimOnConstr $mlexpr_of_constr c$ >> | Tacexpr.ElimOnIdent (_,id) -> - <:expr< Tacexpr.ElimOnIdent loc $mlexpr_of_ident id$ >> + <:expr< Tacexpr.ElimOnIdent $dloc$ $mlexpr_of_ident id$ >> | Tacexpr.ElimOnAnonHyp n -> <:expr< Tacexpr.ElimOnAnonHyp $mlexpr_of_int n$ >> @@ -269,7 +287,7 @@ let mlexpr_of_constr_with_binding = let mlexpr_of_clause_pattern _ = failwith "mlexpr_of_clause_pattern: TODO" -let mlexpr_of_pattern_ast = mlexpr_of_ast +let mlexpr_of_pattern_ast = mlexpr_of_constr let mlexpr_of_entry_type = function _ -> failwith "mlexpr_of_entry_type: TODO" @@ -418,14 +436,14 @@ let rec mlexpr_of_atomic_tactic = function (* | Tacexpr.TacExtend (s,l) -> let l = mlexpr_of_list mlexpr_of_tactic_arg l in - let loc = MLast.loc_of_expr l in + let $dloc$ = MLast.loc_of_expr l in <:expr< Tacexpr.TacExtend $mlexpr_of_string s$ $l$ >> *) | _ -> failwith "Quotation of atomic tactic expressions: TODO" and mlexpr_of_tactic = function | Tacexpr.TacAtom (loc,t) -> - <:expr< Tacexpr.TacAtom loc $mlexpr_of_atomic_tactic t$ >> + <:expr< Tacexpr.TacAtom $dloc$ $mlexpr_of_atomic_tactic t$ >> | Tacexpr.TacThen (t1,t2) -> <:expr< Tacexpr.TacThen $mlexpr_of_tactic t1$ $mlexpr_of_tactic t2$ >> | Tacexpr.TacThens (t,tl) -> @@ -444,9 +462,8 @@ and mlexpr_of_tactic = function <:expr< Tacexpr.TacRepeat $mlexpr_of_tactic t$ >> | Tacexpr.TacProgress t -> <:expr< Tacexpr.TacProgress $mlexpr_of_tactic t$ >> - | Tacexpr.TacId -> let loc = dummy_loc in <:expr< Tacexpr.TacId >> - | Tacexpr.TacFail n -> - let loc = dummy_loc in <:expr< Tacexpr.TacFail $int:string_of_int n$ >> + | Tacexpr.TacId -> <:expr< Tacexpr.TacId >> + | Tacexpr.TacFail n -> <:expr< Tacexpr.TacFail $int:string_of_int n$ >> (* | Tacexpr.TacInfo t -> TacInfo (loc,f t) @@ -456,7 +473,7 @@ and mlexpr_of_tactic = function | Tacexpr.TacLetIn (l,t) -> let f = mlexpr_of_triple - (mlexpr_of_pair (fun _ -> <:expr< loc >>) mlexpr_of_ident) + (mlexpr_of_pair (fun _ -> dloc) mlexpr_of_ident) (mlexpr_of_option (mlexpr_of_may_eval mlexpr_of_constr)) mlexpr_of_tactic_arg in <:expr< Tacexpr.TacLetIn $mlexpr_of_list f l$ $mlexpr_of_tactic t$ >> @@ -469,11 +486,11 @@ and mlexpr_of_tactic = function $mlexpr_of_bool lr$ $mlexpr_of_list (mlexpr_of_match_rule mlexpr_of_tactic) l$>> (* - | Tacexpr.TacFun of loc * tactic_fun_ast - | Tacexpr.TacFunRec of loc * identifier * tactic_fun_ast + | Tacexpr.TacFun of $dloc$ * tactic_fun_ast + | Tacexpr.TacFunRec of $dloc$ * identifier * tactic_fun_ast *) (* - | Tacexpr.TacArg (Tacexpr.AstTacArg (Coqast.Nmeta loc id)) -> anti loc id + | Tacexpr.TacArg (Tacexpr.AstTacArg (Coqast.Nmeta $dloc$ id)) -> anti loc id *) | Tacexpr.TacArg (Tacexpr.MetaIdArg (_,id)) -> anti loc id | Tacexpr.TacArg t -> @@ -483,35 +500,15 @@ and mlexpr_of_tactic = function and mlexpr_of_tactic_arg = function | Tacexpr.MetaIdArg (loc,id) -> anti loc id | Tacexpr.MetaNumArg (loc,n) -> - <:expr< Tacexpr.MetaNumArg loc $mlexpr_of_int n$ >> -(* - | Tacexpr.Identifier id -> - <:expr< Tacexpr.Identifier $mlexpr_of_ident id$ >> -*) -(* - | Tacexpr.AstTacArg t -> - <:expr< Tacexpr.AstTacArg $mlexpr_of_ast t$ >> -*) + <:expr< Tacexpr.MetaNumArg $dloc$ $mlexpr_of_int n$ >> | Tacexpr.TacCall (loc,t,tl) -> - <:expr< Tacexpr.TacCall loc $mlexpr_of_reference t$ $mlexpr_of_list mlexpr_of_tactic_arg tl$>> + <:expr< Tacexpr.TacCall $dloc$ $mlexpr_of_reference t$ $mlexpr_of_list mlexpr_of_tactic_arg tl$>> | Tacexpr.Tacexp t -> <:expr< Tacexpr.Tacexp $mlexpr_of_tactic t$ >> | Tacexpr.ConstrMayEval c -> <:expr< Tacexpr.ConstrMayEval $mlexpr_of_may_eval mlexpr_of_constr c$ >> -(* - | Tacexpr.Constr c -> - <:expr< Tacexpr.Constr $mlexpr_of_constr c$ >> -*) -(* - | Tacexpr.Qualid q -> - <:expr< Tacexpr.Qualid $mlexpr_of_qualid q$ >> -*) | Tacexpr.Reference r -> <:expr< Tacexpr.Reference $mlexpr_of_reference r$ >> -(* - | Tacexpr.TacArgGen q -> - <:expr< Tacexpr.TacArgGen $mlexpr_of_argtype q$ >> -*) | _ -> failwith "mlexpr_of_tactic_arg: TODO" let f e = @@ -542,5 +539,5 @@ let _ = Quotation.add "constr" (fconstr Pcoq.Constr.constr_eoi); Quotation.add "tactic" (ftac Pcoq.Tactic.tactic_eoi); (* Quotation.add "vernac" (f Pcoq.Vernac_.vernac_eoi);*) - Quotation.add "ast" (f Pcoq.Prim.ast_eoi); +(* Quotation.add "ast" (f Pcoq.Prim.ast_eoi);*) Quotation.default := "constr" diff --git a/parsing/search.ml b/parsing/search.ml index e1723a1d1..c771a7737 100644 --- a/parsing/search.ml +++ b/parsing/search.ml @@ -18,7 +18,6 @@ open Declarations open Libobject open Declare open Coqast -open Astterm open Environ open Pattern open Printer diff --git a/parsing/symbols.ml b/parsing/symbols.ml deleted file mode 100644 index cc76d4aa0..000000000 --- a/parsing/symbols.ml +++ /dev/null @@ -1,320 +0,0 @@ -open Util -open Pp -open Names -open Nametab -open Summary -open Rawterm -open Bignat - -(* A scope is a set of notations; it includes - - - a set of ML interpreters/parsers for positive (e.g. 0, 1, 15, ...) and - negative numbers (e.g. -0, -2, -13, ...). These interpreters may - fail if a number has no interpretation in the scope (e.g. there is - no interpretation for negative numbers in [nat]); interpreters both for - terms and patterns can be set; these interpreters are in permanent table - [numeral_interpreter_tab] - - a set of ML printers for expressions denoting numbers parsable in - this scope (permanently declared in [Esyntax.primitive_printer_tab]) - - a set of interpretations for infix (more generally distfix) notations - - an optional pair of delimiters which, when occurring in a syntactic - expression, set this scope to be the current scope -*) - -let pr_bigint = function - | POS n -> str (Bignat.to_string n) - | NEG n -> str "-" ++ str (Bignat.to_string n) - -(**********************************************************************) -(* Scope of symbols *) - -type level = Extend.precedence * Extend.precedence list -type notation = string -type scope_name = string -type delimiters = string * string -type scope = { - notations: (rawconstr * level) Stringmap.t; - delimiters: delimiters option -} -type scopes = scope_name list - -(* Scopes table: scope_name -> symbol_interpretation *) -let scope_map = ref Stringmap.empty - -let empty_scope = { - notations = Stringmap.empty; - delimiters = None -} - -let default_scope = "core_scope" - -let _ = Stringmap.add default_scope empty_scope !scope_map - -let scope_stack = ref [default_scope] - -let current_scopes () = !scope_stack - -(* TODO: push nat_scope, z_scope, ... in scopes summary *) - -(**********************************************************************) -(* Interpreting numbers (not in summary because functional objects) *) - -type numeral_interpreter_name = string -type numeral_interpreter = - (loc -> bigint -> rawconstr) - * (loc -> bigint -> name -> cases_pattern) option - -let numeral_interpreter_tab = - (Hashtbl.create 17 : (numeral_interpreter_name,numeral_interpreter)Hashtbl.t) - -let declare_numeral_interpreter sc t = - Hashtbl.add numeral_interpreter_tab sc t - -let lookup_numeral_interpreter s = - try - Hashtbl.find numeral_interpreter_tab s - with Not_found -> - error ("No interpretation for numerals in scope "^s) - -(* For loading without opening *) -let declare_scope scope = - try let _ = Stringmap.find scope !scope_map in () - with Not_found -> -(* Options.if_verbose message ("Creating scope "^scope);*) - scope_map := Stringmap.add scope empty_scope !scope_map - -let find_scope scope = - try Stringmap.find scope !scope_map - with Not_found -> error ("Scope "^scope^" is not declared") - -let check_scope sc = let _ = find_scope sc in () - -let declare_delimiters scope dlm = - let sc = find_scope scope in - if sc.delimiters <> None && Options.is_verbose () then - warning ("Overwriting previous delimiters in "^scope); - let sc = { sc with delimiters = Some dlm } in - scope_map := Stringmap.add scope sc !scope_map - -(* The mapping between notations and production *) - -let declare_notation prec nt c scope = - let sc = find_scope scope in - if Stringmap.mem nt sc.notations && Options.is_verbose () then - warning ("Notation "^nt^" is already used in scope "^scope); - let sc = { sc with notations = Stringmap.add nt (c,prec) sc.notations } in - scope_map := Stringmap.add scope sc !scope_map - -open Coqast - -let rec subst_meta_rawconstr subst = function - | RMeta (_,n) -> List.nth subst (n-1) - | t -> map_rawconstr (subst_meta_rawconstr subst) t - -let rec find_interpretation f = function - | scope::scopes -> - (try f (find_scope scope) - with Not_found -> find_interpretation f scopes) - | [] -> raise Not_found - -let rec interp_notation ntn scopes args = - let f scope = - let (c,_) = Stringmap.find ntn scope.notations in - subst_meta_rawconstr args c in - try find_interpretation f scopes - with Not_found -> anomaly ("Unknown interpretation for notation "^ntn) - -let find_notation_with_delimiters scope = - match (Stringmap.find scope !scope_map).delimiters with - | Some dlm -> Some (Some dlm) - | None -> None - -let rec find_notation_without_delimiters ntn_scope ntn = function - | scope::scopes -> - (* Is the expected printer attached to the most recently open scope? *) - if scope = ntn_scope then - Some None - else - (* If the most recently open scope has a printer for this pattern - but not the expected one then we need delimiters *) - if Stringmap.mem ntn (Stringmap.find scope !scope_map).notations then - find_notation_with_delimiters ntn_scope - else - find_notation_without_delimiters ntn_scope ntn scopes - | [] -> - find_notation_with_delimiters ntn_scope - -let find_notation ntn_scope ntn scopes = - match - find_notation_without_delimiters ntn_scope ntn scopes - with - | None -> None - | Some None -> Some (None,scopes) - | Some x -> Some (x,ntn_scope::scopes) - -let exists_notation_in_scope scope prec ntn r = - try Stringmap.find ntn (Stringmap.find scope !scope_map).notations = (r,prec) - with Not_found -> false - -let exists_notation_prec prec nt sc = - try snd (Stringmap.find nt sc.notations) = prec with Not_found -> false - -let exists_notation prec nt = - Stringmap.fold (fun scn sc b -> b or exists_notation_prec prec nt sc) - !scope_map false - -(* We have to print delimiters; look for the more recent defined one *) -(* Do we need to print delimiters? To know it, we look for a numeral *) -(* printer available in the current stack of scopes *) -let find_numeral_with_delimiters scope = - match (Stringmap.find scope !scope_map).delimiters with - | Some dlm -> Some (Some dlm) - | None -> None - -let rec find_numeral_without_delimiters printer_scope = function - | scope :: scopes -> - (* Is the expected printer attached to the most recently open scope? *) - if scope = printer_scope then - Some None - else - (* If the most recently open scope has a printer for numerals - but not the expected one then we need delimiters *) - if not (Hashtbl.mem numeral_interpreter_tab scope) then - find_numeral_without_delimiters printer_scope scopes - else - find_numeral_with_delimiters printer_scope - | [] -> - (* Can we switch to [scope]? Yes if it has defined delimiters *) - find_numeral_with_delimiters printer_scope - -let find_numeral_printer printer_scope scopes = - match - find_numeral_without_delimiters printer_scope scopes - with - | None -> None - | Some None -> Some (None,scopes) - | Some x -> Some (x,printer_scope::scopes) - -(* This is the map associating the scope a numeral printer belongs to *) -(* -let numeral_printer_map = ref (Stringmap.empty : scope_name Stringmap.t) -*) - -let rec interp_numeral loc n = function - | scope :: scopes -> - (try fst (lookup_numeral_interpreter scope) loc n - with Not_found -> interp_numeral loc n scopes) - | [] -> - user_err_loc (loc,"interp_numeral", - str "No interpretation for numeral " ++ pr_bigint n) - -let rec interp_numeral_as_pattern loc n name = function - | scope :: scopes -> - (try - match snd (lookup_numeral_interpreter scope) with - | None -> raise Not_found - | Some g -> g loc n name - with Not_found -> interp_numeral_as_pattern loc n name scopes) - | [] -> - user_err_loc (loc,"interp_numeral_as_pattern", - str "No interpretation for numeral " ++ pr_bigint n) - -(* Exportation of scopes *) -let cache_scope (_,sc) = - check_scope sc; - scope_stack := sc :: !scope_stack - -let subst_scope (_,subst,sc) = sc - -open Libobject - -let (inScope,outScope) = - declare_object {(default_object "SCOPE") with - cache_function = cache_scope; - open_function = (fun i o -> if i=1 then cache_scope o); - subst_function = subst_scope; - classify_function = (fun (_,o) -> Substitute o); - export_function = (fun x -> Some x) } - -let open_scope sc = Lib.add_anonymous_leaf (inScope sc) - - -(* Special scopes associated to arguments of a global reference *) - -open Libnames - -module RefOrdered = - struct - type t = global_reference - let compare = Pervasives.compare - end - -module Refmap = Map.Make(RefOrdered) - -let arguments_scope = ref Refmap.empty - -let cache_arguments_scope (_,(r,scl)) = - List.iter (option_iter check_scope) scl; - arguments_scope := Refmap.add r scl !arguments_scope - -let subst_arguments_scope (_,subst,(r,scl)) = (subst_global subst r,scl) - -let (inArgumentsScope,outArgumentsScope) = - declare_object {(default_object "ARGUMENTS-SCOPE") with - cache_function = cache_arguments_scope; - open_function = (fun i o -> if i=1 then cache_arguments_scope o); - subst_function = subst_arguments_scope; - classify_function = (fun (_,o) -> Substitute o); - export_function = (fun x -> Some x) } - -let declare_arguments_scope r scl = - Lib.add_anonymous_leaf (inArgumentsScope (r,scl)) - -let find_arguments_scope r = - try Refmap.find r !arguments_scope - with Not_found -> [] - -(* Printing *) - -let pr_delimiters = function - | None -> str "No delimiters" - | Some (l,r) -> str "Delimiters are " ++ str l ++ str " and " ++ str r - -let pr_notation prraw ntn r = - str ntn ++ str " stands for " ++ prraw r - -let pr_named_scope prraw scope sc = - str "Scope " ++ str scope ++ fnl () - ++ pr_delimiters sc.delimiters ++ fnl () - ++ Stringmap.fold - (fun ntn (r,_) strm -> pr_notation prraw ntn r ++ fnl () ++ strm) - sc.notations (mt ()) - -let pr_scope prraw scope = pr_named_scope prraw scope (find_scope scope) - -let pr_scopes prraw = - Stringmap.fold - (fun scope sc strm -> pr_named_scope prraw scope sc ++ fnl () ++ strm) - !scope_map (mt ()) - -(* Synchronisation with reset *) - -let freeze () = (!scope_map, !scope_stack, !arguments_scope) - -let unfreeze (scm,scs,asc) = - scope_map := scm; - scope_stack := scs; - arguments_scope := asc - -let init () = () -(* - scope_map := Strinmap.empty; - scope_stack := Stringmap.empty -*) - -let _ = - declare_summary "symbols" - { freeze_function = freeze; - unfreeze_function = unfreeze; - init_function = init; - survive_section = false } diff --git a/parsing/symbols.mli b/parsing/symbols.mli deleted file mode 100644 index f5b26b877..000000000 --- a/parsing/symbols.mli +++ /dev/null @@ -1,60 +0,0 @@ -open Names -open Util -open Nametab -open Rawterm -open Bignat - -(* A numeral interpreter is the pair of an interpreter for _integer_ - numbers in terms and an optional interpreter in pattern, if - negative numbers are not supported, the interpreter must fail with - an appropriate error message *) - -type numeral_interpreter_name = string -type numeral_interpreter = - (loc -> bigint -> rawconstr) - * (loc -> bigint -> name -> cases_pattern) option - -(* A scope is a set of interpreters for symbols + optional - interpreter and printers for integers + optional delimiters *) - -type level = Extend.precedence * Extend.precedence list -type scope_name = string -type delimiters = string * string -type scope -type scopes = scope_name list - -val default_scope : scope_name -val current_scopes : unit -> scopes -val open_scope : scope_name -> unit -val declare_scope : scope_name -> unit - -(* Declare delimiters for printing *) -val declare_delimiters : scope_name -> delimiters -> unit - -(* Declare, interpret, and look for a printer for numeral *) -val declare_numeral_interpreter : - numeral_interpreter_name -> numeral_interpreter -> unit -val interp_numeral : loc -> bigint -> scopes -> rawconstr -val interp_numeral_as_pattern: loc -> bigint -> name -> scopes -> cases_pattern -val find_numeral_printer : string -> scopes -> - (delimiters option * scopes) option - -(* Declare, interpret, and look for a printer for symbolic notations *) -type notation = string -val declare_notation : level -> notation -> rawconstr -> scope_name -> unit -val interp_notation : notation -> scopes -> rawconstr list -> rawconstr -val find_notation : scope_name -> notation -> scopes -> - (delimiters option * scopes) option -val exists_notation_in_scope : - scope_name -> level -> notation -> rawconstr -> bool -val exists_notation : level -> notation -> bool - -(* Declare and look for scopes associated to arguments of a global ref *) -open Libnames -val declare_arguments_scope: global_reference -> scope_name option list -> unit -val find_arguments_scope : global_reference -> scope_name option list - -(* Printing scopes *) -open Pp -val pr_scope : (rawconstr -> std_ppcmds) -> scope_name -> std_ppcmds -val pr_scopes : (rawconstr -> std_ppcmds) -> std_ppcmds diff --git a/parsing/tacextend.ml4 b/parsing/tacextend.ml4 index eb9577902..593fb0169 100644 --- a/parsing/tacextend.ml4 +++ b/parsing/tacextend.ml4 @@ -11,7 +11,6 @@ open Genarg open Q_util open Q_coqast -open Ast let join_loc (deb1,_) (_,fin2) = (deb1,fin2) let loc = (0,0) @@ -43,8 +42,9 @@ let rec make_wit loc = function | StringArgType -> <:expr< Genarg.wit_string >> | PreIdentArgType -> <:expr< Genarg.wit_pre_ident >> | IdentArgType -> <:expr< Genarg.wit_ident >> - | QualidArgType -> <:expr< Genarg.wit_qualid >> + | RefArgType -> <:expr< Genarg.wit_ref >> | QuantHypArgType -> <:expr< Genarg.wit_quant_hyp >> + | SortArgType -> <:expr< Genarg.wit_sort >> | ConstrArgType -> <:expr< Genarg.wit_constr >> | ConstrMayEvalArgType -> <:expr< Genarg.wit_constr_may_eval >> | TacticArgType -> <:expr< Genarg.wit_tactic >> @@ -179,9 +179,7 @@ let rec interp_entry_name loc s = | None -> None, <:expr< $lid:s$ >> in let t = match t with - | Some (GenAstType t) -> t - | Some _ -> - failwith "Only entries of generic type can be used in extension" + | Some t -> t | None -> (* Pp.warning_with Pp_control.err_ft ("Unknown primitive grammar entry: "^s);*) diff --git a/parsing/termast.ml b/parsing/termast.ml index 1b9c38758..bacfa24ce 100644 --- a/parsing/termast.ml +++ b/parsing/termast.ml @@ -217,18 +217,21 @@ let rec ast_of_raw = function (* Pour compatibilité des theories, il faut LAMBDALIST partout *) ope("LAMBDALIST",[ast_of_raw t;a]) - | RCases (_,printinfo,typopt,tml,eqns) -> + | RCases (_,typopt,tml,eqns) -> let pred = ast_of_rawopt typopt in - let tag = match printinfo with - | PrintIf -> "FORCEIF" - | PrintLet -> "FORCELET" - | PrintCases -> "CASES" - in + let tag = "CASES" in let asttomatch = ope("TOMATCH", List.map ast_of_raw tml) in let asteqns = List.map ast_of_eqn eqns in ope(tag,pred::asttomatch::asteqns) - | ROldCase (_,isrec,typopt,tm,bv) -> + | ROrderedCase (_,st,typopt,tm,bv) -> + let tag = match st with + | IfStyle -> "FORCEIF" + | LetStyle -> "FORCELET" + | RegularStyle -> "CASES" + | MatchStyle -> "MATCH" + in + (* warning "Old Case syntax"; *) ope("CASE",(ast_of_rawopt typopt) ::(ast_of_raw tm) @@ -387,7 +390,7 @@ let rec ast_of_pattern tenv env = function let tag = if n=1 then "LAMBDA" else "LAMBDALIST" in ope(tag,[ast_of_pattern tenv env t;a]) - | PCase (typopt,tm,bv) -> + | PCase (st,typopt,tm,bv) -> warning "Old Case syntax"; ope("MUTCASE",(ast_of_patopt tenv env typopt) ::(ast_of_pattern tenv env tm) diff --git a/parsing/vernacextend.ml4 b/parsing/vernacextend.ml4 index d9d56770e..a910c1c06 100644 --- a/parsing/vernacextend.ml4 +++ b/parsing/vernacextend.ml4 @@ -42,7 +42,8 @@ let rec make_rawwit loc = function | StringArgType -> <:expr< Genarg.rawwit_string >> | PreIdentArgType -> <:expr< Genarg.rawwit_pre_ident >> | IdentArgType -> <:expr< Genarg.rawwit_ident >> - | QualidArgType -> <:expr< Genarg.rawwit_qualid >> + | RefArgType -> <:expr< Genarg.rawwit_ref >> + | SortArgType -> <:expr< Genarg.rawwit_sort >> | ConstrArgType -> <:expr< Genarg.rawwit_constr >> | ConstrMayEvalArgType -> <:expr< Genarg.rawwit_constr_may_eval >> | QuantHypArgType -> <:expr< Genarg.rawwit_quant_hyp >> @@ -147,9 +148,7 @@ let rec interp_entry_name loc s = | None -> None, <:expr< $lid:s$ >> in let t = match t with - | Some (GenAstType t) -> t - | Some _ -> - failwith "Only entries of generic type can be used in extension" + | Some t -> t | None -> (* Pp.warning_with Pp_control.err_ft ("Unknown primitive grammar entry: "^s);*) diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 4c6e5bb01..5c129efa9 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -591,10 +591,10 @@ let occur_rawconstr id = | RLambda (loc,na,ty,c) -> (occur ty) or ((na <> Name id) & (occur c)) | RProd (loc,na,ty,c) -> (occur ty) or ((na <> Name id) & (occur c)) | RLetIn (loc,na,b,c) -> (occur b) or ((na <> Name id) & (occur c)) - | RCases (loc,prinfo,tyopt,tml,pl) -> + | RCases (loc,tyopt,tml,pl) -> (occur_option tyopt) or (List.exists occur tml) or (List.exists occur_pattern pl) - | ROldCase (loc,b,tyopt,tm,bv) -> + | ROrderedCase (loc,b,tyopt,tm,bv) -> (occur_option tyopt) or (occur tm) or (array_exists occur bv) | RRec (loc,fk,idl,tyl,bv) -> (array_exists occur tyl) or @@ -1369,7 +1369,7 @@ and match_current pb ((current,typ as ct),deps) = let (pred,typ,s) = find_predicate pb.caseloc pb.env pb.isevars pb.pred brtyps cstrs current indt in - let ci = make_case_info pb.env mind None tags in + let ci = make_case_info pb.env mind RegularStyle tags in let case = mkCase (ci,nf_betaiota pred,current,brvals) in let inst = List.map mkRel deps in pattern_status tags, diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 46f9568fa..238fd470f 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -204,7 +204,7 @@ let inh_apply_rel_list apploc env isevars argjl (funloc,funj) tycon = 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 + (join_loc funloc loc) env sigma resj (List.map snd restjl) in apply_rec env 1 funj argjl diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 748c72f4c..53c9453d0 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -19,7 +19,6 @@ open Inductiveops open Environ open Sign open Declare -open Impargs open Rawterm open Nameops open Termops @@ -43,23 +42,23 @@ let isomorphic_to_bool lc = let isomorphic_to_tuple lc = (Array.length lc = 1) -let encode_bool (loc,_ as locqid) = - let (_,lc as x) = encode_inductive locqid in +let encode_bool r = + let (_,lc as x) = encode_inductive r in if not (isomorphic_to_bool lc) then - user_err_loc (loc,"encode_if", + user_err_loc (loc_of_reference r,"encode_if", str "This type cannot be seen as a boolean type"); x -let encode_tuple (loc,_ as locqid) = - let (_,lc as x) = encode_inductive locqid in +let encode_tuple r = + let (_,lc as x) = encode_inductive r in if not (isomorphic_to_tuple lc) then - user_err_loc (loc,"encode_tuple", + user_err_loc (loc_of_reference r,"encode_tuple", str "This type cannot be seen as a tuple type"); x module PrintingCasesMake = functor (Test : sig - val encode : qualid located -> inductive * int array + val encode : reference -> inductive * int array val member_message : std_ppcmds -> bool -> std_ppcmds val field : string val title : string @@ -249,14 +248,18 @@ let rec detype tenv avoid env t = array_map3 (detype_eqn tenv avoid env) constructs consnargsl bl in let eqnl = Array.to_list eqnv in let tag = - if PrintingLet.active (indsp,consnargsl) then - PrintLet + if PrintingLet.active (indsp,consnargsl) then + LetStyle else if PrintingIf.active (indsp,consnargsl) then - PrintIf + IfStyle else - PrintCases + annot.ci_pp_info.style in - RCases (dummy_loc,tag,pred,[tomatch],eqnl) + if tag = RegularStyle then + RCases (dummy_loc,pred,[tomatch],eqnl) + else + let bl = Array.map (detype tenv avoid env) bl in + ROrderedCase (dummy_loc,LetStyle,pred,tomatch,bl) | Fix (nvn,recdef) -> detype_fix tenv avoid env (RFix nvn) recdef | CoFix (n,recdef) -> detype_fix tenv avoid env (RCoFix n) recdef diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 772eae76b..cff9b1acf 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -19,6 +19,7 @@ open Typing open Classops open Recordops open Evarutil +open Libnames type flexible_term = FConst of constant | FRel of int | FVar of identifier type flex_kind_of_term = @@ -70,8 +71,8 @@ let evar_apprec env isevars stack c = let check_conv_record (t1,l1) (t2,l2) = try - let proji = Declare.reference_of_constr t1 in - let cstr = Declare.reference_of_constr t2 in + let proji = reference_of_constr t1 in + let cstr = reference_of_constr t2 in let { o_DEF = c; o_TABS = bs; o_TPARAMS = params; o_TCOMPS = us } = objdef_info (proji, cstr) in let params1, c1, extra_args1 = @@ -327,7 +328,7 @@ and conv_record env isevars (c,bs,(params,params1),(us,us2),(ts,ts1),c1) = let ks = List.fold_left (fun ks b -> - let dloc = (Rawterm.dummy_loc,Rawterm.InternalHole) in + let dloc = (dummy_loc,Rawterm.InternalHole) in (new_isevar isevars env dloc (substl ks b)) :: ks) [] bs in diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml index 6a1fb9ede..9d65430ed 100644 --- a/pretyping/evarutil.ml +++ b/pretyping/evarutil.ml @@ -220,7 +220,7 @@ let evars_reset_evd evd d = d.evars <- evd let add_conv_pb d pb = d.conv_pbs <- pb::d.conv_pbs let evar_source ev d = try List.assoc ev d.history - with Failure _ -> (Rawterm.dummy_loc, Rawterm.InternalHole) + with Failure _ -> (dummy_loc, Rawterm.InternalHole) (* ise_try [f1;...;fn] tries fi() for i=1..n, restoring the evar constraints * when fi returns false or an exception. Returns true if one of the fi diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index 44398099c..f508ac886 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -68,7 +68,7 @@ let mis_make_case_com depopt env sigma (ind,mib,mip) kind = let nbprod = k+1 in let indf = make_ind_family(ind,extended_rel_list nbprod lnamespar) in let lnamesar,_ = get_arity env indf in - let ci = make_default_case_info env ind in + let ci = make_default_case_info env RegularStyle ind in it_mkLambda_or_LetIn_name env' (lambda_create env' (build_dependent_inductive env indf, @@ -288,7 +288,7 @@ let mis_make_indrec env sigma listdepkind (ind,mib,mip) = (lambda_create env (build_dependent_inductive env (lift_inductive_family nrec indf), - mkCase (make_default_case_info env indi, + mkCase (make_default_case_info env RegularStyle indi, mkRel (dect+j+1), mkRel 1, branches))) (Termops.lift_rel_context nrec lnames) in diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index f14f21922..e3a536420 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -91,9 +91,9 @@ let make_case_info env ind style pats_source = ci_npar = mip.mind_nparams; ci_pp_info = print_info } -let make_default_case_info env ind = +let make_default_case_info env style ind = let (mib,mip) = Inductive.lookup_mind_specif env ind in - make_case_info env ind None + make_case_info env ind style (Array.map (fun _ -> RegularPat) mip.mind_consnames) (*s Useful functions *) diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index 43adfd889..4c5c58a9f 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -82,8 +82,8 @@ val type_case_branches_with_names : env -> inductive * constr list -> unsafe_judgment -> constr -> types array * types val make_case_info : - env -> inductive -> case_style option -> pattern_source array -> case_info -val make_default_case_info : env -> inductive -> case_info + env -> inductive -> case_style -> pattern_source array -> case_info +val make_default_case_info : env -> case_style -> inductive -> case_info (********************) val control_only_guard : env -> types -> unit diff --git a/pretyping/pattern.ml b/pretyping/pattern.ml index 6d79b9d28..0afcbdde7 100644 --- a/pretyping/pattern.ml +++ b/pretyping/pattern.ml @@ -31,7 +31,8 @@ type constr_pattern = | PLetIn of name * constr_pattern * constr_pattern | PSort of rawsort | PMeta of int option - | PCase of constr_pattern option * constr_pattern * constr_pattern array + | PCase of case_style * constr_pattern option * constr_pattern * + constr_pattern array | PFix of fixpoint | PCoFix of cofixpoint @@ -41,9 +42,9 @@ let rec occur_meta_pattern = function | PLambda (na,t,c) -> (occur_meta_pattern t) or (occur_meta_pattern c) | PProd (na,t,c) -> (occur_meta_pattern t) or (occur_meta_pattern c) | PLetIn (na,t,c) -> (occur_meta_pattern t) or (occur_meta_pattern c) - | PCase(None,c,br) -> + | PCase(_,None,c,br) -> (occur_meta_pattern c) or (array_exists occur_meta_pattern br) - | PCase(Some p,c,br) -> + | PCase(_,Some p,c,br) -> (occur_meta_pattern p) or (occur_meta_pattern c) or (array_exists occur_meta_pattern br) | PMeta _ | PSoApp _ -> true @@ -83,12 +84,12 @@ let rec subst_pattern subst pat = match pat with PLetIn (name,c1',c2') | PSort _ | PMeta _ -> pat - | PCase (typ, c, branches) -> + | PCase (cs,typ, c, branches) -> let typ' = option_smartmap (subst_pattern subst) typ in let c' = subst_pattern subst c in let branches' = array_smartmap (subst_pattern subst) branches in if typ' == typ && c' == c && branches' == branches then pat else - PCase(typ', c', branches') + PCase(cs,typ', c', branches') | PFix fixpoint -> let cstr = mkFix fixpoint in let fixpoint' = destFix (subst_mps subst cstr) in @@ -132,7 +133,7 @@ let rec head_pattern_bound t = | PProd (_,_,b) -> head_pattern_bound b | PLetIn (_,_,b) -> head_pattern_bound b | PApp (c,args) -> head_pattern_bound c - | PCase (p,c,br) -> head_pattern_bound c + | PCase (_,p,c,br) -> head_pattern_bound c | PRef r -> label_of_ref r | PVar id -> VarNode id | PEvar _ | PRel _ | PMeta _ | PSoApp _ | PSort _ | PFix _ @@ -229,7 +230,7 @@ let matches_core convert pat c = | PVar v1, Var v2 when v1 = v2 -> sigma - | PRef ref, _ when Declare.constr_of_reference ref = cT -> sigma + | PRef ref, _ when constr_of_reference ref = cT -> sigma | PRel n1, Rel n2 when n1 = n2 -> sigma @@ -252,11 +253,11 @@ let matches_core convert pat c = | PRef (ConstRef _ as ref), _ when convert <> None -> let (env,evars) = out_some convert in - let c = Declare.constr_of_reference ref in + let c = constr_of_reference ref in if is_conv env evars c cT then sigma else raise PatternMatchingFailure - | PCase (_,a1,br1), Case (_,_,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 @@ -386,7 +387,8 @@ let rec pattern_of_constr t = if ctxt = [||] then PEvar n else PApp (PEvar n, Array.map pattern_of_constr ctxt) | Case (ci,p,a,br) -> - PCase (Some (pattern_of_constr p),pattern_of_constr a, + PCase (ci.ci_pp_info.style, + Some (pattern_of_constr p),pattern_of_constr a, Array.map pattern_of_constr br) | Fix f -> PFix f | CoFix _ -> diff --git a/pretyping/pattern.mli b/pretyping/pattern.mli index 943a8d8c3..4b8c0aa8d 100644 --- a/pretyping/pattern.mli +++ b/pretyping/pattern.mli @@ -29,7 +29,8 @@ type constr_pattern = | PLetIn of name * constr_pattern * constr_pattern | PSort of Rawterm.rawsort | PMeta of int option - | PCase of constr_pattern option * constr_pattern * constr_pattern array + | PCase of case_style * constr_pattern option * constr_pattern * + constr_pattern array | PFix of fixpoint | PCoFix of cofixpoint diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 162e31e73..cb224fac2 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -19,6 +19,7 @@ open Reductionops open Environ open Type_errors open Typeops +open Libnames open Classops open List open Recordops @@ -48,7 +49,7 @@ let transform_rec loc env sigma (pj,c,lf) indt = let (mib,mip) = lookup_mind_specif env ind in let recargs = mip.mind_recargs in let mI = mkInd ind in - let ci = make_default_case_info env ind in + let ci = make_default_case_info env MatchStyle 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 @@ -185,7 +186,7 @@ let make_dep_of_undep env (IndType (indf,realargs)) pj = (* Main pretyping function *) let pretype_ref isevars env lvar ref = - let c = Declare.constr_of_reference ref in + let c = constr_of_reference ref in make_judge c (Retyping.get_type_of env Evd.empty c) let pretype_sort = function @@ -285,7 +286,7 @@ let rec pretype tycon env isevars lvar lmeta = function | _ -> let hj = pretype empty_tycon env isevars lvar lmeta c in error_cant_apply_not_functional_loc - (Rawterm.join_loc floc argloc) env (evars_of isevars) + (join_loc floc argloc) env (evars_of isevars) resj [hj] in let resj = apply_rec env 1 fj args in @@ -331,7 +332,7 @@ let rec pretype tycon env isevars lvar lmeta = function uj_type = type_app (subst1 j.uj_val) j'.uj_type } (* Special Case for let constructions to avoid exponential behavior *) - | ROldCase (loc,false,po,c,[|f|]) -> + | ROrderedCase (loc,st,po,c,[|f|]) when st <> MatchStyle -> let cj = pretype empty_tycon env isevars lvar lmeta c in let (IndType (indf,realargs) as indt) = try find_rectype env (evars_of isevars) cj.uj_type @@ -364,7 +365,7 @@ let rec pretype tycon env isevars lvar lmeta = function check_branches_message loc env isevars cj.uj_val (bty,[|ft|]); let v = let mis,_ = dest_ind_family indf in - let ci = make_default_case_info env mis in + let ci = make_default_case_info env st mis in mkCase (ci, (nf_betaiota pj.uj_val), cj.uj_val,[|fv|]) in { uj_val = v; uj_type = rsty } @@ -422,12 +423,13 @@ let rec pretype tycon env isevars lvar lmeta = function let ft = fj.uj_type in let v = let mis,_ = dest_ind_family indf in - let ci = make_default_case_info env mis in + let ci = make_default_case_info env st mis in mkCase (ci, (nf_betaiota pj.uj_val), cj.uj_val,[|fv|] ) in { uj_val = v; uj_type = rsty }) - | ROldCase (loc,isrec,po,c,lf) -> + | ROrderedCase (loc,st,po,c,lf) -> + let isrec = (st = MatchStyle) in let cj = pretype empty_tycon env isevars lvar lmeta c in let (IndType (indf,realargs) as indt) = try find_rectype env (evars_of isevars) cj.uj_type @@ -498,14 +500,14 @@ 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 env mis in + let ci = make_default_case_info env st mis in mkCase (ci, (nf_betaiota pj.uj_val), cj.uj_val, Array.map (fun j-> j.uj_val) lfj) in { uj_val = v; uj_type = rsty } - | RCases (loc,prinfo,po,tml,eqns) -> + | RCases (loc,po,tml,eqns) -> Cases.compile_cases loc ((fun vtyc env -> pretype vtyc env isevars lvar lmeta),isevars) tycon env (* loc *) (po,tml,eqns) @@ -640,3 +642,12 @@ let understand_gen sigma env lvar lmeta ~expected_type:exptyp c = let understand_gen_tcc sigma env lvar lmeta exptyp c = let metamap, c = ise_infer_gen false sigma env lvar lmeta exptyp c in metamap, c.uj_val + +let interp_sort = function + | RProp c -> Prop c + | RType _ -> new_Type_sort () + +let interp_elimination_sort = function + | RProp Null -> InProp + | RProp Pos -> InSet + | RType _ -> InType diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index e76c6c14f..dadc8b94c 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -76,3 +76,7 @@ val pretype_type : val_constraint -> env -> evar_defs -> var_map -> meta_map -> rawconstr -> unsafe_type_judgment (*i*) + +val interp_sort : rawsort -> sorts + +val interp_elimination_sort : rawsort -> sorts_family diff --git a/pretyping/rawterm.ml b/pretyping/rawterm.ml index 43bd6fc5b..eaba7663a 100644 --- a/pretyping/rawterm.ml +++ b/pretyping/rawterm.ml @@ -52,25 +52,18 @@ type hole_kind = | InternalHole | TomatchTypeParameter of inductive * int -type 'ctxt reference = - | RConst of constant * 'ctxt - | RInd of inductive * 'ctxt - | RConstruct of constructor * 'ctxt - | RVar of identifier - | REVar of int * 'ctxt - type rawconstr = - | RRef of loc * global_reference - | RVar of loc * identifier + | RRef of (loc * global_reference) + | RVar of (loc * identifier) | REvar of loc * existential_key | RMeta of loc * int | RApp of loc * rawconstr * rawconstr list | RLambda of loc * name * rawconstr * rawconstr | RProd of loc * name * rawconstr * rawconstr | RLetIn of loc * name * rawconstr * rawconstr - | RCases of loc * Term.case_style * rawconstr option * rawconstr list * + | RCases of loc * rawconstr option * rawconstr list * (loc * identifier list * cases_pattern list * rawconstr) list - | ROldCase of loc * bool * rawconstr option * rawconstr * + | ROrderedCase of loc * case_style * rawconstr option * rawconstr * rawconstr array | RRec of loc * fix_kind * identifier array * rawconstr array * rawconstr array @@ -96,15 +89,55 @@ let map_rawconstr f = function | RLambda (loc,na,ty,c) -> RLambda (loc,na,f ty,f c) | RProd (loc,na,ty,c) -> RProd (loc,na,f ty,f c) | RLetIn (loc,na,b,c) -> RLetIn (loc,na,f b,f c) - | RCases (loc,prinfo,tyopt,tml,pl) -> - RCases (loc,prinfo,option_app f tyopt,List.map f tml, + | RCases (loc,tyopt,tml,pl) -> + RCases (loc,option_app f tyopt,List.map f tml, List.map (fun (loc,idl,p,c) -> (loc,idl,p,f c)) pl) - | ROldCase (loc,b,tyopt,tm,bv) -> - ROldCase (loc,b,option_app f tyopt,f tm, Array.map f bv) + | ROrderedCase (loc,b,tyopt,tm,bv) -> + ROrderedCase (loc,b,option_app f tyopt,f tm, Array.map f bv) | RRec (loc,fk,idl,tyl,bv) -> RRec (loc,fk,idl,Array.map f tyl,Array.map f bv) | RCast (loc,c,t) -> RCast (loc,f c,f t) | (RSort _ | RHole _ | RRef _ | REvar _ | RMeta _ | RDynamic _) as x -> x +(* +let name_app f e = function + | Name id -> let (id, e) = f id e in (Name id, e) + | Anonymous -> Anonymous, e + +let fold_ident g idl e = + let (idl,e) = + Array.fold_right + (fun id (idl,e) -> let id,e = g id e in (id::idl,e)) idl ([],e) + in (Array.of_list idl,e) + +let map_rawconstr_with_binders_loc loc g f e = function + | RVar (_,id) -> RVar (loc,id) + | RApp (_,a,args) -> RApp (loc,f e a, List.map (f e) args) + | RLambda (_,na,ty,c) -> + let na,e = name_app g e na in RLambda (loc,na,f e ty,f e c) + | RProd (_,na,ty,c) -> + let na,e = name_app g e na in RProd (loc,na,f e ty,f e c) + | RLetIn (_,na,b,c) -> + let na,e = name_app g e na in RLetIn (loc,na,f e b,f e c) + | RCases (_,tyopt,tml,pl) -> + (* We don't modify pattern variable since we don't traverse patterns *) + let g' id e = snd (g id e) in + let h (_,idl,p,c) = (loc,idl,p,f (List.fold_right g' idl e) c) in + RCases + (loc,option_app (f e) tyopt,List.map (f e) tml, List.map h pl) + | ROrderedCase (_,b,tyopt,tm,bv) -> + ROrderedCase (loc,b,option_app (f e) tyopt,f e tm,Array.map (f e) bv) + | RRec (_,fk,idl,tyl,bv) -> + let idl',e' = fold_ident g idl e in + RRec (loc,fk,idl',Array.map (f e) tyl,Array.map (f e') bv) + | RCast (_,c,t) -> RCast (loc,f e c,f e t) + | RSort (_,x) -> RSort (loc,x) + | RHole (_,x) -> RHole (loc,x) + | RRef (_,x) -> RRef (loc,x) + | REvar (_,x) -> REvar (loc,x) + | RMeta (_,x) -> RMeta (loc,x) + | RDynamic (_,x) -> RDynamic (loc,x) +*) + let rec subst_pat subst pat = match pat with | PatVar _ -> pat @@ -114,6 +147,7 @@ let rec subst_pat subst pat = if kn' == kn && cpl' == cpl then pat else PatCstr (loc,((kn',i),j),cpl',n) +(* let rec subst_raw subst raw = match raw with | RRef (loc,ref) -> @@ -146,7 +180,7 @@ let rec subst_raw subst raw = if r1' == r1 && r2' == r2 then raw else RLetIn (loc,n,r1',r2') - | RCases (loc,cs,ro,rl,branches) -> + | RCases (loc,ro,rl,branches) -> let ro' = option_smartmap (subst_raw subst) ro and rl' = list_smartmap (subst_raw subst) rl and branches' = list_smartmap @@ -158,14 +192,14 @@ let rec subst_raw subst raw = branches in if ro' == ro && rl' == rl && branches' == branches then raw else - RCases (loc,cs,ro',rl',branches') + RCases (loc,ro',rl',branches') - | ROldCase (loc,b,ro,r,ra) -> + | ROrderedCase (loc,b,ro,r,ra) -> let ro' = option_smartmap (subst_raw subst) ro and r' = subst_raw subst r and ra' = array_smartmap (subst_raw subst) ra in if ro' == ro && r' == r && ra' == ra then raw else - ROldCase (loc,b,ro',r',ra') + ROrderedCase (loc,b,ro',r',ra') | RRec (loc,fix,ida,ra1,ra2) -> let ra1' = array_smartmap (subst_raw subst) ra1 @@ -188,8 +222,7 @@ let rec subst_raw subst raw = RCast (loc,r1',r2') | RDynamic _ -> raw - -let dummy_loc = (0,0) +*) let loc_of_rawconstr = function | RRef (loc,_) -> loc @@ -200,16 +233,14 @@ let loc_of_rawconstr = function | RLambda (loc,_,_,_) -> loc | RProd (loc,_,_,_) -> loc | RLetIn (loc,_,_,_) -> loc - | RCases (loc,_,_,_,_) -> loc - | ROldCase (loc,_,_,_,_) -> loc + | RCases (loc,_,_,_) -> loc + | ROrderedCase (loc,_,_,_,_) -> loc | RRec (loc,_,_,_,_) -> loc | RSort (loc,_) -> loc | RHole (loc,_) -> loc | RCast (loc,_,_) -> loc | RDynamic (loc,_) -> loc -let join_loc (deb1,_) (_,fin2) = (deb1,fin2) - type 'a raw_red_flag = { rBeta : bool; rIota : bool; @@ -229,10 +260,10 @@ type ('a,'b) red_expr_gen = | Pattern of (int list * 'a) list | ExtraRedExpr of string * 'a -type 'a or_metanum = AN of loc * 'a | MetaNum of loc * int +type 'a or_metanum = AN of 'a | MetaNum of int located type 'a may_eval = | ConstrTerm of 'a - | ConstrEval of ('a, qualid or_metanum) red_expr_gen * 'a + | ConstrEval of ('a, reference or_metanum) red_expr_gen * 'a | ConstrContext of (loc * identifier) * 'a | ConstrTypeOf of 'a diff --git a/pretyping/rawterm.mli b/pretyping/rawterm.mli index 51ea18028..d1c480ef7 100644 --- a/pretyping/rawterm.mli +++ b/pretyping/rawterm.mli @@ -9,6 +9,7 @@ (*i $Id$ i*) (*i*) +open Util open Names open Sign open Term @@ -51,25 +52,18 @@ type hole_kind = | InternalHole | TomatchTypeParameter of inductive * int -type 'ctxt reference = - | RConst of constant * 'ctxt - | RInd of inductive * 'ctxt - | RConstruct of constructor * 'ctxt - | RVar of identifier - | REVar of int * 'ctxt - type rawconstr = - | RRef of loc * Libnames.global_reference - | RVar of loc * identifier + | RRef of (loc * global_reference) + | RVar of (loc * identifier) | REvar of loc * existential_key | RMeta of loc * int | RApp of loc * rawconstr * rawconstr list | RLambda of loc * name * rawconstr * rawconstr | RProd of loc * name * rawconstr * rawconstr | RLetIn of loc * name * rawconstr * rawconstr - | RCases of loc * Term.case_style * rawconstr option * rawconstr list * + | RCases of loc * rawconstr option * rawconstr list * (loc * identifier list * cases_pattern list * rawconstr) list - | ROldCase of loc * bool * rawconstr option * rawconstr * + | ROrderedCase of loc * case_style * rawconstr option * rawconstr * rawconstr array | RRec of loc * fix_kind * identifier array * rawconstr array * rawconstr array @@ -92,11 +86,17 @@ i*) val map_rawconstr : (rawconstr -> rawconstr) -> rawconstr -> rawconstr -val dummy_loc : loc +(* +val map_rawconstr_with_binders_loc : loc -> + (identifier -> 'a -> identifier * 'a) -> + ('a -> rawconstr -> rawconstr) -> 'a -> rawconstr -> rawconstr +*) + val loc_of_rawconstr : rawconstr -> loc -val join_loc : loc -> loc -> loc +(* val subst_raw : Names.substitution -> rawconstr -> rawconstr +*) type 'a raw_red_flag = { rBeta : bool; @@ -117,10 +117,10 @@ type ('a,'b) red_expr_gen = | Pattern of (int list * 'a) list | ExtraRedExpr of string * 'a -type 'a or_metanum = AN of loc * 'a | MetaNum of loc * int +type 'a or_metanum = AN of 'a | MetaNum of int located type 'a may_eval = | ConstrTerm of 'a - | ConstrEval of ('a, qualid or_metanum) red_expr_gen * 'a + | ConstrEval of ('a, reference or_metanum) red_expr_gen * 'a | ConstrContext of (loc * identifier) * 'a | ConstrTypeOf of 'a diff --git a/pretyping/syntax_def.ml b/pretyping/syntax_def.ml deleted file mode 100644 index cb1be3ebb..000000000 --- a/pretyping/syntax_def.ml +++ /dev/null @@ -1,81 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* !syntax_table); - Summary.unfreeze_function = (fun ft -> syntax_table := ft); - Summary.init_function = (fun () -> syntax_table := KNmap.empty); - Summary.survive_section = false } - -let add_syntax_constant kn c = - syntax_table := KNmap.add kn c !syntax_table - -let cache_syntax_constant ((sp,kn),c) = - if Nametab.exists_cci sp then - errorlabstrm "cache_syntax_constant" - (pr_id (basename sp) ++ str " already exists"); - add_syntax_constant kn c; - Nametab.push_syntactic_definition (Nametab.Until 1) sp kn - -let load_syntax_constant i ((sp,kn),c) = - if Nametab.exists_cci sp then - errorlabstrm "cache_syntax_constant" - (pr_id (basename sp) ++ str " already exists"); - add_syntax_constant kn c; - Nametab.push_syntactic_definition (Nametab.Until i) sp kn - -let open_syntax_constant i ((sp,kn),c) = - Nametab.push_syntactic_definition (Nametab.Exactly i) sp kn - -let subst_syntax_constant ((sp,kn),subst,c) = - subst_raw subst c - -let classify_syntax_constant (_,c) = Substitute c - -let (in_syntax_constant, out_syntax_constant) = - declare_object {(default_object "SYNTAXCONSTANT") with - cache_function = cache_syntax_constant; - load_function = load_syntax_constant; - open_function = open_syntax_constant; - subst_function = subst_syntax_constant; - classify_function = classify_syntax_constant; - export_function = (fun x -> Some x) } - -let declare_syntactic_definition id c = - let _ = add_leaf id (in_syntax_constant c) in () - -let rec set_loc loc = function - | RRef (_,a) -> RRef (loc,a) - | RVar (_,a) -> RVar (loc,a) - | RApp (_,a,b) -> RApp (loc,set_loc loc a,List.map (set_loc loc) b) - | RSort (_,a) -> RSort (loc,a) - | RHole (_,a) -> RHole (loc,a) - | RLambda (_,na,ty,c) -> RLambda (loc,na,set_loc loc ty,set_loc loc c) - | RProd (_,na,ty,c) -> RProd (loc,na,set_loc loc ty,set_loc loc c) - | RLetIn (_,na,b,c) -> RLetIn (loc,na,set_loc loc b,set_loc loc c) - | RCast (_,a,b) -> RCast (loc,set_loc loc a,set_loc loc b) - | a -> warning "Unrelocatated syntactic definition"; a - -let search_syntactic_definition loc kn = - set_loc loc (KNmap.find kn !syntax_table) diff --git a/pretyping/syntax_def.mli b/pretyping/syntax_def.mli deleted file mode 100644 index d9537cd20..000000000 --- a/pretyping/syntax_def.mli +++ /dev/null @@ -1,23 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* rawconstr -> unit - -val search_syntactic_definition : loc -> kernel_name -> rawconstr - - diff --git a/proofs/evar_refiner.ml b/proofs/evar_refiner.ml index 91e13aeed..09879d585 100644 --- a/proofs/evar_refiner.ml +++ b/proofs/evar_refiner.ml @@ -147,7 +147,7 @@ let instantiate n c gl = let pfic gls c = let evc = gls.sigma in - Astterm.interp_constr evc (Global.env_of_context gls.it.evar_hyps) c + Constrintern.interp_constr evc (Global.env_of_context gls.it.evar_hyps) c (* let instantiate_tac = function @@ -170,7 +170,7 @@ let instantiate_pf_com n com pfts = with Failure _ -> error "not so many uninstantiated existential variables" in - let c = Astterm.interp_constr sigma (Evarutil.evar_env evd) com in + let c = Constrintern.interp_constr sigma (Evarutil.evar_env evd) com in let wc' = w_Define sp c wc in let newgc = (w_Underlying wc') in change_constraints_pftreestate newgc pfts diff --git a/proofs/evar_refiner.mli b/proofs/evar_refiner.mli index 46b0db62e..b0dd5e4f4 100644 --- a/proofs/evar_refiner.mli +++ b/proofs/evar_refiner.mli @@ -56,4 +56,4 @@ val instantiate : evar -> constr -> tactic (* val instantiate_tac : tactic_arg list -> tactic *) -val instantiate_pf_com : int -> Coqast.t -> pftreestate -> pftreestate +val instantiate_pf_com : int -> Topconstr.constr_expr -> pftreestate -> pftreestate diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 9e0bcf178..6f682f113 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -22,9 +22,9 @@ open Declare open Typing open Tacmach open Proof_trees +open Tacexpr open Proof_type open Lib -open Astterm open Safe_typing (*********************************************************************) @@ -76,14 +76,13 @@ let get_goal_context n = let get_current_goal_context () = get_goal_context 1 -let set_current_proof s = +let set_current_proof = Edit.focus proof_edits + +let resume_proof (loc,id) = try - Edit.focus proof_edits s + Edit.focus proof_edits id with Invalid_argument "Edit.focus" -> - errorlabstrm "Pfedit.set_proof" - (str"No such proof" ++ (msg_proofs false)) - -let resume_proof = set_current_proof + user_err_loc(loc,"Pfedit.set_proof",str"No such proof" ++ msg_proofs false) let suspend_proof () = try @@ -108,13 +107,15 @@ let get_current_proof_name () = let add_proof (na,pfs,ts) = Edit.create proof_edits (na,pfs,ts,Some (!undo_limit+1)) - -let delete_proof na = + +let delete_proof_gen = Edit.delete proof_edits + +let delete_proof (loc,id) = try - Edit.delete proof_edits na + delete_proof_gen id with (UserError ("Edit.delete",_)) -> - errorlabstrm "Pfedit.delete_proof" - (str"No such proof" ++ msg_proofs false) + user_err_loc + (loc,"Pfedit.delete_proof",str"No such proof" ++ msg_proofs false) let init_proofs () = Edit.clear proof_edits @@ -135,7 +136,7 @@ let restart_proof () = errorlabstrm "Pfedit.restart" (str"No focused proof to restart" ++ msg_proofs true) | Some(na,_,ts) -> - delete_proof na; + delete_proof_gen na; start (na,ts); set_current_proof na @@ -204,7 +205,7 @@ let check_no_pending_proofs () = (str"Proof editing in progress" ++ (msg_proofs false) ++ str"Use \"Abort All\" first or complete proof(s).") -let delete_current_proof () = delete_proof (get_current_proof_name ()) +let delete_current_proof () = delete_proof_gen (get_current_proof_name ()) let delete_all_proofs = init_proofs diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index dd3ac6033..8cf1cffe1 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -9,14 +9,15 @@ (*i $Id$ i*) (*i*) +open Util open Pp open Names open Term open Sign open Environ open Decl_kinds -open Proof_type open Tacmach +open Tacexpr (*i*) (*s Several proofs can be opened simultaneously but at most one is @@ -39,7 +40,7 @@ val check_no_pending_proofs : unit -> unit (*s [delete_proof name] deletes proof of name [name] or fails if no proof has this name *) -val delete_proof : identifier -> unit +val delete_proof : identifier located -> unit (* [delete_current_proof ()] deletes current focused proof or fails if no proof is focused *) @@ -83,7 +84,7 @@ val resume_last_proof : unit -> unit (* [resume_proof name] focuses on the proof of name [name] or raises [UserError] if no proof has name [name] *) -val resume_proof : identifier -> unit +val resume_proof : identifier located -> unit (* [suspend_proof ()] unfocuses the current focused proof or failed with [UserError] if no proof is currently focused *) @@ -141,7 +142,7 @@ val by : tactic -> unit UserError if no proof is focused or if there is no such [n]th existential variable *) -val instantiate_nth_evar_com : int -> Coqast.t -> unit +val instantiate_nth_evar_com : int -> Topconstr.constr_expr -> unit (*s To deal with subgoal focus *) diff --git a/proofs/proof_trees.ml b/proofs/proof_trees.ml index 86ec64c76..34e9a06e7 100644 --- a/proofs/proof_trees.ml +++ b/proofs/proof_trees.ml @@ -248,122 +248,3 @@ let pr_subgoals_existential sigma = function let prest = pr_rec 2 rest in v 0 (int(List.length rest+1) ++ str" subgoals" ++ cut () ++ pg1 ++ prest ++ fnl ()) - -(* -open Ast -open Termast -open Tacexpr -open Rawterm - -let ast_of_cvt_bind f = function - | (NoDepBinding n,c) -> ope ("BINDING", [(num n); ope ("CONSTR",[(f c)])]) - | (DepBinding id,c) -> ope ("BINDING", [nvar id; ope ("CONSTR",[(f c)])]) - | (AnonymousBinding,c) -> ope ("BINDING", [ope ("CONSTR",[(f c)])]) - -let rec ast_of_cvt_intro_pattern = function - | WildPat -> ope ("WILDCAR",[]) - | IdPat id -> nvar id -(* | DisjPat l -> ope ("DISJPATTERN", (List.map ast_of_cvt_intro_pattern l))*) - | ConjPat l -> ope ("CONJPATTERN", (List.map ast_of_cvt_intro_pattern l)) -*) -(* -(* Gives the ast list corresponding to a reduction flag *) -open RedFlags - -let last_of_cvt_flags red = - (if (red_set red fBETA) then [ope("Beta",[])] - else [])@ - (let (n_unf,lconst) = red_get_const red in - let lqid = - List.map - (function - | EvalVarRef id -> nvar id - | EvalConstRef kn -> - ast_of_qualid - (shortest_qualid_of_global None (ConstRef kn))) - lconst in - if lqid = [] then [] - else if n_unf then [ope("Delta",[]);ope("UnfBut",lqid)] - else [ope("Delta",[]);ope("Unf",lqid)])@ - (if (red_set red fIOTA) then [ope("Iota",[])] - else []) -*) -(* -(* Gives the ast corresponding to a reduction expression *) -open Rawterm - -let ast_of_cvt_redexp = function - | Red _ -> ope ("Red",[]) - | Hnf -> ope("Hnf",[]) - | Simpl -> ope("Simpl",[]) -(* - | Cbv flg -> ope("Cbv",last_of_cvt_flags flg) - | Lazy flg -> ope("Lazy",last_of_cvt_flags flg) -*) - | Unfold l -> - ope("Unfold",List.map (fun (locc,sp) -> ope("UNFOLD", - [match sp with - | EvalVarRef id -> nvar id - | EvalConstRef kn -> - ast_of_qualid - (shortest_qualid_of_global None (ConstRef kn))] - @(List.map num locc))) l) - | Fold l -> - ope("Fold",List.map (fun c -> ope ("CONSTR", - [ast_of_constr false (Global.env ()) c])) l) - | Pattern l -> - ope("Pattern",List.map (fun (locc,csr) -> ope("PATTERN", - [ope ("CONSTR",[ast_of_constr false (Global.env ()) csr])]@ - (List.map num locc))) l) -*) -(* Gives the ast corresponding to a tactic argument *) -(* -let ast_of_cvt_arg = function - | Identifier id -> nvar id -(* - | Qualid qid -> ast_of_qualid qid -*) - | Quoted_string s -> string s - | Integer n -> num n -(* | Command c -> ope ("CONSTR",[c])*) - | Constr c -> - ope ("CONSTR",[ast_of_constr false (Global.env ()) c]) - | OpenConstr (_,c) -> - ope ("CONSTR",[ast_of_constr false (Global.env ()) c]) - | Constr_context _ -> - anomalylabstrm "ast_of_cvt_arg" (str - "Constr_context argument could not be used") - | Clause idl -> - let transl = function - | InHyp id -> ope ("INHYP", [nvar id]) - | InHypType id -> ope ("INHYPTYPE", [nvar id]) in - ope ("CLAUSE", List.map transl idl) -(* - | Bindings bl -> ope ("BINDINGS", - List.map (ast_of_cvt_bind (fun x -> x)) bl) - | Cbindings bl -> - ope ("BINDINGS", - List.map - (ast_of_cvt_bind - (ast_of_constr false (Global.env ()))) bl) -*) -(* TODO - | Tacexp ast -> ope ("TACTIC",[ast]) - | Tac (tac,ast) -> ast -*) - | Redexp red -> ope("REDEXP",[ast_of_cvt_redexp red]) - | Fixexp (id,n,c) -> ope ("FIXEXP",[nvar id; num n; ope ("CONSTR",[ast_of_constr false (Global.env ()) c])]) - | Cofixexp (id,c) -> ope ("COFIXEXP",[nvar id; ope ("CONSTR",[ast_of_constr false (Global.env ()) c])]) -(* | Intropattern p -> ast_of_cvt_intro_pattern p*) - | Letpatterns (gl_occ_opt,hyp_occ_list) -> - let hyps_pats = - List.map - (fun (id,l) -> - ope ("HYPPATTERN", nvar id :: (List.map num l))) - hyp_occ_list in - let all_pats = - match gl_occ_opt with - | None -> hyps_pats - | Some l -> hyps_pats @ [ope ("CCLPATTERN", List.map num l)] in - ope ("LETPATTERNS", all_pats) -*) diff --git a/proofs/proof_type.ml b/proofs/proof_type.ml index e3d52c5b3..405d5e5da 100644 --- a/proofs/proof_type.ml +++ b/proofs/proof_type.ml @@ -71,21 +71,21 @@ and validation = (proof_tree list -> proof_tree) and tactic_expr = (constr, - Closure.evaluable_global_reference, + evaluable_global_reference, inductive or_metanum, identifier) Tacexpr.gen_tactic_expr and atomic_tactic_expr = (constr, - Closure.evaluable_global_reference, + evaluable_global_reference, inductive or_metanum, identifier) Tacexpr.gen_atomic_tactic_expr and tactic_arg = (constr, - Closure.evaluable_global_reference, + evaluable_global_reference, inductive or_metanum, identifier) Tacexpr.gen_tactic_arg @@ -99,5 +99,3 @@ type closed_generic_argument = type 'a closed_abstract_argument_type = ('a,constr,raw_tactic_expr) abstract_argument_type - -type declaration_hook = Decl_kinds.strength -> global_reference -> unit diff --git a/proofs/proof_type.mli b/proofs/proof_type.mli index 95bf5d3a2..69aa0aff0 100644 --- a/proofs/proof_type.mli +++ b/proofs/proof_type.mli @@ -99,21 +99,21 @@ and validation = (proof_tree list -> proof_tree) and tactic_expr = (constr, - Closure.evaluable_global_reference, + evaluable_global_reference, inductive or_metanum, identifier) Tacexpr.gen_tactic_expr and atomic_tactic_expr = (constr, - Closure.evaluable_global_reference, + evaluable_global_reference, inductive or_metanum, identifier) Tacexpr.gen_atomic_tactic_expr and tactic_arg = (constr, - Closure.evaluable_global_reference, + evaluable_global_reference, inductive or_metanum, identifier) Tacexpr.gen_tactic_arg @@ -127,5 +127,3 @@ type closed_generic_argument = type 'a closed_abstract_argument_type = ('a,constr,raw_tactic_expr) abstract_argument_type - -type declaration_hook = Decl_kinds.strength -> global_reference -> unit diff --git a/proofs/refiner.ml b/proofs/refiner.ml index 16b13ac9e..a6edd9a3a 100644 --- a/proofs/refiner.ml +++ b/proofs/refiner.ml @@ -212,7 +212,7 @@ let vernac_tactic (s,args) = let abstract_tactic te = abstract_tactic_expr (Tacexpr.TacAtom (dummy_loc,te)) let abstract_extended_tactic s args = - abstract_tactic (Tacexpr.TacExtend (s, args)) + abstract_tactic (Tacexpr.TacExtend (dummy_loc, s, args)) let vernac_tactic (s,args) = let tacfun = lookup_tactic s args in diff --git a/proofs/tacexpr.ml b/proofs/tacexpr.ml index a1d7ff16b..521a08bc2 100644 --- a/proofs/tacexpr.ml +++ b/proofs/tacexpr.ml @@ -9,7 +9,7 @@ (* $Id$ *) open Names -open Coqast +open Topconstr open Libnames open Nametab open Rawterm @@ -24,10 +24,10 @@ type raw_red_flag = | FBeta | FIota | FZeta - | FConst of qualid or_metanum list - | FDeltaBut of qualid or_metanum list + | FConst of reference or_metanum list + | FDeltaBut of reference or_metanum list -type raw_red_expr = (constr_ast, qualid or_metanum) red_expr_gen +type raw_red_expr = (constr_expr, reference or_metanum) red_expr_gen let make_red_flag = let rec add_flag red = function @@ -55,10 +55,6 @@ type 'a raw_hyp_location = (* To distinguish body and type of local defs *) | InHyp of 'a | InHypType of 'a -type extend_tactic_arg = - | TacticArgMeta of loc * string - | TacticArgAst of Coqast.t - type 'a induction_arg = | ElimOnConstr of 'a | ElimOnIdent of identifier located @@ -73,7 +69,7 @@ type 'id clause_pattern = int list option * ('id * int list) list type ('a,'b) location = HypLocation of 'a | ConclLocation of 'b -type pattern_ast = Coqast.t +type pattern_expr = constr_expr (* Type of patterns *) type 'a match_pattern = @@ -138,7 +134,7 @@ type ('constr,'cst,'ind,'id) gen_atomic_tactic_expr = | TacAutoTDB of int option | TacDestructHyp of (bool * identifier located) | TacDestructConcl - | TacSuperAuto of (int option * qualid located list * bool * bool) + | TacSuperAuto of (int option * reference list * bool * bool) | TacDAuto of int option * int option (* Context management *) @@ -164,15 +160,15 @@ type ('constr,'cst,'ind,'id) gen_atomic_tactic_expr = | TacTransitivity of 'constr (* For ML extensions *) - | TacExtend of string * ('constr,raw_tactic_expr) generic_argument list + | TacExtend of loc * string * ('constr,raw_tactic_expr) generic_argument list (* For syntax extensions *) | TacAlias of string * - (string * ('constr,raw_tactic_expr) generic_argument) list + (identifier * ('constr,raw_tactic_expr) generic_argument) list * raw_tactic_expr and raw_tactic_expr = - (constr_ast,qualid or_metanum,qualid or_metanum,identifier located or_metaid) gen_tactic_expr + (constr_expr,reference or_metanum,reference or_metanum,identifier located or_metaid) gen_tactic_expr and ('constr,'cst,'ind,'id) gen_tactic_expr = | TacAtom of loc * ('constr,'cst,'ind,'id) gen_atomic_tactic_expr @@ -191,10 +187,10 @@ and ('constr,'cst,'ind,'id) gen_tactic_expr = | TacInfo of ('constr,'cst,'ind,'id) gen_tactic_expr | TacLetRecIn of (identifier located * ('constr,'cst,'ind,'id) gen_tactic_fun_ast) list * ('constr,'cst,'ind,'id) gen_tactic_expr - | TacLetIn of (identifier located * constr_ast may_eval option * ('constr,'cst,'ind,'id) gen_tactic_arg) list * ('constr,'cst,'ind,'id) gen_tactic_expr - | TacLetCut of (identifier * constr_ast may_eval * ('constr,'cst,'ind,'id) gen_tactic_arg) list - | TacMatch of constr_ast may_eval * (pattern_ast,('constr,'cst,'ind,'id) gen_tactic_expr) match_rule list - | TacMatchContext of direction_flag * (pattern_ast,('constr,'cst,'ind,'id) gen_tactic_expr) match_rule list + | TacLetIn of (identifier located * constr_expr may_eval option * ('constr,'cst,'ind,'id) gen_tactic_arg) list * ('constr,'cst,'ind,'id) gen_tactic_expr + | TacLetCut of (identifier * constr_expr may_eval * ('constr,'cst,'ind,'id) gen_tactic_arg) list + | TacMatch of constr_expr may_eval * (pattern_expr,('constr,'cst,'ind,'id) gen_tactic_expr) match_rule list + | TacMatchContext of direction_flag * (pattern_expr,('constr,'cst,'ind,'id) gen_tactic_expr) match_rule list | TacFun of ('constr,'cst,'ind,'id) gen_tactic_fun_ast | TacFunRec of (identifier located * ('constr,'cst,'ind,'id) gen_tactic_fun_ast) | TacArg of ('constr,'cst,'ind,'id) gen_tactic_arg @@ -209,23 +205,32 @@ and ('constr,'cst,'ind,'id) gen_tactic_arg = | MetaNumArg of loc * int | MetaIdArg of loc * string | ConstrMayEval of 'constr may_eval - | Reference of reference_expr + | Reference of reference | Integer of int | TacCall of loc * - reference_expr * ('constr,'cst,'ind,'id) gen_tactic_arg list + reference * ('constr,'cst,'ind,'id) gen_tactic_arg list | Tacexp of raw_tactic_expr type raw_atomic_tactic_expr = - (constr_ast,qualid or_metanum,qualid or_metanum,identifier located or_metaid) gen_atomic_tactic_expr + (constr_expr, (* constr *) + reference or_metanum, (* evaluable reference *) + reference or_metanum, (* inductive *) + identifier located or_metaid (* identifier *) + ) gen_atomic_tactic_expr type raw_tactic_arg = - (constr_ast,qualid or_metanum,qualid or_metanum,identifier located or_metaid) gen_tactic_arg + (constr_expr, + reference or_metanum, + reference or_metanum, + identifier located or_metaid) gen_tactic_arg type raw_generic_argument = - (constr_ast,raw_tactic_expr) generic_argument + (constr_expr,raw_tactic_expr) generic_argument type closed_raw_generic_argument = - (constr_ast,raw_tactic_expr) generic_argument + (constr_expr,raw_tactic_expr) generic_argument type 'a raw_abstract_argument_type = - ('a, constr_ast,raw_tactic_expr) abstract_argument_type + ('a, constr_expr,raw_tactic_expr) abstract_argument_type + +type declaration_hook = Decl_kinds.strength -> global_reference -> unit diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index 321a7b2ec..c140aec93 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -68,15 +68,15 @@ let pf_ids_of_hyps gls = ids_of_named_context (pf_hyps gls) let pf_interp_constr gls c = let evc = project gls in - Astterm.interp_constr evc (pf_env gls) c + Constrintern.interp_constr evc (pf_env gls) c let pf_interp_openconstr gls c = let evc = project gls in - Astterm.interp_openconstr evc (pf_env gls) c + Constrintern.interp_openconstr evc (pf_env gls) c let pf_interp_type gls c = let evc = project gls in - Astterm.interp_type evc (pf_env gls) c + Constrintern.interp_type evc (pf_env gls) c let pf_global gls id = Declare.construct_reference (Some (pf_hyps gls)) id @@ -215,223 +215,6 @@ let rename_bound_var_goal gls = let ids = ids_of_named_context sign in convert_concl (rename_bound_var (Global.env()) ids cl) gls - -(***************************************) -(* The interpreter of defined tactics *) -(***************************************) - -(* -let vernac_tactic = vernac_tactic - -let add_tactic = Refiner.add_tactic - -let overwriting_tactic = Refiner.overwriting_add_tactic -*) - - -(* Some combinators for parsing tactic arguments. - They transform the Coqast.t arguments of the tactic into - constr arguments *) - -type ('a,'b) parse_combinator = ('a -> tactic) -> ('b -> tactic) - -(********************************************************) -(* Functions for hiding the implementation of a tactic. *) -(********************************************************) - -(* hide_tactic s tac pr registers a tactic s under the name s *) - -let hide_tactic s tac = - add_tactic s tac; - (fun args -> vernac_tactic(s,args)) - -(* overwriting_register_tactic s tac pr registers a tactic s under the - name s even if a tactic of the same name is already registered *) - -let overwrite_hidden_tactic s tac = - overwriting_add_tactic s tac; - (fun args -> vernac_tactic(s,args)) - -let tactic_com = - fun tac t x -> tac (pf_interp_constr x t) x - -let tactic_opencom = - fun tac t x -> tac (pf_interp_openconstr x t) x - -let tactic_com_sort = - fun tac t x -> tac (pf_interp_type x t) x - -let tactic_com_list = - fun tac tl x -> - let translate = pf_interp_constr x in - tac (List.map translate tl) x - -open Rawterm - -let tactic_bind_list = - fun tac tl x -> - let translate = pf_interp_constr x in - let tl = - match tl with - | NoBindings -> NoBindings - | ImplicitBindings l -> ImplicitBindings (List.map translate l) - | ExplicitBindings l -> - ExplicitBindings (List.map (fun (b,c)->(b,translate c)) l) - in tac tl x - -let translate_bindings gl = function - | NoBindings -> NoBindings - | ImplicitBindings l -> ImplicitBindings (List.map (pf_interp_constr gl) l) - | ExplicitBindings l -> - ExplicitBindings (List.map (fun (b,c)->(b,pf_interp_constr gl c)) l) - -let tactic_com_bind_list = - fun tac (c,tl) gl -> - let translate = pf_interp_constr gl in - tac (translate c,translate_bindings gl tl) gl - -let tactic_com_bind_list_list = - fun tac args gl -> - let translate (c,tl) = (pf_interp_constr gl c, translate_bindings gl tl) - in - tac (List.map translate args) gl - -(* Some useful combinators for hiding tactic implementations *) -(* -type 'a hide_combinator = string -> ('a -> tactic) -> ('a -> tactic) - -let hide_atomic_tactic s tac = - add_tactic s (function [] -> tac | _ -> assert false); - vernac_tactic(s,[]) - -let overwrite_hidden_atomic_tactic s tac = - overwriting_tactic s (function [] -> tac | _ -> assert false); - vernac_tactic(s,[]) -*) -(* -let hide_constr_comarg_tactic s tac = - let tacfun = function - | [Constr c] -> tac c -(* | [Command com] -> tactic_com tac com*) - | _ -> anomaly "hide_constr_comarg_tactic : neither CONSTR nor CONSTR" - in - add_tactic s tacfun; - (fun c -> vernac_tactic(s,[Constr c]), - (* fun com -> vernac_tactic(s,[Command com]) *) fun _ -> failwith "Command unsupported") -*) -(* -let overwrite_hidden_constr_comarg_tactic s tac = - let tacfun = function - | [Constr c] -> tac c -(* | [Command com] -> - (fun gls -> tac (pf_interp_constr gls com) gls)*) - | _ -> - anomaly - "overwrite_hidden_constr_comarg_tactic : neither CONSTR nor CONSTR" - in - overwriting_tactic s tacfun; - (fun c -> vernac_tactic(s,[(Constr c)]), - (*fun c -> vernac_tactic(s,[(Command c)])*) fun _ -> failwith "Command unsupported") -*) -(* -let hide_constr_tactic s tac = - let tacfun = function - | [Constr c] -> tac c -(* | [Command com] -> tactic_com tac com*) - | _ -> anomaly "hide_constr_tactic : neither CONSTR nor CONSTR" - in - add_tactic s tacfun; - (fun c -> vernac_tactic(s,[(Constr c)])) -*) -(* -let hide_openconstr_tactic s tac = - let tacfun = function - | [OpenConstr c] -> tac c -(* | [Command com] -> tactic_opencom tac com*) - | _ -> anomaly "hide_openconstr_tactic : neither OPENCONSTR nor CONSTR" - in - add_tactic s tacfun; - (fun c -> vernac_tactic(s,[(OpenConstr c)])) - -let hide_numarg_tactic s tac = - let tacfun = (function [Integer n] -> tac n | _ -> assert false) in - add_tactic s tacfun; - fun n -> vernac_tactic(s,[Integer n]) - -let hide_ident_tactic s tac = - let tacfun = (function [Identifier id] -> tac id | _ -> assert false) in - add_tactic s tacfun; - fun id -> vernac_tactic(s,[Identifier id]) - -let hide_string_tactic s tac = - let tacfun = (function [Quoted_string str] -> tac str | _ -> assert false) in - add_tactic s tacfun; - fun str -> vernac_tactic(s,[Quoted_string str]) - -let hide_identl_tactic s tac = - let tacfun = (function [Clause idl] -> tac idl | _ -> assert false) in - add_tactic s tacfun; - fun idl -> vernac_tactic(s,[Clause idl]) -*) -(* -let hide_constrl_tactic s tac = - let tacfun = function -(* | ((Command com)::_) as al -> - tactic_com_list tac - (List.map (function (Command com) -> com | _ -> assert false) al)*) - | ((Constr com)::_) as al -> - tac (List.map (function (Constr c) -> c | _ -> assert false) al) - | _ -> anomaly "hide_constrl_tactic : neither CONSTR nor CONSTR" - in - add_tactic s tacfun; - fun ids -> vernac_tactic(s,(List.map (fun id -> Constr id) ids)) -*) -(* -let hide_bindl_tactic s tac = - let tacfun = function -(* | [Bindings al] -> tactic_bind_list tac al*) - | [Cbindings al] -> tac al - | _ -> anomaly "hide_bindl_tactic : neither BINDINGS nor CBINDINGS" - in - add_tactic s tacfun; - fun bindl -> vernac_tactic(s,[Cbindings bindl]) -*) -(* -let hide_cbindl_tactic s tac = - let tacfun = function -(* | [Command com; Bindings al] -> tactic_com_bind_list tac (com,al)*) - | [Constr c; Cbindings al] -> tac (c,al) - | _ -> anomaly "hide_cbindl_tactic : neither CONSTR nor CONSTR" - in - add_tactic s tacfun; - fun (c,bindl) -> vernac_tactic(s,[Constr c; Cbindings bindl]) -*) -(* -let hide_cbindll_tactic s tac = - let rec getcombinds = function -(* | ((Command com)::(Bindings al)::l) -> (com,al)::(getcombinds l)*) - | [] -> [] - | _ -> anomaly "hide_cbindll_tactic : not the expected form" - in - let rec getconstrbinds = function - | ((Constr c)::(Cbindings al)::l) -> (c,al)::(getconstrbinds l) - | [] -> [] - | _ -> anomaly "hide_cbindll_tactic : not the expected form" - in - let rec putconstrbinds = function - | (c,binds)::l -> (Constr c)::(Cbindings binds)::(putconstrbinds l) - | [] -> [] - in - let tacfun = function -(* | ((Command com)::_) as args -> - tactic_com_bind_list_list tac (getcombinds args)*) - | ((Constr com)::_) as args -> tac (getconstrbinds args) - | _ -> anomaly "hide_cbindll_tactic : neither CONSTR nor CONSTR" - in - add_tactic s tacfun; - fun l -> vernac_tactic(s,putconstrbinds l) -*) - (* Pretty-printers *) open Pp @@ -442,7 +225,7 @@ open Rawterm let pr_com sigma goal com = prterm (rename_bound_var (Global.env()) (ids_of_named_context goal.evar_hyps) - (Astterm.interp_constr sigma (Evarutil.evar_env goal) com)) + (Constrintern.interp_constr sigma (Evarutil.evar_env goal) com)) let pr_one_binding sigma goal = function | (NamedHyp id,com) -> pr_id id ++ str ":=" ++ pr_com sigma goal com diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index 49a2db419..ec849662f 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -54,8 +54,8 @@ val pf_check_type : goal sigma -> constr -> types -> unit val pf_execute : goal sigma -> constr -> unsafe_judgment val hnf_type_of : goal sigma -> constr -> types -val pf_interp_constr : goal sigma -> Coqast.t -> constr -val pf_interp_type : goal sigma -> Coqast.t -> types +val pf_interp_constr : goal sigma -> Topconstr.constr_expr -> constr +val pf_interp_type : goal sigma -> Topconstr.constr_expr -> types val pf_get_hyp : goal sigma -> identifier -> named_declaration val pf_get_hyp_typ : goal sigma -> identifier -> types @@ -77,7 +77,7 @@ val pf_nf_betaiota : goal sigma -> constr -> constr val pf_reduce_to_quantified_ind : goal sigma -> types -> inductive * types val pf_reduce_to_atomic_ind : goal sigma -> types -> inductive * types val pf_compute : goal sigma -> constr -> constr -val pf_unfoldn : (int list * Closure.evaluable_global_reference) list +val pf_unfoldn : (int list * evaluable_global_reference) list -> goal sigma -> constr -> constr val pf_const_value : goal sigma -> constant -> constr @@ -154,39 +154,12 @@ val tactic_list_tactic : tactic_list -> tactic val tclFIRSTLIST : tactic_list list -> tactic_list val tclIDTAC_list : tactic_list - -(*s Tactic Registration. *) - -(* -val add_tactic : string -> (tactic_arg list -> tactic) -> unit -val overwriting_tactic : string -> (tactic_arg list -> tactic) -> unit -*) - -(*s Transformation of tactic arguments. *) - -type ('a,'b) parse_combinator = ('a -> tactic) -> ('b -> tactic) - -val tactic_com : (constr,Coqast.t) parse_combinator -val tactic_com_sort : (constr,Coqast.t) parse_combinator -val tactic_com_list : (constr list, Coqast.t list) parse_combinator - -val tactic_bind_list : - (constr substitution, Coqast.t substitution) parse_combinator - -val tactic_com_bind_list : - (constr * constr substitution, - Coqast.t * Coqast.t substitution) parse_combinator - -val tactic_com_bind_list_list : - ((constr * constr substitution) list, - (Coqast.t * Coqast.t substitution) list) parse_combinator - (*s Pretty-printing functions. *) (*i*) open Pp (*i*) -val pr_com : evar_map -> goal -> Coqast.t -> std_ppcmds +val pr_com : evar_map -> goal -> Topconstr.constr_expr -> std_ppcmds val pr_gls : goal sigma -> std_ppcmds val pr_glls : goal list sigma -> std_ppcmds diff --git a/scripts/coqmktop.ml b/scripts/coqmktop.ml index 9ba53cdae..8c73b9c5e 100644 --- a/scripts/coqmktop.ml +++ b/scripts/coqmktop.ml @@ -30,6 +30,7 @@ let lib = split_cmo Tolink.lib let kernel = split_cmo Tolink.kernel let library = split_cmo Tolink.library let pretyping = split_cmo Tolink.pretyping +let interp = split_cmo Tolink.interp let parsing = split_cmo Tolink.parsing let proofs = split_cmo Tolink.proofs let tactics = split_cmo Tolink.tactics @@ -37,7 +38,7 @@ let toplevel = split_cmo Tolink.toplevel let highparsing = split_cmo Tolink.highparsing let core_objs = - libobjs @ lib @ kernel @ library @ pretyping @ parsing @ + libobjs @ lib @ kernel @ library @ pretyping @ interp @ parsing @ proofs @ tactics (* 3. Files only in coqsearchisos (if option -searchisos is used) *) diff --git a/syntax/PPCases.v b/syntax/PPCases.v index 3bdf47feb..356f6b214 100644 --- a/syntax/PPCases.v +++ b/syntax/PPCases.v @@ -95,3 +95,4 @@ Syntax constr [1 1] [ $tomatch:L ] ] [1 0] "in " [ $c:L ] ] ] . + diff --git a/syntax/PPConstr.v b/syntax/PPConstr.v index ddfbceb83..d4d2ae5e6 100755 --- a/syntax/PPConstr.v +++ b/syntax/PPConstr.v @@ -83,7 +83,7 @@ Syntax constr (* Things parsed in command5 *) level 5: - cast [ ($C :: $T) ] -> [ [ $C:L [0 0] "::" $T:E] ] + cast [ << (CAST $C $T) >> ] -> [ [ $C:L [0 0] "::" $T:E] ] ; (* Things parsed in command6 *) @@ -117,7 +117,7 @@ Syntax constr | lambdal_cons [ << (LAMLBOX $pbi $c (IDS ($LIST $ids)) [$id]$body) >> ] -> [(LAMLBOX $pbi $c (IDS ($LIST $ids) $id) $body)] - | pi [ ($x : $A)$B ] -> [ (PRODBOX (BINDERS) <<($x : $A)$B>>) ] + | pi [ << (PROD $A [$x]$B) >> ] -> [ (PRODBOX (BINDERS) (PROD $A [$x]$B)) ] | prodlist [ << (PRODLIST $c $b) >> ] -> [(PRODBOX (BINDERS) (PRODLIST $c $b))] @@ -125,7 +125,7 @@ Syntax constr -> [ [ "(" [ $pbi] ")" [0 1] $t:E ] ] | prod_cons - [ << (PRODBOX (BINDERS ($LIST $acc)) <:constr:<($x : $Dom)$body>>) >> ] + [ << (PRODBOX (BINDERS ($LIST $acc)) (PROD $Dom [$x]$body)) >> ] -> [(PRODBOX (BINDERS ($LIST $acc) (BINDER $Dom $x)) $body)] | prodl_start_cons [ << (PRODBOX $pbi (PRODLIST $Dom $Body)) >> ] -> [(PRODLBOX $pbi $Dom (IDS) $Body)] @@ -138,17 +138,18 @@ Syntax constr -> [(PRODLBOX $pbi $c (IDS ($LIST $ids) $id) $body)] - | arrow [ $A -> $B ] -> [ [ $A:L [0 0] "->" (ARROWBOX $B) ] ] + | arrow [ << (PROD $A [<>]$B) >> ] -> + [ [ $A:L [0 0] "->" (ARROWBOX $B) ] ] | arrow_stop [ << (ARROWBOX $c) >> ] -> [ $c:E ] - | arrow_again [ << (ARROWBOX <:constr:< $A -> $B >>) >> ] -> + | arrow_again [ << (ARROWBOX (PROD $A [<>]$B)) >> ] -> [ $A:L [0 0] "->" (ARROWBOX $B) ] (* These are synonymous *) (* redundant | let [ [$x = $M]$N ] -> [ [ "[" $x "=" $M:E "]" [0 1] $N:E ] ] *) - | letin [ [$x := $A]$B ] -> [ [ "[" $x ":=" $A:E "]" [0 1] $B:E ] ] - | letincast [ [$x := $A : $C]$B ] -> [ [ "[" $x ":=" $A:E ":" $C:E "]" [0 1] $B:E ] ] + | letin [ << (LETIN $A [$x]$B) >> ] -> [ [ "[" $x ":=" $A:E "]" [0 1] $B:E ] ] + | letincast [ << (LETIN (CAST $A $C) [$x]$B) >> ] -> [ [ "[" $x ":=" $A:E ":" $C:E "]" [0 1] $B:E ] ] ; (* Things parsed in command9 *) @@ -261,5 +262,3 @@ Syntax constr evalconstr [ << (EVAL $c $r) >> ] -> [ [ "Eval" [1 1] $r [1 0] "in" [1 1] $c:E ] ]. - - diff --git a/tactics/auto.ml b/tactics/auto.ml index ade0b0221..9c153b15e 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -428,19 +428,19 @@ let add_hints dbnames h = let dbnames = if dbnames = [] then ["core"] else dbnames in match h with | HintsResolve lhints -> let env = Global.env() and sigma = Evd.empty in - let f (n,c) = - let c = Astterm.interp_constr sigma env c in + let f (n,c) = + let c = Constrintern.interp_constr sigma env c in let n = match n with - | None -> basename (sp_of_global None (Declare.reference_of_constr c)) + | None -> basename (sp_of_global None (reference_of_constr c)) | Some n -> n in (n,c) in add_resolves env sigma (List.map f lhints) dbnames | HintsImmediate lhints -> let env = Global.env() and sigma = Evd.empty in let f (n,c) = - let c = Astterm.interp_constr sigma env c in + let c = Constrintern.interp_constr sigma env c in let n = match n with - | None -> basename (sp_of_global None (Declare.reference_of_constr c)) + | None -> basename (sp_of_global None (reference_of_constr c)) | Some n -> n in (n,c) in add_trivials env sigma (List.map f lhints) dbnames @@ -460,7 +460,7 @@ let add_hints dbnames h = let lcons = List.map2 (fun id c -> (id,c)) (Array.to_list consnames) lcons in add_resolves env sigma lcons dbnames | HintsExtern (hintname, pri, patcom, tacexp) -> - let pat = Astterm.interp_constrpattern Evd.empty (Global.env()) patcom in + let pat = Constrintern.interp_constrpattern Evd.empty (Global.env()) patcom in add_externs hintname pri pat tacexp dbnames (**************************************************************************) @@ -901,7 +901,7 @@ let default_superauto g = superauto !default_search_depth [] [] g let interp_to_add gl locqid = let r = Nametab.global locqid in let id = basename (sp_of_global None r) in - (next_ident_away id (pf_ids_of_hyps gl), Declare.constr_of_reference r) + (next_ident_away id (pf_ids_of_hyps gl), constr_of_reference r) let gen_superauto nopt l a b gl = let n = match nopt with Some n -> n | None -> !default_search_depth in diff --git a/tactics/auto.mli b/tactics/auto.mli index c887c1bb4..4cd017e5f 100644 --- a/tactics/auto.mli +++ b/tactics/auto.mli @@ -185,4 +185,4 @@ type autoArguments = val superauto : int -> (identifier * constr) list -> autoArguments list -> tactic *) -val h_superauto : int option -> qualid located list -> bool -> bool -> tactic +val h_superauto : int option -> reference list -> bool -> bool -> tactic diff --git a/tactics/dhyp.ml b/tactics/dhyp.ml index a00083938..419d9c43c 100644 --- a/tactics/dhyp.ml +++ b/tactics/dhyp.ml @@ -128,10 +128,10 @@ open Tacticals open Libobject open Library open Pattern -open Coqast open Ast open Pcoq open Tacexpr +open Libnames (* two patterns - one for the type, and one for the type of the type *) type destructor_pattern = { @@ -215,7 +215,7 @@ let add_destructor_hint na loc pat pri code = errorlabstrm "add_destructor_hint" (str "The tactic should be a function of the hypothesis name") end in - let (_,pat) = Astterm.interp_constrpattern Evd.empty (Global.env()) pat in + let (_,pat) = Constrintern.interp_constrpattern Evd.empty (Global.env()) pat in let pat = match loc with | HypLocation b -> HypLocation @@ -251,7 +251,7 @@ let applyDestructor cls discard dd gls = with PatternMatchingFailure -> error "No match" in let tac = match cls, dd.d_code with | Some id, (Some x, tac) -> - let arg = Reference (RIdent (dummy_loc,id)) in + let arg = Reference (Ident (dummy_loc,id)) in TacLetIn ([(dummy_loc, x), None, arg], tac) | None, (None, tac) -> tac | _, (Some _,_) -> error "Destructor expects an hypothesis" diff --git a/tactics/dhyp.mli b/tactics/dhyp.mli index bedbb26c9..2015f6053 100644 --- a/tactics/dhyp.mli +++ b/tactics/dhyp.mli @@ -27,4 +27,4 @@ val h_auto_tdb : int option -> tactic val add_destructor_hint : identifier -> (bool,unit) Tacexpr.location -> - Genarg.constr_ast -> int -> Tacexpr.raw_tactic_expr -> unit + Topconstr.constr_expr -> int -> Tacexpr.raw_tactic_expr -> unit diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4 index 8ab6d23ab..896218c80 100644 --- a/tactics/eauto.ml4 +++ b/tactics/eauto.ml4 @@ -45,11 +45,7 @@ let e_resolve_with_bindings_tac (c,lbind) gl = let clause = make_clenv_binding_apply wc (-1) (c,t) lbind in e_res_pf kONT clause gl -let e_resolve_with_bindings = - tactic_com_bind_list e_resolve_with_bindings_tac - let e_resolve_constr c gls = e_resolve_with_bindings_tac (c,NoBindings) gls -let resolve_constr c gls = Tactics.apply_with_bindings (c,NoBindings) gls TACTIC EXTEND EExact | [ "EExact" constr(c) ] -> [ e_give_exact c ] @@ -61,6 +57,7 @@ let registered_e_assumption gl = tclFIRST (List.map (fun id gl -> e_give_exact_constr (mkVar id) gl) (pf_ids_of_hyps gl)) gl +(* This automatically define h_eApply (among other things) *) TACTIC EXTEND EApply [ "EApply" constr_with_bindings(c) ] -> [ e_resolve_with_bindings_tac c ] END diff --git a/tactics/elim.ml b/tactics/elim.ml index b4f718fbd..09c176ac6 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -128,7 +128,7 @@ let decompose_or c gls = (fun (_,t) -> is_disjunction t) c gls -let inj x = Rawterm.AN (Rawterm.dummy_loc,x) +let inj x = Rawterm.AN x let h_decompose l c = Refiner.abstract_tactic (TacDecompose (List.map inj l,c)) (decompose_these c l) diff --git a/tactics/equality.ml b/tactics/equality.ml index fdd02fe92..bfa1baf83 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -372,7 +372,7 @@ let descend_then sigma env head dirn = let brl = List.map build_branch (interval 1 (Array.length mip.mind_consnames)) in - let ci = make_default_case_info env ind in + let ci = make_default_case_info env RegularStyle ind in mkCase (ci, p, head, Array.of_list brl))) (* Now we need to construct the discriminator, given a discriminable @@ -420,7 +420,7 @@ let construct_discriminator sigma env dirn c sort = 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 + let ci = make_default_case_info env RegularStyle ind in mkCase (ci, p, c, Array.of_list brl) let rec build_discriminator sigma env dirn c sort = function @@ -556,12 +556,6 @@ let discr_tac = function let discrConcl gls = discrClause None gls let discrHyp id gls = discrClause (Some id) gls -(* -let h_discr = hide_atomic_tactic "Discr" discrEverywhere -let h_discrConcl = hide_atomic_tactic "DiscrConcl" discrConcl -let h_discrHyp = hide_ident_or_numarg_tactic "DiscrHyp" discrHyp -*) - (* returns the sigma type (sigS, sigT) with the respective constructor depending on the sort *) @@ -811,11 +805,6 @@ let injClause = function let injConcl gls = injClause None gls let injHyp id gls = injClause (Some id) gls -(* -let h_injConcl = hide_atomic_tactic "Inj" injConcl -let h_injHyp = hide_ident_or_numarg_tactic "InjHyp" injHyp -*) - let decompEqThen ntac id gls = let eqn = pf_whd_betadeltaiota gls (clause_type (Some id) gls) in let (lbeq,(t,t1,t2))= find_eq_data_decompose eqn in @@ -876,11 +865,6 @@ let dEq = dEqThen (fun x -> tclIDTAC) let dEqConcl gls = dEq None gls let dEqHyp id gls = dEq (Some id) gls -(* -let dEqConcl_tac = hide_atomic_tactic "DEqConcl" dEqConcl -let dEqHyp_tac = hide_ident_or_numarg_tactic "DEqHyp" dEqHyp -*) - let rewrite_msg = function | None -> (str "passed term is not a primitive equality") @@ -1099,18 +1083,6 @@ let subst l2r eqn cls gls = let substConcl l2r eqn gls = try_rewrite (subst l2r eqn None) gls let substConcl_LR = substConcl true -(* -let substConcl_LR_tac = - let gentac = - hide_tactic "SubstConcl_LR" - (function - | [Command eqn] -> - (fun gls -> substConcl_LR (pf_interp_constr gls eqn) gls) - | [Constr c] -> substConcl_LR c - | _ -> assert false) - in - fun eqn -> gentac [Command eqn] -*) (* id:(P a) |- G * SubstHyp a=b id @@ -1135,16 +1107,6 @@ let hypSubst_LR = hypSubst true *) let substHypInConcl l2r id gls = try_rewrite (hypSubst l2r id None) gls let substHypInConcl_LR = substHypInConcl true -(* -let substHypInConcl_LR_tac = - let gentac = - hide_tactic "SubstHypInConcl_LR" - (function - | [Identifier id] -> substHypInConcl_LR id - | _ -> assert false) - in - fun id -> gentac [Identifier id] -*) (* id:a=b H:(P a) |- G SubstHypInHyp id H. @@ -1156,18 +1118,6 @@ let substHypInConcl_LR_tac = |- a=b *) let substConcl_RL = substConcl false -(* -let substConcl_RL_tac = - let gentac = - hide_tactic "SubstConcl_RL" - (function - | [Command eqn] -> - (fun gls -> substConcl_RL (pf_interp_constr gls eqn) gls) - | [Constr c] -> substConcl_RL c - | _ -> assert false) - in - fun eqn -> gentac [Command eqn] -*) (* id:(P b) |-G SubstHyp_RL a=b id @@ -1184,16 +1134,6 @@ let hypSubst_RL = hypSubst false * id:a=b |- (P a) *) let substHypInConcl_RL = substHypInConcl false -(* -let substHypInConcl_RL_tac = - let gentac = - hide_tactic "SubstHypInConcl_RL" - (function - | [Identifier id] -> substHypInConcl_RL id - | _ -> assert false) - in - fun id -> gentac [Identifier id] -*) (* id:a=b H:(P b) |- G SubstHypInHyp id H. diff --git a/tactics/extraargs.mli b/tactics/extraargs.mli index d5a2b9886..d90de63c9 100644 --- a/tactics/extraargs.mli +++ b/tactics/extraargs.mli @@ -11,11 +11,12 @@ open Tacexpr open Term open Proof_type +open Topconstr val rawwit_orient : bool raw_abstract_argument_type val wit_orient : bool closed_abstract_argument_type val orient : bool Pcoq.Gram.Entry.e -val rawwit_with_constr : Coqast.t option raw_abstract_argument_type +val rawwit_with_constr : constr_expr option raw_abstract_argument_type val wit_with_constr : constr option closed_abstract_argument_type -val with_constr : Coqast.t option Pcoq.Gram.Entry.e +val with_constr : constr_expr option Pcoq.Gram.Entry.e diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index 6907acd35..2d89b84f5 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -132,7 +132,7 @@ END let add_rewrite_hint name ort t lcsr = let env = Global.env() and sigma = Evd.empty in - let f c = Astterm.interp_constr sigma env c, ort, t in + let f c = Constrintern.interp_constr sigma env c, ort, t in add_rew_rules name (List.map f lcsr) VERNAC COMMAND EXTEND HintRewrite @@ -171,10 +171,6 @@ VERNAC COMMAND EXTEND AddSetoid | [ "Add" "Morphism" constr(m) ":" ident(s) ] -> [ new_named_morphism s m ] END -(* -cp tactics/extratactics.ml4 toto.ml; camlp4o -I parsing pa_extend.cmo grammar.cma pr_o.cmo toto.ml -*) - (* Inversion lemmas (Leminv) *) VERNAC COMMAND EXTEND DeriveInversionClear @@ -188,15 +184,18 @@ VERNAC COMMAND EXTEND DeriveInversionClear -> [ add_inversion_lemma_exn na c s false inv_clear_tac ] | [ "Derive" "Inversion_clear" ident(na) "with" constr(c) ] - -> [ add_inversion_lemma_exn na c (let loc = (0,0) in <:ast< (PROP) >>) false inv_clear_tac ] + -> [ add_inversion_lemma_exn na c (Rawterm.RProp Term.Null) false inv_clear_tac ] END +open Term +open Rawterm + VERNAC COMMAND EXTEND DeriveInversion | [ "Derive" "Inversion" ident(na) "with" constr(c) "Sort" sort(s) ] -> [ add_inversion_lemma_exn na c s false half_inv_tac ] | [ "Derive" "Inversion" ident(na) "with" constr(c) ] - -> [ add_inversion_lemma_exn na c (let loc = (0,0) in <:ast< (PROP) >>) false half_inv_tac ] + -> [ add_inversion_lemma_exn na c (RProp Null) false half_inv_tac ] | [ "Derive" "Inversion" ident(na) ident(id) ] -> [ inversion_lemma_from_goal 1 na id Term.mk_Prop false half_inv_tac ] diff --git a/tactics/hiddentac.ml b/tactics/hiddentac.ml index 1fcf1e6bd..75bcb0d6b 100644 --- a/tactics/hiddentac.ml +++ b/tactics/hiddentac.ml @@ -61,7 +61,7 @@ let h_specialize n (c,bl as d) = let h_lapply c = abstract_tactic (TacLApply c) (cut_and_apply c) (* Context management *) -let inj x = AN (Rawterm.dummy_loc,x) +let inj x = AN x let h_clear l = abstract_tactic (TacClear (List.map inj l)) (clear l) let h_clear_body l = abstract_tactic (TacClearBody (List.map inj l)) (clear_body l) diff --git a/tactics/leminv.ml b/tactics/leminv.ml index adc2054fe..6edf56017 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -274,8 +274,8 @@ let inversion_lemma_from_goal n na id sort dep_option inv_op = let add_inversion_lemma_exn na com comsort bool tac = let env = Global.env () and sigma = Evd.empty in - let c = Astterm.interp_type sigma env com in - let sort = Astterm.interp_sort comsort in + let c = Constrintern.interp_type sigma env com in + let sort = Pretyping.interp_sort comsort in try add_inversion_lemma na env sigma c sort bool tac with diff --git a/tactics/leminv.mli b/tactics/leminv.mli index 3d5f33c66..17e1b0552 100644 --- a/tactics/leminv.mli +++ b/tactics/leminv.mli @@ -3,6 +3,7 @@ open Names open Term open Rawterm open Proof_type +open Topconstr val lemInv_gen : quantified_hypothesis -> constr -> tactic val lemInvIn_gen : quantified_hypothesis -> constr -> identifier list -> tactic @@ -11,5 +12,5 @@ val inversion_lemma_from_goal : int -> identifier -> identifier -> sorts -> bool -> (identifier -> tactic) -> unit val add_inversion_lemma_exn : - identifier -> Coqast.t -> Coqast.t -> bool -> (identifier -> tactic) -> unit + identifier -> constr_expr -> rawsort -> bool -> (identifier -> tactic) -> unit diff --git a/tactics/setoid_replace.ml b/tactics/setoid_replace.ml index 3a4ae8e13..fa62c8dd4 100644 --- a/tactics/setoid_replace.ml +++ b/tactics/setoid_replace.ml @@ -45,7 +45,7 @@ type morphism = lem2 : constr option } -let constr_of c = Astterm.interp_constr Evd.empty (Global.env()) c +let constr_of c = Constrintern.interp_constr Evd.empty (Global.env()) c let constant dir s = let dir = make_dirpath @@ -414,9 +414,8 @@ let new_morphism m id hook = let args_t = (List.map snd args) in let poss = (List.map setoid_table_mem args_t) in let lem = (gen_compat_lemma env m body args_t poss) in - let lemast = (ast_of_constr true env lem) in new_edited id m poss; - start_proof_com (Some id) (IsGlobal DefinitionBody) ([],lemast) hook; + start_proof id (IsGlobal DefinitionBody) lem hook; (Options.if_verbose Vernacentries.show_open_subgoals ())) let rec sub_bool l1 n = function diff --git a/tactics/setoid_replace.mli b/tactics/setoid_replace.mli index d8bc55656..e4d49e902 100644 --- a/tactics/setoid_replace.mli +++ b/tactics/setoid_replace.mli @@ -10,7 +10,7 @@ open Term open Proof_type -open Genarg +open Topconstr val equiv_list : unit -> constr list @@ -22,6 +22,6 @@ val setoid_rewriteRL : constr -> tactic val general_s_rewrite : bool -> constr -> tactic -val add_setoid : constr_ast -> constr_ast -> constr_ast -> unit +val add_setoid : constr_expr -> constr_expr -> constr_expr -> unit -val new_named_morphism : Names.identifier -> constr_ast -> unit +val new_named_morphism : Names.identifier -> constr_expr -> unit diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index efa497b95..be6362d3a 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -8,7 +8,7 @@ (* $Id$ *) -open Astterm +open Constrintern open Closure open RedFlags open Declarations @@ -30,7 +30,7 @@ open Proof_type open Refiner open Tacmach open Tactic_debug -open Coqast +open Topconstr open Ast open Term open Termops @@ -63,7 +63,7 @@ type value = | VFTactic of value list * (value list->tactic) | VRTactic of (goal list sigma * validation) | VContext of interp_sign * direction_flag - * (pattern_ast,raw_tactic_expr) match_rule list + * (pattern_expr,raw_tactic_expr) match_rule list | VFun of (identifier * value) list * identifier option list *raw_tactic_expr | VVoid | VInteger of int @@ -165,9 +165,6 @@ let valueOut = function anomalylabstrm "valueOut" (str "Not a Dynamic ast: " (* ++ print_ast ast*) ) -let constrIn c = constrIn c -let constrOut = constrOut - let loc = dummy_loc (* Table of interpretation functions *) @@ -297,7 +294,7 @@ let glob_hyp (lfun,_) (loc,id) = *) Pretype_errors.error_var_not_found_loc loc id -let glob_lochyp ist (loc,_ as locid) = (loc,glob_hyp ist locid) +let glob_lochyp ist (_loc,_ as locid) = (loc,glob_hyp ist locid) let error_unbound_metanum loc n = user_err_loc @@ -307,30 +304,25 @@ let glob_metanum ist loc n = if List.mem n (snd ist) then n else error_unbound_metanum loc n let glob_hyp_or_metanum ist = function - | AN (loc,id) -> AN (loc,glob_hyp ist (loc,id)) - | MetaNum (loc,n) -> MetaNum (loc,glob_metanum ist loc n) + | AN id -> AN (glob_hyp ist (loc,id)) + | MetaNum (_loc,n) -> MetaNum (loc,glob_metanum ist loc n) let glob_qualid_or_metanum ist = function - | AN (loc,qid) -> AN (loc,qualid_of_sp (sp_of_global None (Nametab.global (loc,qid)))) - | MetaNum (loc,n) -> MetaNum (loc,glob_metanum ist loc n) + | AN qid -> AN (Qualid(loc,qualid_of_sp (sp_of_global None (Nametab.global qid)))) + | MetaNum (_loc,n) -> MetaNum (loc,glob_metanum ist loc n) -let glob_reference ist (_,qid as locqid) = - let dir, id = repr_qualid qid in - try - if dir = empty_dirpath && List.mem id (fst ist) then qid - else raise Not_found - with Not_found -> - qualid_of_sp (sp_of_global None (Nametab.global locqid)) +let glob_reference ist = function + | Ident (loc,id) as r when List.mem id (fst ist) -> r + | r -> Qualid (loc,qualid_of_sp (sp_of_global None (Nametab.global r))) -let glob_ltac_qualid ist (loc,qid as locqid) = - try qualid_of_sp (locate_tactic qid) - with Not_found -> glob_reference ist locqid +let glob_ltac_qualid ist ref = + let (loc,qid) = qualid_of_reference ref in + try Qualid (loc,qualid_of_sp (locate_tactic qid)) + with Not_found -> glob_reference ist ref let glob_ltac_reference ist = function - | RIdent (loc,id) -> - if List.mem id (fst ist) then RIdent (loc,id) - else RQualid (loc,glob_ltac_qualid ist (loc,make_short_qualid id)) - | RQualid qid -> RQualid (loc,glob_ltac_qualid ist qid) + | Ident (_loc,id) when List.mem id (fst ist) -> Ident (loc,id) + | r -> glob_ltac_qualid ist r let rec glob_intro_pattern lf ist = function | IntroOrAndPattern l -> @@ -346,8 +338,10 @@ let glob_quantified_hypothesis ist x = x let glob_constr ist c = - let _ = Astterm.interp_rawconstr_gen Evd.empty (Global.env()) [] false (fst ist) c in - c + let _ = + Constrintern.interp_rawconstr_gen + Evd.empty (Global.env()) [] false (fst ist) c + in c (* Globalize bindings *) let glob_binding ist (b,c) = @@ -364,7 +358,7 @@ let glob_constr_with_bindings ist (c,bl) = let glob_clause_pattern ist (l,occl) = let rec check = function | (hyp,l) :: rest -> - let (loc,_ as id) = skip_metaid hyp in + let (_loc,_ as id) = skip_metaid hyp in (AI(loc,glob_hyp ist id),l)::(check rest) | [] -> [] in (l,check occl) @@ -372,12 +366,12 @@ let glob_clause_pattern ist (l,occl) = let glob_induction_arg ist = function | ElimOnConstr c -> ElimOnConstr (glob_constr ist c) | ElimOnAnonHyp n as x -> x - | ElimOnIdent (loc,id) as x -> x + | ElimOnIdent (_loc,id) as x -> ElimOnIdent (loc,id) (* Globalize a reduction expression *) let glob_evaluable_or_metanum ist = function - | AN (loc,qid) -> AN (loc,glob_reference ist (loc,qid)) - | MetaNum (loc,n) -> MetaNum (loc,glob_metanum ist loc n) + | AN qid -> AN (glob_reference ist qid) + | MetaNum (_loc,n) -> MetaNum (loc,glob_metanum ist loc n) let glob_unfold ist (l,qid) = (l,glob_evaluable_or_metanum ist qid) @@ -398,10 +392,10 @@ let glob_redexp ist = function (* Interprets an hypothesis name *) let glob_hyp_location ist = function | InHyp id -> - let (loc,_ as id) = skip_metaid id in + let (_loc,_ as id) = skip_metaid id in InHyp (AI(loc,glob_hyp ist id)) | InHypType id -> - let (loc,_ as id) = skip_metaid id in + let (_loc,_ as id) = skip_metaid id in InHypType (AI(loc,glob_hyp ist id)) (* Reads a pattern *) @@ -465,7 +459,7 @@ let rec glob_atomic lf ist = function | TacIntrosUntil hyp -> TacIntrosUntil (glob_quantified_hypothesis ist hyp) | TacIntroMove (ido,ido') -> TacIntroMove (option_app (glob_ident lf ist) ido, - option_app (fun (loc,_ as x) -> (loc,glob_hyp ist x)) ido') + option_app (fun (_loc,_ as x) -> (loc,glob_hyp ist x)) ido') | TacAssumption -> TacAssumption | TacExact c -> TacExact (glob_constr ist c) | TacApply cb -> TacApply (glob_constr_with_bindings ist cb) @@ -497,7 +491,7 @@ let rec glob_atomic lf ist = function | TacTrivial l -> TacTrivial l | TacAuto (n,l) -> TacAuto (n,l) | TacAutoTDB n -> TacAutoTDB n - | TacDestructHyp (b,(loc,_ as id)) -> TacDestructHyp(b,(loc,glob_hyp ist id)) + | TacDestructHyp (b,(_loc,_ as id)) -> TacDestructHyp(b,(loc,glob_hyp ist id)) | TacDestructConcl -> TacDestructConcl | TacSuperAuto (n,l,b1,b2) -> TacSuperAuto (n,l,b1,b2) | TacDAuto (n,p) -> TacDAuto (n,p) @@ -550,15 +544,15 @@ let rec glob_atomic lf ist = function | TacTransitivity c -> TacTransitivity (glob_constr ist c) (* For extensions *) - | TacExtend (opn,l) -> + | TacExtend (_loc,opn,l) -> let _ = lookup_tactic opn in - TacExtend (opn,List.map (glob_genarg ist) l) + TacExtend (loc,opn,List.map (glob_genarg ist) l) | TacAlias (_,l,body) -> failwith "TacAlias globalisation: TODO" and glob_tactic ist tac = snd (glob_tactic_seq ist tac) and glob_tactic_seq (lfun,lmeta as ist) = function - | TacAtom (loc,t) -> + | TacAtom (_loc,t) -> let lf = ref lfun in let t = glob_atomic lf ist t in !lf, TacAtom (loc, t) @@ -612,10 +606,10 @@ and glob_tacarg ist = function | Reference r -> Reference (glob_ltac_reference ist r) | Integer n -> Integer n | ConstrMayEval c -> ConstrMayEval (glob_constr_may_eval ist c) - | MetaNumArg (loc,n) -> MetaNumArg (loc,glob_metanum ist loc n) - | MetaIdArg (loc,_) -> error_syntactic_metavariables_not_allowed loc - | TacCall (loc,f,l) -> - TacCall (loc,glob_ltac_reference ist f,List.map (glob_tacarg ist) l) + | MetaNumArg (_loc,n) -> MetaNumArg (loc,glob_metanum ist loc n) + | MetaIdArg (_loc,_) -> error_syntactic_metavariables_not_allowed loc + | TacCall (_loc,f,l) -> + TacCall (_loc,glob_ltac_reference ist f,List.map (glob_tacarg ist) l) | Tacexp t -> Tacexp (glob_tactic ist t) | TacDynamic(_,t) as x -> (match tag t with @@ -641,7 +635,7 @@ and glob_genarg ist x = | IntArgType -> in_gen rawwit_int (out_gen rawwit_int x) | IntOrVarArgType -> let f = function - | ArgVar (loc,id) -> ArgVar (loc,glob_hyp ist (loc,id)) + | ArgVar (_loc,id) -> ArgVar (loc,glob_hyp ist (loc,id)) | ArgArg n as x -> x in in_gen rawwit_int_or_var (f (out_gen rawwit_int_or_var x)) | StringArgType -> @@ -650,9 +644,10 @@ and glob_genarg ist x = in_gen rawwit_pre_ident (out_gen rawwit_pre_ident x) | IdentArgType -> in_gen rawwit_ident (glob_hyp ist (dummy_loc,out_gen rawwit_ident x)) - | QualidArgType -> - let (loc,qid) = out_gen rawwit_qualid x in - in_gen rawwit_qualid (loc,glob_ltac_qualid ist (loc,qid)) + | RefArgType -> + in_gen rawwit_ref (glob_ltac_reference ist (out_gen rawwit_ref x)) + | SortArgType -> + in_gen rawwit_sort (out_gen rawwit_sort x) | ConstrArgType -> in_gen rawwit_constr (glob_constr ist (out_gen rawwit_constr x)) | ConstrMayEvalArgType -> @@ -679,29 +674,6 @@ and glob_genarg ist x = (************* END GLOBALIZE ************) -(* Reads the head of Fun *) -let read_fun ast = - let rec read_fun_rec = function - | Node(_,"VOID",[])::tl -> None::(read_fun_rec tl) - | Nvar(_,s)::tl -> (Some s)::(read_fun_rec tl) - | [] -> [] - | _ -> - anomalylabstrm "Tacinterp.read_fun_rec" (str "Fun not well formed") - in - match ast with - | Node(_,"FUNVAR",l) -> read_fun_rec l - | _ -> - anomalylabstrm "Tacinterp.read_fun" (str "Fun not well formed") - -(* Reads the clauses of a Rec *) -let rec read_rec_clauses = function - | [] -> [] - | Node(_,"RECCLAUSE",[Nvar(_,name);it;body])::tl -> - (name,it,body)::(read_rec_clauses tl) - |_ -> - anomalylabstrm "Tacinterp.read_rec_clauses" - (str "Rec not well formed") - (* Associates variables with values and gives the remaining variables and values *) let head_with_value (lvar,lval) = @@ -906,7 +878,7 @@ let name_interp ist = function | Name id -> Name (ident_interp ist id) let hyp_or_metanum_interp ist = function - | AN (loc,id) -> ident_interp ist id + | AN id -> ident_interp ist id | MetaNum (loc,n) -> constr_to_id loc (List.assoc n ist.lmatch) (* To avoid to move to much simple functions in the big recursive block *) @@ -924,32 +896,30 @@ let interp_ltac_qualid is_applied ist (loc,qid as lqid) = with Not_found -> interp_pure_qualid is_applied ist lqid let interp_ltac_reference isapplied ist = function - | RIdent (loc,id) -> + | Ident (loc,id) -> (try unrec (List.assoc id ist.lfun) with | Not_found -> interp_ltac_qualid isapplied ist (loc,make_short_qualid id)) - | RQualid qid -> interp_ltac_qualid isapplied ist qid + | Qualid qid -> interp_ltac_qualid isapplied ist qid (* Interprets a qualified name *) -let eval_qualid ist (loc,qid as locqid) = - let dir, id = repr_qualid qid in - try - if dir = empty_dirpath then unrec (List.assoc id ist.lfun) - else raise Not_found - with | Not_found -> - interp_pure_qualid false ist locqid - -let qualid_interp ist qid = - let v = eval_qualid ist qid in +let eval_ref ist = function + | Qualid locqid -> interp_pure_qualid false ist locqid + | Ident (loc,id) -> + try unrec (List.assoc id ist.lfun) + with Not_found -> interp_pure_qualid false ist (loc,make_short_qualid id) + +let reference_interp ist qid = + let v = eval_ref ist qid in coerce_to_reference ist v (* Interprets a qualified name. This can be a metavariable to be injected *) let qualid_or_metanum_interp ist = function - | AN (loc,qid) -> qid + | AN qid -> qid | MetaNum (loc,n) -> constr_to_qid loc (List.assoc n ist.lmatch) let eval_ref_or_metanum ist = function - | AN (loc,qid) -> eval_qualid ist (loc,qid) + | AN qid -> eval_ref ist qid | MetaNum (loc,n) -> VConstr (List.assoc n ist.lmatch) let interp_evaluable_or_metanum ist c = @@ -1080,7 +1050,8 @@ let interp_induction_arg ist = function | Some gl -> if Tactics.is_quantified_hypothesis id gl then ElimOnIdent (loc,id) else ElimOnConstr - (constr_interp ist (Termast.ast_of_qualid (make_short_qualid id))) +(* (constr_interp ist (Termast.ast_of_qualid (make_short_qualid id)))*) + (constr_interp ist (CRef (Ident (loc,id)))) let binding_interp ist (b,c) = (interp_quantified_hypothesis ist b,constr_interp ist c) @@ -1173,12 +1144,6 @@ and tacarg_interp ist = function | Tacexp t -> val_interp ist t (* | Tacexp t -> VArg (Tacexp ((*tactic_interp ist t,*)t)) -*) -(* - | Node(loc,s,l) -> - let fv = val_interp ist (Node(loc,"PRIMTACTIC",[Node(loc,s,[])])) - and largs = List.map (val_interp ist) l in - app_interp ist fv largs ast *) | TacDynamic(_,t) -> let tg = (tag t) in @@ -1282,10 +1247,10 @@ and letin_interp ist = function by t; let (_,({const_entry_body = pft; const_entry_type = _},_,_)) = cook_proof () in - delete_proof id; + delete_proof (dummy_loc,id); (id,VConstr (mkCast (pft,typ)))::(letin_interp ist tl) with | NotTactic -> - delete_proof id; + delete_proof (dummy_loc,id); errorlabstrm "Tacinterp.letin_interp" (str "Term or fully applied tactic expected in Let")) @@ -1329,7 +1294,7 @@ and letcut_interp ist = function by t; let (_,({const_entry_body = pft; const_entry_type = _},_,_)) = cook_proof () in - delete_proof id; + delete_proof (dummy_loc,id); let cutt = h_cut typ and exat = h_exact pft in tclTHENSV cutt [|tclTHEN (introduction id) @@ -1340,7 +1305,7 @@ and letcut_interp ist = function tclTHEN ntac (tclTHEN (introduction id) (letcut_interp ist tl))*) with | NotTactic -> - delete_proof id; + delete_proof (dummy_loc,id); errorlabstrm "Tacinterp.letcut_interp" (str "Term or fully applied tactic expected in Let"))) @@ -1478,8 +1443,12 @@ and genarg_interp ist x = in_gen wit_pre_ident (out_gen rawwit_pre_ident x) | IdentArgType -> in_gen wit_ident (ident_interp ist (out_gen rawwit_ident x)) - | QualidArgType -> - in_gen wit_qualid (qualid_interp ist (out_gen rawwit_qualid x)) + | RefArgType -> + in_gen wit_ref (reference_interp ist (out_gen rawwit_ref x)) + | SortArgType -> + in_gen wit_sort + (destSort + (constr_interp ist (CSort (dummy_loc,out_gen rawwit_sort x)))) | ConstrArgType -> in_gen wit_constr (constr_interp ist (out_gen rawwit_constr x)) | ConstrMayEvalArgType -> @@ -1692,17 +1661,17 @@ and interp_atomic ist = function | TacTransitivity c -> h_transitivity (constr_interp ist c) (* For extensions *) - | TacExtend (opn,l) -> vernac_tactic (opn,List.map (genarg_interp ist) l) + | TacExtend (loc,opn,l) -> vernac_tactic (opn,List.map (genarg_interp ist) l) | TacAlias (_,l,body) -> let f x = match genarg_tag x with | IdentArgType -> VIdentifier (ident_interp ist (out_gen rawwit_ident x)) - | QualidArgType -> VConstr (constr_of_reference (qualid_interp ist (out_gen rawwit_qualid x))) + | RefArgType -> VConstr (constr_of_reference (reference_interp ist (out_gen rawwit_ref x))) | ConstrArgType -> VConstr (constr_interp ist (out_gen rawwit_constr x)) | ConstrMayEvalArgType -> VConstr (constr_interp_may_eval ist (out_gen rawwit_constr_may_eval x)) | _ -> failwith "This generic type is not supported in alias" in - tactic_of_value (val_interp { ist with lfun=(List.map (fun (x,c) -> (id_of_string x,f c)) l)@ist.lfun } body) + tactic_of_value (val_interp { ist with lfun=(List.map (fun (x,c) -> (x,f c)) l)@ist.lfun } body) let _ = forward_vcontext_interp := vcontext_interp diff --git a/tactics/tacinterp.mli b/tactics/tacinterp.mli index c4017fc88..07ccf1d59 100644 --- a/tactics/tacinterp.mli +++ b/tactics/tacinterp.mli @@ -18,6 +18,7 @@ open Tactic_debug open Term open Tacexpr open Genarg +open Topconstr (*i*) (* Values for interpretation *) @@ -27,7 +28,7 @@ type value = | VFTactic of value list * (value list->tactic) | VRTactic of (goal list sigma * validation) | VContext of interp_sign * direction_flag - * (pattern_ast,raw_tactic_expr) match_rule list + * (pattern_expr,raw_tactic_expr) match_rule list | VFun of (identifier * value) list * identifier option list *raw_tactic_expr | VVoid | VInteger of int @@ -59,9 +60,6 @@ val tacticIn : (interp_sign -> raw_tactic_expr) -> raw_tactic_expr val tacticOut : raw_tactic_expr -> (interp_sign -> raw_tactic_expr) val valueIn : value -> raw_tactic_arg val valueOut: raw_tactic_arg -> value -val constrIn : constr -> Coqast.t -val constrOut : Coqast.t -> constr -val loc : Coqast.loc (* Sets the debugger mode *) val set_debug : debug_info -> unit @@ -97,7 +95,7 @@ val tac_interp : (identifier * value) list -> (int * constr) list -> debug_info -> raw_tactic_expr -> tactic (* Interprets constr expressions *) -val constr_interp : interp_sign -> constr_ast -> constr +val constr_interp : interp_sign -> constr_expr -> constr (* Initial call for interpretation *) val interp : raw_tactic_expr -> tactic diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 25ba260d4..7a2014ae1 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -224,8 +224,8 @@ let reduce redexp cl goal = (* Unfolding occurrences of a constant *) let unfold_constr = function - | ConstRef sp -> unfold_in_concl [[],Closure.EvalConstRef sp] - | VarRef id -> unfold_in_concl [[],Closure.EvalVarRef id] + | ConstRef sp -> unfold_in_concl [[],EvalConstRef sp] + | VarRef id -> unfold_in_concl [[],EvalVarRef id] | _ -> errorlabstrm "unfold_constr" (str "Cannot unfold a non-constant.") (*******************************************) @@ -481,7 +481,6 @@ let apply_with_bindings (c,lbind) gl = let apply c = apply_with_bindings (c,NoBindings) -let apply_com = tactic_com (fun c -> apply_with_bindings (c,NoBindings)) let apply_list = function | c::l -> apply_with_bindings (c,ImplicitBindings l) @@ -494,8 +493,6 @@ let apply_without_reduce c gl = let clause = mk_clenv_type_of wc c in res_pf kONT clause gl -let apply_without_reduce_com = tactic_com apply_without_reduce - let refinew_scheme kONT clause gl = res_pf kONT clause gl (* A useful resolution tactic which, if c:A->B, transforms |- C into @@ -750,7 +747,7 @@ let exact_no_check = refine let exact_proof c gl = (* on experimente la synthese d'ise dans exact *) - let c = Astterm.interp_casted_constr (project gl) (pf_env gl) c (pf_concl gl) + let c = Constrintern.interp_casted_constr (project gl) (pf_env gl) c (pf_concl gl) in refine c gl let (assumption : tactic) = fun gl -> @@ -1638,7 +1635,7 @@ let abstract_subproof name tac gls = let cd = Entries.DefinitionEntry const in let sp = Declare.declare_constant na (cd,IsProof Lemma) in let newenv = Global.env() in - Declare.constr_of_reference (ConstRef (snd sp)) + constr_of_reference (ConstRef (snd sp)) in exact_no_check (applist (lemme, diff --git a/tactics/tactics.mli b/tactics/tactics.mli index ce31a4dcc..2e35c1761 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -96,7 +96,7 @@ val try_intros_until : val assumption : tactic val exact_no_check : constr -> tactic val exact_check : constr -> tactic -val exact_proof : Coqast.t -> tactic +val exact_proof : Topconstr.constr_expr -> tactic (*s Reduction tactics. *) @@ -121,12 +121,11 @@ val simpl_option : hyp_location option -> tactic val normalise_in_concl: tactic val normalise_in_hyp : hyp_location -> tactic val normalise_option : hyp_location option -> tactic -val unfold_in_concl : (int list * Closure.evaluable_global_reference) list - -> tactic +val unfold_in_concl : (int list * evaluable_global_reference) list -> tactic val unfold_in_hyp : - (int list * Closure.evaluable_global_reference) list -> hyp_location -> tactic + (int list * evaluable_global_reference) list -> hyp_location -> tactic val unfold_option : - (int list * Closure.evaluable_global_reference) list -> hyp_location option + (int list * evaluable_global_reference) list -> hyp_location option -> tactic val reduce : red_expr -> hyp_location list -> tactic val change : constr -> hyp_location list -> tactic diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4 index dc28eb48c..7e6334bc9 100644 --- a/tactics/tauto.ml4 +++ b/tactics/tauto.ml4 @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(*i camlp4deps: "parsing/grammar.cma kernel/names.cmo parsing/ast.cmo parsing/g_tactic.cmo parsing/g_ltac.cmo parsing/g_constr.cmo" i*) +(*i camlp4deps: "parsing/grammar.cma" i*) (*i $Id$ i*) diff --git a/theories/Reals/Rsyntax.v b/theories/Reals/Rsyntax.v index 9022e4f7e..6cc0d71c4 100644 --- a/theories/Reals/Rsyntax.v +++ b/theories/Reals/Rsyntax.v @@ -59,9 +59,14 @@ with rexpr0 : constr := | expr_inv [ "/" rexpr0($c) ] -> [ (Rinv $c) ] | expr_meta [ meta($m) ] -> [ $m ] -with meta : ast := -| rimpl [ "?" ] -> [ (ISEVAR) ] -| rmeta [ "?" constr:numarg($n) ] -> [ (META $n) ] +with meta := +| rimpl [ "?" ] -> [ ? ] +| rmeta0 [ "?" "0" ] -> [ ?0 ] +| rmeta1 [ "?" "1" ] -> [ ?1 ] +| rmeta2 [ "?" "2" ] -> [ ?2 ] +| rmeta3 [ "?" "3" ] -> [ ?3 ] +| rmeta4 [ "?" "4" ] -> [ ?4 ] +| rmeta5 [ "?" "5" ] -> [ ?5 ] with rapplication : constr := apply [ rapplication($p) rexpr($c1) ] -> [ ($p $c1) ] diff --git a/tools/coq_makefile.ml4 b/tools/coq_makefile.ml4 index aec2f82f9..42fe0b0a1 100644 --- a/tools/coq_makefile.ml4 +++ b/tools/coq_makefile.ml4 @@ -191,8 +191,7 @@ let variables l = print "CAMLOPTLINK=ocamlopt\n"; print "COQDEP=$(COQBIN)coqdep -c\n"; print "COQVO2XML=coq_vo2xml\n"; - print "GRAMMARS=grammar.cma g_constr.cmo g_tactic.cmo g_ltac.cmo \\ - g_basevernac.cmo tacextend.cmo vernacextend.cmo\n"; + print "GRAMMARS=grammar.cma"; print "CAMLP4EXTEND=pa_extend.cmo pa_ifdef.cmo q_MLast.cmo\n"; print "PP=-pp \"camlp4o -I . -I $(COQTOP)/parsing $(CAMLP4EXTEND) $(GRAMMARS) -impl\"\n"; var_aux l; diff --git a/toplevel/cerrors.ml b/toplevel/cerrors.ml index 9d00e63f4..b2154c74d 100644 --- a/toplevel/cerrors.ml +++ b/toplevel/cerrors.ml @@ -88,7 +88,7 @@ let rec explain_exn_default = function hov 0 (str "Error: Fail tactic always fails (level " ++ int i ++ str").") | Stdpp.Exc_located (loc,exc) -> - hov 0 ((if loc = Ast.dummy_loc then (mt ()) + hov 0 ((if loc = dummy_loc then (mt ()) else (str"At location " ++ print_loc loc ++ str":" ++ fnl ())) ++ explain_exn_default exc) | Lexer.Error Illegal_character -> diff --git a/toplevel/cerrors.mli b/toplevel/cerrors.mli index 2207608a8..1703a072d 100644 --- a/toplevel/cerrors.mli +++ b/toplevel/cerrors.mli @@ -10,11 +10,12 @@ (*i*) open Pp +open Util (*i*) (* Error report. *) -val print_loc : Coqast.loc -> std_ppcmds +val print_loc : loc -> std_ppcmds val explain_exn : exn -> std_ppcmds diff --git a/toplevel/class.mli b/toplevel/class.mli index 671219c3c..8311be4a5 100644 --- a/toplevel/class.mli +++ b/toplevel/class.mli @@ -46,9 +46,9 @@ val try_add_new_coercion_with_source : global_reference -> strength -> val try_add_new_identity_coercion : identifier -> strength -> source:cl_typ -> target:cl_typ -> unit -val add_coercion_hook : Proof_type.declaration_hook +val add_coercion_hook : Tacexpr.declaration_hook -val add_subclass_hook : Proof_type.declaration_hook +val add_subclass_hook : Tacexpr.declaration_hook (* [try_add_new_class ref] declares [ref] as a new class; usually, this is done implicitely by [try_add_new_coercion]'s functions *) diff --git a/toplevel/command.ml b/toplevel/command.ml index e0f792a83..19842ea62 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -24,11 +24,10 @@ open Nametab open Names open Libnames open Nameops -open Coqast -open Ast +open Topconstr open Library open Libobject -open Astterm +open Constrintern open Proof_type open Tacmach open Safe_typing @@ -37,6 +36,7 @@ open Typeops open Indtypes open Vernacexpr open Decl_kinds +open Pretyping let mkLambdaCit = List.fold_right (fun (x,a) b -> mkLambdaC(x,a,b)) let mkProdCit = List.fold_right (fun (x,a) b -> mkProdC(x,a,b)) @@ -45,14 +45,14 @@ let rec abstract_rawconstr c = function | [] -> c | LocalRawDef (x,b)::bl -> mkLetInC(x,b,abstract_rawconstr c bl) | LocalRawAssum (idl,t)::bl -> - List.fold_right (fun x b -> mkLambdaC(x,t,b)) idl + List.fold_right (fun x b -> mkLambdaC([x],t,b)) idl (abstract_rawconstr c bl) let rec prod_rawconstr c = function | [] -> c | LocalRawDef (x,b)::bl -> mkLetInC(x,b,prod_rawconstr c bl) | LocalRawAssum (idl,t)::bl -> - List.fold_right (fun x b -> mkProdC(x,t,b)) idl + List.fold_right (fun x b -> mkProdC([x],t,b)) idl (prod_rawconstr c bl) let rec destSubCast c = match kind_of_term c with @@ -119,7 +119,8 @@ let declare_definition ident local bl red_option c typopt = declare_global_definition ident ce' local let syntax_definition ident c = - let c = interp_rawconstr Evd.empty (Global.env()) c in + let c = +interp_aconstr c in Syntax_def.declare_syntactic_definition ident c; if_verbose message ((string_of_id ident) ^ " is now a syntax macro") @@ -236,7 +237,7 @@ let declare_mutual_with_eliminations mie = Indrec.declare_eliminations kn; kn -let eq_la (id,ast) (id',ast') = id = id' & alpha_eq(ast,ast') +let eq_la (id,ast) (id',ast') = id = id' & (* alpha_eq(ast,ast') *) (warning "check paramaters convertibility"; true) let extract_coe lc = List.fold_right @@ -306,12 +307,14 @@ let collect_non_rec env = in searchrec [] -let build_recursive lnameargsardef = - let lrecnames = List.map (fun (f,_,_,_) -> f) lnameargsardef +let build_recursive lnameargsardef = + let lrecnames = List.map (fun (f,_,_,_) -> f) lnameargsardef and sigma = Evd.empty and env0 = Global.env() - and nv = Array.of_list (List.map (fun (_,la,_,_) -> (List.length la) -1) - lnameargsardef) + and nv = Array.of_list + (List.map + (fun (_,la,_,_) -> List.length (List.flatten (List.map fst la)) - 1) + lnameargsardef) in let fs = States.freeze() in let (rec_sign,arityl) = @@ -455,9 +458,9 @@ let build_scheme lnamedepindsort = let rec generalize_rawconstr c = function | [] -> c - | LocalRawDef (id,b)::bl -> Ast.mkLetInC(id,b,generalize_rawconstr c bl) + | LocalRawDef (id,b)::bl -> mkLetInC(id,b,generalize_rawconstr c bl) | LocalRawAssum (idl,t)::bl -> - List.fold_right (fun x b -> Ast.mkProdC(x,t,b)) idl + List.fold_right (fun x b -> mkProdC([x],t,b)) idl (generalize_rawconstr c bl) let rec binders_length = function @@ -465,10 +468,12 @@ let rec binders_length = function | LocalRawDef _::bl -> 1 + binders_length bl | LocalRawAssum (idl,_)::bl -> List.length idl + binders_length bl -let start_proof_com sopt kind (bl,t) hook = - let env = Global.env () in +let start_proof id kind c hook = let sign = Global.named_context () in let sign = clear_proofs sign in + Pfedit.start_proof id kind sign c hook + +let start_proof_com sopt kind (bl,t) hook = let id = match sopt with | Some id -> (* We check existence here: it's a bit late at Qed time *) @@ -479,9 +484,10 @@ let start_proof_com sopt kind (bl,t) hook = next_ident_away (id_of_string "Unnamed_thm") (Pfedit.get_all_proof_names ()) in + let env = Global.env () in let c = interp_type Evd.empty env (generalize_rawconstr t bl) in let _ = Typeops.infer_type env c in - Pfedit.start_proof id kind sign c hook + start_proof id kind c hook let apply_tac_not_declare id pft = function | None -> error "Type of Let missing" diff --git a/toplevel/command.mli b/toplevel/command.mli index 9b3d99619..791c33d66 100644 --- a/toplevel/command.mli +++ b/toplevel/command.mli @@ -17,7 +17,10 @@ open Declare open Library open Libnames open Nametab +open Tacexpr open Vernacexpr +open Rawterm +open Topconstr open Decl_kinds (*i*) @@ -27,31 +30,32 @@ open Decl_kinds defined object *) val declare_definition : identifier -> definition_kind -> - local_binder list -> Tacred.red_expr option -> Coqast.t -> Coqast.t option - -> global_reference + local_binder list -> Tacred.red_expr option -> constr_expr -> + constr_expr option -> global_reference -val syntax_definition : identifier -> Coqast.t -> unit +val syntax_definition : identifier -> constr_expr -> unit val declare_assumption : identifier -> assumption_kind -> - local_binder list -> Coqast.t -> global_reference + local_binder list -> constr_expr -> global_reference val build_mutual : inductive_expr list -> bool -> unit val declare_mutual_with_eliminations : Entries.mutual_inductive_entry -> mutual_inductive -val build_recursive : - (identifier * ((identifier * Coqast.t) list) * Coqast.t * Coqast.t) list - -> unit +val build_recursive : fixpoint_expr list -> unit -val build_corecursive : (identifier * Coqast.t * Coqast.t) list -> unit +val build_corecursive : cofixpoint_expr list -> unit -val build_scheme : (identifier * bool * qualid located * Coqast.t) list -> unit +val build_scheme : (identifier * bool * reference * rawsort) list -> unit -val generalize_rawconstr : Coqast.t -> local_binder list -> Coqast.t +val generalize_rawconstr : constr_expr -> local_binder list -> constr_expr + +val start_proof : identifier -> goal_kind -> constr -> + declaration_hook -> unit val start_proof_com : identifier option -> goal_kind -> - (local_binder list * Coqast.t) -> Proof_type.declaration_hook -> unit + (local_binder list * constr_expr) -> declaration_hook -> unit (*s [save_named b] saves the current completed proof under the name it was started; boolean [b] tells if the theorem is declared opaque; it diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml index 10d459dde..14f9de51d 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -11,37 +11,86 @@ open Pp open Util open Names +open Topconstr open Coqast open Ast +open Ppextend open Extend open Esyntax open Libobject open Library open Summary -open Astterm +open Constrintern open Vernacexpr open Pcoq +open Rawterm +open Libnames (************************* **** PRETTY-PRINTING **** *************************) -let globalize_typed_ast t = - let sign = Global.named_context () in - match t with - | Ast.PureAstNode t -> Ast.PureAstNode (globalize_constr t) - | _ -> (* TODO *) t - (* This updates default parsers for Grammar actions and Syntax *) (* patterns by inserting globalization *) (* Done here to get parsing/g_*.ml4 non dependent from kernel *) -let _ = Pcoq.set_globalizer globalize_typed_ast +let constr_to_ast a = + Termast.ast_of_rawconstr (interp_rawconstr Evd.empty (Global.env()) a) (* This installs default quotations parsers to escape the ast parser *) (* "constr" is used by default in quotations found in the ast parser *) -let constr_parser_with_glob = Pcoq.map_entry Astterm.globalize_constr Constr.constr - -let _ = define_quotation true "constr" constr_parser_with_glob +let constr_parser_with_glob = Pcoq.map_entry constr_to_ast Constr.constr + +let _ = define_ast_quotation true "constr" constr_parser_with_glob + +let add_name r = function + | Anonymous -> () + | Name id -> r := id :: !r + +let make_aconstr vars a = + let bound_vars = ref [] in + let bound_binders = ref [] in + let rec aux = function + | RVar (_,id) -> + if List.mem id vars then bound_vars := id::!bound_vars; + AVar id + | RApp (_,g,args) -> AApp (aux g, List.map aux args) + | RLambda (_,na,ty,c) -> add_name bound_binders na; ALambda (na,aux ty,aux c) + | RProd (_,na,ty,c) -> add_name bound_binders na; AProd (na,aux ty,aux c) + | RLetIn (_,na,b,c) -> add_name bound_binders na; ALetIn (na,aux b,aux c) + | ROrderedCase (_,b,tyopt,tm,bv) -> + AOldCase (b,option_app aux tyopt,aux tm, Array.map aux bv) + | RCast (_,c,t) -> ACast (aux c,aux t) + | RSort (_,s) -> ASort s + | RHole (_,w) -> AHole w + | RRef (_,r) -> ARef r + | RMeta (_,n) -> AMeta n + | RDynamic _ | RRec _ | RCases _ | REvar _ -> + error "Fixpoints, cofixpoints, existential variables and pattern-matching not \ +allowed in abbreviatable expressions" + in + let a = aux a in + let find_type x = + if List.mem x !bound_binders then (x,ETIdent) else + if List.mem x !bound_vars then (x,ETConstr) else + error ((string_of_id x)^" is unbound in the right-hand-side") in + let typs = List.map find_type vars in + (a, typs) + +let _ = set_ast_to_rawconstr + (fun etyps a -> + let vl = List.map fst etyps in + let r = + for_grammar (interp_rawconstr_gen Evd.empty (Global.env()) [] false vl) a + in + let a, typs = make_aconstr vl r in +(* + List.iter2 + (fun (x,typ) (x',typ') -> + assert (x=x'); + if typ = ETConstr & typ' = ETIdent then + error "cannot use a constr parser to parse an ident") etyps typs; +*) + a) (* Pretty-printer state summary *) let _ = @@ -75,9 +124,8 @@ let add_syntax_obj whatfor sel = Lib.add_anonymous_leaf (inPPSyntax (interp_syntax_entry whatfor sel)) -(************************ - ******* GRAMMAR ******** - ************************) +(**********************************************************************) +(* Grammar *) let _ = declare_summary "GRAMMAR_LEXER" @@ -112,21 +160,17 @@ let (inGrammar, outGrammar) = classify_function = (fun (_,o) -> Substitute o); export_function = (fun x -> Some x)} -let gram_define_entry (u,_ as univ) ((ntl,nt),et,assoc,rl) = - let etyp = match et with None -> entry_type_from_name u | Some e -> e in - create_entry_if_new univ nt etyp; - let etyp = match etyp with - | AstListType -> ETastl - | GenAstType Genarg.ConstrArgType -> ETast - | PureAstType -> ETast - | _ -> error "Cannot arbitrarily extend non ast entries" in - (nt, etyp, assoc, rl) +open Genarg +let gram_define_entry (u,_ as univ) (nt,et,assoc,rl) = + if u = "tactic" or u = "vernac" then error "tactic and vernac not supported"; + create_entry_if_new univ nt (entry_type_of_constr_entry_type et); + (nt, et, assoc, rl) let add_grammar_obj univ l = let u = create_univ_if_new univ in let entryl = List.map (gram_define_entry u) l in let g = interp_grammar_command univ get_entry_type entryl in - Lib.add_anonymous_leaf (inGrammar (Egrammar.AstGrammar g)) + Lib.add_anonymous_leaf (inGrammar (Egrammar.Grammar g)) let add_tactic_grammar g = Lib.add_anonymous_leaf (inGrammar (Egrammar.TacticGrammar g)) @@ -156,80 +200,41 @@ let split str = in loop 0 0 - -(* A notation comes with a grammar rule, a pretty-printing rule, an - identifiying pattern called notation and an associated scope *) -let load_infix _ (_,(gr,se,prec,ntn,scope,pat)) = - Symbols.declare_scope scope - -let open_infix i (_,(gr,se,prec,ntn,scope,pat)) = - if i=1 then begin - let b = Symbols.exists_notation_in_scope scope prec ntn pat in - (* Declare the printer rule and its interpretation *) - if not b then Esyntax.add_ppobject {sc_univ="constr";sc_entries=se}; - (* Declare the grammar rule ... *) - if not (Symbols.exists_notation prec ntn) then Egrammar.extend_grammar gr; - (* ... and its interpretation *) - if not b then Symbols.declare_notation prec ntn pat scope - end - -let cache_infix o = - load_infix 1 o; - open_infix 1 o - -let subst_infix (_,subst,(gr,se,prec,ntn,scope,pat)) = - (Egrammar.subst_all_grammar_command subst gr, - list_smartmap (Extend.subst_syntax_entry Ast.subst_astpat subst) se, - prec,ntn, - scope, - Rawterm.subst_raw subst pat) - -let (inInfix, outInfix) = - declare_object {(default_object "INFIX") with - open_function = open_infix; - cache_function = cache_infix; - subst_function = subst_infix; - load_function = load_infix; - classify_function = (fun (_,o) -> Substitute o); - export_function = (fun x -> Some x)} - (* Build the syntax and grammar rules *) type symbol = | Terminal of string - | NonTerminal of (int * parenRelation) * string + | NonTerminal of (int * parenRelation) * identifier let prec_assoc = function | Some(Gramext.RightA) -> (L,E) | Some(Gramext.LeftA) -> (E,L) | Some(Gramext.NonA) -> (L,L) - | None -> (E,L) (* LEFTA by default *) + | None -> (L,L) (* NONA by default *) let constr_tab = [| "constr0"; "constr1"; "constr2"; "constr3"; "lassoc_constr4"; - "constr5"; "constr6"; "constr7"; "constr8"; "constr9"; "lconstr"; + "constr5"; "constr6"; "constr7"; "constr"; "constr9"; "lconstr"; "pattern" |] let level_rule (n,p) = if p = E then n else max (n-1) 0 let constr_rule np = constr_tab.(level_rule np) -let nonterm_meta nt var = - NonTerm(ProdPrimitive ("constr",nt), Some (var,ETast)) +let nonterm_meta nt var x = + match x with + | ETIdent -> NonTerm(ProdPrimitive ("constr","ident"), Some (var,x)) + | ETConstr -> NonTerm(ProdPrimitive ("constr",nt), Some (var,x)) + | ETReference -> NonTerm(ProdPrimitive ("constr","global"), Some (var,x)) +(* For old ast printer *) let meta_pattern m = Pmeta(m,Tany) -let collect_metas sl = - List.fold_right - (fun it metatl -> match it with - | NonTerminal (_,m) -> Pcons(meta_pattern m, metatl) - | _ -> metatl) - sl Pnil - -let make_hunks symbols = +(* For old ast printer *) +let make_hunks_ast symbols = List.fold_right (fun it l -> match it with - | NonTerminal ((_,lp),m) -> PH (meta_pattern m, None, lp) :: l + | NonTerminal ((_,lp),m) -> PH (meta_pattern (string_of_id m), None, lp) :: l | Terminal s -> let n,s = if is_letter (s.[String.length s -1]) or is_letter (s.[0]) @@ -238,6 +243,32 @@ let make_hunks symbols = UNP_BRK (n, 1) :: RO s :: l) symbols [] +open Symbols + +type white_status = NextMaybeLetter | NextIsNotLetter | AddBrk of int + +let make_hunks symbols = + let (_,l) = + List.fold_right + (fun it (ws,l) -> match it with + | NonTerminal (prec,m) -> + let u = UnpMetaVar (m,prec) in + let l' = match ws with + | AddBrk n -> UnpCut (PpBrk(n,1)) :: u :: l + | _ -> u :: l in + (NextMaybeLetter, l') + | Terminal s -> + let n = if is_letter (s.[0]) then 1 else 0 in + let s = + if (ws = NextMaybeLetter or ws = AddBrk 1) + & is_letter (s.[String.length s -1]) + then s^" " + else s + in + (AddBrk n, UnpTerminal s :: l)) + symbols (NextMaybeLetter,[]) + in l + let string_of_prec (n,p) = (string_of_int n)^(match p with E -> "E" | L -> "L" | _ -> "") @@ -246,7 +277,7 @@ let string_of_symbol = function | Terminal s -> s let assoc_of_symbol s l = match s with - | NonTerminal (lp,_) -> (level_rule lp,0,0) :: l + | NonTerminal (lp,_) -> level_rule lp :: l | Terminal _ -> l let string_of_assoc = function @@ -255,30 +286,17 @@ let string_of_assoc = function | Some(Gramext.NonA) -> "NONA" let make_symbolic assoc n symbols = - ((n,0,0), List.fold_right assoc_of_symbol symbols []), + (n, List.fold_right assoc_of_symbol symbols []), (String.concat " " (List.map string_of_symbol symbols)) -let make_production = +let make_production typs = List.map (function - | NonTerminal (lp,m) -> nonterm_meta (constr_rule lp) m - | Terminal s -> Term ("",s)) - -let make_constr_grammar_rule n fname prod action = - Egrammar.AstGrammar - { gc_univ = "constr"; - gc_entries = - [ { ge_name = constr_rule (n, E); - ge_type = ETast; - gl_assoc = None; - gl_rules = - [ { gr_name = fname; - gr_production = prod; - gr_action = action} ] - } - ] - } + | NonTerminal (lp,m) -> nonterm_meta (constr_rule lp) m (List.assoc m typs) + | Terminal s -> Term (Extend.terminal s)) +(* let create_meta n = "$e"^(string_of_int n) +*) let strip s = let n = String.length s in @@ -286,20 +304,18 @@ let strip s = let is_symbol s = not (is_letter s.[0]) -let rec find_symbols c_first c_next c_last vars new_var varprecl = function +let rec find_symbols c_first c_next c_last vars varprecl = function | [] -> (vars, []) | x::sl when is_letter x.[0] -> let id = Names.id_of_string x in - if List.mem_assoc id vars then - error ("Variable "^x^" occurs more than once"); + if List.mem id vars then error ("Variable "^x^" occurs more than once"); let prec = try (List.assoc x varprecl,E) with Not_found -> if List.exists is_symbol sl then c_first else c_last in let (vars,l) = - find_symbols c_next c_next c_last vars (new_var+1) varprecl sl in - let meta = create_meta new_var in - ((id,ope ("META",[num new_var]))::vars, NonTerminal (prec, meta) :: l) + find_symbols c_next c_next c_last vars varprecl sl in + (id::vars, NonTerminal (prec,id) :: l) (* | "_"::sl -> warning "Found '_'"; @@ -310,18 +326,14 @@ let rec find_symbols c_first c_next c_last vars new_var varprecl = function (vars, NonTerminal (prec, meta) :: l) *) | s :: sl -> - let (vars,l) = - find_symbols c_next c_next c_last vars new_var varprecl sl in + let (vars,l) = find_symbols c_next c_next c_last vars varprecl sl in (vars, Terminal (strip s) :: l) -let make_grammar_pattern symbols ntn = - Pnode("NOTATION",Pcons(Pquote (Str (dummy_loc,ntn)), collect_metas symbols)) - -let make_grammar_rule n symbols ntn = - let prod = make_production symbols in - let action = Act (PureAstPat (make_grammar_pattern symbols ntn)) in - make_constr_grammar_rule n ("notation "^ntn) prod action +let make_grammar_rule n typs symbols ntn = + let prod = make_production typs symbols in + ((if n=8 then "constr8" else constr_rule (n,E)),ntn,prod) +(* For old ast printer *) let metas_of sl = List.fold_right (fun it metatl -> match it with @@ -329,73 +341,162 @@ let metas_of sl = | _ -> metatl) sl [] +(* For old ast printer *) let make_pattern symbols ast = - let env = List.map (fun m -> (m,ETast)) (metas_of symbols) in + let env = List.map (fun m -> (string_of_id m,ETast)) (metas_of symbols) in fst (to_pat env ast) +(* For old ast printer *) let make_syntax_rule n name symbols ast ntn sc = [{syn_id = name; - syn_prec = (n,0,0); + syn_prec = n; syn_astpat = make_pattern symbols ast; - syn_hunks = [UNP_SYMBOLIC(sc,ntn,UNP_BOX (PpHOVB 1, make_hunks symbols))]}] - -let subst_meta_ast subst a = - let found = ref [] in - let loc = dummy_loc in - let rec subst_rec subst = function - | Smetalam (_,s,body) -> Smetalam (loc,s,subst_rec subst body) - | Node(_,"META",_) -> error "Unexpected metavariable in notation" - | Node(_,"QUALID",[Nvar(_,id)]) as x -> - (try let a = List.assoc id subst in found:=id::!found; a - with Not_found -> x) - | Node(_,op,args) -> Node (loc,op, List.map (subst_rec subst) args) - | Slam(_,None,body) -> Slam(loc,None,subst_rec subst body) - | Slam(_,Some s,body) -> - (* Prévenir que "s" peut forcer une capturer à l'instantiation de la *) - (* règle de grammaire ?? *) - Slam(loc,Some s,subst_rec (List.remove_assoc s subst) body) - | Nmeta _ | Id _ | Nvar _ | Str _ | Num _ | Path _ as a -> set_loc loc a - | Dynamic _ as a -> (* Hum... what to do here *) a - in - let a = subst_rec subst a in - let l = List.filter (fun (x,_) -> not (List.mem x !found)) subst in - if l <> [] then - (let x = string_of_id (fst (List.hd l)) in - error (x^" is unbound in the right-hand-side")); - a - -let rec reify_meta_ast = function - | Smetalam (loc,s,body) -> Smetalam (loc,s,reify_meta_ast body) - | Node(loc,"META",[Num (_,n)]) -> Nmeta (loc,create_meta n) + syn_hunks = [UNP_SYMBOLIC(sc,ntn,UNP_BOX (PpHOVB 1, make_hunks_ast symbols))]}] + +let make_pp_rule symbols = + [UnpBox (PpHOVB 1, make_hunks symbols)] + + +(**************************************************************************) +(* Syntax extenstion: common parsing/printing rules and no interpretation *) + +let cache_syntax_extension (_,(prec,ntn,gr,se)) = + if not (Symbols.exists_notation prec ntn) then begin + Egrammar.extend_grammar (Egrammar.Notation gr); + Symbols.declare_printing_rule ntn (se,fst prec) + end + +let subst_notation_grammar subst x = x + +let subst_printing_rule subst x = x + +let subst_syntax_extension (_,subst,(prec,ntn,gr,se)) = + (prec,ntn,subst_notation_grammar subst gr,subst_printing_rule subst se) + +let (inSyntaxExtension, outSyntaxExtension) = + declare_object {(default_object "SYNTAX-EXTENSION") with + open_function = (fun i o -> if i=1 then cache_syntax_extension o); + cache_function = cache_syntax_extension; + subst_function = subst_syntax_extension; + classify_function = (fun (_,o) -> Substitute o); + export_function = (fun x -> Some x)} + +let interp_syntax_modifiers = + let rec interp assoc precl level etyps = function + | [] -> + let n = match level with None -> 1 | Some n -> n in + (assoc,precl,n,etyps) + | SetItemLevel (id,n) :: l -> + if List.mem_assoc id precl then error (id^"has already a precedence") + else interp assoc ((id,n)::precl) level etyps l + | SetLevel n :: l -> + if level <> None then error "already a level" + else interp assoc precl (Some n) etyps l + | SetAssoc a :: l -> + if assoc <> None then error "already an associativity" + else interp (Some a) precl level etyps l + | SetEntryType (s,typ) :: l -> + let id = id_of_string s in + if List.mem_assoc id etyps then error (s^"has already an entry type") + else interp assoc precl level ((id,typ)::etyps) l + in interp None [] None [] + +let add_syntax_extension df modifiers = + let (assoc,varprecl,n,etyps) = interp_syntax_modifiers modifiers in + let (lp,rp) = prec_assoc assoc in + let (ids,symbs) = find_symbols (n,lp) (10,E) (n,rp) [] varprecl (split df) in + let (prec,notation) = make_symbolic assoc n symbs in + let gram_rule = make_grammar_rule n etyps symbs notation in + let pp_rule = make_pp_rule symbs in + Lib.add_anonymous_leaf (inSyntaxExtension(prec,notation,gram_rule,pp_rule)) + +(**********************************************************************) +(* Distfix, Infix, Notations *) + +(* A notation comes with a grammar rule, a pretty-printing rule, an + identifiying pattern called notation and an associated scope *) +let load_infix _ (_,(gr,_,se,prec,ntn,scope,pat)) = + Symbols.declare_scope scope + +let open_infix i (_,(gr,oldse,se,prec,ntn,scope,pat)) = + if i=1 then begin + let b = Symbols.exists_notation_in_scope scope prec ntn pat in + (* Declare the printer rule and its interpretation *) + if not b then Esyntax.add_ppobject {sc_univ="constr";sc_entries=oldse}; + (* Declare the grammar and printing rules ... *) + if not (Symbols.exists_notation prec ntn) then begin + Egrammar.extend_grammar (Egrammar.Notation gr); + Symbols.declare_printing_rule ntn (se,fst prec) + end; + (* ... and their interpretation *) + if not b then + Symbols.declare_notation ntn scope (pat,prec); + end + +let cache_infix o = + load_infix 1 o; + open_infix 1 o + +let subst_infix (_,subst,(gr,oldse,se,prec,ntn,scope,pat)) = + (subst_notation_grammar subst gr, + list_smartmap (Extend.subst_syntax_entry Ast.subst_astpat subst) oldse, + subst_printing_rule subst se, + prec,ntn, + scope, + subst_aconstr subst pat) + +let (inInfix, outInfix) = + declare_object {(default_object "INFIX") with + open_function = open_infix; + cache_function = cache_infix; + subst_function = subst_infix; + load_function = load_infix; + classify_function = (fun (_,o) -> Substitute o); + export_function = (fun x -> Some x)} + +(* For old ast printer *) +let rec reify_meta_ast vars = function + | Smetalam (loc,s,body) -> Smetalam (loc,s,reify_meta_ast vars body) +(* | Node(loc,"META",[Num (_,n)]) -> Nmeta (loc,create_meta n)*) | Node(loc,"ISEVAR",[]) -> Nmeta (loc,"$_") - | Node(loc,op,args) -> Node (loc,op, List.map (reify_meta_ast) args) - | Slam(loc,na,body) -> Slam(loc,na,reify_meta_ast body) + | Node(loc,op,args) -> Node (loc,op, List.map (reify_meta_ast vars) args) + | Slam(loc,Some id,body) when List.mem id vars -> + Smetalam (loc,string_of_id id,reify_meta_ast vars body) + | Slam(loc,na,body) -> Slam(loc,na,reify_meta_ast vars body) + | Nvar (loc,id) when List.mem id vars -> Nmeta (loc,string_of_id id) | Nmeta _ | Id _ | Nvar _ | Str _ | Num _ | Path _ as a -> a | Dynamic _ as a -> (* Hum... what to do here *) a -(* Distfix, Infix, Notations *) +(* For old ast syntax *) +let make_old_pp_rule n symbols r ntn scope vars = + let ast = Termast.ast_of_rawconstr r in + let ast = reify_meta_ast vars ast in + let rule_name = ntn^"_"^scope^"_notation" in + make_syntax_rule n rule_name symbols ast ntn scope -let add_notation assoc n df ast varprecl sc = +let add_notation df ast modifiers sc = + let (assoc,varprecl,n,_) = interp_syntax_modifiers modifiers in let scope = match sc with None -> Symbols.default_scope | Some sc -> sc in let (lp,rp) = prec_assoc assoc in - let (subst,symbols) = - find_symbols (n,lp) (10,E) (n,rp) [] 1 varprecl (split df) in + let (vars,symbols) = + find_symbols (n,lp) (10,E) (n,rp) [] varprecl (split df) in let (prec,notation) = make_symbolic assoc n symbols in - let rule_name = notation^"_"^scope^"_notation" in (* To globalize... *) - let vars = List.map fst subst in - let ast = subst_meta_ast subst ast in let r = interp_rawconstr_gen Evd.empty (Global.env()) [] false vars ast in - let ast = Termast.ast_of_rawconstr r in - let ast = reify_meta_ast ast in - let gram_rule = make_grammar_rule n symbols notation in - let syntax_rule = make_syntax_rule n rule_name symbols ast notation scope in - Lib.add_anonymous_leaf - (inInfix(gram_rule,syntax_rule,prec,notation,scope,r)) + let a,typs = make_aconstr vars r in + let typs = + List.map (fun (x,t) -> + (x,if List.mem_assoc (string_of_id x) varprecl then ETConstr else t)) + typs + in + let gram_rule = make_grammar_rule n typs symbols notation in + let pp_rule = make_pp_rule symbols in + let old_pp_rule = make_old_pp_rule n symbols r notation scope vars in + Lib.add_anonymous_leaf (inInfix(gram_rule,old_pp_rule,pp_rule,prec,notation,scope,a)) (* TODO add boxes information in the expression *) -let inject_var x = ope ("QUALID", [nvar (id_of_string x)]) +let inject_var x = CRef (Ident (dummy_loc, id_of_string x)) (* To protect alphabetic tokens from being seen as variables *) let quote x = "\'"^x^"\'" @@ -410,15 +511,16 @@ let rec rename x vars n = function | y::l -> let (vars,l) = rename x vars n l in (vars,(quote y)::l) -let add_distfix assoc n df astf sc = +let add_distfix assoc n df r sc = (* "x" cannot clash since ast is globalized (included section vars) *) let (vars,l) = rename "x" [] 1 (split df) in let df = String.concat " " l in - let ast = ope("APPLIST",astf::vars) in - add_notation assoc n df ast [] sc + let ast = mkAppC (mkRefC r, vars) in + let a = match assoc with None -> Gramext.LeftA | Some a -> a in + add_notation df ast [SetAssoc a;SetLevel n] sc -let add_infix assoc n inf qid sc = - let pr = Astterm.globalize_qualid qid in +let add_infix assoc n inf pr sc = +(* let pr = Astterm.globalize_qualid pr in*) (* check the precedence *) if n<1 or n>10 then errorlabstrm "Metasyntax.infix_grammar_entry" @@ -428,9 +530,10 @@ let add_infix assoc n inf qid sc = errorlabstrm "Vernacentries.infix_grammar_entry" (str"Associativity Precedence must be 6,7,8 or 9."); *) - let metas = [inject_var "x"; inject_var "y"] in - let ast = ope("APPLIST",pr::metas) in - add_notation assoc n ("x "^(quote inf)^" y") ast [] sc + let metas = [inject_var "x"; inject_var "y"] in + let ast = mkAppC (mkRefC pr,metas) in + let a = match assoc with None -> Gramext.LeftA | Some a -> a in + add_notation ("x "^(quote inf)^" y") ast [SetAssoc a;SetLevel n] sc (* Delimiters *) let load_delimiters _ (_,(_,_,scope,dlm)) = @@ -438,9 +541,10 @@ let load_delimiters _ (_,(_,_,scope,dlm)) = let open_delimiters i (_,(gram_rule,pat_gram_rule,scope,dlm)) = if i=1 then begin - Egrammar.extend_grammar gram_rule; (* For parsing terms *) - Egrammar.extend_grammar pat_gram_rule; (* For parsing patterns *) - Symbols.declare_delimiters scope dlm (* For printing *) + (* For parsing *) + Egrammar.extend_grammar (Egrammar.Delimiters (scope,gram_rule,pat_gram_rule)); + (* For printing *) + Symbols.declare_delimiters scope dlm end let cache_delimiters o = @@ -454,18 +558,13 @@ let (inDelim,outDelim) = load_function = load_delimiters; export_function = (fun x -> Some x) } -let make_delimiter_rule (l,r as dlms) scope inlevel outlevel dlmname fname = - let symbols = [Terminal l; NonTerminal ((inlevel,E),"$e"); Terminal r] in - let prod = make_production symbols in - let args = Pcons(Pquote (string scope), Pcons (Pmeta ("$e",Tany), Pnil)) in - let action = Act (PureAstPat (Pnode(dlmname,args))) in - make_constr_grammar_rule outlevel fname prod action +let make_delimiter_rule (l,r) inlevel = + let e = Nameops.make_ident "e" None in + let symbols = [Terminal l; NonTerminal ((inlevel,E),e); Terminal r] in + make_production [e,ETConstr] symbols let add_delimiters scope (l,r as dlms) = if l = "" or r = "" then error "Delimiters cannot be empty"; - let fname = scope^"_delimiters" in - let gram_rule = make_delimiter_rule dlms scope 8 0 "DELIMITERS" fname in - let pfname = scope^"_patdelimiters" in - let pat_gram_rule = (* 11 is for "pattern" *) - make_delimiter_rule dlms scope 11 11 "PATTDELIMITERS" pfname in + let gram_rule = make_delimiter_rule dlms 0 (* constr0 *) in + let pat_gram_rule = make_delimiter_rule dlms 11 (* "pattern" *) in Lib.add_anonymous_leaf (inDelim(gram_rule,pat_gram_rule,scope,dlms)) diff --git a/toplevel/metasyntax.mli b/toplevel/metasyntax.mli index 1b667918a..fbbe4a94e 100644 --- a/toplevel/metasyntax.mli +++ b/toplevel/metasyntax.mli @@ -11,32 +11,35 @@ (*i*) open Util open Libnames +open Ppextend open Extend open Tacexpr open Vernacexpr open Symbols +open Topconstr (*i*) (* Adding grammar and pretty-printing objects in the environment *) -val add_syntax_obj : string -> syntax_entry_ast list -> unit +val add_syntax_obj : string -> raw_syntax_entry list -> unit -val add_grammar_obj : string -> grammar_entry_ast list -> unit +val add_grammar_obj : string -> raw_grammar_entry list -> unit val add_token_obj : string -> unit val add_tactic_grammar : (string * (string * grammar_production list) * raw_tactic_expr) list -> unit val add_infix : - Gramext.g_assoc option -> precedence -> string -> qualid located + grammar_associativity -> precedence -> string -> reference -> scope_name option -> unit val add_distfix : - Gramext.g_assoc option -> precedence -> string -> Coqast.t + grammar_associativity -> precedence -> string -> reference -> scope_name option -> unit val add_delimiters : scope_name -> delimiters -> unit -val add_notation : - Gramext.g_assoc option -> precedence -> string -> Coqast.t - -> (string * precedence) list -> scope_name option -> unit +val add_notation : string -> constr_expr + -> syntax_modifier list -> scope_name option -> unit + +val add_syntax_extension : string -> syntax_modifier list -> unit val print_grammar : string -> string -> unit diff --git a/toplevel/record.ml b/toplevel/record.ml index 909cef6d0..7e0286b21 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -21,23 +21,17 @@ open Entries open Declare open Nametab open Coqast -open Astterm +open Constrintern open Command open Inductive open Safe_typing open Decl_kinds open Indtypes open Type_errors +open Topconstr (********** definition d'un record (structure) **************) -let occur_fields id fs = - List.exists - (function - | Vernacexpr.AssumExpr (_,a) -> Ast.occur_var_ast id a - | Vernacexpr.DefExpr (_,a,_) -> Ast.occur_var_ast id a) - fs - let name_of id = if id = wildcard then Anonymous else Name id let interp_decl sigma env = function @@ -45,7 +39,7 @@ let interp_decl sigma env = function | Vernacexpr.DefExpr(id,c,t) -> let c = match t with | None -> c - | Some t -> Ast.ope("CAST",[c; t]) + | Some t -> mkCastC (c,t) in let j = judgment_of_rawconstr Evd.empty env c in (Name id,Some j.uj_val, j.uj_type) @@ -166,7 +160,7 @@ let declare_projections indsp coers fields = let p = mkLambda (x, lift 1 rp, ccl') in let branch = it_mkLambda_or_LetIn (mkRel nfi) lifted_fields in let ci = Inductiveops.make_case_info env indsp - (Some PrintLet) [| RegularPat |] in + LetStyle [| RegularPat |] in mkCase (ci, p, mkRel 1, [|branch|]) in let proj = it_mkLambda_or_LetIn (mkLambda (x,rp,body)) paramdecls in diff --git a/toplevel/record.mli b/toplevel/record.mli index 90b40020e..ddee8f1d8 100644 --- a/toplevel/record.mli +++ b/toplevel/record.mli @@ -13,6 +13,7 @@ open Names open Term open Sign open Vernacexpr +open Topconstr (*i*) (* [declare_projections ref coers params fields] declare projections of @@ -23,5 +24,5 @@ val declare_projections : inductive -> bool list -> rel_context -> constant option list val definition_structure : - identifier with_coercion * (identifier * Genarg.constr_ast) list * + identifier with_coercion * (identifier * constr_expr) list * (local_decl_expr with_coercion) list * identifier * sorts -> unit diff --git a/toplevel/recordobj.mli b/toplevel/recordobj.mli index 71dbc6816..2879e37d4 100755 --- a/toplevel/recordobj.mli +++ b/toplevel/recordobj.mli @@ -9,4 +9,4 @@ (* $Id$ *) val objdef_declare : Libnames.global_reference -> unit -val add_object_hook : Proof_type.declaration_hook +val add_object_hook : Tacexpr.declaration_hook diff --git a/toplevel/toplevel.ml b/toplevel/toplevel.ml index 589bc9ad6..adc2328ab 100644 --- a/toplevel/toplevel.ml +++ b/toplevel/toplevel.ml @@ -132,7 +132,7 @@ let print_highlight_location ib (bp,ep) = let print_location_in_file s fname (bp,ep) = let errstrm = (str"Error while reading " ++ str s ++ str" :" ++ fnl () ++ str"File " ++ str ("\""^fname^"\"")) in - if (bp,ep) = Ast.dummy_loc then + if (bp,ep) = dummy_loc then (errstrm ++ str", unknown location." ++ fnl ()) else let ic = open_in fname in @@ -158,7 +158,7 @@ let print_command_location ib dloc = | None -> (mt ()) let valid_loc dloc (b,e) = - (b,e) <> Ast.dummy_loc + (b,e) <> dummy_loc & match dloc with | Some (bd,ed) -> bd<=b & e<=ed | _ -> true @@ -208,7 +208,7 @@ let print_toplevel_error exc = let (dloc,exc) = match exc with | DuringCommandInterp (loc,ie) -> - if loc = Ast.dummy_loc then (None,ie) else (Some loc, ie) + if loc = dummy_loc then (None,ie) else (Some loc, ie) | _ -> (None, exc) in let (locstrm,exc) = diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index 937d05a22..4ad2c479a 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -22,12 +22,12 @@ open Vernacinterp Use the module Coqtoplevel, which catches these exceptions (the exceptions are explained only at the toplevel). *) -exception DuringCommandInterp of Coqast.loc * exn +exception DuringCommandInterp of Util.loc * exn (* Like Exc_located, but specifies the outermost file read, the filename associated to the location of the error, and the error itself. *) -exception Error_in_file of string * (string * Coqast.loc) * exn +exception Error_in_file of string * (string * Util.loc) * exn (* Specifies which file is read. The intermediate file names are discarded here. The Drop exception becomes an error. We forget @@ -37,13 +37,13 @@ let raise_with_file file exc = let (cmdloc,re) = match exc with | DuringCommandInterp(loc,e) -> (loc,e) - | e -> (Ast.dummy_loc,e) + | e -> (dummy_loc,e) in let (inner,inex) = match re with - | Error_in_file (_, (f,loc), e) when loc <> Ast.dummy_loc -> + | Error_in_file (_, (f,loc), e) when loc <> dummy_loc -> ((f, loc), e) - | Stdpp.Exc_located (loc, e) when loc <> Ast.dummy_loc -> + | Stdpp.Exc_located (loc, e) when loc <> dummy_loc -> ((file, loc), e) | _ -> ((file,cmdloc), re) in diff --git a/toplevel/vernac.mli b/toplevel/vernac.mli index ad89461f2..5d53dab2a 100644 --- a/toplevel/vernac.mli +++ b/toplevel/vernac.mli @@ -13,18 +13,18 @@ (* Like [Exc_located], but specifies the outermost file read, the input buffer associated to the location of the error, and the error itself. *) -exception Error_in_file of string * (string * Coqast.loc) * exn +exception Error_in_file of string * (string * Util.loc) * exn (* Read a vernac command on the specified input (parse only). Raises [End_of_file] if EOF (or Ctrl-D) is reached. *) val parse_phrase : Pcoq.Gram.parsable * in_channel option -> - Coqast.loc * Vernacexpr.vernac_expr + Util.loc * Vernacexpr.vernac_expr (* Reads and executes vernac commands from a stream. The boolean [just_parsing] disables interpretation of commands. *) -exception DuringCommandInterp of Coqast.loc * exn +exception DuringCommandInterp of Util.loc * exn exception End_of_input val just_parsing : bool ref diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 3b899d889..0506dd2da 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -20,17 +20,18 @@ open Term open Pfedit open Tacmach open Proof_trees -open Astterm +open Constrintern open Prettyp open Printer open Tacinterp open Command open Goptions -(*open Declare*) open Libnames open Nametab open Vernacexpr open Decl_kinds +open Topconstr +open Pretyping (* Pcoq hooks *) @@ -39,9 +40,9 @@ type pcoq_hook = { solve : int -> unit; abort : string -> unit; search : searchable -> dir_path list * bool -> unit; - print_name : qualid located -> unit; + print_name : reference -> unit; print_check : Environ.unsafe_judgment -> unit; - print_eval : (constr -> constr) -> Environ.env -> Coqast.t -> Environ.unsafe_judgment -> unit; + print_eval : (constr -> constr) -> Environ.env -> constr_expr -> Environ.unsafe_judgment -> unit; show_goal : int option -> unit } @@ -175,14 +176,16 @@ let print_modules () = pr_vertical_list pr_dirpath only_loaded -let print_module (loc,qid) = +let print_module r = + let (loc,qid) = qualid_of_reference r in try let mp = Nametab.locate_module qid in msgnl (Printmod.print_module true mp) with Not_found -> msgnl (str"Unknown Module " ++ pr_qualid qid) -let print_modtype (loc,qid) = +let print_modtype r = + let (loc,qid) = qualid_of_reference r in try let kn = Nametab.locate_modtype qid in msgnl (Printmod.print_modtype kn) @@ -211,7 +214,8 @@ let locate_file f = msgnl (hov 0 (str"Can't find file" ++ spc () ++ str f ++ spc () ++ str"on loadpath")) -let print_located_qualid (_,qid) = +let print_located_qualid r = + let (loc,qid) = qualid_of_reference r in let msg = try let ref = Nametab.locate qid in @@ -274,7 +278,8 @@ let msg_notfound_library loc qid = function (str"Unable to locate library" ++ spc () ++ pr_qualid qid)) | e -> assert false -let print_located_library (loc,qid) = +let print_located_library r = + let (loc,qid) = qualid_of_reference r in try msg_found_library (Library.locate_qualified_library qid) with e -> msg_notfound_library loc qid e @@ -286,6 +291,8 @@ let vernac_syntax = Metasyntax.add_syntax_obj let vernac_grammar = Metasyntax.add_grammar_obj +let vernac_syntax_extension = Metasyntax.add_syntax_extension + let vernac_delimiters = Metasyntax.add_delimiters let vernac_open_scope = Symbols.open_scope @@ -293,20 +300,9 @@ let vernac_open_scope = Symbols.open_scope let vernac_arguments_scope qid scl = Symbols.declare_arguments_scope (global qid) scl -let vernac_infix assoc n inf qid sc = - let sp = sp_of_global None (global qid) in - let dir = repr_dirpath (dirpath sp) in -(* - if dir <> [] then begin - let modname = List.hd dir in - let long_inf = (string_of_id modname) ^ "." ^ inf in - Metasyntax.add_infix assoc n long_inf qid - end; -*) - Metasyntax.add_infix assoc n inf qid sc +let vernac_infix = Metasyntax.add_infix -let vernac_distfix assoc n inf qid sc = - Metasyntax.add_distfix assoc n inf (Astterm.globalize_qualid qid) sc +let vernac_distfix = Metasyntax.add_distfix let vernac_notation = Metasyntax.add_notation @@ -392,15 +388,16 @@ let vernac_declare_module id binders_ast mty_ast_o mexpr_ast_o = match Lib.is_specification (), mty_ast_o, mexpr_ast_o with | _, None, None | false, _, None -> - Declaremods.start_module Astmod.interp_modtype + Declaremods.start_module Modintern.interp_modtype id binders_ast mty_ast_o; if_verbose message ("Interactive Module "^ string_of_id id ^" started") | true, Some _, None - | true, _, Some (Coqast.Node(_,"QUALID",_)) + | true, _, Some (CMEident _) | false, _, Some _ -> - Declaremods.declare_module Astmod.interp_modtype Astmod.interp_modexpr + Declaremods.declare_module + Modintern.interp_modtype Modintern.interp_modexpr id binders_ast mty_ast_o mexpr_ast_o; if_verbose message ("Module "^ string_of_id id ^" is defined") @@ -422,12 +419,12 @@ let vernac_declare_module_type id binders_ast mty_ast_o = match mty_ast_o with | None -> - Declaremods.start_modtype Astmod.interp_modtype id binders_ast; + Declaremods.start_modtype Modintern.interp_modtype id binders_ast; if_verbose message ("Interactive Module Type "^ string_of_id id ^" started") | Some base_mty -> - Declaremods.declare_modtype Astmod.interp_modtype + Declaremods.declare_modtype Modintern.interp_modtype id binders_ast base_mty; if_verbose message ("Module Type "^ string_of_id id ^" is defined") @@ -446,7 +443,7 @@ let vernac_record struc binders sort nameopt cfs = let const = match nameopt with | None -> add_prefix "Build_" (snd struc) | Some id -> id in - let s = Astterm.interp_sort sort in + let s = interp_sort sort in Record.definition_structure (struc,binders,cfs,const,s) (* Sections *) @@ -480,6 +477,7 @@ let is_obsolete_module (_,qid) = | _ -> false let vernac_require import _ qidl = + let qidl = List.map qualid_of_reference qidl in try match import with | None -> List.iter Library.read_library qidl @@ -496,6 +494,7 @@ let vernac_require import _ qidl = raise e let vernac_import export qidl = + let qidl = List.map qualid_of_reference qidl in if export then List.iter Library.export_library qidl else @@ -517,14 +516,14 @@ let vernac_canonical locqid = let cl_of_qualid = function | FunClass -> Classops.CL_FUN | SortClass -> Classops.CL_SORT - | RefClass (loc,qid) -> Class.class_of_ref (Nametab.global (loc, qid)) + | RefClass r -> Class.class_of_ref (Nametab.global r) -let vernac_coercion stre (loc,qid as locqid) qids qidt = +let vernac_coercion stre ref qids qidt = let target = cl_of_qualid qidt in let source = cl_of_qualid qids in - let ref = Nametab.global locqid in - Class.try_add_new_coercion_with_target ref stre source target; - if_verbose message ((string_of_qualid qid) ^ " is now a coercion") + let ref' = Nametab.global ref in + Class.try_add_new_coercion_with_target ref' stre source target; + if_verbose message ((string_of_reference ref) ^ " is now a coercion") let vernac_identity_coercion stre id qids qidt = let target = cl_of_qualid qidt in @@ -619,8 +618,8 @@ let vernac_hints = Auto.add_hints let vernac_syntactic_definition id c = function | None -> syntax_definition id c | Some n -> - let l = list_tabulate (fun _ -> Ast.ope("ISEVAR",[])) n in - let c = Ast.ope ("APPLIST",c :: l) in + let l = list_tabulate (fun _ -> (CHole (dummy_loc),None)) n in + let c = CApp (dummy_loc,c,l) in syntax_definition id c let vernac_declare_implicits locqid = function @@ -785,7 +784,8 @@ let vernac_print = function | PrintHintDbName s -> Auto.print_hint_db_by_name s | PrintHintDb -> Auto.print_searchtable () -let global_loaded_library (loc, qid) = +let global_loaded_library r = + let (loc,qid) = qualid_of_reference r in try Nametab.locate_loaded_library qid with Not_found -> user_err_loc (loc, "global_loaded_library", @@ -834,7 +834,7 @@ let vernac_abort = function if !pcoq <> None then (out_some !pcoq).abort "" | Some id -> delete_proof id; - let s = string_of_id id in + let s = string_of_id (snd id) in if_verbose message ("Goal "^s^" aborted"); if !pcoq <> None then (out_some !pcoq).abort s @@ -1008,12 +1008,13 @@ let interp c = match c with | VernacSyntax (whatfor,sel) -> vernac_syntax whatfor sel | VernacTacticGrammar al -> Metasyntax.add_tactic_grammar al | VernacGrammar (univ,al) -> vernac_grammar univ al + | VernacSyntaxExtension (s,l) -> vernac_syntax_extension s l | VernacDelimiters (sc,lr) -> vernac_delimiters sc lr | VernacOpenScope sc -> vernac_open_scope sc | VernacArgumentsScope (qid,scl) -> vernac_arguments_scope qid scl | VernacInfix (assoc,n,inf,qid,sc) -> vernac_infix assoc n inf qid sc | VernacDistfix (assoc,n,inf,qid,sc) -> vernac_distfix assoc n inf qid sc - | VernacNotation (assoc,n,inf,c,pl,sc) -> vernac_notation assoc n inf c pl sc + | VernacNotation (inf,c,pl,sc) -> vernac_notation inf c pl sc (* Gallina *) | VernacDefinition (k,id,d,f) -> vernac_definition k id d f diff --git a/toplevel/vernacentries.mli b/toplevel/vernacentries.mli index 0eca1143f..2e6e35df4 100644 --- a/toplevel/vernacentries.mli +++ b/toplevel/vernacentries.mli @@ -13,6 +13,7 @@ open Names open Term open Vernacinterp open Vernacexpr +open Topconstr (*i*) (* Vernacular entries. This module registers almost all the vernacular entries, @@ -52,9 +53,9 @@ type pcoq_hook = { solve : int -> unit; abort : string -> unit; search : searchable -> dir_path list * bool -> unit; - print_name : Libnames.qualid Util.located -> unit; + print_name : Libnames.reference -> unit; print_check : Environ.unsafe_judgment -> unit; - print_eval : (constr -> constr) -> Environ.env -> Coqast.t -> Environ.unsafe_judgment -> unit; + print_eval : (constr -> constr) -> Environ.env -> constr_expr -> Environ.unsafe_judgment -> unit; show_goal : int option -> unit } diff --git a/toplevel/vernacexpr.ml b/toplevel/vernacexpr.ml index 122c0b0b2..be0f4d678 100644 --- a/toplevel/vernacexpr.ml +++ b/toplevel/vernacexpr.ml @@ -10,12 +10,12 @@ open Util open Names -open Coqast open Tacexpr open Extend open Genarg -open Symbols +open Topconstr open Decl_kinds +open Ppextend (* Toplevel control exceptions *) exception ProtectedLoop @@ -30,41 +30,41 @@ type def_kind = DEFINITION | LET | LOCAL | THEOREM | LETTOP | DECL | REMARK open Libnames open Nametab -type class_rawexpr = FunClass | SortClass | RefClass of qualid located +type class_rawexpr = FunClass | SortClass | RefClass of reference type printable = | PrintTables | PrintLocalContext | PrintFullContext - | PrintSectionContext of qualid located + | PrintSectionContext of reference | PrintInspect of int | PrintGrammar of string * string | PrintLoadPath | PrintModules - | PrintModule of qualid located - | PrintModuleType of qualid located + | PrintModule of reference + | PrintModuleType of reference | PrintMLLoadPath | PrintMLModules - | PrintName of qualid located - | PrintOpaqueName of qualid located + | PrintName of reference + | PrintOpaqueName of reference | PrintGraph | PrintClasses | PrintCoercions | PrintCoercionPaths of class_rawexpr * class_rawexpr | PrintUniverses of string option - | PrintHint of qualid located + | PrintHint of reference | PrintHintGoal | PrintHintDbName of string | PrintHintDb type searchable = - | SearchPattern of pattern_ast - | SearchRewrite of pattern_ast - | SearchHead of qualid located + | SearchPattern of pattern_expr + | SearchRewrite of pattern_expr + | SearchHead of reference type locatable = - | LocateTerm of qualid located - | LocateLibrary of qualid located + | LocateTerm of reference + | LocateLibrary of reference | LocateFile of string type goable = @@ -87,22 +87,22 @@ type showable = | ExplainTree of int list type comment = - | CommentConstr of constr_ast + | CommentConstr of constr_expr | CommentString of string | CommentInt of int -type raw_constr_ast = t +type raw_constr_expr = constr_expr type hints = - | HintsResolve of (identifier option * constr_ast) list - | HintsImmediate of (identifier option * constr_ast) list - | HintsUnfold of (identifier option * qualid located) list - | HintsConstructors of identifier * qualid located - | HintsExtern of identifier * int * raw_constr_ast * raw_tactic_expr + | HintsResolve of (identifier option * constr_expr) list + | HintsImmediate of (identifier option * constr_expr) list + | HintsUnfold of (identifier option * reference) list + | HintsConstructors of identifier * reference + | HintsExtern of identifier * int * raw_constr_expr * raw_tactic_expr type search_restriction = - | SearchInside of qualid located list - | SearchOutside of qualid located list + | SearchInside of reference list + | SearchOutside of reference list type option_value = | StringValue of string @@ -111,7 +111,7 @@ type option_value = type option_ref_value = | StringRefValue of string - | QualidRefValue of qualid located + | QualidRefValue of reference type rec_flag = bool (* true = Rec; false = NoRec *) type verbose_flag = bool (* true = Verbose; false = Silent *) @@ -122,36 +122,23 @@ type export_flag = bool (* true = Export; false = Import *) type specif_flag = bool (* true = Specification; false = Implementation *) type inductive_flag = bool (* true = Inductive; false = CoInductive *) -type sort_expr = t +type sort_expr = Rawterm.rawsort -type simple_binder = identifier * constr_ast +type simple_binder = identifier * constr_expr type 'a with_coercion = coercion_flag * 'a type constructor_expr = simple_binder with_coercion type inductive_expr = - identifier * simple_binder list * constr_ast * constructor_expr list -type fixpoint_expr = - identifier * simple_binder list * constr_ast * constr_ast -type cofixpoint_expr = - identifier * constr_ast * constr_ast -type local_binder = - | LocalRawDef of identifier * constr_ast - | LocalRawAssum of identifier list * constr_ast + identifier * simple_binder list * constr_expr * constructor_expr list type definition_expr = - | ProveBody of local_binder list * constr_ast - | DefineBody of local_binder list * raw_red_expr option * constr_ast - * constr_ast option + | ProveBody of local_binder list * constr_expr + | DefineBody of local_binder list * raw_red_expr option * constr_expr + * constr_expr option type local_decl_expr = - | AssumExpr of identifier * constr_ast - | DefExpr of identifier * constr_ast * constr_ast option + | AssumExpr of identifier * constr_expr + | DefExpr of identifier * constr_expr * constr_expr option -type precedence = int -type grammar_entry_ast = - (loc * string) * Ast.entry_type option * - grammar_associativity * raw_grammar_rule list - -type module_ast = Coqast.t -type module_binder = identifier list * module_ast +type module_binder = identifier list * module_type_ast type vernac_expr = (* Control *) @@ -161,35 +148,35 @@ type vernac_expr = | VernacVar of identifier (* Syntax *) - | VernacGrammar of string * grammar_entry_ast list + | VernacGrammar of string * raw_grammar_entry list | VernacTacticGrammar of (string * (string * grammar_production list) * raw_tactic_expr) list - | VernacSyntax of string * syntax_entry_ast list + | VernacSyntax of string * raw_syntax_entry list + | VernacSyntaxExtension of string * syntax_modifier list | VernacOpenScope of scope_name | VernacDelimiters of scope_name * (string * string) - | VernacArgumentsScope of qualid located * scope_name option list + | VernacArgumentsScope of reference * scope_name option list | VernacInfix of - grammar_associativity * precedence * string * qualid located - * scope_name option + grammar_associativity * precedence * string * reference * + scope_name option | VernacDistfix of - grammar_associativity * precedence * string * qualid located - * scope_name option + grammar_associativity * precedence * string * reference * + scope_name option | VernacNotation of - grammar_associativity * precedence * string * constr_ast - * (string * precedence) list * scope_name option + string * constr_expr * syntax_modifier list * scope_name option (* Gallina *) | VernacDefinition of definition_kind * identifier * definition_expr * - Proof_type.declaration_hook + declaration_hook | VernacStartTheoremProof of theorem_kind * identifier * - (local_binder list * Coqast.t) * bool * Proof_type.declaration_hook + (local_binder list * constr_expr) * bool * declaration_hook | VernacEndProof of opacity_flag * (identifier * theorem_kind option) option - | VernacExactProof of constr_ast + | VernacExactProof of constr_expr | VernacAssumption of assumption_kind * simple_binder with_coercion list | VernacInductive of inductive_flag * inductive_expr list | VernacFixpoint of fixpoint_expr list | VernacCoFixpoint of cofixpoint_expr list - | VernacScheme of (identifier * bool * qualid located * sort_expr) list + | VernacScheme of (identifier * bool * reference * sort_expr) list (* Gallina extensions *) | VernacRecord of identifier with_coercion * simple_binder list @@ -197,22 +184,22 @@ type vernac_expr = | VernacBeginSection of identifier | VernacEndSegment of identifier | VernacRequire of - export_flag option * specif_flag option * qualid located list - | VernacImport of export_flag * qualid located list - | VernacCanonical of qualid located - | VernacCoercion of strength * qualid located * class_rawexpr * class_rawexpr + export_flag option * specif_flag option * reference list + | VernacImport of export_flag * reference list + | VernacCanonical of reference + | VernacCoercion of strength * reference * class_rawexpr * class_rawexpr | VernacIdentityCoercion of strength * identifier * class_rawexpr * class_rawexpr (* Modules and Module Types *) | VernacDeclareModule of identifier * - module_binder list * module_ast option * module_ast option + module_binder list * module_type_ast option * module_ast option | VernacDeclareModuleType of identifier * - module_binder list * module_ast option + module_binder list * module_type_ast option (* Solving *) | VernacSolve of int * raw_tactic_expr - | VernacSolveExistential of int * constr_ast + | VernacSolveExistential of int * constr_expr (* Auxiliary file and library management *) | VernacRequireFrom of export_flag * specif_flag option * identifier * string @@ -227,7 +214,7 @@ type vernac_expr = | VernacRestoreState of string (* Resetting *) - | VernacResetName of identifier + | VernacResetName of identifier located | VernacResetInitial | VernacBack of int @@ -236,18 +223,18 @@ type vernac_expr = loc * (identifier located * raw_tactic_expr) list | VernacHints of string list * hints | VernacHintDestruct of - identifier * (bool,unit) location * constr_ast * int * raw_tactic_expr - | VernacSyntacticDefinition of identifier * constr_ast * int option - | VernacDeclareImplicits of qualid located * int list option - | VernacSetOpacity of opacity_flag * qualid located list + identifier * (bool,unit) location * constr_expr * int * raw_tactic_expr + | VernacSyntacticDefinition of identifier * constr_expr * int option + | VernacDeclareImplicits of reference * int list option + | VernacSetOpacity of opacity_flag * reference list | VernacUnsetOption of Goptions.option_name | VernacSetOption of Goptions.option_name * option_value | VernacAddOption of Goptions.option_name * option_ref_value list | VernacRemoveOption of Goptions.option_name * option_ref_value list | VernacMemOption of Goptions.option_name * option_ref_value list | VernacPrintOption of Goptions.option_name - | VernacCheckMayEval of raw_red_expr option * int option * constr_ast - | VernacGlobalCheck of constr_ast + | VernacCheckMayEval of raw_red_expr option * int option * constr_expr + | VernacGlobalCheck of constr_expr | VernacPrint of printable | VernacSearch of searchable * search_restriction | VernacLocate of locatable @@ -255,12 +242,12 @@ type vernac_expr = | VernacNop (* Proof management *) - | VernacGoal of constr_ast - | VernacAbort of identifier option + | VernacGoal of constr_expr + | VernacAbort of identifier located option | VernacAbortAll | VernacRestart | VernacSuspend - | VernacResume of identifier option + | VernacResume of identifier located option | VernacUndo of int | VernacFocus of int option | VernacUnfocus -- cgit v1.2.3