diff options
| author | herbelin | 2001-08-10 14:42:22 +0000 |
|---|---|---|
| committer | herbelin | 2001-08-10 14:42:22 +0000 |
| commit | 8e92ee787e7d1fd48cae1eccf67a9b05e739743e (patch) | |
| tree | b33191fbaba0cad4b14a96cf5d7786dd2c07c3d7 | |
| parent | c0a3b41ad2f2afba3f060e0d4001bd7aceea0831 (diff) | |
Parsing
- Typage renforcé dans les grammaires (distinction des vars et des metavars)
- Disparition de SLAM au profit de ABSTRACT
- Paths primitifs dans les quotations (syntaxe concrète à base de .)
- Mise en place de identifier dès le type ast
- Protection de identifier contre les effets de bord via un String.copy
- Utilisation de module_ident (= identifier) dans les dir_path (au
lieu de string)
Table des noms qualifiés
- Remplacement de la table de visibilité par une table qui ne cache
plus les noms de modules et sections mais seulement les noms des
constantes (e.g. Require A. ne cachera plus le contenu d'un éventuel
module A déjà existant : seuls les noms de constructions de l'ancien
A qui existent aussi dans le nouveau A seront cachés)
- Renoncement à la possibilité d'accéder les formes non déchargées des
constantes définies à l'intérieur de sections et simplification
connexes (suppression de END-SECTION, une seule table de noms qui ne
survit pas au discharge)
- Utilisation de noms longs pour les modules, de noms qualifiés pour
Require and co, tests de cohérence; pour être cohérent avec la non
survie des tables de noms à la sortie des section, les require Ã
l'intérieur d'une section eux aussi sont refaits à la fermeture de la
section
git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/coq/trunk@1889 85f007b7-540e-0410-9357-904b9bb8a0f7
92 files changed, 2523 insertions, 1537 deletions
@@ -8,7 +8,6 @@ kernel/environ.cmi: kernel/declarations.cmi kernel/names.cmi lib/pp.cmi \ kernel/sign.cmi kernel/term.cmi kernel/univ.cmi kernel/esubst.cmi: lib/util.cmi kernel/evd.cmi: kernel/names.cmi kernel/sign.cmi kernel/term.cmi -kernel/identifier.cmi: lib/hashcons.cmi kernel/indtypes.cmi: kernel/declarations.cmi kernel/environ.cmi \ kernel/names.cmi kernel/sign.cmi kernel/term.cmi kernel/univ.cmi kernel/inductive.cmi: kernel/declarations.cmi kernel/environ.cmi \ @@ -51,6 +50,37 @@ library/library.cmi: library/lib.cmi library/libobject.cmi kernel/names.cmi \ library/nametab.cmi lib/pp.cmi lib/system.cmi library/nametab.cmi: kernel/names.cmi lib/pp.cmi kernel/term.cmi lib/util.cmi library/summary.cmi: kernel/names.cmi +parsing-sans-slam/ast.cmi: parsing/coqast.cmi lib/dyn.cmi kernel/names.cmi \ + parsing/pcoq.cmi lib/pp.cmi +parsing-sans-slam/astterm.cmi: parsing/coqast.cmi kernel/environ.cmi \ + kernel/evd.cmi library/impargs.cmi kernel/names.cmi library/nametab.cmi \ + pretyping/pattern.cmi pretyping/rawterm.cmi kernel/sign.cmi \ + kernel/term.cmi +parsing-sans-slam/coqast.cmi: lib/dyn.cmi kernel/names.cmi +parsing-sans-slam/coqlib.cmi: kernel/names.cmi pretyping/pattern.cmi \ + kernel/term.cmi +parsing-sans-slam/egrammar.cmi: parsing/ast.cmi parsing/coqast.cmi \ + parsing/extend.cmi parsing/pcoq.cmi +parsing-sans-slam/esyntax.cmi: parsing/ast.cmi parsing/coqast.cmi \ + parsing/extend.cmi lib/pp.cmi +parsing-sans-slam/extend.cmi: parsing/ast.cmi parsing/coqast.cmi \ + parsing/pcoq.cmi lib/pp.cmi +parsing-sans-slam/g_minicoq.cmi: kernel/environ.cmi kernel/names.cmi \ + lib/pp.cmi kernel/term.cmi +parsing-sans-slam/g_zsyntax.cmi: parsing/coqast.cmi +parsing-sans-slam/pcoq.cmi: parsing/coqast.cmi +parsing-sans-slam/prettyp.cmi: kernel/environ.cmi kernel/inductive.cmi \ + library/lib.cmi kernel/names.cmi library/nametab.cmi lib/pp.cmi \ + kernel/reduction.cmi kernel/safe_typing.cmi kernel/sign.cmi \ + kernel/term.cmi +parsing-sans-slam/printer.cmi: parsing/coqast.cmi kernel/environ.cmi \ + kernel/names.cmi pretyping/pattern.cmi lib/pp.cmi pretyping/rawterm.cmi \ + kernel/sign.cmi kernel/term.cmi +parsing-sans-slam/search.cmi: kernel/environ.cmi kernel/names.cmi \ + pretyping/pattern.cmi lib/pp.cmi kernel/term.cmi +parsing-sans-slam/termast.cmi: parsing/coqast.cmi kernel/environ.cmi \ + kernel/names.cmi library/nametab.cmi pretyping/pattern.cmi \ + pretyping/rawterm.cmi kernel/sign.cmi kernel/term.cmi parsing/ast.cmi: parsing/coqast.cmi lib/dyn.cmi kernel/names.cmi \ parsing/pcoq.cmi lib/pp.cmi parsing/astterm.cmi: parsing/coqast.cmi kernel/environ.cmi kernel/evd.cmi \ @@ -264,28 +294,6 @@ contrib/extraction/mlutil.cmi: contrib/extraction/miniml.cmi kernel/names.cmi \ kernel/term.cmi contrib/extraction/ocaml.cmi: contrib/extraction/miniml.cmi \ contrib/extraction/mlutil.cmi kernel/names.cmi lib/pp.cmi -contrib/interface-essai/ascent.cmi: kernel/names.cmi -contrib/interface-essai/dad.cmi: parsing/coqast.cmi proofs/proof_type.cmi \ - proofs/tacmach.cmi -contrib/interface-essai/debug_tac.cmi: parsing/coqast.cmi \ - proofs/proof_type.cmi proofs/tacmach.cmi -contrib/interface-essai/name_to_ast.cmi: parsing/coqast.cmi \ - library/nametab.cmi -contrib/interface-essai/pbp.cmi: parsing/coqast.cmi proofs/proof_type.cmi \ - proofs/tacmach.cmi -contrib/interface-essai/showproof.cmi: contrib/interface/ascent.cmi \ - parsing/astterm.cmi proofs/clenv.cmi parsing/coqast.cmi \ - kernel/declarations.cmi kernel/environ.cmi kernel/evd.cmi \ - kernel/inductive.cmi kernel/names.cmi proofs/pfedit.cmi lib/pp.cmi \ - parsing/printer.cmi proofs/proof_trees.cmi proofs/proof_type.cmi \ - kernel/reduction.cmi contrib/interface/showproof_ct.cmo kernel/sign.cmi \ - lib/stamps.cmi kernel/term.cmi contrib/interface/translate.cmi \ - pretyping/typing.cmi lib/util.cmi toplevel/vernacinterp.cmi -contrib/interface-essai/translate.cmi: contrib/interface/ascent.cmi \ - kernel/environ.cmi kernel/evd.cmi proofs/proof_type.cmi kernel/term.cmi -contrib/interface-essai/vtp.cmi: contrib/interface/ascent.cmi -contrib/interface-essai/xlate.cmi: contrib/interface/ascent.cmi \ - parsing/coqast.cmi contrib/interface/dad.cmi: contrib/interface/ctast.cmo proofs/proof_type.cmi \ proofs/tacmach.cmi contrib/interface/debug_tac.cmi: parsing/coqast.cmi proofs/proof_type.cmi \ @@ -306,6 +314,28 @@ contrib/interface/translate.cmi: contrib/interface/ascent.cmi \ contrib/interface/vtp.cmi: contrib/interface/ascent.cmi contrib/interface/xlate.cmi: contrib/interface/ascent.cmi \ contrib/interface/ctast.cmo +contrib/interface_essai/ascent.cmi: kernel/names.cmi +contrib/interface_essai/dad.cmi: parsing/coqast.cmi proofs/proof_type.cmi \ + proofs/tacmach.cmi +contrib/interface_essai/debug_tac.cmi: parsing/coqast.cmi \ + proofs/proof_type.cmi proofs/tacmach.cmi +contrib/interface_essai/name_to_ast.cmi: parsing/coqast.cmi \ + library/nametab.cmi +contrib/interface_essai/pbp.cmi: parsing/coqast.cmi proofs/proof_type.cmi \ + proofs/tacmach.cmi +contrib/interface_essai/showproof.cmi: contrib/interface/ascent.cmi \ + parsing/astterm.cmi proofs/clenv.cmi parsing/coqast.cmi \ + kernel/declarations.cmi kernel/environ.cmi kernel/evd.cmi \ + kernel/inductive.cmi kernel/names.cmi proofs/pfedit.cmi lib/pp.cmi \ + parsing/printer.cmi proofs/proof_trees.cmi proofs/proof_type.cmi \ + kernel/reduction.cmi contrib/interface/showproof_ct.cmo kernel/sign.cmi \ + lib/stamps.cmi kernel/term.cmi contrib/interface/translate.cmi \ + pretyping/typing.cmi lib/util.cmi toplevel/vernacinterp.cmi +contrib/interface_essai/translate.cmi: contrib/interface/ascent.cmi \ + kernel/environ.cmi kernel/evd.cmi proofs/proof_type.cmi kernel/term.cmi +contrib/interface_essai/vtp.cmi: contrib/interface/ascent.cmi +contrib/interface_essai/xlate.cmi: contrib/interface/ascent.cmi \ + parsing/coqast.cmi contrib/xml/xmlcommand.cmi: kernel/names.cmi library/nametab.cmi config/coq_config.cmo: config/coq_config.cmi config/coq_config.cmx: config/coq_config.cmi @@ -349,8 +379,6 @@ kernel/evd.cmo: kernel/names.cmi kernel/sign.cmi kernel/term.cmi lib/util.cmi \ kernel/evd.cmi kernel/evd.cmx: kernel/names.cmx kernel/sign.cmx kernel/term.cmx lib/util.cmx \ kernel/evd.cmi -kernel/identifier.cmo: lib/hashcons.cmi lib/util.cmi kernel/identifier.cmi -kernel/identifier.cmx: lib/hashcons.cmx lib/util.cmx kernel/identifier.cmi kernel/indtypes.cmo: kernel/declarations.cmi kernel/environ.cmi \ kernel/evd.cmi kernel/inductive.cmi kernel/instantiate.cmi \ kernel/names.cmi lib/options.cmi kernel/reduction.cmi kernel/sign.cmi \ @@ -373,10 +401,8 @@ kernel/instantiate.cmo: kernel/declarations.cmi kernel/environ.cmi \ kernel/instantiate.cmx: kernel/declarations.cmx kernel/environ.cmx \ kernel/evd.cmx kernel/names.cmx lib/options.cmx lib/pp.cmx \ kernel/sign.cmx kernel/term.cmx lib/util.cmx kernel/instantiate.cmi -kernel/names.cmo: lib/hashcons.cmi kernel/identifier.cmi lib/pp.cmi \ - lib/util.cmi kernel/names.cmi -kernel/names.cmx: lib/hashcons.cmx kernel/identifier.cmx lib/pp.cmx \ - lib/util.cmx kernel/names.cmi +kernel/names.cmo: lib/hashcons.cmi lib/pp.cmi lib/util.cmi kernel/names.cmi +kernel/names.cmx: lib/hashcons.cmx lib/pp.cmx lib/util.cmx kernel/names.cmi kernel/reduction.cmo: kernel/closure.cmi kernel/declarations.cmi \ kernel/environ.cmi kernel/esubst.cmi kernel/evd.cmi \ kernel/instantiate.cmi kernel/names.cmi lib/pp.cmi kernel/sign.cmi \ @@ -533,6 +559,142 @@ library/summary.cmo: lib/dyn.cmi kernel/names.cmi lib/pp.cmi lib/util.cmi \ library/summary.cmi library/summary.cmx: lib/dyn.cmx kernel/names.cmx lib/pp.cmx lib/util.cmx \ library/summary.cmi +parsing-sans-slam/ast.cmo: parsing/coqast.cmi lib/dyn.cmi kernel/names.cmi \ + parsing/pcoq.cmi lib/pp.cmi lib/util.cmi parsing-sans-slam/ast.cmi +parsing-sans-slam/ast.cmx: parsing/coqast.cmx lib/dyn.cmx kernel/names.cmx \ + parsing/pcoq.cmx lib/pp.cmx lib/util.cmx parsing-sans-slam/ast.cmi +parsing-sans-slam/astterm.cmo: parsing/ast.cmi parsing/coqast.cmi \ + library/declare.cmi kernel/environ.cmi pretyping/evarutil.cmi \ + kernel/evd.cmi library/global.cmi library/impargs.cmi kernel/names.cmi \ + library/nametab.cmi pretyping/pattern.cmi lib/pp.cmi \ + pretyping/pretype_errors.cmi pretyping/pretyping.cmi \ + pretyping/rawterm.cmi kernel/reduction.cmi pretyping/retyping.cmi \ + kernel/sign.cmi pretyping/syntax_def.cmi kernel/term.cmi \ + parsing/termast.cmi pretyping/typing.cmi kernel/univ.cmi lib/util.cmi \ + parsing-sans-slam/astterm.cmi +parsing-sans-slam/astterm.cmx: parsing/ast.cmx parsing/coqast.cmx \ + library/declare.cmx kernel/environ.cmx pretyping/evarutil.cmx \ + kernel/evd.cmx library/global.cmx library/impargs.cmx kernel/names.cmx \ + library/nametab.cmx pretyping/pattern.cmx lib/pp.cmx \ + pretyping/pretype_errors.cmx pretyping/pretyping.cmx \ + pretyping/rawterm.cmx kernel/reduction.cmx pretyping/retyping.cmx \ + kernel/sign.cmx pretyping/syntax_def.cmx kernel/term.cmx \ + parsing/termast.cmx pretyping/typing.cmx kernel/univ.cmx lib/util.cmx \ + parsing-sans-slam/astterm.cmi +parsing-sans-slam/coqast.cmo: lib/dyn.cmi lib/hashcons.cmi kernel/names.cmi \ + parsing-sans-slam/coqast.cmi +parsing-sans-slam/coqast.cmx: lib/dyn.cmx lib/hashcons.cmx kernel/names.cmx \ + parsing-sans-slam/coqast.cmi +parsing-sans-slam/coqlib.cmo: library/declare.cmi kernel/evd.cmi \ + library/global.cmi kernel/names.cmi library/nametab.cmi \ + pretyping/pattern.cmi kernel/term.cmi lib/util.cmi \ + parsing-sans-slam/coqlib.cmi +parsing-sans-slam/coqlib.cmx: library/declare.cmx kernel/evd.cmx \ + library/global.cmx kernel/names.cmx library/nametab.cmx \ + pretyping/pattern.cmx kernel/term.cmx lib/util.cmx \ + parsing-sans-slam/coqlib.cmi +parsing-sans-slam/egrammar.cmo: parsing/ast.cmi parsing/coqast.cmi \ + parsing/extend.cmi parsing/lexer.cmi parsing/pcoq.cmi lib/pp.cmi \ + lib/util.cmi parsing-sans-slam/egrammar.cmi +parsing-sans-slam/egrammar.cmx: parsing/ast.cmx parsing/coqast.cmx \ + parsing/extend.cmx parsing/lexer.cmx parsing/pcoq.cmx lib/pp.cmx \ + lib/util.cmx parsing-sans-slam/egrammar.cmi +parsing-sans-slam/esyntax.cmo: parsing/ast.cmi parsing/coqast.cmi \ + parsing/extend.cmi lib/gmap.cmi lib/gmapl.cmi kernel/names.cmi lib/pp.cmi \ + lib/util.cmi parsing-sans-slam/esyntax.cmi +parsing-sans-slam/esyntax.cmx: parsing/ast.cmx parsing/coqast.cmx \ + parsing/extend.cmx lib/gmap.cmx lib/gmapl.cmx kernel/names.cmx lib/pp.cmx \ + lib/util.cmx parsing-sans-slam/esyntax.cmi +parsing-sans-slam/g_natsyntax.cmo: parsing/ast.cmi parsing/coqast.cmi \ + parsing/coqlib.cmi parsing/esyntax.cmi kernel/names.cmi parsing/pcoq.cmi \ + lib/pp.cmi parsing/termast.cmi lib/util.cmi \ + parsing-sans-slam/g_natsyntax.cmi +parsing-sans-slam/g_natsyntax.cmx: parsing/ast.cmx parsing/coqast.cmx \ + parsing/coqlib.cmx parsing/esyntax.cmx kernel/names.cmx parsing/pcoq.cmx \ + lib/pp.cmx parsing/termast.cmx lib/util.cmx \ + parsing-sans-slam/g_natsyntax.cmi +parsing-sans-slam/g_rsyntax.cmo: parsing/ast.cmi parsing/astterm.cmi \ + parsing/coqast.cmi parsing/esyntax.cmi kernel/names.cmi parsing/pcoq.cmi \ + lib/pp.cmi lib/util.cmi +parsing-sans-slam/g_rsyntax.cmx: parsing/ast.cmx parsing/astterm.cmx \ + parsing/coqast.cmx parsing/esyntax.cmx kernel/names.cmx parsing/pcoq.cmx \ + lib/pp.cmx lib/util.cmx +parsing-sans-slam/g_zsyntax.cmo: parsing/ast.cmi parsing/astterm.cmi \ + parsing/coqast.cmi parsing/esyntax.cmi kernel/names.cmi parsing/pcoq.cmi \ + lib/pp.cmi lib/util.cmi parsing-sans-slam/g_zsyntax.cmi +parsing-sans-slam/g_zsyntax.cmx: parsing/ast.cmx parsing/astterm.cmx \ + parsing/coqast.cmx parsing/esyntax.cmx kernel/names.cmx parsing/pcoq.cmx \ + lib/pp.cmx lib/util.cmx parsing-sans-slam/g_zsyntax.cmi +parsing-sans-slam/pretty.cmo: pretyping/classops.cmi kernel/declarations.cmi \ + library/declare.cmi kernel/environ.cmi kernel/evd.cmi library/global.cmi \ + library/impargs.cmi kernel/inductive.cmi kernel/instantiate.cmi \ + library/lib.cmi library/libobject.cmi library/library.cmi \ + kernel/names.cmi library/nametab.cmi lib/pp.cmi parsing/printer.cmi \ + kernel/reduction.cmi kernel/safe_typing.cmi kernel/sign.cmi \ + pretyping/syntax_def.cmi kernel/term.cmi kernel/typeops.cmi lib/util.cmi +parsing-sans-slam/pretty.cmx: pretyping/classops.cmx kernel/declarations.cmx \ + library/declare.cmx kernel/environ.cmx kernel/evd.cmx library/global.cmx \ + library/impargs.cmx kernel/inductive.cmx kernel/instantiate.cmx \ + library/lib.cmx library/libobject.cmx library/library.cmx \ + kernel/names.cmx library/nametab.cmx lib/pp.cmx parsing/printer.cmx \ + kernel/reduction.cmx kernel/safe_typing.cmx kernel/sign.cmx \ + pretyping/syntax_def.cmx kernel/term.cmx kernel/typeops.cmx lib/util.cmx +parsing-sans-slam/prettyp.cmo: pretyping/classops.cmi kernel/declarations.cmi \ + library/declare.cmi kernel/environ.cmi kernel/evd.cmi library/global.cmi \ + library/impargs.cmi kernel/inductive.cmi kernel/instantiate.cmi \ + library/lib.cmi library/libobject.cmi kernel/names.cmi \ + library/nametab.cmi lib/pp.cmi parsing/printer.cmi kernel/reduction.cmi \ + kernel/safe_typing.cmi kernel/sign.cmi pretyping/syntax_def.cmi \ + kernel/term.cmi kernel/typeops.cmi lib/util.cmi \ + parsing-sans-slam/prettyp.cmi +parsing-sans-slam/prettyp.cmx: pretyping/classops.cmx kernel/declarations.cmx \ + library/declare.cmx kernel/environ.cmx kernel/evd.cmx library/global.cmx \ + library/impargs.cmx kernel/inductive.cmx kernel/instantiate.cmx \ + library/lib.cmx library/libobject.cmx kernel/names.cmx \ + library/nametab.cmx lib/pp.cmx parsing/printer.cmx kernel/reduction.cmx \ + kernel/safe_typing.cmx kernel/sign.cmx pretyping/syntax_def.cmx \ + kernel/term.cmx kernel/typeops.cmx lib/util.cmx \ + parsing-sans-slam/prettyp.cmi +parsing-sans-slam/printer.cmo: parsing/ast.cmi parsing/coqast.cmi \ + library/declare.cmi kernel/environ.cmi parsing/esyntax.cmi \ + parsing/extend.cmi library/global.cmi kernel/names.cmi lib/options.cmi \ + pretyping/pattern.cmi lib/pp.cmi kernel/sign.cmi kernel/term.cmi \ + parsing/termast.cmi lib/util.cmi parsing-sans-slam/printer.cmi +parsing-sans-slam/printer.cmx: parsing/ast.cmx parsing/coqast.cmx \ + library/declare.cmx kernel/environ.cmx parsing/esyntax.cmx \ + parsing/extend.cmx library/global.cmx kernel/names.cmx lib/options.cmx \ + pretyping/pattern.cmx lib/pp.cmx kernel/sign.cmx kernel/term.cmx \ + parsing/termast.cmx lib/util.cmx parsing-sans-slam/printer.cmi +parsing-sans-slam/search.cmo: parsing/astterm.cmi parsing/coqast.cmi \ + parsing/coqlib.cmi kernel/declarations.cmi library/declare.cmi \ + kernel/environ.cmi kernel/evd.cmi library/global.cmi \ + library/libobject.cmi library/library.cmi kernel/names.cmi \ + pretyping/pattern.cmi lib/pp.cmi pretyping/pretyping.cmi \ + parsing/printer.cmi pretyping/rawterm.cmi pretyping/retyping.cmi \ + kernel/term.cmi pretyping/typing.cmi lib/util.cmi \ + parsing-sans-slam/search.cmi +parsing-sans-slam/search.cmx: parsing/astterm.cmx parsing/coqast.cmx \ + parsing/coqlib.cmx kernel/declarations.cmx library/declare.cmx \ + kernel/environ.cmx kernel/evd.cmx library/global.cmx \ + library/libobject.cmx library/library.cmx kernel/names.cmx \ + pretyping/pattern.cmx lib/pp.cmx pretyping/pretyping.cmx \ + parsing/printer.cmx pretyping/rawterm.cmx pretyping/retyping.cmx \ + kernel/term.cmx pretyping/typing.cmx lib/util.cmx \ + parsing-sans-slam/search.cmi +parsing-sans-slam/termast.cmo: parsing/ast.cmi pretyping/classops.cmi \ + parsing/coqast.cmi library/declare.cmi pretyping/detyping.cmi \ + kernel/environ.cmi library/impargs.cmi kernel/inductive.cmi \ + kernel/names.cmi library/nametab.cmi pretyping/pattern.cmi lib/pp.cmi \ + pretyping/rawterm.cmi kernel/reduction.cmi kernel/sign.cmi \ + kernel/term.cmi kernel/univ.cmi lib/util.cmi \ + parsing-sans-slam/termast.cmi +parsing-sans-slam/termast.cmx: parsing/ast.cmx pretyping/classops.cmx \ + parsing/coqast.cmx library/declare.cmx pretyping/detyping.cmx \ + kernel/environ.cmx library/impargs.cmx kernel/inductive.cmx \ + kernel/names.cmx library/nametab.cmx pretyping/pattern.cmx lib/pp.cmx \ + pretyping/rawterm.cmx kernel/reduction.cmx kernel/sign.cmx \ + kernel/term.cmx kernel/univ.cmx lib/util.cmx \ + parsing-sans-slam/termast.cmi parsing/ast.cmo: parsing/coqast.cmi lib/dyn.cmi kernel/names.cmi \ parsing/pcoq.cmi lib/pp.cmi lib/util.cmi parsing/ast.cmi parsing/ast.cmx: parsing/coqast.cmx lib/dyn.cmx kernel/names.cmx \ @@ -824,11 +986,11 @@ pretyping/retyping.cmx: kernel/environ.cmx kernel/inductive.cmx \ kernel/names.cmx kernel/reduction.cmx kernel/term.cmx kernel/typeops.cmx \ kernel/univ.cmx lib/util.cmx pretyping/retyping.cmi pretyping/syntax_def.cmo: library/lib.cmi library/libobject.cmi \ - kernel/names.cmi library/nametab.cmi pretyping/rawterm.cmi \ - library/summary.cmi pretyping/syntax_def.cmi + kernel/names.cmi library/nametab.cmi lib/pp.cmi pretyping/rawterm.cmi \ + library/summary.cmi lib/util.cmi pretyping/syntax_def.cmi pretyping/syntax_def.cmx: library/lib.cmx library/libobject.cmx \ - kernel/names.cmx library/nametab.cmx pretyping/rawterm.cmx \ - library/summary.cmx pretyping/syntax_def.cmi + 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 \ library/declare.cmi kernel/environ.cmi kernel/evd.cmi \ kernel/inductive.cmi kernel/instantiate.cmi kernel/names.cmi lib/pp.cmi \ @@ -1747,180 +1909,6 @@ contrib/fourier/fourierR.cmx: parsing/astterm.cmx proofs/clenv.cmx \ library/global.cmx kernel/names.cmx parsing/pcoq.cmx \ contrib/ring/ring.cmx proofs/tacmach.cmx tactics/tactics.cmx \ kernel/term.cmx -contrib/interface-essai/centaur.cmo: contrib/interface/ascent.cmi \ - parsing/ast.cmi parsing/astterm.cmi pretyping/classops.cmi \ - toplevel/command.cmi parsing/coqast.cmi contrib/interface/dad.cmi \ - contrib/interface/debug_tac.cmi kernel/declarations.cmi \ - library/declare.cmi kernel/environ.cmi toplevel/errors.cmi kernel/evd.cmi \ - library/global.cmi contrib/interface/history.cmi library/lib.cmi \ - library/libobject.cmi library/library.cmi \ - toplevel/line_oriented_parser.cmi toplevel/mltop.cmi \ - contrib/interface/name_to_ast.cmi kernel/names.cmi library/nametab.cmi \ - contrib/interface/pbp.cmi proofs/pfedit.cmi lib/pp.cmi \ - pretyping/pretyping.cmi parsing/printer.cmi proofs/proof_trees.cmi \ - proofs/proof_type.cmi toplevel/protectedtoplevel.cmi \ - pretyping/rawterm.cmi kernel/reduction.cmi parsing/search.cmi \ - contrib/interface/showproof.cmi contrib/interface/showproof_ct.cmo \ - proofs/tacinterp.cmi proofs/tacmach.cmi pretyping/tacred.cmi \ - kernel/term.cmi parsing/termast.cmi contrib/interface/translate.cmi \ - lib/util.cmi toplevel/vernac.cmi toplevel/vernacentries.cmi \ - toplevel/vernacinterp.cmi contrib/interface/vtp.cmi \ - contrib/interface/xlate.cmi -contrib/interface-essai/centaur.cmx: contrib/interface/ascent.cmi \ - parsing/ast.cmx parsing/astterm.cmx pretyping/classops.cmx \ - toplevel/command.cmx parsing/coqast.cmx contrib/interface/dad.cmx \ - contrib/interface/debug_tac.cmx kernel/declarations.cmx \ - library/declare.cmx kernel/environ.cmx toplevel/errors.cmx kernel/evd.cmx \ - library/global.cmx contrib/interface/history.cmx library/lib.cmx \ - library/libobject.cmx library/library.cmx \ - toplevel/line_oriented_parser.cmx toplevel/mltop.cmx \ - contrib/interface/name_to_ast.cmx kernel/names.cmx library/nametab.cmx \ - contrib/interface/pbp.cmx proofs/pfedit.cmx lib/pp.cmx \ - pretyping/pretyping.cmx parsing/printer.cmx proofs/proof_trees.cmx \ - proofs/proof_type.cmx toplevel/protectedtoplevel.cmx \ - pretyping/rawterm.cmx kernel/reduction.cmx parsing/search.cmx \ - contrib/interface/showproof.cmx contrib/interface/showproof_ct.cmx \ - proofs/tacinterp.cmx proofs/tacmach.cmx pretyping/tacred.cmx \ - kernel/term.cmx parsing/termast.cmx contrib/interface/translate.cmx \ - lib/util.cmx toplevel/vernac.cmx toplevel/vernacentries.cmx \ - toplevel/vernacinterp.cmx contrib/interface/vtp.cmx \ - contrib/interface/xlate.cmx -contrib/interface-essai/dad.cmo: parsing/astterm.cmi parsing/coqast.cmi \ - kernel/environ.cmi kernel/evd.cmi library/global.cmi kernel/names.cmi \ - contrib/interface/paths.cmi pretyping/pattern.cmi lib/pp.cmi \ - proofs/proof_trees.cmi proofs/proof_type.cmi pretyping/rawterm.cmi \ - kernel/reduction.cmi proofs/tacmach.cmi tactics/tacticals.cmi \ - tactics/tactics.cmi kernel/term.cmi parsing/termast.cmi \ - pretyping/typing.cmi lib/util.cmi toplevel/vernacinterp.cmi \ - contrib/interface-essai/dad.cmi -contrib/interface-essai/dad.cmx: parsing/astterm.cmx parsing/coqast.cmx \ - kernel/environ.cmx kernel/evd.cmx library/global.cmx kernel/names.cmx \ - contrib/interface/paths.cmx pretyping/pattern.cmx lib/pp.cmx \ - proofs/proof_trees.cmx proofs/proof_type.cmx pretyping/rawterm.cmx \ - kernel/reduction.cmx proofs/tacmach.cmx tactics/tacticals.cmx \ - tactics/tactics.cmx kernel/term.cmx parsing/termast.cmx \ - pretyping/typing.cmx lib/util.cmx toplevel/vernacinterp.cmx \ - contrib/interface-essai/dad.cmi -contrib/interface-essai/debug_tac.cmo: parsing/ast.cmi parsing/coqast.cmi \ - toplevel/errors.cmi lib/pp.cmi parsing/printer.cmi proofs/proof_trees.cmi \ - proofs/proof_type.cmi proofs/tacinterp.cmi proofs/tacmach.cmi \ - lib/util.cmi contrib/interface-essai/debug_tac.cmi -contrib/interface-essai/debug_tac.cmx: parsing/ast.cmx parsing/coqast.cmx \ - toplevel/errors.cmx lib/pp.cmx parsing/printer.cmx proofs/proof_trees.cmx \ - proofs/proof_type.cmx proofs/tacinterp.cmx proofs/tacmach.cmx \ - lib/util.cmx contrib/interface-essai/debug_tac.cmi -contrib/interface-essai/history.cmo: contrib/interface/paths.cmi \ - contrib/interface-essai/history.cmi -contrib/interface-essai/history.cmx: contrib/interface/paths.cmx \ - contrib/interface-essai/history.cmi -contrib/interface-essai/line_parser.cmo: \ - contrib/interface-essai/line_parser.cmi -contrib/interface-essai/line_parser.cmx: \ - contrib/interface-essai/line_parser.cmi -contrib/interface-essai/name_to_ast.cmo: parsing/ast.cmi \ - pretyping/classops.cmi parsing/coqast.cmi kernel/declarations.cmi \ - library/declare.cmi kernel/environ.cmi library/global.cmi \ - library/impargs.cmi kernel/inductive.cmi library/lib.cmi \ - library/libobject.cmi kernel/names.cmi library/nametab.cmi lib/pp.cmi \ - parsing/prettyp.cmi kernel/reduction.cmi kernel/sign.cmi \ - pretyping/syntax_def.cmi kernel/term.cmi parsing/termast.cmi lib/util.cmi \ - contrib/interface-essai/name_to_ast.cmi -contrib/interface-essai/name_to_ast.cmx: parsing/ast.cmx \ - pretyping/classops.cmx parsing/coqast.cmx kernel/declarations.cmx \ - library/declare.cmx kernel/environ.cmx library/global.cmx \ - library/impargs.cmx kernel/inductive.cmx library/lib.cmx \ - library/libobject.cmx kernel/names.cmx library/nametab.cmx lib/pp.cmx \ - parsing/prettyp.cmx kernel/reduction.cmx kernel/sign.cmx \ - pretyping/syntax_def.cmx kernel/term.cmx parsing/termast.cmx lib/util.cmx \ - contrib/interface-essai/name_to_ast.cmi -contrib/interface-essai/parse.cmo: contrib/interface/ascent.cmi \ - parsing/ast.cmi config/coq_config.cmi parsing/coqast.cmi \ - toplevel/errors.cmi parsing/esyntax.cmi library/libobject.cmi \ - library/library.cmi contrib/interface/line_parser.cmi \ - toplevel/metasyntax.cmi library/nametab.cmi parsing/pcoq.cmi lib/pp.cmi \ - lib/system.cmi lib/util.cmi contrib/interface/vtp.cmi \ - contrib/interface/xlate.cmi -contrib/interface-essai/parse.cmx: contrib/interface/ascent.cmi \ - parsing/ast.cmx config/coq_config.cmx parsing/coqast.cmx \ - toplevel/errors.cmx parsing/esyntax.cmx library/libobject.cmx \ - library/library.cmx contrib/interface/line_parser.cmx \ - toplevel/metasyntax.cmx library/nametab.cmx parsing/pcoq.cmx lib/pp.cmx \ - lib/system.cmx lib/util.cmx contrib/interface/vtp.cmx \ - contrib/interface/xlate.cmx -contrib/interface-essai/paths.cmo: contrib/interface-essai/paths.cmi -contrib/interface-essai/paths.cmx: contrib/interface-essai/paths.cmi -contrib/interface-essai/pbp.cmo: parsing/coqast.cmi parsing/coqlib.cmi \ - library/declare.cmi kernel/environ.cmi kernel/evd.cmi library/global.cmi \ - tactics/hipattern.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/tacinterp.cmi \ - proofs/tacmach.cmi tactics/tacticals.cmi tactics/tactics.cmi \ - kernel/term.cmi pretyping/typing.cmi lib/util.cmi \ - contrib/interface-essai/pbp.cmi -contrib/interface-essai/pbp.cmx: parsing/coqast.cmx parsing/coqlib.cmx \ - library/declare.cmx kernel/environ.cmx kernel/evd.cmx library/global.cmx \ - tactics/hipattern.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/tacinterp.cmx \ - proofs/tacmach.cmx tactics/tacticals.cmx tactics/tactics.cmx \ - kernel/term.cmx pretyping/typing.cmx lib/util.cmx \ - contrib/interface-essai/pbp.cmi -contrib/interface-essai/showproof.cmo: parsing/ast.cmi parsing/astterm.cmi \ - proofs/clenv.cmi parsing/coqast.cmi kernel/declarations.cmi \ - kernel/environ.cmi kernel/evd.cmi library/global.cmi kernel/inductive.cmi \ - kernel/names.cmi proofs/pfedit.cmi lib/pp.cmi parsing/printer.cmi \ - proofs/proof_trees.cmi proofs/proof_type.cmi kernel/reduction.cmi \ - contrib/interface/showproof_ct.cmo kernel/sign.cmi lib/stamps.cmi \ - proofs/tacmach.cmi kernel/term.cmi parsing/termast.cmi \ - contrib/interface/translate.cmi pretyping/typing.cmi lib/util.cmi \ - toplevel/vernacinterp.cmi contrib/interface-essai/showproof.cmi -contrib/interface-essai/showproof.cmx: parsing/ast.cmx parsing/astterm.cmx \ - proofs/clenv.cmx parsing/coqast.cmx kernel/declarations.cmx \ - kernel/environ.cmx kernel/evd.cmx library/global.cmx kernel/inductive.cmx \ - kernel/names.cmx proofs/pfedit.cmx lib/pp.cmx parsing/printer.cmx \ - proofs/proof_trees.cmx proofs/proof_type.cmx kernel/reduction.cmx \ - contrib/interface/showproof_ct.cmx kernel/sign.cmx lib/stamps.cmx \ - proofs/tacmach.cmx kernel/term.cmx parsing/termast.cmx \ - contrib/interface/translate.cmx pretyping/typing.cmx lib/util.cmx \ - toplevel/vernacinterp.cmx contrib/interface-essai/showproof.cmi -contrib/interface-essai/showproof_ct.cmo: contrib/interface/ascent.cmi \ - parsing/esyntax.cmi library/global.cmi toplevel/metasyntax.cmi \ - kernel/names.cmi lib/pp.cmi parsing/printer.cmi \ - contrib/interface/translate.cmi contrib/interface/vtp.cmi \ - contrib/interface/xlate.cmi -contrib/interface-essai/showproof_ct.cmx: contrib/interface/ascent.cmi \ - parsing/esyntax.cmx library/global.cmx toplevel/metasyntax.cmx \ - kernel/names.cmx lib/pp.cmx parsing/printer.cmx \ - contrib/interface/translate.cmx contrib/interface/vtp.cmx \ - contrib/interface/xlate.cmx -contrib/interface-essai/translate.cmo: contrib/interface/ascent.cmi \ - parsing/ast.cmi parsing/coqast.cmi kernel/environ.cmi \ - pretyping/evarutil.cmi kernel/evd.cmi library/libobject.cmi \ - library/library.cmi kernel/names.cmi proofs/pfedit.cmi lib/pp.cmi \ - proofs/proof_type.cmi kernel/sign.cmi proofs/tacmach.cmi kernel/term.cmi \ - parsing/termast.cmi lib/util.cmi toplevel/vernacinterp.cmi \ - contrib/interface/vtp.cmi contrib/interface/xlate.cmi \ - contrib/interface-essai/translate.cmi -contrib/interface-essai/translate.cmx: contrib/interface/ascent.cmi \ - parsing/ast.cmx parsing/coqast.cmx kernel/environ.cmx \ - pretyping/evarutil.cmx kernel/evd.cmx library/libobject.cmx \ - library/library.cmx kernel/names.cmx proofs/pfedit.cmx lib/pp.cmx \ - proofs/proof_type.cmx kernel/sign.cmx proofs/tacmach.cmx kernel/term.cmx \ - parsing/termast.cmx lib/util.cmx toplevel/vernacinterp.cmx \ - contrib/interface/vtp.cmx contrib/interface/xlate.cmx \ - contrib/interface-essai/translate.cmi -contrib/interface-essai/vtp.cmo: contrib/interface/ascent.cmi \ - kernel/names.cmi contrib/interface-essai/vtp.cmi -contrib/interface-essai/vtp.cmx: contrib/interface/ascent.cmi \ - kernel/names.cmx contrib/interface-essai/vtp.cmi -contrib/interface-essai/xlate.cmo: contrib/interface/ascent.cmi \ - parsing/ast.cmi parsing/coqast.cmi kernel/names.cmi lib/util.cmi \ - contrib/interface-essai/xlate.cmi -contrib/interface-essai/xlate.cmx: contrib/interface/ascent.cmi \ - parsing/ast.cmx parsing/coqast.cmx kernel/names.cmx lib/util.cmx \ - contrib/interface-essai/xlate.cmi contrib/interface/centaur.cmo: contrib/interface/ascent.cmi parsing/ast.cmi \ parsing/astterm.cmi pretyping/classops.cmi toplevel/command.cmi \ parsing/coqast.cmi contrib/interface/ctast.cmo contrib/interface/dad.cmi \ @@ -2093,6 +2081,180 @@ contrib/interface/xlate.cmo: contrib/interface/ascent.cmi parsing/ast.cmi \ contrib/interface/xlate.cmx: contrib/interface/ascent.cmi parsing/ast.cmx \ contrib/interface/ctast.cmx kernel/names.cmx lib/util.cmx \ contrib/interface/xlate.cmi +contrib/interface_essai/centaur.cmo: contrib/interface/ascent.cmi \ + parsing/ast.cmi parsing/astterm.cmi pretyping/classops.cmi \ + toplevel/command.cmi parsing/coqast.cmi contrib/interface/dad.cmi \ + contrib/interface/debug_tac.cmi kernel/declarations.cmi \ + library/declare.cmi kernel/environ.cmi toplevel/errors.cmi kernel/evd.cmi \ + library/global.cmi contrib/interface/history.cmi library/lib.cmi \ + library/libobject.cmi library/library.cmi \ + toplevel/line_oriented_parser.cmi toplevel/mltop.cmi \ + contrib/interface/name_to_ast.cmi kernel/names.cmi library/nametab.cmi \ + contrib/interface/pbp.cmi proofs/pfedit.cmi lib/pp.cmi \ + pretyping/pretyping.cmi parsing/printer.cmi proofs/proof_trees.cmi \ + proofs/proof_type.cmi toplevel/protectedtoplevel.cmi \ + pretyping/rawterm.cmi kernel/reduction.cmi parsing/search.cmi \ + contrib/interface/showproof.cmi contrib/interface/showproof_ct.cmo \ + proofs/tacinterp.cmi proofs/tacmach.cmi pretyping/tacred.cmi \ + kernel/term.cmi parsing/termast.cmi contrib/interface/translate.cmi \ + lib/util.cmi toplevel/vernac.cmi toplevel/vernacentries.cmi \ + toplevel/vernacinterp.cmi contrib/interface/vtp.cmi \ + contrib/interface/xlate.cmi +contrib/interface_essai/centaur.cmx: contrib/interface/ascent.cmi \ + parsing/ast.cmx parsing/astterm.cmx pretyping/classops.cmx \ + toplevel/command.cmx parsing/coqast.cmx contrib/interface/dad.cmx \ + contrib/interface/debug_tac.cmx kernel/declarations.cmx \ + library/declare.cmx kernel/environ.cmx toplevel/errors.cmx kernel/evd.cmx \ + library/global.cmx contrib/interface/history.cmx library/lib.cmx \ + library/libobject.cmx library/library.cmx \ + toplevel/line_oriented_parser.cmx toplevel/mltop.cmx \ + contrib/interface/name_to_ast.cmx kernel/names.cmx library/nametab.cmx \ + contrib/interface/pbp.cmx proofs/pfedit.cmx lib/pp.cmx \ + pretyping/pretyping.cmx parsing/printer.cmx proofs/proof_trees.cmx \ + proofs/proof_type.cmx toplevel/protectedtoplevel.cmx \ + pretyping/rawterm.cmx kernel/reduction.cmx parsing/search.cmx \ + contrib/interface/showproof.cmx contrib/interface/showproof_ct.cmx \ + proofs/tacinterp.cmx proofs/tacmach.cmx pretyping/tacred.cmx \ + kernel/term.cmx parsing/termast.cmx contrib/interface/translate.cmx \ + lib/util.cmx toplevel/vernac.cmx toplevel/vernacentries.cmx \ + toplevel/vernacinterp.cmx contrib/interface/vtp.cmx \ + contrib/interface/xlate.cmx +contrib/interface_essai/dad.cmo: parsing/astterm.cmi parsing/coqast.cmi \ + kernel/environ.cmi kernel/evd.cmi library/global.cmi kernel/names.cmi \ + contrib/interface/paths.cmi pretyping/pattern.cmi lib/pp.cmi \ + proofs/proof_trees.cmi proofs/proof_type.cmi pretyping/rawterm.cmi \ + kernel/reduction.cmi proofs/tacmach.cmi tactics/tacticals.cmi \ + tactics/tactics.cmi kernel/term.cmi parsing/termast.cmi \ + pretyping/typing.cmi lib/util.cmi toplevel/vernacinterp.cmi \ + contrib/interface_essai/dad.cmi +contrib/interface_essai/dad.cmx: parsing/astterm.cmx parsing/coqast.cmx \ + kernel/environ.cmx kernel/evd.cmx library/global.cmx kernel/names.cmx \ + contrib/interface/paths.cmx pretyping/pattern.cmx lib/pp.cmx \ + proofs/proof_trees.cmx proofs/proof_type.cmx pretyping/rawterm.cmx \ + kernel/reduction.cmx proofs/tacmach.cmx tactics/tacticals.cmx \ + tactics/tactics.cmx kernel/term.cmx parsing/termast.cmx \ + pretyping/typing.cmx lib/util.cmx toplevel/vernacinterp.cmx \ + contrib/interface_essai/dad.cmi +contrib/interface_essai/debug_tac.cmo: parsing/ast.cmi parsing/coqast.cmi \ + toplevel/errors.cmi lib/pp.cmi parsing/printer.cmi proofs/proof_trees.cmi \ + proofs/proof_type.cmi proofs/tacinterp.cmi proofs/tacmach.cmi \ + lib/util.cmi contrib/interface_essai/debug_tac.cmi +contrib/interface_essai/debug_tac.cmx: parsing/ast.cmx parsing/coqast.cmx \ + toplevel/errors.cmx lib/pp.cmx parsing/printer.cmx proofs/proof_trees.cmx \ + proofs/proof_type.cmx proofs/tacinterp.cmx proofs/tacmach.cmx \ + lib/util.cmx contrib/interface_essai/debug_tac.cmi +contrib/interface_essai/history.cmo: contrib/interface/paths.cmi \ + contrib/interface_essai/history.cmi +contrib/interface_essai/history.cmx: contrib/interface/paths.cmx \ + contrib/interface_essai/history.cmi +contrib/interface_essai/line_parser.cmo: \ + contrib/interface_essai/line_parser.cmi +contrib/interface_essai/line_parser.cmx: \ + contrib/interface_essai/line_parser.cmi +contrib/interface_essai/name_to_ast.cmo: parsing/ast.cmi \ + pretyping/classops.cmi parsing/coqast.cmi kernel/declarations.cmi \ + library/declare.cmi kernel/environ.cmi library/global.cmi \ + library/impargs.cmi kernel/inductive.cmi library/lib.cmi \ + library/libobject.cmi kernel/names.cmi library/nametab.cmi lib/pp.cmi \ + parsing/prettyp.cmi kernel/reduction.cmi kernel/sign.cmi \ + pretyping/syntax_def.cmi kernel/term.cmi parsing/termast.cmi lib/util.cmi \ + contrib/interface_essai/name_to_ast.cmi +contrib/interface_essai/name_to_ast.cmx: parsing/ast.cmx \ + pretyping/classops.cmx parsing/coqast.cmx kernel/declarations.cmx \ + library/declare.cmx kernel/environ.cmx library/global.cmx \ + library/impargs.cmx kernel/inductive.cmx library/lib.cmx \ + library/libobject.cmx kernel/names.cmx library/nametab.cmx lib/pp.cmx \ + parsing/prettyp.cmx kernel/reduction.cmx kernel/sign.cmx \ + pretyping/syntax_def.cmx kernel/term.cmx parsing/termast.cmx lib/util.cmx \ + contrib/interface_essai/name_to_ast.cmi +contrib/interface_essai/parse.cmo: contrib/interface/ascent.cmi \ + parsing/ast.cmi config/coq_config.cmi parsing/coqast.cmi \ + toplevel/errors.cmi parsing/esyntax.cmi library/libobject.cmi \ + library/library.cmi contrib/interface/line_parser.cmi \ + toplevel/metasyntax.cmi library/nametab.cmi parsing/pcoq.cmi lib/pp.cmi \ + lib/system.cmi lib/util.cmi contrib/interface/vtp.cmi \ + contrib/interface/xlate.cmi +contrib/interface_essai/parse.cmx: contrib/interface/ascent.cmi \ + parsing/ast.cmx config/coq_config.cmx parsing/coqast.cmx \ + toplevel/errors.cmx parsing/esyntax.cmx library/libobject.cmx \ + library/library.cmx contrib/interface/line_parser.cmx \ + toplevel/metasyntax.cmx library/nametab.cmx parsing/pcoq.cmx lib/pp.cmx \ + lib/system.cmx lib/util.cmx contrib/interface/vtp.cmx \ + contrib/interface/xlate.cmx +contrib/interface_essai/paths.cmo: contrib/interface_essai/paths.cmi +contrib/interface_essai/paths.cmx: contrib/interface_essai/paths.cmi +contrib/interface_essai/pbp.cmo: parsing/coqast.cmi parsing/coqlib.cmi \ + library/declare.cmi kernel/environ.cmi kernel/evd.cmi library/global.cmi \ + tactics/hipattern.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/tacinterp.cmi \ + proofs/tacmach.cmi tactics/tacticals.cmi tactics/tactics.cmi \ + kernel/term.cmi pretyping/typing.cmi lib/util.cmi \ + contrib/interface_essai/pbp.cmi +contrib/interface_essai/pbp.cmx: parsing/coqast.cmx parsing/coqlib.cmx \ + library/declare.cmx kernel/environ.cmx kernel/evd.cmx library/global.cmx \ + tactics/hipattern.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/tacinterp.cmx \ + proofs/tacmach.cmx tactics/tacticals.cmx tactics/tactics.cmx \ + kernel/term.cmx pretyping/typing.cmx lib/util.cmx \ + contrib/interface_essai/pbp.cmi +contrib/interface_essai/showproof.cmo: parsing/ast.cmi parsing/astterm.cmi \ + proofs/clenv.cmi parsing/coqast.cmi kernel/declarations.cmi \ + kernel/environ.cmi kernel/evd.cmi library/global.cmi kernel/inductive.cmi \ + kernel/names.cmi proofs/pfedit.cmi lib/pp.cmi parsing/printer.cmi \ + proofs/proof_trees.cmi proofs/proof_type.cmi kernel/reduction.cmi \ + contrib/interface/showproof_ct.cmo kernel/sign.cmi lib/stamps.cmi \ + proofs/tacmach.cmi kernel/term.cmi parsing/termast.cmi \ + contrib/interface/translate.cmi pretyping/typing.cmi lib/util.cmi \ + toplevel/vernacinterp.cmi contrib/interface_essai/showproof.cmi +contrib/interface_essai/showproof.cmx: parsing/ast.cmx parsing/astterm.cmx \ + proofs/clenv.cmx parsing/coqast.cmx kernel/declarations.cmx \ + kernel/environ.cmx kernel/evd.cmx library/global.cmx kernel/inductive.cmx \ + kernel/names.cmx proofs/pfedit.cmx lib/pp.cmx parsing/printer.cmx \ + proofs/proof_trees.cmx proofs/proof_type.cmx kernel/reduction.cmx \ + contrib/interface/showproof_ct.cmx kernel/sign.cmx lib/stamps.cmx \ + proofs/tacmach.cmx kernel/term.cmx parsing/termast.cmx \ + contrib/interface/translate.cmx pretyping/typing.cmx lib/util.cmx \ + toplevel/vernacinterp.cmx contrib/interface_essai/showproof.cmi +contrib/interface_essai/showproof_ct.cmo: contrib/interface/ascent.cmi \ + parsing/esyntax.cmi library/global.cmi toplevel/metasyntax.cmi \ + kernel/names.cmi lib/pp.cmi parsing/printer.cmi \ + contrib/interface/translate.cmi contrib/interface/vtp.cmi \ + contrib/interface/xlate.cmi +contrib/interface_essai/showproof_ct.cmx: contrib/interface/ascent.cmi \ + parsing/esyntax.cmx library/global.cmx toplevel/metasyntax.cmx \ + kernel/names.cmx lib/pp.cmx parsing/printer.cmx \ + contrib/interface/translate.cmx contrib/interface/vtp.cmx \ + contrib/interface/xlate.cmx +contrib/interface_essai/translate.cmo: contrib/interface/ascent.cmi \ + parsing/ast.cmi parsing/coqast.cmi kernel/environ.cmi \ + pretyping/evarutil.cmi kernel/evd.cmi library/libobject.cmi \ + library/library.cmi kernel/names.cmi proofs/pfedit.cmi lib/pp.cmi \ + proofs/proof_type.cmi kernel/sign.cmi proofs/tacmach.cmi kernel/term.cmi \ + parsing/termast.cmi lib/util.cmi toplevel/vernacinterp.cmi \ + contrib/interface/vtp.cmi contrib/interface/xlate.cmi \ + contrib/interface_essai/translate.cmi +contrib/interface_essai/translate.cmx: contrib/interface/ascent.cmi \ + parsing/ast.cmx parsing/coqast.cmx kernel/environ.cmx \ + pretyping/evarutil.cmx kernel/evd.cmx library/libobject.cmx \ + library/library.cmx kernel/names.cmx proofs/pfedit.cmx lib/pp.cmx \ + proofs/proof_type.cmx kernel/sign.cmx proofs/tacmach.cmx kernel/term.cmx \ + parsing/termast.cmx lib/util.cmx toplevel/vernacinterp.cmx \ + contrib/interface/vtp.cmx contrib/interface/xlate.cmx \ + contrib/interface_essai/translate.cmi +contrib/interface_essai/vtp.cmo: contrib/interface/ascent.cmi \ + kernel/names.cmi contrib/interface_essai/vtp.cmi +contrib/interface_essai/vtp.cmx: contrib/interface/ascent.cmi \ + kernel/names.cmx contrib/interface_essai/vtp.cmi +contrib/interface_essai/xlate.cmo: contrib/interface/ascent.cmi \ + parsing/ast.cmi parsing/coqast.cmi kernel/names.cmi lib/util.cmi \ + contrib/interface_essai/xlate.cmi +contrib/interface_essai/xlate.cmx: contrib/interface/ascent.cmi \ + parsing/ast.cmx parsing/coqast.cmx kernel/names.cmx lib/util.cmx \ + contrib/interface_essai/xlate.cmi contrib/omega/coq_omega.cmo: parsing/ast.cmi proofs/clenv.cmi \ kernel/closure.cmi parsing/coqlib.cmi library/declare.cmi \ kernel/environ.cmi tactics/equality.cmi proofs/evar_refiner.cmi \ @@ -10,9 +10,22 @@ Modifications depuis la V7.0 - Correction bugs Cases en cas de prédicat dépendant - Le flag Delta n'inclut plus Zeta et Evar, nouveaux flags Zeta et Evar inclus dans Compute (à documenter) -- Nouvelle tactique TrueCut qui fait la coupure du calcul des séquents +- Prise en compte des noms longs dans Require et Import, et gestion de + modules de même noms situés dans des répertoires différents +- Nouvelle stratégie de référenciation par nom court basée sur le nom de + base et plus sur les noms de module (avant un module pouvait en + cacher un autre, maintenant seul un nom de base peut en cacher un + autre -- c'est le mode de PATH sous unix) +- Plus de typage dans les quotations (les macros $LIST, ... doivent + être suivies d'une métavariable, idem pour { }) +- Développeur: les var des ast sont maintenant des identifiers +- Les identificateurs ne sont plus mutables +- Nouvelle tactique Assert qui fait la coupure du calcul des séquents (et dans le sens attendu) +- Inversion peut faire des Intros until avant - Amélioration de l'efficacité de l'ancien Cut +- En cas de Require en milieu de section, les noms courts importes par le module disparaissent a la fermeture de la section, + et les Require ultérieurs ne les réintroduisent pas. Différences oubliées dans la V7.0beta : @@ -43,10 +43,10 @@ LOCALINCLUDES=-I config -I tools -I scripts -I lib -I kernel -I library \ -I contrib/extraction -I contrib/correctness \ -I contrib/interface -I contrib/fourier -INCLUDES=$(LOCALINCLUDES) -I $(CAMLP4LIB) +MLINCLUDES=$(LOCALINCLUDES) -I $(CAMLP4LIB) -BYTEFLAGS=-rectypes $(INCLUDES) $(CAMLDEBUG) -OPTFLAGS=-rectypes $(INCLUDES) $(CAMLTIMEPROF) +BYTEFLAGS=-rectypes $(MLINCLUDES) $(CAMLDEBUG) +OPTFLAGS=-rectypes $(MLINCLUDES) $(CAMLTIMEPROF) OCAMLDEP=ocamldep DEPFLAGS=$(LOCALINCLUDES) @@ -72,10 +72,10 @@ LIB=lib/pp_control.cmo lib/pp.cmo lib/util.cmo \ lib/bstack.cmo lib/edit.cmo lib/stamps.cmo lib/gset.cmo lib/gmap.cmo \ lib/tlm.cmo lib/bij.cmo lib/gmapl.cmo lib/profile.cmo lib/explore.cmo -KERNEL=kernel/names.cmo kernel/univ.cmo kernel/esubst.cmo kernel/term.cmo \ - kernel/sign.cmo kernel/declarations.cmo \ - kernel/environ.cmo kernel/evd.cmo kernel/instantiate.cmo \ - kernel/closure.cmo kernel/reduction.cmo \ +KERNEL=kernel/names.cmo kernel/univ.cmo \ + kernel/esubst.cmo kernel/term.cmo kernel/sign.cmo \ + kernel/declarations.cmo kernel/environ.cmo kernel/evd.cmo \ + kernel/instantiate.cmo kernel/closure.cmo kernel/reduction.cmo \ kernel/inductive.cmo kernel/type_errors.cmo kernel/typeops.cmo \ kernel/indtypes.cmo kernel/cooking.cmo kernel/safe_typing.cmo @@ -149,7 +149,8 @@ CORRECTNESSCMO=contrib/correctness/pmisc.cmo \ contrib/correctness/pwp.cmo contrib/correctness/pmlize.cmo \ contrib/correctness/ptactic.cmo contrib/correctness/psyntax.cmo -INTERFACE=contrib/interface/vtp.cmo contrib/interface/xlate.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 \ @@ -228,7 +229,7 @@ COQBINARIES= $(COQMKTOP) $(COQC) $(COQTOPBYTE) $(BESTCOQTOP) $(COQTOP) \ world: $(COQBINARIES) states theories contrib tools $(COQTOPOPT): $(COQMKTOP) $(CMX) $(USERTACCMX) - $(COQMKTOP) -opt $(INCLUDES) -o $@ + $(COQMKTOP) -opt $(MLINCLUDES) -o $@ $(STRIP) $@ $(COQTOPBYTE): $(COQMKTOP) $(CMO) $(USERTACCMO) @@ -287,12 +288,12 @@ toplevel: $(TOPLEVEL) # special binaries for debugging bin/coq-interface$(EXE): $(COQMKTOP) $(CMO) $(USERTACCMO) $(INTERFACE) - $(COQMKTOP) -top $(INCLUDES) $(CAMLDEBUG) -o $@ $(INTERFACE) + $(COQMKTOP) -top $(MLINCLUDES) $(CAMLDEBUG) -o $@ $(INTERFACE) -bin/parser$(EXE): contrib/interface/parse.cmo contrib/interface/line_parser.cmo $(PARSERREQUIRES) contrib/interface/xlate.cmo contrib/interface/vtp.cmo - $(OCAMLC) -cclib -lunix -custom $(INCLUDES) -o $@ $(CMA) \ +bin/parser$(EXE): contrib/interface/ctast.cmo contrib/interface/parse.cmo contrib/interface/line_parser.cmo $(PARSERREQUIRES) contrib/interface/xlate.cmo contrib/interface/vtp.cmo + $(OCAMLC) -cclib -lunix -custom $(MLINCLUDES) -o $@ $(CMA) \ $(PARSERREQUIRES) \ - line_parser.cmo vtp.cmo xlate.cmo parse.cmo + ctast.cmo line_parser.cmo vtp.cmo xlate.cmo parse.cmo clean:: rm -f bin/parser$(EXE) bin/coq-interface$(EXE) @@ -335,13 +336,13 @@ TACTICSVO=tactics/Equality.vo \ tactics/EqDecide.vo $(EXTRACTIONVO) tactics/%.vo: tactics/%.v states/barestate.coq $(COQC) - $(COQC) -boot -$(BEST) $(INCLUDES) -is states/barestate.coq $< + $(COQC) -boot -$(BEST) $(COQINCLUDES) -is states/barestate.coq $< contrib/extraction/%.vo: contrib/extraction/%.v states/barestate.coq $(COQC) $(COQC) -boot -$(BEST) $(COQINCLUDES) -is states/barestate.coq $< states/initial.coq: states/barestate.coq states/MakeInitial.v $(INITVO) $(TACTICSVO) $(BESTCOQTOP) - $(BESTCOQTOP) -boot -batch -silent -is states/barestate.coq $(COQINCLUDES) $(INCLUDES) -load-vernac-source states/MakeInitial.v -outputstate states/initial.coq + $(BESTCOQTOP) -boot -batch -silent -is states/barestate.coq $(COQINCLUDES) -load-vernac-source states/MakeInitial.v -outputstate states/initial.coq clean:: rm -f states/*.coq @@ -568,7 +569,7 @@ MINICOQCMO=$(CONFIG) $(LIB) $(KERNEL) \ MINICOQ=bin/minicoq$(EXE) $(MINICOQ): $(MINICOQCMO) - $(OCAMLC) $(CAMLDEBUG) $(INCLUDES) -o $@ -custom $(CMA) $(MINICOQCMO) $(OSDEPLIBS) + $(OCAMLC) $(CAMLDEBUG) $(MLINCLUDES) -o $@ -custom $(CMA) $(MINICOQCMO) $(OSDEPLIBS) archclean:: rm -f $(MINICOQ) @@ -670,7 +671,7 @@ clean:: tags: find . -name "*.ml*" | sort -r | xargs \ - etags "--regex=/let[ \t]+\([^ \t]+\)/\1/" \ + etags "--regex='/let[ \t]+\([^ \t]+\)/\1/'" \ "--regex=/let[ \t]+rec[ \t]+\([^ \t]+\)/\1/" \ "--regex=/and[ \t]+\([^ \t]+\)/\1/" \ "--regex=/type[ \t]+\([^ \t]+\)/\1/" \ @@ -678,6 +679,7 @@ tags: "--regex=/val[ \t]+\([^ \t]+\)/\1/" \ "--regex=/module[ \t]+\([^ \t]+\)/\1/" + ########################################################################### ### Special rules ########################################################################### @@ -688,7 +690,8 @@ ML4FILES += parsing/lexer.ml4 parsing/q_coqast.ml4 \ parsing/g_prim.ml4 parsing/pcoq.ml4 GRAMMARCMO=lib/pp_control.cmo lib/pp.cmo lib/util.cmo lib/dyn.cmo \ - lib/hashcons.cmo parsing/coqast.cmo parsing/lexer.cmo \ + lib/hashcons.cmo kernel/names.cmo \ + parsing/coqast.cmo parsing/lexer.cmo \ parsing/pcoq.cmo parsing/q_coqast.cmo parsing/g_prim.cmo parsing/grammar.cma: $(GRAMMARCMO) @@ -23,6 +23,7 @@ Vernac: - Pb noms cachés (utilisation de noms absolus ?) - Print / Print Proof en fait identiques ; Print ne devrait pas afficher les constantes opaques (devrait afficher qqchose comme <opaque>) +- Print Section imprime-t-il les sections ouvertes ou bien fermees ?? Grammaires: @@ -52,4 +53,4 @@ Doc: - Suggestions de la formation Dans le Intros pattern on pourrait interpreter les _ comme des hypotheses sur lesquelles on ferait Clear immediatement --> FAIT, semble-t'il
\ No newline at end of file +-> FAIT, semble-t'il diff --git a/contrib/correctness/pcic.ml b/contrib/correctness/pcic.ml index ecc17253a1..d13be77200 100644 --- a/contrib/correctness/pcic.ml +++ b/contrib/correctness/pcic.ml @@ -48,7 +48,7 @@ let tuple_n n = (fun i -> let id = id_of_string ("proj_" ^ string_of_int n ^ "_" ^ string_of_int i) in - (false, (id, true, Ast.nvar ("T" ^ string_of_int i)))) + (false, (id, true, Ast.nvar (id_of_string ("T" ^ string_of_int i))))) l1n in let cons = id_of_string ("Build_tuple_" ^ string_of_int n) in diff --git a/contrib/correctness/pmisc.ml b/contrib/correctness/pmisc.ml index d6a15959b2..c885242bda 100644 --- a/contrib/correctness/pmisc.ml +++ b/contrib/correctness/pmisc.ml @@ -120,23 +120,19 @@ let subst_in_constr alist = replace_vars alist' let subst_in_ast alist ast = - let alist' = - List.map (fun (id,id') -> (string_of_id id,string_of_id id')) alist in let rec subst = function - Nvar(l,s) -> Nvar(l,try List.assoc s alist' with Not_found -> s) + Nvar(l,s) -> Nvar(l,try List.assoc s alist with Not_found -> s) | Node(l,s,args) -> Node(l,s,List.map subst args) - | Slam(l,so,a) -> Slam(l,so,subst a) (* TODO:enlever so de alist' ? *) + | Slam(l,so,a) -> Slam(l,so,subst a) (* TODO:enlever so de alist ? *) | x -> x in subst ast let subst_ast_in_ast alist ast = - let alist' = - List.map (fun (id,a) -> (string_of_id id,a)) alist in let rec subst = function - Nvar(l,s) as x -> (try List.assoc s alist' with Not_found -> x) + Nvar(l,s) as x -> (try List.assoc s alist with Not_found -> x) | Node(l,s,args) -> Node(l,s,List.map subst args) - | Slam(l,so,a) -> Slam(l,so,subst a) (* TODO:enlever so de alist' ? *) + | Slam(l,so,a) -> Slam(l,so,subst a) (* TODO:enlever so de alist ? *) | x -> x in subst ast @@ -146,7 +142,8 @@ let real_subst_in_constr = replace_vars (* Coq constants *) -let coq_constant d s = make_path ("Coq" :: d) (id_of_string s) CCI +let coq_constant d s = + make_path (List.map id_of_string ("Coq" :: d)) (id_of_string s) CCI let bool_sp = coq_constant ["Init"; "Datatypes"] "bool" let coq_true = mkMutConstruct (((bool_sp,0),1), [||]) diff --git a/contrib/correctness/psyntax.ml4 b/contrib/correctness/psyntax.ml4 index 5e0f9ad428..fc09cfa69c 100644 --- a/contrib/correctness/psyntax.ml4 +++ b/contrib/correctness/psyntax.ml4 @@ -561,7 +561,7 @@ open Vernac GEXTEND Gram Pcoq.Vernac_.vernac: [ [ IDENT "Global"; "Variable"; - l = LIST1 IDENT SEP ","; ":"; t = type_v; "." -> + l = LIST1 ident SEP ","; ":"; t = type_v; "." -> let idl = List.map Ast.nvar l in let d = Ast.dynamic (in_typev t) in <:ast< (PROGVARIABLE (VERNACARGLIST ($LIST $idl)) (VERNACDYN $d)) >> diff --git a/contrib/extraction/extract_env.ml b/contrib/extraction/extract_env.ml index da3d464bbd..ba4c4a6163 100644 --- a/contrib/extraction/extract_env.ml +++ b/contrib/extraction/extract_env.ml @@ -215,6 +215,7 @@ let _ = those having an ML extraction. *) let extract_module m = + let m = Nametab.locate_loaded_library (Nametab.make_qualid [] m) in let seg = Library.module_segment (Some m) in let get_reference = function | sp, Leaf o -> @@ -242,10 +243,10 @@ let _ = (function | [VARG_STRING lang; VARG_VARGLIST o; VARG_IDENTIFIER m] -> (fun () -> - let m = Names.string_of_id m in - Ocaml.current_module := m; - let f = (String.uncapitalize m) ^ (file_suffix lang) in - let prm = interp_options lang [] true m o in + Ocaml.current_module := Some m; + let ms = Names.string_of_id m in + let f = (String.uncapitalize ms) ^ (file_suffix lang) in + let prm = interp_options lang [] true ms o in let rl = extract_module m in let decls = optimize prm (decl_of_refs rl) in let decls = List.filter (decl_mem rl) decls in diff --git a/contrib/extraction/haskell.ml b/contrib/extraction/haskell.ml index 827381d1c5..98ea283c71 100644 --- a/contrib/extraction/haskell.ml +++ b/contrib/extraction/haskell.ml @@ -385,7 +385,8 @@ module ModularParams = struct in let m = list_last (dirpath sp) in id_of_string - (if m = !current_module then s else (String.capitalize m) ^ "." ^ s) + (if Some m = !current_module then s + else (String.capitalize (string_of_id m)) ^ "." ^ s) let rename_type_global r = let id = Environ.id_of_global (Global.env()) r in diff --git a/contrib/extraction/ocaml.ml b/contrib/extraction/ocaml.ml index 750afc7822..960edb58a1 100644 --- a/contrib/extraction/ocaml.ml +++ b/contrib/extraction/ocaml.ml @@ -395,7 +395,7 @@ module MonoPp = Make(MonoParams) (*s Renaming issues in a modular extraction. *) -let current_module = ref "" +let current_module = ref None module ModularParams = struct @@ -424,7 +424,8 @@ module ModularParams = struct in let m = list_last (dirpath sp) in id_of_string - (if m = !current_module then s else (String.capitalize m) ^ "." ^ s) + (if Some m = !current_module then s + else (String.capitalize (string_of_id m)) ^ "." ^ s) let rename_type_global r = let id = Environ.id_of_global (Global.env()) r in diff --git a/contrib/extraction/ocaml.mli b/contrib/extraction/ocaml.mli index 057d909fa4..6ab76aded6 100644 --- a/contrib/extraction/ocaml.mli +++ b/contrib/extraction/ocaml.mli @@ -22,7 +22,7 @@ val collect_lambda : ml_ast -> identifier list * ml_ast val push_vars : identifier list -> identifier list * Idset.t -> identifier list * (identifier list * Idset.t) -val current_module : string ref +val current_module : identifier option ref (*s Production of Ocaml syntax. We export both a functor to be used for extraction in the Coq toplevel and a function to extract some @@ -32,7 +32,7 @@ open Mlutil module Make : functor(P : Mlpp_param) -> Mlpp -val current_module : string ref +val current_module : Names.identifier option ref val extract_to_file : string -> extraction_params -> ml_decl list -> unit diff --git a/contrib/field/field.ml4 b/contrib/field/field.ml4 index 19b8534d1d..926ca7951b 100644 --- a/contrib/field/field.ml4 +++ b/contrib/field/field.ml4 @@ -23,7 +23,7 @@ let constr_of com = Astterm.interp_constr Evd.empty (Global.env()) com (* Construction of constants *) let constant dir s = - let dir = "Coq"::"field"::dir in + let dir = make_dirpath (List.map id_of_string ("Coq"::"field"::dir)) in let id = id_of_string s in try Declare.global_reference_in_absolute_module dir id @@ -115,7 +115,7 @@ let field g = | [|-(eq ?1 ? ?)] -> ?1 | [|-(eqT ?1 ? ?)] -> ?1>>) in let th = VArg (Constr (lookup typ)) in - (tac_interp [("FT",th)] [] (get_debug ()) <:tactic<Field_Gen FT>>) g + (tac_interp [(id_of_string "FT",th)] [] (get_debug ()) <:tactic<Field_Gen FT>>) g (* Declaration of Field *) let _ = hide_tactic "Field" (function _ -> field) diff --git a/contrib/omega/coq_omega.ml b/contrib/omega/coq_omega.ml index 7307075bea..7bf6441f73 100644 --- a/contrib/omega/coq_omega.ml +++ b/contrib/omega/coq_omega.ml @@ -220,7 +220,7 @@ let recognize_number t = This is the right way to access to Coq constants in tactics ML code *) let constant dir s = - let dir = "Coq"::dir in + let dir = make_dirpath (List.map id_of_string ("Coq"::dir)) in let id = id_of_string s in try Declare.global_reference_in_absolute_module dir id @@ -384,7 +384,7 @@ let coq_imp_simp = lazy (logic_constant ["Decidable"] "imp_simp") (* Section paths for unfold *) open Closure let make_coq_path dir s = - let dir = "Coq"::dir in + let dir = make_dirpath (List.map id_of_string ("Coq"::dir)) in let id = id_of_string s in let ref = try Nametab.locate_in_absolute_module dir id diff --git a/contrib/ring/Setoid_ring_normalize.v b/contrib/ring/Setoid_ring_normalize.v index 04e2aa16ab..e49be32727 100644 --- a/contrib/ring/Setoid_ring_normalize.v +++ b/contrib/ring/Setoid_ring_normalize.v @@ -456,6 +456,8 @@ Proof. NewDestruct l;Trivial. Save. +(* Hints Resolve ivl_aux_ok ics_aux_ok interp_m_ok. *) + Lemma canonical_sum_merge_ok : (x,y:canonical_sum) (Aequiv (interp_cs (canonical_sum_merge x y)) (Aplus (interp_cs x) (interp_cs y))). diff --git a/contrib/ring/quote.ml b/contrib/ring/quote.ml index 7908af7ecd..10ca06b78e 100644 --- a/contrib/ring/quote.ml +++ b/contrib/ring/quote.ml @@ -120,7 +120,7 @@ open Proof_type the constants are loaded in the environment *) let constant dir s = - let dir = "Coq"::"ring"::dir in + let dir = make_dirpath (List.map id_of_string ("Coq"::"ring"::dir)) in let id = id_of_string s in try Declare.global_reference_in_absolute_module dir id diff --git a/contrib/ring/ring.ml b/contrib/ring/ring.ml index fad760cba8..720c5a862f 100644 --- a/contrib/ring/ring.ml +++ b/contrib/ring/ring.ml @@ -34,7 +34,7 @@ let mt_evd = Evd.empty let constr_of com = Astterm.interp_constr mt_evd (Global.env()) com let constant dir s = - let dir = "Coq"::dir in + let dir = make_dirpath (List.map id_of_string ("Coq"::dir)) in let id = id_of_string s in try Declare.global_reference_in_absolute_module dir id diff --git a/contrib/xml/xmlcommand.ml b/contrib/xml/xmlcommand.ml index 95a93cde73..6e75485962 100644 --- a/contrib/xml/xmlcommand.ml +++ b/contrib/xml/xmlcommand.ml @@ -100,7 +100,8 @@ let could_have_namesakes o sp = (* namesake = omonimo in italian *) let uri_of_path sp tag = let module N = Names in let ext_of_sp sp = ext_of_tag tag in - "cic:/" ^ (String.concat "/" (N.wd_of_sp sp)) ^ "." ^ (ext_of_sp sp) + let dir = List.map N.string_of_id (N.wd_of_sp sp) in + "cic:/" ^ (String.concat "/" dir) ^ "." ^ (ext_of_sp sp) ;; let string_of_sort = @@ -795,8 +796,8 @@ let mkfilename dn sp ext = match dn with None -> None | Some basedir -> - Some (basedir ^ join_dirs basedir (N.wd_of_sp sp) ^ - "." ^ ext) + let dir = List.map N.string_of_id (N.wd_of_sp sp) in + Some (basedir ^ join_dirs basedir dir ^ "." ^ ext) ;; (* print_object leaf_object id section_path directory_name formal_vars *) @@ -914,9 +915,10 @@ and print_node n id sp bprintleaf dn = print_if_verbose ("Suppongo gia' stampato " ^ Names.string_of_id id ^ "\n") end end - | L.OpenedSection (s,_) -> print_if_verbose ("OpenDir " ^ s ^ "\n") - | L.ClosedSection (_,s,state) -> - print_if_verbose("ClosedDir " ^ s ^ "\n") ; + | L.OpenedSection (id,_) -> + print_if_verbose ("OpenDir " ^ Names.string_of_id id ^ "\n") + | L.ClosedSection (_,id,state) -> + print_if_verbose("ClosedDir " ^ Names.string_of_id id ^ "\n") ; if bprintleaf then begin (* open a new scope *) @@ -963,12 +965,12 @@ let printModule id dn = let module X = Xml in let str = N.string_of_id id in let sp = Lib.make_path id N.OBJ in - let ls = L.module_segment (Some str) in + let ls = L.module_segment (Some [id]) in print_if_verbose ("MODULE_BEGIN " ^ str ^ " " ^ N.string_of_path sp ^ " " ^ - (snd (L.module_filename str)) ^ "\n") ; + (L.module_full_filename [id]) ^ "\n") ; print_closed_section str (List.rev ls) dn ; print_if_verbose ("MODULE_END " ^ str ^ " " ^ N.string_of_path sp ^ " " ^ - (snd (L.module_filename str)) ^ "\n") + (L.module_full_filename [id]) ^ "\n") ;; (* printSection identifier directory_name *) @@ -982,18 +984,18 @@ let printSection id dn = let module L = Library in let module N = Names in let module X = Xml in - let str = N.string_of_id id in let sp = Lib.make_path id N.OBJ in let ls = let rec find_closed_section = function [] -> raise Not_found - | (_,Lib.ClosedSection (_,str',ls))::_ when str' = str -> ls + | (_,Lib.ClosedSection (_,id',ls))::_ when id' = id -> ls | _::t -> find_closed_section t in print_string ("Searching " ^ Names.string_of_path sp ^ "\n") ; find_closed_section (Lib.contents_after None) in + let str = N.string_of_id id in print_if_verbose ("SECTION_BEGIN " ^ str ^ " " ^ N.string_of_path sp ^ "\n"); print_closed_section str ls dn ; print_if_verbose ("SECTION_END " ^ str ^ " " ^ N.string_of_path sp ^ "\n") diff --git a/dev/base_include b/dev/base_include index 8ef9fc5baf..969db55813 100644 --- a/dev/base_include +++ b/dev/base_include @@ -6,6 +6,7 @@ #install_printer (* identifier *) prid;; #install_printer (* section_path *) prsp;; +#install_printer (* qualid *) prqualid;; #install_printer (* constr *) print_pure_constr;; (* parsing of terms *) diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 48b12aa2ed..71347c695a 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -36,23 +36,20 @@ let pprawterm = (fun x -> pP(pr_rawterm x)) let pppattern = (fun x -> pP(pr_pattern x)) let pptype = (fun x -> pP(prtype x)) -let prid id = pP [< 'sTR(string_of_id id) >] +let prid id = pP [< pr_id id >] let prconst (sp,j) = - pP [< 'sTR"#"; 'sTR(string_of_path sp); - 'sTR"="; prterm j.uj_val >] + pP [< 'sTR"#"; pr_sp sp; 'sTR"="; prterm j.uj_val >] let prvar ((id,a)) = - pP [< 'sTR"#" ; 'sTR(string_of_id id) ; 'sTR":" ; - prterm a >] + pP [< 'sTR"#" ; pr_id id ; 'sTR":" ; prterm a >] let genprj f j = let (c,t) = Termast.with_casts f j in [< c; 'sTR " : "; t >] let prj j = pP (genprj prjudge j) - -let prsp sp = pP[< 'sTR(string_of_path sp) >] +let prsp sp = pP[< pr_sp sp >] let prqualid qid = pP[< Nametab.pr_qualid qid >] @@ -251,7 +248,7 @@ let print_pure_constr csr = | Anonymous -> print_string "_" (* Remove the top names for library and Scratch to avoid long names *) and sp_display sp = let ls = - match (dirpath sp) with + match List.map string_of_id (dirpath sp) with ("Scratch"::l)-> l | ("Coq"::_::l) -> l | l -> l diff --git a/kernel/cooking.ml b/kernel/cooking.ml index 7a06a78968..482be2fb99 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -25,7 +25,7 @@ type modification_action = ABSTRACT | ERASE type 'a modification = | NOT_OCCUR | DO_ABSTRACT of 'a * modification_action list - | DO_REPLACE + | DO_REPLACE of constant_body type work_list = (section_path * section_path modification) list @@ -33,7 +33,7 @@ type work_list = * (constructor_path * constructor_path modification) list type recipe = { - d_from : section_path; + d_from : constant_body; d_abstract : identifier list; d_modlist : work_list } @@ -83,7 +83,7 @@ let modify_opers replfun absfun (constl,indl,cstrl) = | DO_ABSTRACT (oper',modif) -> assert (List.length modif <= Array.length cl); interp_modif absfun mkMutInd (oper',modif) cl' - | DO_REPLACE -> assert false) + | DO_REPLACE _ -> assert false) with | Not_found -> mkMutInd (spi,cl')) @@ -94,7 +94,7 @@ let modify_opers replfun absfun (constl,indl,cstrl) = | DO_ABSTRACT (oper',modif) -> assert (List.length modif <= Array.length cl); interp_modif absfun mkMutConstruct (oper',modif) cl' - | DO_REPLACE -> assert false) + | DO_REPLACE _ -> assert false) with | Not_found -> mkMutConstruct (spi,cl')) @@ -105,7 +105,7 @@ let modify_opers replfun absfun (constl,indl,cstrl) = | DO_ABSTRACT (oper',modif) -> assert (List.length modif <= Array.length cl); interp_modif absfun mkConst (oper',modif) cl' - | DO_REPLACE -> substrec (replfun (sp,cl'))) + | DO_REPLACE cb -> substrec (replfun sp cb cl')) with | Not_found -> mkConst (sp,cl')) @@ -117,17 +117,18 @@ let expmod_constr oldenv modlist c = let sigma = Evd.empty in let simpfun = if modlist = ([],[],[]) then fun x -> x else nf_betaiota in - let expfun cst = - try - constant_value oldenv cst - with NotEvaluableConst Opaque -> - let (sp,_) = cst in + let expfun sp cb args = + if cb.const_opaque then errorlabstrm "expmod_constr" [< 'sTR"Cannot unfold the value of "; - 'sTR(string_of_path sp); 'sPC; - 'sTR"You cannot declare local lemmas as being opaque"; 'sPC; - 'sTR"and then require that theorems which use them"; 'sPC; - 'sTR"be transparent" >]; + 'sTR(string_of_path sp); 'sPC; + 'sTR"You cannot declare local lemmas as being opaque"; 'sPC; + 'sTR"and then require that theorems which use them"; 'sPC; + 'sTR"be transparent" >]; + match cb.const_body with + | Some body -> + instantiate_constr cb.const_hyps body (Array.to_list args) + | None -> assert false in let c' = modify_opers expfun (fun a b -> mkApp (a, [|b|])) modlist c in match kind_of_term c' with @@ -155,7 +156,7 @@ let abstract_constant ids_to_abs hyps (body,typ) = (body',typ') let cook_constant env r = - let cb = lookup_constant r.d_from env in + let cb = r.d_from in let typ = expmod_type env r.d_modlist cb.const_type in let body = option_app (expmod_constr env r.d_modlist) cb.const_body in let hyps = List.map (fun (sp,c,t) -> (basename sp,c,t)) cb.const_hyps in diff --git a/kernel/cooking.mli b/kernel/cooking.mli index f295031768..d9b564835b 100644 --- a/kernel/cooking.mli +++ b/kernel/cooking.mli @@ -20,7 +20,7 @@ type modification_action = ABSTRACT | ERASE type 'a modification = | NOT_OCCUR | DO_ABSTRACT of 'a * modification_action list - | DO_REPLACE + | DO_REPLACE of constant_body type work_list = (section_path * section_path modification) list @@ -28,7 +28,7 @@ type work_list = * (constructor_path * constructor_path modification) list type recipe = { - d_from : section_path; + d_from : constant_body; d_abstract : identifier list; d_modlist : work_list } diff --git a/kernel/environ.ml b/kernel/environ.ml index db187880ff..77b96d30c9 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -20,7 +20,7 @@ open Declarations type checksum = int -type import = string * checksum +type compilation_unit_name = dir_path * checksum type global = Constant | Inductive @@ -28,7 +28,7 @@ type globals = { env_constants : constant_body Spmap.t; env_inductives : mutual_inductive_body Spmap.t; env_locals : (global * section_path) list; - env_imports : import list } + env_imports : compilation_unit_name list } type context = { env_named_context : named_context; @@ -366,9 +366,8 @@ let set_transparent env sp = (*s Modules (i.e. compiled environments). *) type compiled_env = { - cenv_id : string; - cenv_stamp : checksum; - cenv_needed : import list; + cenv_stamped_id : compilation_unit_name; + cenv_needed : compilation_unit_name list; cenv_constants : (section_path * constant_body) list; cenv_inductives : (section_path * mutual_inductive_body) list } @@ -382,8 +381,7 @@ let exported_objects env = let export env id = let (cst,ind) = exported_objects env in - { cenv_id = id; - cenv_stamp = 0; + { cenv_stamped_id = (id,0); cenv_needed = env.env_globals.env_imports; cenv_constants = cst; cenv_inductives = ind } @@ -394,9 +392,9 @@ let check_imports env needed = try let actual_stamp = List.assoc id imports in if stamp <> actual_stamp then - error ("Inconsistent assumptions over module " ^ id) + error ("Inconsistent assumptions over module " ^(string_of_dirpath id)) with Not_found -> - error ("Reference to unknown module " ^ id) + error ("Reference to unknown module " ^ (string_of_dirpath id)) in List.iter check needed @@ -415,7 +413,7 @@ let import cenv env = { env_constants = add_list gl.env_constants cenv.cenv_constants; env_inductives = add_list gl.env_inductives cenv.cenv_inductives; env_locals = gl.env_locals; - env_imports = (cenv.cenv_id,cenv.cenv_stamp) :: gl.env_imports } + env_imports = cenv.cenv_stamped_id :: gl.env_imports } in let g = universes env in let g = List.fold_left diff --git a/kernel/environ.mli b/kernel/environ.mli index ca93b84e78..45c2d1130b 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -173,7 +173,7 @@ val set_transparent : env -> constant_path -> unit type compiled_env -val export : env -> string -> compiled_env +val export : env -> dir_path -> compiled_env val import : compiled_env -> env -> env (*s Unsafe judgments. We introduce here the pre-type of judgments, which is diff --git a/kernel/names.ml b/kernel/names.ml index 4965a733c9..c4ced8e999 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -11,101 +11,16 @@ open Pp open Util +(*s Identifiers *) + (* Utilities *) let code_of_0 = Char.code '0' let code_of_9 = Char.code '9' -(* This checks that a string is acceptable as an ident, i.e. starts - with a letter and contains only letters, digits or "'" *) - -let check_ident_suffix i l s = - for i=1 to l-1 do - let c = String.get s i in - if not (is_letter c or is_digit c or c = '\'') then - error - ("Character "^(String.sub s i 1)^" is not allowed in an identifier") - done - -let check_ident s = - let l = String.length s in - if l = 0 then error "The empty string is not an identifier"; - let c = String.get s 0 in - if not (is_letter c) then error "An identifier starts with a letter"; - check_ident_suffix 1 l s - -let check_suffix s = check_ident_suffix 0 (String.length s) s - -let is_ident s = try check_ident s; true with _ -> false - (* Identifiers *) -(* -module Ident = struct - -type t = { - atom : string ; - index : int } - -let repr_ident { atom = sa; index = n } = - if n = -1 then (sa,None) else (sa,Some n) - -let make_ident sa = function - | Some n -> - let c = Char.code (String.get sa (String.length sa -1)) in - if c < code_of_0 or c > code_of_9 then { atom = sa; index = n } - else { atom = sa^"_"; index = n } - | None -> { atom = sa; index = -1 } - -let string_of_id id = match repr_ident id with - | (s,None) -> s - | (s,Some n) -> s ^ (string_of_int n) - -let id_of_string s = - let slen = String.length s in - (* [n'] is the position of the first non nullary digit *) - let rec numpart n n' = - if n = 0 then - failwith - ("The string " ^ s ^ " is not an identifier: it contains only digits") - else - let c = Char.code (String.get s (n-1)) in - if c = code_of_0 && n <> slen then - numpart (n-1) n' - else if code_of_0 <= c && c <= code_of_9 then - numpart (n-1) (n-1) - else - n' - in - let numstart = numpart slen slen in - if numstart = slen then - { atom = s; index = -1 } - else - { atom = String.sub s 0 numstart; - index = int_of_string (String.sub s numstart (slen - numstart)) } - -let first_char id = - assert (id.atom <> ""); - String.make 1 id.atom.[0] - -let id_ord { atom = s1; index = n1 } { atom = s2; index = n2 } = - let s_bit = Pervasives.compare s1 s2 in - if s_bit = 0 then n1 - n2 else s_bit -(* Rem : if an ident starts with toto00 then after successive - renamings it comes to toto09, then it goes on with toto010 *) -let lift_ident { atom = str; index = i } = { atom = str; index = i+1 } -let restart_ident id = { id with index = 0 } -let has_index id = (id.index <> -1) - -let hash_sub hstr id = { atom = hstr id.atom; index = id.index } -let equal id1 id2 = id1.atom == id2.atom && id1.index = id2.index - -end (* End of module Ident *) -*) -(* Second implementation *) -module Ident = struct - -type t = string +type identifier = string let cut_ident s = let slen = String.length s in @@ -139,13 +54,7 @@ let make_ident sa = function let c = Char.code (String.get sa (String.length sa -1)) in if c < code_of_0 or c > code_of_9 then sa ^ (string_of_int n) else sa ^ "_" ^ (string_of_int n) - | None -> sa - -let add_suffix id s = check_suffix s; id^s -let add_prefix s id = check_ident s; s^id - -let string_of_id id = id -let id_of_string s = s + | None -> String.copy sa let first_char id = assert (id <> ""); @@ -155,7 +64,7 @@ let id_ord = Pervasives.compare (* Rem: semantics is a bit different, if an ident starts with toto00 then after successive renamings it comes to toto09, then it goes on with toto10 *) -let lift_ident id = +let lift_subscript id = let len = String.length id in let rec add carrypos = let c = id.[carrypos] in @@ -180,28 +89,52 @@ let lift_ident id = end in add (len-1) -let has_index id = is_digit (id.[String.length id - 1]) +let has_subscript id = is_digit (id.[String.length id - 1]) -let restart_ident id = +let forget_subscript id = let len = String.length id in let numstart = cut_ident id in let newid = String.make (numstart+1) '0' in String.blit id 0 newid 0 numstart; newid -let hash_sub hstr id = hstr id -let equal id1 id2 = id1 == id2 +(* This checks that a string is acceptable as an ident, i.e. starts + with a letter and contains only letters, digits or "'" *) + +let check_ident_suffix i l s = + for i=1 to l-1 do + let c = String.get s i in + if not (is_letter c or is_digit c or c = '\'' or c = '_' or c = '@') then + error + ("Character "^(String.sub s i 1)^" is not allowed in an identifier") + done + +let check_ident s = + let l = String.length s in + if l = 0 then error "The empty string is not an identifier"; + let c = String.get s 0 in + if (is_letter c) or c = '_' or c = '$' then check_ident_suffix 1 l s + else error (s^": an identifier starts with a letter") + +let is_ident s = try check_ident s; true with _ -> false -end (* End of module Ident *) +let check_suffix s = check_ident_suffix 0 (String.length s) s -type identifier = Ident.t -let repr_ident = Ident.repr_ident -let make_ident = Ident.make_ident let add_suffix id s = check_suffix s; id^s let add_prefix s id = check_ident s; s^id -let string_of_id = Ident.string_of_id -let id_of_string = Ident.id_of_string -let id_ord = Ident.id_ord + +let string_of_id id = String.copy id +let id_of_string s = check_ident s; String.copy s + +(* Hash-consing of identifier *) +module Hident = Hashcons.Make( + struct + type t = string + type u = string -> string + let hash_sub hstr id = hstr id + let equal id1 id2 = id1 == id2 + let hash = Hashtbl.hash + end) module IdOrdered = struct @@ -216,18 +149,18 @@ let atompart_of_id id = fst (repr_ident id) let index_of_id id = snd (repr_ident id) let pr_id id = [< 'sTR (string_of_id id) >] -let first_char = Ident.first_char +let wildcard = id_of_string "_" (* Fresh names *) -let lift_ident = Ident.lift_ident +let lift_ident = lift_subscript let next_ident_away id avoid = if List.mem id avoid then - let id0 = if not (Ident.has_index id) then id else + let id0 = if not (has_subscript id) then id else (* Ce serait sans doute mieux avec quelque chose inspiré de *** make_ident id (Some 0) *** mais ça brise la compatibilité... *) - Ident.restart_ident id in + forget_subscript id in let rec name_rec id = if List.mem id avoid then name_rec (lift_ident id) else id in name_rec id0 @@ -272,30 +205,25 @@ let kind_of_string = function | _ -> invalid_arg "kind_of_string" (*s Directory paths = section names paths *) -type dir_path = string list - -(*s Section paths are absolute names *) +type module_ident = identifier +type dir_path = module_ident list -type section_path = { - dirpath : dir_path ; - basename : identifier ; - kind : path_kind } +module ModIdOrdered = + struct + type t = identifier + let compare = Pervasives.compare + end -let make_path pa id k = { dirpath = pa; basename = id; kind = k } -let repr_path { dirpath = pa; basename = id; kind = k} = (pa,id,k) +module ModIdmap = Map.Make(ModIdOrdered) -let kind_of_path sp = sp.kind -let basename sp = sp.basename -let dirpath sp = sp.dirpath +let make_dirpath x = x +let repr_dirpath x = x -(* parsing and printing of section paths *) -let string_of_dirpath sl = String.concat "." sl +let dirpath_prefix = function + | [] -> anomaly "dirpath_prefix: empty dirpath" + | l -> snd (list_sep_last l) -let string_of_path sp = - let (sl,id,k) = repr_path sp in - String.concat "" - (List.flatten (List.map (fun s -> [s;"."]) sl) - @ [ string_of_id id ]) +let split_dirpath d = let (b,d) = list_sep_last d in (d,b) let parse_sp s = let len = String.length s in @@ -304,37 +232,60 @@ let parse_sp s = let pos = String.index_from s n '.' in let dir = String.sub s n (pos-n) in let dirs,n' = decoupe_dirs (succ pos) in - dir::dirs,n' + (id_of_string dir)::dirs,n' with | Not_found -> [],n in if len = 0 then invalid_arg "parse_section_path"; let dirs,n = decoupe_dirs 0 in let id = String.sub s n (len-n) in - dirs,id + dirs, (id_of_string id) -let path_of_string s = +let dirpath_of_string s = try let sl,s = parse_sp s in - make_path sl (id_of_string s) CCI + sl @ [s] with - | Invalid_argument _ -> invalid_arg "path_of_string" + | Invalid_argument _ -> invalid_arg "dirpath_of_string" -let dirpath_of_string s = +let string_of_dirpath sl = String.concat "." (List.map string_of_id sl) + +let pr_dirpath sl = [< 'sTR (string_of_dirpath sl) >] + +(*s Section paths are absolute names *) + +type section_path = { + dirpath : dir_path ; + basename : identifier ; + kind : path_kind } + +let make_path pa id k = { dirpath = pa; basename = id; kind = k } +let repr_path { dirpath = pa; basename = id; kind = k} = (pa,id,k) + +let kind_of_path sp = sp.kind +let basename sp = sp.basename +let dirpath sp = sp.dirpath + +(* parsing and printing of section paths *) +let string_of_path sp = + let (sl,id,k) = repr_path sp in + (string_of_dirpath sl) ^ "." ^ (string_of_id id) + +let path_of_string s = try let sl,s = parse_sp s in - sl @ [s] + make_path sl s CCI with - | Invalid_argument _ -> invalid_arg "dirpath_of_string" + | Invalid_argument _ -> invalid_arg "path_of_string" let pr_sp sp = [< 'sTR (string_of_path sp) >] let sp_of_wd = function | [] -> invalid_arg "Names.sp_of_wd" - | l -> let (bn,dp) = list_sep_last l in make_path dp (id_of_string bn) OBJ + | l -> let (bn,dp) = list_sep_last l in make_path dp bn OBJ let wd_of_sp sp = - let (sp,id,_) = repr_path sp in sp @ [string_of_id id] + let (sp,id,_) = repr_path sp in sp @ [id] let sp_ord sp1 sp2 = let (p1,id1,k) = repr_path sp1 @@ -346,7 +297,7 @@ let sp_ord sp1 sp2 = else ck -let dirpath_prefix_of = list_prefix_of +let is_dirpath_prefix_of = list_prefix_of module SpOrdered = struct @@ -366,16 +317,6 @@ type inductive_path = section_path * int type constructor_path = inductive_path * int type mutual_inductive_path = section_path -(* Hash-consing of identifier *) -module Hident = Hashcons.Make( - struct - type t = Ident.t - type u = string -> string - let hash_sub = Ident.hash_sub - let equal = Ident.equal - let hash = Hashtbl.hash - end) - (* Hash-consing of name objects *) module Hname = Hashcons.Make( struct @@ -395,9 +336,9 @@ module Hname = Hashcons.Make( module Hsp = Hashcons.Make( struct type t = section_path - type u = (identifier -> identifier) * (string -> string) - let hash_sub (hident,hstr) sp = - { dirpath = List.map hstr sp.dirpath; + type u = identifier -> identifier + let hash_sub hident sp = + { dirpath = List.map hident sp.dirpath; basename = hident sp.basename; kind = sp.kind } let equal sp1 sp2 = @@ -411,6 +352,6 @@ let hcons_names () = let hstring = Hashcons.simple_hcons Hashcons.Hstring.f () in let hident = Hashcons.simple_hcons Hident.f hstring in let hname = Hashcons.simple_hcons Hname.f hident in - let hspcci = Hashcons.simple_hcons Hsp.f (hident,hstring) in - let hspfw = Hashcons.simple_hcons Hsp.f (hident,hstring) in + let hspcci = Hashcons.simple_hcons Hsp.f hident in + let hspfw = Hashcons.simple_hcons Hsp.f hident in (hspcci,hspfw,hname,hident,hstring) diff --git a/kernel/names.mli b/kernel/names.mli index 7eb39ff673..58aae5a657 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -32,10 +32,8 @@ val string_of_id : identifier -> string val id_of_string : string -> identifier val pr_id : identifier -> std_ppcmds -(* These checks the validity of an identifier; [check_ident] fails - with error if invalid *) -val check_ident : string -> unit -val is_ident : string -> bool +(* This is the identifier ["_"] *) +val wildcard : identifier (* Deriving ident from other idents *) val add_suffix : identifier -> string -> identifier @@ -63,10 +61,24 @@ val string_of_kind : path_kind -> string val kind_of_string : string -> path_kind (*s Directory paths = section names paths *) -type dir_path = string list +type module_ident = identifier +type dir_path = module_ident list + +module ModIdmap : Map.S with type key = module_ident + +val make_dirpath : module_ident list -> dir_path +val repr_dirpath : dir_path -> module_ident list + +(* Give the immediate prefix of a dir_path *) +val dirpath_prefix : dir_path -> dir_path + +(* Give the immediate prefix and basename of a dir_path *) +val split_dirpath : dir_path -> dir_path * identifier (* Printing of directory paths as ["coq_root.module.submodule"] *) val string_of_dirpath : dir_path -> string +val pr_dirpath : dir_path -> std_ppcmds + (*s Section paths are {\em absolute} names *) type section_path @@ -80,8 +92,8 @@ val dirpath : section_path -> dir_path val basename : section_path -> identifier val kind_of_path : section_path -> path_kind -val sp_of_wd : string list -> section_path -val wd_of_sp : section_path -> string list +val sp_of_wd : module_ident list -> section_path +val wd_of_sp : section_path -> module_ident list (* Parsing and printing of section path as ["coq_root.module.id"] *) val path_of_string : string -> section_path @@ -89,25 +101,11 @@ val string_of_path : section_path -> string val pr_sp : section_path -> std_ppcmds val dirpath_of_string : string -> dir_path -(*i -val string_of_path_mind : section_path -> identifier -> string -val coerce_path : path_kind -> section_path -> section_path -val fwsp_of : section_path -> section_path -val ccisp_of : section_path -> section_path -val objsp_of : section_path -> section_path -val fwsp_of_ccisp : section_path -> section_path -val ccisp_of_fwsp : section_path -> section_path -val append_to_path : section_path -> string -> section_path - -val sp_gt : section_path * section_path -> bool -i*) val sp_ord : section_path -> section_path -> int (* [is_dirpath_prefix p1 p2=true] if [p1] is a prefix of or is equal to [p2] *) -val dirpath_prefix_of : dir_path -> dir_path -> bool -(*i -module Spset : Set.S with type elt = section_path -i*) +val is_dirpath_prefix_of : dir_path -> dir_path -> bool + module Spmap : Map.S with type key = section_path (*s Specific paths for declarations *) @@ -121,4 +119,3 @@ type mutual_inductive_path = section_path val hcons_names : unit -> (section_path -> section_path) * (section_path -> section_path) * (name -> name) * (identifier -> identifier) * (string -> string) - diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index 04fbe21bb1..102fbb228e 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -63,7 +63,7 @@ val lookup_mind_specif : inductive -> safe_environment -> inductive_instance val set_opaque : safe_environment -> section_path -> unit val set_transparent : safe_environment -> section_path -> unit -val export : safe_environment -> string -> compiled_env +val export : safe_environment -> dir_path -> compiled_env val import : compiled_env -> safe_environment -> safe_environment val env_of_safe_env : safe_environment -> env diff --git a/kernel/univ.ml b/kernel/univ.ml index 7c3060820a..5f03e6a36e 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -40,9 +40,12 @@ let string_of_univ u = let pr_uni u = [< 'sTR (Names.string_of_dirpath u.u_mod) ; 'sTR"." ; 'iNT u.u_num >] - -let dummy_univ = { u_mod = ["dummy univ"]; u_num = 0 } (* for prover terms *) -let implicit_univ = { u_mod = ["implicit univ"]; u_num = 0 } +let dummy_univ = (* for prover terms *) + { u_mod = Names.make_dirpath [Names.id_of_string "dummy_univ"]; + u_num = 0 } +let implicit_univ = + { u_mod = Names.make_dirpath [Names.id_of_string "implicit_univ"]; + u_num = 0 } let current_module = ref [] @@ -83,7 +86,7 @@ let declare_univ u g = (* The universes of Prop and Set: Type_0, Type_1 and the resulting graph. *) let (initial_universes,prop_univ,prop_univ_univ) = - let prop_sp = ["prop_univ"] in + let prop_sp = Names.make_dirpath [Names.id_of_string "prop_univ"] in let u = { u_mod = prop_sp; u_num = 0 } in let su = { u_mod = prop_sp; u_num = 1 } in let g = enter_arc (terminal u) UniverseMap.empty in @@ -430,7 +433,7 @@ module Huniv = Hashcons.Make( struct type t = universe - type u = string -> string + type u = Names.identifier -> Names.identifier let hash_sub hstr {u_mod=sp; u_num=n} = {u_mod=List.map hstr sp; u_num=n} let equal {u_mod=sp1; u_num=n1} {u_mod=sp2; u_num=n2} = @@ -441,5 +444,6 @@ module Huniv = let hcons1_univ u = - let hstring = Hashcons.simple_hcons Hashcons.Hstring.f () in - Hashcons.simple_hcons Huniv.f hstring u + let _,_,_,hid,_ = Names.hcons_names () in + Hashcons.simple_hcons Huniv.f hid u + diff --git a/lib/system.ml b/lib/system.ml index cf48f0e4b4..bb3c711307 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -13,22 +13,18 @@ open Util open Unix (* Files and load path. *) -(* All subdirectories, recursively *) -type load_path_entry = { - directory : string; - coq_dirpath : string list } +type physical_path = string +type load_path = physical_path list -type load_path = load_path_entry list +(* All subdirectories, recursively *) let exists_dir dir = try let _ = opendir dir in true with Unix_error _ -> false -let all_subdirs root alias = +let all_subdirs root = let l = ref [] in - let add f rel = - l := { directory = f; coq_dirpath = rel } :: !l - in + let add f rel = l := (f, rel) :: !l in let rec traverse dir rel = let dirh = opendir dir in try @@ -49,12 +45,8 @@ let all_subdirs root alias = in if exists_dir root then begin - let alias = match alias with - | Some a -> a - | None -> [Filename.basename root] - in - add root alias; - traverse root alias + add root []; + traverse root [] end ; List.rev !l @@ -73,7 +65,7 @@ let glob s = s let search_in_path path filename = let rec search = function | lpe :: rem -> - let f = glob (Filename.concat lpe.directory filename) in + let f = glob (Filename.concat lpe filename) in if Sys.file_exists f then (lpe,f) else search rem | [] -> raise Not_found @@ -86,7 +78,7 @@ let find_file_in_path paths name = let globname = glob name in if not (Filename.is_relative globname) then let root = Filename.dirname globname in - { directory = root; coq_dirpath = [] }, globname + root, globname else try search_in_path paths name @@ -129,12 +121,11 @@ let raw_extern_intern magic suffix = open_trapping_failure (fun n -> n,open_out_bin n) name suffix in output_binary_int channel magic; filec - and intern_state paths name = - let lpe,fname = find_file_in_path paths (make_suffix name suffix) in + and intern_state fname = let channel = open_in_bin fname in if input_binary_int channel <> magic then raise (Bad_magic_number fname); - (lpe,fname,channel) + channel in (extern_state,intern_state) @@ -151,7 +142,8 @@ let extern_intern magic suffix = with Sys_error s -> error ("System error: " ^ s) and intern_state paths name = try - let (_,fname,channel) = raw_intern paths name in + let _,fname = find_file_in_path paths (make_suffix name suffix) in + let channel = raw_intern fname in let v = marshal_in channel in close_in channel; v diff --git a/lib/system.mli b/lib/system.mli index ee2dca4905..e6eb921883 100644 --- a/lib/system.mli +++ b/lib/system.mli @@ -12,15 +12,13 @@ given by the user. For efficiency, we keep the full path (field [directory]), the root path and the path relative to the root. *) -type load_path_entry = { - directory : string; - coq_dirpath : string list } -type load_path = load_path_entry list +type physical_path = string +type load_path = physical_path list -val all_subdirs : unix_path:string -> string list option -> load_path +val all_subdirs : unix_path:string -> (physical_path * string list) list val is_in_path : load_path -> string -> bool -val where_in_path : load_path -> string -> load_path_entry * string +val where_in_path : load_path -> string -> physical_path * string val make_suffix : string -> string -> string val file_readable_p : string -> bool @@ -31,7 +29,7 @@ val home : string val exists_dir : string -> bool -val find_file_in_path : load_path -> string -> load_path_entry * string +val find_file_in_path : load_path -> string -> physical_path * string (*s Generic input and output functions, parameterized by a magic number and a suffix. The intern functions raise the exception [Bad_magic_number] @@ -43,8 +41,7 @@ val marshal_in : in_channel -> 'a exception Bad_magic_number of string val raw_extern_intern : int -> string -> - (string -> string * out_channel) * - (load_path -> string -> load_path_entry * string * in_channel) + (string -> string * out_channel) * (string -> in_channel) val extern_intern : int -> string -> (string -> 'a -> unit) * (load_path -> string -> 'a) diff --git a/lib/util.ml b/lib/util.ml index 0c3c038dd2..cf5b58b49e 100644 --- a/lib/util.ml +++ b/lib/util.ml @@ -223,6 +223,13 @@ let rec list_distinct = function | h::t -> (not (List.mem h t)) && list_distinct t | _ -> true +let rec list_filter2 f = function + | [], [] as p -> p + | d::dp, l::lp -> + let (dp',lp' as p) = list_filter2 f (dp,lp) in + if f d l then d::dp', l::lp' else p + | _ -> invalid_arg "list_filter2" + let list_subset l1 l2 = let t2 = Hashtbl.create 151 in List.iter (fun x -> Hashtbl.add t2 x ()) l2; diff --git a/lib/util.mli b/lib/util.mli index d5976baf1d..a57803c5e2 100644 --- a/lib/util.mli +++ b/lib/util.mli @@ -64,6 +64,7 @@ val list_chop : int -> 'a list -> 'a list * 'a list val list_tabulate : (int -> 'a) -> int -> 'a list val list_assign : 'a list -> int -> 'a -> 'a list val list_distinct : 'a list -> bool +val list_filter2 : ('a -> 'b -> bool) -> 'a list * 'b list -> 'a list * 'b list val list_map_i : (int -> 'a -> 'b) -> int -> 'a list -> 'b list val list_map2_i : (int -> 'a -> 'b -> 'c) -> int -> 'a list -> 'b list -> 'c list diff --git a/library/declare.ml b/library/declare.ml index 34e0c1a12f..b360d8e01b 100644 --- a/library/declare.ml +++ b/library/declare.ml @@ -23,6 +23,7 @@ open Lib open Impargs open Indrec open Nametab +open Library type strength = | NotDeclare @@ -81,7 +82,7 @@ let cache_variable (sp,(id,(d,_,_) as vd)) = | SectionLocalAssum ty -> Global.push_named_assum (id,ty) | SectionLocalDef c -> Global.push_named_def (id,c) end; - Nametab.push_local sp (VarRef sp); + Nametab.push_short_name id (VarRef sp); vartab := let (m,l) = !vartab in (Spmap.add sp vd m, sp::l) let (in_variable, out_variable) = @@ -105,11 +106,17 @@ let cache_parameter (sp,c) = errorlabstrm "cache_parameter" [< pr_id (basename sp); 'sTR " already exists" >]; Global.add_parameter sp c (current_section_context ()); - Nametab.push sp (ConstRef sp) + Nametab.push sp (ConstRef sp); + Nametab.push_short_name (basename sp) (ConstRef sp) -let load_parameter _ = () +let load_parameter (sp,_) = + if Nametab.exists_cci sp then + errorlabstrm "cache_parameter" + [< pr_id (basename sp); 'sTR " already exists" >]; + Nametab.push sp (ConstRef sp) -let open_parameter (sp,_) = () +let open_parameter (sp,_) = + Nametab.push_short_name (basename sp) (ConstRef sp) let export_parameter x = Some x @@ -155,13 +162,19 @@ let cache_constant (sp,(cdt,stre,op)) = | ConstantRecipe r -> Global.add_discharged_constant sp r sc end; Nametab.push sp (ConstRef sp); + Nametab.push_short_name (basename sp) (ConstRef sp); if op then Global.set_opaque sp; csttab := Spmap.add sp stre !csttab let load_constant (sp,(ce,stre,op)) = - csttab := Spmap.add sp stre !csttab + if Nametab.exists_cci sp then + errorlabstrm "cache_constant" + [< pr_id (basename sp); 'sTR " already exists" >] ; + csttab := Spmap.add sp stre !csttab; + Nametab.push sp (ConstRef sp) -let open_constant (sp,_) = () +let open_constant (sp,_) = + Nametab.push_short_name (basename sp) (ConstRef sp) let export_constant x = Some x @@ -216,11 +229,17 @@ let cache_inductive (sp,mie) = let names = inductive_names sp mie in List.iter check_exists_inductive names; Global.add_mind sp mie (current_section_context ()); - List.iter (fun (sp, ref) -> Nametab.push sp ref) names + List.iter (fun (sp, ref) -> Nametab.push sp ref; Nametab.push_short_name + (basename sp) ref) names -let load_inductive _ = () +let load_inductive (sp,mie) = + let names = inductive_names sp mie in + List.iter check_exists_inductive names; + List.iter (fun (sp, ref) -> Nametab.push sp ref) names -let open_inductive (sp,mie) = () +let open_inductive (sp,mie) = + let names = inductive_names sp mie in + List.iter (fun (sp, ref) -> Nametab.push_short_name (basename sp) ref) names let export_inductive x = Some x @@ -481,8 +500,7 @@ let elimination_suffix = function | Prop Null -> "_ind" | Prop Pos -> "_rec" -let make_elimination_ident id s = - id_of_string ((string_of_id id) ^ (elimination_suffix s)) +let make_elimination_ident id s = add_suffix id (elimination_suffix s) let declare_one_elimination mispec = let mindstr = string_of_id (mis_typename mispec) in @@ -524,7 +542,7 @@ let declare_eliminations sp = let lookup_eliminator env path s = let dir, base,k = repr_path path in - let id = id_of_string ((string_of_id base)^(elimination_suffix s)) in + let id = add_suffix base (elimination_suffix s) in (* Try first to get an eliminator defined in the same section as the *) (* inductive type *) try construct_absolute_reference env (Names.make_path dir id k) diff --git a/library/declare.mli b/library/declare.mli index ad462534f3..9bbd0b8f40 100644 --- a/library/declare.mli +++ b/library/declare.mli @@ -14,6 +14,7 @@ open Term open Sign open Declarations open Inductive +open Library (*i*) (* This module provides the official functions to declare new variables, @@ -23,7 +24,7 @@ open Inductive reset works properly --- and will fill some global tables such as [Nametab] and [Impargs]. *) -type strength = +type strength = | NotDeclare | DischargeAt of dir_path | NeverDischarge @@ -64,7 +65,7 @@ val declare_eliminations : mutual_inductive_path -> unit val out_inductive : Libobject.obj -> mutual_inductive_entry -val make_strength : string list -> strength +val make_strength : dir_path -> strength val make_strength_0 : unit -> strength val make_strength_1 : unit -> strength val make_strength_2 : unit -> strength diff --git a/library/global.ml b/library/global.ml index b4f45ad69c..ea5506969a 100644 --- a/library/global.ml +++ b/library/global.ml @@ -31,7 +31,7 @@ let _ = { freeze_function = (fun () -> !global_env); unfreeze_function = (fun fr -> global_env := fr); init_function = (fun () -> global_env := empty_environment); - survive_section = true } + survive_section = false } (* Then we export the functions of [Typing] on that environment. *) diff --git a/library/global.mli b/library/global.mli index c463bd1534..51acc840ee 100644 --- a/library/global.mli +++ b/library/global.mli @@ -50,7 +50,7 @@ val lookup_mind_specif : inductive -> inductive_instance val set_opaque : section_path -> unit val set_transparent : section_path -> unit -val export : string -> compiled_env +val export : dir_path -> compiled_env val import : compiled_env -> unit (*s Some functions of [Environ] instanciated on the global environment. *) diff --git a/library/lib.ml b/library/lib.ml index 9438713d6c..8fc7a4e9cb 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -17,9 +17,9 @@ open Summary type node = | Leaf of obj | Module of dir_path - | OpenedSection of string * Summary.frozen + | OpenedSection of module_ident * Summary.frozen (* bool is to tell if the section must be opened automatically *) - | ClosedSection of bool * string * library_segment + | ClosedSection of bool * module_ident * library_segment | FrozenState of Summary.frozen and library_entry = section_path * node @@ -36,16 +36,16 @@ and library_segment = library_entry list let lib_stk = ref ([] : (section_path * node) list) +let default_module = make_dirpath [id_of_string "Scratch"] let module_name = ref None -let path_prefix = ref ([Nametab.default_root] : dir_path) +let path_prefix = ref (default_module : dir_path) let module_sp () = - match !module_name with Some m -> m | None -> [Nametab.default_root] + match !module_name with Some m -> m | None -> default_module let recalc_path_prefix () = let rec recalc = function - | (sp, OpenedSection _) :: _ -> - let (pl,id,_) = repr_path sp in pl@[string_of_id id] + | (sp, OpenedSection (modid,_)) :: _ -> (dirpath sp)@[modid] | _::l -> recalc l | [] -> module_sp () in @@ -112,12 +112,13 @@ let contents_after = function (* Sections. *) -let open_section s = - let sp = make_path (id_of_string s) OBJ in - if Nametab.exists_module sp then - errorlabstrm "open_section" [< 'sTR (s^" already exists") >]; - add_entry sp (OpenedSection (s, freeze_summaries())); - path_prefix := !path_prefix @ [s]; +let open_section id = + let dir = !path_prefix @ [id] in + let sp = make_path id OBJ in + if Nametab.exists_section dir then + errorlabstrm "open_section" [< pr_id id; 'sTR " already exists" >]; + add_entry sp (OpenedSection (id, freeze_summaries())); + path_prefix := dir; sp let check_for_module () = @@ -130,13 +131,23 @@ let check_for_module () = let start_module s = if !module_name <> None then error "a module is already started"; - if !path_prefix <> [Nametab.default_root] then + if !path_prefix <> default_module then error "some sections are already opened"; module_name := Some s; + (match split_dirpath s with [],id -> Nametab.push_library_root id | _ -> ()); Univ.set_module s; let _ = add_anonymous_entry (Module s) in path_prefix := s +let end_module s = + match !module_name with + | None -> error "no module declared" + | Some m -> + let bm = snd (split_dirpath m) in + if bm <> s then + error ("The current open module has basename "^(string_of_id bm)); + m + let is_opened_section = function (_,OpenedSection _) -> true | _ -> false let sections_are_opened () = @@ -156,11 +167,11 @@ let export_segment seg = in clean [] seg -let close_section export s = +let close_section export id = let sp,fs = try match find_entry_p is_opened_section with - | sp,OpenedSection (s',fs) -> - if s <> s' then error "this is not the last opened section"; (sp,fs) + | sp,OpenedSection (id',fs) -> + if id<>id' then error "this is not the last opened section"; (sp,fs) | _ -> assert false with Not_found -> error "no opened section" @@ -169,16 +180,14 @@ let close_section export s = lib_stk := before; let after' = export_segment after in pop_path_prefix (); - add_entry - (make_path (id_of_string s) OBJ) (ClosedSection (export, s,after')); + add_entry (make_path id OBJ) (ClosedSection (export, id, after')); (sp,after,fs) (* The following function exports the whole library segment, that will be saved as a module. Objects are presented in chronological order, and frozen states are removed. *) -let export_module f = - if !module_name = None then error "no module declared"; +let export_module s = export_segment !lib_stk (* Backtracking. *) @@ -214,8 +223,8 @@ let reset_name id = (* [dir] is a section dir if [module] < [dir] <= [path_prefix] *) let is_section_p sp = - not (dirpath_prefix_of sp (module_sp ())) - & (dirpath_prefix_of sp !path_prefix) + not (is_dirpath_prefix_of sp (module_sp ())) + & (is_dirpath_prefix_of sp !path_prefix) (* State and initialization. *) diff --git a/library/lib.mli b/library/lib.mli index 9b5326db1e..b22839a3da 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -21,8 +21,8 @@ open Summary type node = | Leaf of obj | Module of dir_path - | OpenedSection of string * Summary.frozen - | ClosedSection of bool * string * library_segment + | OpenedSection of module_ident * Summary.frozen + | ClosedSection of bool * module_ident * library_segment | FrozenState of Summary.frozen and library_entry = section_path * node @@ -47,9 +47,9 @@ val contents_after : section_path option -> library_segment (*s Opening and closing a section. *) -val open_section : string -> section_path +val open_section : identifier -> section_path val close_section : - export:bool -> string -> section_path * library_segment * Summary.frozen + export:bool -> identifier -> section_path * library_segment * Summary.frozen val sections_are_opened : unit -> bool val make_path : identifier -> path_kind -> section_path @@ -57,7 +57,8 @@ val cwd : unit -> dir_path val is_section_p : dir_path -> bool val start_module : dir_path -> unit -val export_module : unit -> library_segment +val end_module : module_ident -> dir_path +val export_module : dir_path -> library_segment (*s Backtracking (undo). *) diff --git a/library/library.ml b/library/library.ml index a6b7b50127..5556bf32ee 100644 --- a/library/library.ml +++ b/library/library.ml @@ -10,7 +10,7 @@ open Pp open Util -open System + open Names open Environ open Libobject @@ -19,72 +19,112 @@ open Nametab (*s Load path. *) -let load_path = ref ([] : load_path) +type logical_path = dir_path + +let load_path = ref ([],[] : System.physical_path list * logical_path list) -let get_load_path () = !load_path +let get_load_path () = fst !load_path -let add_load_path_entry lpe = load_path := lpe :: !load_path +let find_logical_path dir = + match list_filter2 (fun p d -> p = dir) !load_path with + | _,[dir] -> dir + | _ -> anomaly ("Two logical paths are associated to "^dir) let remove_path dir = - load_path := List.filter (fun lpe -> lpe.directory <> dir) !load_path + load_path := list_filter2 (fun p d -> p <> dir) !load_path + +let add_load_path_entry (phys_path,coq_path) = + match list_filter2 (fun p d -> p = phys_path) !load_path with + | _,[dir] -> + if dir <> coq_path && coq_path <> Nametab.default_root_prefix then + (* Assume the user is concerned by module naming *) + begin + if dir <> Nametab.default_root_prefix then + warning (phys_path^" was previously bound to " + ^(string_of_dirpath dir) + ^("\nIt is remapped to "^(string_of_dirpath coq_path))); + remove_path phys_path; + load_path := (phys_path::fst !load_path, coq_path::snd !load_path) + end + | _,[] -> + load_path := (phys_path :: fst !load_path, coq_path :: snd !load_path) + | _ -> anomaly ("Two logical paths are associated to "^phys_path) + +let physical_paths (dp,lp) = dp + +let load_path_of_logical_path dir = + fst (list_filter2 (fun p d -> d = dir) !load_path) + +let get_full_load_path () = List.combine (fst !load_path) (snd !load_path) (*s Modules on disk contain the following informations (after the magic number, and before the digest). *) +type compilation_unit_name = dir_path + type module_disk = { - md_name : string; + md_name : compilation_unit_name; md_compiled_env : compiled_env; md_declarations : library_segment; - md_nametab : module_contents; - md_deps : (string * Digest.t * bool) list } + md_deps : (compilation_unit_name * Digest.t * bool) list } (*s Modules loaded in memory contain the following informations. They are kept in the global table [modules_table]. *) type module_t = { - module_name : string; - module_filename : load_path_entry * string; + module_name : compilation_unit_name; + module_filename : System.physical_path; module_compiled_env : compiled_env; module_declarations : library_segment; - module_nametab : module_contents; mutable module_opened : bool; mutable module_exported : bool; - module_deps : (string * Digest.t * bool) list; + module_deps : (compilation_unit_name * Digest.t * bool) list; module_digest : Digest.t } -let modules_table = ref Stringmap.empty +module CompUnitOrdered = + struct + type t = dir_path + let compare = Pervasives.compare + end + +module CompUnitmap = Map.Make(CompUnitOrdered) + +let modules_table = ref CompUnitmap.empty let _ = Summary.declare_summary "MODULES" { Summary.freeze_function = (fun () -> !modules_table); Summary.unfreeze_function = (fun ft -> modules_table := ft); - Summary.init_function = (fun () -> modules_table := Stringmap.empty); - Summary.survive_section = true } + Summary.init_function = (fun () -> modules_table := CompUnitmap.empty); + Summary.survive_section = false } let find_module s = try - Stringmap.find s !modules_table + CompUnitmap.find s !modules_table with Not_found -> - error ("Unknown module " ^ s) + error ("Unknown module " ^ (string_of_dirpath s)) -let module_is_loaded s = - try let _ = Stringmap.find s !modules_table in true with Not_found -> false +let module_is_loaded dir = + try let _ = CompUnitmap.find dir !modules_table in true + with Not_found -> false -let module_is_opened s = (find_module s).module_opened +let module_is_opened s = (find_module [id_of_string s]).module_opened let loaded_modules () = - Stringmap.fold (fun s _ l -> s :: l) !modules_table [] + CompUnitmap.fold (fun s _ l -> s :: l) !modules_table [] let opened_modules () = - Stringmap.fold + CompUnitmap.fold (fun s m l -> if m.module_opened then s :: l else l) !modules_table [] +let compunit_cache = ref Stringmap.empty + let module_segment = function | None -> contents_after None | Some m -> (find_module m).module_declarations -let module_filename m = (find_module m).module_filename +let module_full_filename m = (find_module m).module_filename let vo_magic_number = 0700 @@ -106,7 +146,9 @@ let segment_iter f = let rec apply = function | sp,Leaf obj -> f (sp,obj) | _,OpenedSection _ -> assert false - | _,ClosedSection (export,s,seg) -> if export then iter seg + | sp,ClosedSection (export,s,seg) -> + push_section (wd_of_sp sp); + if export then iter seg | _,(FrozenState _ | Module _) -> () and iter seg = List.iter apply seg @@ -125,7 +167,6 @@ let rec open_module force s = if force or not m.module_opened then begin List.iter (fun (m,_,exp) -> if exp then open_module force m) m.module_deps; open_objects m.module_declarations; - open_module_contents (make_qualid [] (id_of_string s)); m.module_opened <- true end @@ -138,60 +179,198 @@ let import_module = open_module true then same value as for caller is reused in recursive loadings). *) let load_objects decls = - segment_rec_iter load_object decls +(* segment_rec_iter load_object decls*) + segment_iter load_object decls + +exception LibUnmappedDir +exception LibNotFound +type library_location = LibLoaded | LibInPath -let rec load_module_from s f = +let locate_absolute_library dir = + (* Look if loaded *) try - Stringmap.find s !modules_table + let m = CompUnitmap.find dir !modules_table in + (LibLoaded, dir, m.module_filename) with Not_found -> - let (lpe,fname,ch) = - try raw_intern_module (get_load_path ()) f - with System.Bad_magic_number fname -> - errorlabstrm "load_module_from" - [< 'sTR"file "; 'sTR fname; 'sPC; 'sTR"has bad magic number."; - 'sPC; 'sTR"It is corrupted"; 'sPC; - 'sTR"or was compiled with another version of Coq." >] in - let md = System.marshal_in ch in - let digest = System.marshal_in ch in - close_in ch; - let m = { module_name = md.md_name; - module_filename = (lpe,fname); - module_compiled_env = md.md_compiled_env; - module_declarations = md.md_declarations; - module_nametab = md.md_nametab; - module_opened = false; - module_exported = false; - module_deps = md.md_deps; - module_digest = digest } in - if s <> md.md_name then - error ("The file " ^ fname ^ " does not contain module " ^ s); - List.iter (load_mandatory_module s) m.module_deps; - Global.import m.module_compiled_env; - load_objects m.module_declarations; - let sp = Names.make_path lpe.coq_dirpath (id_of_string s) CCI in - push_module sp m.module_nametab; - modules_table := Stringmap.add s m !modules_table; - m - -and load_mandatory_module caller (s,d,_) = - let m = load_module_from s s in + (* Look if in loadpath *) + try + let pref, base = split_dirpath dir in + let loadpath = load_path_of_logical_path pref in + if loadpath = [] then raise LibUnmappedDir; + let name = (string_of_id base)^".vo" in + let _, file = System.where_in_path loadpath name in + (LibInPath, dir, file) + with Not_found -> raise LibNotFound + +let with_magic_number_check f a = + try f a + with System.Bad_magic_number fname -> + errorlabstrm "load_module_from" + [< 'sTR"file "; 'sTR fname; 'sPC; 'sTR"has bad magic number."; + 'sPC; 'sTR"It is corrupted"; 'sPC; + 'sTR"or was compiled with another version of Coq." >] + +let rec load_module = function + | (LibLoaded, dir, _) -> + CompUnitmap.find dir !modules_table + | (LibInPath, dir, f) -> + (* [dir] is an absolute name which matches [f] *) + let md, digest = + try Stringmap.find f !compunit_cache + with Not_found -> + let ch = with_magic_number_check raw_intern_module f in + let md = System.marshal_in ch in + let digest = System.marshal_in ch in + close_in ch; + if dir <> md.md_name then + errorlabstrm "load_module" + [< 'sTR ("The file " ^ f ^ " contains module"); 'sPC; + pr_dirpath md.md_name; 'sPC; 'sTR "and not module"; 'sPC; + pr_dirpath dir >]; + (match split_dirpath dir with + | [], id -> Nametab.push_library_root id + | _ -> ()); + compunit_cache := Stringmap.add f (md, digest) !compunit_cache; + (md, digest) in + intern_module digest f md + +and intern_module digest fname md = + let m = { module_name = md.md_name; + module_filename = fname; + module_compiled_env = md.md_compiled_env; + module_declarations = md.md_declarations; + module_opened = false; + module_exported = false; + module_deps = md.md_deps; + module_digest = digest } in + List.iter (load_mandatory_module md.md_name) m.module_deps; + Global.import m.module_compiled_env; + load_objects m.module_declarations; + modules_table := CompUnitmap.add md.md_name m !modules_table; + Nametab.push_loaded_library md.md_name; + m + +and load_mandatory_module caller (dir,d,_) = + let m = load_absolute_module_from dir in if d <> m.module_digest then - error ("module "^caller^" makes inconsistent assumptions over module "^s) - -let load_module s = function - | None -> ignore (load_module_from s s) - | Some f -> ignore (load_module_from s f) + error ("compiled module "^(string_of_dirpath caller)^ + " makes inconsistent assumptions over module " + ^(string_of_dirpath dir)) +and load_absolute_module_from dir = + try + load_module (locate_absolute_library dir) + with + | LibUnmappedDir -> + let prefix, dir = fst (split_dirpath dir), string_of_dirpath dir in + errorlabstrm "load_module" + [< 'sTR ("Cannot load "^dir^":"); 'sPC; + 'sTR "no physical path bound to"; 'sPC; pr_dirpath prefix; 'fNL >] + | LibNotFound -> + errorlabstrm "load_module" + [< 'sTR"Cannot find module "; pr_dirpath dir; 'sTR" in loadpath">] + | _ -> assert false + +let try_locate_qualified_library qid = + (* Look if loaded *) + try + let dir = Nametab.locate_loaded_library qid in + (LibLoaded, dir, module_full_filename dir) + with Not_found -> + (* Look if in loadpath *) + try + let dir, base = repr_qualid qid in + let loadpath = + if dir = [] then get_load_path () + else if is_absolute_dirpath dir then + load_path_of_logical_path dir + else + error + ("Not loaded partially qualified library names not implemented: " + ^(string_of_qualid qid)) + in + if loadpath = [] then raise LibUnmappedDir; + let name = (string_of_id base)^".vo" in + let path, file = System.where_in_path loadpath name in + (LibInPath, find_logical_path path@[base], file) + with Not_found -> raise LibNotFound + +let locate_qualified_library qid = + try + try_locate_qualified_library qid + with + | LibUnmappedDir -> + let prefix, id = repr_qualid qid in + errorlabstrm "load_module" + [< 'sTR ("Cannot load "^(string_of_id id)^":"); 'sPC; + 'sTR "no physical path bound to"; 'sPC; pr_dirpath prefix; 'fNL >] + | LibNotFound -> + errorlabstrm "load_module" + [< 'sTR"Cannot find module "; pr_qualid qid; 'sTR" in loadpath">] + | _ -> assert false + +let check_module_short_name f dir = function + | Some id when id <> snd (split_dirpath dir) -> + errorlabstrm "load_module" + [< 'sTR ("The file " ^ f ^ " contains module"); 'sPC; + pr_dirpath dir; 'sPC; 'sTR "and not module"; 'sPC; + pr_id id >] + | _ -> () + +let locate_by_filename_only id f = + let ch = with_magic_number_check raw_intern_module f in + let md = System.marshal_in ch in + let digest = System.marshal_in ch in + close_in ch; + (* Only the base name is expected to match *) + check_module_short_name f md.md_name id; + (* We check no other file containing same module is loaded *) + try + let m = CompUnitmap.find md.md_name !modules_table in + warning ((string_of_dirpath md.md_name)^" is already loaded from file "^ + m.module_filename); + (LibLoaded, md.md_name, m.module_filename) + with Not_found -> + (match split_dirpath md.md_name with + | [], id -> Nametab.push_library_root id + | _ -> ()); + compunit_cache := Stringmap.add f (md, digest) !compunit_cache; + (LibInPath, md.md_name, f) + +let locate_module qid = function + | Some f -> + (* A name is specified, we have to check it contains module id *) + let prefix, id = repr_qualid qid in + assert (prefix = []); + let _, f = System.find_file_in_path (get_load_path ()) (f^".vo") in + locate_by_filename_only (Some id) f + | None -> + (* No name, we need to find the file name *) + locate_qualified_library qid + +let read_module qid = + ignore (load_module (locate_qualified_library qid)) + +let read_module_from_file f = + let _, f = System.find_file_in_path (get_load_path ()) (f^".vo") in + ignore (load_module (locate_by_filename_only None f)) + +let reload_module (modref, export) = + let m = load_module modref in + if export then m.module_exported <- true; + open_module false m.module_name (*s [require_module] loads and opens a module. This is a synchronized operation. *) -let cache_require (_,(name,file,export)) = - let m = load_module_from name file in +type module_reference = (library_location * CompUnitmap.key * Util.Stringmap.key) * bool + +let cache_require (_,(modref,export)) = + let m = load_module modref in if export then m.module_exported <- true; - open_module false name + open_module false m.module_name -let (in_require, _) = +let (in_require, out_require) = declare_object ("REQUIRE", { cache_function = cache_require; @@ -199,32 +378,28 @@ let (in_require, _) = open_function = (fun _ -> ()); export_function = (fun _ -> None) }) -let require_module spec name fileopt export = +let require_module spec qid fileopt export = (* Trop contraignant if sections_are_opened () then warning ("Objets of "^name^" not surviving sections (e.g. Grammar \nand Hints) will be removed at the end of the section"); *) - let file = match fileopt with - | None -> name - | Some f -> f - in - add_anonymous_leaf (in_require (name,file,export)); + let modref = locate_module qid fileopt in + add_anonymous_leaf (in_require (modref,export)); add_frozen_state () (*s [save_module s] saves the module [m] to the disk. *) let current_imports () = - Stringmap.fold + CompUnitmap.fold (fun _ m l -> (m.module_name, m.module_digest, m.module_exported) :: l) !modules_table [] -let save_module_to process s f = - let seg = export_module () in +let save_module_to s f = + let seg = export_module s in let md = { md_name = s; md_compiled_env = Global.export s; md_declarations = seg; - md_nametab = process seg; md_deps = current_imports () } in let (f',ch) = raw_extern_module f in try @@ -234,6 +409,7 @@ let save_module_to process s f = System.marshal_out ch di; close_out ch with e -> (warning ("Removed file "^f');close_out ch; Sys.remove f'; raise e) + (*s Iterators. *) let fold_all_segments insec f x = @@ -244,7 +420,7 @@ let fold_all_segments insec f x = | _ -> acc in let acc' = - Stringmap.fold + CompUnitmap.fold (fun _ m acc -> List.fold_left apply acc m.module_declarations) !modules_table x in @@ -256,7 +432,7 @@ let iter_all_segments insec f = | _, ClosedSection (_,_,seg) -> if insec then List.iter apply seg | _ -> () in - Stringmap.iter + CompUnitmap.iter (fun _ m -> List.iter apply m.module_declarations) !modules_table; List.iter apply (Lib.contents_after None) @@ -266,9 +442,9 @@ let fmt_modules_state () = let opened = opened_modules () and loaded = loaded_modules () in [< 'sTR "Imported (open) Modules: " ; - prlist_with_sep pr_spc (fun s -> [< 'sTR s >]) opened ; 'fNL ; - 'sTR "Loaded Modules: " ; - prlist_with_sep pr_spc (fun s -> [< 'sTR s >]) loaded ; 'fNL >] + prlist_with_sep pr_spc pr_dirpath opened ; 'fNL ; + 'sTR "Loaded Modules: "; + prlist_with_sep pr_spc pr_dirpath loaded ; 'fNL >] (*s Display the memory use of a module. *) @@ -276,6 +452,6 @@ open Printf let mem s = let m = find_module s in - h 0 [< 'sTR (sprintf "%dk (cenv = %dk / seg = %dk / nmt = %dk)" + h 0 [< 'sTR (sprintf "%dk (cenv = %dk / seg = %dk)" (size_kb m) (size_kb m.module_compiled_env) - (size_kb m.module_declarations) (size_kb m.module_nametab)) >] + (size_kb m.module_declarations)) >] diff --git a/library/library.mli b/library/library.mli index e5ad55e48c..3274f7361f 100644 --- a/library/library.mli +++ b/library/library.mli @@ -20,14 +20,15 @@ open Libobject provides a high level function [require] which corresponds to the vernacular command [Require]. *) -val load_module : string -> string option -> unit -val import_module : string -> unit +val read_module : Nametab.qualid -> unit +val read_module_from_file : System.physical_path -> unit +val import_module : dir_path -> unit -val module_is_loaded : string -> bool +val module_is_loaded : dir_path -> bool val module_is_opened : string -> bool -val loaded_modules : unit -> string list -val opened_modules : unit -> string list +val loaded_modules : unit -> dir_path list +val opened_modules : unit -> dir_path list val fmt_modules_state : unit -> Pp.std_ppcmds @@ -37,21 +38,21 @@ val fmt_modules_state : unit -> Pp.std_ppcmds ([false]), if not [None]. And [export] specifies if the module must be exported. *) -val require_module : bool option -> string -> string option -> bool -> unit +val require_module : + bool option -> Nametab.qualid -> string option -> bool -> unit (*s [save_module_to s f] saves the current environment as a module [s] in the file [f]. *) -val save_module_to : (Lib.library_segment -> Nametab.module_contents) -> - string -> string -> unit +val save_module_to : dir_path -> string -> unit (*s [module_segment m] returns the segment of the loaded module [m]; if not given, the segment of the current module is returned (which is then the same as [Lib.contents_after None]). - [module_filename] returns the full filename of a loaded module. *) + [module_full_filename] returns the full filename of a loaded module. *) -val module_segment : string option -> Lib.library_segment -val module_filename : string -> System.load_path_entry * string +val module_segment : dir_path option -> Lib.library_segment +val module_full_filename : dir_path -> string (*s [fold_all_segments] and [iter_all_segments] iterate over all segments, the modules' segments first and then the current @@ -63,10 +64,28 @@ val fold_all_segments : bool -> ('a -> section_path -> obj -> 'a) -> 'a -> 'a val iter_all_segments : bool -> (section_path -> obj -> unit) -> unit (*s Global load path *) -val get_load_path : unit -> System.load_path -val add_load_path_entry : System.load_path_entry -> unit -val remove_path : string -> unit +type logical_path = dir_path + +val get_load_path : unit -> System.physical_path list +val get_full_load_path : unit -> (System.physical_path * logical_path) list +val add_load_path_entry : System.physical_path * logical_path -> unit +val remove_path : System.physical_path -> unit +val find_logical_path : System.physical_path -> logical_path +val load_path_of_logical_path : dir_path -> System.physical_path list + +exception LibUnmappedDir +exception LibNotFound +type library_location = LibLoaded | LibInPath + +val locate_qualified_library : + Nametab.qualid -> library_location * dir_path * System.physical_path (*s Displays the memory use of a module. *) -val mem : string -> Pp.std_ppcmds +val mem : dir_path -> Pp.std_ppcmds + +(* For discharge *) +type module_reference + +val out_require : Libobject.obj -> module_reference +val reload_module : module_reference -> unit diff --git a/library/nametab.ml b/library/nametab.ml index aec5da6f90..3d7ca98f4e 100755 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -16,16 +16,20 @@ open Declarations open Term (*s qualified names *) -type qualid = string list * identifier +type qualid = dir_path * identifier let make_qualid p id = (p,id) let repr_qualid q = q -let string_of_qualid (l,id) = String.concat "." (l@[string_of_id id]) -let pr_qualid (l,id) = - prlist_with_sep (fun () -> pr_str ".") pr_str (l@[string_of_id id]) +let string_of_qualid (l,id) = + let dir = if l = [] then "" else string_of_dirpath l ^ "." in + dir ^ string_of_id id +let pr_qualid p = pr_str (string_of_qualid p) let qualid_of_sp sp = make_qualid (dirpath sp) (basename sp) +let qualid_of_dirpath dir = + let a,l = list_sep_last (repr_qualid dir) in + make_qualid l a exception GlobalizationError of qualid @@ -39,141 +43,161 @@ let error_global_not_found q = raise (GlobalizationError q) let roots = ref [] let push_library_root s = roots := list_add_set s !roots -let coq_root = "Coq" -let default_root = "Scratch" - -(* Names tables *) -type cci_table = global_reference Idmap.t -type obj_table = (section_path * obj) Idmap.t -type mod_table = (section_path * module_contents) Stringmap.t -and module_contents = Closed of cci_table * obj_table * mod_table - -let empty = - Closed (Idmap.empty, Idmap.empty, Stringmap.empty) - -let persistent_nametab = ref (empty : module_contents) -let local_nametab = ref (empty : module_contents) - -let push_cci (Closed (ccitab, objtab, modtab)) s ref = - Closed (Idmap.add s ref ccitab, objtab, modtab) - -let push_obj (Closed (ccitab, objtab, modtab)) s obj = - Closed (ccitab, Idmap.add s obj objtab, modtab) - -let push_mod (Closed (ccitab, objtab, modtab)) s mc = - (* devrait pas mais ca plante en décommentant la ligne ci-dessous *) - (* assert (not (Stringmap.mem s modtab)); *) - Closed (ccitab, objtab, Stringmap.add s mc modtab) - -let push_tree push dir id o = - let rec search (Closed (ccitab, objtab, modtab) as tabs) pref = function - | id :: dir' -> - let sp, mc = - try Stringmap.find id modtab - with Not_found -> - let pref = List.rev pref in - (make_path dir (id_of_string id) CCI, empty) +let coq_root = id_of_string "Coq" +let default_root_prefix = [] + +(* Constructions and syntactic definitions live in the same space *) +type extended_global_reference = + | TrueGlobal of global_reference + | SyntacticDef of section_path + +type 'a nametree = ('a option * 'a nametree ModIdmap.t) +type ccitab = extended_global_reference nametree Idmap.t +type objtab = section_path nametree Idmap.t +type dirtab = dir_path nametree ModIdmap.t + +let the_ccitab = ref (Idmap.empty : ccitab) +let the_libtab = ref (ModIdmap.empty : dirtab) +let the_sectab = ref (ModIdmap.empty : dirtab) +let the_objtab = ref (Idmap.empty : objtab) + +(* How necessarily_open works: concretely, roots and directory are + always open but libraries are open only during their interactive + construction or on demand if a precompiled one; then for a name + "Root.Rep.Lib.name", then "Lib.name", "Rep.Lib.name" and + "Root.Rep.Lib.name", but not "name" are pushed *) + +(* We add a binding of [[modid1;...;modidn;id]] to [o] in the name tab *) +(* We proceed in the reverse way, looking first to [id] *) +let push_tree tab dir o = + let rec push necessarily_open (current,dirmap) = function + | modid :: path as dir -> + let mc = + try ModIdmap.find modid dirmap + with Not_found -> (None, ModIdmap.empty) in - Closed (ccitab, objtab, - Stringmap.add id (sp,search mc (id::pref) dir') modtab) - | [] -> - push tabs id o in - persistent_nametab := search !persistent_nametab [] dir - -(* This pushes a name at the current level (for relative qualified use) *) -let push_cci_current = push_tree push_cci [] -let push_obj_current = push_tree push_obj [] -let push_mod_current = push_tree push_mod [] - -(* This pushes a name at the root level (for absolute access) *) -let push_cci_absolute = push_tree push_cci -let push_obj_absolute = push_tree push_obj -let push_mod_absolute = push_tree push_mod + let this = if necessarily_open then Some o else current in + (this, ModIdmap.add modid (push true mc path) dirmap) + | [] -> (Some o,dirmap) in + push false tab (List.rev dir) + +let push_idtree tab dir id o = + let modtab = + try Idmap.find id !tab + with Not_found -> (None, ModIdmap.empty) in + tab := Idmap.add id (push_tree modtab dir o) !tab + +let push_long_names_ccipath = push_idtree the_ccitab +let push_short_name_ccipath = push_idtree the_ccitab +let push_short_name_objpath = push_idtree the_objtab + +let push_modidtree tab dir id o = + let modtab = + try ModIdmap.find id !tab + with Not_found -> (None, ModIdmap.empty) in + tab := ModIdmap.add id (push_tree modtab dir o) !tab + +let push_long_names_secpath = push_modidtree the_sectab +let push_long_names_libpath = push_modidtree the_libtab (* These are entry points for new declarations at toplevel *) -(* Do not use with "open" since it pushes an absolute name too *) -let push sp ref = - let dir, s = repr_qualid (qualid_of_sp sp) in - push_cci_absolute dir s ref; - push_cci_current s ref -let push_object sp obj = - let dir, s = repr_qualid (qualid_of_sp sp) in - push_obj_absolute dir s (sp,obj); - push_obj_current s (sp,obj) +(* This is for permanent constructions (never discharged -- but with + possibly limited visibility, i.e. Theorem, Lemma, Definition, Axiom, + Parameter but also Remark and Fact) *) -let push_module sp mc = - let dir, s = repr_qualid (qualid_of_sp sp) in - let s = string_of_id s in - push_mod_absolute dir s (sp,mc); - if List.mem s !roots then - warning ("Cannot allow access to "^s^" by relative paths: it is already registered as a root of the Coq library") - else push_mod_current s (sp,mc) - -(* Sections are not accessible by basename *) -let push_section sp mc = +let push_cci sp ref = let dir, s = repr_qualid (qualid_of_sp sp) in - push_mod_absolute dir (string_of_id s) (sp,mc) + (* We push partially qualified name (with at least one prefix) *) + push_long_names_ccipath dir s (TrueGlobal ref) -(* This is an entry point for local declarations at toplevel *) -(* Do not use with "open" since it pushes an absolute name too *) +let push = push_cci -let push_cci_local s ref = - local_nametab := push_cci !local_nametab s ref +let push_short_name id ref = + (* We push a volatile unqualified name *) + push_short_name_ccipath [] id (TrueGlobal ref) -let push_obj_local s o = - local_nametab := push_obj !local_nametab s o +(* This is for Syntactic Definitions *) -let push_local sp ref = +let push_syntactic_definition sp = let dir, s = repr_qualid (qualid_of_sp sp) in - push_cci_absolute dir s ref; - push_cci_local s ref + push_long_names_ccipath dir s (SyntacticDef sp) -let push_local_object sp obj = - let dir, s = repr_qualid (qualid_of_sp sp) in - push_obj_absolute dir s (sp,obj); - push_obj_local s (sp,obj) +let push_short_name_syntactic_definition sp = + let _, s = repr_qualid (qualid_of_sp sp) in + push_short_name_ccipath [] s (SyntacticDef sp) + +(* This is for dischargeable non-cci objects (removed at the end of the + section -- i.e. Hints, Grammar ...) *) (* --> Unused *) + +let push_short_name_object sp = + push_short_name_objpath [] (basename sp) sp + +(* This is to remember absolute Section/Module names and to avoid redundancy *) + +let push_section fulldir = + let dir, s = split_dirpath fulldir in + (* We push all partially qualified name *) + push_long_names_secpath dir s fulldir; + push_long_names_secpath [] s fulldir (* These are entry points to locate names *) (* If the name starts with the coq_root name, then it is an absolute name *) -let locate qid = - let (dir,id) = repr_qualid qid in - let rec search (Closed (ccitab,_,modtab)) = function - | id :: dir' -> search (snd (Stringmap.find id modtab)) dir' - | [] -> Idmap.find id ccitab +let locate_in_tree tab dir = + let dir = List.rev dir in + let rec search (current,modidtab) = function + | modid :: path -> search (ModIdmap.find modid modidtab) path + | [] -> match current with Some o -> o | _ -> raise Not_found in - try search !local_nametab dir - with Not_found -> search !persistent_nametab dir + search tab dir + +let locate_cci qid = + let (dir,id) = repr_qualid qid in + locate_in_tree (Idmap.find id !the_ccitab) dir + +(* This should be used when syntactic definitions are allowed *) +let extended_locate = locate_cci + +(* This should be used when no syntactic definitions is expected *) +let locate qid = match locate_cci qid with + | TrueGlobal ref -> ref + | SyntacticDef _ -> raise Not_found let locate_obj qid = let (dir,id) = repr_qualid qid in - let rec search (Closed (_,objtab,modtab)) = function - | id :: dir' -> search (snd (Stringmap.find id modtab)) dir' - | [] -> Idmap.find id objtab - in - try search !local_nametab dir - with Not_found -> search !persistent_nametab dir + locate_in_tree (Idmap.find id !the_objtab) dir + +(* Actually, this table has only two levels, since only basename and *) +(* fullname are registered *) +let push_loaded_library fulldir = + let dir, s = split_dirpath fulldir in + push_long_names_libpath dir s fulldir; + push_long_names_libpath [] s fulldir -let locate_module qid = +let locate_loaded_library qid = let (dir,id) = repr_qualid qid in - let s = string_of_id id in - let rec search (Closed (_,_,modtab)) = function - | id :: dir' -> search (snd (Stringmap.find id modtab)) dir' - | [] -> Stringmap.find s modtab - in - try search !local_nametab dir - with Not_found -> search !persistent_nametab dir + locate_in_tree (ModIdmap.find id !the_libtab) dir + +let locate_section qid = + let (dir,id) = repr_qualid qid in + locate_in_tree (ModIdmap.find id !the_sectab) dir + +(* Derived functions *) let locate_constant qid = - match locate qid with - | ConstRef sp -> sp + match locate_cci qid with + | TrueGlobal (ConstRef sp) -> sp | _ -> raise Not_found -let sp_of_id _ id = locate (make_qualid [] id) +let sp_of_id _ id = match locate_cci (make_qualid [] id) with + | TrueGlobal ref -> ref + | SyntacticDef _ -> + anomaly ("sp_of_id: "^(string_of_id id) + ^" is not a true global reference but a syntactic definition") let constant_sp_of_id id = - match locate (make_qualid [] id) with - | ConstRef sp -> sp + match locate_cci (make_qualid [] id) with + | TrueGlobal (ConstRef sp) -> sp | _ -> raise Not_found let check_absoluteness dir = @@ -181,29 +205,19 @@ let check_absoluteness dir = | a::_ when List.mem a !roots -> () | _ -> anomaly ("Not an absolute dirpath: "^(string_of_dirpath dir)) +let is_absolute_dirpath = function + | a::_ when List.mem a !roots -> true + | _ -> false + let absolute_reference sp = check_absoluteness (dirpath sp); locate (qualid_of_sp sp) -exception Found of global_reference -let locate_in_module dir id = - let rec exists_in id (Closed (ccitab,_,modtab)) = - try raise (Found (Idmap.find id ccitab)) - with Not_found -> - Stringmap.iter (fun _ (sp,mc) -> exists_in id mc) modtab - in - let rec search (Closed (ccitab,_,modtab) as mc) = function - | modid :: dir' -> search (snd (Stringmap.find modid modtab)) dir' - | [] -> - try exists_in id mc; raise Not_found - with Found ref -> ref - in - search !persistent_nametab dir - let locate_in_absolute_module dir id = check_absoluteness dir; - locate_in_module dir id + locate (make_qualid dir id) +(* (* These are entry points to make the contents of a module/section visible *) (* in the current env (does not affect the absolute name space `coq_root') *) let open_module_contents qid = @@ -229,40 +243,46 @@ let rec rec_open_module_contents qid = push_mod_current m mt; rec_open_module_contents (qualid_of_sp sp)) modtab - +*) let exists_cci sp = - try let _ = locate (qualid_of_sp sp) in true with Not_found -> false + try let _ = locate_cci (qualid_of_sp sp) in true + with Not_found -> false -let exists_module sp = - try let _ = locate_module (qualid_of_sp sp) in true with Not_found -> false +let exists_section dir = + try let _ = locate_section (qualid_of_dirpath dir) in true + with Not_found -> false (********************************************************************) -(* Registration of persistent tables as a global table and rollback *) - -type frozen = module_contents - -let init () = persistent_nametab := empty; roots := [] -let freeze () = !persistent_nametab, !roots -let unfreeze (mc,r) = persistent_nametab := mc; roots := r - -let _ = - Summary.declare_summary "persistent-names" - { Summary.freeze_function = freeze; - Summary.unfreeze_function = unfreeze; - Summary.init_function = init; - Summary.survive_section = true } (********************************************************************) -(* Registration of persistent tables as a global table and rollback *) - -let init () = local_nametab := empty -let freeze () = !local_nametab -let unfreeze mc = local_nametab := mc +(* Registration of tables as a global table and rollback *) + +type frozen = ccitab * dirtab * dirtab * objtab * identifier list + +let init () = + the_ccitab := Idmap.empty; + the_libtab := ModIdmap.empty; + the_sectab := ModIdmap.empty; + the_objtab := Idmap.empty; + roots := [] + +let freeze () = + !the_ccitab, + !the_libtab, + !the_sectab, + !the_objtab, + !roots + +let unfreeze (mc,ml,ms,mo,r) = + the_ccitab := mc; + the_libtab := ml; + the_sectab := ms; + the_objtab := mo; + roots := r let _ = - Summary.declare_summary "local-names" + Summary.declare_summary "names" { Summary.freeze_function = freeze; Summary.unfreeze_function = unfreeze; Summary.init_function = init; Summary.survive_section = false } - diff --git a/library/nametab.mli b/library/nametab.mli index 8506c7a5b5..927205dea9 100755 --- a/library/nametab.mli +++ b/library/nametab.mli @@ -18,6 +18,10 @@ open Term (*s This module contains the table for globalization, which associates global names (section paths) to qualified names. *) +type extended_global_reference = + | TrueGlobal of global_reference + | SyntacticDef of section_path + (*s A [qualid] is a partially qualified ident; it includes fully qualified names (= absolute names) and all intermediate partial qualifications of absolute names, including single identifiers *) @@ -38,19 +42,17 @@ exception GlobalizationError of qualid val error_global_not_found_loc : loc -> qualid -> 'a val error_global_not_found : qualid -> 'a -(*s Names tables *) -type cci_table = global_reference Idmap.t -type obj_table = (section_path * Libobject.obj) Idmap.t -type mod_table = (section_path * module_contents) Stringmap.t -and module_contents = Closed of cci_table * obj_table * mod_table - -(*s Registers absolute paths *) +(*s Register visibility of absolute paths by qualified names *) val push : section_path -> global_reference -> unit -val push_object : section_path -> Libobject.obj -> unit -val push_module : section_path -> module_contents -> unit +val push_syntactic_definition : section_path -> unit + +(*s Register visibility of absolute paths by short names *) +val push_short_name : identifier -> global_reference -> unit +val push_short_name_syntactic_definition : section_path -> unit +val push_short_name_object : section_path -> unit -val push_local : section_path -> global_reference -> unit -val push_local_object : section_path -> Libobject.obj -> unit +(*s Register visibility by all qualifications *) +val push_section : dir_path -> unit (* This should eventually disappear *) val sp_of_id : path_kind -> identifier -> global_reference @@ -61,37 +63,47 @@ val sp_of_id : path_kind -> identifier -> global_reference val constant_sp_of_id : identifier -> section_path val locate : qualid -> global_reference -val locate_obj : qualid -> (section_path * Libobject.obj) + +(* This locates also syntactic definitions *) +val extended_locate : qualid -> extended_global_reference + +val locate_obj : qualid -> section_path + val locate_constant : qualid -> constant_path -val locate_module : qualid -> section_path * module_contents +val locate_section : qualid -> dir_path (* [exists sp] tells if [sp] is already bound to a cci term *) val exists_cci : section_path -> bool -val exists_module : section_path -> bool - +val exists_section : dir_path -> bool +(* val open_module_contents : qualid -> unit val rec_open_module_contents : qualid -> unit (*s Entry points for sections *) val open_section_contents : qualid -> unit val push_section : section_path -> module_contents -> unit - +*) (*s Roots of the space of absolute names *) (* This is the root of the standard library of Coq *) -val coq_root : string +val coq_root : module_ident -(* This is the default root for developments which doesn't mention a root *) -val default_root : string +(* This is the default root prefix for developments which doesn't mention a root *) +val default_root_prefix : dir_path (* This is to declare a new root *) -val push_library_root : string -> unit +val push_library_root : module_ident -> unit (* This turns a "user" absolute name into a global reference; especially, constructor/inductive names are turned into internal references inside a block of mutual inductive *) val absolute_reference : section_path -> global_reference +val is_absolute_dirpath : dir_path -> bool + (* [locate_in_absolute_module dir id] finds [id] in module [dir] or in one of its section/subsection *) val locate_in_absolute_module : dir_path -> identifier -> global_reference + +val push_loaded_library : dir_path -> unit +val locate_loaded_library : qualid -> dir_path diff --git a/parsing/ast.ml b/parsing/ast.ml index b870371274..dc751186f7 100755 --- a/parsing/ast.ml +++ b/parsing/ast.ml @@ -21,11 +21,13 @@ let dummy_loc = (0,0) let loc = function | Node (loc,_,_) -> loc | Nvar (loc,_) -> loc + | Nmeta (loc,_) -> loc | Slam (loc,_,_) -> loc + | Smetalam (loc,_,_) -> loc | Num (loc,_) -> loc | Id (loc,_) -> loc | Str (loc,_) -> loc - | Path (loc,_,_) -> loc + | Path (loc,_) -> loc | Dynamic (loc,_) -> loc (* building a node with dummy location *) @@ -36,27 +38,24 @@ let ide s = Id(dummy_loc,s) let nvar s = Nvar(dummy_loc,s) let num n = Num(dummy_loc,n) let str s = Str(dummy_loc,s) -let path sl s = Path(dummy_loc,sl,s) +let path sl = Path(dummy_loc,sl) let dynamic d = Dynamic(dummy_loc,d) let rec set_loc loc = function | Node(_,op,al) -> Node(loc, op, List.map (set_loc loc) al) | Slam(_,idl,b) -> Slam(loc,idl, set_loc loc b) + | Smetalam(_,idl,b) -> Smetalam(loc,idl, set_loc loc b) | Nvar(_,s) -> Nvar(loc,s) + | Nmeta(_,s) -> Nmeta(loc,s) | Id(_,s) -> Id(loc,s) | Str(_,s) -> Str(loc,s) | Num(_,s) -> Num(loc,s) - | Path(_,sl,s) -> Path(loc,sl,s) + | Path(_,sl) -> Path(loc,sl) | Dynamic(_,d) -> Dynamic(loc,d) -let path_section loc sp = - let (sl,bn,pk) = repr_path sp in - Coqast.Path(loc, sl @ [string_of_id bn], string_of_kind pk) +let path_section loc sp = Coqast.Path(loc, sp) -let section_path sl k = - match List.rev sl with - | s::pa -> make_path (List.rev pa) (id_of_string s) (kind_of_string k) - | [] -> invalid_arg "section_path" +let section_path sp = sp (* ast destructors *) let num_of_ast = function @@ -76,7 +75,7 @@ type pat = | Pquote of t | Pmeta of string * tok_kind | Pnode of string * patlist - | Pslam of string option * pat + | Pslam of identifier option * pat | Pmeta_slam of string * pat and patlist = @@ -105,15 +104,16 @@ let rec print_ast ast = match ast with | Num(_,n) -> [< 'iNT n >] | Str(_,s) -> [< 'qS s >] - | Path(_,sl,u) -> - [< prlist (fun s -> [< 'sTR"#"; 'sTR s >]) sl; 'sTR"."; 'sTR u >] + | Path(_,sl) -> [< pr_sp sl >] | Id (_,s) -> [< 'sTR"{" ; 'sTR s ; 'sTR"}" >] - | Nvar(_,s) -> [< 'sTR s >] + | Nvar(_,s) -> [< pr_id s >] + | Nmeta(_,s) -> [< 'sTR s >] | Node(_,op,l) -> hOV 3 [< 'sTR"(" ; 'sTR op ; 'sPC ; print_astl l; 'sTR")" >] | Slam(_,None,ast) -> hOV 1 [< 'sTR"[<>]"; print_ast ast >] | Slam(_,Some x,ast) -> - hOV 1 [< 'sTR"["; 'sTR x; 'sTR"]"; 'cUT; print_ast ast >] + hOV 1 [< 'sTR"["; pr_id x; 'sTR"]"; 'cUT; print_ast ast >] + | Smetalam(_,id,ast) -> hOV 1 [< 'sTR id; print_ast ast >] | Dynamic(_,d) -> hOV 0 [< 'sTR"<dynamic: "; 'sTR(Dyn.tag d); 'sTR">" >] @@ -137,8 +137,8 @@ let rec print_astpat = function | Pnode(op,al) -> hOV 2 [< 'sTR"(" ; 'sTR op; 'sPC; print_astlpat al; 'sTR")" >] | Pslam(None,b) -> hOV 1 [< 'sTR"[<>]"; 'cUT; print_astpat b >] - | Pslam(Some s,b) -> - hOV 1 [< 'sTR"["; 'sTR s; 'sTR"]"; 'cUT; print_astpat b >] + | Pslam(Some id,b) -> + hOV 1 [< 'sTR"["; pr_id id; 'sTR"]"; 'cUT; print_astpat b >] and print_astlpat = function | Pnil -> [< >] @@ -172,14 +172,20 @@ let check_cast loc a k = | _ -> user_err_loc (loc,"Ast.cast_val", [< 'sTR"cast _"; print_ast_cast k; 'sTR"failed" >]) -let rec coerce_to_var v = function - | Nvar(_,id) -> id - | Node(_,"QUALID",[Nvar(_,id)]) -> id - | Node(_,"QUALIDARG",[Nvar(_,id)]) -> id +let rec coerce_to_var = function + | Nvar(_,id) as var -> var + | Nmeta(_,id) as var -> var + | Node(_,"QUALID",[Nvar(_,id) as var]) -> var + | Node(_,"QUALIDARG",[Nvar(_,id) as var]) -> var | ast -> user_err_loc (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 + | Nvar (_,id) -> id +(* | Nmeta(_,id) -> id_of_string id*) + | ast -> invalid_arg "coerce_to_id" + let env_assoc_value loc v env = try List.assoc v env @@ -200,8 +206,8 @@ let env_assoc sigma k (loc,v) = let env_assoc_nvars sigma (dloc,v) = match env_assoc_value dloc v sigma with - | Vastlist al -> List.map (coerce_to_var v) al - | Vast ast -> [coerce_to_var v ast] + | Vastlist al -> List.map coerce_to_id al + | Vast ast -> [coerce_to_id ast] let build_lams dloc idl ast = List.fold_right (fun id lam -> Slam(dloc,Some id,lam)) idl ast @@ -253,14 +259,16 @@ let check_ast_meta env loc pv = let rec val_of_ast env ast = match ast with - | Nvar(loc,pv) when isMeta pv -> + | Nmeta(loc,pv) -> check_ast_meta env loc pv; Pmeta(pv,Tany) +(* | Id(loc,pv) when isMeta pv -> check_ast_meta env loc pv; Pmeta(pv,Tid) +*) | Node(_,"$QUOTE",[qast]) -> Pquote (set_loc dummy_loc qast) - | Slam(loc,Some s,a) when isMeta s -> + | Smetalam(loc,s,a) -> let _ = type_of_meta env loc s in (* ids are coerced to id lists *) Pmeta_slam(s, val_of_ast env a) | (Path _|Num _|Id _|Str _|Nvar _) -> Pquote (set_loc dummy_loc ast) @@ -274,7 +282,7 @@ let rec val_of_ast env ast = and vall_of_astl env astl = match astl with - | (Node(loc,"$LIST",[Nvar(locv,pv)]))::asttl when isMeta pv -> + | (Node(loc,"$LIST",[Nmeta(locv,pv)]))::asttl -> if type_of_meta env locv pv = ETastl then if asttl = [] then Plmeta pv @@ -309,7 +317,9 @@ let rec alpha alp a1 a2 = | (Id(_,s1),Id(_,s2)) -> s1=s2 | (Str(_,s1),Str(_,s2)) -> s1=s2 | (Num(_,n1),Num(_,n2)) -> n1=n2 - | (Path(_,sl1,s1),Path(_,sl2,s2)) -> sl1=sl2 & s1=s2 + | (Path(_,sl1),Path(_,sl2)) -> sl1=sl2 + | ((Smetalam _ | Nmeta _ | Dynamic _), _) -> false + | (_, (Smetalam _ | Nmeta _ | Dynamic _)) -> false | _ -> false let alpha_eq (a1,a2)= alpha [] a1 a2 @@ -324,6 +334,7 @@ let alpha_eq_val = function let rec occur_var_ast s = function | Node(loc,op,args) -> List.exists (occur_var_ast s) args | Nvar(_,s2) -> s = s2 + | Smetalam _ | Nmeta _ -> anomaly "occur_var: metas should not occur here" | Slam(_,sopt,body) -> (Some s <> sopt) & occur_var_ast s body | Id _ | Str _ | Num _ | Path _ -> false | Dynamic _ -> (* Hum... what to do here *) false @@ -331,6 +342,7 @@ let rec occur_var_ast s = function 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 @@ -342,7 +354,7 @@ exception No_match of string let no_match_loc (loc,s) = Stdpp.raise_with_loc loc (No_match s) -(* Binds value v to variable var. If var is already bound, checks if the +(* Binds value v to variable var. If var is already bound, checks if its value is alpha convertible with v. This allows non-linear patterns. Important note: The Metavariable $_ is a special case; it cannot be @@ -390,6 +402,8 @@ let rec amatch alp sigma spat ast = | (Pmeta(pv,Tlist),_) -> grammar_type_error (loc ast,"Ast.amatch") | (Pmeta_slam(pv,pb), Slam(loc, Some s, b)) -> amatch alp (bind_env_ast sigma pv (Nvar(loc,s))) pb b + | (Pmeta_slam(pv,pb), Smetalam(loc, s, b)) -> + anomaly "amatch: match a pattern with an open ast" | (Pnode(nodp,argp), Node(loc,op,args)) when nodp = op -> (try amatchl alp sigma argp args with e -> Stdpp.raise_with_loc loc e) @@ -443,26 +457,35 @@ let make_astvar env loc v cast = (Pmeta(v,cast), env') (* Note: no metavar in operator position. necessary ? *) -(* TODO: $SLAM pour recuperer tous les Slam d'un coup dans une liste *) let rec pat_of_ast env ast = match ast with - | Nvar(loc,pv) when isMeta pv -> make_astvar env loc pv Tany + | Nmeta(loc,pv) -> make_astvar env loc pv Tany +(* Obsolète | Id(loc,pv) when isMeta pv -> make_astvar env loc pv Tid - | Slam(loc,Some s,a) when isMeta s -> +*) + | Smetalam(loc,s,a) -> let senv = bind_patvar env loc s ETast in let (pa,env') = pat_of_ast senv a in (Pmeta_slam(s, pa), env') - | Node(_,"$VAR",[Nvar(loc,pv)]) when isMeta pv -> + | Node(_,"$VAR",[Nmeta(loc,pv)]) -> make_astvar env loc pv Tvar - | Node(_,"$ID",[Nvar(loc,pv)]) when isMeta pv -> + | Node(_,"$ID",[Nmeta(loc,pv)]) -> make_astvar env loc pv Tid - | Node(_,"$NUM",[Nvar(loc,pv)]) when isMeta pv -> + | Node(_,"$NUM",[Nmeta(loc,pv)]) -> make_astvar env loc pv Tnum - | Node(_,"$STR",[Nvar(loc,pv)]) when isMeta pv -> + | Node(_,"$STR",[Nmeta(loc,pv)]) -> make_astvar env loc pv Tstr - | Node(_,"$PATH",[Nvar(loc,pv)]) when isMeta pv -> + | Node(_,"$PATH",[Nmeta(loc,pv)]) -> make_astvar env loc pv Tpath | Node(_,"$QUOTE",[qast]) -> (Pquote (set_loc dummy_loc qast), env) + + (* This may occur when the meta is not textual but bound by coerce_to_id*) + | Slam(loc,Some id,b) when isMeta (string_of_id id) -> + let s = string_of_id id in + let senv = bind_patvar env loc s ETast in + let (pb,env') = pat_of_ast senv b in + (Pmeta_slam(s, pb), env') + | Slam(_,os,b) -> let (pb,env') = pat_of_ast env b in (Pslam(os,pb), env') @@ -478,7 +501,7 @@ let rec pat_of_ast env ast = and patl_of_astl env astl = match astl with - | [Node(_,"$LIST",[Nvar(loc,pv)])] when isMeta pv -> + | [Node(_,"$LIST",[Nmeta(loc,pv)])] -> let penv = bind_patvar env loc pv ETastl in (Plmeta pv, penv) | [] -> (Pnil,env) @@ -583,51 +606,3 @@ let to_act_check_vars env etyp ast = match ast with | Node(_,"ASTACT",[a]) -> act_of_ast env etyp a | _ -> invalid_arg_loc (loc ast,"Ast.to_act_env") - - -(* Hash-consing *) -module Hloc = Hashcons.Make( - struct - type t = Coqast.loc - type u = unit - let equal (b1,e1) (b2,e2) = b1=b2 & e1=e2 - let hash_sub () x = x - let hash = Hashtbl.hash - end) - -module Hast = Hashcons.Make( - struct - type t = Coqast.t - type u = (Coqast.t -> Coqast.t) * ((loc -> loc) * (string -> string)) - let hash_sub (hast,(hloc,hstr)) = function - | Node(l,s,al) -> Node(hloc l, hstr s, List.map hast al) - | Nvar(l,s) -> Nvar(hloc l, hstr s) - | Slam(l,None,t) -> Slam(hloc l, None, hast t) - | Slam(l,Some s,t) -> Slam(hloc l, Some (hstr s), hast t) - | Num(l,n) -> Num(hloc l, n) - | Id(l,s) -> Id(hloc l, hstr s) - | Str(l,s) -> Str(hloc l, hstr s) - | Path(l,d,k) -> Path(hloc l, List.map hstr d, hstr k) - | Dynamic(l,d) -> Dynamic(hloc l, d) - let equal a1 a2 = - match (a1,a2) with - | (Node(l1,s1,al1), Node(l2,s2,al2)) -> - (l1==l2 & s1==s2 & List.length al1 = List.length al2) - & List.for_all2 (==) al1 al2 - | (Nvar(l1,s1), Nvar(l2,s2)) -> l1==l2 & s1==s2 - | (Slam(l1,None,t1), Slam(l2,None,t2)) -> l1==l2 & t1==t2 - | (Slam(l1,Some s1,t1), Slam(l2,Some s2,t2)) -> l1==l2 & t1==t2 - | (Num(l1,n1), Num(l2,n2)) -> l1==l2 & n1=n2 - | (Id(l1,s1), Id(l2,s2)) -> l1==l2 & s1==s2 - | (Str(l1,s1),Str(l2,s2)) -> l1==l2 & s1==s2 - | (Path(l1,d1,k1), Path(l2,d2,k2)) -> - (l1==l2 & k1==k2 & List.length d1 = List.length d2) - & List.for_all2 (==) d1 d2 - | _ -> false - let hash = Hashtbl.hash - end) - -let hcons_ast hstr = - let hloc = Hashcons.simple_hcons Hloc.f () in - let hast = Hashcons.recursive_hcons Hast.f (hloc,hstr) in - (hast,hloc) diff --git a/parsing/ast.mli b/parsing/ast.mli index 0379ba305f..d3e0ee4ab2 100755 --- a/parsing/ast.mli +++ b/parsing/ast.mli @@ -21,24 +21,23 @@ val loc : Coqast.t -> Coqast.loc (* ast constructors with dummy location *) val ope : string * Coqast.t list -> Coqast.t -val slam : string option * Coqast.t -> Coqast.t -val nvar : string -> Coqast.t +val slam : identifier option * Coqast.t -> Coqast.t +val nvar : identifier -> Coqast.t val ide : string -> Coqast.t val num : int -> Coqast.t val str : string -> Coqast.t -val path : string list -> string -> Coqast.t +val path : section_path -> Coqast.t val dynamic : Dyn.t -> Coqast.t val set_loc : Coqast.loc -> Coqast.t -> Coqast.t val path_section : Coqast.loc -> section_path -> Coqast.t -val section_path : string list -> string -> section_path - +val section_path : section_path -> section_path (* ast destructors *) val num_of_ast : Coqast.t -> int val id_of_ast : Coqast.t -> string -val nvar_of_ast : Coqast.t -> string +val nvar_of_ast : Coqast.t -> identifier (* ast processing datatypes *) @@ -47,7 +46,7 @@ type pat = | Pquote of Coqast.t | Pmeta of string * tok_kind | Pnode of string * patlist - | Pslam of string option * pat + | Pslam of identifier option * pat | Pmeta_slam of string * pat and patlist = @@ -71,7 +70,11 @@ type v = type env = (string * v) list -val coerce_to_var : string -> Coqast.t -> string +val coerce_to_var : Coqast.t -> Coqast.t + +(* +val coerce_to_id : Coqast.t -> identifier +*) exception No_match of string @@ -96,8 +99,8 @@ val vall_of_astl : entry_env -> Coqast.t list -> patlist val alpha_eq : Coqast.t * Coqast.t -> bool val alpha_eq_val : v * v -> bool -val occur_var_ast : string -> Coqast.t -> bool -val replace_vars_ast : (string * string) list -> Coqast.t -> Coqast.t +val occur_var_ast : identifier -> Coqast.t -> bool +val replace_vars_ast : (identifier * identifier) list -> Coqast.t -> Coqast.t val bind_env : env -> string -> v -> env val ast_match : env -> pat -> Coqast.t -> env @@ -111,8 +114,3 @@ val to_pat : entry_env -> Coqast.t -> (pat * entry_env) val eval_act : Coqast.loc -> env -> act -> v val to_act_check_vars : entry_env -> entry_type -> Coqast.t -> act - -(* Hash-consing *) -val hcons_ast: (string -> string) -> - (Coqast.t -> Coqast.t) * (Coqast.loc -> Coqast.loc) - diff --git a/parsing/astterm.ml b/parsing/astterm.ml index 30ec93b79e..194ce335ee 100644 --- a/parsing/astterm.ml +++ b/parsing/astterm.ml @@ -27,10 +27,6 @@ open Ast open Coqast open Nametab -type extended_global_reference = - | TrueGlobal of global_reference - | SyntacticDef of section_path - (*Takes a list of variables which must not be globalized*) let from_list l = List.fold_right Idset.add l Idset.empty @@ -40,7 +36,7 @@ let rec adjust_implicits n = function (* when an head ident is not a constructor in pattern *) let mssg_hd_is_not_constructor s = - [< 'sTR ("The symbol "^s^" should be a constructor") >] + [< 'sTR "The symbol "; pr_id s; 'sTR " should be a constructor" >] (* checking linearity of a list of ids in patterns *) let non_linearl_mssg id = @@ -50,7 +46,7 @@ let non_linearl_mssg id = let error_capture_loc loc s = user_err_loc (loc,"ast_to_rawconstr", - [< 'sTR ("The variable "^s^" occurs in its type") >]) + [< 'sTR "The variable "; pr_id s; 'sTR " occurs in its type" >]) let error_expl_impl_loc loc = user_err_loc @@ -116,34 +112,34 @@ let check_number_of_pattern loc n l = (* Translation of references *) let ast_to_sp = function - | Path(loc,sl,s) -> + | Path(loc,sp) -> (try - section_path sl s + section_path sp with Invalid_argument _ | Failure _ -> anomaly_loc(loc,"Astterm.ast_to_sp", - [< 'sTR"malformed section-path" >])) + [< '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 = "_") +let is_underscore id = (id = wildcard) let name_of_nvar s = - if is_underscore s then Anonymous else Name (id_of_string 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 (id_of_string s) + else s let interp_qualid p = let outnvar = function | Nvar (loc,s) -> s - | _ -> anomaly "interp_qualid: bad-formed qualified identifier" in + | _ -> 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 p (id_of_string (List.hd r)) + make_qualid p (List.hd r) let maybe_variable = function | [Nvar (_,s)] -> Some s @@ -161,7 +157,7 @@ let ids_of_ctxt ctxt = type pattern_qualid_kind = | IsConstrPat of loc * (constructor_path * identifier list) - | IsVarPat of loc * string + | IsVarPat of loc * identifier let maybe_constructor env = function | Node(loc,"QUALID",l) -> @@ -188,7 +184,13 @@ let maybe_constructor env = function | Node(loc,"MUTCONSTRUCT",[sp;Num(_,ti);Num(_,n)]) -> (* Buggy: needs to compute the context *) IsConstrPat (loc,(((ast_to_sp sp,ti),n),[])) - + + | Path(loc,sp) -> + (match absolute_reference sp with + | ConstructRef (spi,j) -> + IsConstrPat (loc,((spi,j),[])) + | _ -> error ("Unknown absolute constructor name: "^(string_of_path sp))) + | Node(loc,("CONST"|"EVAR"|"MUTIND"|"SYNCONST" as key), l) -> user_err_loc (loc,"ast_to_pattern", [< 'sTR "Found a pattern involving global references which are not constructors" @@ -237,10 +239,9 @@ let ref_from_constr c = match kind_of_term c with [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 s = - let id = id_of_string s in +let ast_to_var (env,impls) (vars1,vars2) loc id = let imps = - if Idset.mem id env or List.mem s vars1 + if Idset.mem id env or List.mem id vars1 then try List.assoc id impls with Not_found -> [] @@ -248,7 +249,7 @@ let ast_to_var (env,impls) (vars1,vars2) loc s = let _ = lookup_id id vars2 in (* Car Fixpoint met les fns définies tmporairement comme vars de sect *) try - let ref = Nametab.locate (make_qualid [] (id_of_string s)) in + let ref = Nametab.locate (make_qualid [] id) in implicits_of_global ref with _ -> [] in RVar (loc, id), [], imps @@ -262,6 +263,10 @@ type 'a globalization_action = { fail : qualid -> 'a * int list; } +let implicits_of_extended_reference = function + | TrueGlobal ref -> implicits_of_global ref + | SyntacticDef _ -> [] + let translate_qualid act qid = (* Is it a bound variable? *) try @@ -269,56 +274,47 @@ let translate_qualid act qid = | [],id -> act.parse_var id, [] | _ -> raise Not_found with Not_found -> - (* Is it a global reference? *) - try - let ref = Nametab.locate qid in - act.parse_ref (TrueGlobal ref), implicits_of_global ref - with Not_found -> - (* Is it a reference to a syntactic definition? *) + (* Is it a global reference or a syntactic definition? *) try - let sp = Syntax_def.locate_syntactic_definition qid in - act.parse_ref (SyntacticDef sp), [] + let ref = Nametab.extended_locate qid in + act.parse_ref ref, implicits_of_extended_reference ref with Not_found -> act.fail qid (**********************************************************************) -let rawconstr_of_var env vars loc s = +let rawconstr_of_var env vars loc id = try - ast_to_var env vars loc s + ast_to_var env vars loc id with Not_found -> - Pretype_errors.error_var_not_found_loc loc (id_of_string s) + Pretype_errors.error_var_not_found_loc loc id let rawconstr_of_qualid env vars loc qid = (* Is it a bound variable? *) try match repr_qualid qid with - | [],s -> ast_to_var env vars loc (string_of_id s) + | [],s -> ast_to_var env vars loc s | _ -> raise Not_found with Not_found -> - (* Is it a global reference? *) - try - let ref = Nametab.locate qid in + (* Is it a global reference or a syntactic definition? *) + try match Nametab.extended_locate qid with + | TrueGlobal ref -> let hyps = implicit_section_args ref in let section_args = List.map (fun id -> RRef (loc, VarRef id)) hyps in let imps = implicits_of_global ref in RRef (loc, ref), section_args, adjust_implicits (List.length hyps) imps - with Not_found -> - (* Is it a reference to a syntactic definition? *) - try - let sp = Syntax_def.locate_syntactic_definition qid in + | SyntacticDef sp -> set_loc_of_rawconstr loc (Syntax_def.search_syntactic_definition sp),[],[] with Not_found -> error_global_not_found_loc loc qid -let mkLambdaC (x,a,b) = ope("LAMBDA",[a;slam(Some (string_of_id x),b)]) +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 (string_of_id x),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 -> (id_of_string (nvar_of_ast id),c)) idl + | Node(_,"BINDER",c::idl) -> List.map (fun id -> (nvar_of_ast id,c)) idl | _ -> anomaly "BINDER is expected" (* [merge_aliases] returns the sets of all aliases encountered at this @@ -328,14 +324,15 @@ let merge_aliases (ids,subst as aliases) = function | Name id -> ids@[id], if ids=[] then subst - else (string_of_id id,string_of_id (List.hd ids))::subst + else (id, List.hd ids)::subst let alias_of = function | ([],_) -> Anonymous | (id::_,_) -> Name id -let message_redondant_alias (s1,s2) = - warning ("Alias variable "^s1^" is merged with "^s2) +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 env aliases = function | Node(_,"PATTAS",[Nvar (loc,s); p]) -> @@ -363,12 +360,12 @@ 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 - ((id_of_string fi)::lf, (ni-1)::ln, astA::lA, astT::lt) - | Node(_,"FDECL", [Nvar(_,fi); Node(_,"BINDERS",bl); astA; astT])::rest -> + (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 - ((id_of_string fi)::lf, ni::ln, (mkProdCit binders astA)::lA, + (fi::lf, ni::ln, (mkProdCit binders astA)::lA, (mkLambdaCit binders astT)::lt) | _ -> anomaly "FDECL or NUMFDECL is expected" @@ -376,13 +373,13 @@ let rec ast_to_cofix = function | [] -> ([],[],[]) | Node(_,"CFDECL", [Nvar(_,fi); astA; astT])::rest -> let (lf,lA,lt) = ast_to_cofix rest in - ((id_of_string fi)::lf, astA::lA, astT::lt) + (fi::lf, astA::lA, astT::lt) | _ -> anomaly "CFDECL is expected" let error_fixname_unbound str is_cofix loc name = user_err_loc (loc,"ast_to (COFIX)", - [< 'sTR "The name"; 'sPC ; 'sTR name ; + [< '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") >]) (* @@ -431,7 +428,7 @@ let ast_to_rawconstr sigma env allow_soapp lvar = | Node(loc,("PROD"|"LAMBDA"|"LETIN" as k), [c1;Slam(_,ona,c2)]) -> let na,ids' = match ona with - | Some s -> let id = id_of_string s in Name id, Idset.add id ids + | Some id -> Name id, Idset.add id ids | _ -> Anonymous, ids in let c1' = dbrec env c1 and c2' = dbrec (ids',impls) c2 in (match k with @@ -522,17 +519,17 @@ let ast_to_rawconstr sigma env allow_soapp lvar = check_uppercase loc eqn_ids; check_number_of_pattern loc n pl; let rhs = replace_vars_ast subst rhs in - List.iter message_redondant_alias subst; + 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) rhs) - | _ -> anomaly "ast_to_rawconstr: badly-formed ast for Cases equation" + | _ -> anomaly "ast_to_rawconstr: ill-formed ast for Cases equation" and iterated_binder oper n ty (ids,impls as env) = function | Slam(loc,ona,body) -> let na,ids' = match ona with - | Some s -> - if n>0 then check_capture loc s ty body; - let id = id_of_string s in Name id, Idset.add id ids + | 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) body in @@ -614,16 +611,15 @@ let ast_adjust_consts sigma = | 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) - | Nvar (loc, s) as ast -> - let id = id_of_string s in - if isMeta s then ast - else if Idset.mem id env then ast - else adjust_qualid env loc ast (make_qualid [] (id_of_string s)) + | 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_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 (id_of_string na) env in + 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 @@ -653,7 +649,7 @@ let rec glob_ast sigma env = 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 (id_of_string na) env in + 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 @@ -727,20 +723,14 @@ let retype_list sigma env lst = (* 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 (fun x -> string_of_id (fst x)) lvar) - com + 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 (fun x -> string_of_id (fst x)) lvar) - com + 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;; @@ -807,9 +797,7 @@ let interp_constrpattern_gen sigma env lvar com = let c = ast_to_rawconstr sigma (from_list (ids_of_rel_context (rel_context env)), []) - true (List.map - (fun x -> - string_of_id (fst x)) lvar,named_context env) com + true (List.map fst lvar,named_context env) com and nlvar = List.map (fun (id,c) -> (id,pattern_of_constr c)) lvar in try pattern_of_rawconstr nlvar c diff --git a/parsing/coqast.ml b/parsing/coqast.ml index 81df802bc0..7604818f25 100644 --- a/parsing/coqast.ml +++ b/parsing/coqast.ml @@ -8,16 +8,22 @@ (* $Id$ *) +(*i*) +open Names +(*i*) + type loc = int * int type t = | Node of loc * string * t list - | Nvar of loc * string - | Slam of loc * string option * t + | Nmeta of loc * string + | Nvar of loc * identifier + | Slam of loc * identifier option * t + | Smetalam of loc * string * t | Num of loc * int - | Id of loc * string | Str of loc * string - | Path of loc * string list* string + | Id of loc * string + | Path of loc * section_path | Dynamic of loc * Dyn.t type the_coq_ast = t @@ -28,6 +34,7 @@ let subst_meta bl ast = | Node(loc, node_name, args) -> Node(loc, node_name, List.map aux args) | Slam(loc, var, arg) -> Slam(loc, var, aux arg) + | Smetalam(loc, var, arg) -> Smetalam(loc, var, aux arg) | other -> other in aux ast @@ -36,6 +43,7 @@ let rec collect_metas = function | Node (_,"META", [Num(_, n)]) -> [n] | Node(_, _, args) -> List.concat (List.map collect_metas args) | Slam(loc, var, arg) -> collect_metas arg + | Smetalam(loc, var, arg) -> collect_metas arg | _ -> [] (* Hash-consing *) @@ -51,38 +59,41 @@ module Hloc = Hashcons.Make( module Hast = Hashcons.Make( struct type t = the_coq_ast - type u = (the_coq_ast -> the_coq_ast) * ((loc -> loc) * (string -> string)) - let hash_sub (hast,(hloc,hstr)) = function + type u = + (the_coq_ast -> the_coq_ast) * + ((loc -> loc) * (string -> string) + * (identifier -> identifier) * (section_path -> section_path)) + let hash_sub (hast,(hloc,hstr,hid,hsp)) = function | Node(l,s,al) -> Node(hloc l, hstr s, List.map hast al) - | Nvar(l,s) -> Nvar(hloc l, hstr s) + | Nmeta(l,s) -> Nmeta(hloc l, hstr s) + | Nvar(l,s) -> Nvar(hloc l, hid s) | Slam(l,None,t) -> Slam(hloc l, None, hast t) - | Slam(l,Some s,t) -> Slam(hloc l, Some (hstr s), hast t) + | Slam(l,Some s,t) -> Slam(hloc l, Some (hid s), hast t) + | Smetalam(l,s,t) -> Smetalam(hloc l, hstr s, hast t) | Num(l,n) -> Num(hloc l, n) | Id(l,s) -> Id(hloc l, hstr s) | Str(l,s) -> Str(hloc l, hstr s) - | Path(l,d,k) -> Path(hloc l, List.map hstr d, hstr k) + | Path(l,d) -> Path(hloc l, hsp d) | Dynamic(l,d) -> Dynamic(hloc l, d) let equal a1 a2 = match (a1,a2) with | (Node(l1,s1,al1), Node(l2,s2,al2)) -> (l1==l2 & s1==s2 & List.length al1 = List.length al2) & List.for_all2 (==) al1 al2 + | (Nmeta(l1,s1), Nmeta(l2,s2)) -> l1==l2 & s1==s2 | (Nvar(l1,s1), Nvar(l2,s2)) -> l1==l2 & s1==s2 | (Slam(l1,None,t1), Slam(l2,None,t2)) -> l1==l2 & t1==t2 - | (Slam(l1,Some s1,t1), Slam(l2,Some s2,t2)) -> l1==l2 & t1==t2 + | (Slam(l1,Some s1,t1), Slam(l2,Some s2,t2)) ->l1==l2 & s1==s2 & t1==t2 + | (Smetalam(l1,s1,t1), Smetalam(l2,s2,t2)) -> l1==l2 & s1==s2 & t1==t2 | (Num(l1,n1), Num(l2,n2)) -> l1==l2 & n1=n2 | (Id(l1,s1), Id(l2,s2)) -> l1==l2 & s1==s2 | (Str(l1,s1),Str(l2,s2)) -> l1==l2 & s1==s2 - | (Path(l1,d1,k1), Path(l2,d2,k2)) -> - (l1==l2 & k1==k2 & List.length d1 = List.length d2) - & List.for_all2 (==) d1 d2 + | (Path(l1,d1), Path(l2,d2)) -> (l1==l2 & d1==d2) | _ -> false let hash = Hashtbl.hash end) -let hcons_ast hstr = +let hcons_ast (hstr,hid,hpath) = let hloc = Hashcons.simple_hcons Hloc.f () in - let hast = Hashcons.recursive_hcons Hast.f (hloc,hstr) in + let hast = Hashcons.recursive_hcons Hast.f (hloc,hstr,hid,hpath) in (hast,hloc) - - diff --git a/parsing/coqast.mli b/parsing/coqast.mli index 255611c463..f741574e82 100644 --- a/parsing/coqast.mli +++ b/parsing/coqast.mli @@ -8,18 +8,24 @@ (*i $Id$ i*) +(*i*) +open Names +(*i*) + (* Abstract syntax trees. *) type loc = int * int type t = | Node of loc * string * t list - | Nvar of loc * string - | Slam of loc * string option * t + | Nmeta of loc * string + | Nvar of loc * identifier + | Slam of loc * identifier option * t + | Smetalam of loc * string * t | Num of loc * int - | Id of loc * string | Str of loc * string - | Path of loc * string list* string + | Id of loc * string + | Path of loc * section_path | Dynamic of loc * Dyn.t (* returns the list of metas occuring in the ast *) @@ -30,5 +36,7 @@ val collect_metas : t -> int list val subst_meta : (int * t) list -> t -> t (* hash-consing function *) -val hcons_ast: (string -> string) -> (t -> t) * (loc -> loc) - +val hcons_ast: + (string -> string) * (Names.identifier -> Names.identifier) + * (section_path -> section_path) + -> (t -> t) * (loc -> loc) diff --git a/parsing/coqlib.ml b/parsing/coqlib.ml index 88548def38..dca396ea21 100644 --- a/parsing/coqlib.ml +++ b/parsing/coqlib.ml @@ -15,9 +15,20 @@ open Declare open Pattern open Nametab -let nat_path = make_path ["Coq";"Init";"Datatypes"] (id_of_string "nat") CCI +let make_dir l = make_dirpath (List.map id_of_string l) +let coq_id = id_of_string "Coq" +let init_id = id_of_string "Init" +let arith_id = id_of_string "Arith" +let datatypes_id = id_of_string "Datatypes" + +let logic_module = make_dir ["Coq";"Init";"Logic"] +let logic_type_module = make_dir ["Coq";"Init";"Logic_Type"] +let datatypes_module = make_dir ["Coq";"Init";"Datatypes"] +let arith_module = make_dir ["Coq";"Arith";"Arith"] + +let nat_path = make_path datatypes_module (id_of_string "nat") CCI let myvar_path = - make_path ["Coq";"Arith";"Arith"] (id_of_string "My_special_variable") CCI + make_path arith_module (id_of_string "My_special_variable") CCI let glob_nat = IndRef (nat_path,0) @@ -26,14 +37,14 @@ let glob_S = ConstructRef ((nat_path,0),2) let glob_My_special_variable_nat = ConstRef myvar_path -let eq_path = make_path ["Coq";"Init";"Logic"] (id_of_string "eq") CCI -let eqT_path = make_path ["Coq";"Init";"Logic_Type"] (id_of_string "eqT") CCI +let eq_path = make_path logic_module (id_of_string "eq") CCI +let eqT_path = make_path logic_type_module (id_of_string "eqT") CCI let glob_eq = IndRef (eq_path,0) let glob_eqT = IndRef (eqT_path,0) let reference dir s = - let dir = "Coq"::"Init"::[dir] in + let dir = make_dir ("Coq"::"Init"::[dir]) in let id = id_of_string s in try Nametab.locate_in_absolute_module dir id diff --git a/parsing/coqlib.mli b/parsing/coqlib.mli index b4e66f9f27..92292161af 100644 --- a/parsing/coqlib.mli +++ b/parsing/coqlib.mli @@ -18,6 +18,10 @@ open Pattern (*s Global references *) +(* Modules *) +val logic_module : Names.dir_path +val logic_type_module : Names.dir_path + (* Natural numbers *) val glob_nat : global_reference val glob_O : global_reference diff --git a/parsing/esyntax.ml b/parsing/esyntax.ml index 64f7d877e6..28be507232 100644 --- a/parsing/esyntax.ml +++ b/parsing/esyntax.ml @@ -23,9 +23,9 @@ open Extend * according to the key of the pattern. *) type key = - | Cst of string list (* keys for global constants rules *) - | Ind of string list * int - | Cstr of (string list * int) * int + | Cst of Names.section_path (* keys for global constants rules *) + | Ind of Names.section_path * int + | Cstr of (Names.section_path * int) * int | Nod of string (* keys for other constructed asts rules *) | Oth (* key for other syntax rules *) | All (* key for catch-all rules (i.e. with a pattern such as $x .. *) @@ -33,12 +33,12 @@ type key = let warning_verbose = ref true let ast_keys = function - | Node(_,"APPLIST", Node(_,"CONST", [Path (_,sl,_)]) ::_) -> + | Node(_,"APPLIST", Node(_,"CONST", [Path (_,sl)]) ::_) -> [Cst sl; Nod "APPLIST"; All] - | Node(_,"APPLIST", Node(_,"MUTIND", [Path (_,sl,_); Num (_,tyi)]) ::_) -> + | Node(_,"APPLIST", Node(_,"MUTIND", [Path (_,sl); Num (_,tyi)]) ::_) -> [Ind (sl,tyi); Nod "APPLIST"; All] | Node(_,"APPLIST", Node(_,"MUTCONSTRUCT", - [Path (_,sl,_); Num (_,tyi); Num (_,i)]) ::_) -> + [Path (_,sl); Num (_,tyi); Num (_,i)]) ::_) -> [Cstr ((sl,tyi),i); Nod "APPLIST"; All] | Node(_,s,_) -> [Nod s; All] | _ -> [Oth; All] @@ -47,16 +47,16 @@ let spat_key astp = match astp with | Pnode("APPLIST", Pcons(Pnode("CONST", - Pcons(Pquote(Path (_,sl,s)),_)), _)) + Pcons(Pquote(Path (_,sl)),_)), _)) -> Cst sl | Pnode("APPLIST", Pcons(Pnode("MUTIND", - Pcons(Pquote(Path (_,sl,s)), + Pcons(Pquote(Path (_,sl)), Pcons(Pquote(Num (_,tyi)),_))), _)) -> Ind (sl,tyi) | Pnode("APPLIST", Pcons(Pnode("MUTCONSTRUCT", - Pcons(Pquote(Path (_,sl,s)), + Pcons(Pquote(Path (_,sl)), Pcons(Pquote(Num (_,tyi)), Pcons(Pquote(Num (_,i)),_)))), _)) -> Cstr ((sl,tyi),i) diff --git a/parsing/extend.ml4 b/parsing/extend.ml4 index d3c0eecba7..2c74daa860 100644 --- a/parsing/extend.ml4 +++ b/parsing/extend.ml4 @@ -114,14 +114,9 @@ let nterm univ ast = let prod_item univ env ast = match ast with | Str (_, s) -> env, Term (terminal s) - | Node (_, "NT", [nt; Nvar (locp, p)]) -> + | Node (_, "NT", [nt; Nmeta (locp, p)]) -> let (nont, etyp) = nterm univ nt in - if isMeta p then - ((p, etyp) :: env, NonTerm (nont, etyp, Some p)) - else - user_err_loc - (locp,"Extend.prod_item", - [< 'sTR"This ident is not a metavariable." >]) + ((p, etyp) :: env, NonTerm (nont, etyp, Some p)) | Node (_, "NT", [nt]) -> let (nont, etyp) = nterm univ nt in env, NonTerm (nont, etyp, None) @@ -150,10 +145,10 @@ let gram_entry univ (nt, etyp, ass, rl) = gl_rules = List.map (gram_rule univ etyp) rl } let gram_assoc = function - | Id (_, "LEFTA") -> Some LeftA - | Id (_, "RIGHTA") -> Some RightA - | Id (_, "NONA") -> Some NonA - | Id (_, "NONE") -> None + | Node (_, "LEFTA", []) -> Some LeftA + | Node (_, "RIGHTA", []) -> Some RightA + | Node (_, "NONA", []) -> Some NonA + | Node (_, "NONE", []) -> None | ast -> invalid_arg_loc (Ast.loc ast, "Egrammar.assoc") let gram_define_entry univ = function @@ -168,10 +163,10 @@ let gram_define_entry univ = function try create_entry univ nt etyp with Failure s -> - user_err_loc (ntl,"Extend.gram_define_entry",[< 'sTR s >]) + user_err_loc (ntl,"gram_define_entry",[< 'sTR s >]) in (nt, etyp, assoc, rl) - | ast -> invalid_arg_loc (Ast.loc ast, "Egrammar.gram_define_entry") + | ast -> invalid_arg_loc (Ast.loc ast, "gram_define_entry") let interp_grammar_command univ astl = @@ -252,7 +247,7 @@ let rec unparsing_hunk_of_ast vars = function | Node(_, "PH", [e; Node (loc,"EXTERN", ext_args)]) -> let (ppex, rel) = extern_of_ast loc ext_args in PH (Ast.val_of_ast vars e, Some ppex, rel) - | Node(loc, "PH", [e; Id(_,pr)]) -> + | Node(loc, "PH", [e; Node(_,pr, [])]) -> let reln = (match pr with | "L" -> L diff --git a/parsing/g_basevernac.ml4 b/parsing/g_basevernac.ml4 index f3d066f2f4..7e48d545ae 100644 --- a/parsing/g_basevernac.ml4 +++ b/parsing/g_basevernac.ml4 @@ -28,14 +28,14 @@ GEXTEND Gram [ [ l = LIST1 identarg -> l ] ] ; qualidarg: - [ [ l = Constr.qualid -> <:ast< (QUALIDARG ($LIST l)) >> ] ] + [ [ l = Constr.qualid -> <:ast< (QUALIDARG ($LIST $l)) >> ] ] ; ne_qualidarg_list: [ [ q = qualidarg; l = ne_qualidarg_list -> q::l | q = qualidarg -> [q] ] ] ; qualidconstarg: - [ [ l = Constr.qualid -> <:ast< (QUALIDCONSTARG ($LIST l)) >> ] ] + [ [ l = Constr.qualid -> <:ast< (QUALIDCONSTARG ($LIST $l)) >> ] ] ; numarg: [ [ n = Prim.number -> n @@ -81,7 +81,7 @@ GEXTEND Gram command: [ [ IDENT "Comments"; args = commentarg_list -> - <:ast< (Comments ($LIST args)) >> + <:ast< (Comments ($LIST $args)) >> | IDENT "Pwd" -> <:ast< (PWD) >> | IDENT "Cd" -> <:ast< (CD) >> | IDENT "Cd"; dir = stringarg -> <:ast< (CD $dir) >> @@ -114,7 +114,7 @@ GEXTEND Gram | IDENT "Locate"; IDENT "File"; f = stringarg -> <:ast< (LocateFile $f) >> - | IDENT "Locate"; IDENT "Library"; id = identarg -> + | IDENT "Locate"; IDENT "Library"; id = qualidarg -> <:ast< (LocateLibrary $id) >> | IDENT "Locate"; id = qualidarg -> <:ast< (Locate $id) >> @@ -199,17 +199,17 @@ GEXTEND Gram (* Set printing of coercions *) | "Set"; IDENT "Printing"; IDENT "Coercion"; qidl = ne_qualidarg_list -> - <:ast< (PRINTING_COERCIONS_ON ($LIST qidl)) >> + <:ast< (PRINTING_COERCIONS_ON ($LIST $qidl)) >> | "Set"; IDENT "Printing"; IDENT "Coercions" -> <:ast< (PRINTING_COERCIONS_ON) >> | IDENT "Unset"; IDENT "Printing"; IDENT "Coercion"; qidl = ne_qualidarg_list -> - <:ast< (PRINTING_COERCIONS_OFF ($LIST qidl)) >> + <:ast< (PRINTING_COERCIONS_OFF ($LIST $qidl)) >> | IDENT "Unset"; IDENT "Printing"; IDENT "Coercions" -> <:ast< (PRINTING_COERCIONS_OFF) >> | IDENT "Test"; IDENT "Printing"; IDENT "Coercion"; qidl = ne_qualidarg_list -> - <:ast< (TEST_PRINTING_COERCIONS ($LIST qidl)) >> + <:ast< (TEST_PRINTING_COERCIONS ($LIST $qidl)) >> | IDENT "Test"; IDENT "Printing"; IDENT "Coercions" -> <:ast< (TEST_PRINTING_COERCIONS) >> @@ -289,10 +289,10 @@ GEXTEND Gram | "Grammar"; univ = univ; tl = LIST1 Prim.grammar_entry SEP "with" -> - <:ast< (GRAMMAR ($VAR univ) (ASTLIST ($LIST tl))) >> + <:ast< (GRAMMAR { $univ } (ASTLIST ($LIST $tl))) >> | "Syntax"; univ = univ; el=LIST1 Prim.syntax_entry SEP ";" -> - <:ast< (SYNTAX ($VAR univ) (ASTLIST ($LIST el))) >> + <:ast< (SYNTAX { $univ } (ASTLIST ($LIST $el))) >> (* Faudrait une version de qualidarg dans Prim pour respecter l'ordre *) | IDENT "Infix"; as_ = entry_prec; n = numarg; op = Prim.string; @@ -308,18 +308,18 @@ GEXTEND Gram Prim.grammar_entry: [[ nont = Prim.ident; etyp = Prim.entry_type; ":="; ep = entry_prec; OPT "|"; rl = LIST0 grammar_rule SEP "|" -> - <:ast< (GRAMMARENTRY $nont $etyp $ep ($LIST rl)) >> ]] + <:ast< (GRAMMARENTRY $nont $etyp $ep ($LIST $rl)) >> ]] ; entry_prec: - [[ IDENT "LEFTA" -> <:ast< {LEFTA} >> - | IDENT "RIGHTA" -> <:ast< {RIGHTA} >> - | IDENT "NONA" -> <:ast< {NONA} >> - | -> <:ast< {NONE} >> ] ] + [[ IDENT "LEFTA" -> <:ast< (LEFTA) >> + | IDENT "RIGHTA" -> <:ast< (RIGHTA) >> + | IDENT "NONA" -> <:ast< (NONA) >> + | -> <:ast< (NONE) >> ] ] ; grammar_rule: [[ name = rule_name; "["; pil = LIST0 production_item; "]"; "->"; a = Prim.astact -> - <:ast< (GRAMMARRULE ($ID name) $a ($LIST pil)) >> ]] + <:ast< (GRAMMARRULE ($ID $name) $a ($LIST $pil)) >> ]] ; rule_name: [[ name = IDENT -> name ]] @@ -369,7 +369,7 @@ GEXTEND Gram | e = Prim.ast; oprec = OPT [ ":"; pr = paren_reln_or_extern -> pr ] -> match oprec with | Some pr -> <:ast< (PH $e $pr) >> - | None -> <:ast< (PH $e {Any}) >> ]] + | None -> <:ast< (PH $e (Any)) >> ]] ; box: [ [ "<"; bk = box_kind; ">" -> bk ] ] @@ -382,8 +382,8 @@ GEXTEND Gram | IDENT "t" -> <:ast< (PpTB) >> ] ] ; paren_reln_or_extern: - [ [ IDENT "L" -> <:ast< {L} >> - | IDENT "E" -> <:ast< {E} >> + [ [ IDENT "L" -> <:ast< (L) >> + | IDENT "E" -> <:ast< (E) >> | pprim = STRING; precrec = OPT [ ":"; p = precedence -> p ] -> match precrec with | Some p -> <:ast< (EXTERN ($STR $pprim) $p) >> diff --git a/parsing/g_cases.ml4 b/parsing/g_cases.ml4 index 52c35ce043..3ce0e7b4a8 100644 --- a/parsing/g_cases.ml4 +++ b/parsing/g_cases.ml4 @@ -26,7 +26,7 @@ GEXTEND Gram | p = pattern; "as"; id = ident -> <:ast< (PATTAS $id $p)>> | p1 = pattern; ","; p2 = pattern -> - <:ast< (PATTCONSTRUCT (QUALID Datatypes pair) $p1 $p2) >> + <:ast< (PATTCONSTRUCT Coq.Init.Datatypes.pair $p1 $p2) >> | p = pattern -> p ] ] ; ne_pattern_list: diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index e0a7e61ae7..92e2262f34 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -19,18 +19,29 @@ GEXTEND Gram ne_ident_comma_list ne_constr_list sort ne_binders_list qualid global; ident: - [ [ id = IDENT -> <:ast< ($VAR $id) >> + [ [ id = Prim.var -> id (* This is used in quotations *) - | id = METAIDENT -> <:ast< ($VAR $id) >> ] ] + | id = Prim.metaident -> id ] ] ; global: - [ [ l = qualid -> <:ast< (QUALID ($LIST l)) >> + [ [ l = qualid -> <:ast< (QUALID ($LIST $l)) >> (* This is used in quotations *) - | id = METAIDENT -> <:ast< ($VAR $id) >> ] ] + | id = Prim.metaident -> id ] ] ; qualid: + [ [ id = Prim.var; l = fields -> id :: l + | id = Prim.var -> [ id ] + ] ] + ; + fields: + [ [ id = FIELD; l = fields -> <:ast< ($VAR $id) >> :: l + | id = FIELD -> [ <:ast< ($VAR $id) >> ] + ] ] + ; +(* + qualid: [ [ id = IDENT; l = fields -> <:ast< ($VAR $id) >> :: l ] ] ; fields: @@ -38,6 +49,7 @@ GEXTEND Gram | -> [] ] ] ; +*) raw_constr: [ [ c = Prim.ast -> c ] ] ; @@ -65,18 +77,19 @@ GEXTEND Gram | "?"; n = Prim.number -> <:ast< (META $n) >> | bl = binders; c = constr -> <:ast< ($ABSTRACT "LAMBDALIST" $bl $c) >> | "("; lc1 = lconstr; ":"; c = constr; body = product_tail -> - let id = Ast.coerce_to_var "lc1" lc1 in + let id = Ast.coerce_to_var lc1 in <:ast< (PROD $c [$id]$body) >> | "("; lc1 = lconstr; ","; lc2 = lconstr; ":"; c = constr; body = product_tail -> - let id1 = Ast.coerce_to_var "lc1" lc1 in - let id2 = Ast.coerce_to_var "lc2" lc2 in - <:ast< (PRODLIST $c [$id1][$id2]$body) >> + let id1 = Ast.coerce_to_var lc1 in + let id2 = Ast.coerce_to_var lc2 in + <:ast< (PRODLIST $c [$id1][$id2]$body) >> | "("; lc1 = lconstr; ","; lc2 = lconstr; ","; idl = ne_ident_comma_list; ":"; c = constr; body = product_tail -> - let id1 = Ast.coerce_to_var "lc1" lc1 in - let id2 = Ast.coerce_to_var "lc2" lc2 in - <:ast< (PRODLIST $c [$id1][$id2]($SLAM $idl $body)) >> + 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) >> | "("; lc1 = lconstr; ")" -> lc1 | "("; lc1 = lconstr; ")"; "@"; "["; cl = ne_constr_list; "]" -> <:ast< (SOAPP $lc1 ($LIST $cl)) >> @@ -109,9 +122,15 @@ GEXTEND Gram <:ast< (MATCH "SYNTH" $c ($LIST $cl)) >> | IDENT "let"; "("; b = ne_ident_comma_list; ")"; "="; c = constr; "in"; c1 = constr -> - <:ast< (LET "SYNTH" $c (LAMBDALIST (ISEVAR) ($SLAM $b $c1))) >> + <:ast< (LET "SYNTH" $c ($ABSTRACT "LAMBDALIST" + (BINDERS (BINDER (ISEVAR) ($LIST $b))) $c1)) >> + | IDENT "let"; id1 = ident ; "="; c = constr; "in"; c1 = constr -> + <:ast< (LETIN $c [$id1]$c1) >> +(* | IDENT "let"; id1 = IDENT ; "="; c = constr; "in"; c1 = constr -> + let id1 = Names.id_of_string id1 in <:ast< (LETIN $c [$id1]$c1) >> +*) | IDENT "if"; c1 = constr; IDENT "then"; c2 = constr; IDENT "else"; c3 = constr -> <:ast< ( IF "SYNTH" $c1 $c2 $c3) >> @@ -119,7 +138,9 @@ GEXTEND Gram | "<"; l1 = lconstr; ">"; IDENT "let"; "("; b = ne_ident_comma_list; ")"; "="; c = constr; "in"; c1 = constr -> - <:ast< (LET $l1 $c (LAMBDALIST (ISEVAR) ($SLAM $b $c1))) >> +(* <:ast< (CASE "NOREC" $l1 $c (LAMBDALIST (ISEVAR) ($SLAM $b $c1))) >>*) + <:ast< (LET $l1 $c ($ABSTRACT "LAMBDALIST" (BINDERS + (BINDER (ISEVAR) ($LIST $b))) $c1)) >> | "<"; l1 = lconstr; ">"; IDENT "if"; c1 = constr; IDENT "then"; c2 = constr; IDENT "else"; c3 = constr -> @@ -180,11 +201,14 @@ GEXTEND Gram | id = vardecls -> [id] ] ] ; binders: + [ [ "["; bl = ne_vardecls_list; "]" -> <:ast< (BINDERS ($LIST $bl)) >> ] ] + ; + rawbinders: [ [ "["; bl = ne_vardecls_list; "]" -> bl ] ] ; ne_binders_list: - [ [ bl = binders; bll = ne_binders_list -> bl @ bll - | bl = binders -> bl ] ] + [ [ bl = rawbinders; bll = ne_binders_list -> bl @ bll + | bl = rawbinders -> bl ] ] ; type_option: [ [ ":"; c = constr -> c @@ -206,9 +230,9 @@ GEXTEND Gram fixbinder: [ [ id = ident; "/"; recarg = Prim.number; ":"; type_ = constr; ":="; def = constr -> <:ast< (NUMFDECL $id $recarg $type_ $def) >> - | id = ident; idl = ne_binders_list; ":"; type_ = constr; + | id = ident; bl = ne_binders_list; ":"; type_ = constr; ":="; def = constr -> - <:ast< (FDECL $id (BINDERS ($LIST $idl)) $type_ $def) >> ] ] + <:ast< (FDECL $id (BINDERS ($LIST $bl)) $type_ $def) >> ] ] ; fixbinders: [ [ fb = fixbinder; "with"; fbs = fixbinders -> fb::fbs @@ -225,9 +249,9 @@ GEXTEND Gram product_tail: [ [ ";"; idl = ne_ident_comma_list; ":"; c = constr; c2 = product_tail -> - <:ast< (PRODLIST $c ($SLAM $idl $c2)) >> + <:ast< ($ABSTRACT "PRODLIST" (BINDERS (BINDER $c ($LIST $idl))) $c2) >> | ";"; idl = ne_ident_comma_list; c2 = product_tail -> - <:ast< (PRODLIST (ISEVAR) ($SLAM $idl $c2)) >> + <:ast< ($ABSTRACT "PRODLIST" (BINDERS (BINDER (ISEVAR) ($LIST $idl))) $c2) >> | ")"; c = constr -> c ] ] ; END;; diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4 index b027f8f4de..dc69dca1ad 100644 --- a/parsing/g_ltac.ml4 +++ b/parsing/g_ltac.ml4 @@ -48,8 +48,8 @@ GEXTEND Gram [ [ id = constrarg; "["; pc = constrarg; "]" -> (match id with | Coqast.Node(_,"COMMAND", - [Coqast.Node(_,"QUALID",[Coqast.Nvar(_,s)])]) -> - <:ast< (SUBTERM ($VAR $s) $pc) >> + [Coqast.Node(_,"QUALID",[Coqast.Nvar(_,_) as s])]) -> + <:ast< (SUBTERM $s $pc) >> | _ -> errorlabstrm "Gram.match_pattern" [<'sTR "Not a correct SUBTERM">]) | "["; pc = constrarg; "]" -> <:ast< (SUBTERM $pc) >> @@ -124,7 +124,7 @@ GEXTEND Gram <:ast< (MATCH $com ($LIST $mrl)) >> | "("; te = tactic_expr; ")" -> te | "("; te = tactic_expr; tel=LIST1 tactic_expr; ")" -> - <:ast< (APP $te ($LIST tel)) >> + <:ast< (APP $te ($LIST $tel)) >> | IDENT "First" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> <:ast<(FIRST ($LIST $l))>> | IDENT "Info"; tc = tactic_expr -> <:ast< (INFO $tc) >> @@ -152,8 +152,8 @@ GEXTEND Gram | l = Constr.qualid -> (match l with | [id] -> id - | _ -> <:ast< (QUALIDARG ($LIST l)) >>) - | id = METAIDENT -> <:ast< ($VAR $id) >> + | _ -> <:ast< (QUALIDARG ($LIST $l)) >>) + | id = Prim.metaident -> id | "?" -> <:ast< (COMMAND (ISEVAR)) >> | "?"; n = Prim.number -> <:ast< (COMMAND (META $n)) >> | IDENT "Eval"; rtc = Tactic.red_tactic; "in"; c = Constr.constr -> diff --git a/parsing/g_prim.ml4 b/parsing/g_prim.ml4 index 9c50e1fcfe..7955660650 100644 --- a/parsing/g_prim.ml4 +++ b/parsing/g_prim.ml4 @@ -10,17 +10,18 @@ open Coqast open Pcoq - +open Names open Prim GEXTEND Gram - GLOBAL: var ident metaident number string path ast astpat astact entry_type; + GLOBAL: var ident metaident number string (*path*) ast astpat + astact entry_type; - var: - [ [ s = IDENT -> Nvar(loc,s) ] ] - ; metaident: - [ [ s = METAIDENT -> Nvar(loc,s) ] ] + [ [ s = METAIDENT -> Nmeta(loc,s) ] ] + ; + var: + [ [ s = IDENT -> Nvar(loc, id_of_string s) ] ] ; ident: [ [ s = IDENT -> Id(loc,s) ] ] @@ -32,31 +33,54 @@ GEXTEND Gram [ [ s = STRING -> Str(loc,s) ] ] ; astpath: - [ [ (l,pk) = astqualid -> Path(loc,l,pk) ] ] + [ [ id = IDENT; (l,a) = astfields -> + Path(loc, make_path (make_dirpath (id_of_string id :: l)) a CCI) + | id = IDENT -> + Path(loc, make_path (make_dirpath []) (id_of_string id) Names.CCI) + ] ] ; - astqualid: - [ [ "#"; l = LIST1 IDENT SEP "#"; "."; pk = IDENT -> (l, pk) ] ] + astfields: + [ [ id = FIELD; (l,a) = astfields -> id_of_string id :: l, a + | id = FIELD -> [], id_of_string id + ] ] ; astident: - [ [ s = IDENT -> s - | s = METAIDENT -> s ] ] + [ [ s = IDENT -> s ] ] ; (* ast *) ast: - [ [ id = astident -> Nvar(loc,id) - | s = INT -> Num(loc, int_of_string s) - | s = STRING -> Str(loc,s) + [ [ id = metaident -> id | p = astpath -> p - | "{"; s = IDENT; "}" -> Id(loc,s) + | s = INT -> Num(loc, int_of_string s) + | s = STRING -> Str(loc, s) + | "{"; s = METAIDENT; "}" -> Id(loc,s) | "("; nname = astident; l = LIST0 ast; ")" -> Node(loc,nname,l) + | "("; METAIDENT "$LIST"; id = metaident; ")" -> Node(loc,"$LIST",[id]) + | "("; METAIDENT "$STR"; id = metaident; ")" -> Node(loc,"$STR",[id]) + | "("; METAIDENT "$VAR"; id = metaident; ")" -> Node(loc,"$VAR",[id]) + | "("; METAIDENT "$ID"; id = metaident; ")" -> Node(loc,"$ID",[id]) + | "("; METAIDENT "$ABSTRACT"; l = LIST0 ast;")"->Node(loc,"$ABSTRACT",l) + | "("; METAIDENT "$PATH"; id = metaident; ")" -> Node(loc,"$PATH",[id]) + | "("; METAIDENT "$NUM"; id = metaident; ")" -> Node(loc,"$NUM",[id]) + | "["; "<>"; "]"; b = ast -> Slam(loc,None,b) + | "["; a = ast; "]"; b = ast -> + (match a with + | Nvar (_,id) -> Slam(loc,Some id,b) + | Nmeta (_,s) -> Smetalam(loc,s,b) + | _ -> failwith "Slam expects a var or a metavar") + +(* | "["; ido = astidoption; "]"; b = ast -> Slam(loc,ido,b) + | "["; id = METAIDENT; "]"; b = ast -> Smetalam(loc,id,b) +*) | "'"; a = ast -> Node(loc,"$QUOTE",[a]) ] ] ; +(* astidoption: [ [ "<>" -> None - | id = astident -> Some id ] ] + | id = IDENT -> Some (id_of_string id) ] ] ; - +*) (* meta-syntax entries *) astpat: [ [ "<<" ; a = ast; ">>" -> Node loc "ASTPAT" [a] diff --git a/parsing/g_rsyntax.ml b/parsing/g_rsyntax.ml index 1cce6719d5..ff42bc01d0 100644 --- a/parsing/g_rsyntax.ml +++ b/parsing/g_rsyntax.ml @@ -16,8 +16,10 @@ exception Non_closed_number let get_r_sign loc = let ast_of_id id = Astterm.globalize_constr (Nvar(loc,id)) in - ((ast_of_id "R0", ast_of_id "R1", ast_of_id "Rplus", - ast_of_id "NRplus")) + ((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 r_of_int n dloc = let (ast0,ast1,astp,_) = get_r_sign dloc in diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index c93f807025..b1f68d0701 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -58,11 +58,11 @@ GEXTEND Gram [ [ id = idmeta_arg -> <:ast< (INHYP $id) >> ] ] ; qualidarg: - [ [ l = Constr.qualid -> <:ast< (QUALIDARG ($LIST l)) >> + [ [ l = Constr.qualid -> <:ast< (QUALIDARG ($LIST $l)) >> | "?"; n = Prim.number -> <:ast< (QUALIDMETA $n) >> ] ] ; qualidconstarg: - [ [ l = Constr.qualid -> <:ast< (QUALIDCONSTARG ($LIST l)) >> ] ] + [ [ l = Constr.qualid -> <:ast< (QUALIDCONSTARG ($LIST $l)) >> ] ] ; pure_numarg: [ [ n = Prim.number -> n @@ -94,8 +94,8 @@ GEXTEND Gram ident_or_constrarg: [ [ c = Constr.constr -> match c with - | Coqast.Nvar(_,s) -> <:ast<($VAR $s)>> - | Coqast.Node(_,"QUALID",[Coqast.Nvar(_,s)]) -> <:ast<($VAR $s)>> + | Coqast.Nvar(_,s) -> c + | Coqast.Node(_,"QUALID",[Coqast.Nvar(_,s) as c]) -> c | _ -> <:ast< (COMMAND $c) >> ] ] ; ne_identarg_list: @@ -167,9 +167,9 @@ GEXTEND Gram binding_list: [ [ c1 = constrarg; ":="; c2 = constrarg; bl = simple_binding_list -> let id = match c1 with - | Coqast.Node(_,"COMMAND",[c]) -> coerce_to_var "c1" c + | Coqast.Node(_,"COMMAND",[c]) -> coerce_to_var c | _ -> assert false - in <:ast<(BINDINGS (BINDING ($VAR $id) $c2) ($LIST $bl))>> + in <:ast<(BINDINGS (BINDING $id $c2) ($LIST $bl))>> | n = pure_numarg; ":="; c = constrarg; bl = simple_binding_list -> <:ast<(BINDINGS (BINDING $n $c) ($LIST $bl))>> | c1 = constrarg; bl = com_binding_list -> @@ -203,20 +203,20 @@ GEXTEND Gram | IDENT "Iota" -> <:ast< (Iota) >> | IDENT "Zeta" -> <:ast< (Zeta) >> | IDENT "Evar" -> <:ast< (Evar) >> - | "["; idl = ne_qualidarg_list; "]" -> <:ast< (Unf ($LIST idl)) >> + | "["; idl = ne_qualidarg_list; "]" -> <:ast< (Unf ($LIST $idl)) >> | "-"; "["; idl = ne_qualidarg_list; "]" -> - <:ast< (UnfBut ($LIST idl)) >> ] ] + <:ast< (UnfBut ($LIST $idl)) >> ] ] ; red_tactic: [ [ IDENT "Red" -> <:ast< (Red) >> | IDENT "Hnf" -> <:ast< (Hnf) >> | IDENT "Simpl" -> <:ast< (Simpl) >> - | IDENT "Cbv"; s = LIST1 red_flag -> <:ast< (Cbv ($LIST s)) >> - | IDENT "Lazy"; s = LIST1 red_flag -> <:ast< (Lazy ($LIST s)) >> + | IDENT "Cbv"; s = LIST1 red_flag -> <:ast< (Cbv ($LIST $s)) >> + | IDENT "Lazy"; s = LIST1 red_flag -> <:ast< (Lazy ($LIST $s)) >> | IDENT "Compute" -> <:ast< (Cbv (Beta) (Delta) (Evar) (Iota) (Zeta)) >> | IDENT "Unfold"; ul = ne_unfold_occ_list -> - <:ast< (Unfold ($LIST ul)) >> - | IDENT "Fold"; cl = constrarg_list -> <:ast< (Fold ($LIST cl)) >> + <:ast< (Unfold ($LIST $ul)) >> + | IDENT "Fold"; cl = constrarg_list -> <:ast< (Fold ($LIST $cl)) >> | IDENT "Pattern"; pl = ne_pattern_list -> <:ast< (Pattern ($LIST $pl)) >> ] ] ; @@ -228,7 +228,7 @@ GEXTEND Gram [ [ l = LIST1 hypident -> l ] ] ; clausearg: - [ [ "in"; idl = ne_hyp_list -> <:ast< (CLAUSE ($LIST idl)) >> + [ [ "in"; idl = ne_hyp_list -> <:ast< (CLAUSE ($LIST $idl)) >> | -> <:ast< (CLAUSE) >> ] ] ; fixdecl: diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 20bc8732d4..b325dbba91 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -55,8 +55,8 @@ GEXTEND Gram theorem_body_line: [ [ n = numarg; ":"; tac = tacarg; "." -> - <:ast< (VERNACCALL {SOLVE} $n (TACTIC $tac)) >> - | tac = tacarg; "." -> <:ast< (VERNACCALL {SOLVE} 1 (TACTIC $tac)) >> + <:ast< (VERNACCALL "SOLVE" $n (TACTIC $tac)) >> + | tac = tacarg; "." -> <:ast< (VERNACCALL "SOLVE" 1 (TACTIC $tac)) >> ] ] ; theorem_body_line_list: @@ -113,8 +113,8 @@ GEXTEND Gram | -> [] ] ] ; binders_list: - [ [ idl = Constr.ne_binders_list -> idl - | -> [] ] ] + [ [ idl = Constr.ne_binders_list -> <:ast< (BINDERS ($LIST $idl)) >> + | -> <:ast< (BINDERS) >> ] ] ; gallina: (* Definition, Goal *) @@ -170,8 +170,8 @@ GEXTEND Gram | IDENT "Structure" -> <:ast< "Structure" >> ] ] ; constructor: - [ [ id = IDENT; ":"; c = Constr.constr -> - <:ast< (BINDER $c ($VAR $id)) >> ] ] + [ [ id = identarg; ":"; c = Constr.constr -> + <:ast< (BINDER $c $id) >> ] ] ; ne_constructor_list: [ [ idc = constructor; "|"; l = ne_constructor_list -> idc :: l @@ -346,16 +346,16 @@ GEXTEND Gram (* Coercions *) | IDENT "Coercion"; qid = qualidarg; ":="; c = def_body -> - let s = Ast.coerce_to_var "qid" qid in - <:ast< (DEFINITION "COERCION" ($VAR $s) $c) >> + let s = Ast.coerce_to_var qid in + <:ast< (DEFINITION "COERCION" $s $c) >> | IDENT "Coercion"; IDENT "Local"; qid = qualidarg; ":="; c = constrarg -> - let s = Ast.coerce_to_var "qid" qid in - <:ast< (DEFINITION "LCOERCION" ($VAR $s) $c) >> + let s = Ast.coerce_to_var qid in + <:ast< (DEFINITION "LCOERCION" $s $c) >> | IDENT "Coercion"; IDENT "Local"; qid = qualidarg; ":="; c1 = Constr.constr; ":"; c2 = Constr.constr -> - let s = Ast.coerce_to_var "qid" qid in - <:ast< (DEFINITION "LCOERCION" ($VAR $s) (CONSTR (CAST $c1 $c2))) >> + let s = Ast.coerce_to_var qid in + <:ast< (DEFINITION "LCOERCION" $s (CONSTR (CAST $c1 $c2))) >> | IDENT "Identity"; IDENT "Coercion"; IDENT "Local"; f = qualidarg; ":"; c = qualidarg; ">->"; d = qualidarg -> <:ast< (COERCION "LOCAL" "IDENTITY" $f $c $d) >> @@ -420,20 +420,20 @@ GEXTEND Gram <:ast< (CompileFile ($STR $verbosely) ($STR $only_spec) ($STR $mname) ($STR $fname))>> *) - | IDENT "Read"; IDENT "Module"; id = identarg -> - <:ast< (ReadModule $id) >> + | IDENT "Read"; IDENT "Module"; qid = qualidarg -> + <:ast< (ReadModule $qid) >> | IDENT "Require"; import = import_tok; specif = specif_tok; - id = identarg -> <:ast< (Require $import $specif $id) >> + qid = qualidarg -> <:ast< (Require $import $specif $qid) >> | IDENT "Require"; import = import_tok; specif = specif_tok; - id = identarg; filename = stringarg -> - <:ast< (RequireFrom $import $specif $id $filename) >> + qid = qualidarg; filename = stringarg -> + <:ast< (RequireFrom $import $specif $qid $filename) >> | IDENT "Write"; IDENT "Module"; id = identarg -> <:ast< (WriteModule $id) >> | IDENT "Write"; IDENT "Module"; id = identarg; s = stringarg -> <:ast< (WriteModule $id $s) >> | IDENT "Declare"; IDENT "ML"; IDENT "Module"; l = ne_stringarg_list -> <:ast< (DeclareMLModule ($LIST $l)) >> - | IDENT "Import"; id = identarg -> <:ast< (ImportModule $id) >> + | IDENT "Import"; qid = qualidarg -> <:ast< (ImportModule $qid) >> ] ] diff --git a/parsing/g_zsyntax.ml b/parsing/g_zsyntax.ml index 96f9bc6111..8b94b4fd7b 100644 --- a/parsing/g_zsyntax.ml +++ b/parsing/g_zsyntax.ml @@ -17,9 +17,14 @@ open Ast let get_z_sign loc = let ast_of_id id = Astterm.globalize_constr (Nvar(loc,id)) in - ((ast_of_id "xI", ast_of_id "xO", ast_of_id "xH"), - (ast_of_id "ZERO", ast_of_id "POS", ast_of_id "NEG"), - (ast_of_id "My_special_variable0", ast_of_id "My_special_variable1")) + ((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")), + (ast_of_id (id_of_string "My_special_variable0"), + ast_of_id (id_of_string "My_special_variable1"))) let int_array_of_string s = let a = Array.create (String.length s) 0 in diff --git a/parsing/lexer.ml4 b/parsing/lexer.ml4 index 065ed4350d..a3ea85e022 100644 --- a/parsing/lexer.ml4 +++ b/parsing/lexer.ml4 @@ -116,7 +116,8 @@ let add_token (con, str) = match con with true in if normal_token then add_keyword str else add_special_token str - | "METAIDENT" | "IDENT" | "FIELD" | "INT" | "STRING" | "EOI" -> () + | "METAIDENT" | "IDENT" | "FIELD" | "INT" | "STRING" | "EOI" + -> () | _ -> raise (Token.Error ("\ the constructor \"" ^ con ^ "\" is not recognized by Lexer")) diff --git a/parsing/pcoq.ml4 b/parsing/pcoq.ml4 index 8680734efd..05bf62b997 100644 --- a/parsing/pcoq.ml4 +++ b/parsing/pcoq.ml4 @@ -133,6 +133,7 @@ let parse_string f x = let slam_ast (_,fin) id ast = match id with | Coqast.Nvar ((deb,_), s) -> Coqast.Slam ((deb,fin), Some s, ast) + | Coqast.Nmeta ((deb,_), s) -> Coqast.Smetalam ((deb,fin), s, ast) | _ -> invalid_arg "Ast.slam_ast" (* This is to interpret the macro $ABSTRACT used in binders *) @@ -149,9 +150,11 @@ let abstract_binder_ast (_,fin as loc) name a b = 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 = - List.fold_right (abstract_binder_ast loc name) - +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" type entry_type = ETast | ETastl diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 807d5d8fd7..2f9c69b2e2 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -34,7 +34,7 @@ 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 list -> Coqast.t -> Coqast.t + Coqast.loc -> string -> Coqast.t -> Coqast.t -> Coqast.t (* Entry types *) diff --git a/parsing/pretty.ml b/parsing/pretty.ml new file mode 100644 index 0000000000..da0398dcd5 --- /dev/null +++ b/parsing/pretty.ml @@ -0,0 +1,597 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +(* $Id$ *) + +open Pp +open Util +open Names +open Term +open Declarations +open Inductive +open Sign +open Reduction +open Environ +open Instantiate +open Library +open Declare +open Impargs +open Libobject +open Printer +open Nametab + +let print_basename sp = pr_global (ConstRef sp) + +let print_closed_sections = ref false + +let print_typed_value_in_env env (trm,typ) = + [< prterm_env env trm ; 'fNL ; + 'sTR " : "; prtype_env env typ ; 'fNL >] + +let print_typed_value x = print_typed_value_in_env (Global.env ()) x + +let pkprinters = function + | FW -> (fprterm,fprterm_env) + | CCI -> (prterm,prterm_env) + | _ -> anomaly "pkprinters" + +let print_impl_args = function + | [] -> [<>] + | [i] -> [< 'sTR"Position ["; 'iNT i; 'sTR"] is implicit" >] + | l -> + [< 'sTR"Positions ["; + prlist_with_sep (fun () -> [< 'sTR";" >]) (fun i -> [< 'iNT i >]) l; + 'sTR"] are implicit" >] + +(* To be improved; the type should be used to provide the types in the + abstractions. This should be done recursively inside prterm, so that + the pretty-print of a proposition (P:(nat->nat)->Prop)(P [u]u) + synthesizes the type nat of the abstraction on u *) + +let print_named_def name body typ = + let pbody = prterm body in + let ptyp = prtype typ in + [< 'sTR "*** ["; 'sTR name ; 'sTR " "; + hOV 0 [< 'sTR ":="; 'bRK (1,2); pbody; 'sPC; + 'sTR ":"; 'bRK (1,2); ptyp >]; + 'sTR "]"; 'fNL >] + +let print_named_assum name typ = + [< 'sTR "*** [" ; 'sTR name ; 'sTR " : "; prtype typ; 'sTR "]"; 'fNL >] + +let print_named_decl (id,c,typ) = + let s = string_of_id id in + match c with + | Some body -> print_named_def s body typ + | None -> print_named_assum s typ + +let assumptions_for_print lna = + List.fold_right (fun na env -> add_name na env) lna empty_names_context + +let implicit_args_id id l = + if l = [] then + [<>] + else + [< 'sTR"For "; pr_id id; 'sTR": "; print_impl_args l ; 'fNL >] + +let implicit_args_msg sp mipv = + [< prvecti + (fun i mip -> + let imps = inductive_implicits_list (sp,i) in + [< (implicit_args_id mip.mind_typename imps); + prvecti + (fun j idc -> + let imps = constructor_implicits_list ((sp,i),succ j) in + (implicit_args_id idc imps)) + mip.mind_consnames + >]) + mipv >] + +let print_params env params = + if List.length params = 0 then + [<>] + else + [< 'sTR "["; pr_rel_context env params; 'sTR "]"; 'bRK(1,2) >] + +let print_constructors envpar names types = + let pc = + [< prvect_with_sep (fun () -> [<'bRK(1,0); 'sTR "| " >]) + (fun (id,c) -> [< pr_id id; 'sTR " : "; prterm_env envpar c >]) + (array_map2 (fun n t -> (n,t)) names types) >] + in hV 0 [< 'sTR " "; pc >] + +let build_inductive sp tyi = + let ctxt = context_of_global_reference (IndRef (sp,tyi)) in + let ctxt = Array.of_list (instance_from_section_context ctxt) in + let mis = Global.lookup_mind_specif ((sp,tyi),ctxt) in + let params = mis_params_ctxt mis in + let args = extended_rel_list 0 params in + let indf = make_ind_family (mis,args) in + let arity = get_arity_type indf in + let cstrtypes = get_constructors_types indf in + let cstrnames = mis_consnames mis in + (IndRef (sp,tyi), params, arity, cstrnames, cstrtypes) + +let print_one_inductive sp tyi = + let (ref, params, arity, cstrnames, cstrtypes) = build_inductive sp tyi in + let env = Global.env () in + let envpar = push_rels params env in + (hOV 0 + [< (hOV 0 + [< pr_global (IndRef (sp,tyi)) ; 'bRK(1,2); print_params env params; + 'sTR ": "; prterm_env envpar arity; 'sTR " :=" >]); + 'bRK(1,2); print_constructors envpar cstrnames cstrtypes >]) + +let print_mutual sp = + let mipv = (Global.lookup_mind sp).mind_packets in + if Array.length mipv = 1 then + let (ref, params, arity, cstrnames, cstrtypes) = build_inductive sp 0 in + let sfinite = + if mipv.(0).mind_finite then "Inductive " else "CoInductive " in + let env = Global.env () in + let envpar = push_rels params env in + (hOV 0 [< + 'sTR sfinite ; + pr_global (IndRef (sp,0)); 'bRK(1,2); + print_params env params; 'bRK(1,5); + 'sTR": "; prterm_env envpar arity; 'sTR" :="; + 'bRK(0,4); print_constructors envpar cstrnames cstrtypes; 'fNL; + implicit_args_msg sp mipv >] ) + (* Mutual [co]inductive definitions *) + else + let _,(mipli,miplc) = + Array.fold_right + (fun mi (n,(li,lc)) -> + if mi.mind_finite then (n+1,(n::li,lc)) else (n+1,(li,n::lc))) + mipv (0,([],[])) + in + let strind = + if mipli = [] then [<>] + else [< 'sTR "Inductive"; 'bRK(1,4); + (prlist_with_sep + (fun () -> [< 'fNL; 'sTR" with"; 'bRK(1,4) >]) + (print_one_inductive sp) mipli); 'fNL >] + and strcoind = + if miplc = [] then [<>] + else [< 'sTR "CoInductive"; 'bRK(1,4); + (prlist_with_sep + (fun () -> [<'fNL; 'sTR " with"; 'bRK(1,4) >]) + (print_one_inductive sp) miplc); 'fNL >] + in + (hV 0 [< 'sTR"Mutual " ; + if mipv.(0).mind_finite then + [< strind; strcoind >] + else + [<strcoind; strind>]; + implicit_args_msg sp mipv >]) + +(* + let env = Global.env () in + let evd = Evd.empty in + let {mind_packets=mipv} = mib in + (* On suppose que tous les inductifs ont les même paramètres *) + let nparams = mipv.(0).mind_nparams in + let (lpars,_) = decomp_n_prod env evd nparams + (body_of_type (mind_user_arity mipv.(0))) in + let arities = Array.map (fun mip -> (Name mip.mind_typename, None, mip.mind_nf_arity)) mipv in + let env_ar = push_rels lpars env in + let pr_constructor (id,c) = + [< pr_id id; 'sTR " : "; prterm_env env_ar c >] in + let print_constructors mis = + let (_,lC) = mis_type_mconstructs mis in + let lidC = + array_map2 (fun id c -> (id, snd (decomp_n_prod env evd nparams c))) + (mis_consnames mis) lC in + let plidC = + prvect_with_sep (fun () -> [<'bRK(0,0); 'sTR "| " >]) + pr_constructor + lidC + in + hV 0 [< 'sTR " "; plidC >] + in + let params = + if nparams = 0 then + [<>] + else + [< 'sTR "["; pr_rel_context env lpars; 'sTR "]"; 'bRK(1,2) >] in + let print_oneind tyi = + let mis = + build_mis + ((sp,tyi), + Array.of_list (instance_from_section_context mib.mind_hyps)) + mib in + let (_,arity) = decomp_n_prod env evd nparams + (body_of_type (mis_user_arity mis)) in + (hOV 0 + [< (hOV 0 + [< pr_global (IndRef (sp,tyi)) ; 'bRK(1,2); params; + 'sTR ": "; prterm_env env_ar arity; 'sTR " :=" >]); + 'bRK(1,2); print_constructors mis >]) + in + let mis0 = + build_mis + ((sp,0),Array.of_list (instance_from_section_context mib.mind_hyps)) + mib in + (* Case one [co]inductive *) + if Array.length mipv = 1 then + let (_,arity) = decomp_n_prod env evd nparams + (body_of_type (mis_user_arity mis0)) in + let sfinite = if mis_finite mis0 then "Inductive " else "CoInductive " in + (hOV 0 [< 'sTR sfinite ; pr_global (IndRef (sp,0)); + if nparams = 0 then + [<>] + else + [< 'sTR" ["; pr_rel_context env lpars; 'sTR "]">]; + 'bRK(1,5); 'sTR": "; prterm_env env_ar arity; 'sTR" :="; + 'bRK(0,4); print_constructors mis0; 'fNL; + implicit_args_msg sp mipv >] ) + (* Mutual [co]inductive definitions *) + else + let _,(mipli,miplc) = + List.fold_left + (fun (n,(li,lc)) mi -> + if mi.mind_finite then (n+1,(n::li,lc)) else (n+1,(li,n::lc))) + (0,([],[])) (Array.to_list mipv) + in + let strind = + if mipli = [] then [<>] + else [< 'sTR "Inductive"; 'bRK(1,4); + (prlist_with_sep + (fun () -> [< 'fNL; 'sTR" with"; 'bRK(1,4) >]) + print_oneind + (List.rev mipli)); 'fNL >] + and strcoind = + if miplc = [] then [<>] + else [< 'sTR "CoInductive"; 'bRK(1,4); + (prlist_with_sep + (fun () -> [<'fNL; 'sTR " with"; 'bRK(1,4) >]) + print_oneind (List.rev miplc)); 'fNL >] + in + (hV 0 [< 'sTR"Mutual " ; + if mis_finite mis0 then + [< strind; strcoind >] + else + [<strcoind; strind>]; + implicit_args_msg sp mipv >]) +*) +let print_section_variable sp = + let (d,_,_) = get_variable sp in + let l = implicits_of_var sp in + [< print_named_decl d; print_impl_args l; 'fNL >] + +let print_body = function + | Some c -> prterm c + | None -> [< 'sTR"<no body>" >] + +let print_typed_body (val_0,typ) = + [< print_body val_0; 'fNL; 'sTR " : "; prtype typ; 'fNL >] + +let print_constant with_values sep sp = + let cb = Global.lookup_constant sp in + if kind_of_path sp = CCI then + let val_0 = cb.const_body in + let typ = cb.const_type in + let impls = constant_implicits_list sp in + hOV 0 [< (match val_0 with + | None -> + [< 'sTR"*** [ "; + print_basename sp; + 'sTR " : "; 'cUT ; prtype typ ; 'sTR" ]"; 'fNL >] + | _ -> + [< print_basename sp; + 'sTR sep; 'cUT ; + if with_values then + print_typed_body (val_0,typ) + else + [< prtype typ ; 'fNL >] >]); + print_impl_args impls; 'fNL >] + else + hOV 0 [< 'sTR"Fw constant " ; + print_basename sp ; 'fNL>] + +let print_inductive sp = + if kind_of_path sp = CCI then + [< print_mutual sp; 'fNL >] + else + hOV 0 [< 'sTR"Fw inductive definition "; + print_basename sp; 'fNL >] + +let print_syntactic_def sep sp = + let id = basename sp in + let c = Syntax_def.search_syntactic_definition sp in + [< 'sTR" Syntactif Definition "; pr_id id ; 'sTR sep; pr_rawterm c; 'fNL >] + +let print_leaf_entry with_values sep (sp,lobj) = + let tag = object_tag lobj in + match (sp,tag) with + | (_,"VARIABLE") -> + print_section_variable sp + | (_,("CONSTANT"|"PARAMETER")) -> + print_constant with_values sep sp + | (_,"INDUCTIVE") -> + print_inductive sp + | (_,"AUTOHINT") -> + [< 'sTR" Hint Marker"; 'fNL >] + | (_,"GRAMMAR") -> + [< 'sTR" Grammar Marker"; 'fNL >] + | (_,"SYNTAXCONSTANT") -> + print_syntactic_def sep sp + | (_,"PPSYNTAX") -> + [< 'sTR" Syntax Marker"; 'fNL >] + | (_,"TOKEN") -> + [< 'sTR" Token Marker"; 'fNL >] + | (_,"CLASS") -> + [< 'sTR" Class Marker"; 'fNL >] + | (_,"COERCION") -> + [< 'sTR" Coercion Marker"; 'fNL >] + | (_,"REQUIRE") -> + [< 'sTR" Require Marker"; 'fNL >] + | (_,"END-SECTION") -> [< >] + | (_,s) -> + [< 'sTR(string_of_path sp); 'sTR" : "; + 'sTR"Unrecognized object "; 'sTR s; 'fNL >] + +let rec print_library_entry with_values ent = + let sep = if with_values then " = " else " : " in + match ent with + | (sp,Lib.Leaf lobj) -> + [< print_leaf_entry with_values sep (sp,lobj) >] + | (_,Lib.OpenedSection (str,_)) -> + [< 'sTR(" >>>>>>> Section "^(string_of_id str)); 'fNL >] + | (sp,Lib.ClosedSection _) -> + [< 'sTR" >>>>>>> Closed Section "; pr_id (basename sp); + 'fNL >] + | (_,Lib.Module dir) -> + [< 'sTR(" >>>>>>> Module " ^ (string_of_dirpath dir)); 'fNL >] + | (_,Lib.FrozenState _) -> + [< >] + +and print_context with_values = + let rec prec = function + | h::rest -> [< prec rest ; print_library_entry with_values h >] + | [] -> [< >] + in + prec + +let print_full_context () = print_context true (Lib.contents_after None) + +let print_full_context_typ () = print_context false (Lib.contents_after None) + +(* For printing an inductive definition with + its constructors and elimination, + assume that the declaration of constructors and eliminations + follows the definition of the inductive type *) + +let list_filter_vec f vec = + let rec frec n lf = + if n < 0 then lf + else if f vec.(n) then + frec (n-1) (vec.(n)::lf) + else + frec (n-1) lf + in + frec (Array.length vec -1) [] + +let read_sec_context qid = + let dir = Nametab.locate_section qid in + let rec get_cxt in_cxt = function + | ((sp,Lib.OpenedSection (_,_)) as hd)::rest -> + let dir' = make_dirpath (wd_of_sp sp) in + if dir = dir' then (hd::in_cxt) else get_cxt (hd::in_cxt) rest + | [] -> [] + | hd::rest -> get_cxt (hd::in_cxt) rest + in + let cxt = (Lib.contents_after None) in + List.rev (get_cxt [] cxt) + +let print_sec_context sec = print_context true (read_sec_context sec) + +let print_sec_context_typ sec = print_context false (read_sec_context sec) + +let print_judgment env {uj_val=trm;uj_type=typ} = + print_typed_value_in_env env (trm, typ) + +let print_safe_judgment env j = + let trm = Safe_typing.j_val j in + let typ = Safe_typing.j_type j in + print_typed_value_in_env env (trm, typ) + +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 qid = + try + let sp = Nametab.locate_obj qid in + let (sp,lobj) = + let (sp,entry) = + List.find (fun en -> (fst en) = sp) (Lib.contents_after None) + in + match entry with + | Lib.Leaf obj -> (sp,obj) + | _ -> raise Not_found + in + print_leaf_entry true " = " (sp,lobj) + with Not_found -> + try + match Nametab.locate qid with + | ConstRef sp -> print_constant true " = " sp + | IndRef (sp,_) -> print_inductive sp + | ConstructRef ((sp,_),_) -> print_inductive sp + | VarRef sp -> print_section_variable sp + with Not_found -> + try (* Var locale de but, pas var de section... donc pas d'implicits *) + let dir,str = repr_qualid qid in + if dir <> [] then raise Not_found; + let (c,typ) = Global.lookup_named str in + [< print_named_decl (str,c,typ) >] + with Not_found -> + try + let sp = Syntax_def.locate_syntactic_definition qid in + print_syntactic_def " = " sp + with Not_found -> + errorlabstrm "print_name" + [< pr_qualid qid; 'sPC; 'sTR "not a defined object" >] + +let print_opaque_name qid = + let sigma = Evd.empty in + let env = Global.env () in + let sign = Global.named_context () in + try + let x = global_qualified_reference qid in + match kind_of_term x with + | IsConst (sp,_ as cst) -> + let cb = Global.lookup_constant sp in + if is_defined cb then + print_constant true " = " sp + else + error "not a defined constant" + | IsMutInd ((sp,_),_) -> + print_mutual sp + | IsMutConstruct cstr -> + let ty = Typeops.type_of_constructor env sigma cstr in + print_typed_value (x, ty) + | IsVar id -> + let (c,ty) = lookup_named id env in + print_named_decl (id,c,ty) + | _ -> + assert false + with Not_found -> + errorlabstrm "print_opaque" [< pr_qualid qid; 'sPC; 'sTR "not declared" >] + +let print_local_context () = + let env = Lib.contents_after None in + let rec print_var_rec = function + | [] -> [< >] + | (sp,Lib.Leaf lobj)::rest -> + if "VARIABLE" = object_tag lobj then + let (d,_,_) = get_variable sp in + [< print_var_rec rest; + print_named_decl d >] + else + print_var_rec rest + | _::rest -> print_var_rec rest + + and print_last_const = function + | (sp,Lib.Leaf lobj)::rest -> + (match object_tag lobj with + | "CONSTANT" | "PARAMETER" -> + let {const_body=val_0;const_type=typ} = + Global.lookup_constant sp in + [< print_last_const rest; + print_basename sp ;'sTR" = "; + print_typed_body (val_0,typ) >] + | "INDUCTIVE" -> + [< print_last_const rest;print_mutual sp; 'fNL >] + | "VARIABLE" -> [< >] + | _ -> print_last_const rest) + | _ -> [< >] + in + [< print_var_rec env; print_last_const env >] + +let fprint_var name typ = + [< 'sTR ("*** [" ^ name ^ " :"); fprtype typ; 'sTR "]"; 'fNL >] + +let fprint_judge {uj_val=trm;uj_type=typ} = + [< fprterm trm; 'sTR" : " ; fprterm (body_of_type typ) >] + +let unfold_head_fconst = + let rec unfrec k = match kind_of_term k with + | IsConst cst -> constant_value (Global.env ()) cst + | IsLambda (na,t,b) -> mkLambda (na,t,unfrec b) + | IsApp (f,v) -> appvect (unfrec f,v) + | _ -> k + in + unfrec + +(* for debug *) +let inspect depth = + let rec inspectrec n res env = + if n=0 or env=[] then + res + else + inspectrec (n-1) (List.hd env::res) (List.tl env) + in + let items = List.rev (inspectrec depth [] (Lib.contents_after None)) in + print_context false items + + +(*************************************************************************) +(* Pretty-printing functions coming from classops.ml *) + +open Classops + +let string_of_strength = function + | NotDeclare -> "(temp)" + | NeverDischarge -> "(global)" + | DischargeAt sp -> "(disch@"^(string_of_dirpath sp) + +let print_coercion_value v = prterm (get_coercion_value v) + +let print_index_coercion c = + let _,v = coercion_info_from_index c in + print_coercion_value v + +let print_class i = + let cl,_ = class_info_from_index i in + [< 'sTR (string_of_class cl) >] + +let print_path ((i,j),p) = + [< 'sTR"["; + prlist_with_sep (fun () -> [< 'sTR"; " >]) + (fun c -> print_index_coercion c) p; + 'sTR"] : "; print_class i; 'sTR" >-> "; + print_class j >] + +let _ = Classops.install_path_printer print_path + +let print_graph () = + [< prlist_with_sep pr_fnl print_path (inheritance_graph()) >] + +let print_classes () = + [< prlist_with_sep pr_spc + (fun (_,(cl,x)) -> + [< 'sTR (string_of_class cl) + (*; 'sTR(string_of_strength x.cl_strength) *) >]) + (classes()) >] + +let print_coercions () = + [< prlist_with_sep pr_spc + (fun (_,(_,v)) -> [< print_coercion_value v >]) (coercions()) >] + +let cl_of_id id = + match string_of_id id with + | "FUNCLASS" -> CL_FUN + | "SORTCLASS" -> CL_SORT + | _ -> let v = Declare.global_reference CCI id in + let cl,_ = constructor_at_head v in + cl + +let index_cl_of_id id = + try + let cl = cl_of_id id in + let i,_ = class_info cl in + i + with _ -> + errorlabstrm "index_cl_of_id" + [< 'sTR(string_of_id id); 'sTR" is not a defined class" >] + +let print_path_between ids idt = + let i = (index_cl_of_id ids) in + let j = (index_cl_of_id idt) in + let p = + try + lookup_path_between (i,j) + with _ -> + errorlabstrm "index_cl_of_id" + [< 'sTR"No path between ";'sTR(string_of_id ids); + 'sTR" and ";'sTR(string_of_id ids) >] + in + print_path ((i,j),p) + +(*************************************************************************) diff --git a/parsing/prettyp.ml b/parsing/prettyp.ml index 6044767c2c..cbb0ba6640 100644 --- a/parsing/prettyp.ml +++ b/parsing/prettyp.ml @@ -340,13 +340,12 @@ let rec print_library_entry with_values ent = match ent with | (sp,Lib.Leaf lobj) -> [< print_leaf_entry with_values sep (sp,lobj) >] - | (_,Lib.OpenedSection (str,_)) -> - [< 'sTR(" >>>>>>> Section " ^ str); 'fNL >] + | (_,Lib.OpenedSection (id,_)) -> + [< 'sTR " >>>>>>> Section "; pr_id id; 'fNL >] | (sp,Lib.ClosedSection _) -> - [< 'sTR(" >>>>>>> Closed Section " ^ (string_of_id (basename sp))); - 'fNL >] + [< 'sTR " >>>>>>> Closed Section "; pr_id (basename sp); 'fNL >] | (_,Lib.Module dir) -> - [< 'sTR(" >>>>>>> Module " ^ (string_of_dirpath dir)); 'fNL >] + [< 'sTR " >>>>>>> Module "; pr_dirpath dir; 'fNL >] | (_,Lib.FrozenState _) -> [< >] @@ -377,10 +376,13 @@ let list_filter_vec f vec = frec (Array.length vec -1) [] let read_sec_context qid = - let sp, _ = Nametab.locate_module qid in + let dir = + try Nametab.locate_section qid + with Not_found -> error "Unknown section" in let rec get_cxt in_cxt = function - | ((sp',Lib.OpenedSection (str,_)) as hd)::rest -> - if sp' = sp then (hd::in_cxt) else get_cxt (hd::in_cxt) rest + | ((sp,Lib.OpenedSection (_,_)) as hd)::rest -> + let dir' = make_dirpath (wd_of_sp sp) in + if dir = dir' then (hd::in_cxt) else get_cxt (hd::in_cxt) rest | [] -> [] | hd::rest -> get_cxt (hd::in_cxt) rest in @@ -405,7 +407,7 @@ let print_eval red_fun env {uj_val=trm;uj_type=typ} = let print_name qid = try - let sp,_ = Nametab.locate_obj qid in + let sp = Nametab.locate_obj qid in let (sp,lobj) = let (sp,entry) = List.find (fun en -> (fst en) = sp) (Lib.contents_after None) diff --git a/parsing/printer.ml b/parsing/printer.ml index 858c806672..52300882a2 100644 --- a/parsing/printer.ml +++ b/parsing/printer.ml @@ -48,14 +48,14 @@ let global_constr_name ((sp,tyi),i) = ^","^(string_of_int i)^")") >] let globpr gt = match gt with - | Nvar(_,s) -> [< 'sTR s >] + | Nvar(_,s) -> [< pr_id s >] | Node(_,"EVAR", [Num (_,ev)]) -> [< 'sTR ("?" ^ (string_of_int ev)) >] - | Node(_,"CONST",[Path(_,sl,s)]) -> - global_const_name (section_path sl s) - | Node(_,"MUTIND",[Path(_,sl,s); Num(_,tyi)]) -> - global_ind_name (section_path sl s, tyi) - | Node(_,"MUTCONSTRUCT",[Path(_,sl,s); Num(_,tyi); Num(_,i)]) -> - global_constr_name ((section_path sl s, tyi), i) + | Node(_,"CONST",[Path(_,sl)]) -> + global_const_name (section_path sl) + | Node(_,"MUTIND",[Path(_,sl); Num(_,tyi)]) -> + global_ind_name (section_path sl, tyi) + | Node(_,"MUTCONSTRUCT",[Path(_,sl); Num(_,tyi); Num(_,i)]) -> + global_constr_name ((section_path sl, tyi), i) | gt -> dfltpr gt let wrap_exception = function @@ -135,18 +135,18 @@ let rec gentacpr gt = Esyntax.genprint default_tacpr tactic_syntax_universe tactic_initial_prec gt and default_tacpr = function - | Nvar(_,s) -> [< 'sTR s >] + | Nvar(_,s) -> [< pr_id s >] (* constr's may occur inside tac expressions ! *) | Node(_,"EVAR", [Num (_,ev)]) -> [< 'sTR ("?" ^ (string_of_int ev)) >] - | Node(_,"CONST",[Path(_,sl,s)]) -> - let sp = section_path sl s in - pr_global (ConstRef (section_path sl s)) - | Node(_,"MUTIND",[Path(_,sl,s); Num(_,tyi)]) -> - let sp = section_path sl s in + | Node(_,"CONST",[Path(_,sl)]) -> + let sp = section_path sl in + pr_global (ConstRef sp) + | Node(_,"MUTIND",[Path(_,sl); Num(_,tyi)]) -> + let sp = section_path sl in pr_global (IndRef (sp,tyi)) - | Node(_,"MUTCONSTRUCT",[Path(_,sl,s); Num(_,tyi); Num(_,i)]) -> - let sp = section_path sl s in + | Node(_,"MUTCONSTRUCT",[Path(_,sl); Num(_,tyi); Num(_,i)]) -> + let sp = section_path sl in pr_global (ConstructRef ((sp,tyi),i)) (* This should be tactics *) diff --git a/parsing/q_coqast.ml4 b/parsing/q_coqast.ml4 index e8ee0c67d0..90d2f1babe 100644 --- a/parsing/q_coqast.ml4 +++ b/parsing/q_coqast.ml4 @@ -36,51 +36,62 @@ let anti loc x = (* which will bind their actual ast value *) let rec expr_of_ast = function - | Coqast.Nvar loc id when is_meta id -> anti loc id - | Coqast.Id loc id when is_meta id -> anti loc id - | Coqast.Node _ "$VAR" [Coqast.Nvar loc x] -> - <:expr< Coqast.Nvar loc $anti loc x$ >> - | Coqast.Node loc "$PATH" l -> - let extract_var = function - | Coqast.Nvar loc id -> id - | Coqast.Id loc id -> failwith ("Id"^id) - | Coqast.Node _ s _ -> failwith ("Node"^s) - | _ -> failwith "Path is not built from ast variables" in - let l = List.map extract_var l in - let l = expr_list_of_var_list l in - <:expr< Coqast.Path loc $l$ Names.CCI >> - | Coqast.Node _ "$ID" [Coqast.Nvar loc x] -> + | Coqast.Nmeta loc id -> anti loc id + | Coqast.Id loc id when is_meta id -> <:expr< Coqast.Id loc $anti loc id$ >> + | Coqast.Node _ "$VAR" [Coqast.Nmeta loc x] -> + <:expr< let s = $anti loc x$ in + if String.length s > 0 && s.[0] = '$' then + failwith "Wrong ast: $VAR should not be bound to a meta variable" + else + Coqast.Nvar loc (Names.id_of_string s) >> + | Coqast.Node _ "$PATH" [Coqast.Nmeta loc x] -> + <:expr< Coqast.Path loc $anti loc x$ >> + | Coqast.Node _ "$ID" [Coqast.Nmeta loc x] -> <:expr< Coqast.Id loc $anti loc x$ >> - | Coqast.Node _ "$STR" [Coqast.Nvar loc x] -> + | Coqast.Node _ "$STR" [Coqast.Nmeta loc x] -> <:expr< Coqast.Str loc $anti loc x$ >> - | Coqast.Node _ "$SLAM" [Coqast.Nvar loc idl; y] -> +(* Obsolète + | Coqast.Node _ "$SLAM" [Coqast.Nmeta loc idl; y] -> <:expr< List.fold_right (Pcoq.slam_ast loc) $anti loc idl$ $expr_of_ast y$ >> - | Coqast.Node _ "$ABSTRACT" [Coqast.Str _ s;Coqast.Nvar loc idl; y] -> +*) + | Coqast.Node loc "$ABSTRACT" [Coqast.Str _ s; x; y] -> <:expr< - Pcoq.abstract_binders_ast loc $str:s$ $anti loc idl$ $expr_of_ast y$ >> + Pcoq.abstract_binders_ast loc $str:s$ $expr_of_ast x$ $expr_of_ast y$ >> | Coqast.Node loc nn al -> let e = expr_list_of_ast_list al in <:expr< Coqast.Node loc $str:nn$ $e$ >> - | Coqast.Nvar loc id -> <:expr< Coqast.Nvar loc $str:id$ >> + | Coqast.Nvar loc id -> + <:expr< Coqast.Nvar loc (Names.id_of_string $str:Names.string_of_id id$) >> | Coqast.Slam loc None a -> <:expr< Coqast.Slam loc None $expr_of_ast a$ >> + | Coqast.Smetalam loc s a -> + <:expr< + match $anti loc s$ with + [ Coqast.Nvar _ id -> Coqast.Slam loc (Some id) $expr_of_ast a$ + | Coqast.Nmeta _ s -> Coqast.Smetalam loc s $expr_of_ast a$ + | _ -> failwith "Slam expects a var or a metavar" ] >> | Coqast.Slam loc (Some s) a -> - let se = if is_meta s then anti loc s else <:expr< $str:s$ >> in + let se = <:expr< Names.id_of_string $str:Names.string_of_id s$ >> in <:expr< Coqast.Slam loc (Some $se$) $expr_of_ast a$ >> | Coqast.Num loc i -> <:expr< Coqast.Num loc $int:string_of_int i$ >> | Coqast.Id loc id -> <:expr< Coqast.Id loc $str:id$ >> | Coqast.Str loc str -> <:expr< Coqast.Str loc $str:str$ >> - | Coqast.Path loc sl s -> - let e = expr_list_of_var_list sl in - <:expr< Coqast.Path loc $e$ $str:s$ >> + | Coqast.Path loc qid -> + let l,a,_ = Names.repr_path qid in + let expr_of_modid id = + <:expr< Names.id_of_string $str:Names.string_of_id id$ >> in + let e = List.map expr_of_modid (Names.repr_dirpath l) in + let e = expr_list_of_var_list e in + <:expr< Coqast.Path loc (Names.make_path (Names.make_dirpath + $e$) (Names.id_of_string $str:Names.string_of_id a$) Names.CCI) >> | Coqast.Dynamic _ _ -> failwith "Q_Coqast: dynamic: not implemented" and expr_list_of_ast_list al = List.fold_right (fun a e2 -> match a with - | (Coqast.Node _ "$LIST" [Coqast.Nvar locv pv]) -> + | (Coqast.Node _ "$LIST" [Coqast.Nmeta locv pv]) -> let e1 = anti locv pv in let loc = (fst(MLast.loc_of_expr e1), snd(MLast.loc_of_expr e2)) in if e2 = (let loc = dummy_loc in <:expr< [] >>) @@ -95,8 +106,7 @@ and expr_list_of_ast_list al = and expr_list_of_var_list sl = let loc = dummy_loc in List.fold_right - (fun s e2 -> - let e1 = if is_meta s then anti loc s else <:expr< $str:s$ >> in + (fun e1 e2 -> let loc = (fst (MLast.loc_of_expr e1), snd (MLast.loc_of_expr e2)) in <:expr< [$e1$ :: $e2$] >>) sl <:expr< [] >> diff --git a/parsing/search.ml b/parsing/search.ml index 2b9a5dd448..839acb4b4e 100644 --- a/parsing/search.ml +++ b/parsing/search.ml @@ -108,15 +108,17 @@ let filter_by_module (module_list:dir_path list) (accept:bool) let sp = sp_of_global env ref in let sl = dirpath sp in let rec filter_aux = function - | m :: tl -> (not (dirpath_prefix_of m sl)) && (filter_aux tl) + | m :: tl -> (not (is_dirpath_prefix_of m sl)) && (filter_aux tl) | [] -> true in xor accept (filter_aux module_list) with No_section_path -> false -let gref_eq = IndRef (make_path ["Coq";"Init";"Logic"] (id_of_string "eq") CCI, 0) -let gref_eqT = IndRef (make_path ["Coq";"Init";"Logic_Type"] (id_of_string "eqT") CCI, 0) +let gref_eq = + IndRef (make_path Coqlib.logic_module (id_of_string "eq") CCI, 0) +let gref_eqT = + IndRef (make_path Coqlib.logic_type_module (id_of_string "eqT") CCI, 0) let mk_rewrite_pattern1 eq pattern = PApp (PRef eq, [| PMeta None; pattern; PMeta None |]) diff --git a/parsing/termast.ml b/parsing/termast.ml index 448aa148a6..431743f13a 100644 --- a/parsing/termast.ml +++ b/parsing/termast.ml @@ -77,14 +77,14 @@ let ids_of_ctxt ctxt = "Termast: arbitrary substitution of references not yet implemented") ctxt) -let ast_of_ident id = nvar (string_of_id id) +let ast_of_ident id = nvar id let ast_of_name = function - | Name id -> nvar (string_of_id id) - | Anonymous -> nvar "_" + | Name id -> nvar id + | Anonymous -> nvar wildcard -let stringopt_of_name = function - | Name id -> Some (string_of_id id) +let idopt_of_name = function + | Name id -> Some id | Anonymous -> None let ast_of_constant_ref sp = @@ -107,19 +107,19 @@ let ast_of_ref = function let ast_of_qualid p = let dir, s = repr_qualid p in - let args = List.map nvar (dir@[string_of_id s]) in + let args = List.map nvar (dir@[s]) in ope ("QUALID", args) (**********************************************************************) (* conversion of patterns *) let rec ast_of_cases_pattern = function (* loc is thrown away for printing *) - | PatVar (loc,Name id) -> nvar (string_of_id id) - | PatVar (loc,Anonymous) -> nvar "_" + | PatVar (loc,Name id) -> nvar id + | PatVar (loc,Anonymous) -> nvar wildcard | PatCstr(loc,(cstrsp,_),args,Name id) -> let args = List.map ast_of_cases_pattern args in ope("PATTAS", - [nvar (string_of_id id); + [nvar id; ope("PATTCONSTRUCT", (ast_of_constructor_ref cstrsp)::args)]) | PatCstr(loc,(cstrsp,_),args,Anonymous) -> ope("PATTCONSTRUCT", @@ -128,7 +128,7 @@ let rec ast_of_cases_pattern = function (* loc is thrown away for printing *) let ast_dependent na aty = match na with - | Name id -> occur_var_ast (string_of_id id) aty + | Name id -> occur_var_ast id aty | Anonymous -> false let decompose_binder = function @@ -196,7 +196,7 @@ let rec ast_of_raw = function ope("PROD",[ast_of_raw t; slam(None,ast_of_raw c)]) | RLetIn (_,na,t,c) -> - ope("LETIN",[ast_of_raw t; slam(stringopt_of_name na,ast_of_raw c)]) + ope("LETIN",[ast_of_raw t; slam(idopt_of_name na,ast_of_raw c)]) | RProd (_,na,t,c) -> let (n,a) = factorize_binder 1 BProd na (ast_of_raw t) c in @@ -287,7 +287,7 @@ and factorize_binder n oper na aty c = -> factorize_binder (n+1) oper na' aty c' | _ -> (n,ast_of_raw c) in - (p,slam(stringopt_of_name na, body)) + (p,slam(idopt_of_name na, body)) let ast_of_rawconstr = ast_of_raw @@ -345,8 +345,7 @@ let rec ast_of_pattern env = function | Anonymous -> anomaly "ast_of_pattern: index to an anonymous variable" with Not_found -> - let s = "[REL "^(string_of_int n)^"]" - in nvar s) + nvar (id_of_string ("[REL "^(string_of_int n)^"]"))) | PApp (f,args) -> let (f,args) = @@ -364,7 +363,7 @@ let rec ast_of_pattern env = function | PLetIn (na,b,c) -> let c' = ast_of_pattern (add_name na env) c in - ope("LETIN",[ast_of_pattern env b;slam(stringopt_of_name na,c')]) + ope("LETIN",[ast_of_pattern env b;slam(idopt_of_name na,c')]) | PProd (Anonymous,t,c) -> ope("PROD",[ast_of_pattern env t; slam(None,ast_of_pattern env c)]) @@ -415,4 +414,4 @@ and factorize_binder_pattern env n oper na aty c = factorize_binder_pattern (add_name na' env) (n+1) oper na' aty c' | _ -> (n,ast_of_pattern env c) in - (p,slam(stringopt_of_name na, body)) + (p,slam(idopt_of_name na, body)) diff --git a/pretyping/classops.ml b/pretyping/classops.ml index 8cbfcc0a5b..556dbd3341 100755 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -14,6 +14,7 @@ open Options open Names open Environ open Libobject +open Library open Declare open Term open Rawterm @@ -30,7 +31,7 @@ let cte_of_constr c = match kind_of_term c with | IsConst (sp,_) -> ConstRef sp | IsMutInd (ind_sp,_) -> IndRef ind_sp | IsMutConstruct (cstr_cp,_) -> ConstructRef cstr_cp - | IsVar id -> VarRef (find_section_variable id) + | IsVar id -> VarRef (Declare.find_section_variable id) | _ -> raise Not_found type cl_typ = diff --git a/pretyping/syntax_def.ml b/pretyping/syntax_def.ml index 6a171d7c46..1b875affa7 100644 --- a/pretyping/syntax_def.ml +++ b/pretyping/syntax_def.ml @@ -8,6 +8,8 @@ (* $Id$ *) +open Util +open Pp open Names open Rawterm open Libobject @@ -27,31 +29,39 @@ let _ = Summary.declare_summary let add_syntax_constant sp c = syntax_table := Spmap.add sp c !syntax_table -(* Impossible de rendre récursive la définition de in_syntax_constant - et cache_syntax_constant, alors on triche ... *) -let cache_syntax_constant = ref (fun c -> failwith "Undefined function") +let cache_syntax_constant (sp,c) = + if Nametab.exists_cci sp then + errorlabstrm "cache_syntax_constant" + [< pr_id (basename sp); 'sTR " already exists" >]; + add_syntax_constant sp c; + Nametab.push_syntactic_definition sp; + Nametab.push_short_name_syntactic_definition sp + +let load_syntax_constant (sp,c) = + if Nametab.exists_cci sp then + errorlabstrm "cache_syntax_constant" + [< pr_id (basename sp); 'sTR " already exists" >]; + add_syntax_constant sp c; + Nametab.push_syntactic_definition sp + +let open_syntax_constant (sp,c) = + Nametab.push_short_name_syntactic_definition sp let (in_syntax_constant, out_syntax_constant) = let od = { - cache_function = (fun c -> !cache_syntax_constant c); - load_function = (fun _ -> ()); - open_function = (fun c -> !cache_syntax_constant c); + cache_function = cache_syntax_constant; + load_function = load_syntax_constant; + open_function = open_syntax_constant; export_function = (fun x -> Some x) } in declare_object ("SYNTAXCONSTANT", od) -let _ = - cache_syntax_constant := fun (sp,c) -> - add_syntax_constant sp c; - Nametab.push_object sp (in_syntax_constant c) - let declare_syntactic_definition id c = let _ = add_leaf id CCI (in_syntax_constant c) in () let search_syntactic_definition sp = Spmap.find sp !syntax_table -let locate_syntactic_definition sp = - let (sp,obj) = Nametab.locate_obj sp in - if object_tag obj = "SYNTAXCONSTANT" then sp else raise Not_found - - +let locate_syntactic_definition qid = + match Nametab.extended_locate qid with + | Nametab.SyntacticDef sp -> sp + | _ -> raise Not_found diff --git a/proofs/proof_trees.ml b/proofs/proof_trees.ml index 8bfa53842c..222b8277a2 100644 --- a/proofs/proof_trees.ml +++ b/proofs/proof_trees.ml @@ -342,13 +342,12 @@ open Termast let ast_of_cvt_bind f = function | (NoDep n,c) -> ope ("BINDING", [(num n); ope ("COMMAND",[(f c)])]) - | (Dep id,c) -> ope ("BINDING", [nvar (string_of_id id); - ope ("COMMAND",[(f c)])]) + | (Dep id,c) -> ope ("BINDING", [nvar id; ope ("COMMAND",[(f c)])]) | (Com,c) -> ope ("BINDING", [ope ("COMMAND",[(f c)])]) let rec ast_of_cvt_intro_pattern = function | WildPat -> ope ("WILDCAR",[]) - | IdPat id -> nvar (string_of_id id) + | 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)) | ListPat l -> ope ("LISTPATTERN", (List.map ast_of_cvt_intro_pattern l)) @@ -363,7 +362,7 @@ let last_of_cvt_flags (_,red) = let lqid = List.map (function - | EvalVarRef id -> nvar (string_of_id id) + | EvalVarRef id -> nvar id | EvalConstRef sp -> ast_of_qualid (Global.qualid_of_global (ConstRef sp))) lconst in @@ -383,7 +382,7 @@ let ast_of_cvt_redexp = function | Unfold l -> ope("Unfold",List.map (fun (locc,sp) -> ope("UNFOLD", [match sp with - | EvalVarRef id -> nvar (string_of_id id) + | EvalVarRef id -> nvar id | EvalConstRef sp -> ast_of_qualid (Global.qualid_of_global (ConstRef sp))] @(List.map num locc))) l) @@ -397,8 +396,8 @@ let ast_of_cvt_redexp = function (* Gives the ast corresponding to a tactic argument *) let ast_of_cvt_arg = function - | Identifier id -> nvar (string_of_id id) - | Qualid qid -> nvar (Nametab.string_of_qualid qid) + | Identifier id -> nvar id + | Qualid qid -> ast_of_qualid qid | Quoted_string s -> str s | Integer n -> num n | Command c -> ope ("COMMAND",[c]) @@ -411,8 +410,8 @@ let ast_of_cvt_arg = function "Constr_context argument could not be used">] | Clause idl -> let transl = function - | InHyp id -> ope ("INHYP", [nvar (string_of_id id)]) - | InHypType id -> ope ("INHYPTYPE", [nvar (string_of_id id)]) in + | 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) @@ -424,17 +423,14 @@ let ast_of_cvt_arg = function | 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 (string_of_id id)); - (num n); - ope ("COMMAND",[c])]) - | Cofixexp (id,c) -> ope ("COFIXEXP",[(nvar (string_of_id id)); - (ope ("COMMAND",[c]))]) + | Fixexp (id,n,c) -> ope ("FIXEXP",[nvar id; num n; ope ("COMMAND",[c])]) + | Cofixexp (id,c) -> ope ("COFIXEXP",[nvar id; ope ("COMMAND",[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 (string_of_id id) :: (List.map num l))) + ope ("HYPPATTERN", nvar id :: (List.map num l))) hyp_occ_list in let all_pats = match gl_occ_opt with diff --git a/proofs/tacinterp.ml b/proofs/tacinterp.ml index ede93699af..846344210c 100644 --- a/proofs/tacinterp.ml +++ b/proofs/tacinterp.ml @@ -29,6 +29,7 @@ open Tactic_debug open Coqast open Ast open Term +open Declare let err_msg_tactic_not_found macro_loc macro = user_err_loc @@ -42,13 +43,13 @@ type value = | VRTactic of (goal list sigma * validation) | VContext of (goal sigma -> value) | VArg of tactic_arg - | VFun of (string * value) list * string option list * Coqast.t + | VFun of (identifier * value) list * identifier option list * Coqast.t | VVoid | VRec of value ref (* Signature for interpretation: val_interp and interpretation functions *) and interp_sign = - enamed_declarations * Environ.env * (string * value) list * + enamed_declarations * Environ.env * (identifier * value) list * (int * constr) list * goal sigma option * debug_info (* For tactic_of_value *) @@ -124,9 +125,9 @@ let constr_of_id id = function (* Extracted the constr list from lfun *) let rec constr_list goalopt = function - | (str,VArg(Constr c))::tl -> (id_of_string str,c)::(constr_list goalopt tl) - | (str,VArg(Identifier id))::tl -> - (try (id_of_string str,(constr_of_id id goalopt))::(constr_list goalopt tl) + | (id,VArg(Constr c))::tl -> (id,c)::(constr_list goalopt tl) + | (id0,VArg(Identifier id))::tl -> + (try (id0,(constr_of_id id goalopt))::(constr_list goalopt tl) with | Not_found -> (constr_list goalopt tl)) | _::tl -> constr_list goalopt tl | [] -> [] @@ -278,12 +279,12 @@ let head_with_value (lvar,lval) = (* Type of patterns *) type match_pattern = | Term of constr_pattern - | Subterm of string option * constr_pattern + | Subterm of identifier option * constr_pattern (* Type of hypotheses for a Match Context rule *) type match_context_hyps = | NoHypId of match_pattern - | Hyp of string * match_pattern + | Hyp of identifier * match_pattern (* Type of a Match rule for Match Context and Match *) type match_rule= @@ -503,7 +504,7 @@ let rec val_interp (evc,env,lfun,lmatch,goalopt,debug) ast = (try (unrec (List.assoc s lfun)) with | Not_found -> (try (vcontext_interp goalopt (lookup s)) - with | Not_found -> VArg (Identifier (id_of_string s)))) + with | Not_found -> VArg (Identifier s))) | Node(_,"QUALIDARG",[Nvar(_,s)]) -> (try (make_qid (unrec (List.assoc s lfun))) with | Not_found -> @@ -531,9 +532,9 @@ let rec val_interp (evc,env,lfun,lmatch,goalopt,debug) ast = VArg (Tac ((tac_interp lfun lmatch debug ast),ast)) (*Remains to treat*) | Node(_,"FIXEXP", [Nvar(_,s); Num(_,n);Node(_,"COMMAND",[c])]) -> - VArg ((Fixexp (id_of_string s,n,c))) + VArg ((Fixexp (s,n,c))) | Node(_,"COFIXEXP", [Nvar(_,s); Node(_,"COMMAND",[c])]) -> - VArg ((Cofixexp (id_of_string s,c))) + VArg ((Cofixexp (s,c))) (*End of Remains to treat*) | Node(_,"INTROPATTERN", [ast]) -> VArg ((Intropattern (cvt_intro_pattern @@ -621,19 +622,18 @@ and letin_interp (evc,env,lfun,lmatch,goalopt,debug) ast = function | Node(_,"LETCLAUSE",[Nvar(_,id);t])::tl -> (id,val_interp (evc,env,lfun,lmatch,goalopt,debug) t):: (letin_interp (evc,env,lfun,lmatch,goalopt,debug) ast tl) - | Node(_,"LETCUTCLAUSE",[Nvar(_,s);com;tce])::tl -> - let id = id_of_string s - and typ = + | Node(_,"LETCUTCLAUSE",[Nvar(_,id);com;tce])::tl -> + let typ = constr_of_Constr (unvarg (val_interp (evc,env,lfun,lmatch,goalopt,debug) com)) and tac = val_interp (evc,env,lfun,lmatch,goalopt,debug) tce in (match tac with | VArg (Constr csr) -> - (s,VArg (Constr (mkCast (csr,typ)))):: + (id,VArg (Constr (mkCast (csr,typ)))):: (letin_interp (evc,env,lfun,lmatch,goalopt,debug) ast tl) | VArg (Identifier id) -> (try - (s,VArg (Constr (mkCast (constr_of_id id goalopt,typ)))):: + (id,VArg (Constr (mkCast (constr_of_id id goalopt,typ)))):: (letin_interp (evc,env,lfun,lmatch,goalopt,debug) ast tl) with | Not_found -> errorlabstrm "Tacinterp.letin_interp" @@ -645,12 +645,12 @@ and letin_interp (evc,env,lfun,lmatch,goalopt,debug) ast = function (match goalopt with | None -> Global.named_context () | Some g -> pf_hyps g) in - start_proof id Declare.NeverDischarge ndc typ; + start_proof id NeverDischarge ndc typ; by t; let (_,({const_entry_body = pft; const_entry_type = _},_)) = cook_proof () in delete_proof id; - (s,VArg (Constr (mkCast (pft,typ)))):: + (id,VArg (Constr (mkCast (pft,typ)))):: (letin_interp (evc,env,lfun,lmatch,goalopt,debug) ast tl) with | NotTactic -> delete_proof id; @@ -663,9 +663,8 @@ and letin_interp (evc,env,lfun,lmatch,goalopt,debug) ast = function (* Interprets the clauses of a LetCut *) and letcut_interp (evc,env,lfun,lmatch,goalopt,debug) ast = function | [] -> tclIDTAC - | Node(_,"LETCUTCLAUSE",[Nvar(_,s);com;tce])::tl -> - let id = id_of_string s - and typ = + | Node(_,"LETCUTCLAUSE",[Nvar(_,id);com;tce])::tl -> + let typ = constr_of_Constr (unvarg (val_interp (evc,env,lfun,lmatch,goalopt,debug) com)) and tac = val_interp (evc,env,lfun,lmatch,goalopt,debug) tce @@ -699,7 +698,7 @@ and letcut_interp (evc,env,lfun,lmatch,goalopt,debug) ast = function | _ -> (try let t = tactic_of_value tac in - start_proof id Declare.NeverDischarge ndc typ; + start_proof id NeverDischarge ndc typ; by t; let (_,({const_entry_body = pft; const_entry_type = _},_)) = cook_proof () in @@ -1216,7 +1215,7 @@ let add_tacdef na vbody = errorlabstrm "Tacinterp.add_tacdef" [< 'sTR "There is already a Meta Definition or a Tactic Definition named "; - 'sTR na>]; - let _ = Lib.add_leaf (id_of_string na) OBJ (inMD (na,vbody)) in - Options.if_verbose mSGNL [< 'sTR (na ^ " is defined") >] + pr_id na>]; + let _ = Lib.add_leaf na OBJ (inMD (na,vbody)) in + Options.if_verbose mSGNL [< pr_id na; 'sTR " is defined" >] end diff --git a/proofs/tacinterp.mli b/proofs/tacinterp.mli index 971cb88df8..f6be508697 100644 --- a/proofs/tacinterp.mli +++ b/proofs/tacinterp.mli @@ -25,13 +25,13 @@ type value = | VRTactic of (goal list sigma * validation) | VContext of (goal sigma -> value) | VArg of tactic_arg - | VFun of (string * value) list * string option list * Coqast.t + | VFun of (identifier * value) list * identifier option list * Coqast.t | VVoid | VRec of value ref (* Signature for interpretation: val\_interp and interpretation functions *) and interp_sign = - enamed_declarations * Environ.env * (string * value) list * + enamed_declarations * Environ.env * (identifier * value) list * (int * constr) list * goal sigma option * debug_info (* Gives the constr corresponding to a CONSTR [tactic_arg] *) @@ -45,7 +45,7 @@ val tacticIn : (unit -> Coqast.t) -> Coqast.t initialized with dummy values *) val r_evc : enamed_declarations ref val r_env : Environ.env ref -val r_lfun : (string * value) list ref +val r_lfun : (identifier * value) list ref val r_lmatch : (int * constr) list ref val r_goalopt : goal sigma option ref val r_debug : debug_info ref @@ -57,7 +57,7 @@ val set_debug : debug_info -> unit val get_debug : unit -> debug_info (* Adds a definition for tactics in the table *) -val add_tacdef : string -> Coqast.t -> unit +val add_tacdef : identifier -> Coqast.t -> unit (* Interprets any expression *) val val_interp : interp_sign -> Coqast.t -> value @@ -66,8 +66,8 @@ val val_interp : interp_sign -> Coqast.t -> value val interp_tacarg : interp_sign -> Coqast.t -> tactic_arg (* Interprets tactic expressions *) -val tac_interp : (string * value) list -> (int * constr) list -> debug_info -> - Coqast.t -> tactic +val tac_interp : (identifier * value) list -> (int * constr) list -> + debug_info -> Coqast.t -> tactic (* Initial call for interpretation *) val interp : Coqast.t -> tactic diff --git a/tactics/Inv.v b/tactics/Inv.v index 39a434b010..2b9271aca5 100644 --- a/tactics/Inv.v +++ b/tactics/Inv.v @@ -49,7 +49,7 @@ Grammar tactic simple_tactic: ast := | inv_using [ inversion_com($ic) identarg($id) "using" constrarg($c) ] -> case [$ic] of - Inversion -> [(UseInversionLemma $id $c)] + "Inversion" -> [(UseInversionLemma $id $c)] esac | inv_num_using [ inversion_com($ic) pure_numarg($n) "using" constrarg($c) ] @@ -61,13 +61,13 @@ Grammar tactic simple_tactic: ast := [ inversion_com($ic) identarg($id) "using" constrarg($c) "in" ne_identarg_list($l) ] -> case [$ic] of - Inversion -> [(UseInversionLemmaIn $id $c ($LIST $l))] + "Inversion" -> [(UseInversionLemmaIn $id $c ($LIST $l))] esac with inversion_com: ast := - simple_inv [ "Simple" "Inversion" ] -> [ HalfInversion ] -| inversion_com [ "Inversion" ] -> [ Inversion ] -| inv_clear [ "Inversion_clear" ] -> [ InversionClear ]. + simple_inv [ "Simple" "Inversion" ] -> [ "HalfInversion" ] +| inversion_com [ "Inversion" ] -> [ "Inversion" ] +| inv_clear [ "Inversion_clear" ] -> [ "InversionClear" ]. Grammar vernac vernac: ast := diff --git a/tactics/dhyp.ml b/tactics/dhyp.ml index 211ecbf6dd..839c639789 100644 --- a/tactics/dhyp.ml +++ b/tactics/dhyp.ml @@ -253,8 +253,8 @@ let match_dpat dp cls gls = let applyDestructor cls discard dd gls = let mvb = match_dpat dd.d_pat cls gls in let astb = match cls with - | Some id -> ["$0", Vast (nvar (string_of_id id))] - | None -> ["$0", Vast (nvar "$0")] in + | Some id -> ["$0", Vast (nvar id)] + | None -> ["$0", Vast (nvar (id_of_string "$0"))] in (* TODO: find the real location *) let tcom = match Ast.eval_act dummy_loc astb dd.d_code with | Vast tcom -> tcom diff --git a/tactics/inv.ml b/tactics/inv.ml index 4e0c39ab26..3fbe8e8eef 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -413,9 +413,9 @@ let inv gene com status id = in fun gls -> try tac gls with e -> wrap_inv_error id e -let hinv_kind = Identifier (id_of_string "HalfInversion") -let inv_kind = Identifier (id_of_string "Inversion") -let invclr_kind = Identifier (id_of_string "InversionClear") +let hinv_kind = Quoted_string "HalfInversion" +let inv_kind = Quoted_string "Inversion" +let invclr_kind = Quoted_string "InversionClear" let com_of_id id = if id = hinv_kind then None @@ -519,6 +519,6 @@ let invIn_tac = in fun com id hl -> gentac - ((Identifier (id_of_string com)) + ((Identifier com) ::(Identifier id) ::(List.map (fun id -> (Identifier id)) hl)) diff --git a/tactics/inv.mli b/tactics/inv.mli index ed0dc1de0c..792f132613 100644 --- a/tactics/inv.mli +++ b/tactics/inv.mli @@ -24,4 +24,4 @@ val half_dinv_with : identifier -> constr -> tactic val dinv_with : identifier -> constr -> tactic val dinv_clear_with : identifier -> constr -> tactic -val invIn_tac : string -> identifier -> identifier list -> tactic +val invIn_tac : identifier -> identifier -> identifier list -> tactic diff --git a/tactics/setoid_replace.ml b/tactics/setoid_replace.ml index dd35bc58f4..613c0a475c 100644 --- a/tactics/setoid_replace.ml +++ b/tactics/setoid_replace.ml @@ -39,7 +39,7 @@ type morphism = let constr_of c = Astterm.interp_constr Evd.empty (Global.env()) c let constant dir s = - let dir = "Coq"::"Setoid"::dir in + let dir = make_dirpath (List.map id_of_string ("Coq"::"Setoid"::dir)) in let id = id_of_string s in try Declare.global_reference_in_absolute_module dir id @@ -47,7 +47,7 @@ let constant dir s = anomaly ("Setoid: cannot find "^(Nametab.string_of_qualid (Nametab.make_qualid dir id))) let global_constant dir s = - let dir = "Coq"::"Init"::dir in + let dir = make_dirpath (List.map id_of_string ("Coq"::"Init"::dir)) in let id = id_of_string s in try Declare.global_reference_in_absolute_module dir id @@ -206,7 +206,7 @@ let gen_eq_lem_name = let i = ref 0 in function () -> incr i; - id_of_string ("setoid_eq_ext"^(string_of_int !i)) + make_ident "setoid_eq_ext" (Some !i) let add_setoid a aeq th = if setoid_table_mem a @@ -289,11 +289,11 @@ let check_is_dependent t n = in aux t 0 n let gen_lem_name m = match kind_of_term m with - | IsVar id -> id_of_string ((string_of_id id)^"_ext") - | IsConst (sp, _) -> id_of_string ((string_of_id(basename sp))^"_ext") - | IsMutInd ((sp, i), _) -> id_of_string ((string_of_id(basename sp))^(string_of_int i)^"_ext") - | IsMutConstruct (((sp,i),j), _) -> id_of_string - ((string_of_id(basename sp))^(string_of_int i)^(string_of_int i)^"_ext") + | IsVar id -> add_suffix id "_ext" + | IsConst (sp, _) -> add_suffix (basename sp) "_ext" + | IsMutInd ((sp, i), _) -> add_suffix (basename sp) ((string_of_int i)^"_ext") + | IsMutConstruct (((sp,i),j), _) -> add_suffix + (basename sp) ((string_of_int i)^(string_of_int i)^"_ext") | _ -> errorlabstrm "New Morphism" [< 'sTR "The term "; prterm m; 'sTR "is not a known name">] let gen_lemma_tail m lisset body n = @@ -449,7 +449,7 @@ let add_morphism lem_name (m,profil) = (if (eq_constr body mkProp) then (let lem_2 = gen_lem_iff env m mext args_t poss in - let lem2_name = (id_of_string ((string_of_id lem_name)^"2")) in + let lem2_name = add_suffix lem_name "2" in let _ = Declare.declare_constant lem2_name ((Declare.ConstantEntry {Declarations.const_entry_body = lem_2; Declarations.const_entry_type = None}), diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index cb86443838..9d8f07d78f 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -312,12 +312,6 @@ let last_arg c = match kind_of_term c with let general_elim_then_using elim elim_sign_fun tac predicate (indbindings,elimbindings) c gl = let ((ity,_,_),t) = reduce_to_ind_goal gl (pf_type_of gl c) in - let name_elim = - (match kind_of_term elim with - | IsConst (sp,_) -> id_of_string (string_of_path sp) - | IsVar id -> id - | _ -> id_of_string " ") - in (* applying elimination_scheme just a little modified *) let (wc,kONT) = startWalk gl in let indclause = mk_clenv_from wc (c,t) in @@ -332,8 +326,14 @@ let general_elim_then_using let p, _ = decomp_app (clenv_template_type elimclause).rebus in match kind_of_term p with | IsMeta p -> p - | _ -> error ("The elimination combinator " ^ - (string_of_id name_elim) ^ " is not known") + | _ -> + let name_elim = + match kind_of_term elim with + | IsConst (sp,_) -> string_of_path sp + | IsVar id -> string_of_id id + | _ -> "\b" + in + error ("The elimination combinator " ^ name_elim ^ " is not known") in let elimclause' = clenv_fchain indmv elimclause indclause' in let elimclause' = clenv_constrain_with_bindings elimbindings elimclause' in diff --git a/tactics/tactics.ml b/tactics/tactics.ml index bffbfea4ce..12b41b6027 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1823,7 +1823,7 @@ let abstract_subproof name tac gls = in if occur_existential concl then error "Abstract cannot handle existentials"; let lemme = - start_proof na Declare.NeverDischarge current_sign concl; + start_proof na NeverDischarge current_sign concl; let _,(const,strength) = try by (tclCOMPLETE (tclTHEN (tclDO (List.length sign) intro) tac)); diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4 index 7edf1610e5..5996449275 100644 --- a/tactics/tauto.ml4 +++ b/tactics/tauto.ml4 @@ -115,7 +115,7 @@ let rec intuition_main () = let unfold_not_iff = function | None -> interp <:tactic<Unfold not iff>> | Some id -> - let ast_id = nvar (string_of_id id) in + let ast_id = nvar id in interp <:tactic<Unfold not iff in $ast_id>> let reduction_not_iff = Tacticals.onAllClauses (fun ido -> unfold_not_iff ido) @@ -123,7 +123,7 @@ let reduction_not_iff = Tacticals.onAllClauses (fun ido -> unfold_not_iff ido) let compute = function | None -> interp <:tactic<Compute>> | Some id -> - let ast_id = nvar (string_of_id id) in + let ast_id = nvar id in interp <:tactic<Compute in $ast_id>> let reduction = Tacticals.onAllClauses (fun ido -> compute ido) diff --git a/toplevel/class.ml b/toplevel/class.ml index 1a3cc28008..6b0ed89ab4 100644 --- a/toplevel/class.ml +++ b/toplevel/class.ml @@ -37,7 +37,8 @@ let stre_gt = function | (_,NeverDischarge) -> true | (_,NotDeclare) -> true | (DischargeAt sp1,DischargeAt sp2) -> - dirpath_prefix_of sp1 sp2 (* was sp_gt but don't understand why - HH *) + is_dirpath_prefix_of sp1 sp2 + (* was sp_gt but don't understand why - HH *) let stre_max (stre1,stre2) = if stre_gt (stre1,stre2) then stre1 else stre2 diff --git a/toplevel/command.ml b/toplevel/command.ml index 0384ca8048..b3a34e2ce6 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -28,9 +28,9 @@ open Proof_type open Tacmach let mkCastC(c,t) = ope("CAST",[c;t]) -let mkLambdaC(x,a,b) = ope("LAMBDA",[a;slam(Some (string_of_id x),b)]) +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 (string_of_id x),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)) (* Commands of the interface *) @@ -102,13 +102,13 @@ let syntax_definition ident com = let parameter_def_var ident c = let c = interp_type Evd.empty (Global.env()) c in - let sp = declare_parameter (id_of_string ident) c in - if_verbose message (ident ^ " is assumed"); + let sp = declare_parameter ident c in + if_verbose message ((string_of_id ident) ^ " is assumed"); sp let declare_global_assumption ident c = let sp = parameter_def_var ident c in - wARNING [< 'sTR ident; 'sTR" is declared as a parameter"; + wARNING [< pr_id ident; 'sTR" is declared as a parameter"; 'sTR" because it is at a global level" >]; ConstRef sp @@ -118,11 +118,10 @@ let hypothesis_def_var is_refining ident n c = | DischargeAt disch_sp -> if Lib.is_section_p disch_sp then begin let t = interp_type Evd.empty (Global.env()) c in - let sp = declare_variable (id_of_string ident) - (SectionLocalAssum t,n,false) in - if_verbose message (ident ^ " is assumed"); + let sp = declare_variable ident (SectionLocalAssum t,n,false) in + if_verbose message ((string_of_id ident) ^ " is assumed"); if is_refining then - mSGERRNL [< 'sTR"Warning: Variable "; 'sTR ident; + mSGERRNL [< 'sTR"Warning: Variable "; pr_id ident; 'sTR" is not visible from current goals" >]; VarRef sp end @@ -437,7 +436,7 @@ let apply_tac_not_declare id pft = function let save opacity id ({const_entry_body = pft; const_entry_type = tpo} as const) strength = begin match strength with - | DischargeAt disch_sp when Lib.is_section_p disch_sp -> + | DischargeAt disch_sp when Lib.is_section_p disch_sp (*&& not opacity*) -> let c = constr_of_constr_entry const in let _ = declare_variable id (SectionLocalDef c,strength,opacity) in () | NeverDischarge | DischargeAt _ -> @@ -464,12 +463,12 @@ let check_anonymity id save_ident = let save_anonymous opacity save_ident = let id,(const,strength) = Pfedit.cook_proof () in check_anonymity id save_ident; - save opacity (id_of_string save_ident) const strength + save opacity save_ident const strength let save_anonymous_with_strength strength opacity save_ident = let id,(const,_) = Pfedit.cook_proof () in check_anonymity id save_ident; - save opacity (id_of_string save_ident) const strength + save opacity save_ident const strength let get_current_context () = try Pfedit.get_current_goal_context () diff --git a/toplevel/command.mli b/toplevel/command.mli index b7b9d0f130..3c1d52b6a3 100644 --- a/toplevel/command.mli +++ b/toplevel/command.mli @@ -12,6 +12,7 @@ open Names open Term open Declare +open Library (*i*) (*s Declaration functions. The following functions take ASTs, @@ -31,10 +32,10 @@ val syntax_definition : identifier -> Coqast.t -> unit val abstraction_definition : identifier -> int array -> Coqast.t -> unit i*) -val hypothesis_def_var : bool -> string -> strength -> Coqast.t +val hypothesis_def_var : bool -> identifier -> strength -> Coqast.t -> global_reference -val parameter_def_var : string -> Coqast.t -> constant_path +val parameter_def_var : identifier -> Coqast.t -> constant_path val build_mutual : (identifier * Coqast.t) list -> @@ -61,13 +62,13 @@ val save_named : bool -> unit (* [save_anonymous b name] behaves as [save_named] but declares the theorem under the name [name] and respects the strength of the declaration *) -val save_anonymous : bool -> string -> unit +val save_anonymous : bool -> identifier -> unit (* [save_anonymous_with_strength s b name] behaves as [save_anonymous] but declares the theorem under the name [name] and gives it the strength [strength] *) -val save_anonymous_with_strength : strength -> bool -> string -> unit +val save_anonymous_with_strength : strength -> bool -> identifier -> unit (* [get_current_context ()] returns the evar context and env of the current open proof if any, otherwise returns the empty evar context diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml index 80c81d243b..e7f56ef87a 100644 --- a/toplevel/coqinit.ml +++ b/toplevel/coqinit.ml @@ -80,16 +80,19 @@ let init_load_path () = List.iter (fun s -> coq_add_rec_path (Filename.concat coqlib s)) dirs; let camlp4 = getenv_else "CAMLP4LIB" Coq_config.camlp4lib in add_ml_include camlp4; - Mltop.add_path "." [Nametab.default_root]; + Mltop.add_path "." Nametab.default_root_prefix; (* additional loadpath, given with -I -include -R options *) List.iter (fun (s,alias,reci) -> if reci then Mltop.add_rec_path s alias else Mltop.add_path s alias) (List.rev !includes) +(* Must be done after restoring initial state! *) let init_library_roots () = List.iter - (fun (_,alias,_) -> Nametab.push_library_root (List.hd alias)) !includes; + (fun (_,alias,_) -> + if alias <> [] then Nametab.push_library_root (List.hd alias)) + !includes; includes := [] (* Initialises the Ocaml toplevel before launching it, so that it can diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index a88223925f..7d293aed9a 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -12,6 +12,7 @@ open Pp open Util open System open Options +open Names open States open Toplevel open Coqinit @@ -44,10 +45,10 @@ let outputstate = ref "" let set_outputstate s = outputstate:=s let outputstate () = if !outputstate <> "" then extern_state !outputstate -let set_include d p = push_include (d,Names.dirpath_of_string p) -let set_rec_include d p = push_rec_include (d,Names.dirpath_of_string p) -let set_default_include d = set_include d Nametab.default_root -let set_default_rec_include d = set_rec_include d Nametab.default_root +let set_include d p = push_include (d,p) +let set_rec_include d p = push_rec_include (d,p) +let set_default_include d = set_include d Nametab.default_root_prefix +let set_default_rec_include d = set_rec_include d Nametab.default_root_prefix let load_vernacular_list = ref ([] : string list) let add_load_vernacular s = @@ -60,15 +61,15 @@ let load_vernacular () = let load_vernacular_obj = ref ([] : string list) let add_vernac_obj s = load_vernacular_obj := s :: !load_vernacular_obj let load_vernac_obj () = - List.iter - (fun s -> Library.load_module (Filename.basename s) (Some s)) - (List.rev !load_vernacular_obj) + List.iter Library.read_module_from_file (List.rev !load_vernacular_obj) let require_list = ref ([] : string list) let add_require s = require_list := s :: !require_list let require () = List.iter - (fun s -> Library.require_module None (Filename.basename s) (Some s) false) + (fun s -> + let qid = Nametab.make_qualid [] (id_of_string (Filename.basename s)) in + Library.require_module None qid (Some s) false) (List.rev !require_list) (* Re-exec Coq in bytecode or native code if necessary. [s] is either @@ -110,7 +111,7 @@ let parse_args () = | ("-I"|"-include") :: d :: rem -> set_default_include d; parse rem | ("-I"|"-include") :: [] -> usage () - | "-R" :: d :: p :: rem -> set_rec_include d p; parse rem + | "-R" :: d :: p :: rem ->set_rec_include d (dirpath_of_string p);parse rem | "-R" :: ([] | [_]) -> usage () | "-q" :: rem -> no_load_rc (); parse rem diff --git a/toplevel/discharge.ml b/toplevel/discharge.ml index 2b3fd2c5d2..c8e031bb86 100644 --- a/toplevel/discharge.ml +++ b/toplevel/discharge.ml @@ -26,6 +26,7 @@ open Impargs open Classops open Class open Recordops +open Library let recalc_sp dir sp = let (_,spid,k) = repr_path sp in Names.make_path dir spid k @@ -169,6 +170,7 @@ type discharge_operation = | Struc of inductive_path * (unit -> struc_typ) | Objdef of constant_path | Coercion of coercion_entry + | Require of module_reference (* Main function to traverse the library segment and compute the various discharge operations. *) @@ -179,8 +181,13 @@ let process_object oldenv dir sec_sp match tag with | "VARIABLE" -> let ((id,c,t),stre,sticky) = get_variable sp in - if stre = (DischargeAt sec_sp) or ids_to_discard <> [] then + (* VARIABLE means local (entry Variable/Hypothesis/Local and are *) + (* always discharged *) +(* + if stre = (DischargeAt sec_sp) or ids_to_discard <> [] then +*) (ops,id::ids_to_discard,work_alist) +(* else let imp = is_implicit_var sp in let newdecl = @@ -194,13 +201,19 @@ let process_object oldenv dir sec_sp in (Variable (id,newdecl,stre,sticky,imp) :: ops, ids_to_discard,work_alist) +*) | "CONSTANT" | "PARAMETER" -> - let stre = constant_or_parameter_strength sp in + (* CONSTANT/PARAMETER means never discharge (though visibility *) + (* may vary) *) + let stre = constant_or_parameter_strength sp in +(* if stre = (DischargeAt sec_sp) then - let constl = (sp, DO_REPLACE)::constl in + let cb = Environ.lookup_constant sp oldenv in + let constl = (sp, DO_REPLACE cb)::constl in (ops, ids_to_discard, (constl,indl,cstrl)) else +*) let cb = Environ.lookup_constant sp oldenv in let spid = basename sp in let imp = is_implicit_constant sp in @@ -209,7 +222,7 @@ let process_object oldenv dir sec_sp let modl = build_abstract_list cb.const_hyps ids_to_discard in [ (sp, DO_ABSTRACT(newsp,modl)) ] in - let r = { d_from = sp; + let r = { d_from = cb; d_modlist = work_alist; d_abstract = ids_to_discard } in let op = Constant (spid,r,stre,cb.const_opaque,imp) in @@ -255,6 +268,10 @@ let process_object oldenv dir sec_sp let new_sp = recalc_sp dir sp in ((Objdef new_sp)::ops, ids_to_discard, work_alist) + | "REQUIRE" -> + let c = out_require lobj in + ((Require c)::ops, ids_to_discard, work_alist) + | _ -> (ops,ids_to_discard,work_alist) let process_item oldenv dir sec_sp acc = function @@ -284,79 +301,18 @@ let process_operation = function | Objdef newsp -> begin try Recordobj.objdef_declare (ConstRef newsp) with _ -> () end | Coercion y -> add_new_coercion y + | Require y -> reload_module y -let push_inductive_names ccitab sp mie = - let _,ccitab = - List.fold_left - (fun (n,ccitab) ind -> - let id = ind.mind_entry_typename in - let indsp = (sp,n) in - let _,ccitab = - List.fold_left - (fun (p,ccitab) x -> - (p+1, Idmap.add x (ConstructRef (indsp,p)) ccitab)) - (1,Idmap.add id (IndRef indsp) ccitab) - ind.mind_entry_consnames in - (n+1,ccitab)) - (0,ccitab) - mie.mind_entry_inds - in ccitab - -(*s Operations performed at section closing. *) - -let cache_end_section (_,(sp,mc)) = - Nametab.push_section sp mc; - Nametab.open_section_contents (Nametab.qualid_of_sp sp) - -let load_end_section (_,(sp,mc)) = - Nametab.push_module sp mc - -let open_end_section (_,(sp,_)) = - Nametab.rec_open_module_contents (Nametab.qualid_of_sp sp) - -let (in_end_section, out_end_section) = - declare_object - ("END-SECTION", - { cache_function = cache_end_section; - load_function = load_end_section; - open_function = open_end_section; - export_function = (fun x -> Some x) }) - -let rec process_object (ccitab, objtab, modtab as tabs) = function - | sp,Leaf obj -> - begin match object_tag obj with - | "CONSTANT" | "PARAMETER" -> - (Idmap.add (basename sp) (ConstRef sp) ccitab,objtab,modtab) - | "INDUCTIVE" -> - let mie = out_inductive obj in - (push_inductive_names ccitab sp mie, objtab, modtab) - (* Variables are never visible *) - | "VARIABLE" -> tabs - | "END-SECTION" -> - let (sp,mc) = out_end_section obj in - let id = string_of_id (basename sp) in - (ccitab, objtab, Stringmap.add id (sp,mc) modtab) - (* All the rest is visible only at toplevel ??? *) - (* Actually it is unsafe, it should be visible only in empty context *) - (* ou quelque chose comme cela *) - | "CLASS" | "COERCION" | "STRUCTURE" | "OBJDEF1" | "SYNTAXCONSTANT" - | _ -> - (ccitab, Idmap.add (basename sp) (sp,obj) objtab, modtab) - end - | _,(ClosedSection _ | OpenedSection _ | FrozenState _ | Module _) -> tabs - -and segment_contents seg = - let ccitab, objtab, modtab = - List.fold_left process_object - (Idmap.empty, Idmap.empty, Stringmap.empty) - seg - in - Nametab.Closed (ccitab, objtab, modtab) +let catch_not_found f x = + try f x + with Not_found -> + error ("Something is missing; perhaps a reference to a"^ + " module required inside the section") let close_section _ s = let oldenv = Global.env() in let sec_sp,decls,fs = close_section false s in - let newdir = dirpath (* Trick for HELM *) sec_sp in + let newdir = dirpath sec_sp in let olddir = wd_of_sp sec_sp in let (ops,ids,_) = if Options.immediate_discharge then ([],[],([],[],[])) @@ -367,14 +323,8 @@ let close_section _ s = let ids = last_section_hyps olddir in Global.pop_named_decls ids; Summary.unfreeze_lost_summaries fs; - let mc = segment_contents decls in - add_anonymous_leaf (in_end_section (sec_sp,mc)); add_frozen_state (); if Options.immediate_discharge then () else - List.iter process_operation (List.rev ops) - -let save_module_to s f = - Library.save_module_to segment_contents s f - - + catch_not_found (List.iter process_operation) (List.rev ops); + Nametab.push_section olddir diff --git a/toplevel/discharge.mli b/toplevel/discharge.mli index 2f7b247ac3..42ac9d790e 100644 --- a/toplevel/discharge.mli +++ b/toplevel/discharge.mli @@ -8,11 +8,11 @@ (*i $Id$ i*) +open Names + (* This module implements the discharge mechanism. It provides a function to close the last opened section. That function calls [Lib.close_section] and then re-introduce all the discharged versions of the objects that were defined in the section. *) -val close_section : bool -> string -> unit - -val save_module_to : string -> string -> unit +val close_section : bool -> identifier -> unit diff --git a/toplevel/mltop.ml4 b/toplevel/mltop.ml4 index 0499eff838..51271b510d 100644 --- a/toplevel/mltop.ml4 +++ b/toplevel/mltop.ml4 @@ -35,7 +35,7 @@ open Vernacinterp Finally, we can create an object which is an ML module, and require that the "caching" of the ML module cause the loading of the associated ML file, if that file has not been yet loaded. Of - course, the problem is how to record dependences between ML + course, the problem is how to record dependencies between ML modules. (I do not know of a solution to this problem, other than to put all the needed names into the ML Module object.) *) @@ -44,8 +44,7 @@ open Vernacinterp let coq_mlpath_copy = ref [] let keep_copy_mlpath s = let dir = glob s in - let lpe = { directory = dir; coq_dirpath = [] } in - coq_mlpath_copy := lpe :: !coq_mlpath_copy + coq_mlpath_copy := dir :: !coq_mlpath_copy (* If there is a toplevel under Coq *) type toplevel = { @@ -144,33 +143,33 @@ let add_ml_dir s = (* For Rec Add ML Path *) let add_rec_ml_dir dir = - List.iter (fun lpe -> add_ml_dir lpe.directory) (all_subdirs dir None) + List.iter (fun (lp,_) -> add_ml_dir lp) (all_subdirs dir) (* Adding files to Coq and ML loadpath *) let add_path dir coq_dirpath = - if coq_dirpath = [] then anomaly "add_path: empty path in library"; if exists_dir dir then begin add_ml_dir dir; - Library.add_load_path_entry - { directory = dir; coq_dirpath = coq_dirpath }; - Nametab.push_library_root (List.hd coq_dirpath) + Library.add_load_path_entry (dir,coq_dirpath); + if coq_dirpath <> [] then Nametab.push_library_root (List.hd coq_dirpath) end else wARNING [< 'sTR ("Cannot open " ^ dir) >] let add_rec_path dir coq_dirpath = - if coq_dirpath = [] then anomaly "add_path: empty path in library"; - let dirs = all_subdirs dir (Some coq_dirpath) in + let dirs = all_subdirs dir in if dirs <> [] then + let convert = List.map Names.id_of_string in + let dirs = List.map (fun (lp,cp) -> (lp,coq_dirpath@(convert cp))) dirs in begin - List.iter (fun lpe -> add_ml_dir lpe.directory) dirs; + List.iter (fun lpe -> add_ml_dir (fst lpe)) dirs; List.iter Library.add_load_path_entry dirs; - Nametab.push_library_root (List.hd coq_dirpath) + if coq_dirpath <> [] then Nametab.push_library_root (List.hd coq_dirpath) + else List.iter (fun (_, cp) -> Nametab.push_library_root (List.hd cp)) dirs end - else - wARNING [< 'sTR ("Cannot open " ^ dir) >] + else + wARNING [< 'sTR ("Cannot open " ^ dir) >] (* convertit un nom quelconque en nom de fichier ou de module *) let mod_of_name name = @@ -284,11 +283,11 @@ let declare_ml_modules l = let print_ml_path () = let l = !coq_mlpath_copy in pPNL [< 'sTR"ML Load Path:"; 'fNL; 'sTR" "; - hV 0 (prlist_with_sep pr_fnl (fun e -> [< 'sTR e.directory >]) l) >] + hV 0 (prlist_with_sep pr_fnl pr_str l) >] (* Printing of loaded ML modules *) let print_ml_modules () = let l = get_loaded_modules () in pP [< 'sTR"Loaded ML Modules : " ; - hOV 0 (prlist_with_sep pr_fnl (fun s -> [< 'sTR s >]) l); 'fNL >] + hOV 0 (prlist_with_sep pr_fnl pr_str l); 'fNL >] diff --git a/toplevel/record.ml b/toplevel/record.ml index 5df670982c..13b2891ecf 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -24,20 +24,17 @@ open Command let make_constructor idstruc idps fields = let app_constructor = Ast.ope("APPLISTEXPL", - (Ast.nvar (string_of_id idstruc)):: - List.map (fun id -> Ast.nvar(string_of_id id)) idps) in + (Ast.nvar idstruc):: List.map (fun id -> Ast.nvar id) idps) in let rec aux fields = match fields with | [] -> app_constructor - | (id,true,ty)::l -> - Ast.ope("PROD",[ty; Ast.slam(Some (string_of_id id), aux l)]) - | (id,false,c)::l -> - Ast.ope("LETIN",[c; Ast.slam(Some (string_of_id id), aux l)]) + | (id,true,ty)::l -> Ast.ope("PROD",[ty; Ast.slam(Some id, aux l)]) + | (id,false,c)::l -> Ast.ope("LETIN",[c; Ast.slam(Some id, aux l)]) in aux fields let occur_fields id fs = - List.exists (fun (_,_,a) -> Ast.occur_var_ast (string_of_id id) a) fs + List.exists (fun (_,_,a) -> Ast.occur_var_ast id a) fs let interp_decl sigma env (id,assum,t) = if assum then diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index d36779b43d..82d31cf641 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -143,11 +143,11 @@ let print_located_qualid qid = with Not_found -> error ((Nametab.string_of_qualid qid) ^ " not a defined object") -let print_path_entry s = - [< 'sTR s.directory; 'tBRK (0,2); 'sTR (string_of_dirpath s.coq_dirpath) >] +let print_path_entry (s,l) = + [< 'sTR s; 'tBRK (0,2); 'sTR (string_of_dirpath l) >] let print_loadpath () = - let l = Library.get_load_path () in + let l = Library.get_full_load_path () in mSGNL (Pp.t [< 'sTR "Physical path: "; 'tAB; 'sTR "Logical Path:"; 'fNL; prlist_with_sep pr_fnl print_path_entry l >]) @@ -169,11 +169,29 @@ let _ = | [VARG_STRING f] -> (fun () -> locate_file f) | _ -> bad_vernac_args "LocateFile") +let msg_found_library = function + | Library.LibLoaded, fulldir, file -> + mSG [< pr_dirpath fulldir; 'sTR " has been loaded from file"; 'fNL; + 'sTR file; 'fNL >] + | Library.LibInPath, fulldir, file -> + mSG [< pr_dirpath fulldir; 'sTR " is bound to file "; 'sTR file; 'fNL >] + +let msg_notfound_library qid = function + | Library.LibUnmappedDir -> + let dir = fst (Nametab.repr_qualid qid) in + mSG [< 'sTR "No physical path is bound to "; pr_dirpath dir; 'fNL >] + | Library.LibNotFound -> + mSG (hOV 0 + [< 'sTR"Unable to locate library"; 'sPC; Nametab.pr_qualid qid; 'fNL >]) + | _ -> assert false + let _ = add "LocateLibrary" (function - | [VARG_IDENTIFIER id] -> - (fun () -> locate_file ((string_of_id id)^".vo")) + | [VARG_QUALID qid] -> + (fun () -> + try msg_found_library (Library.locate_qualified_library qid) + with e -> msg_notfound_library qid e) | _ -> bad_vernac_args "LocateLibrary") let _ = @@ -187,10 +205,10 @@ let _ = add "ADDPATH" (function | [VARG_STRING dir] -> - (fun () -> Mltop.add_path dir [Nametab.default_root]) + (fun () -> Mltop.add_path dir Nametab.default_root_prefix) | [VARG_STRING dir ; VARG_QUALID alias] -> let aliasdir,aliasname = Nametab.repr_qualid alias in - (fun () -> Mltop.add_path dir (aliasdir@[string_of_id aliasname])) + (fun () -> Mltop.add_path dir (aliasdir@[aliasname])) | _ -> bad_vernac_args "ADDPATH") (* For compatibility *) @@ -204,13 +222,10 @@ let _ = add "RECADDPATH" (function | [VARG_STRING dir] -> - (fun () -> Mltop.add_rec_path dir [Nametab.default_root]) + (fun () -> Mltop.add_rec_path dir Nametab.default_root_prefix) | [VARG_STRING dir ; VARG_QUALID alias] -> let aliasdir,aliasname = Nametab.repr_qualid alias in - (fun () -> - let alias = aliasdir@[string_of_id aliasname] in - Mltop.add_rec_path dir alias; - Nametab.push_library_root (List.hd alias)) + (fun () -> Mltop.add_rec_path dir (aliasdir@[aliasname])) | _ -> bad_vernac_args "RECADDPATH") (* For compatibility *) @@ -316,34 +331,37 @@ let _ = (function | [VARG_IDENTIFIER id] -> let s = string_of_id id in - let lpe,_ = - System.find_file_in_path (Library.get_load_path ()) (s^".v") in - fun () -> Lib.start_module (lpe.coq_dirpath @ [s]) + let lpe,_ = System.find_file_in_path (Library.get_load_path ()) (s^".v") in + let dir = (Library.find_logical_path lpe) @ [id] in + fun () -> + Lib.start_module dir | _ -> bad_vernac_args "BeginModule") let _ = add "WriteModule" (function | [VARG_IDENTIFIER id] -> - fun () -> let m = string_of_id id in Discharge.save_module_to m m + let mid = Lib.end_module id in + fun () -> let m = string_of_id id in Library.save_module_to mid m | [VARG_IDENTIFIER id; VARG_STRING f] -> - fun () -> Discharge.save_module_to (string_of_id id) f + let mid = Lib.end_module id in + fun () -> Library.save_module_to mid f | _ -> bad_vernac_args "WriteModule") let _ = add "ReadModule" (function - | [VARG_IDENTIFIER id] -> - fun () -> - without_mes_ambig Library.load_module (string_of_id id) None + | [VARG_QUALID qid] -> + fun () -> without_mes_ambig Library.read_module qid | _ -> bad_vernac_args "ReadModule") let _ = add "ImportModule" (function - | [VARG_IDENTIFIER id] -> - fun () -> - without_mes_ambig Library.import_module (string_of_id id) + | [VARG_QUALID qid] -> + fun () -> + let fullname = Nametab.locate_loaded_library qid in + without_mes_ambig Library.import_module fullname | _ -> bad_vernac_args "ImportModule") let _ = @@ -354,12 +372,10 @@ let _ = let opened = Library.opened_modules () and loaded = Library.loaded_modules () in mSG [< 'sTR"Loaded Modules: "; - hOV 0 (prlist_with_sep pr_fnl - (fun s -> [< 'sTR s >]) loaded); + hOV 0 (prlist_with_sep pr_fnl pr_dirpath loaded); 'fNL; 'sTR"Imported (open) Modules: "; - hOV 0 (prlist_with_sep pr_fnl - (fun s -> [< 'sTR s >]) opened); + hOV 0 (prlist_with_sep pr_fnl pr_dirpath opened); 'fNL >]) | _ -> bad_vernac_args "PrintModules") @@ -369,7 +385,7 @@ let _ = add "BeginSection" (function | [VARG_IDENTIFIER id] -> - (fun () -> let _ = Lib.open_section (string_of_id id) in ()) + (fun () -> let _ = Lib.open_section id in ()) | _ -> bad_vernac_args "BeginSection") let _ = @@ -378,7 +394,7 @@ let _ = | [VARG_IDENTIFIER id] -> (fun () -> check_no_pending_proofs (); - Discharge.close_section (is_verbose ()) (string_of_id id)) + Discharge.close_section (is_verbose ()) id) | _ -> bad_vernac_args "EndSection") (* Proof switching *) @@ -602,7 +618,7 @@ let _ = | [VARG_IDENTIFIER id] -> (fun () -> if_verbose show_script (); - save_anonymous false (string_of_id id)) + save_anonymous false id) | _ -> bad_vernac_args "DefinedAnonymous") let _ = @@ -612,11 +628,11 @@ let _ = (fun () -> let (strength, opacity) = interp_definition_kind kind in if_verbose show_script (); - save_anonymous_with_strength strength opacity (string_of_id id)) + save_anonymous_with_strength strength opacity id) | [VARG_IDENTIFIER id] -> (fun () -> if_verbose show_script (); - save_anonymous true (string_of_id id)) + save_anonymous true id) | _ -> bad_vernac_args "SaveAnonymous") let _ = @@ -859,7 +875,7 @@ let _ = let _ = add "TheoremProof" (function - | [VARG_STRING kind; VARG_IDENTIFIER s; + | [VARG_STRING kind; VARG_IDENTIFIER id; VARG_CONSTR com; VARG_VARGLIST coml] -> let calls = List.map (function @@ -872,7 +888,7 @@ let _ = try States.with_heavy_rollback (fun () -> - start_proof_com (Some s) stre com; + start_proof_com (Some id) stre com; if_verbose show_open_subgoals (); List.iter Vernacinterp.call calls; if_verbose show_script (); @@ -884,19 +900,19 @@ let _ = const_entry_type = _},_)) = cook_proof () in let cutt = vernac_tactic ("Cut",[Constr csr]) and exat = vernac_tactic ("Exact",[Constr pft]) in - delete_proof s; - by (tclTHENS cutt [introduction s;exat])) + delete_proof id; + by (tclTHENS cutt [introduction id;exat])) () with e -> if (is_unsafe "proof") && not (kind = "LETTOP") then begin - mSGNL [< 'sTR "Warning: checking of theorem "; pr_id s; + mSGNL [< 'sTR "Warning: checking of theorem "; pr_id id; 'sPC; 'sTR "failed"; 'sTR "... converting to Axiom" >]; - delete_proof s; - let _ = parameter_def_var (string_of_id s) com in () + delete_proof id; + let _ = parameter_def_var id com in () end else errorlabstrm "Vernacentries.TheoremProof" - [< 'sTR "checking of theorem "; pr_id s; 'sPC; + [< 'sTR "checking of theorem "; pr_id id; 'sPC; 'sTR "failed... aborting" >]) | _ -> bad_vernac_args "TheoremProof") @@ -961,12 +977,9 @@ let _ = List.iter (fun (sl,c) -> List.iter - (fun s -> - let ref = - hypothesis_def_var - (refining()) (string_of_id s) stre c in - if coe then - Class.try_add_new_coercion ref stre) + (fun id -> + let ref = hypothesis_def_var (refining()) id stre c in + if coe then Class.try_add_new_coercion ref stre) sl) slcl | _ -> bad_vernac_args "VARIABLE") @@ -982,7 +995,7 @@ let _ = (fun (sl,c) -> List.iter (fun s -> - let _ = parameter_def_var (string_of_id s) c in ()) + let _ = parameter_def_var s c in ()) sl) slcl | _ -> bad_vernac_args "PARAMETER") @@ -1018,7 +1031,7 @@ let _ = let extract_qualid = function | VARG_QUALID qid -> - (try wd_of_sp (fst (Nametab.locate_module qid)) + (try Nametab.locate_loaded_library qid with Not_found -> error ("Module/section "^(Nametab.string_of_qualid qid)^" not found")) | _ -> bad_vernac_args "extract_qualid" @@ -1196,7 +1209,7 @@ let _ = | _ -> bad_vernac_args "RECORD") cfs in let const = match namec with - | [] -> (id_of_string ("Build_"^(string_of_id struc))) + | [] -> add_prefix "Build_" struc | [VARG_IDENTIFIER id] -> id | _ -> bad_vernac_args "RECORD" in let iscoe = (coe = "COERCION") in @@ -1276,27 +1289,10 @@ let _ = syntax_definition id (aux com n)) | _ -> bad_vernac_args "SyntaxMacro") -(*** -let _ = - add "ABSTRACTION" - (function - | (VARG_IDENTIFIER id) :: (VARG_CONSTR com) :: l -> - (fun () -> - let arity = - Array.of_list - (List.map (function | (VARG_NUMBER n) -> n - | _ -> bad_vernac_args "") l) - in - abstraction_definition id arity com; - if_verbose - message ((string_of_id id)^" is now an abstraction")) - | _ -> bad_vernac_args "ABSTRACTION") -***) - let _ = add "Require" (function - | [VARG_STRING import; VARG_STRING specif; VARG_IDENTIFIER id] -> + | [VARG_STRING import; VARG_STRING specif; VARG_QUALID qid] -> fun () -> without_mes_ambig (Library.require_module @@ -1304,7 +1300,7 @@ let _ = None else Some (specif="SPECIFICATION")) - (string_of_id id) None) + qid None) (import="EXPORT") | _ -> bad_vernac_args "Require") @@ -1312,7 +1308,7 @@ let _ = add "RequireFrom" (function | [VARG_STRING import; VARG_STRING specif; - VARG_IDENTIFIER id; VARG_STRING filename] -> + VARG_QUALID qid; VARG_STRING filename] -> (fun () -> without_mes_ambig (Library.require_module @@ -1320,7 +1316,7 @@ let _ = None else Some (specif="SPECIFICATION")) - (string_of_id id) (Some filename)) + qid (Some filename)) (import="EXPORT")) | _ -> bad_vernac_args "RequireFrom") @@ -1416,22 +1412,22 @@ let _ = let _ = add "GRAMMAR" (function - | [VARG_IDENTIFIER univ; VARG_ASTLIST al] -> - (fun () -> Metasyntax.add_grammar_obj (string_of_id univ) al) + | [VARG_STRING univ; VARG_ASTLIST al] -> + (fun () -> Metasyntax.add_grammar_obj univ al) | _ -> bad_vernac_args "GRAMMAR") let _ = add "SYNTAX" (function - | [VARG_IDENTIFIER whatfor; VARG_ASTLIST sel] -> - (fun () -> Metasyntax.add_syntax_obj (string_of_id whatfor) sel) + | [VARG_STRING whatfor; VARG_ASTLIST sel] -> + (fun () -> Metasyntax.add_syntax_obj whatfor sel) | _ -> bad_vernac_args "SYNTAX") let _ = add "TACDEF" (let rec tacdef_fun lacc=function (VARG_IDENTIFIER name)::(VARG_AST tacexp)::tl -> - tacdef_fun ((string_of_id name,tacexp)::lacc) tl + tacdef_fun ((name,tacexp)::lacc) tl |[] -> fun () -> List.iter (fun (name,ve) -> Tacinterp.add_tacdef name ve) lacc diff --git a/toplevel/vernacinterp.ml b/toplevel/vernacinterp.ml index a0b434b9a4..f1d38494f4 100644 --- a/toplevel/vernacinterp.ml +++ b/toplevel/vernacinterp.ml @@ -82,10 +82,8 @@ let rec cvt_varg ast = VARG_VARGLIST (List.map cvt_varg l) | Node(_,"VERNACCALL",(Str (_,na))::l) -> VCALL (na,List.map cvt_varg l) - | Node(_,"VERNACCALL",(Id (_,na))::l) -> - VCALL (na,List.map cvt_varg l) - | Nvar(_,s) -> VARG_IDENTIFIER (id_of_string s) + | Nvar(_,id) -> VARG_IDENTIFIER id | Node(loc,"QUALIDARG",p) -> VARG_QUALID (Astterm.interp_qualid p) | Node(loc,"QUALIDCONSTARG",p) -> let q = Astterm.interp_qualid p in @@ -94,13 +92,14 @@ let rec cvt_varg ast = with Not_found -> Nametab.error_global_not_found_loc loc q in VARG_CONSTANT sp | Str(_,s) -> VARG_STRING s + | Id(_,s) -> VARG_STRING s | Num(_,n) -> VARG_NUMBER n | Node(_,"NONE",[]) -> VARG_UNIT | Node(_,"CONSTR",[c]) -> VARG_CONSTR c | Node(_,"CONSTRLIST",l) -> VARG_CONSTRLIST l | Node(_,"TACTIC",[c]) -> VARG_TACTIC c | Node(_,"BINDER",c::idl) -> - VARG_BINDER(List.map (compose id_of_string nvar_of_ast) idl, c) + VARG_BINDER(List.map nvar_of_ast idl, c) | Node(_,"BINDERLIST",l) -> VARG_BINDERLIST (List.map (compose (function |