summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--CHANGES6
-rw-r--r--Makefile2
-rw-r--r--Makefile.build4
-rw-r--r--TODO53
-rw-r--r--checker/inductive.ml93
-rw-r--r--checker/inductive.mli4
-rw-r--r--checker/safe_typing.ml2
-rw-r--r--config/coq_config.mli2
-rwxr-xr-xconfigure4
-rw-r--r--dev/doc/changes.txt7
-rwxr-xr-xdoc/stdlib/Library.tex2
-rw-r--r--ide/command_windows.ml2
-rw-r--r--ide/command_windows.mli2
-rw-r--r--ide/config_lexer.mll2
-rw-r--r--ide/config_parser.mly2
-rw-r--r--ide/coq.ml2
-rw-r--r--ide/coq.mli2
-rw-r--r--ide/coq_commands.ml2
-rw-r--r--ide/coq_tactics.ml2
-rw-r--r--ide/coq_tactics.mli2
-rw-r--r--ide/coqide.ml2
-rw-r--r--ide/coqide.mli2
-rw-r--r--ide/highlight.mll2
-rw-r--r--ide/ideutils.ml2
-rw-r--r--ide/ideutils.mli2
-rw-r--r--ide/preferences.ml2
-rw-r--r--ide/preferences.mli2
-rw-r--r--ide/undo.ml2
-rw-r--r--ide/undo_lablgtk_ge26.mli2
-rw-r--r--ide/undo_lablgtk_lt26.mli2
-rw-r--r--ide/utf8_convert.mll2
-rw-r--r--ide/utils/config_file.ml2
-rw-r--r--interp/constrextern.ml65
-rw-r--r--interp/constrextern.mli2
-rw-r--r--interp/constrintern.ml704
-rw-r--r--interp/constrintern.mli73
-rw-r--r--interp/coqlib.ml5
-rw-r--r--interp/coqlib.mli8
-rw-r--r--interp/dumpglob.ml9
-rw-r--r--interp/dumpglob.mli3
-rw-r--r--interp/genarg.ml2
-rw-r--r--interp/genarg.mli2
-rw-r--r--interp/implicit_quantifiers.ml39
-rw-r--r--interp/implicit_quantifiers.mli4
-rw-r--r--interp/modintern.ml2
-rw-r--r--interp/modintern.mli2
-rw-r--r--interp/notation.ml5
-rw-r--r--interp/notation.mli2
-rw-r--r--interp/ppextend.ml3
-rw-r--r--interp/ppextend.mli3
-rw-r--r--interp/reserve.ml2
-rw-r--r--interp/reserve.mli2
-rw-r--r--interp/syntax_def.ml6
-rw-r--r--interp/syntax_def.mli2
-rw-r--r--interp/topconstr.ml588
-rw-r--r--interp/topconstr.mli76
-rw-r--r--kernel/byterun/int64_emul.h2
-rw-r--r--kernel/byterun/int64_native.h2
-rw-r--r--kernel/cbytegen.ml138
-rw-r--r--kernel/closure.ml16
-rw-r--r--kernel/closure.mli2
-rw-r--r--kernel/conv_oracle.ml2
-rw-r--r--kernel/conv_oracle.mli2
-rw-r--r--kernel/cooking.ml2
-rw-r--r--kernel/cooking.mli2
-rw-r--r--kernel/csymtable.ml2
-rw-r--r--kernel/declarations.ml2
-rw-r--r--kernel/declarations.mli2
-rw-r--r--kernel/entries.ml2
-rw-r--r--kernel/entries.mli2
-rw-r--r--kernel/environ.ml2
-rw-r--r--kernel/environ.mli2
-rw-r--r--kernel/esubst.ml2
-rw-r--r--kernel/esubst.mli2
-rw-r--r--kernel/indtypes.ml2
-rw-r--r--kernel/indtypes.mli2
-rw-r--r--kernel/inductive.ml82
-rw-r--r--kernel/inductive.mli6
-rw-r--r--kernel/mod_subst.ml2
-rw-r--r--kernel/mod_subst.mli2
-rw-r--r--kernel/mod_typing.ml2
-rw-r--r--kernel/mod_typing.mli2
-rw-r--r--kernel/modops.ml2
-rw-r--r--kernel/modops.mli2
-rw-r--r--kernel/names.ml2
-rw-r--r--kernel/names.mli2
-rw-r--r--kernel/pre_env.ml2
-rw-r--r--kernel/pre_env.mli2
-rw-r--r--kernel/reduction.ml11
-rw-r--r--kernel/reduction.mli2
-rw-r--r--kernel/retroknowledge.ml2
-rw-r--r--kernel/retroknowledge.mli2
-rw-r--r--kernel/safe_typing.ml2
-rw-r--r--kernel/safe_typing.mli2
-rw-r--r--kernel/sign.ml2
-rw-r--r--kernel/sign.mli2
-rw-r--r--kernel/subtyping.ml2
-rw-r--r--kernel/subtyping.mli2
-rw-r--r--kernel/term.ml2
-rw-r--r--kernel/term.mli2
-rw-r--r--kernel/term_typing.ml2
-rw-r--r--kernel/term_typing.mli2
-rw-r--r--kernel/type_errors.ml2
-rw-r--r--kernel/type_errors.mli2
-rw-r--r--kernel/typeops.ml2
-rw-r--r--kernel/typeops.mli2
-rw-r--r--kernel/univ.ml2
-rw-r--r--kernel/univ.mli2
-rw-r--r--kernel/vm.ml138
-rw-r--r--lib/bigint.ml2
-rw-r--r--lib/bigint.mli2
-rw-r--r--lib/bstack.ml2
-rw-r--r--lib/bstack.mli2
-rw-r--r--lib/dyn.ml2
-rw-r--r--lib/dyn.mli2
-rw-r--r--lib/edit.ml2
-rw-r--r--lib/edit.mli2
-rw-r--r--lib/explore.ml2
-rw-r--r--lib/explore.mli2
-rw-r--r--lib/flags.ml4
-rw-r--r--lib/flags.mli4
-rw-r--r--lib/gmap.ml2
-rw-r--r--lib/gmap.mli2
-rw-r--r--lib/gmapl.ml2
-rw-r--r--lib/gmapl.mli2
-rw-r--r--lib/gset.ml2
-rw-r--r--lib/gset.mli2
-rw-r--r--lib/hashcons.ml2
-rw-r--r--lib/hashcons.mli2
-rw-r--r--lib/heap.ml2
-rw-r--r--lib/heap.mli2
-rw-r--r--lib/option.ml2
-rw-r--r--lib/option.mli2
-rw-r--r--lib/pp.ml42
-rw-r--r--lib/pp.mli2
-rw-r--r--lib/pp_control.ml2
-rw-r--r--lib/pp_control.mli2
-rw-r--r--lib/predicate.ml2
-rw-r--r--lib/predicate.mli2
-rw-r--r--lib/profile.ml2
-rw-r--r--lib/profile.mli2
-rw-r--r--lib/rtree.ml2
-rw-r--r--lib/rtree.mli2
-rw-r--r--lib/system.ml2
-rw-r--r--lib/system.mli2
-rw-r--r--lib/tlm.ml2
-rw-r--r--lib/tlm.mli2
-rw-r--r--lib/util.ml31
-rw-r--r--lib/util.mli21
-rw-r--r--library/decl_kinds.ml2
-rw-r--r--library/decl_kinds.mli2
-rw-r--r--library/declare.ml2
-rw-r--r--library/declare.mli2
-rw-r--r--library/declaremods.ml2
-rw-r--r--library/declaremods.mli2
-rw-r--r--library/decls.ml2
-rw-r--r--library/decls.mli2
-rw-r--r--library/dischargedhypsmap.ml2
-rw-r--r--library/dischargedhypsmap.mli2
-rw-r--r--library/global.ml2
-rw-r--r--library/global.mli2
-rw-r--r--library/goptions.ml2
-rw-r--r--library/goptions.mli2
-rw-r--r--library/heads.ml2
-rw-r--r--library/heads.mli2
-rw-r--r--library/impargs.ml2
-rw-r--r--library/impargs.mli2
-rw-r--r--library/lib.ml2
-rw-r--r--library/lib.mli2
-rw-r--r--library/libnames.ml2
-rw-r--r--library/libnames.mli2
-rw-r--r--library/libobject.ml2
-rw-r--r--library/libobject.mli2
-rw-r--r--library/library.ml2
-rw-r--r--library/library.mli2
-rw-r--r--library/nameops.ml2
-rw-r--r--library/nameops.mli2
-rw-r--r--library/nametab.ml2
-rw-r--r--library/nametab.mli2
-rw-r--r--library/states.ml2
-rw-r--r--library/states.mli2
-rw-r--r--library/summary.ml2
-rw-r--r--library/summary.mli2
-rw-r--r--parsing/argextend.ml42
-rw-r--r--parsing/egrammar.ml74
-rw-r--r--parsing/egrammar.mli14
-rw-r--r--parsing/extend.ml6
-rw-r--r--parsing/extend.mli4
-rw-r--r--parsing/extrawit.ml2
-rw-r--r--parsing/extrawit.mli2
-rw-r--r--parsing/g_constr.ml4137
-rw-r--r--parsing/g_decl_mode.ml42
-rw-r--r--parsing/g_ltac.ml42
-rw-r--r--parsing/g_natsyntax.mli2
-rw-r--r--parsing/g_prim.ml42
-rw-r--r--parsing/g_proofs.ml42
-rw-r--r--parsing/g_tactic.ml42
-rw-r--r--parsing/g_vernac.ml438
-rw-r--r--parsing/g_xml.ml42
-rw-r--r--parsing/g_zsyntax.mli2
-rw-r--r--parsing/lexer.ml42
-rw-r--r--parsing/lexer.mli2
-rw-r--r--parsing/pcoq.ml434
-rw-r--r--parsing/pcoq.mli11
-rw-r--r--parsing/ppconstr.ml58
-rw-r--r--parsing/ppconstr.mli2
-rw-r--r--parsing/ppdecl_proof.ml2
-rw-r--r--parsing/pptactic.ml2
-rw-r--r--parsing/pptactic.mli2
-rw-r--r--parsing/ppvernac.ml14
-rw-r--r--parsing/ppvernac.mli2
-rw-r--r--parsing/prettyp.ml2
-rw-r--r--parsing/prettyp.mli2
-rw-r--r--parsing/printer.ml2
-rw-r--r--parsing/printer.mli2
-rw-r--r--parsing/q_constr.ml42
-rw-r--r--parsing/q_coqast.ml49
-rw-r--r--parsing/q_util.ml42
-rw-r--r--parsing/q_util.mli2
-rw-r--r--parsing/tacextend.ml42
-rw-r--r--parsing/tactic_printer.ml2
-rw-r--r--parsing/tactic_printer.mli2
-rw-r--r--parsing/vernacextend.ml42
-rw-r--r--plugins/cc/ccalgo.ml2
-rw-r--r--plugins/cc/ccalgo.mli2
-rw-r--r--plugins/cc/ccproof.ml2
-rw-r--r--plugins/cc/ccproof.mli2
-rw-r--r--plugins/cc/cctac.ml2
-rw-r--r--plugins/cc/cctac.mli2
-rw-r--r--plugins/cc/g_congruence.ml42
-rw-r--r--plugins/dp/Dp.v2
-rw-r--r--plugins/dp/g_dp.ml42
-rw-r--r--plugins/dp/zenon.v2
-rw-r--r--plugins/extraction/ExtrOcamlBasic.v2
-rw-r--r--plugins/extraction/common.ml2
-rw-r--r--plugins/extraction/common.mli2
-rw-r--r--plugins/extraction/extract_env.ml2
-rw-r--r--plugins/extraction/extract_env.mli2
-rw-r--r--plugins/extraction/extraction.ml2
-rw-r--r--plugins/extraction/extraction.mli2
-rw-r--r--plugins/extraction/haskell.ml2
-rw-r--r--plugins/extraction/haskell.mli2
-rw-r--r--plugins/extraction/miniml.mli2
-rw-r--r--plugins/extraction/mlutil.ml2
-rw-r--r--plugins/extraction/mlutil.mli2
-rw-r--r--plugins/extraction/modutil.ml2
-rw-r--r--plugins/extraction/modutil.mli2
-rw-r--r--plugins/extraction/ocaml.ml2
-rw-r--r--plugins/extraction/ocaml.mli2
-rw-r--r--plugins/extraction/scheme.ml2
-rw-r--r--plugins/extraction/scheme.mli2
-rw-r--r--plugins/extraction/table.ml2
-rw-r--r--plugins/extraction/table.mli2
-rw-r--r--plugins/field/LegacyField.v2
-rw-r--r--plugins/field/LegacyField_Compl.v2
-rw-r--r--plugins/field/LegacyField_Tactic.v2
-rw-r--r--plugins/field/LegacyField_Theory.v2
-rw-r--r--plugins/field/field.ml42
-rw-r--r--plugins/firstorder/formula.ml2
-rw-r--r--plugins/firstorder/formula.mli2
-rw-r--r--plugins/firstorder/g_ground.ml422
-rw-r--r--plugins/firstorder/ground.ml2
-rw-r--r--plugins/firstorder/ground.mli2
-rw-r--r--plugins/firstorder/instances.ml2
-rw-r--r--plugins/firstorder/instances.mli2
-rw-r--r--plugins/firstorder/rules.ml2
-rw-r--r--plugins/firstorder/rules.mli2
-rw-r--r--plugins/firstorder/sequent.ml2
-rw-r--r--plugins/firstorder/sequent.mli2
-rw-r--r--plugins/firstorder/unify.ml2
-rw-r--r--plugins/firstorder/unify.mli2
-rw-r--r--plugins/fourier/Fourier.v2
-rw-r--r--plugins/fourier/Fourier_util.v2
-rw-r--r--plugins/fourier/fourier.ml2
-rw-r--r--plugins/fourier/fourierR.ml2
-rw-r--r--plugins/fourier/g_fourier.ml42
-rw-r--r--plugins/funind/functional_principles_proofs.ml1
-rw-r--r--plugins/funind/indfun.ml3
-rw-r--r--plugins/funind/recdef.ml4
-rw-r--r--plugins/micromega/g_micromega.ml42
-rw-r--r--plugins/nsatz/Nsatz.v (renamed from plugins/nsatz/Nsatz_domain.v)431
-rw-r--r--plugins/nsatz/NsatzR.v407
-rw-r--r--plugins/nsatz/NsatzZ.v73
-rw-r--r--plugins/nsatz/vo.itarget4
-rw-r--r--plugins/omega/Omega.v2
-rw-r--r--plugins/omega/OmegaLemmas.v2
-rw-r--r--plugins/omega/OmegaPlugin.v2
-rw-r--r--plugins/omega/coq_omega.ml2
-rw-r--r--plugins/omega/g_omega.ml42
-rw-r--r--plugins/quote/Quote.v2
-rw-r--r--plugins/quote/g_quote.ml42
-rw-r--r--plugins/quote/quote.ml2
-rw-r--r--plugins/ring/LegacyArithRing.v2
-rw-r--r--plugins/ring/LegacyNArithRing.v2
-rw-r--r--plugins/ring/LegacyRing.v2
-rw-r--r--plugins/ring/LegacyRing_theory.v2
-rw-r--r--plugins/ring/LegacyZArithRing.v2
-rw-r--r--plugins/ring/Ring_abstract.v2
-rw-r--r--plugins/ring/Ring_normalize.v2
-rw-r--r--plugins/ring/Setoid_ring.v2
-rw-r--r--plugins/ring/Setoid_ring_normalize.v2
-rw-r--r--plugins/ring/Setoid_ring_theory.v2
-rw-r--r--plugins/ring/g_ring.ml42
-rw-r--r--plugins/ring/ring.ml2
-rw-r--r--plugins/rtauto/Bintree.v2
-rw-r--r--plugins/rtauto/Rtauto.v2
-rw-r--r--plugins/rtauto/g_rtauto.ml42
-rw-r--r--plugins/rtauto/proof_search.ml2
-rw-r--r--plugins/rtauto/proof_search.mli2
-rw-r--r--plugins/rtauto/refl_tauto.ml2
-rw-r--r--plugins/rtauto/refl_tauto.mli2
-rw-r--r--plugins/setoid_ring/newring.ml48
-rw-r--r--plugins/subtac/eterm.ml30
-rw-r--r--plugins/subtac/eterm.mli2
-rw-r--r--plugins/subtac/g_subtac.ml419
-rw-r--r--plugins/subtac/subtac.ml38
-rw-r--r--plugins/subtac/subtac_cases.ml22
-rw-r--r--plugins/subtac/subtac_cases.mli2
-rw-r--r--plugins/subtac/subtac_classes.ml6
-rw-r--r--plugins/subtac/subtac_classes.mli2
-rw-r--r--plugins/subtac/subtac_coercion.ml25
-rw-r--r--plugins/subtac/subtac_command.ml55
-rw-r--r--plugins/subtac/subtac_command.mli6
-rw-r--r--plugins/subtac/subtac_obligations.ml77
-rw-r--r--plugins/subtac/subtac_obligations.mli7
-rw-r--r--plugins/subtac/subtac_pretyping.ml26
-rw-r--r--plugins/subtac/subtac_pretyping.mli2
-rw-r--r--plugins/subtac/subtac_pretyping_F.ml36
-rw-r--r--plugins/subtac/subtac_utils.ml127
-rw-r--r--plugins/subtac/subtac_utils.mli80
-rw-r--r--plugins/syntax/ascii_syntax.ml2
-rw-r--r--plugins/syntax/nat_syntax.ml2
-rw-r--r--plugins/syntax/numbers_syntax.ml2
-rw-r--r--plugins/syntax/r_syntax.ml2
-rw-r--r--plugins/syntax/string_syntax.ml2
-rw-r--r--plugins/syntax/z_syntax.ml2
-rw-r--r--plugins/xml/xml.mli2
-rw-r--r--plugins/xml/xmlcommand.mli2
-rw-r--r--plugins/xml/xmlentries.ml42
-rw-r--r--pretyping/cases.ml6
-rw-r--r--pretyping/cases.mli2
-rw-r--r--pretyping/cbv.ml2
-rw-r--r--pretyping/cbv.mli2
-rw-r--r--pretyping/classops.ml2
-rw-r--r--pretyping/classops.mli2
-rw-r--r--pretyping/clenv.ml23
-rw-r--r--pretyping/clenv.mli5
-rw-r--r--pretyping/coercion.ml2
-rw-r--r--pretyping/coercion.mli2
-rw-r--r--pretyping/detyping.ml4
-rw-r--r--pretyping/detyping.mli2
-rw-r--r--pretyping/evarconv.ml10
-rw-r--r--pretyping/evarconv.mli4
-rw-r--r--pretyping/evarutil.ml15
-rw-r--r--pretyping/evarutil.mli2
-rw-r--r--pretyping/evd.ml5
-rw-r--r--pretyping/evd.mli2
-rw-r--r--pretyping/indrec.ml2
-rw-r--r--pretyping/indrec.mli2
-rw-r--r--pretyping/inductiveops.ml2
-rw-r--r--pretyping/inductiveops.mli2
-rw-r--r--pretyping/matching.ml2
-rw-r--r--pretyping/matching.mli2
-rw-r--r--pretyping/namegen.ml2
-rw-r--r--pretyping/namegen.mli2
-rw-r--r--pretyping/pattern.ml2
-rw-r--r--pretyping/pattern.mli2
-rw-r--r--pretyping/pretype_errors.ml2
-rw-r--r--pretyping/pretype_errors.mli2
-rw-r--r--pretyping/pretyping.ml17
-rw-r--r--pretyping/pretyping.mli2
-rw-r--r--pretyping/rawterm.ml34
-rw-r--r--pretyping/rawterm.mli6
-rw-r--r--pretyping/recordops.ml2
-rw-r--r--pretyping/recordops.mli2
-rw-r--r--pretyping/reductionops.ml20
-rw-r--r--pretyping/reductionops.mli2
-rw-r--r--pretyping/retyping.ml2
-rw-r--r--pretyping/retyping.mli2
-rw-r--r--pretyping/tacred.ml2
-rw-r--r--pretyping/tacred.mli2
-rw-r--r--pretyping/termops.ml2
-rw-r--r--pretyping/termops.mli2
-rw-r--r--pretyping/typeclasses.ml59
-rw-r--r--pretyping/typeclasses.mli2
-rw-r--r--pretyping/typeclasses_errors.ml2
-rw-r--r--pretyping/typeclasses_errors.mli2
-rw-r--r--pretyping/typing.ml2
-rw-r--r--pretyping/typing.mli2
-rw-r--r--pretyping/unification.ml24
-rw-r--r--pretyping/unification.mli2
-rw-r--r--pretyping/vnorm.ml4
-rw-r--r--proofs/clenvtac.ml2
-rw-r--r--proofs/clenvtac.mli2
-rw-r--r--proofs/decl_expr.mli2
-rw-r--r--proofs/decl_mode.ml2
-rw-r--r--proofs/decl_mode.mli2
-rw-r--r--proofs/evar_refiner.ml2
-rw-r--r--proofs/evar_refiner.mli2
-rw-r--r--proofs/logic.ml4
-rw-r--r--proofs/logic.mli2
-rw-r--r--proofs/pfedit.ml2
-rw-r--r--proofs/pfedit.mli2
-rw-r--r--proofs/proof_trees.ml2
-rw-r--r--proofs/proof_trees.mli2
-rw-r--r--proofs/proof_type.ml2
-rw-r--r--proofs/proof_type.mli2
-rw-r--r--proofs/redexpr.ml2
-rw-r--r--proofs/redexpr.mli2
-rw-r--r--proofs/refiner.ml2
-rw-r--r--proofs/refiner.mli2
-rw-r--r--proofs/tacexpr.ml2
-rw-r--r--proofs/tacmach.ml2
-rw-r--r--proofs/tacmach.mli2
-rw-r--r--proofs/tactic_debug.ml2
-rw-r--r--proofs/tactic_debug.mli2
-rw-r--r--scripts/coqc.ml2
-rw-r--r--scripts/coqmktop.ml2
-rw-r--r--tactics/auto.ml2
-rw-r--r--tactics/auto.mli2
-rw-r--r--tactics/autorewrite.ml2
-rw-r--r--tactics/autorewrite.mli2
-rw-r--r--tactics/btermdn.ml5
-rw-r--r--tactics/btermdn.mli2
-rw-r--r--tactics/class_tactics.ml448
-rw-r--r--tactics/contradiction.ml2
-rw-r--r--tactics/contradiction.mli2
-rw-r--r--tactics/decl_interp.ml2
-rw-r--r--tactics/decl_interp.mli2
-rw-r--r--tactics/decl_proof_instr.ml2
-rw-r--r--tactics/decl_proof_instr.mli2
-rw-r--r--tactics/dhyp.ml2
-rw-r--r--tactics/dhyp.mli2
-rw-r--r--tactics/eauto.ml427
-rw-r--r--tactics/eauto.mli4
-rw-r--r--tactics/elim.ml2
-rw-r--r--tactics/elim.mli2
-rw-r--r--tactics/elimschemes.ml2
-rw-r--r--tactics/elimschemes.mli2
-rw-r--r--tactics/eqdecide.ml42
-rw-r--r--tactics/eqschemes.ml2
-rw-r--r--tactics/eqschemes.mli2
-rw-r--r--tactics/equality.ml2
-rw-r--r--tactics/equality.mli2
-rw-r--r--tactics/evar_tactics.ml2
-rw-r--r--tactics/evar_tactics.mli2
-rw-r--r--tactics/extraargs.ml42
-rw-r--r--tactics/extraargs.mli2
-rw-r--r--tactics/extratactics.ml42
-rw-r--r--tactics/extratactics.mli2
-rw-r--r--tactics/hiddentac.ml2
-rw-r--r--tactics/hiddentac.mli2
-rw-r--r--tactics/hipattern.ml42
-rw-r--r--tactics/hipattern.mli2
-rw-r--r--tactics/inv.ml2
-rw-r--r--tactics/inv.mli2
-rw-r--r--tactics/leminv.ml2
-rw-r--r--tactics/nbtermdn.ml4
-rw-r--r--tactics/nbtermdn.mli4
-rw-r--r--tactics/refine.ml2
-rw-r--r--tactics/refine.mli2
-rw-r--r--tactics/rewrite.ml4543
-rw-r--r--tactics/tacinterp.ml6
-rw-r--r--tactics/tacinterp.mli2
-rw-r--r--tactics/tactic_option.ml57
-rw-r--r--tactics/tactic_option.mli18
-rw-r--r--tactics/tacticals.ml2
-rw-r--r--tactics/tacticals.mli2
-rw-r--r--tactics/tactics.ml9
-rw-r--r--tactics/tactics.mli2
-rw-r--r--tactics/tactics.mllib1
-rw-r--r--tactics/tauto.ml42
-rw-r--r--tactics/termdn.ml14
-rw-r--r--tactics/termdn.mli4
-rw-r--r--test-suite/bugs/closed/2319.v13
-rw-r--r--test-suite/bugs/closed/shouldsucceed/1507.v2
-rw-r--r--test-suite/bugs/closed/shouldsucceed/2145.v4
-rw-r--r--test-suite/bugs/closed/shouldsucceed/2262.v11
-rw-r--r--test-suite/bugs/closed/shouldsucceed/2303.v4
-rw-r--r--test-suite/bugs/closed/shouldsucceed/2347.v10
-rw-r--r--test-suite/output/Notations.out28
-rw-r--r--test-suite/output/Notations.v39
-rw-r--r--test-suite/output/Notations2.out15
-rw-r--r--test-suite/output/Notations2.v41
-rw-r--r--test-suite/output/Search.out18
-rw-r--r--test-suite/output/SearchPattern.out18
-rw-r--r--test-suite/success/Field.v2
-rw-r--r--test-suite/success/Nsatz.v132
-rw-r--r--test-suite/success/Nsatz_domain.v274
-rw-r--r--test-suite/success/Tauto.v2
-rw-r--r--test-suite/success/Typeclasses.v6
-rw-r--r--theories/Arith/Arith.v2
-rw-r--r--theories/Arith/Arith_base.v2
-rw-r--r--theories/Arith/Between.v2
-rw-r--r--theories/Arith/Bool_nat.v2
-rw-r--r--theories/Arith/Compare.v2
-rw-r--r--theories/Arith/Compare_dec.v2
-rw-r--r--theories/Arith/Div2.v2
-rw-r--r--theories/Arith/EqNat.v2
-rw-r--r--theories/Arith/Euclid.v2
-rw-r--r--theories/Arith/Even.v2
-rw-r--r--theories/Arith/Factorial.v2
-rw-r--r--theories/Arith/Gt.v2
-rw-r--r--theories/Arith/Le.v2
-rw-r--r--theories/Arith/Lt.v2
-rw-r--r--theories/Arith/Max.v2
-rw-r--r--theories/Arith/Min.v2
-rw-r--r--theories/Arith/Minus.v2
-rw-r--r--theories/Arith/Mult.v2
-rw-r--r--theories/Arith/Peano_dec.v2
-rw-r--r--theories/Arith/Plus.v2
-rw-r--r--theories/Arith/Wf_nat.v2
-rw-r--r--theories/Bool/Bool.v2
-rw-r--r--theories/Bool/BoolEq.v2
-rw-r--r--theories/Bool/Bvector.v2
-rw-r--r--theories/Bool/DecBool.v2
-rw-r--r--theories/Bool/IfProp.v2
-rw-r--r--theories/Bool/Sumbool.v2
-rw-r--r--theories/Bool/Zerob.v2
-rw-r--r--theories/Classes/EquivDec.v2
-rw-r--r--theories/Classes/Equivalence.v2
-rw-r--r--theories/Classes/Init.v2
-rw-r--r--theories/Classes/Morphisms.v8
-rw-r--r--theories/Classes/RelationClasses.v4
-rw-r--r--theories/Classes/SetoidClass.v2
-rw-r--r--theories/Classes/SetoidDec.v5
-rw-r--r--theories/Classes/SetoidTactics.v2
-rw-r--r--theories/FSets/FMapAVL.v2
-rw-r--r--theories/FSets/FMapFacts.v2
-rw-r--r--theories/FSets/FMapFullAVL.v2
-rw-r--r--theories/FSets/FMapInterface.v2
-rw-r--r--theories/FSets/FMapList.v2
-rw-r--r--theories/FSets/FMapPositive.v2
-rw-r--r--theories/FSets/FMapWeakList.v2
-rw-r--r--theories/FSets/FMaps.v2
-rw-r--r--theories/FSets/FSetAVL.v2
-rw-r--r--theories/FSets/FSetBridge.v2
-rw-r--r--theories/FSets/FSetDecide.v2
-rw-r--r--theories/FSets/FSetEqProperties.v2
-rw-r--r--theories/FSets/FSetFacts.v2
-rw-r--r--theories/FSets/FSetInterface.v2
-rw-r--r--theories/FSets/FSetList.v2
-rw-r--r--theories/FSets/FSetProperties.v2
-rw-r--r--theories/FSets/FSetToFiniteSet.v2
-rw-r--r--theories/FSets/FSetWeakList.v2
-rw-r--r--theories/FSets/FSets.v2
-rw-r--r--theories/Init/Datatypes.v2
-rw-r--r--theories/Init/Logic.v2
-rw-r--r--theories/Init/Logic_Type.v2
-rw-r--r--theories/Init/Notations.v2
-rw-r--r--theories/Init/Peano.v2
-rw-r--r--theories/Init/Prelude.v2
-rw-r--r--theories/Init/Specif.v2
-rw-r--r--theories/Init/Tactics.v2
-rw-r--r--theories/Init/Wf.v2
-rw-r--r--theories/Lists/List.v2
-rw-r--r--theories/Lists/ListSet.v2
-rw-r--r--theories/Lists/ListTactics.v2
-rw-r--r--theories/Lists/SetoidList.v2
-rw-r--r--theories/Lists/Streams.v2
-rw-r--r--theories/Lists/TheoryList.v2
-rw-r--r--theories/Logic/Berardi.v2
-rw-r--r--theories/Logic/ChoiceFacts.v2
-rw-r--r--theories/Logic/Classical.v2
-rw-r--r--theories/Logic/ClassicalChoice.v2
-rw-r--r--theories/Logic/ClassicalDescription.v2
-rw-r--r--theories/Logic/ClassicalEpsilon.v2
-rw-r--r--theories/Logic/ClassicalFacts.v2
-rw-r--r--theories/Logic/ClassicalUniqueChoice.v2
-rw-r--r--theories/Logic/Classical_Pred_Set.v2
-rw-r--r--theories/Logic/Classical_Pred_Type.v2
-rw-r--r--theories/Logic/Classical_Prop.v2
-rw-r--r--theories/Logic/Classical_Type.v2
-rw-r--r--theories/Logic/ConstructiveEpsilon.v4
-rw-r--r--theories/Logic/Decidable.v2
-rw-r--r--theories/Logic/Description.v2
-rw-r--r--theories/Logic/Diaconescu.v2
-rw-r--r--theories/Logic/Epsilon.v2
-rw-r--r--theories/Logic/Eqdep.v6
-rw-r--r--theories/Logic/EqdepFacts.v2
-rw-r--r--theories/Logic/Eqdep_dec.v2
-rw-r--r--theories/Logic/FunctionalExtensionality.v2
-rw-r--r--theories/Logic/IndefiniteDescription.v2
-rw-r--r--theories/Logic/JMeq.v2
-rw-r--r--theories/Logic/RelationalChoice.v2
-rw-r--r--theories/NArith/BinNat.v2
-rw-r--r--theories/NArith/BinPos.v2
-rw-r--r--theories/NArith/NArith.v2
-rw-r--r--theories/NArith/Ndec.v2
-rw-r--r--theories/NArith/Ndigits.v2
-rw-r--r--theories/NArith/Ndist.v2
-rw-r--r--theories/NArith/Nnat.v2
-rw-r--r--theories/NArith/Pnat.v2
-rw-r--r--theories/Numbers/BigNumPrelude.v2
-rw-r--r--theories/Numbers/Cyclic/Abstract/CyclicAxioms.v2
-rw-r--r--theories/Numbers/Cyclic/Abstract/NZCyclic.v2
-rw-r--r--theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v2
-rw-r--r--theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v2
-rw-r--r--theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v2
-rw-r--r--theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v2
-rw-r--r--theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v2
-rw-r--r--theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v2
-rw-r--r--theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v2
-rw-r--r--theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v2
-rw-r--r--theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v2
-rw-r--r--theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v2
-rw-r--r--theories/Numbers/Cyclic/Int31/Cyclic31.v2
-rw-r--r--theories/Numbers/Cyclic/Int31/Int31.v2
-rw-r--r--theories/Numbers/Cyclic/Int31/Ring31.v2
-rw-r--r--theories/Numbers/Cyclic/ZModulo/ZModulo.v2
-rw-r--r--theories/Numbers/Integer/Abstract/ZAdd.v2
-rw-r--r--theories/Numbers/Integer/Abstract/ZAddOrder.v2
-rw-r--r--theories/Numbers/Integer/Abstract/ZAxioms.v2
-rw-r--r--theories/Numbers/Integer/Abstract/ZBase.v2
-rw-r--r--theories/Numbers/Integer/Abstract/ZLt.v2
-rw-r--r--theories/Numbers/Integer/Abstract/ZMul.v2
-rw-r--r--theories/Numbers/Integer/Abstract/ZMulOrder.v2
-rw-r--r--theories/Numbers/Integer/Abstract/ZProperties.v2
-rw-r--r--theories/Numbers/Integer/BigZ/BigZ.v2
-rw-r--r--theories/Numbers/Integer/BigZ/ZMake.v2
-rw-r--r--theories/Numbers/Integer/Binary/ZBinary.v2
-rw-r--r--theories/Numbers/Integer/NatPairs/ZNatPairs.v2
-rw-r--r--theories/Numbers/Integer/SpecViaZ/ZSig.v2
-rw-r--r--theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v2
-rw-r--r--theories/Numbers/NaryFunctions.v2
-rw-r--r--theories/Numbers/NatInt/NZAdd.v2
-rw-r--r--theories/Numbers/NatInt/NZAddOrder.v2
-rw-r--r--theories/Numbers/NatInt/NZAxioms.v2
-rw-r--r--theories/Numbers/NatInt/NZBase.v2
-rw-r--r--theories/Numbers/NatInt/NZDomain.v2
-rw-r--r--theories/Numbers/NatInt/NZMul.v2
-rw-r--r--theories/Numbers/NatInt/NZMulOrder.v2
-rw-r--r--theories/Numbers/NatInt/NZOrder.v2
-rw-r--r--theories/Numbers/NatInt/NZProperties.v2
-rw-r--r--theories/Numbers/Natural/Abstract/NAdd.v2
-rw-r--r--theories/Numbers/Natural/Abstract/NAddOrder.v2
-rw-r--r--theories/Numbers/Natural/Abstract/NAxioms.v2
-rw-r--r--theories/Numbers/Natural/Abstract/NBase.v2
-rw-r--r--theories/Numbers/Natural/Abstract/NDefOps.v2
-rw-r--r--theories/Numbers/Natural/Abstract/NIso.v2
-rw-r--r--theories/Numbers/Natural/Abstract/NMulOrder.v2
-rw-r--r--theories/Numbers/Natural/Abstract/NOrder.v2
-rw-r--r--theories/Numbers/Natural/Abstract/NProperties.v2
-rw-r--r--theories/Numbers/Natural/Abstract/NStrongRec.v2
-rw-r--r--theories/Numbers/Natural/Abstract/NSub.v2
-rw-r--r--theories/Numbers/Natural/BigN/NMake_gen.ml2
-rw-r--r--theories/Numbers/Natural/BigN/Nbasic.v2
-rw-r--r--theories/Numbers/Natural/Binary/NBinary.v2
-rw-r--r--theories/Numbers/Natural/Peano/NPeano.v2
-rw-r--r--theories/Numbers/Natural/SpecViaZ/NSig.v2
-rw-r--r--theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v2
-rw-r--r--theories/Numbers/NumPrelude.v2
-rw-r--r--theories/Numbers/Rational/SpecViaQ/QSig.v2
-rw-r--r--theories/Program/Basics.v2
-rw-r--r--theories/Program/Combinators.v2
-rw-r--r--theories/Program/Equality.v5
-rw-r--r--theories/Program/Program.v2
-rw-r--r--theories/Program/Subset.v2
-rw-r--r--theories/Program/Syntax.v2
-rw-r--r--theories/Program/Tactics.v4
-rw-r--r--theories/Program/Utils.v2
-rw-r--r--theories/Program/Wf.v6
-rw-r--r--theories/QArith/QArith.v2
-rw-r--r--theories/QArith/QArith_base.v2
-rw-r--r--theories/QArith/Qcanon.v2
-rw-r--r--theories/QArith/Qfield.v2
-rw-r--r--theories/QArith/Qreals.v2
-rw-r--r--theories/QArith/Qreduction.v2
-rw-r--r--theories/QArith/Qring.v2
-rw-r--r--theories/Reals/Alembert.v2
-rw-r--r--theories/Reals/AltSeries.v2
-rw-r--r--theories/Reals/ArithProp.v2
-rw-r--r--theories/Reals/Binomial.v2
-rw-r--r--theories/Reals/Cauchy_prod.v2
-rw-r--r--theories/Reals/Cos_plus.v2
-rw-r--r--theories/Reals/Cos_rel.v2
-rw-r--r--theories/Reals/DiscrR.v2
-rw-r--r--theories/Reals/Exp_prop.v2
-rw-r--r--theories/Reals/Integration.v2
-rw-r--r--theories/Reals/LegacyRfield.v2
-rw-r--r--theories/Reals/MVT.v2
-rw-r--r--theories/Reals/NewtonInt.v2
-rw-r--r--theories/Reals/PSeries_reg.v2
-rw-r--r--theories/Reals/PartSum.v2
-rw-r--r--theories/Reals/RIneq.v2
-rw-r--r--theories/Reals/RList.v2
-rw-r--r--theories/Reals/R_Ifp.v2
-rw-r--r--theories/Reals/R_sqr.v2
-rw-r--r--theories/Reals/R_sqrt.v2
-rw-r--r--theories/Reals/Ranalysis.v2
-rw-r--r--theories/Reals/Ranalysis1.v2
-rw-r--r--theories/Reals/Ranalysis2.v2
-rw-r--r--theories/Reals/Ranalysis3.v2
-rw-r--r--theories/Reals/Ranalysis4.v2
-rw-r--r--theories/Reals/Raxioms.v2
-rw-r--r--theories/Reals/Rbase.v2
-rw-r--r--theories/Reals/Rbasic_fun.v2
-rw-r--r--theories/Reals/Rcomplete.v2
-rw-r--r--theories/Reals/Rdefinitions.v2
-rw-r--r--theories/Reals/Rderiv.v2
-rw-r--r--theories/Reals/Reals.v2
-rw-r--r--theories/Reals/Rfunctions.v2
-rw-r--r--theories/Reals/Rgeom.v2
-rw-r--r--theories/Reals/RiemannInt.v2
-rw-r--r--theories/Reals/RiemannInt_SF.v2
-rw-r--r--theories/Reals/Rlimit.v2
-rw-r--r--theories/Reals/Rpow_def.v2
-rw-r--r--theories/Reals/Rpower.v2
-rw-r--r--theories/Reals/Rprod.v2
-rw-r--r--theories/Reals/Rseries.v2
-rw-r--r--theories/Reals/Rsigma.v2
-rw-r--r--theories/Reals/Rsqrt_def.v2
-rw-r--r--theories/Reals/Rtopology.v2
-rw-r--r--theories/Reals/Rtrigo.v2
-rw-r--r--theories/Reals/Rtrigo_alt.v2
-rw-r--r--theories/Reals/Rtrigo_calc.v2
-rw-r--r--theories/Reals/Rtrigo_def.v2
-rw-r--r--theories/Reals/Rtrigo_fun.v2
-rw-r--r--theories/Reals/Rtrigo_reg.v2
-rw-r--r--theories/Reals/SeqProp.v2
-rw-r--r--theories/Reals/SeqSeries.v2
-rw-r--r--theories/Reals/SplitAbsolu.v2
-rw-r--r--theories/Reals/SplitRmult.v2
-rw-r--r--theories/Reals/Sqrt_reg.v2
-rw-r--r--theories/Relations/Operators_Properties.v2
-rw-r--r--theories/Relations/Relation_Definitions.v2
-rw-r--r--theories/Relations/Relation_Operators.v2
-rw-r--r--theories/Relations/Relations.v2
-rw-r--r--theories/Setoids/Setoid.v2
-rw-r--r--theories/Sets/Classical_sets.v2
-rw-r--r--theories/Sets/Constructive_sets.v2
-rw-r--r--theories/Sets/Cpo.v2
-rw-r--r--theories/Sets/Ensembles.v2
-rw-r--r--theories/Sets/Finite_sets.v2
-rw-r--r--theories/Sets/Finite_sets_facts.v2
-rw-r--r--theories/Sets/Image.v2
-rw-r--r--theories/Sets/Infinite_sets.v2
-rw-r--r--theories/Sets/Integers.v2
-rw-r--r--theories/Sets/Multiset.v2
-rw-r--r--theories/Sets/Partial_Order.v2
-rw-r--r--theories/Sets/Permut.v2
-rw-r--r--theories/Sets/Powerset.v2
-rw-r--r--theories/Sets/Powerset_Classical_facts.v2
-rw-r--r--theories/Sets/Powerset_facts.v2
-rw-r--r--theories/Sets/Relations_1.v2
-rw-r--r--theories/Sets/Relations_1_facts.v2
-rw-r--r--theories/Sets/Relations_2.v2
-rw-r--r--theories/Sets/Relations_2_facts.v2
-rw-r--r--theories/Sets/Relations_3.v2
-rw-r--r--theories/Sets/Relations_3_facts.v2
-rw-r--r--theories/Sets/Uniset.v2
-rw-r--r--theories/Sorting/Heap.v51
-rw-r--r--theories/Sorting/Mergesort.v2
-rw-r--r--theories/Sorting/PermutEq.v2
-rw-r--r--theories/Sorting/PermutSetoid.v2
-rw-r--r--theories/Sorting/Permutation.v2
-rw-r--r--theories/Sorting/Sorted.v2
-rw-r--r--theories/Sorting/Sorting.v2
-rw-r--r--theories/Strings/Ascii.v2
-rw-r--r--theories/Strings/String.v2
-rw-r--r--theories/Structures/DecidableType.v2
-rw-r--r--theories/Structures/DecidableTypeEx.v2
-rw-r--r--theories/Structures/Equalities.v2
-rw-r--r--theories/Structures/OrderedType.v2
-rw-r--r--theories/Structures/OrderedTypeAlt.v2
-rw-r--r--theories/Structures/OrderedTypeEx.v2
-rw-r--r--theories/Structures/Orders.v2
-rw-r--r--theories/Structures/OrdersAlt.v2
-rw-r--r--theories/Structures/OrdersEx.v2
-rw-r--r--theories/Unicode/Utf8_core.v25
-rw-r--r--theories/Unicode/vo.itarget1
-rw-r--r--theories/Wellfounded/Disjoint_Union.v2
-rw-r--r--theories/Wellfounded/Inclusion.v2
-rw-r--r--theories/Wellfounded/Inverse_Image.v2
-rw-r--r--theories/Wellfounded/Lexicographic_Exponentiation.v2
-rw-r--r--theories/Wellfounded/Lexicographic_Product.v2
-rw-r--r--theories/Wellfounded/Transitive_Closure.v2
-rw-r--r--theories/Wellfounded/Union.v2
-rw-r--r--theories/Wellfounded/Well_Ordering.v2
-rw-r--r--theories/Wellfounded/Wellfounded.v2
-rw-r--r--theories/ZArith/BinInt.v2
-rw-r--r--theories/ZArith/Int.v2
-rw-r--r--theories/ZArith/Wf_Z.v2
-rw-r--r--theories/ZArith/ZArith.v2
-rw-r--r--theories/ZArith/ZArith_base.v2
-rw-r--r--theories/ZArith/ZArith_dec.v2
-rw-r--r--theories/ZArith/Zabs.v2
-rw-r--r--theories/ZArith/Zbool.v2
-rw-r--r--theories/ZArith/Zcomplements.v2
-rw-r--r--theories/ZArith/Zdigits.v2
-rw-r--r--theories/ZArith/Zdiv.v2
-rw-r--r--theories/ZArith/Zeven.v2
-rw-r--r--theories/ZArith/Zgcd_alt.v2
-rw-r--r--theories/ZArith/Zhints.v2
-rw-r--r--theories/ZArith/Zlogarithm.v2
-rw-r--r--theories/ZArith/Zmax.v2
-rw-r--r--theories/ZArith/Zmin.v2
-rw-r--r--theories/ZArith/Zmisc.v2
-rw-r--r--theories/ZArith/Znat.v2
-rw-r--r--theories/ZArith/Znumtheory.v2
-rw-r--r--theories/ZArith/Zorder.v2
-rw-r--r--theories/ZArith/Zpow_facts.v2
-rw-r--r--theories/ZArith/Zpower.v2
-rw-r--r--theories/ZArith/Zsqrt.v2
-rw-r--r--theories/ZArith/Zwf.v2
-rw-r--r--theories/ZArith/auxiliary.v2
-rw-r--r--tools/coq_makefile.ml42
-rw-r--r--tools/coq_tex.ml42
-rw-r--r--tools/coqdep.ml2
-rw-r--r--tools/coqdep_boot.ml2
-rw-r--r--tools/coqdep_lexer.mll2
-rw-r--r--tools/coqdoc/alpha.ml2
-rw-r--r--tools/coqdoc/alpha.mli2
-rw-r--r--tools/coqdoc/cpretty.mli2
-rw-r--r--tools/coqdoc/cpretty.mll2
-rw-r--r--tools/coqdoc/index.ml2
-rw-r--r--tools/coqdoc/index.mli2
-rw-r--r--tools/coqdoc/main.ml2
-rw-r--r--tools/coqdoc/output.ml2
-rw-r--r--tools/coqdoc/output.mli2
-rw-r--r--tools/coqwc.mll2
-rw-r--r--tools/gallina.ml2
-rw-r--r--tools/gallina_lexer.mll2
-rw-r--r--toplevel/auto_ind_decl.ml2
-rw-r--r--toplevel/cerrors.ml2
-rw-r--r--toplevel/cerrors.mli2
-rw-r--r--toplevel/class.ml2
-rw-r--r--toplevel/class.mli2
-rw-r--r--toplevel/classes.ml4
-rw-r--r--toplevel/classes.mli2
-rw-r--r--toplevel/command.ml62
-rw-r--r--toplevel/command.mli14
-rw-r--r--toplevel/coqinit.ml2
-rw-r--r--toplevel/coqinit.mli2
-rw-r--r--toplevel/coqtop.ml4
-rw-r--r--toplevel/coqtop.mli2
-rw-r--r--toplevel/discharge.ml2
-rw-r--r--toplevel/discharge.mli2
-rw-r--r--toplevel/himsg.ml4
-rw-r--r--toplevel/himsg.mli2
-rw-r--r--toplevel/ind_tables.ml2
-rw-r--r--toplevel/indschemes.ml72
-rw-r--r--toplevel/indschemes.mli2
-rw-r--r--toplevel/lemmas.ml2
-rw-r--r--toplevel/lemmas.mli2
-rw-r--r--toplevel/metasyntax.ml265
-rw-r--r--toplevel/metasyntax.mli4
-rw-r--r--toplevel/mltop.ml42
-rw-r--r--toplevel/mltop.mli2
-rw-r--r--toplevel/record.ml10
-rw-r--r--toplevel/record.mli2
-rw-r--r--toplevel/search.ml2
-rw-r--r--toplevel/search.mli2
-rw-r--r--toplevel/toplevel.ml2
-rw-r--r--toplevel/toplevel.mli2
-rw-r--r--toplevel/usage.ml2
-rw-r--r--toplevel/usage.mli2
-rw-r--r--toplevel/vernac.ml2
-rw-r--r--toplevel/vernac.mli2
-rw-r--r--toplevel/vernacentries.ml5
-rw-r--r--toplevel/vernacentries.mli2
-rw-r--r--toplevel/vernacexpr.ml3
-rw-r--r--toplevel/vernacinterp.ml2
-rw-r--r--toplevel/vernacinterp.mli2
-rw-r--r--toplevel/whelp.ml42
-rw-r--r--toplevel/whelp.mli2
866 files changed, 4085 insertions, 3665 deletions
diff --git a/CHANGES b/CHANGES
index 9e83e43d..7bcc8f62 100644
--- a/CHANGES
+++ b/CHANGES
@@ -11,7 +11,8 @@ Rewriting tactics
proofs that are dependent (use "simple subst" for preserving compatibility).
- Added support for Leibniz-rewriting of dependent hypotheses.
- Renamed "Morphism" into "Proper" and "respect" into "proper_prf"
- (possible source of incompatibility).
+ (possible source of incompatibility). A partial fix is to define
+ "Notation Morphism R f := (Proper (R%signature) f)."
- New tactic variants "rewrite* by" and "autorewrite*" that rewrite
respectively the first and all matches whose side-conditions are
solved.
@@ -126,7 +127,8 @@ Module system
- A functor application can be prefixed by a "!" to make it ignore any
"Inline" annotation in the type of its argument(s) (for examples of
use of the new features, see libraries Structures and Numbers).
-- Coercions are now active only when modules are imported.
+- Coercions are now active only when modules are imported (use "Set Automatic
+ Coercions Import" to get the behavior of the previous versions of Coq).
Extraction
diff --git a/Makefile b/Makefile
index 01772c0b..719511b1 100644
--- a/Makefile
+++ b/Makefile
@@ -6,7 +6,7 @@
# # GNU Lesser General Public License Version 2.1 #
#######################################################################
-# $Id$
+# $Id: Makefile 13184 2010-06-23 09:19:15Z notin $
# Makefile for Coq
diff --git a/Makefile.build b/Makefile.build
index a7ae1e22..4a7354e4 100644
--- a/Makefile.build
+++ b/Makefile.build
@@ -6,7 +6,7 @@
# # GNU Lesser General Public License Version 2.1 #
#######################################################################
-# $Id$
+# $Id: Makefile.build 13324 2010-07-24 19:21:23Z glondu $
# Makefile for Coq
@@ -623,7 +623,7 @@ install-coq-manpages:
install-emacs:
$(MKDIR) $(FULLEMACSLIB)
- $(INSTALLLIB) tools/coq.el tools/coq-inferior.el $(FULLEMACSLIB)
+ $(INSTALLLIB) tools/coq-db.el tools/coq-font-lock.el tools/coq-syntax.el tools/coq.el tools/coq-inferior.el $(FULLEMACSLIB)
# command to update TeX' kpathsea database
#UPDATETEX = $(MKTEXLSR) /usr/share/texmf /var/spool/texmf $(BASETEXDIR) > /dev/null
diff --git a/TODO b/TODO
deleted file mode 100644
index d6891e5f..00000000
--- a/TODO
+++ /dev/null
@@ -1,53 +0,0 @@
-Langage:
-
-Distribution:
-
-Environnement:
-
-- Porter SearchIsos
-
-Noyau:
-
-Tactic:
-
-- Que contradiction raisonne a isomorphisme pres de False
-
-Vernac:
-
-- Print / Print Proof en fait identiques ; Print ne devrait pas afficher
- les constantes opaques (devrait afficher qqchose comme <opaque>)
-
-Theories:
-
-- Rendre transparent tous les theoremes prouvant {A}+{B}
-- Faire demarrer PolyList.nth a` l'indice 0
- Renommer l'actuel nth en nth1 ??
-
-Doc:
-
-- Mettre à jour les messages d'erreurs de Discriminate/Simplify_eq/Injection
-- Documenter le filtrage sur les types inductifs avec let-ins (dont la
- compatibilite V6)
-
-- Ajouter let dans les règles du CIC
- -> FAIT, mais reste a documenter le let dans les inductifs
- et les champs manifestes dans les Record
-- revoir le chapitre sur les tactiques utilisateur
-- faut-il mieux spécifier la sémantique de Simpl (??)
-
-- Préciser la clarification syntaxique de IntroPattern
-- preciser que Goal vient en dernier dans une clause pattern list et
- qu'il doit apparaitre si il y a un "in"
-
-- Omega Time debranche mais Omega System et Omega Action remarchent ?
-- Ajout "Replace in" (mais TODO)
-- Syntaxe Conditional tac Rewrite marche, à documenter
-- Documenter Dependent Rewrite et CutRewrite ?
-- Ajouter les motifs sous-termes de ltac
-
-- ajouter doc de GenFixpoint (mais avant: changer syntaxe) (J. Forest ou Pierre C.)
-- mettre à jour la doc de induction (arguments multiples) (Pierre C.)
-- mettre à jour la doc de functional induction/scheme (J. Forest ou Pierre C.)
---> mettre à jour le CHANGES (vers la ligne 72)
-
-
diff --git a/checker/inductive.ml b/checker/inductive.ml
index a300af79..fcd69f26 100644
--- a/checker/inductive.ml
+++ b/checker/inductive.ml
@@ -429,7 +429,7 @@ type guard_env =
(* the recarg information of inductive family *)
recvec : wf_paths array;
(* dB of variables denoting subterms *)
- genv : subterm_spec list;
+ genv : subterm_spec Lazy.t list;
}
let make_renv env minds recarg (kn,tyi) =
@@ -440,7 +440,7 @@ let make_renv env minds recarg (kn,tyi) =
rel_min = recarg+2;
inds = minds;
recvec = mind_recvec;
- genv = [Subterm(Large,mind_recvec.(tyi))] }
+ genv = [Lazy.lazy_from_val (Subterm(Large,mind_recvec.(tyi)))] }
let push_var renv (x,ty,spec) =
{ renv with
@@ -452,30 +452,30 @@ let assign_var_spec renv (i,spec) =
{ renv with genv = list_assign renv.genv (i-1) spec }
let push_var_renv renv (x,ty) =
- push_var renv (x,ty,Not_subterm)
+ push_var renv (x,ty,Lazy.lazy_from_val Not_subterm)
(* Fetch recursive information about a variable p *)
let subterm_var p renv =
- try List.nth renv.genv (p-1)
+ try Lazy.force (List.nth renv.genv (p-1))
with Failure _ | Invalid_argument _ -> Not_subterm
(* Add a variable and mark it as strictly smaller with information [spec]. *)
let add_subterm renv (x,a,spec) =
- push_var renv (x,a,spec_of_tree spec)
+ push_var renv (x,a,lazy (spec_of_tree (Lazy.force spec)))
let push_ctxt_renv renv ctxt =
let n = rel_context_length ctxt in
{ renv with
env = push_rel_context ctxt renv.env;
rel_min = renv.rel_min+n;
- genv = iterate (fun ge -> Not_subterm::ge) n renv.genv }
+ genv = iterate (fun ge -> Lazy.lazy_from_val Not_subterm::ge) n renv.genv }
let push_fix_renv renv (_,v,_ as recdef) =
let n = Array.length v in
{ renv with
env = push_rec_types recdef renv.env;
rel_min = renv.rel_min+n;
- genv = iterate (fun ge -> Not_subterm::ge) n renv.genv }
+ genv = iterate (fun ge -> Lazy.lazy_from_val Not_subterm::ge) n renv.genv }
(******************************)
@@ -499,12 +499,44 @@ let lookup_subterms env ind =
(*********************************)
+let match_trees t1 t2 =
+ let v1 = dest_subterms t1 in
+ let v2 = dest_subterms t2 in
+ array_for_all2 (fun l1 l2 -> List.length l1 = List.length l2) v1 v2
+
+(* In {match c as z in ind y_s return P with |C_i x_s => t end}
+ [branches_specif renv c_spec ind] returns an array of x_s specs given
+ c_spec the spec of c. *)
+let branches_specif renv c_spec ind =
+ let (_,mip) = lookup_mind_specif renv.env ind in
+ let car =
+ (* We fetch the regular tree associated to the inductive of the match.
+ This is just to get the number of constructors (and constructor
+ arities) that fit the match branches without forcing c_spec.
+ Note that c_spec might be more precise than [v] below, because of
+ nested inductive types. *)
+ let v = dest_subterms mip.mind_recargs in
+ Array.map List.length v in
+ Array.mapi
+ (fun i nca -> (* i+1-th cstructor has arity nca *)
+ let lvra = lazy
+ (match Lazy.force c_spec with
+ Subterm (_,t) when match_trees mip.mind_recargs t ->
+ let vra = Array.of_list (dest_subterms t).(i) in
+ assert (nca = Array.length vra);
+ Array.map spec_of_tree vra
+ | Dead_code -> Array.create nca Dead_code
+ | _ -> Array.create nca Not_subterm) in
+ list_tabulate (fun j -> lazy (Lazy.force lvra).(j)) nca)
+ car
+
(* Propagation of size information through Cases: if the matched
object is a recursive subterm then compute the information
associated to its own subterms.
Rq: if branch is not eta-long, then the recursive information
is not propagated to the missing abstractions *)
let case_branches_specif renv c_spec ind lbr =
+ let vlrec = branches_specif renv c_spec ind in
let rec push_branch_args renv lrec c =
match lrec with
ra::lr ->
@@ -516,17 +548,9 @@ let case_branches_specif renv c_spec ind lbr =
| _ -> (* branch not in eta-long form: cannot perform rec. calls *)
(renv,c'))
| [] -> (renv, c) in
- match c_spec with
- Subterm (_,t) ->
- let sub_spec = Array.map (List.map spec_of_tree) (dest_subterms t) in
- assert (Array.length sub_spec = Array.length lbr);
- array_map2 (push_branch_args renv) sub_spec lbr
- | Dead_code ->
- let t = dest_subterms (lookup_subterms renv.env ind) in
- let sub_spec = Array.map (List.map (fun _ -> Dead_code)) t in
- assert (Array.length sub_spec = Array.length lbr);
- array_map2 (push_branch_args renv) sub_spec lbr
- | Not_subterm -> Array.map (fun c -> (renv,c)) lbr
+ assert (Array.length vlrec = Array.length lbr);
+ array_map2 (push_branch_args renv) vlrec lbr
+
(* [subterm_specif renv t] computes the recursive structure of [t] and
compare its size with the size of the initial recursive argument of
@@ -541,14 +565,11 @@ let rec subterm_specif renv t =
| Rel k -> subterm_var k renv
| Case (ci,_,c,lbr) ->
- if Array.length lbr = 0 then Dead_code
- else
- let c_spec = subterm_specif renv c in
- let lbr_spec = case_branches_specif renv c_spec ci.ci_ind lbr in
- let stl =
- Array.map (fun (renv',br') -> subterm_specif renv' br')
- lbr_spec in
- subterm_spec_glb stl
+ let lbr_spec = case_subterm_specif renv ci c lbr in
+ let stl =
+ Array.map (fun (renv',br') -> subterm_specif renv' br')
+ lbr_spec in
+ subterm_spec_glb stl
| Fix ((recindxs,i),(_,typarray,bodies as recdef)) ->
(* when proving that the fixpoint f(x)=e is less than n, it is enough
@@ -571,7 +592,8 @@ let rec subterm_specif renv t =
let renv' =
(* Why Strict here ? To be general, it could also be
Large... *)
- assign_var_spec renv' (nbfix-i, Subterm(Strict,recargs)) in
+ assign_var_spec renv'
+ (nbfix-i, Lazy.lazy_from_val (Subterm(Strict,recargs))) in
let decrArg = recindxs.(i) in
let theBody = bodies.(i) in
let nbOfAbst = decrArg+1 in
@@ -582,7 +604,7 @@ let rec subterm_specif renv t =
if List.length l < nbOfAbst then renv''
else
let theDecrArg = List.nth l decrArg in
- let arg_spec = subterm_specif renv theDecrArg in
+ let arg_spec = lazy_subterm_specif renv theDecrArg in
assign_var_spec renv'' (1, arg_spec) in
subterm_specif renv'' strippedBody)
@@ -596,7 +618,15 @@ let rec subterm_specif renv t =
(* Other terms are not subterms *)
| _ -> Not_subterm
+and lazy_subterm_specif renv t =
+ lazy (subterm_specif renv t)
+and case_subterm_specif renv ci c lbr =
+ if Array.length lbr = 0 then [||]
+ else
+ let c_spec = lazy_subterm_specif renv c in
+ case_branches_specif renv c_spec ci.ci_ind lbr
+
(* Check term c can be applied to one of the mutual fixpoints. *)
let check_is_subterm renv c =
match subterm_specif renv c with
@@ -611,7 +641,7 @@ let error_illegal_rec_call renv fx arg =
let (_,le_vars,lt_vars) =
List.fold_left
(fun (i,le,lt) sbt ->
- match sbt with
+ match Lazy.force sbt with
(Subterm(Strict,_) | Dead_code) -> (i+1, le, i::lt)
| (Subterm(Large,_)) -> (i+1, i::le, lt)
| _ -> (i+1, le ,lt))
@@ -665,8 +695,7 @@ let check_one_fix renv recpos def =
List.iter (check_rec_call renv) (c_0::p::l);
(* compute the recarg information for the arguments of
each branch *)
- let c_spec = subterm_specif renv c_0 in
- let lbr = case_branches_specif renv c_spec ci.ci_ind lrest in
+ let lbr = case_subterm_specif renv ci c_0 lrest in
Array.iter (fun (renv',br') -> check_rec_call renv' br') lbr
(* Enables to traverse Fixpoint definitions in a more intelligent
@@ -694,7 +723,7 @@ let check_one_fix renv recpos def =
(fun j body ->
if i=j then
let theDecrArg = List.nth l decrArg in
- let arg_spec = subterm_specif renv theDecrArg in
+ let arg_spec = lazy_subterm_specif renv theDecrArg in
check_nested_fix_body renv' (decrArg+1) arg_spec body
else check_rec_call renv' body)
bodies
diff --git a/checker/inductive.mli b/checker/inductive.mli
index 2708c2d8..d44d1556 100644
--- a/checker/inductive.mli
+++ b/checker/inductive.mli
@@ -77,9 +77,9 @@ type guard_env =
(* the recarg information of inductive family *)
recvec : wf_paths array;
(* dB of variables denoting subterms *)
- genv : subterm_spec list;
+ genv : subterm_spec Lazy.t list;
}
val subterm_specif : guard_env -> constr -> subterm_spec
-val case_branches_specif : guard_env -> subterm_spec -> inductive ->
+val case_branches_specif : guard_env -> subterm_spec Lazy.t -> inductive ->
constr array -> (guard_env * constr) array
diff --git a/checker/safe_typing.ml b/checker/safe_typing.ml
index 9c82285b..07718a09 100644
--- a/checker/safe_typing.ml
+++ b/checker/safe_typing.ml
@@ -131,7 +131,7 @@ let import file (dp,mb,depends,engmt as vo) digest =
full_add_module dp mb digest
(* When the module is admitted, digests *must* match *)
-let unsafe_import file (dp,mb,depends,engmt as vo) digest =
+let unsafe_import file (dp,mb,depends,engmt) digest =
(* if !Flags.debug then Validate.apply !Flags.debug val_vo vo;*)
let env = !genv in
check_imports (errorlabstrm"unsafe_import") dp env depends;
diff --git a/config/coq_config.mli b/config/coq_config.mli
index 6a99d017..10c298b5 100644
--- a/config/coq_config.mli
+++ b/config/coq_config.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: coq_config.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
val local : bool (* local use (no installation) *)
diff --git a/configure b/configure
index fb6dac1e..c7482ead 100755
--- a/configure
+++ b/configure
@@ -6,7 +6,7 @@
#
##################################
-VERSION=8.3-bugfix
+VERSION=8.3-rc1
VOMAGIC=08300
STATEMAGIC=58300
DATE=`LANG=C date +"%B %Y"`
@@ -1114,4 +1114,4 @@ echo
echo "*Warning* To compile the system for a new architecture"
echo " don't forget to do a 'make archclean' before './configure'."
-# $Id: configure 12689 2010-01-26 13:41:56Z glondu $
+# $Id: configure 13372 2010-08-06 08:36:16Z notin $
diff --git a/dev/doc/changes.txt b/dev/doc/changes.txt
index 91255202..069f7d42 100644
--- a/dev/doc/changes.txt
+++ b/dev/doc/changes.txt
@@ -7,6 +7,13 @@
whd_castappevar is now whd_head_evar
obsolete whd_ise disappears
+** Restructuration of the syntax of binders **
+
+binders_let -> binders
+binders_let_fixannot -> binders_fixannot
+binder_let -> closed_binder (and now covers only bracketed binders)
+binder was already obsolete and has been removed
+
** Semantical change of h_induction_destruct **
Warning, the order of the isrec and evar_flag was inconsistent and has
diff --git a/doc/stdlib/Library.tex b/doc/stdlib/Library.tex
index f5509c3a..bfd7f3f2 100755
--- a/doc/stdlib/Library.tex
+++ b/doc/stdlib/Library.tex
@@ -61,4 +61,4 @@ you can access from the \Coq\ home page at
\end{document}
-% $Id$
+% $Id: Library.tex 12363 2009-09-28 15:04:07Z letouzey $
diff --git a/ide/command_windows.ml b/ide/command_windows.ml
index 44ede5ac..4510189b 100644
--- a/ide/command_windows.ml
+++ b/ide/command_windows.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: command_windows.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
class command_window () =
(* let window = GWindow.window
diff --git a/ide/command_windows.mli b/ide/command_windows.mli
index 821d4ef2..eb0aa568 100644
--- a/ide/command_windows.mli
+++ b/ide/command_windows.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: command_windows.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
class command_window :
unit ->
diff --git a/ide/config_lexer.mll b/ide/config_lexer.mll
index 05a7d443..4e3ffd89 100644
--- a/ide/config_lexer.mll
+++ b/ide/config_lexer.mll
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: config_lexer.mll 13323 2010-07-24 15:57:30Z herbelin $ *)
{
diff --git a/ide/config_parser.mly b/ide/config_parser.mly
index a412391e..0859cbe0 100644
--- a/ide/config_parser.mly
+++ b/ide/config_parser.mly
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************/
-/* $Id$ */
+/* $Id: config_parser.mly 13323 2010-07-24 15:57:30Z herbelin $ */
%{
diff --git a/ide/coq.ml b/ide/coq.ml
index 3aaec889..9a12f1c1 100644
--- a/ide/coq.ml
+++ b/ide/coq.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: coq.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Vernac
open Vernacexpr
diff --git a/ide/coq.mli b/ide/coq.mli
index c81439f5..af17c0e9 100644
--- a/ide/coq.mli
+++ b/ide/coq.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: coq.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Names
open Term
diff --git a/ide/coq_commands.ml b/ide/coq_commands.ml
index 0fee399e..c8a5c940 100644
--- a/ide/coq_commands.ml
+++ b/ide/coq_commands.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: coq_commands.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
let commands = [
[(* "Abort"; *)
diff --git a/ide/coq_tactics.ml b/ide/coq_tactics.ml
index 1ad05785..e3d8131e 100644
--- a/ide/coq_tactics.ml
+++ b/ide/coq_tactics.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: coq_tactics.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
let tactics = [
"Abstract";
diff --git a/ide/coq_tactics.mli b/ide/coq_tactics.mli
index c5e4ca62..e33c73ab 100644
--- a/ide/coq_tactics.mli
+++ b/ide/coq_tactics.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: coq_tactics.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
val tactics : string list
diff --git a/ide/coqide.ml b/ide/coqide.ml
index 96ef695b..08452fe2 100644
--- a/ide/coqide.ml
+++ b/ide/coqide.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: coqide.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Preferences
open Vernacexpr
diff --git a/ide/coqide.mli b/ide/coqide.mli
index b79b2389..b70a9b4b 100644
--- a/ide/coqide.mli
+++ b/ide/coqide.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: coqide.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(* The CoqIde main module. The following function [start] will parse the
command line, initialize the load path, load the input
diff --git a/ide/highlight.mll b/ide/highlight.mll
index 3a6a6192..dfcc4354 100644
--- a/ide/highlight.mll
+++ b/ide/highlight.mll
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: highlight.mll 13323 2010-07-24 15:57:30Z herbelin $ *)
{
diff --git a/ide/ideutils.ml b/ide/ideutils.ml
index adeabf5d..138bf5f6 100644
--- a/ide/ideutils.ml
+++ b/ide/ideutils.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: ideutils.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Preferences
diff --git a/ide/ideutils.mli b/ide/ideutils.mli
index 28199207..9af4fb43 100644
--- a/ide/ideutils.mli
+++ b/ide/ideutils.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: ideutils.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
val async : ('a -> unit) -> 'a -> unit
val sync : ('a -> 'b) -> 'a -> 'b
diff --git a/ide/preferences.ml b/ide/preferences.ml
index d5ed7934..31d03ab9 100644
--- a/ide/preferences.ml
+++ b/ide/preferences.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: preferences.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Configwin
open Printf
diff --git a/ide/preferences.mli b/ide/preferences.mli
index cc39dcc3..50659717 100644
--- a/ide/preferences.mli
+++ b/ide/preferences.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: preferences.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
type pref =
{
diff --git a/ide/undo.ml b/ide/undo.ml
index 50e1a515..819b4807 100644
--- a/ide/undo.ml
+++ b/ide/undo.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: undo.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open GText
open Ideutils
diff --git a/ide/undo_lablgtk_ge26.mli b/ide/undo_lablgtk_ge26.mli
index 4d70a3ad..c260f171 100644
--- a/ide/undo_lablgtk_ge26.mli
+++ b/ide/undo_lablgtk_ge26.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: undo_lablgtk_ge26.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(* An undoable view class *)
diff --git a/ide/undo_lablgtk_lt26.mli b/ide/undo_lablgtk_lt26.mli
index f1910148..c9d1bacb 100644
--- a/ide/undo_lablgtk_lt26.mli
+++ b/ide/undo_lablgtk_lt26.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: undo_lablgtk_lt26.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(* An undoable view class *)
diff --git a/ide/utf8_convert.mll b/ide/utf8_convert.mll
index 1025e3b4..5034ab3c 100644
--- a/ide/utf8_convert.mll
+++ b/ide/utf8_convert.mll
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: utf8_convert.mll 13323 2010-07-24 15:57:30Z herbelin $ *)
{
open Lexing
diff --git a/ide/utils/config_file.ml b/ide/utils/config_file.ml
index 37f2e9a4..d972639f 100644
--- a/ide/utils/config_file.ml
+++ b/ide/utils/config_file.ml
@@ -23,7 +23,7 @@
(* *)
(*********************************************************************************)
-(* $Id$ *)
+(* $Id: config_file.ml 10348 2007-12-06 17:36:14Z aspiwack $ *)
(* TODO *)
(* section comments *)
diff --git a/interp/constrextern.ml b/interp/constrextern.ml
index 77a79883..b2b21925 100644
--- a/interp/constrextern.ml
+++ b/interp/constrextern.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: constrextern.ml 13329 2010-07-26 11:05:39Z herbelin $ *)
(*i*)
open Pp
@@ -178,9 +178,10 @@ let rec check_same_type ty1 ty2 =
check_same_type b1 b2
| CCast(_,a1,CastCoerce), CCast(_,a2, CastCoerce) ->
check_same_type a1 a2
- | CNotation(_,n1,(e1,el1)), CNotation(_,n2,(e2,el2)) when n1=n2 ->
+ | CNotation(_,n1,(e1,el1,bl1)), CNotation(_,n2,(e2,el2,bl2)) when n1=n2 ->
List.iter2 check_same_type e1 e2;
- List.iter2 (List.iter2 check_same_type) el1 el2
+ List.iter2 (List.iter2 check_same_type) el1 el2;
+ List.iter2 check_same_fix_binder bl1 bl2
| CPrim(_,i1), CPrim(_,i2) when i1=i2 -> ()
| CDelimiters(_,s1,e1), CDelimiters(_,s2,e2) when s1=s2 ->
check_same_type e1 e2
@@ -287,7 +288,7 @@ and spaces ntn n =
if n = String.length ntn then []
else if ntn.[n] = ' ' then wildcards ntn (n+1) else spaces ntn (n+1)
-let expand_curly_brackets loc mknot ntn (l,ll) =
+let expand_curly_brackets loc mknot ntn l =
let ntn' = ref ntn in
let rec expand_ntn i =
function
@@ -300,12 +301,12 @@ let expand_curly_brackets loc mknot ntn (l,ll) =
ntn' :=
String.sub !ntn' 0 p ^ "_" ^
String.sub !ntn' (p+5) (String.length !ntn' -p-5);
- mknot (loc,"{ _ }",([a],[])) end
+ mknot (loc,"{ _ }",[a]) end
else a in
a' :: expand_ntn (i+1) l in
let l = expand_ntn 0 l in
(* side effect *)
- mknot (loc,!ntn',(l,ll))
+ mknot (loc,!ntn',l)
let destPrim = function CPrim(_,t) -> Some t | _ -> None
let destPatPrim = function CPatPrim(_,t) -> Some t | _ -> None
@@ -313,32 +314,34 @@ let destPatPrim = function CPatPrim(_,t) -> Some t | _ -> None
let make_notation_gen loc ntn mknot mkprim destprim l =
if has_curly_brackets ntn
then expand_curly_brackets loc mknot ntn l
- else match ntn,List.map destprim (fst l),(snd l) with
+ else match ntn,List.map destprim l with
(* Special case to avoid writing "- 3" for e.g. (Zopp 3) *)
- | "- _", [Some (Numeral p)],[] when Bigint.is_strictly_pos p ->
- mknot (loc,ntn,([mknot (loc,"( _ )",l)],[]))
+ | "- _", [Some (Numeral p)] when Bigint.is_strictly_pos p ->
+ mknot (loc,ntn,([mknot (loc,"( _ )",l)]))
| _ ->
match decompose_notation_key ntn, l with
- | [Terminal "-"; Terminal x], ([],[]) ->
+ | [Terminal "-"; Terminal x], [] ->
(try mkprim (loc, Numeral (Bigint.neg (Bigint.of_string x)))
- with _ -> mknot (loc,ntn,([],[])))
- | [Terminal x], ([],[]) ->
+ with _ -> mknot (loc,ntn,[]))
+ | [Terminal x], [] ->
(try mkprim (loc, Numeral (Bigint.of_string x))
- with _ -> mknot (loc,ntn,([],[])))
+ with _ -> mknot (loc,ntn,[]))
| _ ->
mknot (loc,ntn,l)
-let make_notation loc ntn l =
+let make_notation loc ntn (terms,termlists,binders as subst) =
+ if termlists <> [] or binders <> [] then CNotation (loc,ntn,subst) else
make_notation_gen loc ntn
- (fun (loc,ntn,l) -> CNotation (loc,ntn,l))
+ (fun (loc,ntn,l) -> CNotation (loc,ntn,(l,[],[])))
(fun (loc,p) -> CPrim (loc,p))
- destPrim l
+ destPrim terms
-let make_pat_notation loc ntn l =
+let make_pat_notation loc ntn (terms,termlists as subst) =
+ if termlists <> [] then CPatNotation (loc,ntn,subst) else
make_notation_gen loc ntn
- (fun (loc,ntn,l) -> CPatNotation (loc,ntn,l))
+ (fun (loc,ntn,l) -> CPatNotation (loc,ntn,(l,[])))
(fun (loc,p) -> CPatPrim (loc,p))
- destPatPrim l
+ destPatPrim terms
(* Better to use extern_rawconstr composed with injection/retraction ?? *)
let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat =
@@ -686,10 +689,10 @@ let rec extern inctx scopes vars r =
let na' = match na,tm with
Anonymous, RVar (_,id) when
rtntypopt<>None & occur_rawconstr id (Option.get rtntypopt)
- -> Some Anonymous
+ -> Some (dummy_loc,Anonymous)
| Anonymous, _ -> None
| Name id, RVar (_,id') when id=id' -> None
- | Name _, _ -> Some na in
+ | Name _, _ -> Some (dummy_loc,na) in
(sub_extern false scopes vars tm,
(na',Option.map (fun (loc,ind,n,nal) ->
let params = list_tabulate
@@ -703,15 +706,15 @@ let rec extern inctx scopes vars r =
CCases (loc,sty,rtntypopt',tml,eqns)
| RLetTuple (loc,nal,(na,typopt),tm,b) ->
- CLetTuple (loc,nal,
- (Option.map (fun _ -> na) typopt,
+ CLetTuple (loc,List.map (fun na -> (dummy_loc,na)) nal,
+ (Option.map (fun _ -> (dummy_loc,na)) typopt,
Option.map (extern_typ scopes (add_vname vars na)) typopt),
sub_extern false scopes vars tm,
extern inctx scopes (List.fold_left add_vname vars nal) b)
| RIf (loc,c,(na,typopt),b1,b2) ->
CIf (loc,sub_extern false scopes vars c,
- (Option.map (fun _ -> na) typopt,
+ (Option.map (fun _ -> (dummy_loc,na)) typopt,
Option.map (extern_typ scopes (add_vname vars na)) typopt),
sub_extern inctx scopes vars b1, sub_extern inctx scopes vars b2)
@@ -836,7 +839,7 @@ and extern_symbol (tmp_scope,scopes as allscopes) vars t = function
| _, None -> t, [], [], []
| _ -> raise No_match in
(* Try matching ... *)
- let subst,substlist = match_aconstr t pat in
+ let terms,termlists,binders = match_aconstr t pat in
(* Try availability of interpretation ... *)
let e =
match keyrule with
@@ -851,17 +854,21 @@ and extern_symbol (tmp_scope,scopes as allscopes) vars t = function
List.map (fun (c,(scopt,scl)) ->
extern (* assuming no overloading: *) true
(scopt,scl@scopes') vars c)
- subst in
+ terms in
let ll =
List.map (fun (c,(scopt,scl)) ->
List.map (extern true (scopt,scl@scopes') vars) c)
- substlist in
- insert_delimiters (make_notation loc ntn (l,ll)) key)
+ termlists in
+ let bll =
+ List.map (fun (bl,(scopt,scl)) ->
+ snd (extern_local_binder (scopt,scl@scopes') vars bl))
+ binders in
+ insert_delimiters (make_notation loc ntn (l,ll,bll)) key)
| SynDefRule kn ->
let l =
List.map (fun (c,(scopt,scl)) ->
extern true (scopt,scl@scopes) vars c, None)
- subst in
+ terms in
let a = CRef (Qualid (loc, shortest_qualid_of_syndef vars kn)) in
if l = [] then a else CApp (loc,(None,a),l) in
if args = [] then e
diff --git a/interp/constrextern.mli b/interp/constrextern.mli
index 5f170bdc..248abeda 100644
--- a/interp/constrextern.mli
+++ b/interp/constrextern.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: constrextern.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Util
diff --git a/interp/constrintern.ml b/interp/constrintern.ml
index 0fed211d..3bf556f1 100644
--- a/interp/constrintern.ml
+++ b/interp/constrintern.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: constrintern.ml 13332 2010-07-26 22:12:43Z msozeau $ *)
open Pp
open Util
@@ -28,7 +28,10 @@ open Inductiveops
(* To interpret implicits and arg scopes of variables in inductive
types and recursive definitions and of projection names in records *)
-type var_internalization_type = Inductive | Recursive | Method
+type var_internalization_type =
+ | Inductive of identifier list (* list of params *)
+ | Recursive
+ | Method
type var_internalization_data =
(* type of the "free" variable, for coqdoc, e.g. while typing the
@@ -45,19 +48,12 @@ type var_internalization_data =
type internalization_env =
(identifier * var_internalization_data) list
-type full_internalization_env =
- (* a superset of the list of variables that may be automatically
- inserted and that must not occur as binders *)
- identifier list *
- (* mapping of the variables to their internalization data *)
- internalization_env
-
type raw_binder = (name * binding_kind * rawconstr option * rawconstr)
let interning_grammar = ref false
(* Historically for parsing grammar rules, but in fact used only for
- translator, v7 parsing, and unstrict tactic internalisation *)
+ translator, v7 parsing, and unstrict tactic internalization *)
let for_grammar f x =
interning_grammar := true;
let a = f x in
@@ -92,9 +88,9 @@ let global_reference_in_absolute_module dir id =
constr_of_global (Nametab.global_of_path (Libnames.make_path dir id))
(**********************************************************************)
-(* Internalisation errors *)
+(* Internalization errors *)
-type internalisation_error =
+type internalization_error =
| VariableCapture of identifier
| WrongExplicitImplicit
| IllegalMetavariable
@@ -104,7 +100,7 @@ type internalisation_error =
| BadPatternsNumber of int * int
| BadExplicitationNumber of explicitation * int option
-exception InternalisationError of loc * internalisation_error
+exception InternalizationError of loc * internalization_error
let explain_variable_capture id =
str "The variable " ++ pr_id id ++ str " occurs in its type"
@@ -146,7 +142,7 @@ let explain_bad_explicitation_number n po =
str "Bad explicitation name: found " ++ pr_id id ++
str" but was expecting " ++ s
-let explain_internalisation_error e =
+let explain_internalization_error e =
let pp = match e with
| VariableCapture id -> explain_variable_capture id
| WrongExplicitImplicit -> explain_wrong_explicit_implicit
@@ -171,30 +167,26 @@ let error_inductive_parameter_not_implicit loc =
(* Pre-computing the implicit arguments and arguments scopes needed *)
(* for interpretation *)
-let empty_internalization_env = ([],[])
+let empty_internalization_env = []
-let set_internalization_env_params ienv params =
- let nparams = List.length params in
- if nparams = 0 then
- ([],ienv)
- else
- let ienv_with_implicit_params =
- List.map (fun (id,(ty,_,impl,scopes)) ->
- let sub_impl,_ = list_chop nparams impl in
- let sub_impl' = List.filter is_status_implicit sub_impl in
- (id,(ty,List.map name_of_implicit sub_impl',impl,scopes))) ienv in
- (params, ienv_with_implicit_params)
-
-let compute_internalization_data env ty typ impls =
- let impl = compute_implicits_with_manual env typ (is_implicit_args()) impls in
- (ty, [], impl, compute_arguments_scope typ)
-
-let compute_full_internalization_env env ty params idl typl impll =
- set_internalization_env_params
- (list_map3
- (fun id typ impl -> (id,compute_internalization_data env ty typ impl))
- idl typl impll)
- params
+let compute_explicitable_implicit imps = function
+ | Inductive params ->
+ (* In inductive types, the parameters are fixed implicit arguments *)
+ let sub_impl,_ = list_chop (List.length params) imps in
+ let sub_impl' = List.filter is_status_implicit sub_impl in
+ List.map name_of_implicit sub_impl'
+ | Recursive | Method ->
+ (* Unable to know in advance what the implicit arguments will be *)
+ []
+
+let compute_internalization_data env ty typ impl =
+ let impl = compute_implicits_with_manual env typ (is_implicit_args()) impl in
+ let expls_impl = compute_explicitable_implicit impl ty in
+ (ty, expls_impl, impl, compute_arguments_scope typ)
+
+let compute_internalization_env env ty =
+ list_map3
+ (fun id typ impl -> (id,compute_internalization_data env ty typ impl))
(**********************************************************************)
(* Contracting "{ _ }" in notations *)
@@ -216,18 +208,18 @@ let expand_notation_string ntn n =
(* This contracts the special case of "{ _ }" for sumbool, sumor notations *)
(* Remark: expansion of squash at definition is done in metasyntax.ml *)
-let contract_notation ntn (l,ll) =
+let contract_notation ntn (l,ll,bll) =
let ntn' = ref ntn in
let rec contract_squash n = function
| [] -> []
- | CNotation (_,"{ _ }",([a],[])) :: l ->
+ | CNotation (_,"{ _ }",([a],[],[])) :: l ->
ntn' := expand_notation_string !ntn' n;
contract_squash n (a::l)
| a :: l ->
a::contract_squash (n+1) l in
let l = contract_squash 0 l in
(* side effect; don't inline *)
- !ntn',(l,ll)
+ !ntn',(l,ll,bll)
let contract_pat_notation ntn (l,ll) =
let ntn' = ref ntn in
@@ -250,43 +242,219 @@ let make_current_scope = function
| (Some tmp_scope,scopes) -> tmp_scope::scopes
| None,scopes -> scopes
-let set_var_scope loc id (_,_,scopt,scopes) varscopes =
- let idscopes = List.assoc id varscopes in
- if !idscopes <> None &
- make_current_scope (Option.get !idscopes)
- <> make_current_scope (scopt,scopes) then
- let pr_scope_stack = function
- | [] -> str "the empty scope stack"
- | [a] -> str "scope " ++ str a
- | l -> str "scope stack " ++
- str "[" ++ prlist_with_sep pr_comma str l ++ str "]" in
- user_err_loc (loc,"set_var_scope",
- pr_id id ++ str " is used both in " ++
- pr_scope_stack (make_current_scope (Option.get !idscopes)) ++
- strbrk " and in " ++
- pr_scope_stack (make_current_scope (scopt,scopes)))
- else
- idscopes := Some (scopt,scopes)
+let pr_scope_stack = function
+ | [] -> str "the empty scope stack"
+ | [a] -> str "scope " ++ str a
+ | l -> str "scope stack " ++
+ str "[" ++ prlist_with_sep pr_comma str l ++ str "]"
+
+let error_inconsistent_scope loc id scopes1 scopes2 =
+ user_err_loc (loc,"set_var_scope",
+ pr_id id ++ str " is used both in " ++
+ pr_scope_stack scopes1 ++ strbrk " and in " ++ pr_scope_stack scopes2)
+
+let error_expect_constr_notation_type loc id =
+ user_err_loc (loc,"",
+ pr_id id ++ str " is bound in the notation to a term variable.")
+
+let error_expect_binder_notation_type loc id =
+ user_err_loc (loc,"",
+ pr_id id ++
+ str " is expected to occur in binding position in the right-hand side.")
+
+let set_var_scope loc id istermvar (_,_,scopt,scopes) ntnvars =
+ try
+ let idscopes,typ = List.assoc id ntnvars in
+ if !idscopes <> None &
+ make_current_scope (Option.get !idscopes)
+ <> make_current_scope (scopt,scopes) then
+ error_inconsistent_scope loc id
+ (make_current_scope (Option.get !idscopes))
+ (make_current_scope (scopt,scopes))
+ else
+ idscopes := Some (scopt,scopes);
+ match typ with
+ | NtnInternTypeBinder ->
+ if istermvar then error_expect_binder_notation_type loc id
+ | NtnInternTypeConstr ->
+ (* We need sometimes to parse idents at a constr level for
+ factorization and we cannot enforce this constraint:
+ if not istermvar then error_expect_constr_notation_type loc id *)
+ ()
+ | NtnInternTypeIdent -> ()
+ with Not_found ->
+ (* Not in a notation *)
+ ()
+
+let set_type_scope (ids,unb,tmp_scope,scopes) =
+ (ids,unb,Some Notation.type_scope,scopes)
+
+let reset_tmp_scope (ids,unb,tmp_scope,scopes) =
+ (ids,unb,None,scopes)
+
+let rec it_mkRProd env body =
+ match env with
+ (na, bk, _, t) :: tl -> it_mkRProd tl (RProd (dummy_loc, na, bk, t, body))
+ | [] -> body
+
+let rec it_mkRLambda env body =
+ match env with
+ (na, bk, _, t) :: tl -> it_mkRLambda tl (RLambda (dummy_loc, na, bk, t, body))
+ | [] -> body
+
+(**********************************************************************)
+(* Utilities for binders *)
+
+let check_capture loc ty = function
+ | Name id when occur_var_constr_expr id ty ->
+ raise (InternalizationError (loc,VariableCapture id))
+ | _ ->
+ ()
+
+let locate_if_isevar loc na = function
+ | RHole _ ->
+ (try match na with
+ | Name id -> Reserve.find_reserved_type id
+ | Anonymous -> raise Not_found
+ with Not_found -> RHole (loc, Evd.BinderType na))
+ | x -> x
+
+let check_hidden_implicit_parameters id (_,_,_,impls) =
+ if List.exists (function
+ | (_,(Inductive indparams,_,_,_)) -> List.mem id indparams
+ | _ -> false) impls
+ then
+ errorlabstrm "" (strbrk "A parameter of an inductive type " ++
+ pr_id id ++ strbrk " is not allowed to be used as a bound variable in the type of its constructor.")
+
+let push_name_env ?(global_level=false) lvar (ids,unb,tmpsc,scopes as env) =
+ function
+ | loc,Anonymous ->
+ if global_level then
+ user_err_loc (loc,"", str "Anonymous variables not allowed");
+ env
+ | loc,Name id ->
+ check_hidden_implicit_parameters id lvar;
+ set_var_scope loc id false env (let (_,_,ntnvars,_) = lvar in ntnvars);
+ if global_level then Dumpglob.dump_definition (loc,id) true "var"
+ else Dumpglob.dump_binding loc id;
+ (Idset.add id ids,unb,tmpsc,scopes)
+
+let intern_generalized_binder ?(global_level=false) intern_type lvar
+ (ids,unb,tmpsc,sc as env) bl (loc, na) b b' t ty =
+ let ids = match na with Anonymous -> ids | Name na -> Idset.add na ids in
+ let ty, ids' =
+ if t then ty, ids else
+ Implicit_quantifiers.implicit_application ids
+ Implicit_quantifiers.combine_params_freevar ty
+ in
+ let ty' = intern_type (ids,true,tmpsc,sc) ty in
+ let fvs = Implicit_quantifiers.generalizable_vars_of_rawconstr ~bound:ids ~allowed:ids' ty' in
+ let env' = List.fold_left (fun env (x, l) -> push_name_env ~global_level lvar env (l, Name x)) env fvs in
+ let bl = List.map (fun (id, loc) -> (Name id, b, None, RHole (loc, Evd.BinderType (Name id)))) fvs in
+ let na = match na with
+ | Anonymous ->
+ if global_level then na
+ else
+ let name =
+ let id =
+ match ty with
+ | CApp (_, (_, CRef (Ident (loc,id))), _) -> id
+ | _ -> id_of_string "H"
+ in Implicit_quantifiers.make_fresh ids' (Global.env ()) id
+ in Name name
+ | _ -> na
+ in (push_name_env ~global_level lvar env' (loc,na)), (na,b',None,ty') :: List.rev bl
+
+let intern_local_binder_aux ?(global_level=false) intern intern_type lvar (env,bl) = function
+ | LocalRawAssum(nal,bk,ty) ->
+ (match bk with
+ | Default k ->
+ let (loc,na) = List.hd nal in
+ (* TODO: fail if several names with different implicit types *)
+ let ty = locate_if_isevar loc na (intern_type env ty) in
+ List.fold_left
+ (fun (env,bl) na ->
+ (push_name_env lvar env na,(snd na,k,None,ty)::bl))
+ (env,bl) nal
+ | Generalized (b,b',t) ->
+ let env, b = intern_generalized_binder ~global_level intern_type lvar env bl (List.hd nal) b b' t ty in
+ env, b @ bl)
+ | LocalRawDef((loc,na as locna),def) ->
+ (push_name_env lvar env locna,
+ (na,Explicit,Some(intern env def),RHole(loc,Evd.BinderType na))::bl)
+
+let intern_generalization intern (ids,unb,tmp_scope,scopes as env) lvar loc bk ak c =
+ let c = intern (ids,true,tmp_scope,scopes) c in
+ let fvs = Implicit_quantifiers.generalizable_vars_of_rawconstr ~bound:ids c in
+ let env', c' =
+ let abs =
+ let pi =
+ match ak with
+ | Some AbsPi -> true
+ | None when tmp_scope = Some Notation.type_scope
+ || List.mem Notation.type_scope scopes -> true
+ | _ -> false
+ in
+ if pi then
+ (fun (id, loc') acc ->
+ RProd (join_loc loc' loc, Name id, bk, RHole (loc', Evd.BinderType (Name id)), acc))
+ else
+ (fun (id, loc') acc ->
+ RLambda (join_loc loc' loc, Name id, bk, RHole (loc', Evd.BinderType (Name id)), acc))
+ in
+ List.fold_right (fun (id, loc as lid) (env, acc) ->
+ let env' = push_name_env lvar env (loc, Name id) in
+ (env', abs lid acc)) fvs (env,c)
+ in c'
+
+let iterate_binder intern lvar (env,bl) = function
+ | LocalRawAssum(nal,bk,ty) ->
+ let intern_type env = intern (set_type_scope env) in
+ (match bk with
+ | Default k ->
+ let (loc,na) = List.hd nal in
+ (* TODO: fail if several names with different implicit types *)
+ let ty = intern_type env ty in
+ let ty = locate_if_isevar loc na ty in
+ List.fold_left
+ (fun (env,bl) na -> (push_name_env lvar env na,(snd na,k,None,ty)::bl))
+ (env,bl) nal
+ | Generalized (b,b',t) ->
+ let env, b = intern_generalized_binder intern_type lvar env bl (List.hd nal) b b' t ty in
+ env, b @ bl)
+ | LocalRawDef((loc,na as locna),def) ->
+ (push_name_env lvar env locna,
+ (na,Explicit,Some(intern env def),RHole(loc,Evd.BinderType na))::bl)
(**********************************************************************)
(* Syntax extensions *)
-let traverse_binder (subst,substlist) (renaming,(ids,unb,tmpsc,scopes as env))=
+let option_mem_assoc id = function
+ | Some (id',c) -> id = id'
+ | None -> false
+
+let find_fresh_name renaming (terms,termlists,binders) id =
+ let fvs1 = List.map (fun (_,(c,_)) -> free_vars_of_constr_expr c) terms in
+ let fvs2 = List.flatten (List.map (fun (_,(l,_)) -> List.map free_vars_of_constr_expr l) termlists) in
+ let fvs3 = List.map snd renaming in
+ (* TODO binders *)
+ let fvs = List.flatten (List.map Idset.elements (fvs1@fvs2)) @ fvs3 in
+ next_ident_away id fvs
+
+let traverse_binder (terms,_,_ as subst)
+ (renaming,(ids,unb,tmpsc,scopes as env))=
function
| Anonymous -> (renaming,env),Anonymous
| Name id ->
try
(* Binders bound in the notation are considered first-order objects *)
- let _,na = coerce_to_name (fst (List.assoc id subst)) in
+ let _,na = coerce_to_name (fst (List.assoc id terms)) in
(renaming,(name_fold Idset.add na ids,unb,tmpsc,scopes)), na
with Not_found ->
(* Binders not bound in the notation do not capture variables *)
(* outside the notation (i.e. in the substitution) *)
- let fvs1 = List.map (fun (_,(c,_)) -> free_vars_of_constr_expr c) subst in
- let fvs2 = List.flatten (List.map (fun (_,(l,_)) -> List.map free_vars_of_constr_expr l) substlist) in
- let fvs3 = List.map snd renaming in
- let fvs = List.flatten (List.map Idset.elements (fvs1@fvs2)) @ fvs3 in
- let id' = next_ident_away id fvs in
+ let id' = find_fresh_name renaming subst id in
let renaming' = if id=id' then renaming else (id,id')::renaming in
(renaming',env), Name id'
@@ -294,17 +462,18 @@ let rec subst_iterator y t = function
| RVar (_,id) as x -> if id = y then t else x
| x -> map_rawconstr (subst_iterator y t) x
-let rec subst_aconstr_in_rawconstr loc interp (subst,substlist as sub) infos c =
- let (renaming,(ids,unb,_,scopes)) = infos in
- let subinfos = renaming,(ids,unb,None,scopes) in
- match c with
- | AVar id ->
+let subst_aconstr_in_rawconstr loc intern lvar subst infos c =
+ let (terms,termlists,binders) = subst in
+ let rec aux (terms,binderopt as subst') (renaming,(ids,unb,_,scopes as env)) c =
+ let subinfos = renaming,(ids,unb,None,scopes) in
+ match c with
+ | AVar id ->
begin
(* subst remembers the delimiters stack in the interpretation *)
(* of the notations *)
try
- let (a,(scopt,subscopes)) = List.assoc id subst in
- interp (ids,unb,scopt,subscopes@scopes) a
+ let (a,(scopt,subscopes)) = List.assoc id terms in
+ intern (ids,unb,scopt,subscopes@scopes) a
with Not_found ->
try
RVar (loc,List.assoc id renaming)
@@ -312,83 +481,96 @@ let rec subst_aconstr_in_rawconstr loc interp (subst,substlist as sub) infos c =
(* Happens for local notation joint with inductive/fixpoint defs *)
RVar (loc,id)
end
- | AList (x,_,iter,terminator,lassoc) ->
+ | AList (x,_,iter,terminator,lassoc) ->
(try
(* All elements of the list are in scopes (scopt,subscopes) *)
- let (l,(scopt,subscopes)) = List.assoc x substlist in
- let termin =
- subst_aconstr_in_rawconstr loc interp sub subinfos terminator in
+ let (l,(scopt,subscopes)) = List.assoc x termlists in
+ let termin = aux subst' subinfos terminator in
List.fold_right (fun a t ->
subst_iterator ldots_var t
- (subst_aconstr_in_rawconstr loc interp
- ((x,(a,(scopt,subscopes)))::subst,substlist) subinfos iter))
+ (aux ((x,(a,(scopt,subscopes)))::terms,binderopt) subinfos iter))
(if lassoc then List.rev l else l) termin
with Not_found ->
anomaly "Inconsistent substitution of recursive notation")
- | AHole (Evd.BinderType (Name id as na)) ->
+ | AHole (Evd.BinderType (Name id as na)) ->
let na =
- try snd (coerce_to_name (fst (List.assoc id subst)))
+ try snd (coerce_to_name (fst (List.assoc id terms)))
with Not_found -> na in
RHole (loc,Evd.BinderType na)
- | t ->
- rawconstr_of_aconstr_with_binders loc (traverse_binder sub)
- (subst_aconstr_in_rawconstr loc interp sub) subinfos t
-
-let intern_notation intern (_,_,tmp_scope,scopes as env) loc ntn fullargs =
- let ntn,(args,argslist as fullargs) = contract_notation ntn fullargs in
- let (((ids,idsl),c),df) = interp_notation loc ntn (tmp_scope,scopes) in
+ | ABinderList (x,_,iter,terminator) ->
+ (try
+ (* All elements of the list are in scopes (scopt,subscopes) *)
+ let (bl,(scopt,subscopes)) = List.assoc x binders in
+ let env,bl = List.fold_left (iterate_binder intern lvar) (env,[]) bl in
+ let termin = aux subst' (renaming,env) terminator in
+ List.fold_left (fun t binder ->
+ subst_iterator ldots_var t
+ (aux (terms,Some(x,binder)) subinfos iter))
+ termin bl
+ with Not_found ->
+ anomaly "Inconsistent substitution of recursive notation")
+ | AProd (Name id, AHole _, c') when option_mem_assoc id binderopt ->
+ let (na,bk,_,t) = snd (Option.get binderopt) in
+ RProd (loc,na,bk,t,aux subst' infos c')
+ | ALambda (Name id,AHole _,c') when option_mem_assoc id binderopt ->
+ let (na,bk,_,t) = snd (Option.get binderopt) in
+ RLambda (loc,na,bk,t,aux subst' infos c')
+ | t ->
+ rawconstr_of_aconstr_with_binders loc (traverse_binder subst)
+ (aux subst') subinfos t
+ in aux (terms,None) infos c
+
+let split_by_type ids =
+ List.fold_right (fun (x,(scl,typ)) (l1,l2,l3) ->
+ match typ with
+ | NtnTypeConstr -> ((x,scl)::l1,l2,l3)
+ | NtnTypeConstrList -> (l1,(x,scl)::l2,l3)
+ | NtnTypeBinderList -> (l1,l2,(x,scl)::l3)) ids ([],[],[])
+
+let make_subst ids l = List.map2 (fun (id,scl) a -> (id,(a,scl))) ids l
+
+let intern_notation intern (_,_,tmp_scope,scopes as env) lvar loc ntn fullargs =
+ let ntn,(args,argslist,bll as fullargs) = contract_notation ntn fullargs in
+ let ((ids,c),df) = interp_notation loc ntn (tmp_scope,scopes) in
Dumpglob.dump_notation_location (ntn_loc loc fullargs ntn) ntn df;
- let subst = List.map2 (fun (id,scl) a -> (id,(a,scl))) ids args in
- let substlist = List.map2 (fun (id,scl) a -> (id,(a,scl))) idsl argslist in
- subst_aconstr_in_rawconstr loc intern (subst,substlist) ([],env) c
-
-let set_type_scope (ids,unb,tmp_scope,scopes) =
- (ids,unb,Some Notation.type_scope,scopes)
-
-let reset_tmp_scope (ids,unb,tmp_scope,scopes) =
- (ids,unb,None,scopes)
-
-let rec it_mkRProd env body =
- match env with
- (na, bk, _, t) :: tl -> it_mkRProd tl (RProd (dummy_loc, na, bk, t, body))
- | [] -> body
-
-let rec it_mkRLambda env body =
- match env with
- (na, bk, _, t) :: tl -> it_mkRLambda tl (RLambda (dummy_loc, na, bk, t, body))
- | [] -> body
+ let ids,idsl,idsbl = split_by_type ids in
+ let terms = make_subst ids args in
+ let termlists = make_subst idsl argslist in
+ let binders = make_subst idsbl bll in
+ subst_aconstr_in_rawconstr loc intern lvar
+ (terms,termlists,binders) ([],env) c
(**********************************************************************)
(* Discriminating between bound variables and global references *)
-(* [vars1] is a set of name to avoid (used for the tactic language);
- [vars2] is the set of global variables, env is the set of variables
- abstracted until this point *)
-
let string_of_ty = function
- | Inductive -> "ind"
+ | Inductive _ -> "ind"
| Recursive -> "def"
| Method -> "meth"
-let intern_var (env,unbound_vars,_,_ as genv) (ltacvars,vars2,vars3,(_,impls)) loc id =
- let (vars1,unbndltacvars) = ltacvars in
+let intern_var (ids,_,_,_ as genv) (ltacvars,namedctxvars,ntnvars,impls) loc id =
+ let (ltacvars,unbndltacvars) = ltacvars in
(* Is [id] an inductive type potentially with implicit *)
try
- let ty,l,impl,argsc = List.assoc id impls in
- let l = List.map
- (fun id -> CRef (Ident (loc,id)), Some (loc,ExplByName id)) l in
+ let ty,expl_impls,impls,argsc = List.assoc id impls in
+ let expl_impls = List.map
+ (fun id -> CRef (Ident (loc,id)), Some (loc,ExplByName id)) expl_impls in
let tys = string_of_ty ty in
- Dumpglob.dump_reference loc "<>" (string_of_id id) tys;
- RVar (loc,id), impl, argsc, l
+ Dumpglob.dump_reference loc "<>" (string_of_id id) tys;
+ RVar (loc,id), impls, argsc, expl_impls
with Not_found ->
- (* Is [id] bound in current env or is an ltac var bound to constr *)
- if Idset.mem id env or List.mem id vars1
+ (* Is [id] bound in current term or is an ltac var bound to constr *)
+ if Idset.mem id ids or List.mem id ltacvars
then
RVar (loc,id), [], [], []
(* Is [id] a notation variable *)
- else if List.mem_assoc id vars3
+ else if List.mem_assoc id ntnvars
+ then
+ (set_var_scope loc id true genv ntnvars; RVar (loc,id), [], [], [])
+ (* Is [id] the special variable for recursive notations *)
+ else if ntnvars <> [] && id = ldots_var
then
- (set_var_scope loc id genv vars3; RVar (loc,id), [], [], [])
+ RVar (loc,id), [], [], []
else
(* Is [id] bound to a free name in ltac (this is an ltac error message) *)
try
@@ -398,7 +580,7 @@ let intern_var (env,unbound_vars,_,_ as genv) (ltacvars,vars2,vars3,(_,impls)) l
| Some id0 -> Pretype_errors.error_var_not_found_loc loc id0
with Not_found ->
(* Is [id] a goal or section variable *)
- let _ = Sign.lookup_named id vars2 in
+ let _ = Sign.lookup_named id namedctxvars in
try
(* [id] a section variable *)
(* Redundant: could be done in intern_qualid *)
@@ -443,7 +625,7 @@ let intern_reference ref =
(intern_extended_global_of_qualid (qualid_of_reference ref))
(* Is it a global reference or a syntactic definition? *)
-let intern_qualid loc qid intern env args =
+let intern_qualid loc qid intern env lvar args =
match intern_extended_global_of_qualid (loc,qid) with
| TrueGlobal ref ->
RRef (loc, ref), args
@@ -453,25 +635,25 @@ let intern_qualid loc qid intern env args =
if List.length args < nids then error_not_enough_arguments loc;
let args1,args2 = list_chop nids args in
check_no_explicitation args1;
- let subst = List.map2 (fun (id,scl) a -> (id,(fst a,scl))) ids args1 in
- subst_aconstr_in_rawconstr loc intern (subst,[]) ([],env) c, args2
+ let subst = make_subst ids (List.map fst args1) in
+ subst_aconstr_in_rawconstr loc intern lvar (subst,[],[]) ([],env) c, args2
(* Rule out section vars since these should have been found by intern_var *)
-let intern_non_secvar_qualid loc qid intern env args =
- match intern_qualid loc qid intern env args with
+let intern_non_secvar_qualid loc qid intern env lvar args =
+ match intern_qualid loc qid intern env lvar args with
| RRef (loc, VarRef id),_ -> error_global_not_found_loc loc qid
| r -> r
let intern_applied_reference intern (_, unb, _, _ as env) lvar args = function
| Qualid (loc, qid) ->
- let r,args2 = intern_qualid loc qid intern env args in
+ let r,args2 = intern_qualid loc qid intern env lvar args in
find_appl_head_data r, args2
| Ident (loc, id) ->
try intern_var env lvar loc id, args
with Not_found ->
let qid = qualid_of_ident id in
try
- let r,args2 = intern_non_secvar_qualid loc qid intern env args in
+ let r,args2 = intern_non_secvar_qualid loc qid intern env lvar args in
find_appl_head_data r, args2
with e ->
(* Extra allowance for non globalizing functions *)
@@ -482,7 +664,7 @@ let intern_applied_reference intern (_, unb, _, _ as env) lvar args = function
let interp_reference vars r =
let (r,_,_,_),_ =
intern_applied_reference (fun _ -> error_not_enough_arguments dummy_loc)
- (Idset.empty,false,None,[]) (vars,[],[],([],[])) [] r
+ (Idset.empty,false,None,[]) (vars,[],[],[]) [] r
in r
let apply_scope_env (ids,unb,_,scopes) = function
@@ -529,14 +711,14 @@ let loc_of_lhs lhs =
let check_linearity lhs ids =
match has_duplicate ids with
| Some id ->
- raise (InternalisationError (loc_of_lhs lhs,NonLinearPattern id))
+ raise (InternalizationError (loc_of_lhs lhs,NonLinearPattern id))
| None ->
()
(* Match the number of pattern against the number of matched args *)
let check_number_of_pattern loc n l =
let p = List.length l in
- if n<>p then raise (InternalisationError (loc,BadPatternsNumber (n,p)))
+ if n<>p then raise (InternalizationError (loc,BadPatternsNumber (n,p)))
let check_or_pat_variables loc ids idsl =
if List.exists (fun ids' -> not (list_eq_set ids ids')) idsl then
@@ -646,7 +828,7 @@ let find_constructor ref f aliases pats scopes =
let (loc,qid) = qualid_of_reference ref in
let gref =
try locate_extended qid
- with Not_found -> raise (InternalisationError (loc,NotAConstructor ref)) in
+ with Not_found -> raise (InternalizationError (loc,NotAConstructor ref)) in
match gref with
| SynDef sp ->
let (vars,a) = Syntax_def.search_syntactic_definition sp in
@@ -677,7 +859,7 @@ let find_constructor ref f aliases pats scopes =
let find_pattern_variable = function
| Ident (loc,id) -> id
- | Qualid (loc,_) as x -> raise (InternalisationError(loc,NotAConstructor x))
+ | Qualid (loc,_) as x -> raise (InternalizationError(loc,NotAConstructor x))
let maybe_constructor ref f aliases scopes =
try
@@ -686,7 +868,7 @@ let maybe_constructor ref f aliases scopes =
ConstrPat (c,idspl1)
with
(* patt var does not exists globally *)
- | InternalisationError _ -> VarPat (find_pattern_variable ref)
+ | InternalizationError _ -> VarPat (find_pattern_variable ref)
(* patt var also exists globally but does not satisfy preconditions *)
| (Environ.NotEvaluableConst _ | Not_found) ->
if_verbose msg_warning (str "pattern " ++ pr_reference ref ++
@@ -696,7 +878,7 @@ let maybe_constructor ref f aliases scopes =
let mustbe_constructor loc ref f aliases patl scopes =
try find_constructor ref f aliases patl scopes
with (Environ.NotEvaluableConst _ | Not_found) ->
- raise (InternalisationError (loc,NotAConstructor ref))
+ raise (InternalizationError (loc,NotAConstructor ref))
let sort_fields mode loc l completer =
(*mode=false if pattern and true if constructor*)
@@ -813,7 +995,8 @@ let rec intern_cases_pattern genv scopes (ids,asubst as aliases) tmp_scope pat=
intern_pat scopes aliases tmp_scope a
| CPatNotation (loc, ntn, fullargs) ->
let ntn,(args,argsl as fullargs) = contract_pat_notation ntn fullargs in
- let (((ids',idsl'),c),df) = Notation.interp_notation loc ntn (tmp_scope,scopes) in
+ let ((ids',c),df) = Notation.interp_notation loc ntn (tmp_scope,scopes) in
+ let (ids',idsl',_) = split_by_type ids' in
Dumpglob.dump_notation_location (patntn_loc loc fullargs ntn) ntn df;
let subst = List.map2 (fun (id,scl) a -> (id,(a,scl))) ids' args in
let substlist = List.map2 (fun (id,scl) a -> (id,(a,scl))) idsl' argsl in
@@ -849,116 +1032,6 @@ let rec intern_cases_pattern genv scopes (ids,asubst as aliases) tmp_scope pat=
(ids,List.flatten pl')
(**********************************************************************)
-(* Fix and CoFix *)
-
-(**********************************************************************)
-(* Utilities for binders *)
-
-let check_capture loc ty = function
- | Name id when occur_var_constr_expr id ty ->
- raise (InternalisationError (loc,VariableCapture id))
- | _ ->
- ()
-
-let locate_if_isevar loc na = function
- | RHole _ ->
- (try match na with
- | Name id -> Reserve.find_reserved_type id
- | Anonymous -> raise Not_found
- with Not_found -> RHole (loc, Evd.BinderType na))
- | x -> x
-
-let check_hidden_implicit_parameters id (_,_,_,(indnames,_)) =
- if List.mem id indnames then
- errorlabstrm "" (strbrk "A parameter or name of an inductive type " ++
- pr_id id ++ strbrk " is not allowed to be used as a bound variable in the type of its constructor.")
-
-let push_name_env ?(fail_anonymous=false) lvar (ids,unb,tmpsc,scopes as env) = function
- | Anonymous ->
- if fail_anonymous then errorlabstrm "" (str "Anonymous variables not allowed");
- env
- | Name id ->
- check_hidden_implicit_parameters id lvar;
- (Idset.add id ids, unb,tmpsc,scopes)
-
-let push_loc_name_env ?(fail_anonymous=false) lvar (ids,unb,tmpsc,scopes as env) loc = function
- | Anonymous ->
- if fail_anonymous then user_err_loc (loc,"", str "Anonymous variables not allowed");
- env
- | Name id ->
- check_hidden_implicit_parameters id lvar;
- Dumpglob.dump_binding loc id;
- (Idset.add id ids,unb,tmpsc,scopes)
-
-let intern_generalized_binder ?(fail_anonymous=false) intern_type lvar
- (ids,unb,tmpsc,sc as env) bl (loc, na) b b' t ty =
- let ids = match na with Anonymous -> ids | Name na -> Idset.add na ids in
- let ty, ids' =
- if t then ty, ids else
- Implicit_quantifiers.implicit_application ids
- Implicit_quantifiers.combine_params_freevar ty
- in
- let ty' = intern_type (ids,true,tmpsc,sc) ty in
- let fvs = Implicit_quantifiers.generalizable_vars_of_rawconstr ~bound:ids ~allowed:ids' ty' in
- let env' = List.fold_left (fun env (x, l) -> push_loc_name_env ~fail_anonymous lvar env l (Name x)) env fvs in
- let bl = List.map (fun (id, loc) -> (Name id, b, None, RHole (loc, Evd.BinderType (Name id)))) fvs in
- let na = match na with
- | Anonymous ->
- if fail_anonymous then na
- else
- let name =
- let id =
- match ty with
- | CApp (_, (_, CRef (Ident (loc,id))), _) -> id
- | _ -> id_of_string "H"
- in Implicit_quantifiers.make_fresh ids' (Global.env ()) id
- in Name name
- | _ -> na
- in (push_loc_name_env ~fail_anonymous lvar env' loc na), (na,b',None,ty') :: List.rev bl
-
-let intern_local_binder_aux ?(fail_anonymous=false) intern intern_type lvar ((ids,unb,ts,sc as env),bl) = function
- | LocalRawAssum(nal,bk,ty) ->
- (match bk with
- | Default k ->
- let (loc,na) = List.hd nal in
- (* TODO: fail if several names with different implicit types *)
- let ty = locate_if_isevar loc na (intern_type env ty) in
- List.fold_left
- (fun ((ids,unb,ts,sc),bl) (_,na) ->
- ((name_fold Idset.add na ids,unb,ts,sc), (na,k,None,ty)::bl))
- (env,bl) nal
- | Generalized (b,b',t) ->
- let env, b = intern_generalized_binder ~fail_anonymous intern_type lvar env bl (List.hd nal) b b' t ty in
- env, b @ bl)
- | LocalRawDef((loc,na),def) ->
- ((name_fold Idset.add na ids,unb,ts,sc),
- (na,Explicit,Some(intern env def),RHole(loc,Evd.BinderType na))::bl)
-
-let intern_generalization intern (ids,unb,tmp_scope,scopes as env) lvar loc bk ak c =
- let c = intern (ids,true,tmp_scope,scopes) c in
- let fvs = Implicit_quantifiers.generalizable_vars_of_rawconstr ~bound:ids c in
- let env', c' =
- let abs =
- let pi =
- match ak with
- | Some AbsPi -> true
- | None when tmp_scope = Some Notation.type_scope
- || List.mem Notation.type_scope scopes -> true
- | _ -> false
- in
- if pi then
- (fun (id, loc') acc ->
- RProd (join_loc loc' loc, Name id, bk, RHole (loc', Evd.BinderType (Name id)), acc))
- else
- (fun (id, loc') acc ->
- RLambda (join_loc loc' loc, Name id, bk, RHole (loc', Evd.BinderType (Name id)), acc))
- in
- List.fold_right (fun (id, loc as lid) (env, acc) ->
- let env' = push_loc_name_env lvar env loc (Name id) in
- (env', abs lid acc)) fvs (env,c)
- in c'
-
-(**********************************************************************)
(* Utilities for application *)
let merge_impargs l args =
@@ -1030,7 +1103,7 @@ let extract_explicit_arg imps args =
(**********************************************************************)
(* Main loop *)
-let internalise sigma globalenv env allow_patvar lvar c =
+let internalize sigma globalenv env allow_patvar lvar c =
let rec intern (ids,unb,tmp_scope,scopes as env) = function
| CRef ref as x ->
let (c,imp,subscopes,l),_ =
@@ -1044,17 +1117,16 @@ let internalise sigma globalenv env allow_patvar lvar c =
let n =
try list_index0 iddef lf
with Not_found ->
- raise (InternalisationError (locid,UnboundFixName (false,iddef)))
+ raise (InternalizationError (locid,UnboundFixName (false,iddef)))
in
let idl = Array.map
(fun (id,(n,order),bl,ty,bd) ->
let intern_ro_arg f =
- let idx = Option.default 0 (index_of_annot bl n) in
- let before, after = list_chop idx bl in
+ let before, after = split_at_annot bl n in
let ((ids',_,_,_) as env',rbefore) =
List.fold_left intern_local_binder (env,[]) before in
let ro = f (intern (ids', unb, tmp_scope, scopes)) in
- let n' = Option.map (fun _ -> List.length before) n in
+ let n' = Option.map (fun _ -> List.length rbefore) n in
n', ro, List.fold_left intern_local_binder (env',rbefore) after
in
let n, ro, ((ids',_,_,_),rbl) =
@@ -1082,7 +1154,7 @@ let internalise sigma globalenv env allow_patvar lvar c =
let n =
try list_index0 iddef lf
with Not_found ->
- raise (InternalisationError (locid,UnboundFixName (true,iddef)))
+ raise (InternalizationError (locid,UnboundFixName (true,iddef)))
in
let idl = Array.map
(fun (id,bl,ty,bd) ->
@@ -1107,15 +1179,15 @@ let internalise sigma globalenv env allow_patvar lvar c =
intern env c2
| CLambdaN (loc,(nal,bk,ty)::bll,c2) ->
iterate_lam loc (reset_tmp_scope env) bk ty (CLambdaN (loc, bll, c2)) nal
- | CLetIn (loc,(loc1,na),c1,c2) ->
- RLetIn (loc, na, intern (reset_tmp_scope env) c1,
- intern (push_loc_name_env lvar env loc1 na) c2)
- | CNotation (loc,"- _",([CPrim (_,Numeral p)],[]))
+ | CLetIn (loc,na,c1,c2) ->
+ RLetIn (loc, snd na, intern (reset_tmp_scope env) c1,
+ intern (push_name_env lvar env na) c2)
+ | CNotation (loc,"- _",([CPrim (_,Numeral p)],[],[]))
when Bigint.is_strictly_pos p ->
intern env (CPrim (loc,Numeral (Bigint.neg p)))
- | CNotation (_,"( _ )",([a],[])) -> intern env a
+ | CNotation (_,"( _ )",([a],[],[])) -> intern env a
| CNotation (loc,ntn,args) ->
- intern_notation intern env loc ntn args
+ intern_notation intern env lvar loc ntn args
| CGeneralization (loc,b,a,c) ->
intern_generalization intern env lvar loc b a c
| CPrim (loc, p) ->
@@ -1138,8 +1210,8 @@ let internalise sigma globalenv env allow_patvar lvar c =
let (c,impargs,args_scopes,l),args =
match f with
| CRef ref -> intern_applied_reference intern env lvar args ref
- | CNotation (loc,ntn,([],[])) ->
- let c = intern_notation intern env loc ntn ([],[]) in
+ | CNotation (loc,ntn,([],[],[])) ->
+ let c = intern_notation intern env lvar loc ntn ([],[],[]) in
find_appl_head_data c, args
| x -> (intern env f,[],[],[]), args in
let args =
@@ -1177,7 +1249,7 @@ let internalise sigma globalenv env allow_patvar lvar c =
let p' = Option.map (fun p ->
let env'' = List.fold_left (push_name_env lvar) env ids in
intern_type env'' p) po in
- RLetTuple (loc, nal, (na', p'), b',
+ RLetTuple (loc, List.map snd nal, (na', p'), b',
intern (List.fold_left (push_name_env lvar) env nal) c)
| CIf (loc, c, (na,po), b1, b2) ->
let env' = reset_tmp_scope env in
@@ -1191,7 +1263,7 @@ let internalise sigma globalenv env allow_patvar lvar c =
| CPatVar (loc, n) when allow_patvar ->
RPatVar (loc, n)
| CPatVar (loc, _) ->
- raise (InternalisationError (loc,IllegalMetavariable))
+ raise (InternalizationError (loc,IllegalMetavariable))
| CEvar (loc, n, l) ->
REvar (loc, n, Option.map (List.map (intern env)) l)
| CSort (loc, s) ->
@@ -1252,27 +1324,27 @@ let internalise sigma globalenv env allow_patvar lvar c =
if List.length l <> nindargs then
error_wrong_numarg_inductive_loc loc globalenv ind nindargs;
let nal = List.map (function
- | RHole loc -> Anonymous
- | RVar (_,id) -> Name id
+ | RHole (loc,_) -> loc,Anonymous
+ | RVar (loc,id) -> loc,Name id
| c -> user_err_loc (loc_of_rawconstr c,"",str "Not a name.")) l in
let parnal,realnal = list_chop nparams nal in
- if List.exists ((<>) Anonymous) parnal then
+ if List.exists (fun (_,na) -> na <> Anonymous) parnal then
error_inductive_parameter_not_implicit loc;
- realnal, Some (loc,ind,nparams,realnal)
+ realnal, Some (loc,ind,nparams,List.map snd realnal)
| None ->
[], None in
let na = match tm', na with
- | RVar (_,id), None when Idset.mem id vars -> Name id
- | RRef (loc, VarRef id), None -> Name id
- | _, None -> Anonymous
- | _, Some na -> na in
- (tm',(na,typ)), na::ids
+ | RVar (loc,id), None when Idset.mem id vars -> loc,Name id
+ | RRef (loc, VarRef id), None -> loc,Name id
+ | _, None -> dummy_loc,Anonymous
+ | _, Some (loc,na) -> loc,na in
+ (tm',(snd na,typ)), na::ids
and iterate_prod loc2 env bk ty body nal =
let rec default env bk = function
- | (loc1,na)::nal ->
+ | (loc1,na as locna)::nal ->
if nal <> [] then check_capture loc1 ty na;
- let body = default (push_loc_name_env lvar env loc1 na) bk nal in
+ let body = default (push_name_env lvar env locna) bk nal in
let ty = locate_if_isevar loc1 na (intern_type env ty) in
RProd (join_loc loc1 loc2, na, bk, ty, body)
| [] -> intern_type env body
@@ -1280,24 +1352,22 @@ let internalise sigma globalenv env allow_patvar lvar c =
match bk with
| Default b -> default env b nal
| Generalized (b,b',t) ->
- let env, ibind = intern_generalized_binder intern_type lvar
- env [] (List.hd nal) b b' t ty in
+ let env, ibind = intern_generalized_binder intern_type lvar env [] (List.hd nal) b b' t ty in
let body = intern_type env body in
it_mkRProd ibind body
and iterate_lam loc2 env bk ty body nal =
let rec default env bk = function
- | (loc1,na)::nal ->
+ | (loc1,na as locna)::nal ->
if nal <> [] then check_capture loc1 ty na;
- let body = default (push_loc_name_env lvar env loc1 na) bk nal in
+ let body = default (push_name_env lvar env locna) bk nal in
let ty = locate_if_isevar loc1 na (intern_type env ty) in
RLambda (join_loc loc1 loc2, na, bk, ty, body)
| [] -> intern env body
in match bk with
| Default b -> default env b nal
| Generalized (b, b', t) ->
- let env, ibind = intern_generalized_binder intern_type lvar
- env [] (List.hd nal) b b' t ty in
+ let env, ibind = intern_generalized_binder intern_type lvar env [] (List.hd nal) b b' t ty in
let body = intern env body in
it_mkRLambda ibind body
@@ -1345,9 +1415,9 @@ let internalise sigma globalenv env allow_patvar lvar c =
try
intern env c
with
- InternalisationError (loc,e) ->
+ InternalizationError (loc,e) ->
user_err_loc (loc,"internalize",
- explain_internalisation_error e)
+ explain_internalization_error e)
(**************************************************************************)
(* Functions to translate constr_expr into rawconstr *)
@@ -1359,11 +1429,11 @@ let extract_ids env =
Idset.empty
let intern_gen isarity sigma env
- ?(impls=([],[])) ?(allow_patvar=false) ?(ltacvars=([],[]))
+ ?(impls=[]) ?(allow_patvar=false) ?(ltacvars=([],[]))
c =
let tmp_scope =
if isarity then Some Notation.type_scope else None in
- internalise sigma env (extract_ids env, false, tmp_scope,[])
+ internalize sigma env (extract_ids env, false, tmp_scope,[])
allow_patvar (ltacvars,Environ.named_context env, [], impls) c
let intern_constr sigma env c = intern_gen false sigma env c
@@ -1374,8 +1444,8 @@ let intern_pattern env patt =
try
intern_cases_pattern env [] ([],[]) None patt
with
- InternalisationError (loc,e) ->
- user_err_loc (loc,"internalize",explain_internalisation_error e)
+ InternalizationError (loc,e) ->
+ user_err_loc (loc,"internalize",explain_internalization_error e)
type manual_implicits = (explicitation * (bool * bool * bool)) list
@@ -1384,7 +1454,7 @@ type manual_implicits = (explicitation * (bool * bool * bool)) list
(* Functions to parse and interpret constructions *)
let interp_gen kind sigma env
- ?(impls=([],[])) ?(allow_patvar=false) ?(ltacvars=([],[]))
+ ?(impls=[]) ?(allow_patvar=false) ?(ltacvars=([],[]))
c =
let c = intern_gen (kind=IsType) ~impls ~allow_patvar ~ltacvars sigma env c in
Default.understand_gen kind sigma env c
@@ -1392,10 +1462,10 @@ let interp_gen kind sigma env
let interp_constr sigma env c =
interp_gen (OfType None) sigma env c
-let interp_type sigma env ?(impls=([],[])) c =
+let interp_type sigma env ?(impls=[]) c =
interp_gen IsType sigma env ~impls c
-let interp_casted_constr sigma env ?(impls=([],[])) c typ =
+let interp_casted_constr sigma env ?(impls=[]) c typ =
interp_gen (OfType (Some typ)) sigma env ~impls c
let interp_open_constr sigma env c =
@@ -1423,34 +1493,35 @@ let interp_constr_judgment sigma env c =
Default.understand_judgment sigma env (intern_constr sigma env c)
let interp_constr_evars_gen_impls ?evdref ?(fail_evar=true)
- env ?(impls=([],[])) kind c =
+ env ?(impls=[]) kind c =
let evdref =
match evdref with
| None -> ref Evd.empty
| Some evdref -> evdref
in
- let c = intern_gen (kind=IsType) ~impls !evdref env c in
- let imps = Implicit_quantifiers.implicits_of_rawterm c in
+ let istype = kind = IsType in
+ let c = intern_gen istype ~impls !evdref env c in
+ let imps = Implicit_quantifiers.implicits_of_rawterm ~with_products:istype c in
Default.understand_tcc_evars ~fail_evar evdref env kind c, imps
let interp_casted_constr_evars_impls ?evdref ?(fail_evar=true)
- env ?(impls=([],[])) c typ =
+ env ?(impls=[]) c typ =
interp_constr_evars_gen_impls ?evdref ~fail_evar env ~impls (OfType (Some typ)) c
-let interp_type_evars_impls ?evdref ?(fail_evar=true) env ?(impls=([],[])) c =
+let interp_type_evars_impls ?evdref ?(fail_evar=true) env ?(impls=[]) c =
interp_constr_evars_gen_impls ?evdref ~fail_evar env IsType ~impls c
-let interp_constr_evars_impls ?evdref ?(fail_evar=true) env ?(impls=([],[])) c =
+let interp_constr_evars_impls ?evdref ?(fail_evar=true) env ?(impls=[]) c =
interp_constr_evars_gen_impls ?evdref ~fail_evar env (OfType None) ~impls c
-let interp_constr_evars_gen evdref env ?(impls=([],[])) kind c =
+let interp_constr_evars_gen evdref env ?(impls=[]) kind c =
let c = intern_gen (kind=IsType) ~impls ( !evdref) env c in
Default.understand_tcc_evars evdref env kind c
-let interp_casted_constr_evars evdref env ?(impls=([],[])) c typ =
+let interp_casted_constr_evars evdref env ?(impls=[]) c typ =
interp_constr_evars_gen evdref env ~impls (OfType (Some typ)) c
-let interp_type_evars evdref env ?(impls=([],[])) c =
+let interp_type_evars evdref env ?(impls=[]) c =
interp_constr_evars_gen evdref env IsType ~impls c
type ltac_sign = identifier list * unbound_ltac_var_map
@@ -1459,19 +1530,20 @@ let intern_constr_pattern sigma env ?(as_type=false) ?(ltacvars=([],[])) c =
let c = intern_gen as_type ~allow_patvar:true ~ltacvars sigma env c in
pattern_of_rawconstr c
-let interp_aconstr ?(impls=([],[])) (vars,varslist) a =
+let interp_aconstr ?(impls=[]) vars recvars a =
let env = Global.env () in
(* [vl] is intended to remember the scope of the free variables of [a] *)
- let vl = List.map (fun id -> (id,ref None)) (vars@varslist) in
- let c = internalise Evd.empty (Global.env()) (extract_ids env, false, None, [])
+ let vl = List.map (fun (id,typ) -> (id,(ref None,typ))) vars in
+ let c = internalize Evd.empty (Global.env()) (extract_ids env, false, None, [])
false (([],[]),Environ.named_context env,vl,impls) a in
(* Translate and check that [c] has all its free variables bound in [vars] *)
- let a = aconstr_of_rawconstr vars c in
+ let a = aconstr_of_rawconstr vars recvars c in
+ (* Splits variables into those that are binding, bound, or both *)
+ (* binding and bound *)
+ let out_scope = function None -> None,[] | Some (a,l) -> a,l in
+ let vars = List.map (fun (id,(sc,typ)) -> (id,(out_scope !sc,typ))) vl in
(* Returns [a] and the ordered list of variables with their scopes *)
- (* Variables occurring in binders have no relevant scope since bound *)
- let vl = List.map (fun (id,r) ->
- (id,match !r with None -> None,[] | Some (a,l) -> a,l)) vl in
- list_chop (List.length vars) vl, a
+ vars, a
(* Interpret binders and contexts *)
@@ -1489,14 +1561,14 @@ open Environ
open Term
let my_intern_constr sigma env lvar acc c =
- internalise sigma env acc false lvar c
+ internalize sigma env acc false lvar c
let my_intern_type sigma env lvar acc c = my_intern_constr sigma env lvar (set_type_scope acc) c
-let intern_context fail_anonymous sigma env params =
- let lvar = (([],[]),Environ.named_context env, [], ([], [])) in
+let intern_context global_level sigma env params =
+ let lvar = (([],[]),Environ.named_context env, [], []) in
snd (List.fold_left
- (intern_local_binder_aux ~fail_anonymous (my_intern_constr sigma env lvar) (my_intern_type sigma env lvar) lvar)
+ (intern_local_binder_aux ~global_level (my_intern_constr sigma env lvar) (my_intern_type sigma env lvar) lvar)
((extract_ids env,false,None,[]), []) params)
let interp_rawcontext_gen understand_type understand_judgment env bl =
@@ -1522,15 +1594,15 @@ let interp_rawcontext_gen understand_type understand_judgment env bl =
(env,[],1,[]) (List.rev bl)
in (env, par), impls
-let interp_context_gen understand_type understand_judgment ?(fail_anonymous=false) sigma env params =
- let bl = intern_context fail_anonymous sigma env params in
+let interp_context_gen understand_type understand_judgment ?(global_level=false) sigma env params =
+ let bl = intern_context global_level sigma env params in
interp_rawcontext_gen understand_type understand_judgment env bl
-let interp_context ?(fail_anonymous=false) sigma env params =
+let interp_context ?(global_level=false) sigma env params =
interp_context_gen (Default.understand_type sigma)
- (Default.understand_judgment sigma) ~fail_anonymous sigma env params
+ (Default.understand_judgment sigma) ~global_level sigma env params
-let interp_context_evars ?(fail_anonymous=false) evdref env params =
+let interp_context_evars ?(global_level=false) evdref env params =
interp_context_gen (fun env t -> Default.understand_tcc_evars evdref env IsType t)
- (Default.understand_judgment_tcc evdref) ~fail_anonymous !evdref env params
+ (Default.understand_judgment_tcc evdref) ~global_level !evdref env params
diff --git a/interp/constrintern.mli b/interp/constrintern.mli
index ebee4eda..acb13a8b 100644
--- a/interp/constrintern.mli
+++ b/interp/constrintern.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: constrintern.mli 13329 2010-07-26 11:05:39Z herbelin $ i*)
(*i*)
open Names
@@ -30,45 +30,45 @@ open Pretyping
- check all variables are bound
- make absolute the references to global objets
- resolution of symbolic notations using scopes
- - insert existential variables for implicit arguments
+ - insertion of implicit arguments
*)
-(* To interpret implicits and arg scopes of recursive variables while
- internalizing inductive types and recursive definitions, and also
+(* To interpret implicit arguments and arg scopes of recursive variables
+ while internalizing inductive types and recursive definitions, and also
projection while typing records.
the third and fourth arguments associate a list of implicit
positions and scopes to identifiers declared in the [rel_context]
of [env] *)
-type var_internalization_type = Inductive | Recursive | Method
+type var_internalization_type =
+ | Inductive of identifier list (* list of params *)
+ | Recursive
+ | Method
type var_internalization_data =
var_internalization_type *
+ (* type of the "free" variable, for coqdoc, e.g. while typing the
+ constructor of JMeq, "JMeq" behaves as a variable of type Inductive *)
identifier list *
- Impargs.implicits_list *
- scope_name option list
+ (* impargs to automatically add to the variable, e.g. for "JMeq A a B b"
+ in implicit mode, this is [A;B] and this adds (A:=A) and (B:=B) *)
+ Impargs.implicits_list * (* signature of impargs of the variable *)
+ scope_name option list (* subscopes of the args of the variable *)
(* A map of free variables to their implicit arguments and scopes *)
type internalization_env =
(identifier * var_internalization_data) list
(* Contains also a list of identifiers to automatically apply to the variables*)
-type full_internalization_env =
- identifier list * internalization_env
-
-val empty_internalization_env : full_internalization_env
+val empty_internalization_env : internalization_env
val compute_internalization_data : env -> var_internalization_type ->
types -> Impargs.manual_explicitation list -> var_internalization_data
-val set_internalization_env_params :
- internalization_env -> identifier list -> full_internalization_env
-
-val compute_full_internalization_env : env ->
- var_internalization_type ->
- identifier list -> identifier list -> types list ->
- Impargs.manual_explicitation list list -> full_internalization_env
+val compute_internalization_env : env -> var_internalization_type ->
+ identifier list -> types list -> Impargs.manual_explicitation list list ->
+ internalization_env
type manual_implicits = (explicitation * (bool * bool * bool)) list
@@ -83,7 +83,7 @@ val intern_constr : evar_map -> env -> constr_expr -> rawconstr
val intern_type : evar_map -> env -> constr_expr -> rawconstr
val intern_gen : bool -> evar_map -> env ->
- ?impls:full_internalization_env -> ?allow_patvar:bool -> ?ltacvars:ltac_sign ->
+ ?impls:internalization_env -> ?allow_patvar:bool -> ?ltacvars:ltac_sign ->
constr_expr -> rawconstr
val intern_pattern : env -> cases_pattern_expr ->
@@ -97,7 +97,7 @@ val intern_context : bool -> evar_map -> env -> local_binder list -> raw_binder
(* Main interpretation function *)
val interp_gen : typing_constraint -> evar_map -> env ->
- ?impls:full_internalization_env -> ?allow_patvar:bool -> ?ltacvars:ltac_sign ->
+ ?impls:internalization_env -> ?allow_patvar:bool -> ?ltacvars:ltac_sign ->
constr_expr -> constr
(* Particular instances *)
@@ -105,33 +105,33 @@ val interp_gen : typing_constraint -> evar_map -> env ->
val interp_constr : evar_map -> env ->
constr_expr -> constr
-val interp_type : evar_map -> env -> ?impls:full_internalization_env ->
- constr_expr -> types
+val interp_type : evar_map -> env -> ?impls:internalization_env ->
+ constr_expr -> types
val interp_open_constr : evar_map -> env -> constr_expr -> evar_map * constr
val interp_open_constr_patvar : evar_map -> env -> constr_expr -> evar_map * constr
-val interp_casted_constr : evar_map -> env -> ?impls:full_internalization_env ->
+val interp_casted_constr : evar_map -> env -> ?impls:internalization_env ->
constr_expr -> types -> constr
(* Accepting evars and giving back the manual implicits in addition. *)
val interp_casted_constr_evars_impls : ?evdref:(evar_map ref) -> ?fail_evar:bool -> env ->
- ?impls:full_internalization_env -> constr_expr -> types -> constr * manual_implicits
+ ?impls:internalization_env -> constr_expr -> types -> constr * manual_implicits
val interp_type_evars_impls : ?evdref:(evar_map ref) -> ?fail_evar:bool ->
- env -> ?impls:full_internalization_env ->
+ env -> ?impls:internalization_env ->
constr_expr -> types * manual_implicits
val interp_constr_evars_impls : ?evdref:(evar_map ref) -> ?fail_evar:bool ->
- env -> ?impls:full_internalization_env ->
+ env -> ?impls:internalization_env ->
constr_expr -> constr * manual_implicits
val interp_casted_constr_evars : evar_map ref -> env ->
- ?impls:full_internalization_env -> constr_expr -> types -> constr
+ ?impls:internalization_env -> constr_expr -> types -> constr
-val interp_type_evars : evar_map ref -> env -> ?impls:full_internalization_env ->
+val interp_type_evars : evar_map ref -> env -> ?impls:internalization_env ->
constr_expr -> types
(*s Build a judgment *)
@@ -160,13 +160,13 @@ val interp_binder_evars : evar_map ref -> env -> name -> constr_expr -> types
val interp_context_gen : (env -> rawconstr -> types) ->
(env -> rawconstr -> unsafe_judgment) ->
- ?fail_anonymous:bool ->
+ ?global_level:bool ->
evar_map -> env -> local_binder list -> (env * rel_context) * manual_implicits
-val interp_context : ?fail_anonymous:bool ->
+val interp_context : ?global_level:bool ->
evar_map -> env -> local_binder list -> (env * rel_context) * manual_implicits
-val interp_context_evars : ?fail_anonymous:bool ->
+val interp_context_evars : ?global_level:bool ->
evar_map ref -> env -> local_binder list -> (env * rel_context) * manual_implicits
(* Locating references of constructions, possibly via a syntactic definition *)
@@ -177,10 +177,15 @@ val construct_reference : named_context -> identifier -> constr
val global_reference : identifier -> constr
val global_reference_in_absolute_module : dir_path -> identifier -> constr
-(* Interprets into a abbreviatable constr *)
+(* Interprets a term as the left-hand side of a notation; the boolean
+ list is a set and this set is [true] for a variable occurring in
+ term position, [false] for a variable occurring in binding
+ position; [true;false] if in both kinds of position *)
-val interp_aconstr : ?impls:full_internalization_env ->
- identifier list * identifier list -> constr_expr -> interpretation
+val interp_aconstr : ?impls:internalization_env ->
+ (identifier * notation_var_internalization_type) list ->
+ (identifier * identifier) list -> constr_expr ->
+ (identifier * (subscopes * notation_var_internalization_type)) list * aconstr
(* Globalization leak for Grammar *)
val for_grammar : ('a -> 'b) -> 'a -> 'b
diff --git a/interp/coqlib.ml b/interp/coqlib.ml
index dbec915d..0848ccc7 100644
--- a/interp/coqlib.ml
+++ b/interp/coqlib.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: coqlib.ml 13332 2010-07-26 22:12:43Z msozeau $ *)
open Util
open Pp
@@ -182,14 +182,11 @@ type coq_bool_data = {
andb_prop : constr;
andb_true_intro : constr}
-type 'a delayed = unit -> 'a
-
let build_bool_type () =
{ andb = init_constant ["Datatypes"] "andb";
andb_prop = init_constant ["Datatypes"] "andb_prop";
andb_true_intro = init_constant ["Datatypes"] "andb_true_intro" }
-
let build_sigma_set () = anomaly "Use build_sigma_type"
let build_sigma_type () =
diff --git a/interp/coqlib.mli b/interp/coqlib.mli
index 12791139..81cc3baa 100644
--- a/interp/coqlib.mli
+++ b/interp/coqlib.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: coqlib.mli 13332 2010-07-26 22:12:43Z msozeau $ i*)
(*i*)
open Names
@@ -14,6 +14,7 @@ open Libnames
open Nametab
open Term
open Pattern
+open Util
(*i*)
(*s This module collects the global references, constructions and
@@ -86,9 +87,8 @@ val glob_jmeq : global_reference
at compile time. Therefore, we can only provide methods to build
them at runtime. This is the purpose of the [constr delayed] and
[constr_pattern delayed] types. Objects of this time needs to be
- applied to [()] to get the actual constr or pattern at runtime *)
-
-type 'a delayed = unit -> 'a
+ forced with [delayed_force] to get the actual constr or pattern
+ at runtime. *)
type coq_bool_data = {
andb : constr;
diff --git a/interp/dumpglob.ml b/interp/dumpglob.ml
index ec02146e..0a42b78b 100644
--- a/interp/dumpglob.ml
+++ b/interp/dumpglob.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: dumpglob.ml 13328 2010-07-26 11:05:30Z herbelin $ *)
(* Dump of globalization (to be used by coqdoc) *)
@@ -161,13 +161,6 @@ let dump_name (loc, n) sec ty =
| Names.Name id -> dump_definition (loc, id) sec ty
| Names.Anonymous -> ()
-let dump_local_binder b sec ty =
- if dump () then
- match b with
- | Topconstr.LocalRawAssum (nl, _, _) ->
- List.iter (fun x -> dump_name x sec ty) nl
- | Topconstr.LocalRawDef _ -> ()
-
let dump_modref loc mp ty =
if dump () then
let (dp, l) = Lib.split_modpath mp in
diff --git a/interp/dumpglob.mli b/interp/dumpglob.mli
index 2d5b1468..049bad5a 100644
--- a/interp/dumpglob.mli
+++ b/interp/dumpglob.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: dumpglob.mli 13328 2010-07-26 11:05:30Z herbelin $ *)
val open_glob_file : string -> unit
@@ -39,7 +39,6 @@ val dump_notation_location : (int * int) list -> Topconstr.notation -> (Notation
val dump_binding : Util.loc -> Names.Idset.elt -> unit
val dump_notation : Util.loc * (Topconstr.notation * Notation.notation_location) -> Topconstr.scope_name option -> bool -> unit
val dump_constraint : Topconstr.typeclass_constraint -> bool -> string -> unit
-val dump_local_binder : Topconstr.local_binder -> bool -> string -> unit
val dump_string : string -> unit
diff --git a/interp/genarg.ml b/interp/genarg.ml
index a6a042d6..310420aa 100644
--- a/interp/genarg.ml
+++ b/interp/genarg.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: genarg.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Pp
open Util
diff --git a/interp/genarg.mli b/interp/genarg.mli
index f410e1ed..9c9096bb 100644
--- a/interp/genarg.mli
+++ b/interp/genarg.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: genarg.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Util
open Names
diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml
index 73e3910a..22075654 100644
--- a/interp/implicit_quantifiers.ml
+++ b/interp/implicit_quantifiers.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: implicit_quantifiers.ml 13332 2010-07-26 22:12:43Z msozeau $ i*)
(*i*)
open Names
@@ -93,7 +93,7 @@ let is_freevar ids env x =
with _ -> not (is_global x)
with _ -> true
-(* Auxilliary functions for the inference of implicitly quantified variables. *)
+(* Auxiliary functions for the inference of implicitly quantified variables. *)
let ungeneralizable loc id =
user_err_loc (loc, "Generalization",
@@ -110,7 +110,7 @@ let free_vars_of_constr_expr c ?(bound=Idset.empty) l =
in
let rec aux bdvars l c = match c with
| CRef (Ident (loc,id)) -> found loc id bdvars l
- | CNotation (_, "{ _ : _ | _ }", (CRef (Ident (_, id)) :: _, [])) when not (Idset.mem id bdvars) ->
+ | CNotation (_, "{ _ : _ | _ }", (CRef (Ident (_, id)) :: _, [], [])) when not (Idset.mem id bdvars) ->
fold_constr_expr_with_binders (fun a l -> Idset.add a l) aux (Idset.add id bdvars) l c
| c -> fold_constr_expr_with_binders (fun a l -> Idset.add a l) aux bdvars l c
in aux bound l c
@@ -297,19 +297,28 @@ let implicit_application env ?(allow_partial=true) f ty =
CAppExpl (loc, (None, id), args), avoid
in c, avoid
-let implicits_of_rawterm l =
+let implicits_of_rawterm ?(with_products=true) l =
let rec aux i c =
- match c with
- RProd (loc, na, bk, t, b) | RLambda (loc, na, bk, t, b) ->
- let rest = aux (succ i) b in
- if bk = Implicit then
- let name =
- match na with
- Name id -> Some id
- | Anonymous -> None
- in
- (ExplByPos (i, name), (true, true, true)) :: rest
- else rest
+ let abs loc na bk t b =
+ let rest = aux (succ i) b in
+ if bk = Implicit then
+ let name =
+ match na with
+ | Name id -> Some id
+ | Anonymous -> None
+ in
+ (ExplByPos (i, name), (true, true, true)) :: rest
+ else rest
+ in
+ match c with
+ | RProd (loc, na, bk, t, b) ->
+ if with_products then abs loc na bk t b
+ else
+ (if bk = Implicit then
+ msg_warning (str "Ignoring implicit status of product binder " ++
+ pr_name na ++ str " and following binders");
+ [])
+ | RLambda (loc, na, bk, t, b) -> abs loc na bk t b
| RLetIn (loc, na, t, b) -> aux i b
| _ -> []
in aux 1 l
diff --git a/interp/implicit_quantifiers.mli b/interp/implicit_quantifiers.mli
index 315541e2..b8f6594a 100644
--- a/interp/implicit_quantifiers.mli
+++ b/interp/implicit_quantifiers.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: implicit_quantifiers.mli 13332 2010-07-26 22:12:43Z msozeau $ i*)
(*i*)
open Names
@@ -46,7 +46,7 @@ val generalizable_vars_of_rawconstr : ?bound:Idset.t -> ?allowed:Idset.t ->
val make_fresh : Names.Idset.t -> Environ.env -> identifier -> identifier
-val implicits_of_rawterm : Rawterm.rawconstr -> (Topconstr.explicitation * (bool * bool * bool)) list
+val implicits_of_rawterm : ?with_products:bool -> Rawterm.rawconstr -> (Topconstr.explicitation * (bool * bool * bool)) list
val combine_params_freevar :
Names.Idset.t -> (global_reference * bool) option * (Names.name * Term.constr option * Term.types) ->
diff --git a/interp/modintern.ml b/interp/modintern.ml
index f414adab..bed5597e 100644
--- a/interp/modintern.ml
+++ b/interp/modintern.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: modintern.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Pp
open Util
diff --git a/interp/modintern.mli b/interp/modintern.mli
index 304db5be..1cf8a5bd 100644
--- a/interp/modintern.mli
+++ b/interp/modintern.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: modintern.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Declarations
diff --git a/interp/notation.ml b/interp/notation.ml
index 4a89dbd7..fe9d8b6d 100644
--- a/interp/notation.ml
+++ b/interp/notation.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: notation.ml 13329 2010-07-26 11:05:39Z herbelin $ *)
(*i*)
open Util
@@ -209,7 +209,8 @@ let cases_pattern_key = function
let aconstr_key = function (* Rem: AApp(ARef ref,[]) stands for @ref *)
| AApp (ARef ref,args) -> RefKey(make_gr ref), Some (List.length args)
- | AList (_,_,AApp (ARef ref,args),_,_) -> RefKey (make_gr ref), Some (List.length args)
+ | AList (_,_,AApp (ARef ref,args),_,_)
+ | ABinderList (_,_,AApp (ARef ref,args),_) -> RefKey (make_gr ref), Some (List.length args)
| ARef ref -> RefKey(make_gr ref), None
| _ -> Oth, None
diff --git a/interp/notation.mli b/interp/notation.mli
index 533ccb76..72b576eb 100644
--- a/interp/notation.mli
+++ b/interp/notation.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: notation.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Util
diff --git a/interp/ppextend.ml b/interp/ppextend.ml
index 653aefed..618f8320 100644
--- a/interp/ppextend.ml
+++ b/interp/ppextend.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ *)
+(*i $Id: ppextend.ml 13329 2010-07-26 11:05:39Z herbelin $ *)
(*i*)
open Pp
@@ -53,6 +53,7 @@ let ppcmd_of_cut = function
type unparsing =
| UnpMetaVar of int * parenRelation
| UnpListMetaVar of int * parenRelation * unparsing list
+ | UnpBinderListMetaVar of int * bool * unparsing list
| UnpTerminal of string
| UnpBox of ppbox * unparsing list
| UnpCut of ppcut
diff --git a/interp/ppextend.mli b/interp/ppextend.mli
index 7b988786..6c386162 100644
--- a/interp/ppextend.mli
+++ b/interp/ppextend.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: ppextend.mli 13329 2010-07-26 11:05:39Z herbelin $ i*)
(*i*)
open Pp
@@ -43,6 +43,7 @@ val ppcmd_of_cut : ppcut -> std_ppcmds
type unparsing =
| UnpMetaVar of int * parenRelation
| UnpListMetaVar of int * parenRelation * unparsing list
+ | UnpBinderListMetaVar of int * bool * unparsing list
| UnpTerminal of string
| UnpBox of ppbox * unparsing list
| UnpCut of ppcut
diff --git a/interp/reserve.ml b/interp/reserve.ml
index 7f9b35a6..2225bb6e 100644
--- a/interp/reserve.ml
+++ b/interp/reserve.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: reserve.ml 13323 2010-07-24 15:57:30Z herbelin $ i*)
(* Reserved names *)
diff --git a/interp/reserve.mli b/interp/reserve.mli
index e1853a74..613ba830 100644
--- a/interp/reserve.mli
+++ b/interp/reserve.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: reserve.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Util
open Names
diff --git a/interp/syntax_def.ml b/interp/syntax_def.ml
index e6bb468e..77b34d4f 100644
--- a/interp/syntax_def.ml
+++ b/interp/syntax_def.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: syntax_def.ml 13329 2010-07-26 11:05:39Z herbelin $ *)
open Util
open Pp
@@ -76,8 +76,8 @@ type syndef_interpretation = (identifier * subscopes) list * aconstr
(* Coercions to the general format of notation that also supports
variables bound to list of expressions *)
-let in_pat (ids,ac) = ((ids,[]),ac)
-let out_pat ((ids,idsl),ac) = assert (idsl=[]); (ids,ac)
+let in_pat (ids,ac) = (List.map (fun (id,sc) -> (id,(sc,NtnTypeConstr))) ids,ac)
+let out_pat (ids,ac) = (List.map (fun (id,(sc,typ)) -> (id,sc)) ids,ac)
let declare_syntactic_definition local id onlyparse pat =
let _ = add_leaf id (in_syntax_constant (local,in_pat pat,onlyparse)) in ()
diff --git a/interp/syntax_def.mli b/interp/syntax_def.mli
index 49e74b65..33d4c5d3 100644
--- a/interp/syntax_def.mli
+++ b/interp/syntax_def.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: syntax_def.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Util
diff --git a/interp/topconstr.ml b/interp/topconstr.ml
index 5911f667..b8a90088 100644
--- a/interp/topconstr.ml
+++ b/interp/topconstr.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: topconstr.ml 13357 2010-07-29 22:59:55Z herbelin $ *)
(*i*)
open Pp
@@ -36,6 +36,7 @@ type aconstr =
(* Part only in rawconstr *)
| ALambda of name * aconstr * aconstr
| AProd of name * aconstr * aconstr
+ | ABinderList of identifier * identifier * aconstr * aconstr
| ALetIn of name * aconstr * aconstr
| ACases of case_style * aconstr option *
(aconstr * (name * (inductive * int * name list) option)) list *
@@ -50,6 +51,21 @@ type aconstr =
| APatVar of patvar
| ACast of aconstr * aconstr cast_type
+type scope_name = string
+
+type tmp_scope_name = scope_name
+
+type subscopes = tmp_scope_name option * scope_name list
+
+type notation_var_instance_type =
+ | NtnTypeConstr | NtnTypeConstrList | NtnTypeBinderList
+
+type notation_var_internalization_type =
+ | NtnInternTypeConstr | NtnInternTypeBinder | NtnInternTypeIdent
+
+type interpretation =
+ (identifier * (subscopes * notation_var_instance_type)) list * aconstr
+
(**********************************************************************)
(* Re-interpret a notation as a rawconstr, taking care of binders *)
@@ -69,6 +85,16 @@ let rec cases_pattern_fold_map loc g e = function
let rec subst_rawvars l = function
| RVar (_,id) as r -> (try List.assoc id l with Not_found -> r)
+ | RProd (loc,Name id,bk,t,c) ->
+ let id =
+ try match List.assoc id l with RVar(_,id') -> id' | _ -> id
+ with Not_found -> id in
+ RProd (loc,Name id,bk,subst_rawvars l t,subst_rawvars l c)
+ | RLambda (loc,Name id,bk,t,c) ->
+ let id =
+ try match List.assoc id l with RVar(_,id') -> id' | _ -> id
+ with Not_found -> id in
+ RLambda (loc,Name id,bk,subst_rawvars l t,subst_rawvars l c)
| r -> map_rawconstr (subst_rawvars l) r (* assume: id is not binding *)
let ldots_var = id_of_string ".."
@@ -82,6 +108,12 @@ let rawconstr_of_aconstr_with_binders loc g f e = function
let inner = RApp (loc,RVar (loc,ldots_var),[subst_rawvars innerl it]) in
let outerl = (ldots_var,inner)::(if swap then [x,RVar(loc,y)] else []) in
subst_rawvars outerl it
+ | ABinderList (x,y,iter,tail) ->
+ let t = f e tail in let it = f e iter in
+ let innerl = [(ldots_var,t);(x,RVar(loc,y))] in
+ let inner = RApp (loc,RVar (loc,ldots_var),[subst_rawvars innerl it]) in
+ let outerl = [(ldots_var,inner)] in
+ subst_rawvars outerl it
| ALambda (na,ty,c) ->
let e,na = g e na in RLambda (loc,na,Explicit,f e ty,f e c)
| AProd (na,ty,c) ->
@@ -134,72 +166,135 @@ let rec rawconstr_of_aconstr loc x =
(****************************************************************************)
(* Translating a rawconstr into a notation, interpreting recursive patterns *)
-let add_name r = function
- | Anonymous -> ()
- | Name id -> r := id :: !r
+let add_id r id = r := (id :: pi1 !r, pi2 !r, pi3 !r)
+let add_name r = function Anonymous -> () | Name id -> add_id r id
-let has_ldots =
- List.exists
- (function RApp (_,RVar(_,v),_) when v = ldots_var -> true | _ -> false)
-
-let compare_rawconstr f t1 t2 = match t1,t2 with
- | RRef (_,r1), RRef (_,r2) -> eq_gr r1 r2
- | RVar (_,v1), RVar (_,v2) -> v1 = v2
- | RApp (_,f1,l1), RApp (_,f2,l2) -> f f1 f2 & List.for_all2 f l1 l2
- | RLambda (_,na1,bk1,ty1,c1), RLambda (_,na2,bk2,ty2,c2) when na1 = na2 && bk1 = bk2 ->
- f ty1 ty2 & f c1 c2
+let split_at_recursive_part c =
+ let sub = ref None in
+ let rec aux = function
+ | RApp (loc0,RVar(loc,v),c::l) when v = ldots_var ->
+ if !sub <> None then
+ (* Not narrowed enough to find only one recursive part *)
+ raise Not_found
+ else
+ (sub := Some c;
+ if l = [] then RVar (loc,ldots_var)
+ else RApp (loc0,RVar (loc,ldots_var),l))
+ | c -> map_rawconstr aux c in
+ let outer_iterator = aux c in
+ match !sub with
+ | None -> (* No recursive pattern found *) raise Not_found
+ | Some c ->
+ match outer_iterator with
+ | RVar (_,v) when v = ldots_var -> (* Not enough context *) raise Not_found
+ | _ -> outer_iterator, c
+
+let on_true_do b f c = if b then (f c; b) else b
+
+let compare_rawconstr f add t1 t2 = match t1,t2 with
+ | RRef (_,r1), RRef (_,r2) -> eq_gr r1 r2
+ | RVar (_,v1), RVar (_,v2) -> on_true_do (v1 = v2) add (Name v1)
+ | RApp (_,f1,l1), RApp (_,f2,l2) -> f f1 f2 & list_for_all2eq f l1 l2
+ | RLambda (_,na1,bk1,ty1,c1), RLambda (_,na2,bk2,ty2,c2) when na1 = na2 && bk1 = bk2 -> on_true_do (f ty1 ty2 & f c1 c2) add na1
| RProd (_,na1,bk1,ty1,c1), RProd (_,na2,bk2,ty2,c2) when na1 = na2 && bk1 = bk2 ->
- f ty1 ty2 & f c1 c2
+ on_true_do (f ty1 ty2 & f c1 c2) add na1
| RHole _, RHole _ -> true
| RSort (_,s1), RSort (_,s2) -> s1 = s2
- | (RLetIn _ | RCases _ | RRec _ | RDynamic _
+ | RLetIn (_,na1,b1,c1), RLetIn (_,na2,b2,c2) when na1 = na2 ->
+ on_true_do (f b1 b2 & f c1 c2) add na1
+ | (RCases _ | RRec _ | RDynamic _
| RPatVar _ | REvar _ | RLetTuple _ | RIf _ | RCast _),_
- | _,(RLetIn _ | RCases _ | RRec _ | RDynamic _
+ | _,(RCases _ | RRec _ | RDynamic _
| RPatVar _ | REvar _ | RLetTuple _ | RIf _ | RCast _)
-> error "Unsupported construction in recursive notations."
- | (RRef _ | RVar _ | RApp _ | RLambda _ | RProd _ | RHole _ | RSort _), _
+ | (RRef _ | RVar _ | RApp _ | RLambda _ | RProd _
+ | RHole _ | RSort _ | RLetIn _), _
-> false
-let rec eq_rawconstr t1 t2 = compare_rawconstr eq_rawconstr t1 t2
+let rec eq_rawconstr t1 t2 = compare_rawconstr eq_rawconstr (fun _ -> ()) t1 t2
+
+let subtract_loc loc1 loc2 = make_loc (fst (unloc loc1),fst (unloc loc2)-1)
-let discriminate_patterns foundvars nl l1 l2 =
+let check_is_hole id = function RHole _ -> () | t ->
+ user_err_loc (loc_of_rawconstr t,"",
+ strbrk "In recursive notation with binders, " ++ pr_id id ++
+ strbrk " is expected to come without type.")
+
+let compare_recursive_parts found f (iterator,subc) =
let diff = ref None in
- let rec aux n c1 c2 = match c1,c2 with
- | RVar (_,v1), RVar (_,v2) when v1<>v2 ->
- if !diff = None then (diff := Some (v1,v2,(n>=nl)); true)
- else
- !diff = Some (v1,v2,(n>=nl)) or !diff = Some (v2,v1,(n<nl))
- or (error
- "Both ends of the recursive pattern differ in more than one place")
- | _ -> compare_rawconstr (aux (n+1)) c1 c2 in
- let l = list_map2_i aux 0 l1 l2 in
- if not (List.for_all ((=) true) l) then
- error "Both ends of the recursive pattern differ.";
- match !diff with
- | None -> error "Both ends of the recursive pattern are the same."
- | Some (x,y,_ as discr) ->
- List.iter (fun id ->
- if List.mem id !foundvars
- then errorlabstrm "" (strbrk "Variables used in the recursive part of a pattern are not allowed to occur outside of the recursive part.");
- foundvars := id::!foundvars) [x;y];
- discr
+ let terminator = ref None in
+ let rec aux c1 c2 = match c1,c2 with
+ | RVar(_,v), term when v = ldots_var ->
+ (* We found the pattern *)
+ assert (!terminator = None); terminator := Some term;
+ true
+ | RApp (_,RVar(_,v),l1), RApp (_,term,l2) when v = ldots_var ->
+ (* We found the pattern, but there are extra arguments *)
+ (* (this allows e.g. alternative (recursive) notation of application) *)
+ assert (!terminator = None); terminator := Some term;
+ list_for_all2eq aux l1 l2
+ | RVar (_,x), RVar (_,y) when x<>y ->
+ (* We found the position where it differs *)
+ let lassoc = (!terminator <> None) in
+ let x,y = if lassoc then y,x else x,y in
+ !diff = None && (diff := Some (x,y,Some lassoc); true)
+ | RLambda (_,Name x,_,t_x,c), RLambda (_,Name y,_,t_y,term)
+ | RProd (_,Name x,_,t_x,c), RProd (_,Name y,_,t_y,term) ->
+ (* We found a binding position where it differs *)
+ check_is_hole y t_x;
+ check_is_hole y t_y;
+ !diff = None && (diff := Some (x,y,None); aux c term)
+ | _ ->
+ compare_rawconstr aux (add_name found) c1 c2 in
+ if aux iterator subc then
+ match !diff with
+ | None ->
+ let loc1 = loc_of_rawconstr iterator in
+ let loc2 = loc_of_rawconstr (Option.get !terminator) in
+ (* Here, we would need a loc made of several parts ... *)
+ user_err_loc (subtract_loc loc1 loc2,"",
+ str "Both ends of the recursive pattern are the same.")
+ | Some (x,y,Some lassoc) ->
+ let newfound = (pi1 !found, (x,y) :: pi2 !found, pi3 !found) in
+ let iterator =
+ f (if lassoc then subst_rawvars [y,RVar(dummy_loc,x)] iterator
+ else iterator) in
+ (* found have been collected by compare_constr *)
+ found := newfound;
+ AList (x,y,iterator,f (Option.get !terminator),lassoc)
+ | Some (x,y,None) ->
+ let newfound = (pi1 !found, pi2 !found, (x,y) :: pi3 !found) in
+ let iterator = f iterator in
+ (* found have been collected by compare_constr *)
+ found := newfound;
+ ABinderList (x,y,iterator,f (Option.get !terminator))
+ else
+ raise Not_found
let aconstr_and_vars_of_rawconstr a =
- let found = ref [] in
- let rec aux = function
- | RVar (_,id) -> found := id::!found; AVar id
- | RApp (_,f,args) when has_ldots args -> make_aconstr_list f args
- | RApp (_,RVar (_,f),[RApp (_,t,[c]);d]) when f = ldots_var ->
- (* Special case for alternative (recursive) notation of application *)
- let x,y,lassoc = discriminate_patterns found 0 [c] [d] in
- found := ldots_var :: !found; assert lassoc;
- AList (x,y,AApp (AVar ldots_var,[AVar x]),aux t,lassoc)
+ let found = ref ([],[],[]) in
+ let rec aux c =
+ let keepfound = !found in
+ (* n^2 complexity but small and done only once per notation *)
+ try compare_recursive_parts found aux' (split_at_recursive_part c)
+ with Not_found ->
+ found := keepfound;
+ match c with
+ | RApp (_,RVar (loc,f),[c]) when f = ldots_var ->
+ (* Fall on the second part of the recursive pattern w/o having
+ found the first part *)
+ user_err_loc (loc,"",
+ str "Cannot find where the recursive pattern starts.")
+ | c ->
+ aux' c
+ and aux' = function
+ | RVar (_,id) -> add_id found id; AVar id
| RApp (_,g,args) -> AApp (aux g, List.map aux args)
| RLambda (_,na,bk,ty,c) -> add_name found na; ALambda (na,aux ty,aux c)
| RProd (_,na,bk,ty,c) -> add_name found na; AProd (na,aux ty,aux c)
| RLetIn (_,na,b,c) -> add_name found na; ALetIn (na,aux b,aux c)
| RCases (_,sty,rtntypopt,tml,eqnl) ->
- let f (_,idl,pat,rhs) = found := idl@(!found); (pat,aux rhs) in
+ let f (_,idl,pat,rhs) = List.iter (add_id found) idl; (pat,aux rhs) in
ACases (sty,Option.map aux rtntypopt,
List.map (fun (tm,(na,x)) ->
add_name found na;
@@ -215,7 +310,7 @@ let aconstr_and_vars_of_rawconstr a =
add_name found na;
AIf (aux c,(na,Option.map aux po),aux b1,aux b2)
| RRec (_,fk,idl,dll,tl,bl) ->
- Array.iter (fun id -> found := id::!found) idl;
+ Array.iter (add_id found) idl;
let dll = Array.map (List.map (fun (na,bk,oc,b) ->
if bk <> Explicit then
error "Binders marked as implicit not allowed in notations.";
@@ -231,51 +326,61 @@ let aconstr_and_vars_of_rawconstr a =
| RDynamic _ | REvar _ ->
error "Existential variables not allowed in notations."
- (* Recognizing recursive notations *)
- and terminator_of_pat f1 ll1 lr1 = function
- | RApp (loc,f2,l2) ->
- if not (eq_rawconstr f1 f2) then errorlabstrm ""
- (strbrk "Cannot recognize the same head to both ends of the recursive pattern.");
- let nl = List.length ll1 in
- let nr = List.length lr1 in
- if List.length l2 <> nl + nr + 1 then
- error "Both ends of the recursive pattern have different lengths.";
- let ll2,l2' = list_chop nl l2 in
- let t = List.hd l2' and lr2 = List.tl l2' in
- let x,y,order = discriminate_patterns found nl (ll1@lr1) (ll2@lr2) in
- let iter =
- if order then RApp (loc,f2,ll2@RVar (loc,ldots_var)::lr2)
- else RApp (loc,f1,ll1@RVar (loc,ldots_var)::lr1) in
- (if order then y else x),(if order then x else y), aux iter, aux t, order
- | _ -> error "One end of the recursive pattern is not an application."
-
- and make_aconstr_list f args =
- let rec find_patterns acc = function
- | RApp(_,RVar (_,a),[c]) :: l when a = ldots_var ->
- (* We've found the recursive part *)
- let x,y,iter,term,lassoc = terminator_of_pat f (List.rev acc) l c in
- AList (x,y,iter,term,lassoc)
- | a::l -> find_patterns (a::acc) l
- | [] -> error "Ill-formed recursive notation."
- in find_patterns [] args
-
in
let t = aux a in
(* Side effect *)
t, !found
-let aconstr_of_rawconstr vars a =
- let a,foundvars = aconstr_and_vars_of_rawconstr a in
- let check_type x =
- if not (List.mem x foundvars) then
- error ((string_of_id x)^" is unbound in the right-hand-side.") in
- List.iter check_type vars;
+let rec list_rev_mem_assoc x = function
+ | [] -> false
+ | (_,x')::l -> x = x' || list_rev_mem_assoc x l
+
+let check_variables vars recvars (found,foundrec,foundrecbinding) =
+ let useless_vars = List.map snd recvars in
+ let vars = List.filter (fun (y,_) -> not (List.mem y useless_vars)) vars in
+ let check_recvar x =
+ if List.mem x found then
+ errorlabstrm "" (pr_id x ++
+ strbrk " should only be used in the recursive part of a pattern.") in
+ List.iter (fun (x,y) -> check_recvar x; check_recvar y)
+ (foundrec@foundrecbinding);
+ let check_bound x =
+ if not (List.mem x found) then
+ if List.mem_assoc x foundrec or List.mem_assoc x foundrecbinding
+ or list_rev_mem_assoc x foundrec or list_rev_mem_assoc x foundrecbinding
+ then
+ error ((string_of_id x)^" should not be bound in a recursive pattern of the right-hand side.")
+ else
+ error ((string_of_id x)^" is unbound in the right-hand side.") in
+ let check_pair s x y where =
+ if not (List.mem (x,y) where) then
+ errorlabstrm "" (strbrk "in the right-hand side, " ++ pr_id x ++
+ str " and " ++ pr_id y ++ strbrk " should appear in " ++ str s ++
+ str " position as part of a recursive pattern.") in
+ let check_type (x,typ) =
+ match typ with
+ | NtnInternTypeConstr ->
+ begin
+ try check_pair "term" x (List.assoc x recvars) foundrec
+ with Not_found -> check_bound x
+ end
+ | NtnInternTypeBinder ->
+ begin
+ try check_pair "binding" x (List.assoc x recvars) foundrecbinding
+ with Not_found -> check_bound x
+ end
+ | NtnInternTypeIdent -> check_bound x in
+ List.iter check_type vars
+
+let aconstr_of_rawconstr vars recvars a =
+ let a,found = aconstr_and_vars_of_rawconstr a in
+ check_variables vars recvars found;
a
(* Substitution of kernel names, avoiding a list of bound identifiers *)
let aconstr_of_constr avoiding t =
- aconstr_of_rawconstr [] (Detyping.detype false avoiding [] t)
+ aconstr_of_rawconstr [] [] (Detyping.detype false avoiding [] t)
let rec subst_pat subst pat =
match pat with
@@ -319,6 +424,12 @@ let rec subst_aconstr subst bound raw =
if r1' == r1 && r2' == r2 then raw else
AProd (n,r1',r2')
+ | ABinderList (id1,id2,r1,r2) ->
+ let r1' = subst_aconstr subst bound r1
+ and r2' = subst_aconstr subst bound r2 in
+ if r1' == r1 && r2' == r2 then raw else
+ ABinderList (id1,id2,r1',r2')
+
| ALetIn (n,r1,r2) ->
let r1' = subst_aconstr subst bound r1
and r2' = subst_aconstr subst bound r2 in
@@ -396,7 +507,7 @@ let rec subst_aconstr subst bound raw =
ACast (r1',CastCoerce)
let subst_interpretation subst (metas,pat) =
- let bound = List.map fst (fst metas @ snd metas) in
+ let bound = List.map fst metas in
(metas,subst_aconstr subst bound pat)
let encode_list_value l = RApp (dummy_loc,RVar (dummy_loc,ldots_var),l)
@@ -434,7 +545,7 @@ let rec alpha_var id1 id2 = function
let alpha_eq_val (x,y) = x = y
-let bind_env alp (sigma,sigmalist as fullsigma) var v =
+let bind_env alp (sigma,sigmalist,sigmabinders as fullsigma) var v =
try
let vvar = List.assoc var sigma in
if alpha_eq_val (v,vvar) then fullsigma
@@ -443,7 +554,10 @@ let bind_env alp (sigma,sigmalist as fullsigma) var v =
(* Check that no capture of binding variables occur *)
if List.exists (fun (id,_) ->occur_rawconstr id v) alp then raise No_match;
(* TODO: handle the case of multiple occs in different scopes *)
- ((var,v)::sigma,sigmalist)
+ ((var,v)::sigma,sigmalist,sigmabinders)
+
+let bind_binder (sigma,sigmalist,sigmabinders) x bl =
+ (sigma,sigmalist,(x,List.rev bl)::sigmabinders)
let match_fix_kind fk1 fk2 =
match (fk1,fk2) with
@@ -458,13 +572,9 @@ let match_opt f sigma t1 t2 = match (t1,t2) with
| Some t1, Some t2 -> f sigma t1 t2
| _ -> raise No_match
-let rawconstr_of_name = function
- | Anonymous -> RHole (dummy_loc,Evd.InternalHole)
- | Name id -> RVar (dummy_loc,id)
-
let match_names metas (alp,sigma) na1 na2 = match (na1,na2) with
- | (na,Name id2) when List.mem id2 metas ->
- alp, bind_env alp sigma id2 (rawconstr_of_name na)
+ | (Name id1,Name id2) when List.mem id2 (fst metas) ->
+ alp, bind_env alp sigma id2 (RVar (dummy_loc,id1))
| (Name id1,Name id2) -> (id1,id2)::alp,sigma
| (Anonymous,Anonymous) -> alp,sigma
| _ -> raise No_match
@@ -482,33 +592,80 @@ let adjust_application_n n loc f l =
let l1,l2 = list_chop (List.length l - n) l in
if l1 = [] then f,l else RApp (loc,f,l1), l2
-let match_alist match_fun metas sigma l1 l2 x iter termin lassoc =
- (* match the iterator at least once *)
- let sigmavar,sigmalist =
- List.fold_left2 (match_fun (ldots_var::metas)) sigma l1 l2 in
- (* Recover the recursive position *)
- let rest = List.assoc ldots_var sigmavar in
- (* Recover the first element *)
- let t1 = List.assoc x sigmavar in
- let sigmavar = List.remove_assoc x (List.remove_assoc ldots_var sigmavar) in
- (* try to find the remaining elements or the terminator *)
- let rec match_alist_tail metas sigma acc rest =
+let glue_letin_with_decls = true
+
+let rec match_iterated_binders islambda decls = function
+ | RLambda (_,na,bk,t,b) when islambda ->
+ match_iterated_binders islambda ((na,bk,None,t)::decls) b
+ | RProd (_,(Name _ as na),bk,t,b) when not islambda ->
+ match_iterated_binders islambda ((na,bk,None,t)::decls) b
+ | RLetIn (loc,na,c,b) when glue_letin_with_decls ->
+ match_iterated_binders islambda
+ ((na,Explicit (*?*), Some c,RHole(loc,Evd.BinderType na))::decls) b
+ | b -> (decls,b)
+
+let remove_sigma x (sigmavar,sigmalist,sigmabinders) =
+ (List.remove_assoc x sigmavar,sigmalist,sigmabinders)
+
+let rec match_abinderlist_with_app match_fun metas sigma rest x iter termin =
+ let rec aux sigma acc rest =
try
- let sigmavar,sigmalist = match_fun (ldots_var::metas) sigma rest iter in
- let rest = List.assoc ldots_var sigmavar in
- let t = List.assoc x sigmavar in
- let sigmavar =
- List.remove_assoc x (List.remove_assoc ldots_var sigmavar) in
- match_alist_tail metas (sigmavar,sigmalist) (t::acc) rest
- with No_match ->
- List.rev acc, match_fun metas (sigmavar,sigmalist) rest termin in
- let tl,(sigmavar,sigmalist) = match_alist_tail metas sigma [t1] rest in
- (sigmavar, (x,if lassoc then List.rev tl else tl)::sigmalist)
-
-let rec match_ alp metas sigma a1 a2 = match (a1,a2) with
- | r1, AVar id2 when List.mem id2 metas -> bind_env alp sigma id2 r1
+ let sigma = match_fun (ldots_var::fst metas,snd metas) sigma rest iter in
+ let rest = List.assoc ldots_var (pi1 sigma) in
+ let b = match List.assoc x (pi3 sigma) with [b] -> b | _ ->assert false in
+ let sigma = remove_sigma x (remove_sigma ldots_var sigma) in
+ aux sigma (b::acc) rest
+ with No_match when acc <> [] ->
+ acc, match_fun metas sigma rest termin in
+ let bl,sigma = aux sigma [] rest in
+ bind_binder sigma x bl
+
+let match_alist match_fun metas sigma rest x iter termin lassoc =
+ let rec aux sigma acc rest =
+ try
+ let sigma = match_fun (ldots_var::fst metas,snd metas) sigma rest iter in
+ let rest = List.assoc ldots_var (pi1 sigma) in
+ let t = List.assoc x (pi1 sigma) in
+ let sigma = remove_sigma x (remove_sigma ldots_var sigma) in
+ aux sigma (t::acc) rest
+ with No_match when acc <> [] ->
+ acc, match_fun metas sigma rest termin in
+ let l,sigma = aux sigma [] rest in
+ (pi1 sigma, (x,if lassoc then l else List.rev l)::pi2 sigma, pi3 sigma)
+
+let rec match_ alp (tmetas,blmetas as metas) sigma a1 a2 = match (a1,a2) with
+
+ (* Matching notation variable *)
+ | r1, AVar id2 when List.mem id2 tmetas -> bind_env alp sigma id2 r1
+
+ (* Matching recursive notations for terms *)
+ | r1, AList (x,_,iter,termin,lassoc) ->
+ match_alist (match_ alp) metas sigma r1 x iter termin lassoc
+
+ (* Matching recursive notations for binders: ad hoc cases supporting let-in *)
+ | RLambda (_,na1,bk,t1,b1), ABinderList (x,_,ALambda (Name id2,_,b2),termin)->
+ let (decls,b) = match_iterated_binders true [(na1,bk,None,t1)] b1 in
+ (* TODO: address the possibility that termin is a Lambda itself *)
+ match_ alp metas (bind_binder sigma x decls) b termin
+ | RProd (_,na1,bk,t1,b1), ABinderList (x,_,AProd (Name id2,_,b2),termin)
+ when na1 <> Anonymous ->
+ let (decls,b) = match_iterated_binders false [(na1,bk,None,t1)] b1 in
+ (* TODO: address the possibility that termin is a Prod itself *)
+ match_ alp metas (bind_binder sigma x decls) b termin
+ (* Matching recursive notations for binders: general case *)
+ | r, ABinderList (x,_,iter,termin) ->
+ match_abinderlist_with_app (match_ alp) metas sigma r x iter termin
+
+ (* Matching individual binders as part of a recursive pattern *)
+ | RLambda (_,na,bk,t,b1), ALambda (Name id,_,b2) when List.mem id blmetas ->
+ match_ alp metas (bind_binder sigma id [(na,bk,None,t)]) b1 b2
+ | RProd (_,na,bk,t,b1), AProd (Name id,_,b2)
+ when List.mem id blmetas & na <> Anonymous ->
+ match_ alp metas (bind_binder sigma id [(na,bk,None,t)]) b1 b2
+
+ (* Matching compositionally *)
| RVar (_,id1), AVar id2 when alpha_var id1 id2 alp -> sigma
- | RRef (_,r1), ARef r2 when (eq_gr r1 r2) -> sigma
+ | RRef (_,r1), ARef r2 when (eq_gr r1 r2) -> sigma
| RPatVar (_,(_,n1)), APatVar n2 when n1=n2 -> sigma
| RApp (loc,f1,l1), AApp (f2,l2) ->
let n1 = List.length l1 and n2 = List.length l2 in
@@ -519,11 +676,6 @@ let rec match_ alp metas sigma a1 a2 = match (a1,a2) with
let l11,l12 = list_chop (n1-n2) l1 in RApp (loc,f1,l11),l12, f2,l2
else f1,l1, f2, l2 in
List.fold_left2 (match_ alp metas) (match_ alp metas sigma f1 f2) l1 l2
- | RApp (loc,f1,l1), AList (x,_,(AApp (f2,l2) as iter),termin,lassoc)
- when List.length l1 >= List.length l2 ->
- let f1,l1 = adjust_application_n (List.length l2) loc f1 l1 in
- match_alist (match_ alp)
- metas sigma (f1::l1) (f2::l2) x iter termin lassoc
| RLambda (_,na1,_,t1,b1), ALambda (na2,t2,b2) ->
match_binders alp metas na1 na2 (match_ alp metas sigma t1 t2) b1 b2
| RProd (_,na1,_,t1,b1), AProd (na2,t2,b2) ->
@@ -588,38 +740,36 @@ and match_equations alp metas sigma (_,_,patl1,rhs1) (patl2,rhs2) =
(alp,sigma) patl1 patl2 in
match_ alp metas sigma rhs1 rhs2
-type scope_name = string
-
-type tmp_scope_name = scope_name
-
-type subscopes = tmp_scope_name option * scope_name list
-
-type interpretation =
- (* regular vars of notation / recursive parts of notation / body *)
- ((identifier * subscopes) list * (identifier * subscopes) list) * aconstr
-
-let match_aconstr c ((metas_scl,metaslist_scl),pat) =
- let vars = List.map fst metas_scl @ List.map fst metaslist_scl in
- let subst,substlist = match_ [] vars ([],[]) c pat in
+let match_aconstr c (metas,pat) =
+ let vars = list_split_by (fun (_,(_,x)) -> x <> NtnTypeBinderList) metas in
+ let vars = (List.map fst (fst vars), List.map fst (snd vars)) in
+ let terms,termlists,binders = match_ [] vars ([],[],[]) c pat in
(* Reorder canonically the substitution *)
let find x =
- try List.assoc x subst
+ try List.assoc x terms
with Not_found ->
(* Happens for binders bound to Anonymous *)
(* Find a better way to propagate Anonymous... *)
RVar (dummy_loc,x) in
- List.map (fun (x,scl) -> (find x,scl)) metas_scl,
- List.map (fun (x,scl) -> (List.assoc x substlist,scl)) metaslist_scl
+ List.fold_right (fun (x,(scl,typ)) (terms',termlists',binders') ->
+ match typ with
+ | NtnTypeConstr ->
+ ((find x, scl)::terms',termlists',binders')
+ | NtnTypeConstrList ->
+ (terms',(List.assoc x termlists,scl)::termlists',binders')
+ | NtnTypeBinderList ->
+ (terms',termlists',(List.assoc x binders,scl)::binders'))
+ metas ([],[],[])
(* Matching cases pattern *)
-let bind_env_cases_pattern (sigma,sigmalist as fullsigma) var v =
+let bind_env_cases_pattern (sigma,sigmalist,x as fullsigma) var v =
try
let vvar = List.assoc var sigma in
if v=vvar then fullsigma else raise No_match
with Not_found ->
(* TODO: handle the case of multiple occs in different scopes *)
- (var,v)::sigma,sigmalist
+ (var,v)::sigma,sigmalist,x
let rec match_cases_pattern metas sigma a1 a2 = match (a1,a2) with
| r1, AVar id2 when List.mem id2 metas -> bind_env_cases_pattern sigma id2 r1
@@ -639,26 +789,21 @@ let rec match_cases_pattern metas sigma a1 a2 = match (a1,a2) with
(* All parameters must be _ *)
List.iter (function AHole _ -> () | _ -> raise No_match) p2;
List.fold_left2 (match_cases_pattern metas) sigma args1 args2
- | PatCstr (loc,(ind,_ as r1),args1,_),
- AList (x,_,(AApp (ARef (ConstructRef r2),l2) as iter),termin,lassoc)
- when r1 = r2 ->
- let nparams = Inductive.inductive_params (Global.lookup_inductive ind) in
- assert (List.length args1 + nparams = List.length l2);
- let (p2,args2) = list_chop nparams l2 in
- List.iter (function AHole _ -> () | _ -> raise No_match) p2;
- match_alist match_cases_pattern
- metas sigma args1 args2 x iter termin lassoc
+ | r1, AList (x,_,iter,termin,lassoc) ->
+ match_alist (fun (metas,_) -> match_cases_pattern metas)
+ (metas,[]) (pi1 sigma,pi2 sigma,()) r1 x iter termin lassoc
| _ -> raise No_match
-let match_aconstr_cases_pattern c ((metas_scl,metaslist_scl),pat) =
- let vars = List.map fst metas_scl @ List.map fst metaslist_scl in
- let subst,substlist = match_cases_pattern vars ([],[]) c pat in
+let match_aconstr_cases_pattern c (metas,pat) =
+ let vars = List.map fst metas in
+ let terms,termlists,() = match_cases_pattern vars ([],[],()) c pat in
(* Reorder canonically the substitution *)
- let find x subst =
- try List.assoc x subst
- with Not_found -> anomaly "match_aconstr_cases_pattern" in
- List.map (fun (x,scl) -> (find x subst,scl)) metas_scl,
- List.map (fun (x,scl) -> (find x substlist,scl)) metaslist_scl
+ List.fold_right (fun (x,(scl,typ)) (terms',termlists') ->
+ match typ with
+ | NtnTypeConstr -> ((List.assoc x terms, scl)::terms',termlists')
+ | NtnTypeConstrList -> (terms',(List.assoc x termlists,scl)::termlists')
+ | NtnTypeBinderList -> assert false)
+ metas ([],[])
(**********************************************************************)
(*s Concrete syntax for terms *)
@@ -675,19 +820,20 @@ type proj_flag = int option (* [Some n] = proj of the n-th visible argument *)
type prim_token = Numeral of Bigint.bigint | String of string
-type 'a notation_substitution =
- 'a list * (* for recursive notations: *) 'a list list
-
type cases_pattern_expr =
| CPatAlias of loc * cases_pattern_expr * identifier
| CPatCstr of loc * reference * cases_pattern_expr list
| CPatAtom of loc * reference option
| CPatOr of loc * cases_pattern_expr list
- | CPatNotation of loc * notation * cases_pattern_expr notation_substitution
+ | CPatNotation of loc * notation * cases_pattern_notation_substitution
| CPatPrim of loc * prim_token
- | CPatRecord of loc * (reference * cases_pattern_expr) list
+ | CPatRecord of Util.loc * (reference * cases_pattern_expr) list
| CPatDelimiters of loc * string * cases_pattern_expr
+and cases_pattern_notation_substitution =
+ cases_pattern_expr list * (** for constr subterms *)
+ cases_pattern_expr list list (** for recursive notations *)
+
type constr_expr =
| CRef of reference
| CFix of loc * identifier located * fix_expr list
@@ -701,18 +847,18 @@ type constr_expr =
(constr_expr * explicitation located option) list
| CRecord of loc * constr_expr option * (reference * constr_expr) list
| CCases of loc * case_style * constr_expr option *
- (constr_expr * (name option * constr_expr option)) list *
+ (constr_expr * (name located option * constr_expr option)) list *
(loc * cases_pattern_expr list located list * constr_expr) list
- | CLetTuple of loc * name list * (name option * constr_expr option) *
+ | CLetTuple of loc * name located list * (name located option * constr_expr option) *
constr_expr * constr_expr
- | CIf of loc * constr_expr * (name option * constr_expr option)
+ | CIf of loc * constr_expr * (name located option * constr_expr option)
* constr_expr * constr_expr
| CHole of loc * Evd.hole_kind option
| CPatVar of loc * (bool * patvar)
| CEvar of loc * existential_key * constr_expr list option
| CSort of loc * rawsort
| CCast of loc * constr_expr * constr_expr cast_type
- | CNotation of loc * notation * constr_expr notation_substitution
+ | CNotation of loc * notation * constr_notation_substitution
| CGeneralization of loc * binding_kind * abstraction_kind option * constr_expr
| CPrim of loc * prim_token
| CDelimiters of loc * string * constr_expr
@@ -721,14 +867,6 @@ type constr_expr =
and fix_expr =
identifier located * (identifier located option * recursion_order_expr) * local_binder list * constr_expr * constr_expr
-and local_binder =
- | LocalRawDef of name located * constr_expr
- | LocalRawAssum of name located list * binder_kind * constr_expr
-
-and typeclass_constraint = name located * binding_kind * constr_expr
-
-and typeclass_context = typeclass_constraint list
-
and cofix_expr =
identifier located * local_binder list * constr_expr * constr_expr
@@ -737,6 +875,19 @@ and recursion_order_expr =
| CWfRec of constr_expr
| CMeasureRec of constr_expr * constr_expr option (* measure, relation *)
+and local_binder =
+ | LocalRawDef of name located * constr_expr
+ | LocalRawAssum of name located list * binder_kind * constr_expr
+
+and constr_notation_substitution =
+ constr_expr list * (* for constr subterms *)
+ constr_expr list list * (* for recursive notations *)
+ local_binder list list (* for binders subexpressions *)
+
+type typeclass_constraint = name located * binding_kind * constr_expr
+
+and typeclass_context = typeclass_constraint list
+
type constr_pattern_expr = constr_expr
(***********************)
@@ -789,6 +940,15 @@ let cases_pattern_expr_loc = function
| CPatPrim (loc,_) -> loc
| CPatDelimiters (loc,_,_) -> loc
+let local_binder_loc = function
+ | LocalRawAssum ((loc,_)::_,_,t)
+ | LocalRawDef ((loc,_),t) -> join_loc loc (constr_loc t)
+ | LocalRawAssum ([],_,_) -> assert false
+
+let local_binders_loc bll =
+ if bll = [] then dummy_loc else
+ join_loc (local_binder_loc (List.hd bll)) (local_binder_loc (list_last bll))
+
let occur_var_constr_ref id = function
| Ident (loc,id') -> id = id'
| Qualid _ -> false
@@ -798,7 +958,7 @@ let ids_of_cases_indtype =
let rec vars_of = function
(* We deal only with the regular cases *)
| CApp (_,_,l) -> List.fold_left add_var [] (List.map fst l)
- | CNotation (_,_,(l,[]))
+ | CNotation (_,_,(l,[],[]))
(* assume the ntn is applicative and does not instantiate the head !! *)
| CAppExpl (_,_,l) -> List.fold_left add_var [] l
| CDelimiters(_,_,c) -> vars_of c
@@ -809,7 +969,7 @@ let ids_of_cases_tomatch tms =
List.fold_right
(fun (_,(ona,indnal)) l ->
Option.fold_right (fun t -> (@) (ids_of_cases_indtype t))
- indnal (Option.fold_right name_cons ona l))
+ indnal (Option.fold_right (down_located name_cons) ona l))
tms []
let is_constructor id =
@@ -849,7 +1009,7 @@ let rec fold_local_binders g f n acc b = function
f n (fold_local_binders g f n' acc b l) t
| LocalRawDef ((_,na),t)::l ->
f n (fold_local_binders g f (name_fold g na n) acc b l) t
- | _ ->
+ | [] ->
f n acc b
let fold_constr_expr_with_binders g f n acc = function
@@ -860,7 +1020,11 @@ let fold_constr_expr_with_binders g f n acc = function
| CLetIn (_,na,a,b) -> fold_constr_expr_binders g f n acc b [[na],default_binder_kind,a]
| CCast (loc,a,CastConv(_,b)) -> f n (f n acc a) b
| CCast (loc,a,CastCoerce) -> f n acc a
- | CNotation (_,_,(l,ll)) -> List.fold_left (f n) acc (l@List.flatten ll)
+ | CNotation (_,_,(l,ll,bll)) ->
+ (* The following is an approximation: we don't know exactly if
+ an ident is binding nor to which subterms bindings apply *)
+ let acc = List.fold_left (f n) acc (l@List.flatten ll) in
+ List.fold_left (fun acc bl -> fold_local_binders g f n acc (CHole (dummy_loc,None)) bl) acc bll
| CGeneralization (_,_,_,c) -> f n acc c
| CDelimiters (loc,_,a) -> f n acc a
| CHole _ | CEvar _ | CPatVar _ | CSort _ | CPrim _ | CDynamic _ | CRef _ ->
@@ -874,11 +1038,12 @@ let fold_constr_expr_with_binders g f n acc = function
let ids = ids_of_pattern_list patl in
f (Idset.fold g ids n) acc rhs) bl acc
| CLetTuple (loc,nal,(ona,po),b,c) ->
- let n' = List.fold_right (name_fold g) nal n in
- f (Option.fold_right (name_fold g) ona n') (f n acc b) c
+ let n' = List.fold_right (down_located (name_fold g)) nal n in
+ f (Option.fold_right (down_located (name_fold g)) ona n') (f n acc b) c
| CIf (_,c,(ona,po),b1,b2) ->
let acc = f n (f n (f n acc b1) b2) c in
- Option.fold_left (f (Option.fold_right (name_fold g) ona n)) acc po
+ Option.fold_left
+ (f (Option.fold_right (down_located (name_fold g)) ona n)) acc po
| CFix (loc,_,l) ->
let n' = List.fold_right (fun ((_,id),_,_,_,_) -> g id) l n in
List.fold_right (fun (_,(_,o),lb,t,c) acc ->
@@ -961,21 +1126,29 @@ let coerce_to_name = function
(* Interpret the index of a recursion order annotation *)
-let index_of_annot bl na =
+let split_at_annot bl na =
let names = List.map snd (names_of_local_assums bl) in
match na with
| None ->
- if names = [] then error "A fixpoint needs at least one parameter."
- else None
+ if names = [] then error "A fixpoint needs at least one parameter."
+ else [], bl
| Some (loc, id) ->
- try Some (list_index0 (Name id) names)
- with Not_found ->
- user_err_loc(loc,"",
- str "No parameter named " ++ Nameops.pr_id id ++ str".")
+ let rec aux acc = function
+ | LocalRawAssum (bls, k, t) as x :: rest ->
+ let l, r = list_split_when (fun (loc, na) -> na = Name id) bls in
+ if r = [] then aux (x :: acc) rest
+ else
+ (List.rev (if l = [] then acc else LocalRawAssum (l, k, t) :: acc),
+ LocalRawAssum (r, k, t) :: rest)
+ | LocalRawDef _ as x :: rest -> aux (x :: acc) rest
+ | [] ->
+ user_err_loc(loc,"",
+ str "No parameter named " ++ Nameops.pr_id id ++ str".")
+ in aux [] bl
(* Used in correctness and interface *)
-let map_binder g e nal = List.fold_right (fun (_,na) -> name_fold g na) nal e
+let map_binder g e nal = List.fold_right (down_located (name_fold g)) nal e
let map_binders f g e bl =
(* TODO: avoid variable capture in [t] by some [na] in [List.tl nal] *)
@@ -1005,8 +1178,10 @@ let map_constr_expr_with_binders g f e = function
| CLetIn (loc,na,a,b) -> CLetIn (loc,na,f e a,f (name_fold g (snd na) e) b)
| CCast (loc,a,CastConv (k,b)) -> CCast (loc,f e a,CastConv(k, f e b))
| CCast (loc,a,CastCoerce) -> CCast (loc,f e a,CastCoerce)
- | CNotation (loc,n,(l,ll)) ->
- CNotation (loc,n,(List.map (f e) l,List.map (List.map (f e)) ll))
+ | CNotation (loc,n,(l,ll,bll)) ->
+ (* This is an approximation because we don't know what binds what *)
+ CNotation (loc,n,(List.map (f e) l,List.map (List.map (f e)) ll,
+ List.map (fun bl -> snd (map_local_binders f g e bl)) bll))
| CGeneralization (loc,b,a,c) -> CGeneralization (loc,b,a,f e c)
| CDelimiters (loc,s,a) -> CDelimiters (loc,s,f e a)
| CHole _ | CEvar _ | CPatVar _ | CSort _
@@ -1019,11 +1194,11 @@ let map_constr_expr_with_binders g f e = function
let po = Option.map (f (List.fold_right g ids e)) rtnpo in
CCases (loc, sty, po, List.map (fun (tm,x) -> (f e tm,x)) a,bl)
| CLetTuple (loc,nal,(ona,po),b,c) ->
- let e' = List.fold_right (name_fold g) nal e in
- let e'' = Option.fold_right (name_fold g) ona e in
+ let e' = List.fold_right (down_located (name_fold g)) nal e in
+ let e'' = Option.fold_right (down_located (name_fold g)) ona e in
CLetTuple (loc,nal,(ona,Option.map (f e'') po),f e b,f e' c)
| CIf (loc,c,(ona,po),b1,b2) ->
- let e' = Option.fold_right (name_fold g) ona e in
+ let e' = Option.fold_right (down_located (name_fold g)) ona e in
CIf (loc,f e c,(ona,Option.map (f e') po),f e b1,f e b2)
| CFix (loc,id,dl) ->
CFix (loc,id,List.map (fun (id,n,bl,t,d) ->
@@ -1067,16 +1242,21 @@ type 'a module_signature =
| Check of 'a list (* ... <: T1 <: T2, possibly empty *)
(* Returns the ranges of locs of the notation that are not occupied by args *)
-(* and which are them occupied by proper symbols of the notation (or spaces) *)
+(* and which are then occupied by proper symbols of the notation (or spaces) *)
-let locs_of_notation f loc (args,argslist) ntn =
+let locs_of_notation loc locs ntn =
let (bl,el) = Util.unloc loc in
+ let locs = List.map Util.unloc locs in
let rec aux pos = function
| [] -> if pos = el then [] else [(pos,el-1)]
- | a::l ->
- let ba,ea = Util.unloc (f a) in
- if pos = ba then aux ea l else (pos,ba-1)::aux ea l
- in aux bl (args@List.flatten argslist)
+ | (ba,ea)::l ->if pos = ba then aux ea l else (pos,ba-1)::aux ea l
+ in aux bl (Sort.list (fun l1 l2 -> fst l1 < fst l2) locs)
+
+let ntn_loc loc (args,argslist,binderslist) =
+ locs_of_notation loc
+ (List.map constr_loc (args@List.flatten argslist)@
+ List.map local_binders_loc binderslist)
-let ntn_loc = locs_of_notation constr_loc
-let patntn_loc = locs_of_notation cases_pattern_expr_loc
+let patntn_loc loc (args,argslist) =
+ locs_of_notation loc
+ (List.map cases_pattern_expr_loc (args@List.flatten argslist))
diff --git a/interp/topconstr.mli b/interp/topconstr.mli
index 0918a4de..5e49d2ea 100644
--- a/interp/topconstr.mli
+++ b/interp/topconstr.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: topconstr.mli 13332 2010-07-26 22:12:43Z msozeau $ i*)
(*i*)
open Pp
@@ -32,6 +32,7 @@ type aconstr =
(* Part only in [rawconstr] *)
| ALambda of name * aconstr * aconstr
| AProd of name * aconstr * aconstr
+ | ABinderList of identifier * identifier * aconstr * aconstr
| ALetIn of name * aconstr * aconstr
| ACases of case_style * aconstr option *
(aconstr * (name * (inductive * int * name list) option)) list *
@@ -46,11 +47,34 @@ type aconstr =
| APatVar of patvar
| ACast of aconstr * aconstr cast_type
+type scope_name = string
+
+type tmp_scope_name = scope_name
+
+type subscopes = tmp_scope_name option * scope_name list
+
+(** Type of the meta-variables of an aconstr: in a recursive pattern x..y,
+ x carries the sequence of objects bound to the list x..y *)
+type notation_var_instance_type =
+ | NtnTypeConstr | NtnTypeConstrList | NtnTypeBinderList
+
+(** Type of variables when interpreting a constr_expr as an aconstr:
+ in a recursive pattern x..y, both x and y carry the individual type
+ of each element of the list x..y *)
+type notation_var_internalization_type =
+ | NtnInternTypeConstr | NtnInternTypeBinder | NtnInternTypeIdent
+
+(** This characterizes to what a notation is interpreted to *)
+type interpretation =
+ (identifier * (subscopes * notation_var_instance_type)) list * aconstr
+
(**********************************************************************)
(* Translate a rawconstr into a notation given the list of variables *)
(* bound by the notation; also interpret recursive patterns *)
-val aconstr_of_rawconstr : identifier list -> rawconstr -> aconstr
+val aconstr_of_rawconstr :
+ (identifier * notation_var_internalization_type) list ->
+ (identifier * identifier) list -> rawconstr -> aconstr
(* Name of the special identifier used to encode recursive notations *)
val ldots_var : identifier
@@ -68,23 +92,14 @@ val rawconstr_of_aconstr_with_binders : loc ->
val rawconstr_of_aconstr : loc -> aconstr -> rawconstr
(**********************************************************************)
-(* [match_aconstr metas] matches a rawconstr against an aconstr with *)
-(* metavariables in [metas]; raise [No_match] if the matching fails *)
+(* [match_aconstr] matches a rawconstr against a notation *)
+(* interpretation raise [No_match] if the matching fails *)
exception No_match
-type scope_name = string
-
-type tmp_scope_name = scope_name
-
-type subscopes = tmp_scope_name option * scope_name list
-
-type interpretation =
- (* regular vars of notation / recursive parts of notation / body *)
- ((identifier * subscopes) list * (identifier * subscopes) list) * aconstr
-
val match_aconstr : rawconstr -> interpretation ->
- (rawconstr * subscopes) list * (rawconstr list * subscopes) list
+ (rawconstr * subscopes) list * (rawconstr list * subscopes) list *
+ (rawdecl list * subscopes) list
val match_aconstr_cases_pattern : cases_pattern -> interpretation ->
(cases_pattern * subscopes) list * (cases_pattern list * subscopes) list
@@ -113,19 +128,20 @@ type proj_flag = int option (* [Some n] = proj of the n-th visible argument *)
type prim_token = Numeral of Bigint.bigint | String of string
-type 'a notation_substitution =
- 'a list * (* for recursive notations: *) 'a list list
-
type cases_pattern_expr =
| CPatAlias of loc * cases_pattern_expr * identifier
| CPatCstr of loc * reference * cases_pattern_expr list
| CPatAtom of loc * reference option
| CPatOr of loc * cases_pattern_expr list
- | CPatNotation of loc * notation * cases_pattern_expr notation_substitution
+ | CPatNotation of loc * notation * cases_pattern_notation_substitution
| CPatPrim of loc * prim_token
| CPatRecord of Util.loc * (reference * cases_pattern_expr) list
| CPatDelimiters of loc * string * cases_pattern_expr
+and cases_pattern_notation_substitution =
+ cases_pattern_expr list * (** for constr subterms *)
+ cases_pattern_expr list list (** for recursive notations *)
+
type constr_expr =
| CRef of reference
| CFix of loc * identifier located * fix_expr list
@@ -139,18 +155,18 @@ type constr_expr =
(constr_expr * explicitation located option) list
| CRecord of loc * constr_expr option * (reference * constr_expr) list
| CCases of loc * case_style * constr_expr option *
- (constr_expr * (name option * constr_expr option)) list *
+ (constr_expr * (name located option * constr_expr option)) list *
(loc * cases_pattern_expr list located list * constr_expr) list
- | CLetTuple of loc * name list * (name option * constr_expr option) *
+ | CLetTuple of loc * name located list * (name located option * constr_expr option) *
constr_expr * constr_expr
- | CIf of loc * constr_expr * (name option * constr_expr option)
+ | CIf of loc * constr_expr * (name located option * constr_expr option)
* constr_expr * constr_expr
| CHole of loc * Evd.hole_kind option
| CPatVar of loc * (bool * patvar)
| CEvar of loc * existential_key * constr_expr list option
| CSort of loc * rawsort
| CCast of loc * constr_expr * constr_expr cast_type
- | CNotation of loc * notation * constr_expr notation_substitution
+ | CNotation of loc * notation * constr_notation_substitution
| CGeneralization of loc * binding_kind * abstraction_kind option * constr_expr
| CPrim of loc * prim_token
| CDelimiters of loc * string * constr_expr
@@ -172,6 +188,11 @@ and local_binder =
| LocalRawDef of name located * constr_expr
| LocalRawAssum of name located list * binder_kind * constr_expr
+and constr_notation_substitution =
+ constr_expr list * (** for constr subterms *)
+ constr_expr list list * (** for recursive notations *)
+ local_binder list list (** for binders subexpressions *)
+
type typeclass_constraint = name located * binding_kind * constr_expr
and typeclass_context = typeclass_constraint list
@@ -185,6 +206,8 @@ val constr_loc : constr_expr -> loc
val cases_pattern_expr_loc : cases_pattern_expr -> loc
+val local_binders_loc : local_binder list -> loc
+
val replace_vars_constr_expr :
(identifier * identifier) list -> constr_expr -> constr_expr
@@ -208,7 +231,7 @@ val coerce_reference_to_id : reference -> identifier
val coerce_to_id : constr_expr -> identifier located
val coerce_to_name : constr_expr -> name located
-val index_of_annot : local_binder list -> identifier located option -> int option
+val split_at_annot : local_binder list -> identifier located option -> local_binder list * local_binder list
val abstract_constr_expr : constr_expr -> local_binder list -> constr_expr
val prod_constr_expr : constr_expr -> local_binder list -> constr_expr
@@ -256,7 +279,6 @@ type 'a module_signature =
| Check of 'a list (* ... <: T1 <: T2, possibly empty *)
val ntn_loc :
- Util.loc -> constr_expr notation_substitution -> string -> (int * int) list
+ Util.loc -> constr_notation_substitution -> string -> (int * int) list
val patntn_loc :
- Util.loc -> cases_pattern_expr notation_substitution -> string ->
- (int * int) list
+ Util.loc -> cases_pattern_notation_substitution -> string -> (int * int) list
diff --git a/kernel/byterun/int64_emul.h b/kernel/byterun/int64_emul.h
index 04e38656..0a61ad79 100644
--- a/kernel/byterun/int64_emul.h
+++ b/kernel/byterun/int64_emul.h
@@ -11,7 +11,7 @@
/* */
/***********************************************************************/
-/* $Id$ */
+/* $Id: int64_emul.h 10739 2008-04-01 14:45:20Z herbelin $ */
/* Software emulation of 64-bit integer arithmetic, for C compilers
that do not support it. */
diff --git a/kernel/byterun/int64_native.h b/kernel/byterun/int64_native.h
index f5bef4a6..4fc3c220 100644
--- a/kernel/byterun/int64_native.h
+++ b/kernel/byterun/int64_native.h
@@ -11,7 +11,7 @@
/* */
/***********************************************************************/
-/* $Id$ */
+/* $Id: int64_native.h 10739 2008-04-01 14:45:20Z herbelin $ */
/* Wrapper macros around native 64-bit integer arithmetic,
so that it has the same interface as the software emulation
diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml
index e7859962..0578c7b4 100644
--- a/kernel/cbytegen.ml
+++ b/kernel/cbytegen.ml
@@ -7,49 +7,46 @@ open Declarations
open Pre_env
-(* Compilation des variables + calcul des variables libres *)
+(* Compilation of variables + computing free variables *)
-(* Dans la machine virtuel il n'y a pas de difference entre les *)
-(* fonctions et leur environnement *)
+(* The virtual machine doesn't distinguish closures and their environment *)
-(* Representation de l'environnements des fonctions : *)
+(* Representation of function environments : *)
(* [clos_t | code | fv1 | fv2 | ... | fvn ] *)
(* ^ *)
-(* l'offset pour l'acces au variable libre est 1 (il faut passer le *)
-(* pointeur de code). *)
-(* Lors de la compilation, les variables libres sont stock'ees dans *)
-(* [in_env] dans l'ordre inverse de la representation machine, ceci *)
-(* permet de rajouter des nouvelles variables dans l'environnememt *)
-(* facilement. *)
-(* Les arguments de la fonction arrive sur la pile dans l'ordre de *)
-(* l'application : f arg1 ... argn *)
-(* - la pile est alors : *)
+(* The offset for accessing free variables is 1 (we must skip the code *)
+(* pointer). *)
+(* While compiling, free variables are stored in [in_env] in order *)
+(* opposite to machine representation, so we can add new free variables *)
+(* easily (i.e. without changing the position of previous variables) *)
+(* Function arguments are on the stack in the same order as the *)
+(* application : f arg1 ... argn *)
+(* - the stack is then : *)
(* arg1 : ... argn : extra args : return addr : ... *)
-(* Dans le corps de la fonction [arg1] est repr'esent'e par le de Bruijn *)
-(* [n], [argn] par le de Bruijn [1] *)
+(* In the function body [arg1] is represented by de Bruijn [n], and *)
+(* [argn] by de Bruijn [1] *)
-(* Representation des environnements des points fix mutuels : *)
+(* Representation of environements of mutual fixpoints : *)
(* [t1|C1| ... |tc|Cc| ... |t(nbr)|C(nbr)| fv1 | fv2 | .... | fvn | type] *)
(* ^<----------offset---------> *)
(* type = [Ct1 | .... | Ctn] *)
-(* Ci est le code correspondant au corps du ieme point fix *)
-(* Lors de l'evaluation d'un point fix l'environnement est un pointeur *)
-(* sur la position correspondante a son code. *)
-(* Dans le corps de chaque point fix le de Bruijn [nbr] represente, *)
-(* le 1er point fix de la declaration mutuelle, le de Bruijn [1] le *)
-(* nbr-ieme. *)
-(* L'acces a ces variables se fait par l'instruction [Koffsetclosure] *)
-(* (decalage de l'environnement) *)
-
-(* Ceci permet de representer tout les point fix mutuels en un seul bloc *)
-(* [Ct1 | ... | Ctn] est un tableau contant le code d'evaluation des *)
-(* types des points fixes, ils sont utilises pour tester la conversion *)
-(* Leur environnement d'execution est celui du dernier point fix : *)
+(* Ci is the code pointer of the i-th body *)
+(* At runtime, a fixpoint environment (which is the same as the fixpoint *)
+(* itself) is a pointer to the field holding its code pointer. *)
+(* In each fixpoint body, de Bruijn [nbr] represents the first fixpoint *)
+(* and de Bruijn [1] the last one. *)
+(* Access to these variables is performed by the [Koffsetclosure n] *)
+(* instruction that shifts the environment pointer of [n] fields. *)
+
+(* This allows to represent mutual fixpoints in just one block. *)
+(* [Ct1 | ... | Ctn] is an array holding code pointers of the fixpoint *)
+(* types. They are used in conversion tests (which requires that *)
+(* fixpoint types must be convertible). Their environment is the one of *)
+(* the last fixpoint : *)
(* [t1|C1| ... |tc|Cc| ... |t(nbr)|C(nbr)| fv1 | fv2 | .... | fvn | type] *)
(* ^ *)
-
-(* Representation des cofix mutuels : *)
+(* Representation of mutual cofix : *)
(* a1 = [A_t | accumulate | [Cfx_t | fcofix1 ] ] *)
(* ... *)
(* anbr = [A_t | accumulate | [Cfx_t | fcofixnbr ] ] *)
@@ -59,29 +56,28 @@ open Pre_env
(* ... *)
(* fcofixnbr = [clos_t | codenbr | a1 |...| anbr | fv1 |...| fvn | type] *)
(* ^ *)
-(* Les block [ai] sont des fonctions qui accumulent leurs arguments : *)
+(* The [ai] blocks are functions that accumulate their arguments: *)
(* ai arg1 argp ---> *)
(* ai' = [A_t | accumulate | [Cfx_t | fcofixi] | arg1 | ... | argp ] *)
-(* Si un tel bloc arrive sur un [match] il faut forcer l'evaluation, *)
-(* la fonction [fcofixi] est alors appliqu'ee a [ai'] [arg1] ... [argp] *)
-(* A la fin de l'evaluation [ai'] est mis a jour avec le resultat de *)
-(* l'evaluation : *)
+(* If such a block is matched against, we have to force evaluation, *)
+(* function [fcofixi] is then applied to [ai'] [arg1] ... [argp] *)
+(* Once evaluation is completed [ai'] is updated with the result: *)
(* ai' <-- *)
(* [A_t | accumulate | [Cfxe_t |fcofixi|result] | arg1 | ... | argp ] *)
-(* L'avantage de cette representation est qu'elle permet d'evaluer qu'une *)
-(* fois l'application d'un cofix (evaluation lazy) *)
-(* De plus elle permet de creer facilement des cycles quand les cofix ne *)
-(* n'ont pas d'aruments, ex: *)
+(* This representation is nice because the application of the cofix is *)
+(* evaluated only once (it simulates a lazy evaluation) *)
+(* Moreover, when cofix don't have arguments, it is possible to create *)
+(* a cycle, e.g.: *)
(* cofix one := cons 1 one *)
(* a1 = [A_t | accumulate | [Cfx_t|fcofix1] ] *)
(* fcofix1 = [clos_t | code | a1] *)
-(* Quand on force l'evaluation de [a1] le resultat est *)
-(* [cons_t | 1 | a1] *)
-(* [a1] est mis a jour : *)
+(* The result of evaluating [a1] is [cons_t | 1 | a1]. *)
+(* When [a1] is updated : *)
(* a1 = [A_t | accumulate | [Cfxe_t | fcofix1 | [cons_t | 1 | a1]] ] *)
-(* Le cycle est cree ... *)
-
-(* On conserve la fct de cofix pour la conversion *)
+(* The cycle is created ... *)
+(* *)
+(* In Cfxe_t accumulators, we need to store [fcofixi] for testing *)
+(* conversion of cofixpoints (which is intentional). *)
let empty_fv = { size= 0; fv_rev = [] }
@@ -112,7 +108,7 @@ let comp_env_fun arity =
}
-let comp_env_type rfv =
+let comp_env_fix_type rfv =
{ nb_stack = 0;
in_stack = [];
nb_rec = 0;
@@ -134,6 +130,15 @@ let comp_env_fix ndef curr_pos arity rfv =
in_env = rfv
}
+let comp_env_cofix_type ndef rfv =
+ { nb_stack = 0;
+ in_stack = [];
+ nb_rec = 0;
+ pos_rec = [];
+ offset = 1+ndef;
+ in_env = rfv
+ }
+
let comp_env_cofix ndef arity rfv =
let prec = ref [] in
for i = 1 to ndef do
@@ -147,14 +152,13 @@ let comp_env_cofix ndef arity rfv =
in_env = rfv
}
-(* [push_param ] ajoute les parametres de fonction dans la pile *)
+(* [push_param ] add function parameters on the stack *)
let push_param n sz r =
{ r with
nb_stack = r.nb_stack + n;
in_stack = add_param n sz r.in_stack }
-(* [push_local e sz] ajoute une nouvelle variable dans la pile a la *)
-(* position [sz] *)
+(* [push_local sz r] add a new variable on the stack at position [sz] *)
let push_local sz r =
{ r with
nb_stack = r.nb_stack + 1;
@@ -185,7 +189,7 @@ let pos_rel i r sz =
let i = i - r.nb_stack in
if i <= r.nb_rec then
try List.nth r.pos_rec (i-1)
- with _ -> assert false
+ with (Failure _|Invalid_argument _) -> assert false
else
let i = i - r.nb_rec in
let db = FVrel(i) in
@@ -297,19 +301,19 @@ let cont_cofix arity =
Kreturn (arity+2) ]
-(*i Global environment global *)
+(*i Global environment *)
let global_env = ref empty_env
let set_global_env env = global_env := env
-(* Code des fermetures *)
+(* Code of closures *)
let fun_code = ref []
let init_fun_code () = fun_code := []
-(* Compilation des constructeurs et des inductifs *)
+(* Compilation of constructors and inductive types *)
(* Inv : nparam + arity > 0 *)
let code_construct tag nparams arity cont =
@@ -424,7 +428,7 @@ let rec str_const c =
end
| _ -> Bconstr c
-(* compilation des applications *)
+(* compiling application *)
let comp_args comp_expr reloc args sz cont =
let nargs_m_1 = Array.length args - 1 in
let c = ref (comp_expr reloc args.(0) (sz + nargs_m_1) cont) in
@@ -451,7 +455,7 @@ let comp_app comp_fun comp_arg reloc f args sz cont =
(comp_args comp_arg reloc args (sz + 3)
(Kpush :: (comp_fun reloc f (sz+3+nargs) (Kapply nargs :: cont1))))
-(* Compilation des variables libres *)
+(* Compiling free variables *)
let compile_fv_elem reloc fv sz cont =
match fv with
@@ -466,7 +470,7 @@ let rec compile_fv reloc l sz cont =
compile_fv_elem reloc fvn sz
(Kpush :: compile_fv reloc tl (sz + 1) cont)
-(* compilation des constantes *)
+(* Compiling constants *)
let rec get_allias env kn =
let tps = (lookup_constant kn env).const_body_code in
@@ -475,7 +479,7 @@ let rec get_allias env kn =
| _ -> kn
-(* compilation des expressions *)
+(* Compiling expressions *)
let rec compile_constr reloc c sz cont =
match kind_of_term c with
@@ -522,7 +526,7 @@ let rec compile_constr reloc c sz cont =
let lbl_types = Array.create ndef Label.no in
let lbl_bodies = Array.create ndef Label.no in
(* Compilation des types *)
- let env_type = comp_env_type rfv in
+ let env_type = comp_env_fix_type rfv in
for i = 0 to ndef - 1 do
let lbl,fcode =
label_code
@@ -530,7 +534,7 @@ let rec compile_constr reloc c sz cont =
lbl_types.(i) <- lbl;
fun_code := [Ksequence(fcode,!fun_code)]
done;
- (* Compilation des corps *)
+ (* Compiling bodies *)
for i = 0 to ndef - 1 do
let params,body = decompose_lam rec_bodies.(i) in
let arity = List.length params in
@@ -550,9 +554,9 @@ let rec compile_constr reloc c sz cont =
let ndef = Array.length type_bodies in
let lbl_types = Array.create ndef Label.no in
let lbl_bodies = Array.create ndef Label.no in
- (* Compilation des types *)
+ (* Compiling types *)
let rfv = ref empty_fv in
- let env_type = comp_env_type rfv in
+ let env_type = comp_env_cofix_type ndef rfv in
for i = 0 to ndef - 1 do
let lbl,fcode =
label_code
@@ -560,7 +564,7 @@ let rec compile_constr reloc c sz cont =
lbl_types.(i) <- lbl;
fun_code := [Ksequence(fcode,!fun_code)]
done;
- (* Compilation des corps *)
+ (* Compiling bodies *)
for i = 0 to ndef - 1 do
let params,body = decompose_lam rec_bodies.(i) in
let arity = List.length params in
@@ -585,11 +589,11 @@ let rec compile_constr reloc c sz cont =
let lbl_consts = Array.create oib.mind_nb_constant Label.no in
let lbl_blocks = Array.create (oib.mind_nb_args+1) Label.no in
let branch1,cont = make_branch cont in
- (* Compilation du type *)
+ (* Compiling return type *)
let lbl_typ,fcode =
label_code (compile_constr reloc t sz [Kpop sz; Kstop])
in fun_code := [Ksequence(fcode,!fun_code)];
- (* Compilation des branches *)
+ (* Compiling branches *)
let lbl_sw = Label.create () in
let sz_b,branch,is_tailcall =
match branch1 with
@@ -597,13 +601,13 @@ let rec compile_constr reloc c sz cont =
| _ -> sz+3, Kjump, false
in
let annot = {ci = ci; rtbl = tbl; tailcall = is_tailcall} in
- (* Compilation de la branche accumulate *)
+ (* Compiling branch for accumulators *)
let lbl_accu, code_accu =
label_code(Kmakeswitchblock(lbl_typ,lbl_sw,annot,sz) :: branch::cont)
in
lbl_blocks.(0) <- lbl_accu;
let c = ref code_accu in
- (* Compilation des branches constructeurs *)
+ (* Compiling regular constructor branches *)
for i = 0 to Array.length tbl - 1 do
let tag, arity = tbl.(i) in
if arity = 0 then
diff --git a/kernel/closure.ml b/kernel/closure.ml
index 82bd017a..3f4c1059 100644
--- a/kernel/closure.ml
+++ b/kernel/closure.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: closure.ml 13340 2010-07-28 12:22:04Z barras $ *)
open Util
open Pp
@@ -524,6 +524,7 @@ let destFLambda clos_fun t =
| FLambda(n,(na,ty)::tys,b,e) ->
(na,clos_fun e ty,{norm=Cstr;term=FLambda(n-1,tys,b,subs_lift e)})
| _ -> assert false
+ (* t must be a FLambda and binding list cannot be empty *)
(* Optimization: do not enclose variables in a closure.
Makes variable access much faster *)
@@ -758,8 +759,8 @@ let rec reloc_rargs_rec depth stk =
let reloc_rargs depth stk =
if depth = 0 then stk else reloc_rargs_rec depth stk
-let rec drop_parameters depth n stk =
- match stk with
+let rec drop_parameters depth n argstk =
+ match argstk with
Zapp args::s ->
let q = Array.length args in
if n > q then drop_parameters depth (n-q) s
@@ -768,9 +769,12 @@ let rec drop_parameters depth n stk =
let aft = Array.sub args n (q-n) in
reloc_rargs depth (append_stack aft s)
| Zshift(k)::s -> drop_parameters (depth-k) n s
- | [] -> assert (n=0); []
- | _ -> assert false (* we know that n < stack_args_size(stk) *)
-
+ | [] -> (* we know that n < stack_args_size(argstk) (if well-typed term) *)
+ if n=0 then []
+ else anomaly
+ "ill-typed term: found a match on a partially applied constructor"
+ | _ -> assert false
+ (* strip_update_shift_app only produces Zapp and Zshift items *)
(* Iota reduction: expansion of a fixpoint.
* Given a fixpoint and a substitution, returns the corresponding
diff --git a/kernel/closure.mli b/kernel/closure.mli
index 7d212f53..0af30bed 100644
--- a/kernel/closure.mli
+++ b/kernel/closure.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: closure.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Pp
diff --git a/kernel/conv_oracle.ml b/kernel/conv_oracle.ml
index ca9482d0..935f6fe7 100644
--- a/kernel/conv_oracle.ml
+++ b/kernel/conv_oracle.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: conv_oracle.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Names
diff --git a/kernel/conv_oracle.mli b/kernel/conv_oracle.mli
index 1de1ddbf..94911edd 100644
--- a/kernel/conv_oracle.mli
+++ b/kernel/conv_oracle.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: conv_oracle.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Names
diff --git a/kernel/cooking.ml b/kernel/cooking.ml
index e6bc0684..ad5e725b 100644
--- a/kernel/cooking.ml
+++ b/kernel/cooking.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: cooking.ml 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Pp
open Util
diff --git a/kernel/cooking.mli b/kernel/cooking.mli
index a471dbc9..bd1f4aec 100644
--- a/kernel/cooking.mli
+++ b/kernel/cooking.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: cooking.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Names
open Term
diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml
index 145ca27d..8eeb1ce6 100644
--- a/kernel/csymtable.ml
+++ b/kernel/csymtable.ml
@@ -146,7 +146,7 @@ and slot_for_fv env fv =
let (_, b, _) = lookup_rel i env.env_rel_context in
let (v, d) =
match b with
- | None -> (val_of_rel i, Idset.empty)
+ | None -> (val_of_rel (nb_rel env - i), Idset.empty)
| Some c -> let renv = env_of_rel i env in
(val_of_constr renv c, Environ.global_vars_set (Environ.env_of_pre_env renv) c)
in
diff --git a/kernel/declarations.ml b/kernel/declarations.ml
index d3866b42..42055a23 100644
--- a/kernel/declarations.ml
+++ b/kernel/declarations.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: declarations.ml 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Util
diff --git a/kernel/declarations.mli b/kernel/declarations.mli
index 56075869..ee1242bb 100644
--- a/kernel/declarations.mli
+++ b/kernel/declarations.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: declarations.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Names
diff --git a/kernel/entries.ml b/kernel/entries.ml
index d3dcc5e7..cec46423 100644
--- a/kernel/entries.ml
+++ b/kernel/entries.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: entries.ml 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Names
diff --git a/kernel/entries.mli b/kernel/entries.mli
index 2b3e2c49..ecc50213 100644
--- a/kernel/entries.mli
+++ b/kernel/entries.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: entries.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Names
diff --git a/kernel/environ.ml b/kernel/environ.ml
index 41805241..935faae6 100644
--- a/kernel/environ.ml
+++ b/kernel/environ.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: environ.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Util
open Names
diff --git a/kernel/environ.mli b/kernel/environ.mli
index ef912e6f..7485ca37 100644
--- a/kernel/environ.mli
+++ b/kernel/environ.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: environ.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Names
diff --git a/kernel/esubst.ml b/kernel/esubst.ml
index 2ba2670a..2d3956a1 100644
--- a/kernel/esubst.ml
+++ b/kernel/esubst.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: esubst.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Util
diff --git a/kernel/esubst.mli b/kernel/esubst.mli
index 2cad93f5..96da8dda 100644
--- a/kernel/esubst.mli
+++ b/kernel/esubst.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: esubst.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*s Explicit substitutions of type ['a]. *)
(* - ESID(n) = %n END bounded identity
diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml
index df3670d5..91aec40c 100644
--- a/kernel/indtypes.ml
+++ b/kernel/indtypes.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: indtypes.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Util
open Names
diff --git a/kernel/indtypes.mli b/kernel/indtypes.mli
index b9f39cef..8384a63a 100644
--- a/kernel/indtypes.mli
+++ b/kernel/indtypes.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: indtypes.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Names
diff --git a/kernel/inductive.ml b/kernel/inductive.ml
index ca7d0614..ba5e5252 100644
--- a/kernel/inductive.ml
+++ b/kernel/inductive.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: inductive.ml 13368 2010-08-03 13:22:49Z barras $ *)
open Util
open Names
@@ -418,8 +418,10 @@ type subterm_spec =
| Dead_code
| Not_subterm
-let spec_of_tree t =
- if Rtree.eq_rtree (=) t mk_norec then Not_subterm else Subterm(Strict,t)
+let spec_of_tree t = lazy
+ (if Rtree.eq_rtree (=) (Lazy.force t) mk_norec
+ then Not_subterm
+ else Subterm(Strict,Lazy.force t))
let subterm_spec_glb =
let glb2 s1 s2 =
@@ -443,7 +445,7 @@ type guard_env =
(* the recarg information of inductive family *)
recvec : wf_paths array;
(* dB of variables denoting subterms *)
- genv : subterm_spec list;
+ genv : subterm_spec Lazy.t list;
}
let make_renv env minds recarg (kn,tyi) =
@@ -454,7 +456,7 @@ let make_renv env minds recarg (kn,tyi) =
rel_min = recarg+2;
inds = minds;
recvec = mind_recvec;
- genv = [Subterm(Large,mind_recvec.(tyi))] }
+ genv = [Lazy.lazy_from_val(Subterm(Large,mind_recvec.(tyi)))] }
let push_var renv (x,ty,spec) =
{ renv with
@@ -466,11 +468,11 @@ let assign_var_spec renv (i,spec) =
{ renv with genv = list_assign renv.genv (i-1) spec }
let push_var_renv renv (x,ty) =
- push_var renv (x,ty,Not_subterm)
+ push_var renv (x,ty,Lazy.lazy_from_val Not_subterm)
(* Fetch recursive information about a variable p *)
let subterm_var p renv =
- try List.nth renv.genv (p-1)
+ try Lazy.force (List.nth renv.genv (p-1))
with Failure _ | Invalid_argument _ -> Not_subterm
(* Add a variable and mark it as strictly smaller with information [spec]. *)
@@ -482,14 +484,14 @@ let push_ctxt_renv renv ctxt =
{ renv with
env = push_rel_context ctxt renv.env;
rel_min = renv.rel_min+n;
- genv = iterate (fun ge -> Not_subterm::ge) n renv.genv }
+ genv = iterate (fun ge -> Lazy.lazy_from_val Not_subterm::ge) n renv.genv }
let push_fix_renv renv (_,v,_ as recdef) =
let n = Array.length v in
{ renv with
env = push_rec_types recdef renv.env;
rel_min = renv.rel_min+n;
- genv = iterate (fun ge -> Not_subterm::ge) n renv.genv }
+ genv = iterate (fun ge -> Lazy.lazy_from_val Not_subterm::ge) n renv.genv }
(******************************)
@@ -513,12 +515,47 @@ let lookup_subterms env ind =
(*********************************)
+let match_trees t1 t2 =
+ let v1 = dest_subterms t1 in
+ let v2 = dest_subterms t2 in
+ array_for_all2 (fun l1 l2 -> List.length l1 = List.length l2) v1 v2
+
+(* In {match c as z in ind y_s return P with |C_i x_s => t end}
+ [branches_specif renv c_spec ind] returns an array of x_s specs given
+ c_spec the spec of c. *)
+let branches_specif renv c_spec ind =
+ let (_,mip) = lookup_mind_specif renv.env ind in
+ let car =
+ (* We fetch the regular tree associated to the inductive of the match.
+ This is just to get the number of constructors (and constructor
+ arities) that fit the match branches without forcing c_spec.
+ Note that c_spec might be more precise than [v] below, because of
+ nested inductive types. *)
+ let v = dest_subterms mip.mind_recargs in
+ Array.map List.length v in
+ Array.mapi
+ (fun i nca -> (* i+1-th cstructor has arity nca *)
+ let lvra = lazy
+ (match Lazy.force c_spec with
+ Subterm (_,t) when match_trees mip.mind_recargs t ->
+ let vra = Array.of_list (dest_subterms t).(i) in
+ assert (nca = Array.length vra);
+ Array.map
+ (fun t -> Lazy.force (spec_of_tree (lazy t)))
+ vra
+ | Dead_code -> Array.create nca Dead_code
+ | _ -> Array.create nca Not_subterm) in
+ list_tabulate (fun j -> lazy (Lazy.force lvra).(j)) nca)
+ car
+
+
(* Propagation of size information through Cases: if the matched
object is a recursive subterm then compute the information
associated to its own subterms.
Rq: if branch is not eta-long, then the recursive information
is not propagated to the missing abstractions *)
let case_branches_specif renv c_spec ind lbr =
+ let vlrec = branches_specif renv c_spec ind in
let rec push_branch_args renv lrec c =
match lrec with
ra::lr ->
@@ -530,17 +567,8 @@ let case_branches_specif renv c_spec ind lbr =
| _ -> (* branch not in eta-long form: cannot perform rec. calls *)
(renv,c'))
| [] -> (renv, c) in
- match c_spec with
- Subterm (_,t) ->
- let sub_spec = Array.map (List.map spec_of_tree) (dest_subterms t) in
- assert (Array.length sub_spec = Array.length lbr);
- array_map2 (push_branch_args renv) sub_spec lbr
- | Dead_code ->
- let t = dest_subterms (lookup_subterms renv.env ind) in
- let sub_spec = Array.map (List.map (fun _ -> Dead_code)) t in
- assert (Array.length sub_spec = Array.length lbr);
- array_map2 (push_branch_args renv) sub_spec lbr
- | Not_subterm -> Array.map (fun c -> (renv,c)) lbr
+ assert (Array.length vlrec = Array.length lbr);
+ array_map2 (push_branch_args renv) vlrec lbr
(* [subterm_specif renv t] computes the recursive structure of [t] and
compare its size with the size of the initial recursive argument of
@@ -582,7 +610,8 @@ let rec subterm_specif renv t =
let renv' =
(* Why Strict here ? To be general, it could also be
Large... *)
- assign_var_spec renv' (nbfix-i, Subterm(Strict,recargs)) in
+ assign_var_spec renv'
+ (nbfix-i, Lazy.lazy_from_val(Subterm(Strict,recargs))) in
let decrArg = recindxs.(i) in
let theBody = bodies.(i) in
let nbOfAbst = decrArg+1 in
@@ -593,7 +622,7 @@ let rec subterm_specif renv t =
if List.length l < nbOfAbst then renv''
else
let theDecrArg = List.nth l decrArg in
- let arg_spec = subterm_specif renv theDecrArg in
+ let arg_spec = lazy_subterm_specif renv theDecrArg in
assign_var_spec renv'' (1, arg_spec) in
subterm_specif renv'' strippedBody)
@@ -607,10 +636,13 @@ let rec subterm_specif renv t =
(* Other terms are not subterms *)
| _ -> Not_subterm
+and lazy_subterm_specif renv t =
+ lazy (subterm_specif renv t)
+
and case_subterm_specif renv ci c lbr =
if Array.length lbr = 0 then [||]
else
- let c_spec = subterm_specif renv c in
+ let c_spec = lazy_subterm_specif renv c in
case_branches_specif renv c_spec ci.ci_ind lbr
(* Check term c can be applied to one of the mutual fixpoints. *)
@@ -627,7 +659,7 @@ let error_illegal_rec_call renv fx arg =
let (_,le_vars,lt_vars) =
List.fold_left
(fun (i,le,lt) sbt ->
- match sbt with
+ match Lazy.force sbt with
(Subterm(Strict,_) | Dead_code) -> (i+1, le, i::lt)
| (Subterm(Large,_)) -> (i+1, i::le, lt)
| _ -> (i+1, le ,lt))
@@ -709,7 +741,7 @@ let check_one_fix renv recpos def =
(fun j body ->
if i=j then
let theDecrArg = List.nth l decrArg in
- let arg_spec = subterm_specif renv theDecrArg in
+ let arg_spec = lazy_subterm_specif renv theDecrArg in
check_nested_fix_body renv' (decrArg+1) arg_spec body
else check_rec_call renv' body)
bodies
diff --git a/kernel/inductive.mli b/kernel/inductive.mli
index 59eaf77f..a2bd674f 100644
--- a/kernel/inductive.mli
+++ b/kernel/inductive.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: inductive.mli 13368 2010-08-03 13:22:49Z barras $ i*)
(*i*)
open Names
@@ -110,9 +110,9 @@ type guard_env =
(* the recarg information of inductive family *)
recvec : wf_paths array;
(* dB of variables denoting subterms *)
- genv : subterm_spec list;
+ genv : subterm_spec Lazy.t list;
}
val subterm_specif : guard_env -> constr -> subterm_spec
-val case_branches_specif : guard_env -> subterm_spec -> inductive ->
+val case_branches_specif : guard_env -> subterm_spec Lazy.t -> inductive ->
constr array -> (guard_env * constr) array
diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml
index d27fad95..53d26ec6 100644
--- a/kernel/mod_subst.ml
+++ b/kernel/mod_subst.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: mod_subst.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Pp
open Util
diff --git a/kernel/mod_subst.mli b/kernel/mod_subst.mli
index f137c7c0..a16ee99e 100644
--- a/kernel/mod_subst.mli
+++ b/kernel/mod_subst.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: mod_subst.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*s [Mod_subst] *)
diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml
index d0e567a8..c2a2ffee 100644
--- a/kernel/mod_typing.ml
+++ b/kernel/mod_typing.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: mod_typing.ml 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Util
open Names
diff --git a/kernel/mod_typing.mli b/kernel/mod_typing.mli
index 7f35530f..58a80869 100644
--- a/kernel/mod_typing.mli
+++ b/kernel/mod_typing.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: mod_typing.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Declarations
diff --git a/kernel/modops.ml b/kernel/modops.ml
index 2cac5334..02662adf 100644
--- a/kernel/modops.ml
+++ b/kernel/modops.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: modops.ml 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Util
diff --git a/kernel/modops.mli b/kernel/modops.mli
index c1c262cc..9b12fea6 100644
--- a/kernel/modops.mli
+++ b/kernel/modops.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: modops.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Util
diff --git a/kernel/names.ml b/kernel/names.ml
index 54304376..550c70b4 100644
--- a/kernel/names.ml
+++ b/kernel/names.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: names.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Pp
open Util
diff --git a/kernel/names.mli b/kernel/names.mli
index 8209119c..f54df6ec 100644
--- a/kernel/names.mli
+++ b/kernel/names.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: names.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*s Identifiers *)
diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml
index f35da2d2..bad04af5 100644
--- a/kernel/pre_env.ml
+++ b/kernel/pre_env.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: pre_env.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Util
open Names
diff --git a/kernel/pre_env.mli b/kernel/pre_env.mli
index ac51e49d..80f382c6 100644
--- a/kernel/pre_env.mli
+++ b/kernel/pre_env.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: pre_env.mli 13323 2010-07-24 15:57:30Z herbelin $ *)
open Util
open Names
diff --git a/kernel/reduction.ml b/kernel/reduction.ml
index cd4902c5..00e8014f 100644
--- a/kernel/reduction.ml
+++ b/kernel/reduction.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: reduction.ml 13354 2010-07-29 16:44:45Z barras $ *)
open Util
open Names
@@ -253,7 +253,8 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv =
| (FAtom a1, FAtom a2) ->
(match kind_of_term a1, kind_of_term a2 with
| (Sort s1, Sort s2) ->
- assert (is_empty_stack v1 && is_empty_stack v2);
+ if not (is_empty_stack v1 && is_empty_stack v2) then
+ anomaly "conversion was given ill-typed terms (Sort)";
sort_cmp cv_pb s1 s2 cuniv
| (Meta n, Meta m) ->
if n=m
@@ -313,14 +314,16 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv =
(* other constructors *)
| (FLambda _, FLambda _) ->
- assert (is_empty_stack v1 && is_empty_stack v2);
+ if not (is_empty_stack v1 && is_empty_stack v2) then
+ anomaly "conversion was given ill-typed terms (FLambda)";
let (_,ty1,bd1) = destFLambda mk_clos hd1 in
let (_,ty2,bd2) = destFLambda mk_clos hd2 in
let u1 = ccnv CONV infos el1 el2 ty1 ty2 cuniv in
ccnv CONV infos (el_lift el1) (el_lift el2) bd1 bd2 u1
| (FProd (_,c1,c2), FProd (_,c'1,c'2)) ->
- assert (is_empty_stack v1 && is_empty_stack v2);
+ if not (is_empty_stack v1 && is_empty_stack v2) then
+ anomaly "conversion was given ill-typed terms (FProd)";
(* Luo's system *)
let u1 = ccnv CONV infos el1 el2 c1 c'1 cuniv in
ccnv cv_pb infos (el_lift el1) (el_lift el2) c2 c'2 u1
diff --git a/kernel/reduction.mli b/kernel/reduction.mli
index 28691fa1..83a858cf 100644
--- a/kernel/reduction.mli
+++ b/kernel/reduction.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: reduction.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Term
diff --git a/kernel/retroknowledge.ml b/kernel/retroknowledge.ml
index 69c830e7..799bce47 100644
--- a/kernel/retroknowledge.ml
+++ b/kernel/retroknowledge.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: retroknowledge.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Term
open Names
diff --git a/kernel/retroknowledge.mli b/kernel/retroknowledge.mli
index c0854361..2a4878e9 100644
--- a/kernel/retroknowledge.mli
+++ b/kernel/retroknowledge.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: retroknowledge.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Names
diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml
index f8154f19..dee2f5e8 100644
--- a/kernel/safe_typing.ml
+++ b/kernel/safe_typing.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: safe_typing.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Util
open Names
diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli
index 0443dcf2..446ee75b 100644
--- a/kernel/safe_typing.mli
+++ b/kernel/safe_typing.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: safe_typing.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Names
diff --git a/kernel/sign.ml b/kernel/sign.ml
index 44b35970..0d4887ec 100644
--- a/kernel/sign.ml
+++ b/kernel/sign.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: sign.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Names
open Util
diff --git a/kernel/sign.mli b/kernel/sign.mli
index f470377b..313118e4 100644
--- a/kernel/sign.mli
+++ b/kernel/sign.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: sign.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Names
diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml
index f8cbd840..cbff43ad 100644
--- a/kernel/subtyping.ml
+++ b/kernel/subtyping.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: subtyping.ml 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Util
diff --git a/kernel/subtyping.mli b/kernel/subtyping.mli
index 32bca5df..d3736fd9 100644
--- a/kernel/subtyping.mli
+++ b/kernel/subtyping.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: subtyping.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Univ
diff --git a/kernel/term.ml b/kernel/term.ml
index 4c0a8890..b031f750 100644
--- a/kernel/term.ml
+++ b/kernel/term.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: term.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
(* This module instantiates the structure of generic deBruijn terms to Coq *)
diff --git a/kernel/term.mli b/kernel/term.mli
index f1e78246..f9e11df5 100644
--- a/kernel/term.mli
+++ b/kernel/term.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: term.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Names
diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml
index 8054eff7..8cd9b909 100644
--- a/kernel/term_typing.ml
+++ b/kernel/term_typing.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: term_typing.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Util
open Names
diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli
index b731f813..4d32be1e 100644
--- a/kernel/term_typing.mli
+++ b/kernel/term_typing.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: term_typing.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Names
diff --git a/kernel/type_errors.ml b/kernel/type_errors.ml
index 65a9d76a..033dde90 100644
--- a/kernel/type_errors.ml
+++ b/kernel/type_errors.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: type_errors.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Names
open Term
diff --git a/kernel/type_errors.mli b/kernel/type_errors.mli
index f93ddb6c..38ee5058 100644
--- a/kernel/type_errors.mli
+++ b/kernel/type_errors.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: type_errors.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Names
diff --git a/kernel/typeops.ml b/kernel/typeops.ml
index ee29da42..7527e3e7 100644
--- a/kernel/typeops.ml
+++ b/kernel/typeops.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: typeops.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Util
open Names
diff --git a/kernel/typeops.mli b/kernel/typeops.mli
index a3ec5a64..aaacf3c5 100644
--- a/kernel/typeops.mli
+++ b/kernel/typeops.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: typeops.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Names
diff --git a/kernel/univ.ml b/kernel/univ.ml
index 03550cbd..77c14b10 100644
--- a/kernel/univ.ml
+++ b/kernel/univ.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: univ.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
(* Initial Caml version originates from CoC 4.8 [Dec 1988] *)
(* Extension with algebraic universes by HH [Sep 2001] *)
diff --git a/kernel/univ.mli b/kernel/univ.mli
index d71c4832..da01879c 100644
--- a/kernel/univ.mli
+++ b/kernel/univ.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: univ.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(* Universes. *)
diff --git a/kernel/vm.ml b/kernel/vm.ml
index 35032c6b..ceb8ea9c 100644
--- a/kernel/vm.ml
+++ b/kernel/vm.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: vm.ml 13363 2010-07-30 16:17:24Z barras $ *)
open Names
open Term
@@ -16,7 +16,7 @@ open Cbytecodes
external set_drawinstr : unit -> unit = "coq_set_drawinstr"
(******************************************)
-(* Fonctions en plus du module Obj ********)
+(* Utility Functions about Obj ************)
(******************************************)
external offset_closure : Obj.t -> int -> Obj.t = "coq_offset_closure"
@@ -25,7 +25,7 @@ external offset : Obj.t -> int = "coq_offset"
let accu_tag = 0
(*******************************************)
-(* Initalisation de la machine abstraite ***)
+(* Initalization of the abstract machine ***)
(*******************************************)
external init_vm : unit -> unit = "init_coq_vm"
@@ -36,15 +36,13 @@ external transp_values : unit -> bool = "get_coq_transp_value"
external set_transp_values : bool -> unit = "coq_set_transp_value"
(*******************************************)
-(* Le code machine ************************)
+(* Machine code *** ************************)
(*******************************************)
type tcode
let tcode_of_obj v = ((Obj.obj v):tcode)
let fun_code v = tcode_of_obj (Obj.field (Obj.repr v) 0)
-
-
external mkAccuCode : int -> tcode = "coq_makeaccu"
external mkPopStopCode : int -> tcode = "coq_pushpop"
external mkAccuCond : int -> tcode = "coq_accucond"
@@ -73,12 +71,12 @@ let popstop_code i =
let stop = popstop_code 0
(******************************************************)
-(* Types de donnees abstraites et fonctions associees *)
+(* Abstract data types and utility functions **********)
(******************************************************)
(* Values of the abstract machine *)
let val_of_obj v = ((Obj.obj v):values)
-let crasy_val = (val_of_obj (Obj.repr 0))
+let crazy_val = (val_of_obj (Obj.repr 0))
(* Abstract data *)
type vprod
@@ -99,63 +97,60 @@ type vswitch = {
sw_env : vm_env
}
-(* Representation des types abstraits: *)
-(* + Les produits : *)
+(* Representation of values *)
+(* + Products : *)
(* - vprod = 0_[ dom | codom] *)
(* dom : values, codom : vfun *)
(* *)
-(* + Les fonctions ont deux representations possibles : *)
-(* - fonction non applique : vf = Ct_[ C | fv1 | ... | fvn] *)
+(* + Functions have two representations : *)
+(* - unapplied fun : vf = Ct_[ C | fv1 | ... | fvn] *)
(* C:tcode, fvi : values *)
-(* Remarque : il n'y a pas de difference entre la fct et son *)
-(* environnement. *)
-(* - Application partielle : Ct_[Restart:C| vf | arg1 | ... argn] *)
+(* Remark : a function and its environment is the same value. *)
+(* - partially applied fun : Ct_[Restart:C| vf | arg1 | ... argn] *)
(* *)
-(* + Les points fixes : *)
+(* + Fixpoints : *)
(* - Ct_[C1|Infix_t|C2|...|Infix_t|Cn|fv1|...|fvn] *)
-(* Remarque il n'y a qu'un seul block pour representer tout les *)
-(* points fixes d'une declaration mutuelle, chaque point fixe *)
-(* pointe sur la position de son code dans le block. *)
-(* - L'application partielle d'un point fixe suit le meme schema *)
-(* que celui des fonctions *)
-(* Remarque seul les points fixes qui n'ont pas encore recu leur *)
-(* argument recursif sont encode de cette maniere (si l'argument *)
-(* recursif etait un constructeur le point fixe se serait reduit *)
-(* sinon il est represente par un accumulateur) *)
+(* One single block to represent all of the fixpoints, each fixpoint *)
+(* is the pointer to the field holding the pointer to its code, and *)
+(* the infix tag is used to know where the block starts. *)
+(* - Partial application follows the scheme of partially applied *)
+(* functions. Note: only fixpoints not having been applied to its *)
+(* recursive argument are coded this way. When the rec. arg. is *)
+(* applied, either it's a constructor and the fix reduces, or it's *)
+(* and the fix is coded as an accumulator. *)
(* *)
-(* + Les cofix sont expliques dans cbytegen.ml *)
+(* + Cofixpoints : see cbytegen.ml *)
(* *)
-(* + Les vblock encodent les constructeurs (non constant) de caml, *)
-(* la difference est que leur tag commence a 1 (0 est reserve pour les *)
-(* accumulateurs : accu_tag) *)
+(* + vblock's encode (non constant) constructors as in Ocaml, but *)
+(* starting from 0 up. tag 0 ( = accu_tag) is reserved for *)
+(* accumulators. *)
(* *)
-(* + vm_env est le type des environnement machine (une fct ou un pt fixe) *)
+(* + vm_env is the type of the machine environments (i.e. a function or *)
+(* a fixpoint) *)
(* *)
-(* + Les accumulateurs : At_[accumulate| accu | arg1 | ... | argn ] *)
-(* - representation des [accu] : tag_[....] *)
-(* -- tag <= 2 : encodage du type atom *)
-(* -- 3_[accu|fix_app] : un point fixe bloque par un accu *)
-(* -- 4_[accu|vswitch] : un case bloque par un accu *)
-(* -- 5_[fcofix] : une fonction de cofix *)
-(* -- 6_[fcofix|val] : une fonction de cofix, val represente *)
-(* la valeur de la reduction de la fct applique a arg1 ... argn *)
-(* Le type [arguments] est utiliser de maniere abstraite comme un *)
-(* tableau, il represente la structure de donnee suivante : *)
+(* + Accumulators : At_[accumulate| accu | arg1 | ... | argn ] *)
+(* - representation of [accu] : tag_[....] *)
+(* -- tag <= 2 : encoding atom type (sorts, free vars, etc.) *)
+(* -- 3_[accu|fix_app] : a fixpoint blocked by an accu *)
+(* -- 4_[accu|vswitch] : a match blocked by an accu *)
+(* -- 5_[fcofix] : a cofix function *)
+(* -- 6_[fcofix|val] : a cofix function, val represent the value *)
+(* of the function applied to arg1 ... argn *)
+(* The [arguments] type, which is abstracted as an array, represents : *)
(* tag[ _ | _ |v1|... | vn] *)
-(* Generalement le 1er champs est un pointeur de code *)
+(* Generally the first field is a code pointer. *)
-(* Ne pas changer ce type sans modifier le code C, *)
-(* en particulier le fichier "coq_values.h" *)
+(* Do not edit this type without editing C code, especially "coq_values.h" *)
type atom =
| Aid of id_key
| Aiddef of id_key * values
| Aind of inductive
-(* Les zippers *)
+(* Zippers *)
type zipper =
| Zapp of arguments
- | Zfix of vfix*arguments (* Peut-etre vide *)
+ | Zfix of vfix*arguments (* Possibly empty *)
| Zswitch of vswitch
type stack = zipper list
@@ -193,28 +188,20 @@ let rec whd_accu a stk =
let zswitch = Zswitch (Obj.obj (Obj.field at 1)) in
whd_accu (Obj.field at 0) (zswitch :: stk)
| 5 (* cofix_tag *) ->
+ let vcfx = Obj.obj (Obj.field at 0) in
+ let to_up = Obj.obj a in
begin match stk with
- | [] ->
- let vcfx = Obj.obj (Obj.field at 0) in
- let to_up = Obj.obj a in
- Vcofix(vcfx, to_up, None)
- | [Zapp args] ->
- let vcfx = Obj.obj (Obj.field at 0) in
- let to_up = Obj.obj a in
- Vcofix(vcfx, to_up, Some args)
+ | [] -> Vcofix(vcfx, to_up, None)
+ | [Zapp args] -> Vcofix(vcfx, to_up, Some args)
| _ -> assert false
end
| 6 (* cofix_evaluated_tag *) ->
+ let vcofix = Obj.obj (Obj.field at 0) in
+ let res = Obj.obj a in
begin match stk with
- | [] ->
- let vcofix = Obj.obj (Obj.field at 0) in
- let res = Obj.obj a in
- Vcofix(vcofix, res, None)
- | [Zapp args] ->
- let vcofix = Obj.obj (Obj.field at 0) in
- let res = Obj.obj a in
- Vcofix(vcofix, res, Some args)
- | _ -> assert false
+ | [] -> Vcofix(vcofix, res, None)
+ | [Zapp args] -> Vcofix(vcofix, res, Some args)
+ | _ -> assert false
end
| _ -> assert false
@@ -245,7 +232,7 @@ let whd_val : values -> whd =
(************************************************)
-(* La machine abstraite *************************)
+(* Abstrct machine ******************************)
(************************************************)
(* gestion de la pile *)
@@ -291,7 +278,7 @@ let apply_vstack vf vstk =
end
(**********************************************)
-(* Constructeurs ******************************)
+(* Constructors *******************************)
(**********************************************)
let obj_of_atom : atom -> Obj.t =
@@ -349,11 +336,11 @@ let mkrel_vstack k arity =
let max = k + arity - 1 in
Array.init arity (fun i -> val_of_rel (max - i))
+
(*************************************************)
-(** Operations pour la manipulation des donnees **)
+(** Operations manipulating data types ***********)
(*************************************************)
-
(* Functions over products *)
let dom : vprod -> values = fun p -> val_of_obj (Obj.field (Obj.repr p) 0)
@@ -395,13 +382,13 @@ exception FALSE
let check_fix f1 f2 =
let i1, i2 = current_fix f1, current_fix f2 in
- (* Verification du point de depart *)
+ (* Checking starting point *)
if i1 = i2 then
let fb1,fb2 = first (Obj.repr f1), first (Obj.repr f2) in
let n = Obj.size (last fb1) in
- (* Verification du nombre de definition *)
+ (* Checking number of definitions *)
if n = Obj.size (last fb2) then
- (* Verification des arguments recursifs *)
+ (* Checking recursive arguments *)
try
for i = 0 to n - 1 do
if unsafe_rec_arg fb1 i <> unsafe_rec_arg fb2 i
@@ -439,14 +426,14 @@ let relaccu_code i =
let reduce_fix k vf =
let fb = first (Obj.repr vf) in
- (* calcul des types *)
+ (* computing types *)
let fc_typ = ((Obj.obj (last fb)) : tcode array) in
let ndef = Array.length fc_typ in
let et = offset_closure fb (2*(ndef - 1)) in
let ftyp =
Array.map
- (fun c -> interprete c crasy_val (Obj.magic et) 0) fc_typ in
- (* Construction de l' environnement des corps des points fixes *)
+ (fun c -> interprete c crazy_val (Obj.magic et) 0) fc_typ in
+ (* Construction of the environment of fix bodies *)
let e = Obj.dup fb in
for i = 0 to ndef - 1 do
Obj.set_field e (2 * i) (Obj.repr (relaccu_code (k + i)))
@@ -485,9 +472,10 @@ let reduce_cofix k vcf =
let fc_typ = ((Obj.obj (last (Obj.repr vcf))) : tcode array) in
let ndef = Array.length fc_typ in
let ftyp =
- Array.map (fun c -> interprete c crasy_val (Obj.magic vcf) 0) fc_typ in
- (* Construction de l'environnement des corps des cofix *)
+ (* Evaluate types *)
+ Array.map (fun c -> interprete c crazy_val (Obj.magic vcf) 0) fc_typ in
+ (* Construction of the environment of cofix bodies *)
let e = Obj.dup (Obj.repr vcf) in
for i = 0 to ndef - 1 do
Obj.set_field e (i+1) (Obj.repr (val_of_rel (k+i)))
@@ -522,7 +510,7 @@ let case_info sw = sw.sw_annot.ci
let type_of_switch sw =
push_vstack sw.sw_stk;
- interprete sw.sw_type_code crasy_val sw.sw_env 0
+ interprete sw.sw_type_code crazy_val sw.sw_env 0
let branch_arg k (tag,arity) =
if arity = 0 then ((Obj.magic tag):values)
diff --git a/lib/bigint.ml b/lib/bigint.ml
index 084189a8..b33baa83 100644
--- a/lib/bigint.ml
+++ b/lib/bigint.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: bigint.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
(*i*)
open Pp
diff --git a/lib/bigint.mli b/lib/bigint.mli
index 01bfedac..48e36875 100644
--- a/lib/bigint.mli
+++ b/lib/bigint.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: bigint.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Pp
diff --git a/lib/bstack.ml b/lib/bstack.ml
index 6330afec..4afbe41e 100644
--- a/lib/bstack.ml
+++ b/lib/bstack.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: bstack.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
(* Queues of a given length *)
diff --git a/lib/bstack.mli b/lib/bstack.mli
index 057bace3..b34d18d7 100644
--- a/lib/bstack.mli
+++ b/lib/bstack.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: bstack.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(* Bounded stacks. If the depth is [None], then there is no depth limit. *)
diff --git a/lib/dyn.ml b/lib/dyn.ml
index 09c9a38c..8a2a467a 100644
--- a/lib/dyn.ml
+++ b/lib/dyn.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: dyn.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Util
diff --git a/lib/dyn.mli b/lib/dyn.mli
index 290907b1..512baf7f 100644
--- a/lib/dyn.mli
+++ b/lib/dyn.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: dyn.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(* Dynamics. Use with extreme care. Not for kids. *)
diff --git a/lib/edit.ml b/lib/edit.ml
index 18d8d8dc..edfde186 100644
--- a/lib/edit.ml
+++ b/lib/edit.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: edit.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Pp
open Util
diff --git a/lib/edit.mli b/lib/edit.mli
index 4274846e..3d6f98ab 100644
--- a/lib/edit.mli
+++ b/lib/edit.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: edit.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(* The type of editors.
* An editor is a finite map, ['a -> 'b], which knows how to apply
diff --git a/lib/explore.ml b/lib/explore.ml
index c20726aa..c6a40e04 100644
--- a/lib/explore.ml
+++ b/lib/explore.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: explore.ml 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Format
diff --git a/lib/explore.mli b/lib/explore.mli
index b7fe7a5a..f8180577 100644
--- a/lib/explore.mli
+++ b/lib/explore.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: explore.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*s Search strategies. *)
diff --git a/lib/flags.ml b/lib/flags.ml
index 2961d83f..de70b6a6 100644
--- a/lib/flags.ml
+++ b/lib/flags.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: flags.ml 13358 2010-07-29 23:10:17Z herbelin $ i*)
let with_option o f x =
let old = !o in o:=true;
@@ -35,8 +35,6 @@ let dont_load_proofs = ref false
let raw_print = ref false
-let unicode_syntax = ref false
-
(* Compatibility mode *)
type compat_version = V8_2
diff --git a/lib/flags.mli b/lib/flags.mli
index 87c8e792..75cfc96d 100644
--- a/lib/flags.mli
+++ b/lib/flags.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: flags.mli 13358 2010-07-29 23:10:17Z herbelin $ i*)
(* Global options of the system. *)
@@ -27,8 +27,6 @@ val dont_load_proofs : bool ref
val raw_print : bool ref
-val unicode_syntax : bool ref
-
type compat_version = V8_2
val compat_version : compat_version option ref
val version_strictly_greater : compat_version -> bool
diff --git a/lib/gmap.ml b/lib/gmap.ml
index 41a57276..1544dacc 100644
--- a/lib/gmap.ml
+++ b/lib/gmap.ml
@@ -5,7 +5,7 @@
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: gmap.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
(* Maps using the generic comparison function of ocaml. Code borrowed from
the ocaml standard library (Copyright 1996, INRIA). *)
diff --git a/lib/gmap.mli b/lib/gmap.mli
index 3e125a60..379aa63f 100644
--- a/lib/gmap.mli
+++ b/lib/gmap.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: gmap.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(* Maps using the generic comparison function of ocaml. Same interface as
the module [Map] from the ocaml standard library. *)
diff --git a/lib/gmapl.ml b/lib/gmapl.ml
index 87804bb5..5f539971 100644
--- a/lib/gmapl.ml
+++ b/lib/gmapl.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: gmapl.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Util
diff --git a/lib/gmapl.mli b/lib/gmapl.mli
index 95a80a29..7c5d0ceb 100644
--- a/lib/gmapl.mli
+++ b/lib/gmapl.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: gmapl.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(* Maps from ['a] to lists of ['b]. *)
diff --git a/lib/gset.ml b/lib/gset.ml
index fca46496..dc88127e 100644
--- a/lib/gset.ml
+++ b/lib/gset.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: gset.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
(* Sets using the generic comparison function of ocaml. Code borrowed from
the ocaml standard library. *)
diff --git a/lib/gset.mli b/lib/gset.mli
index 570ce5e0..911ff3f0 100644
--- a/lib/gset.mli
+++ b/lib/gset.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: gset.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(* Sets using the generic comparison function of ocaml. Same interface as
the module [Set] from the ocaml standard library. *)
diff --git a/lib/hashcons.ml b/lib/hashcons.ml
index 6841132e..1ebf8773 100644
--- a/lib/hashcons.ml
+++ b/lib/hashcons.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: hashcons.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
(* Hash consing of datastructures *)
diff --git a/lib/hashcons.mli b/lib/hashcons.mli
index 3fbf3c9b..0ce4d3b9 100644
--- a/lib/hashcons.mli
+++ b/lib/hashcons.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: hashcons.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(* Generic hash-consing. *)
diff --git a/lib/heap.ml b/lib/heap.ml
index 5f70b5f2..47cfb46f 100644
--- a/lib/heap.ml
+++ b/lib/heap.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: heap.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
(*s Heaps *)
diff --git a/lib/heap.mli b/lib/heap.mli
index edafef5d..e46f97ac 100644
--- a/lib/heap.mli
+++ b/lib/heap.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: heap.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(* Heaps *)
diff --git a/lib/option.ml b/lib/option.ml
index e5b9ecd3..850d7306 100644
--- a/lib/option.ml
+++ b/lib/option.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: option.ml 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** Module implementing basic combinators for OCaml option type.
It tries follow closely the style of OCaml standard library.
diff --git a/lib/option.mli b/lib/option.mli
index 03e989d3..c76deb3c 100644
--- a/lib/option.mli
+++ b/lib/option.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: option.mli 13323 2010-07-24 15:57:30Z herbelin $ *)
(** Module implementing basic combinators for OCaml option type.
It tries follow closely the style of OCaml standard library.
diff --git a/lib/pp.ml4 b/lib/pp.ml4
index 0983e5e7..87c12fba 100644
--- a/lib/pp.ml4
+++ b/lib/pp.ml4
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: pp.ml4 13323 2010-07-24 15:57:30Z herbelin $ *)
open Pp_control
diff --git a/lib/pp.mli b/lib/pp.mli
index 03aa1f9c..4b8e5a29 100644
--- a/lib/pp.mli
+++ b/lib/pp.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: pp.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Pp_control
diff --git a/lib/pp_control.ml b/lib/pp_control.ml
index 54e8fa0c..507a54a7 100644
--- a/lib/pp_control.ml
+++ b/lib/pp_control.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: pp_control.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
(* Parameters of pretty-printing *)
diff --git a/lib/pp_control.mli b/lib/pp_control.mli
index c1540e72..bf95bb5e 100644
--- a/lib/pp_control.mli
+++ b/lib/pp_control.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: pp_control.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(* Parameters of pretty-printing. *)
diff --git a/lib/predicate.ml b/lib/predicate.ml
index af66c0f2..506a87c9 100644
--- a/lib/predicate.ml
+++ b/lib/predicate.ml
@@ -10,7 +10,7 @@
(* *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: predicate.ml 12337 2009-09-17 15:58:14Z glondu $ *)
(* Sets over ordered types *)
diff --git a/lib/predicate.mli b/lib/predicate.mli
index 41d5399b..85596fea 100644
--- a/lib/predicate.mli
+++ b/lib/predicate.mli
@@ -1,5 +1,5 @@
-(*i $Id$ i*)
+(*i $Id: predicate.mli 6621 2005-01-21 17:24:37Z herbelin $ i*)
(* Module [Pred]: sets over infinite ordered types with complement. *)
diff --git a/lib/profile.ml b/lib/profile.ml
index b612f31d..87bfe624 100644
--- a/lib/profile.ml
+++ b/lib/profile.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: profile.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Gc
diff --git a/lib/profile.mli b/lib/profile.mli
index bde8587c..e61aba85 100644
--- a/lib/profile.mli
+++ b/lib/profile.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: profile.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*s This program is a small time and allocation profiler for Objective Caml *)
diff --git a/lib/rtree.ml b/lib/rtree.ml
index 55b00a93..a7428e12 100644
--- a/lib/rtree.ml
+++ b/lib/rtree.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: rtree.ml 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Util
diff --git a/lib/rtree.mli b/lib/rtree.mli
index 3013199a..17cccfc8 100644
--- a/lib/rtree.mli
+++ b/lib/rtree.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: rtree.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(* Type of regular tree with nodes labelled by values of type 'a *)
(* The implementation uses de Bruijn indices, so binding capture
diff --git a/lib/system.ml b/lib/system.ml
index 7e7dfbcb..17d211f8 100644
--- a/lib/system.ml
+++ b/lib/system.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: system.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Pp
open Util
diff --git a/lib/system.mli b/lib/system.mli
index 44314c23..971a5c86 100644
--- a/lib/system.mli
+++ b/lib/system.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: system.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*s Files and load paths. Load path entries remember the original root
given by the user. For efficiency, we keep the full path (field
diff --git a/lib/tlm.ml b/lib/tlm.ml
index 098a1247..aad4d363 100644
--- a/lib/tlm.ml
+++ b/lib/tlm.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: tlm.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
type ('a,'b) t = Node of 'b Gset.t * ('a, ('a,'b) t) Gmap.t
diff --git a/lib/tlm.mli b/lib/tlm.mli
index 95a788ff..db3d7dd3 100644
--- a/lib/tlm.mli
+++ b/lib/tlm.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: tlm.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(* Tries. This module implements a data structure [('a,'b) t] mapping lists
of values of type ['a] to sets (as lists) of values of type ['b]. *)
diff --git a/lib/util.ml b/lib/util.ml
index 6d04c3c2..851afc60 100644
--- a/lib/util.ml
+++ b/lib/util.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
-(* $Id$ *)
+(* $Id: util.ml 13357 2010-07-29 22:59:55Z herbelin $ *)
open Pp
@@ -43,6 +43,7 @@ let invalid_arg_loc (loc,s) = Stdpp.raise_with_loc loc (Invalid_argument s)
let located_fold_left f x (_,a) = f x a
let located_iter2 f (_,a) (_,b) = f a b
+let down_located f (_,a) = f a
(* Like Exc_located, but specifies the outermost file read, the filename
associated to the location of the error, and the error itself. *)
@@ -66,6 +67,11 @@ let pi1 (a,_,_) = a
let pi2 (_,a,_) = a
let pi3 (_,_,a) = a
+(* Projection operator *)
+
+let down_fst f x = f (fst x)
+let down_snd f x = f (snd x)
+
(* Characters *)
let is_letter c = (c >= 'a' && c <= 'z') or (c >= 'A' && c <= 'Z')
@@ -700,6 +706,16 @@ let list_split_when p =
in
split_when_loop []
+(* [list_split_by p l] splits [l] into two lists [(l1,l2)] such that elements of
+ [l1] satisfy [p] and elements of [l2] do not *)
+let list_split_by p =
+ let rec split_by_loop = function
+ | [] -> ([],[])
+ | a::l ->
+ let (l1,l2) = split_by_loop l in if p a then (a::l1,l2) else (l1,a::l2)
+ in
+ split_by_loop
+
let rec list_split3 = function
| [] -> ([], [], [])
| (x,y,z)::l ->
@@ -828,6 +844,13 @@ let list_cartesians op init ll =
let list_combinations l = list_cartesians (fun x l -> x::l) [] l
+let rec list_combine3 x y z =
+ match x, y, z with
+ | [], [], [] -> []
+ | (x :: xs), (y :: ys), (z :: zs) ->
+ (x, y, z) :: list_combine3 xs ys zs
+ | _, _, _ -> raise (Invalid_argument "list_combine3")
+
(* Keep only those products that do not return None *)
let rec list_cartesian_filter op l1 l2 =
@@ -1171,6 +1194,12 @@ let iterate_for a b f x =
let rec iterate i v = if i > b then v else iterate (succ i) (f i v) in
iterate a x
+(* Delayed computations *)
+
+type 'a delayed = unit -> 'a
+
+let delayed_force f = f ()
+
(* Misc *)
type ('a,'b) union = Inl of 'a | Inr of 'b
diff --git a/lib/util.mli b/lib/util.mli
index cd8e3135..00c73a1f 100644
--- a/lib/util.mli
+++ b/lib/util.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
-(*i $Id$ i*)
+(*i $Id: util.mli 13357 2010-07-29 22:59:55Z herbelin $ i*)
(*i*)
open Pp
@@ -52,6 +52,7 @@ val invalid_arg_loc : loc * string -> 'a
val join_loc : loc -> loc -> loc
val located_fold_left : ('a -> 'b -> 'a) -> 'a -> 'b located -> 'a
val located_iter2 : ('a -> 'b -> unit) -> 'a located -> 'b located -> unit
+val down_located : ('a -> 'b) -> 'a located -> 'b
(* Like [Exc_located], but specifies the outermost file read, the
input buffer associated to the location of the error (or the module name
@@ -64,6 +65,11 @@ exception Error_in_file of string * (bool * string * loc) * exn
val on_fst : ('a -> 'b) -> 'a * 'c -> 'b * 'c
val on_snd : ('a -> 'b) -> 'c * 'a -> 'c * 'b
+(* Going down pairs *)
+
+val down_fst : ('a -> 'b) -> 'a * 'c -> 'b
+val down_snd : ('a -> 'b) -> 'c * 'a -> 'b
+
(* Mapping under triple *)
val on_pi1 : ('a -> 'b) -> 'a * 'c * 'd -> 'b * 'c * 'd
@@ -170,6 +176,7 @@ val list_merge_uniq : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list
val list_subset : 'a list -> 'a list -> bool
val list_split_at : int -> 'a list -> 'a list*'a list
val list_split_when : ('a -> bool) -> 'a list -> 'a list * 'a list
+val list_split_by : ('a -> bool) -> 'a list -> 'a list * 'a list
val list_split3 : ('a * 'b * 'c) list -> 'a list * 'b list * 'c list
val list_partition_by : ('a -> 'a -> bool) -> 'a list -> 'a list list
val list_firstn : int -> 'a list -> 'a list
@@ -202,7 +209,9 @@ val list_cartesian : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
val list_cartesians : ('a -> 'b -> 'b) -> 'b -> 'a list list -> 'b list
(* list_combinations [[a;b];[c;d]] returns [[a;c];[a;d];[b;c];[b;d]] *)
val list_combinations : 'a list list -> 'a list list
-(* Keep only those products that do not return None *)
+val list_combine3 : 'a list -> 'b list -> 'c list -> ('a * 'b * 'c) list
+
+(** Keep only those products that do not return None *)
val list_cartesian_filter :
('a -> 'b -> 'c option) -> 'a list -> 'b list -> 'c list
val list_cartesians_filter :
@@ -272,7 +281,13 @@ val iterate : ('a -> 'a) -> int -> 'a -> 'a
val repeat : int -> ('a -> unit) -> 'a -> unit
val iterate_for : int -> int -> (int -> 'a -> 'a) -> 'a -> 'a
-(*s Misc. *)
+(** {6 Delayed computations. } *)
+
+type 'a delayed = unit -> 'a
+
+val delayed_force : 'a delayed -> 'a
+
+(** {6 Misc. } *)
type ('a,'b) union = Inl of 'a | Inr of 'b
diff --git a/library/decl_kinds.ml b/library/decl_kinds.ml
index 583ecd6f..0bb052be 100644
--- a/library/decl_kinds.ml
+++ b/library/decl_kinds.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: decl_kinds.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Util
open Libnames
diff --git a/library/decl_kinds.mli b/library/decl_kinds.mli
index 99c07227..2d31932f 100644
--- a/library/decl_kinds.mli
+++ b/library/decl_kinds.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: decl_kinds.mli 13323 2010-07-24 15:57:30Z herbelin $ *)
open Util
open Libnames
diff --git a/library/declare.ml b/library/declare.ml
index 630f28ed..4f5bf2bb 100644
--- a/library/declare.ml
+++ b/library/declare.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: declare.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
(** This module is about the low-level declaration of logical objects *)
diff --git a/library/declare.mli b/library/declare.mli
index dc45cf0e..f2a61180 100644
--- a/library/declare.mli
+++ b/library/declare.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: declare.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Names
diff --git a/library/declaremods.ml b/library/declaremods.ml
index 6a002081..ef8f2ddd 100644
--- a/library/declaremods.ml
+++ b/library/declaremods.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: declaremods.ml 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Pp
open Util
diff --git a/library/declaremods.mli b/library/declaremods.mli
index 5045d110..51455ff6 100644
--- a/library/declaremods.mli
+++ b/library/declaremods.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: declaremods.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Util
diff --git a/library/decls.ml b/library/decls.ml
index db292a7e..83d5ea08 100644
--- a/library/decls.ml
+++ b/library/decls.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: decls.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
(** This module registers tables for some non-logical informations
associated declarations *)
diff --git a/library/decls.mli b/library/decls.mli
index 93979882..0bb66fe5 100644
--- a/library/decls.mli
+++ b/library/decls.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: decls.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Names
open Sign
diff --git a/library/dischargedhypsmap.ml b/library/dischargedhypsmap.ml
index 1fd4d9c3..a8ee5e96 100644
--- a/library/dischargedhypsmap.ml
+++ b/library/dischargedhypsmap.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: dischargedhypsmap.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Util
open Libnames
diff --git a/library/dischargedhypsmap.mli b/library/dischargedhypsmap.mli
index a0198f3e..77bcf2df 100644
--- a/library/dischargedhypsmap.mli
+++ b/library/dischargedhypsmap.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: dischargedhypsmap.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Libnames
diff --git a/library/global.ml b/library/global.ml
index c17e3011..5139c252 100644
--- a/library/global.ml
+++ b/library/global.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: global.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Util
open Names
diff --git a/library/global.mli b/library/global.mli
index 5675cf68..4290aaa0 100644
--- a/library/global.mli
+++ b/library/global.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: global.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Names
diff --git a/library/goptions.ml b/library/goptions.ml
index f35588b5..bfd3b272 100644
--- a/library/goptions.ml
+++ b/library/goptions.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: goptions.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
(* This module manages customization parameters at the vernacular level *)
diff --git a/library/goptions.mli b/library/goptions.mli
index 69b09d48..d2f98cd2 100644
--- a/library/goptions.mli
+++ b/library/goptions.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: goptions.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(* This module manages customization parameters at the vernacular level *)
diff --git a/library/heads.ml b/library/heads.ml
index a8011206..52f98e6d 100644
--- a/library/heads.ml
+++ b/library/heads.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: heads.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Pp
open Util
diff --git a/library/heads.mli b/library/heads.mli
index 6f3117ad..156b1307 100644
--- a/library/heads.mli
+++ b/library/heads.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: heads.mli 13323 2010-07-24 15:57:30Z herbelin $ *)
open Names
open Term
diff --git a/library/impargs.ml b/library/impargs.ml
index 431e694d..2aff1dec 100644
--- a/library/impargs.ml
+++ b/library/impargs.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: impargs.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Util
open Names
diff --git a/library/impargs.mli b/library/impargs.mli
index 219c75c5..1c27d9f5 100644
--- a/library/impargs.mli
+++ b/library/impargs.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: impargs.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Names
diff --git a/library/lib.ml b/library/lib.ml
index efdd0d84..fde67940 100644
--- a/library/lib.ml
+++ b/library/lib.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: lib.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Pp
open Util
diff --git a/library/lib.mli b/library/lib.mli
index 15357708..3abe22ec 100644
--- a/library/lib.mli
+++ b/library/lib.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: lib.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*s This module provides a general mechanism to keep a trace of all operations
diff --git a/library/libnames.ml b/library/libnames.ml
index b544c8f5..d81dc60f 100644
--- a/library/libnames.ml
+++ b/library/libnames.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: libnames.ml 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Pp
open Util
diff --git a/library/libnames.mli b/library/libnames.mli
index 97a49601..5dcb61ea 100644
--- a/library/libnames.mli
+++ b/library/libnames.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: libnames.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Pp
diff --git a/library/libobject.ml b/library/libobject.ml
index 55a9aa08..5c7d27c6 100644
--- a/library/libobject.ml
+++ b/library/libobject.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: libobject.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Util
open Names
diff --git a/library/libobject.mli b/library/libobject.mli
index 212118a8..130708aa 100644
--- a/library/libobject.mli
+++ b/library/libobject.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: libobject.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Names
diff --git a/library/library.ml b/library/library.ml
index c183e86b..c8fd89bf 100644
--- a/library/library.ml
+++ b/library/library.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: library.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Pp
open Util
diff --git a/library/library.mli b/library/library.mli
index 201e5c3a..e835843d 100644
--- a/library/library.mli
+++ b/library/library.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: library.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Util
diff --git a/library/nameops.ml b/library/nameops.ml
index 5649fd2c..fad4f44c 100644
--- a/library/nameops.ml
+++ b/library/nameops.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: nameops.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Pp
open Util
diff --git a/library/nameops.mli b/library/nameops.mli
index a3fc8bdc..91434361 100644
--- a/library/nameops.mli
+++ b/library/nameops.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: nameops.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Names
diff --git a/library/nametab.ml b/library/nametab.ml
index 495c0062..c8d6967c 100644
--- a/library/nametab.ml
+++ b/library/nametab.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: nametab.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Util
open Pp
diff --git a/library/nametab.mli b/library/nametab.mli
index bb0a3323..386f3d55 100644
--- a/library/nametab.mli
+++ b/library/nametab.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: nametab.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Util
diff --git a/library/states.ml b/library/states.ml
index 972d562a..3af2bcd7 100644
--- a/library/states.ml
+++ b/library/states.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: states.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open System
diff --git a/library/states.mli b/library/states.mli
index 35a05e9e..198e1632 100644
--- a/library/states.mli
+++ b/library/states.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: states.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*s States of the system. In that module, we provide functions to get
and set the state of the whole system. Internally, it is done by
diff --git a/library/summary.ml b/library/summary.ml
index 63ce4c27..376f41d7 100644
--- a/library/summary.ml
+++ b/library/summary.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: summary.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Pp
open Util
diff --git a/library/summary.mli b/library/summary.mli
index 8a7f5ed1..00301613 100644
--- a/library/summary.mli
+++ b/library/summary.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: summary.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(* This module registers the declaration of global tables, which will be kept
in synchronization during the various backtracks of the system. *)
diff --git a/parsing/argextend.ml4 b/parsing/argextend.ml4
index 6baff5da..8bc7ad02 100644
--- a/parsing/argextend.ml4
+++ b/parsing/argextend.ml4
@@ -8,7 +8,7 @@
(*i camlp4use: "pa_extend.cmo q_MLast.cmo" i*)
-(* $Id$ *)
+(* $Id: argextend.ml4 13323 2010-07-24 15:57:30Z herbelin $ *)
open Genarg
open Q_util
diff --git a/parsing/egrammar.ml b/parsing/egrammar.ml
index 67492e3e..943a9487 100644
--- a/parsing/egrammar.ml
+++ b/parsing/egrammar.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: egrammar.ml 13329 2010-07-26 11:05:39Z herbelin $ *)
open Pp
open Util
@@ -66,41 +66,52 @@ type grammar_constr_prod_item =
type 'a action_env = 'a list * 'a list list
let make_constr_action
- (f : loc -> constr_expr action_env -> constr_expr) pil =
- let rec make (env,envlist as fullenv : constr_expr action_env) = function
+ (f : loc -> constr_notation_substitution -> constr_expr) pil =
+ let rec make (constrs,constrlists,binders as fullsubst) = function
| [] ->
- Gramext.action (fun loc -> f loc fullenv)
+ Gramext.action (fun loc -> f loc fullsubst)
| (GramConstrTerminal _ | GramConstrNonTerminal (_,None)) :: tl ->
(* parse a non-binding item *)
- Gramext.action (fun _ -> make fullenv tl)
+ Gramext.action (fun _ -> make fullsubst tl)
| GramConstrNonTerminal (typ, Some _) :: tl ->
(* parse a binding non-terminal *)
- (match typ with
- | (ETConstr _| ETOther _) ->
- Gramext.action (fun (v:constr_expr) -> make (v :: env, envlist) tl)
- | ETReference ->
- Gramext.action (fun (v:reference) -> make (CRef v :: env, envlist) tl)
- | ETName ->
- Gramext.action (fun (na:name located) ->
- make (constr_expr_of_name na :: env, envlist) tl)
- | ETBigint ->
- Gramext.action (fun (v:Bigint.bigint) ->
- make (CPrim (dummy_loc,Numeral v) :: env, envlist) tl)
- | ETConstrList (_,n) ->
- Gramext.action (fun (v:constr_expr list) -> make (env, v::envlist) tl)
+ (match typ with
+ | (ETConstr _| ETOther _) ->
+ Gramext.action (fun (v:constr_expr) ->
+ make (v :: constrs, constrlists, binders) tl)
+ | ETReference ->
+ Gramext.action (fun (v:reference) ->
+ make (CRef v :: constrs, constrlists, binders) tl)
+ | ETName ->
+ Gramext.action (fun (na:name located) ->
+ make (constr_expr_of_name na :: constrs, constrlists, binders) tl)
+ | ETBigint ->
+ Gramext.action (fun (v:Bigint.bigint) ->
+ make (CPrim(dummy_loc,Numeral v) :: constrs, constrlists, binders) tl)
+ | ETConstrList (_,n) ->
+ Gramext.action (fun (v:constr_expr list) ->
+ make (constrs, v::constrlists, binders) tl)
+ | ETBinder _ | ETBinderList (true,_) ->
+ Gramext.action (fun (v:local_binder list) ->
+ make (constrs, constrlists, v::binders) tl)
+ | ETBinderList (false,_) ->
+ Gramext.action (fun (v:local_binder list list) ->
+ make (constrs, constrlists, List.flatten v::binders) tl)
| ETPattern ->
failwith "Unexpected entry of type cases pattern")
| GramConstrListMark (n,b) :: tl ->
(* Rebuild expansions of ConstrList *)
- let heads,env = list_chop n env in
- if b then make (env,(heads@List.hd envlist)::List.tl envlist) tl
- else make (env,heads::envlist) tl
+ let heads,constrs = list_chop n constrs in
+ let constrlists =
+ if b then (heads@List.hd constrlists)::List.tl constrlists
+ else heads::constrlists
+ in make (constrs, constrlists, binders) tl
in
- make ([],[]) (List.rev pil)
+ make ([],[],[]) (List.rev pil)
let make_cases_pattern_action
- (f : loc -> cases_pattern_expr action_env -> cases_pattern_expr) pil =
- let rec make (env,envlist as fullenv : cases_pattern_expr action_env) = function
+ (f : loc -> cases_pattern_notation_substitution -> cases_pattern_expr) pil =
+ let rec make (env,envlist as fullenv) = function
| [] ->
Gramext.action (fun loc -> f loc fullenv)
| (GramConstrTerminal _ | GramConstrNonTerminal (_,None)) :: tl ->
@@ -123,7 +134,7 @@ let make_cases_pattern_action
| ETConstrList (_,_) ->
Gramext.action (fun (vl:cases_pattern_expr list) ->
make (env, vl :: envlist) tl)
- | (ETPattern | ETOther _) ->
+ | (ETPattern | ETBinderList _ | ETBinder _ | ETOther _) ->
failwith "Unexpected entry of type cases pattern or other")
| GramConstrListMark (n,b) :: tl ->
(* Rebuild expansions of ConstrList *)
@@ -271,7 +282,10 @@ type notation_grammar =
int * Gramext.g_assoc option * notation * grammar_constr_prod_item list list
type all_grammar_command =
- | Notation of (precedence * tolerability list) * notation_grammar
+ | Notation of
+ (precedence * tolerability list) *
+ notation_var_internalization_type list *
+ notation_grammar
| TacticGrammar of
(string * int * grammar_prod_item list *
(dir_path * Tacexpr.glob_tactic_expr))
@@ -280,14 +294,16 @@ let (grammar_state : all_grammar_command list ref) = ref []
let extend_grammar gram =
(match gram with
- | Notation (_,a) -> extend_constr_notation a
+ | Notation (_,_,a) -> extend_constr_notation a
| TacticGrammar g -> add_tactic_entry g);
grammar_state := gram :: !grammar_state
let recover_notation_grammar ntn prec =
let l = map_succeed (function
- | Notation (prec',(_,_,ntn',_ as x)) when prec = prec' & ntn = ntn' -> x
- | _ -> failwith "") !grammar_state in
+ | Notation (prec',vars,(_,_,ntn',_ as x)) when prec = prec' & ntn = ntn' ->
+ vars, x
+ | _ ->
+ failwith "") !grammar_state in
assert (List.length l = 1);
List.hd l
diff --git a/parsing/egrammar.mli b/parsing/egrammar.mli
index decc263d..f6b9f6ad 100644
--- a/parsing/egrammar.mli
+++ b/parsing/egrammar.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: egrammar.mli 13329 2010-07-26 11:05:39Z herbelin $ i*)
(*i*)
open Util
@@ -48,7 +48,12 @@ type grammar_prod_item =
(* Adding notations *)
type all_grammar_command =
- | Notation of (precedence * tolerability list) * notation_grammar
+ | Notation of
+ (precedence * tolerability list)
+ * notation_var_internalization_type list
+ (** not needed for defining grammar, hosted by egrammar for
+ transmission to interp_aconstr (via recover_notation_grammar) *)
+ * notation_grammar
| TacticGrammar of
(string * int * grammar_prod_item list *
(dir_path * Tacexpr.glob_tactic_expr))
@@ -64,5 +69,8 @@ val extend_vernac_command_grammar :
val get_extend_vernac_grammars :
unit -> (string * grammar_prod_item list list) list
+(** For a declared grammar, returns the rule + the ordered entry types
+ of variables in the rule (for use in the interpretation) *)
val recover_notation_grammar :
- notation -> (precedence * tolerability list) -> notation_grammar
+ notation -> (precedence * tolerability list) ->
+ notation_var_internalization_type list * notation_grammar
diff --git a/parsing/extend.ml b/parsing/extend.ml
index 5e79cbd5..92ca4dd1 100644
--- a/parsing/extend.ml
+++ b/parsing/extend.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: extend.ml 13329 2010-07-26 11:05:39Z herbelin $ i*)
open Util
@@ -45,16 +45,18 @@ type production_level =
type ('lev,'pos) constr_entry_key_gen =
| ETName | ETReference | ETBigint
+ | ETBinder of bool
| ETConstr of ('lev * 'pos)
| ETPattern
| ETOther of string * string
| ETConstrList of ('lev * 'pos) * Token.pattern list
+ | ETBinderList of bool * Token.pattern list
(* Entries level (left-hand-side of grammar rules) *)
type constr_entry_key =
(int,unit) constr_entry_key_gen
-(* Entries used in productions (in right-hand-side of grammar rules) *)
+(* Entries used in productions (in right-hand side of grammar rules) *)
type constr_prod_entry_key =
(production_level,production_position) constr_entry_key_gen
diff --git a/parsing/extend.mli b/parsing/extend.mli
index 5e79cbd5..ad371872 100644
--- a/parsing/extend.mli
+++ b/parsing/extend.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: extend.mli 13329 2010-07-26 11:05:39Z herbelin $ i*)
open Util
@@ -45,10 +45,12 @@ type production_level =
type ('lev,'pos) constr_entry_key_gen =
| ETName | ETReference | ETBigint
+ | ETBinder of bool
| ETConstr of ('lev * 'pos)
| ETPattern
| ETOther of string * string
| ETConstrList of ('lev * 'pos) * Token.pattern list
+ | ETBinderList of bool * Token.pattern list
(* Entries level (left-hand-side of grammar rules) *)
type constr_entry_key =
diff --git a/parsing/extrawit.ml b/parsing/extrawit.ml
index e56c2e12..e12e2593 100644
--- a/parsing/extrawit.ml
+++ b/parsing/extrawit.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: extrawit.ml 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Util
open Genarg
diff --git a/parsing/extrawit.mli b/parsing/extrawit.mli
index 02b71ddc..1a1b6fe4 100644
--- a/parsing/extrawit.mli
+++ b/parsing/extrawit.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: extrawit.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Util
open Genarg
diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4
index bba3d0d6..76b761b1 100644
--- a/parsing/g_constr.ml4
+++ b/parsing/g_constr.ml4
@@ -8,7 +8,7 @@
(*i camlp4use: "pa_extend.cmo" i*)
-(* $Id$ *)
+(* $Id: g_constr.ml4 13359 2010-07-30 08:46:55Z herbelin $ *)
open Pp
open Pcoq
@@ -34,11 +34,6 @@ let mk_cast = function
(c,(_,None)) -> c
| (c,(_,Some ty)) -> CCast(join_loc (constr_loc c) (constr_loc ty), c, CastConv (DEFAULTcast, ty))
-let loc_of_binder_let = function
- | LocalRawAssum ((loc,_)::_,_,_)::_ -> loc
- | LocalRawDef ((loc,_),_)::_ -> loc
- | _ -> dummy_loc
-
let binders_of_lidents l =
List.map (fun (loc, id) ->
LocalRawAssum ([loc, Name id], Default Rawterm.Explicit,
@@ -88,8 +83,8 @@ let lpar_id_coloneq =
| _ -> raise Stream.Failure)
| _ -> raise Stream.Failure)
-let impl_ident =
- Gram.Entry.of_parser "impl_ident"
+let impl_ident_head =
+ Gram.Entry.of_parser "impl_ident_head"
(fun strm ->
match Stream.npeek 1 strm with
| [(_,"{")] ->
@@ -126,13 +121,13 @@ let ident_with =
| _ -> raise Stream.Failure)
| _ -> raise Stream.Failure)
-let aliasvar = function CPatAlias (_, _, id) -> Some (Name id) | _ -> None
+let aliasvar = function CPatAlias (loc, _, id) -> Some (loc,Name id) | _ -> None
GEXTEND Gram
GLOBAL: binder_constr lconstr constr operconstr sort global
constr_pattern lconstr_pattern Constr.ident
- binder binder_let binders_let record_declaration
- binders_let_fixannot typeclass_constraint pattern appl_arg;
+ closed_binder open_binders binder binders binders_fixannot
+ record_declaration typeclass_constraint pattern appl_arg;
Constr.ident:
[ [ id = Prim.ident -> id
@@ -204,7 +199,7 @@ GEXTEND Gram
| "("; c = operconstr LEVEL "200"; ")" ->
(match c with
CPrim (_,Numeral z) when Bigint.is_pos_or_zero z ->
- CNotation(loc,"( _ )",([c],[]))
+ CNotation(loc,"( _ )",([c],[],[]))
| _ -> c)
| "{|"; c = record_declaration; "|}" -> c
| "`{"; c = operconstr LEVEL "200"; "}" ->
@@ -214,14 +209,10 @@ GEXTEND Gram
] ]
;
forall:
- [ [ "forall" -> ()
- | IDENT "Π" -> ()
- ] ]
+ [ [ "forall" -> () ] ]
;
lambda:
- [ [ "fun" -> ()
- | IDENT "λ" -> ()
- ] ]
+ [ [ "fun" -> () ] ]
;
record_declaration:
[ [ fs = LIST1 record_field_declaration SEP ";" -> CRecord (loc, None, fs)
@@ -234,13 +225,13 @@ GEXTEND Gram
(id, Topconstr.abstract_constr_expr c (binders_of_lidents params)) ] ]
;
binder_constr:
- [ [ forall; bl = binder_list; ","; c = operconstr LEVEL "200" ->
+ [ [ forall; bl = open_binders; ","; c = operconstr LEVEL "200" ->
mkCProdN loc bl c
- | lambda; bl = binder_list; [ "=>" | "," ]; c = operconstr LEVEL "200" ->
+ | lambda; bl = open_binders; [ "=>" | "," ]; c = operconstr LEVEL "200" ->
mkCLambdaN loc bl c
- | "let"; id=name; bl = binders_let; ty = type_cstr; ":=";
+ | "let"; id=name; bl = binders; ty = type_cstr; ":=";
c1 = operconstr LEVEL "200"; "in"; c2 = operconstr LEVEL "200" ->
- let loc1 = loc_of_binder_let bl in
+ let loc1 = join_loc (local_binders_loc bl) (constr_loc c1) in
CLetIn(loc,id,mkCLambdaN loc1 bl (mk_cast(c1,ty)),c2)
| "let"; fx = single_fix; "in"; c = operconstr LEVEL "200" ->
let fixp = mk_single_fix fx in
@@ -253,7 +244,7 @@ GEXTEND Gram
po = return_type;
":="; c1 = operconstr LEVEL "200"; "in";
c2 = operconstr LEVEL "200" ->
- CLetTuple (loc,List.map snd lb,po,c1,c2)
+ CLetTuple (loc,lb,po,c1,c2)
| "let"; "'"; p=pattern; ":="; c1 = operconstr LEVEL "200";
"in"; c2 = operconstr LEVEL "200" ->
CCases (loc, LetPatternStyle, None, [(c1,(None,None))], [(loc, [(loc,[p])], c2)])
@@ -298,7 +289,7 @@ GEXTEND Gram
| "cofix" -> false ] ]
;
fix_decl:
- [ [ id=identref; bl=binders_let_fixannot; ty=type_cstr; ":=";
+ [ [ id=identref; bl=binders_fixannot; ty=type_cstr; ":=";
c=operconstr LEVEL "200" ->
(id,fst bl,snd bl,c,ty) ] ]
;
@@ -310,14 +301,14 @@ GEXTEND Gram
[ [ c=operconstr LEVEL "100"; p=pred_pattern -> (c,p) ] ]
;
pred_pattern:
- [ [ ona = OPT ["as"; id=name -> snd id];
+ [ [ ona = OPT ["as"; id=name -> id];
ty = OPT ["in"; t=lconstr -> t] -> (ona,ty) ] ]
;
case_type:
[ [ "return"; ty = operconstr LEVEL "100" -> ty ] ]
;
return_type:
- [ [ a = OPT [ na = OPT["as"; id=name -> snd id];
+ [ [ a = OPT [ na = OPT["as"; na=name -> na];
ty = case_type -> (na,ty) ] ->
match a with
| None -> None, None
@@ -365,15 +356,7 @@ GEXTEND Gram
| n = INT -> CPatPrim (loc, Numeral (Bigint.of_string n))
| s = string -> CPatPrim (loc, String s) ] ]
;
- binder_list:
- [ [ idl=LIST1 name; bl=binders_let ->
- LocalRawAssum (idl,Default Explicit,CHole (loc, Some (Evd.BinderType (snd (List.hd idl)))))::bl
- | idl=LIST1 name; ":"; c=lconstr ->
- [LocalRawAssum (idl,Default Explicit,c)]
- | cl = binders_let -> cl
- ] ]
- ;
- binder_assum:
+ impl_ident_tail:
[ [ "}" -> fun id -> LocalRawAssum([id], Default Implicit, CHole(loc, None))
| idl=LIST1 name; ":"; c=lconstr; "}" ->
(fun id -> LocalRawAssum (id::idl,Default Implicit,c))
@@ -390,47 +373,59 @@ GEXTEND Gram
rel=OPT constr; "}" -> (id, CMeasureRec (m,rel))
] ]
;
- binders_let_fixannot:
- [ [ id=impl_ident; assum=binder_assum; bl = binders_let_fixannot ->
- (assum (loc, Name id) :: fst bl), snd bl
- | f = fixannot -> [], f
- | b = binder_let; bl = binders_let_fixannot -> b @ fst bl, snd bl
- | -> [], (None, CStructRec)
+ binders_fixannot:
+ [ [ id = impl_ident_head; assum = impl_ident_tail; bl = binders_fixannot ->
+ (assum (loc, Name id) :: fst bl), snd bl
+ | f = fixannot -> [], f
+ | b = binder; bl = binders_fixannot -> b @ fst bl, snd bl
+ | -> [], (None, CStructRec)
] ]
;
- binders_let:
- [ [ b = binder_let; bl = binders_let -> b @ bl
- | -> [] ] ]
- ;
- binder_let:
- [ [ id=name ->
- [LocalRawAssum ([id],Default Explicit,CHole (loc, None))]
- | "("; id=name; idl=LIST1 name; ":"; c=lconstr; ")" ->
- [LocalRawAssum (id::idl,Default Explicit,c)]
- | "("; id=name; ":"; c=lconstr; ")" ->
- [LocalRawAssum ([id],Default Explicit,c)]
- | "("; id=name; ":="; c=lconstr; ")" ->
- [LocalRawDef (id,c)]
- | "("; id=name; ":"; t=lconstr; ":="; c=lconstr; ")" ->
- [LocalRawDef (id,CCast (join_loc (constr_loc t) loc,c, CastConv (DEFAULTcast,t)))]
- | "{"; id=name; "}" ->
- [LocalRawAssum ([id],Default Implicit,CHole (loc, None))]
- | "{"; id=name; idl=LIST1 name; ":"; c=lconstr; "}" ->
- [LocalRawAssum (id::idl,Default Implicit,c)]
- | "{"; id=name; ":"; c=lconstr; "}" ->
- [LocalRawAssum ([id],Default Implicit,c)]
- | "{"; id=name; idl=LIST1 name; "}" ->
- List.map (fun id -> LocalRawAssum ([id],Default Implicit,CHole (loc, None))) (id::idl)
- | "`("; tc = LIST1 typeclass_constraint SEP "," ; ")" ->
- List.map (fun (n, b, t) -> LocalRawAssum ([n], Generalized (Implicit, Explicit, b), t)) tc
- | "`{"; tc = LIST1 typeclass_constraint SEP "," ; "}" ->
- List.map (fun (n, b, t) -> LocalRawAssum ([n], Generalized (Implicit, Implicit, b), t)) tc
+ open_binders:
+ (* Same as binders but parentheses around a closed binder are optional if
+ the latter is unique *)
+ [ [ (* open binder *)
+ id = name; idl = LIST0 name; ":"; c = lconstr ->
+ [LocalRawAssum (id::idl,Default Explicit,c)]
+ (* binders factorized with open binder *)
+ | id = name; idl = LIST0 name; bl = binders ->
+ let t = CHole (loc, Some (Evd.BinderType (snd id))) in
+ LocalRawAssum (id::idl,Default Explicit,t)::bl
+ | id1 = name; ".."; id2 = name ->
+ [LocalRawAssum ([id1;(loc,Name ldots_var);id2],
+ Default Explicit,CHole (loc,None))]
+ | bl = closed_binder; bl' = binders ->
+ bl@bl'
] ]
;
+ binders:
+ [ [ l = LIST0 binder -> List.flatten l ] ]
+ ;
binder:
- [ [ id=name -> ([id],Default Explicit,CHole (loc, None))
- | "("; idl=LIST1 name; ":"; c=lconstr; ")" -> (idl,Default Explicit,c)
- | "{"; idl=LIST1 name; ":"; c=lconstr; "}" -> (idl,Default Implicit,c)
+ [ [ id = name -> [LocalRawAssum ([id],Default Explicit,CHole (loc, None))]
+ | bl = closed_binder -> bl ] ]
+ ;
+ closed_binder:
+ [ [ "("; id=name; idl=LIST1 name; ":"; c=lconstr; ")" ->
+ [LocalRawAssum (id::idl,Default Explicit,c)]
+ | "("; id=name; ":"; c=lconstr; ")" ->
+ [LocalRawAssum ([id],Default Explicit,c)]
+ | "("; id=name; ":="; c=lconstr; ")" ->
+ [LocalRawDef (id,c)]
+ | "("; id=name; ":"; t=lconstr; ":="; c=lconstr; ")" ->
+ [LocalRawDef (id,CCast (join_loc (constr_loc t) loc,c, CastConv (DEFAULTcast,t)))]
+ | "{"; id=name; "}" ->
+ [LocalRawAssum ([id],Default Implicit,CHole (loc, None))]
+ | "{"; id=name; idl=LIST1 name; ":"; c=lconstr; "}" ->
+ [LocalRawAssum (id::idl,Default Implicit,c)]
+ | "{"; id=name; ":"; c=lconstr; "}" ->
+ [LocalRawAssum ([id],Default Implicit,c)]
+ | "{"; id=name; idl=LIST1 name; "}" ->
+ List.map (fun id -> LocalRawAssum ([id],Default Implicit,CHole (loc, None))) (id::idl)
+ | "`("; tc = LIST1 typeclass_constraint SEP "," ; ")" ->
+ List.map (fun (n, b, t) -> LocalRawAssum ([n], Generalized (Implicit, Explicit, b), t)) tc
+ | "`{"; tc = LIST1 typeclass_constraint SEP "," ; "}" ->
+ List.map (fun (n, b, t) -> LocalRawAssum ([n], Generalized (Implicit, Implicit, b), t)) tc
] ]
;
typeclass_constraint:
diff --git a/parsing/g_decl_mode.ml4 b/parsing/g_decl_mode.ml4
index c9da8779..0aa8272b 100644
--- a/parsing/g_decl_mode.ml4
+++ b/parsing/g_decl_mode.ml4
@@ -9,7 +9,7 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
(*i camlp4use: "pa_extend.cmo q_MLast.cmo" i*)
-(* $Id$ *)
+(* $Id: g_decl_mode.ml4 13323 2010-07-24 15:57:30Z herbelin $ *)
open Decl_expr
diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4
index d5c8b78b..e0f31b98 100644
--- a/parsing/g_ltac.ml4
+++ b/parsing/g_ltac.ml4
@@ -8,7 +8,7 @@
(*i camlp4use: "pa_extend.cmo" i*)
-(* $Id$ *)
+(* $Id: g_ltac.ml4 13323 2010-07-24 15:57:30Z herbelin $ *)
open Pp
open Util
diff --git a/parsing/g_natsyntax.mli b/parsing/g_natsyntax.mli
index 5ad93c9e..21335332 100644
--- a/parsing/g_natsyntax.mli
+++ b/parsing/g_natsyntax.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: g_natsyntax.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(* Nice syntax for naturals. *)
diff --git a/parsing/g_prim.ml4 b/parsing/g_prim.ml4
index 5c2fadbb..a7ed810d 100644
--- a/parsing/g_prim.ml4
+++ b/parsing/g_prim.ml4
@@ -8,7 +8,7 @@
(*i camlp4use: "pa_extend.cmo" i*)
-(*i $Id$ i*)
+(*i $Id: g_prim.ml4 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Pcoq
open Names
diff --git a/parsing/g_proofs.ml4 b/parsing/g_proofs.ml4
index 779e4b22..df23465e 100644
--- a/parsing/g_proofs.ml4
+++ b/parsing/g_proofs.ml4
@@ -8,7 +8,7 @@
(*i camlp4use: "pa_extend.cmo" i*)
-(* $Id$ *)
+(* $Id: g_proofs.ml4 13323 2010-07-24 15:57:30Z herbelin $ *)
open Pcoq
diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4
index 324119ed..4a1b9c63 100644
--- a/parsing/g_tactic.ml4
+++ b/parsing/g_tactic.ml4
@@ -8,7 +8,7 @@
(*i camlp4use: "pa_extend.cmo" i*)
-(* $Id$ *)
+(* $Id: g_tactic.ml4 13323 2010-07-24 15:57:30Z herbelin $ *)
open Pp
open Pcoq
diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4
index c3ea4d22..1f5a6cf9 100644
--- a/parsing/g_vernac.ml4
+++ b/parsing/g_vernac.ml4
@@ -9,7 +9,7 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
(*i camlp4use: "pa_extend.cmo" i*)
-(* $Id$ *)
+(* $Id: g_vernac.ml4 13332 2010-07-26 22:12:43Z msozeau $ *)
open Pp
@@ -134,9 +134,9 @@ GEXTEND Gram
gallina:
(* Definition, Theorem, Variable, Axiom, ... *)
- [ [ thm = thm_token; id = identref; bl = binders_let; ":"; c = lconstr;
+ [ [ thm = thm_token; id = identref; bl = binders; ":"; c = lconstr;
l = LIST0
- [ "with"; id = identref; bl = binders_let; ":"; c = lconstr ->
+ [ "with"; id = identref; bl = binders; ":"; c = lconstr ->
(Some id,(bl,c,None)) ] ->
VernacStartTheoremProof (thm,(Some id,(bl,c,None))::l, false, no_hook)
| stre = assumption_token; nl = inline; bl = assum_list ->
@@ -170,7 +170,7 @@ GEXTEND Gram
;
gallina_ext:
[ [ b = record_token; infer = infer_token; oc = opt_coercion; name = identref;
- ps = binders_let;
+ ps = binders;
s = OPT [ ":"; s = lconstr -> s ];
cfs = [ ":="; l = constructor_list_or_record_decl -> l
| -> RecordDecl (None, []) ] ->
@@ -231,13 +231,13 @@ GEXTEND Gram
;
(* Simple definitions *)
def_body:
- [ [ bl = binders_let; ":="; red = reduce; c = lconstr ->
+ [ [ bl = binders; ":="; red = reduce; c = lconstr ->
(match c with
CCast(_,c, Rawterm.CastConv (k,t)) -> DefineBody (bl, red, c, Some t)
| _ -> DefineBody (bl, red, c, None))
- | bl = binders_let; ":"; t = lconstr; ":="; red = reduce; c = lconstr ->
+ | bl = binders; ":"; t = lconstr; ":="; red = reduce; c = lconstr ->
DefineBody (bl, red, c, Some t)
- | bl = binders_let; ":"; t = lconstr ->
+ | bl = binders; ":"; t = lconstr ->
ProveBody (bl, t) ] ]
;
reduce:
@@ -254,7 +254,7 @@ GEXTEND Gram
;
(* Inductives and records *)
inductive_definition:
- [ [ id = identref; oc = opt_coercion; indpar = binders_let;
+ [ [ id = identref; oc = opt_coercion; indpar = binders;
c = OPT [ ":"; c = lconstr -> c ];
":="; lc = constructor_list_or_record_decl; ntn = decl_notation ->
(((oc,id),indpar,c,lc),ntn) ] ]
@@ -281,13 +281,13 @@ GEXTEND Gram
(* (co)-fixpoints *)
rec_definition:
[ [ id = identref;
- bl = binders_let_fixannot;
+ bl = binders_fixannot;
ty = type_cstr;
def = OPT [":="; def = lconstr -> def]; ntn = decl_notation ->
let bl, annot = bl in ((id,annot,bl,ty,def),ntn) ] ]
;
corec_definition:
- [ [ id = identref; bl = binders_let; ty = type_cstr;
+ [ [ id = identref; bl = binders; ty = type_cstr;
def = OPT [":="; def = lconstr -> def]; ntn = decl_notation ->
((id,bl,ty,def),ntn) ] ]
;
@@ -305,6 +305,10 @@ GEXTEND Gram
IDENT "Sort"; s = sort-> InductionScheme(true,ind,s)
| IDENT "Minimality"; "for"; ind = smart_global;
IDENT "Sort"; s = sort-> InductionScheme(false,ind,s)
+ | IDENT "Elimination"; "for"; ind = smart_global;
+ IDENT "Sort"; s = sort-> CaseScheme(true,ind,s)
+ | IDENT "Case"; "for"; ind = smart_global;
+ IDENT "Sort"; s = sort-> CaseScheme(false,ind,s)
| IDENT "Equality"; "for" ; ind = smart_global -> EqualityScheme(ind) ] ]
;
(* Various Binders *)
@@ -324,12 +328,12 @@ GEXTEND Gram
[ [ bd = record_binder; ntn = decl_notation -> bd,ntn ] ]
;
record_binder_body:
- [ [ l = binders_let; oc = of_type_with_opt_coercion;
+ [ [ l = binders; oc = of_type_with_opt_coercion;
t = lconstr -> fun id -> (oc,AssumExpr (id,mkCProdN loc l t))
- | l = binders_let; oc = of_type_with_opt_coercion;
+ | l = binders; oc = of_type_with_opt_coercion;
t = lconstr; ":="; b = lconstr -> fun id ->
(oc,DefExpr (id,mkCLambdaN loc l b,Some (mkCProdN loc l t)))
- | l = binders_let; ":="; b = lconstr -> fun id ->
+ | l = binders; ":="; b = lconstr -> fun id ->
match b with
| CCast(_,b, Rawterm.CastConv (_, t)) ->
(false,DefExpr(id,mkCLambdaN loc l b,Some (mkCProdN loc l t)))
@@ -352,7 +356,7 @@ GEXTEND Gram
;
constructor_type:
- [[ l = binders_let;
+ [[ l = binders;
t= [ coe = of_type_with_opt_coercion; c = lconstr ->
fun l id -> (coe,(id,mkCProdN loc l c))
| ->
@@ -527,7 +531,7 @@ GEXTEND Gram
t = class_rawexpr ->
VernacCoercion (use_locality_exp (), ByNotation ntn, s, t)
- | IDENT "Context"; c = binders_let ->
+ | IDENT "Context"; c = binders ->
VernacContext c
| IDENT "Instance"; namesup = instance_name; ":";
@@ -577,7 +581,7 @@ GEXTEND Gram
| IDENT "transparent" -> Conv_oracle.transparent ] ]
;
instance_name:
- [ [ name = identref; sup = OPT binders_let ->
+ [ [ name = identref; sup = OPT binders ->
(let (loc,id) = name in (loc, Name id)),
(Option.default [] sup)
| -> (loc, Anonymous), [] ] ]
@@ -922,6 +926,8 @@ GEXTEND Gram
syntax_extension_type:
[ [ IDENT "ident" -> ETName | IDENT "global" -> ETReference
| IDENT "bigint" -> ETBigint
+ | IDENT "binder" -> ETBinder true
+ | IDENT "closed"; IDENT "binder" -> ETBinder false
] ]
;
opt_scope:
diff --git a/parsing/g_xml.ml4 b/parsing/g_xml.ml4
index b75d55c5..5ad9f664 100644
--- a/parsing/g_xml.ml4
+++ b/parsing/g_xml.ml4
@@ -8,7 +8,7 @@
(*i camlp4use: "pa_extend.cmo" i*)
-(* $Id$ *)
+(* $Id: g_xml.ml4 13323 2010-07-24 15:57:30Z herbelin $ *)
open Pp
open Util
diff --git a/parsing/g_zsyntax.mli b/parsing/g_zsyntax.mli
index 74637969..16b1ba65 100644
--- a/parsing/g_zsyntax.mli
+++ b/parsing/g_zsyntax.mli
@@ -6,6 +6,6 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: g_zsyntax.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(* Nice syntax for integers. *)
diff --git a/parsing/lexer.ml4 b/parsing/lexer.ml4
index 59b1a048..cc48c84f 100644
--- a/parsing/lexer.ml4
+++ b/parsing/lexer.ml4
@@ -10,7 +10,7 @@
(* Add pr_o.cmo to circumvent a useless-warning bug when preprocessed with
* ast-based camlp4 *)
-(*i $Id$ i*)
+(*i $Id: lexer.ml4 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Pp
open Util
diff --git a/parsing/lexer.mli b/parsing/lexer.mli
index 35836f5c..a25774c5 100644
--- a/parsing/lexer.mli
+++ b/parsing/lexer.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: lexer.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Pp
open Util
diff --git a/parsing/pcoq.ml4 b/parsing/pcoq.ml4
index 6a85775d..90a9220f 100644
--- a/parsing/pcoq.ml4
+++ b/parsing/pcoq.ml4
@@ -8,7 +8,7 @@
(*i camlp4use: "pa_extend.cmo pa_macro.cmo" i*)
-(*i $Id$ i*)
+(*i $Id: pcoq.ml4 13329 2010-07-26 11:05:39Z herbelin $ i*)
open Pp
open Util
@@ -313,10 +313,11 @@ module Constr =
let pattern = Gram.Entry.create "constr:pattern"
let constr_pattern = gec_constr "constr_pattern"
let lconstr_pattern = gec_constr "lconstr_pattern"
+ let closed_binder = Gram.Entry.create "constr:closed_binder"
let binder = Gram.Entry.create "constr:binder"
- let binder_let = Gram.Entry.create "constr:binder_let"
- let binders_let = Gram.Entry.create "constr:binders_let"
- let binders_let_fixannot = Gram.Entry.create "constr:binders_let_fixannot"
+ let binders = Gram.Entry.create "constr:binders"
+ let open_binders = Gram.Entry.create "constr:open_binders"
+ let binders_fixannot = Gram.Entry.create "constr:binders_fixannot"
let typeclass_constraint = Gram.Entry.create "constr:typeclass_constraint"
let record_declaration = Gram.Entry.create "constr:record_declaration"
let appl_arg = Gram.Entry.create "constr:appl_arg"
@@ -563,10 +564,15 @@ let compute_entry allow_create adjust forpat = function
else weaken_entry Constr.operconstr),
adjust (n,q), false
| ETName -> weaken_entry Prim.name, None, false
+ | ETBinder true -> anomaly "Should occur only as part of BinderList"
+ | ETBinder false -> weaken_entry Constr.binder, None, false
+ | ETBinderList (true,tkl) ->
+ assert (tkl=[]); weaken_entry Constr.open_binders, None, false
+ | ETBinderList (false,_) -> anomaly "List of entries cannot be registered."
| ETBigint -> weaken_entry Prim.bigint, None, false
| ETReference -> weaken_entry Constr.global, None, false
| ETPattern -> weaken_entry Constr.pattern, None, false
- | ETConstrList _ -> error "List of entries cannot be registered."
+ | ETConstrList _ -> anomaly "List of entries cannot be registered."
| ETOther (u,n) ->
let u = get_univ u in
let e =
@@ -606,6 +612,12 @@ let is_binder_level from e =
ETConstr(NumLevel 200,(BorderProd(Right,_)|InternalProd)) -> true
| _ -> false
+let make_sep_rules tkl =
+ Gramext.srules
+ [List.map (fun x -> Gramext.Stoken x) tkl,
+ List.fold_right (fun _ v -> Gramext.action (fun _ -> v)) tkl
+ (Gramext.action (fun loc -> ()))]
+
let rec symbol_of_constr_prod_entry_key assoc from forpat typ =
if is_binder_level from typ then
if forpat then
@@ -621,10 +633,14 @@ let rec symbol_of_constr_prod_entry_key assoc from forpat typ =
| ETConstrList (typ',tkl) ->
Gramext.Slist1sep
(symbol_of_constr_prod_entry_key assoc from forpat (ETConstr typ'),
- Gramext.srules
- [List.map (fun x -> Gramext.Stoken x) tkl,
- List.fold_right (fun _ v -> Gramext.action (fun _ -> v)) tkl
- (Gramext.action (fun loc -> ()))])
+ make_sep_rules tkl)
+ | ETBinderList (false,[]) ->
+ Gramext.Slist1
+ (symbol_of_constr_prod_entry_key assoc from forpat (ETBinder false))
+ | ETBinderList (false,tkl) ->
+ Gramext.Slist1sep
+ (symbol_of_constr_prod_entry_key assoc from forpat (ETBinder false),
+ make_sep_rules tkl)
| _ ->
match interp_constr_prod_entry_key assoc from forpat typ with
| (eobj,None,_) -> Gramext.Snterm (Gram.Entry.obj eobj)
diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli
index 88bf9c1c..e4566e77 100644
--- a/parsing/pcoq.mli
+++ b/parsing/pcoq.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: pcoq.mli 13329 2010-07-26 11:05:39Z herbelin $ i*)
open Util
open Names
@@ -203,10 +203,11 @@ module Constr :
val pattern : cases_pattern_expr Gram.Entry.e
val constr_pattern : constr_expr Gram.Entry.e
val lconstr_pattern : constr_expr Gram.Entry.e
- val binder : (name located list * binder_kind * constr_expr) Gram.Entry.e
- val binder_let : local_binder list Gram.Entry.e
- val binders_let : local_binder list Gram.Entry.e
- val binders_let_fixannot : (local_binder list * (identifier located option * recursion_order_expr)) Gram.Entry.e
+ val closed_binder : local_binder list Gram.Entry.e
+ val binder : local_binder list Gram.Entry.e (* closed_binder or variable *)
+ val binders : local_binder list Gram.Entry.e
+ val open_binders : local_binder list Gram.Entry.e
+ val binders_fixannot : (local_binder list * (identifier located option * recursion_order_expr)) Gram.Entry.e
val typeclass_constraint : (name located * bool * constr_expr) Gram.Entry.e
val record_declaration : constr_expr Gram.Entry.e
val appl_arg : (constr_expr * explicitation located option) Gram.Entry.e
diff --git a/parsing/ppconstr.ml b/parsing/ppconstr.ml
index fcdc2aee..eef28fcf 100644
--- a/parsing/ppconstr.ml
+++ b/parsing/ppconstr.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: ppconstr.ml 13358 2010-07-29 23:10:17Z herbelin $ *)
(*i*)
open Util
@@ -64,8 +64,8 @@ let prec_of_prim_token = function
open Notation
-let print_hunks n pr (env,envlist) unp =
- let env = ref env and envlist = ref envlist in
+let print_hunks n pr pr_binders (terms,termlists,binders) unp =
+ let env = ref terms and envlist = ref termlists and bll = ref binders in
let pop r = let a = List.hd !r in r := List.tl !r; a in
let rec aux = function
| [] -> mt ()
@@ -76,6 +76,8 @@ let print_hunks n pr (env,envlist) unp =
let pp1 = prlist_with_sep (fun () -> aux sl) (pr (n,prec)) cl in
let pp2 = aux l in
pp1 ++ pp2
+ | UnpBinderListMetaVar (_,isopen,sl) :: l ->
+ let cl = pop bll in pr_binders (fun () -> aux sl) isopen cl ++ aux l
| UnpTerminal s :: l -> str s ++ aux l
| UnpBox (b,sub) :: l ->
(* Keep order: side-effects *)
@@ -85,9 +87,9 @@ let print_hunks n pr (env,envlist) unp =
| UnpCut cut :: l -> ppcmd_of_cut cut ++ aux l in
aux unp
-let pr_notation pr s env =
+let pr_notation pr pr_binders s env =
let unpl, level = find_notation_printing_rule s in
- print_hunks level pr env unpl, level
+ print_hunks level pr pr_binders env unpl, level
let pr_delimiters key strm =
strm ++ str ("%"^key)
@@ -191,7 +193,8 @@ let rec pr_patt sep inh p =
hov 0 (prlist_with_sep pr_bar (pr_patt spc (lpator,L)) pl), lpator
| CPatNotation (_,"( _ )",([p],[])) ->
pr_patt (fun()->str"(") (max_int,E) p ++ str")", latom
- | CPatNotation (_,s,env) -> pr_notation (pr_patt mt) s env
+ | CPatNotation (_,s,(l,ll)) ->
+ pr_notation (pr_patt mt) (fun _ _ _ -> mt()) s (l,ll,[])
| CPatPrim (_,p) -> pr_prim_token p, latom
| CPatDelimiters (_,k,p) -> pr_delimiters k (pr_patt mt lsimple p), 1
in
@@ -254,18 +257,22 @@ let pr_binder_among_many pr_c = function
hov 1 (pr_lname na ++ pr_opt_type pr_c topt ++
str":=" ++ cut() ++ pr_c c)
-let pr_undelimited_binders pr_c =
- prlist_with_sep spc (pr_binder_among_many pr_c)
+let pr_undelimited_binders sep pr_c =
+ prlist_with_sep sep (pr_binder_among_many pr_c)
-let pr_delimited_binders kw pr_c bl =
+let pr_delimited_binders kw sep pr_c bl =
let n = begin_of_binders bl in
match bl with
| [LocalRawAssum (nal,k,t)] ->
pr_com_at n ++ kw() ++ pr_binder false pr_c (nal,k,t)
| LocalRawAssum _ :: _ as bdl ->
- pr_com_at n ++ kw() ++ pr_undelimited_binders pr_c bdl
+ pr_com_at n ++ kw() ++ pr_undelimited_binders sep pr_c bdl
| _ -> assert false
+let pr_binders_gen pr_c sep is_open =
+ if is_open then pr_delimited_binders mt sep pr_c
+ else pr_undelimited_binders sep pr_c
+
let rec extract_prod_binders = function
(* | CLetIn (loc,na,b,c) as x ->
let bl,c = extract_prod_binders c in
@@ -399,7 +406,7 @@ let pr_recursive_decl pr pr_dangling dangling_with_for id bl annot t c =
let pr_body =
if dangling_with_for then pr_dangling else pr in
pr_id id ++ str" " ++
- hov 0 (pr_undelimited_binders (pr ltop) bl ++ annot) ++
+ hov 0 (pr_undelimited_binders spc (pr ltop) bl ++ annot) ++
pr_opt_type_spc pr t ++ str " :=" ++
pr_sep_com (fun () -> brk(1,2)) (pr_body ltop) c
@@ -446,7 +453,7 @@ let tm_clash = function
let pr_asin pr (na,indnalopt) =
(match na with (* Decision of printing "_" or not moved to constrextern.ml *)
- | Some na -> spc () ++ str "as " ++ pr_name na
+ | Some na -> spc () ++ str "as " ++ pr_lname na
| None -> mt ()) ++
(match indnalopt with
| None -> mt ()
@@ -465,7 +472,7 @@ let pr_return_type pr po = pr_case_type pr po
let pr_simple_return_type pr na po =
(match na with
- | Some (Name id) ->
+ | Some (_,Name id) ->
spc () ++ str "as " ++ pr_id id
| _ -> mt ()) ++
pr_case_type pr po
@@ -483,15 +490,11 @@ let pr_app pr a l =
pr (lapp,L) a ++
prlist (fun a -> spc () ++ pr_expl_args pr a) l)
-let pr_forall () =
- if !Flags.unicode_syntax then str"Π" ++ spc ()
- else str"forall" ++ spc ()
+let pr_forall () = str"forall" ++ spc ()
-let pr_fun () =
- if !Flags.unicode_syntax then str"λ" ++ spc ()
- else str"fun" ++ spc ()
+let pr_fun () = str"fun" ++ spc ()
-let pr_fun_sep = lazy (if !Flags.unicode_syntax then str "," else str " =>")
+let pr_fun_sep = str " =>"
let pr_dangling_with_for sep pr inherited a =
@@ -519,16 +522,16 @@ let pr pr sep inherited a =
| CProdN _ ->
let (bl,a) = extract_prod_binders a in
hov 0 (
- hov 2 (pr_delimited_binders pr_forall
+ hov 2 (pr_delimited_binders pr_forall spc
(pr mt ltop) bl) ++
str "," ++ pr spc ltop a),
lprod
| CLambdaN _ ->
let (bl,a) = extract_lam_binders a in
hov 0 (
- hov 2 (pr_delimited_binders pr_fun
+ hov 2 (pr_delimited_binders pr_fun spc
(pr mt ltop) bl) ++
- Lazy.force pr_fun_sep ++ pr spc ltop a),
+ pr_fun_sep ++ pr spc ltop a),
llambda
| CLetIn (_,(_,Name x),(CFix(_,(_,x'),[_])|CCoFix(_,(_,x'),[_]) as fx), b)
when x=x' ->
@@ -599,7 +602,7 @@ let pr pr sep inherited a =
hv 0 (
str "let " ++
hov 0 (str "(" ++
- prlist_with_sep sep_v pr_name nal ++
+ prlist_with_sep sep_v pr_lname nal ++
str ")" ++
pr_simple_return_type (pr mt) na po ++ str " :=" ++
pr spc ltop c ++ str " in") ++
@@ -626,9 +629,10 @@ let pr pr sep inherited a =
| CCast (_,a,CastCoerce) ->
hv 0 (pr mt (lcast,L) a ++ cut () ++ str ":>"),
lcast
- | CNotation (_,"( _ )",([t],[])) ->
+ | CNotation (_,"( _ )",([t],[],[])) ->
pr (fun()->str"(") (max_int,L) t ++ str")", latom
- | CNotation (_,s,env) -> pr_notation (pr mt) s env
+ | CNotation (_,s,env) ->
+ pr_notation (pr mt) (pr_binders_gen (pr mt ltop)) s env
| CGeneralization (_,bk,ak,c) -> pr_generalization bk ak (pr mt lsimple c), latom
| CPrim (_,p) -> pr_prim_token p, prec_of_prim_token p
| CDelimiters (_,sc,a) -> pr_delimiters sc (pr mt lsimple a), 1
@@ -700,7 +704,7 @@ let pr_lconstr_pattern_expr c = !term_pr.pr_lconstr_pattern_expr c
let pr_cases_pattern_expr = pr_patt ltop
-let pr_binders = pr_undelimited_binders (pr ltop)
+let pr_binders = pr_undelimited_binders spc (pr ltop)
let pr_with_occurrences pr occs =
match occs with
diff --git a/parsing/ppconstr.mli b/parsing/ppconstr.mli
index 0d566a5d..1ad110cb 100644
--- a/parsing/ppconstr.mli
+++ b/parsing/ppconstr.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: ppconstr.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Pp
open Environ
diff --git a/parsing/ppdecl_proof.ml b/parsing/ppdecl_proof.ml
index b276444f..275b02df 100644
--- a/parsing/ppdecl_proof.ml
+++ b/parsing/ppdecl_proof.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: ppdecl_proof.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Util
open Pp
diff --git a/parsing/pptactic.ml b/parsing/pptactic.ml
index ba7558f7..f27959c2 100644
--- a/parsing/pptactic.ml
+++ b/parsing/pptactic.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: pptactic.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Pp
open Names
diff --git a/parsing/pptactic.mli b/parsing/pptactic.mli
index 46786997..bb9d8426 100644
--- a/parsing/pptactic.mli
+++ b/parsing/pptactic.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: pptactic.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Pp
open Genarg
diff --git a/parsing/ppvernac.ml b/parsing/ppvernac.ml
index 83fcff7e..ff35be57 100644
--- a/parsing/ppvernac.ml
+++ b/parsing/ppvernac.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: ppvernac.ml 13332 2010-07-26 22:12:43Z msozeau $ *)
open Pp
open Names
@@ -113,7 +113,9 @@ let pr_set_entry_type = function
| ETConstr _ -> str"constr"
| ETOther (_,e) -> str e
| ETBigint -> str "bigint"
- | ETConstrList _ -> failwith "Internal entry type"
+ | ETBinder true -> str "binder"
+ | ETBinder false -> str "closed binder"
+ | ETBinderList _ | ETConstrList _ -> failwith "Internal entry type"
let strip_meta id =
let s = string_of_id id in
@@ -330,6 +332,14 @@ let pr_onescheme (idop,schem) =
hov 0 ((if dep then str"Induction for" else str"Minimality for")
++ spc() ++ pr_smart_global ind) ++ spc() ++
hov 0 (str"Sort" ++ spc() ++ pr_rawsort s)
+ | CaseScheme (dep,ind,s) ->
+ (match idop with
+ | Some id -> hov 0 (pr_lident id ++ str" :=") ++ spc()
+ | None -> spc ()
+ ) ++
+ hov 0 ((if dep then str"Elimination for" else str"Case for")
+ ++ spc() ++ pr_smart_global ind) ++ spc() ++
+ hov 0 (str"Sort" ++ spc() ++ pr_rawsort s)
| EqualityScheme ind ->
(match idop with
| Some id -> hov 0 (pr_lident id ++ str" :=") ++ spc()
diff --git a/parsing/ppvernac.mli b/parsing/ppvernac.mli
index f1322914..dce1bbd7 100644
--- a/parsing/ppvernac.mli
+++ b/parsing/ppvernac.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: ppvernac.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Pp
open Genarg
diff --git a/parsing/prettyp.ml b/parsing/prettyp.ml
index 8f12ec6d..9c39e57e 100644
--- a/parsing/prettyp.ml
+++ b/parsing/prettyp.ml
@@ -10,7 +10,7 @@
* on May-June 2006 for implementation of abstraction of pretty-printing of objects.
*)
-(* $Id$ *)
+(* $Id: prettyp.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Pp
open Util
diff --git a/parsing/prettyp.mli b/parsing/prettyp.mli
index 9cda516e..d7f83b63 100644
--- a/parsing/prettyp.mli
+++ b/parsing/prettyp.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: prettyp.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Pp
diff --git a/parsing/printer.ml b/parsing/printer.ml
index 54d7065c..c9f27678 100644
--- a/parsing/printer.ml
+++ b/parsing/printer.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: printer.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Pp
open Util
diff --git a/parsing/printer.mli b/parsing/printer.mli
index 63493768..a6f73a40 100644
--- a/parsing/printer.mli
+++ b/parsing/printer.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: printer.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Pp
diff --git a/parsing/q_constr.ml4 b/parsing/q_constr.ml4
index 84340cae..fff29083 100644
--- a/parsing/q_constr.ml4
+++ b/parsing/q_constr.ml4
@@ -8,7 +8,7 @@
(*i camlp4use: "pa_extend.cmo q_MLast.cmo" i*)
-(* $Id$ *)
+(* $Id: q_constr.ml4 13323 2010-07-24 15:57:30Z herbelin $ *)
open Rawterm
open Term
diff --git a/parsing/q_coqast.ml4 b/parsing/q_coqast.ml4
index 0f2ef78b..d0afcdd4 100644
--- a/parsing/q_coqast.ml4
+++ b/parsing/q_coqast.ml4
@@ -8,7 +8,7 @@
(*i camlp4use: "q_MLast.cmo pa_macro.cmo" i*)
-(* $Id$ *)
+(* $Id: q_coqast.ml4 13329 2010-07-26 11:05:39Z herbelin $ *)
open Util
open Names
@@ -162,11 +162,10 @@ let rec mlexpr_of_constr = function
| Topconstr.CCases (loc,_,_,_,_) -> failwith "mlexpr_of_constr: TODO"
| Topconstr.CHole (loc, None) -> <:expr< Topconstr.CHole $dloc$ None >>
| Topconstr.CHole (loc, Some _) -> failwith "mlexpr_of_constr: TODO CHole (Some _)"
- | Topconstr.CNotation(_,ntn,subst) ->
+ | Topconstr.CNotation(_,ntn,(subst,substl,[])) ->
<:expr< Topconstr.CNotation $dloc$ $mlexpr_of_string ntn$
- $mlexpr_of_pair
- (mlexpr_of_list mlexpr_of_constr)
- (mlexpr_of_list (mlexpr_of_list mlexpr_of_constr)) subst$ >>
+ ($mlexpr_of_list mlexpr_of_constr subst$,
+ $mlexpr_of_list (mlexpr_of_list mlexpr_of_constr) substl$,[]) >>
| Topconstr.CPatVar (loc,n) ->
<:expr< Topconstr.CPatVar $dloc$ $mlexpr_of_pair mlexpr_of_bool mlexpr_of_ident n$ >>
| _ -> failwith "mlexpr_of_constr: TODO"
diff --git a/parsing/q_util.ml4 b/parsing/q_util.ml4
index a23e4b18..6d6c229c 100644
--- a/parsing/q_util.ml4
+++ b/parsing/q_util.ml4
@@ -8,7 +8,7 @@
(*i camlp4use: "q_MLast.cmo" i*)
-(* $Id$ *)
+(* $Id: q_util.ml4 13323 2010-07-24 15:57:30Z herbelin $ *)
(* This file defines standard combinators to build ml expressions *)
diff --git a/parsing/q_util.mli b/parsing/q_util.mli
index 7617dc53..c55d8482 100644
--- a/parsing/q_util.mli
+++ b/parsing/q_util.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: q_util.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
val patt_of_expr : MLast.expr -> MLast.patt
diff --git a/parsing/tacextend.ml4 b/parsing/tacextend.ml4
index 465465fa..f067fcf3 100644
--- a/parsing/tacextend.ml4
+++ b/parsing/tacextend.ml4
@@ -8,7 +8,7 @@
(*i camlp4use: "pa_extend.cmo q_MLast.cmo" i*)
-(* $Id$ *)
+(* $Id: tacextend.ml4 13323 2010-07-24 15:57:30Z herbelin $ *)
open Util
open Genarg
diff --git a/parsing/tactic_printer.ml b/parsing/tactic_printer.ml
index ff87ac03..3d048c30 100644
--- a/parsing/tactic_printer.ml
+++ b/parsing/tactic_printer.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: tactic_printer.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Pp
open Util
diff --git a/parsing/tactic_printer.mli b/parsing/tactic_printer.mli
index 3584f626..9233233f 100644
--- a/parsing/tactic_printer.mli
+++ b/parsing/tactic_printer.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: tactic_printer.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Pp
diff --git a/parsing/vernacextend.ml4 b/parsing/vernacextend.ml4
index 05c5ef86..95eccfda 100644
--- a/parsing/vernacextend.ml4
+++ b/parsing/vernacextend.ml4
@@ -8,7 +8,7 @@
(*i camlp4use: "pa_extend.cmo q_MLast.cmo" i*)
-(* $Id$ *)
+(* $Id: vernacextend.ml4 13323 2010-07-24 15:57:30Z herbelin $ *)
open Util
open Genarg
diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml
index c2f19c4f..4171aceb 100644
--- a/plugins/cc/ccalgo.ml
+++ b/plugins/cc/ccalgo.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: ccalgo.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
(* This file implements the basic congruence-closure algorithm by *)
(* Downey,Sethi and Tarjan. *)
diff --git a/plugins/cc/ccalgo.mli b/plugins/cc/ccalgo.mli
index 02e03a97..2825be1a 100644
--- a/plugins/cc/ccalgo.mli
+++ b/plugins/cc/ccalgo.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: ccalgo.mli 13323 2010-07-24 15:57:30Z herbelin $ *)
open Util
open Term
diff --git a/plugins/cc/ccproof.ml b/plugins/cc/ccproof.ml
index cb1f4725..5ee17b6e 100644
--- a/plugins/cc/ccproof.ml
+++ b/plugins/cc/ccproof.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: ccproof.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
(* This file uses the (non-compressed) union-find structure to generate *)
(* proof-trees that will be transformed into proof-terms in cctac.ml4 *)
diff --git a/plugins/cc/ccproof.mli b/plugins/cc/ccproof.mli
index 141d2e13..4c75f9b0 100644
--- a/plugins/cc/ccproof.mli
+++ b/plugins/cc/ccproof.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: ccproof.mli 13323 2010-07-24 15:57:30Z herbelin $ *)
open Ccalgo
open Names
diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml
index 2f8a4527..b7358121 100644
--- a/plugins/cc/cctac.ml
+++ b/plugins/cc/cctac.ml
@@ -8,7 +8,7 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
-(* $Id$ *)
+(* $Id: cctac.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
(* This file is the interface between the c-c algorithm and Coq *)
diff --git a/plugins/cc/cctac.mli b/plugins/cc/cctac.mli
index 05200a33..1c07cabf 100644
--- a/plugins/cc/cctac.mli
+++ b/plugins/cc/cctac.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: cctac.mli 13323 2010-07-24 15:57:30Z herbelin $ *)
open Term
open Proof_type
diff --git a/plugins/cc/g_congruence.ml4 b/plugins/cc/g_congruence.ml4
index 722e7fa4..bed77a7b 100644
--- a/plugins/cc/g_congruence.ml4
+++ b/plugins/cc/g_congruence.ml4
@@ -8,7 +8,7 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
-(* $Id$ *)
+(* $Id: g_congruence.ml4 13323 2010-07-24 15:57:30Z herbelin $ *)
open Cctac
open Tactics
diff --git a/plugins/dp/Dp.v b/plugins/dp/Dp.v
index bc7d73f6..5ddc4452 100644
--- a/plugins/dp/Dp.v
+++ b/plugins/dp/Dp.v
@@ -6,7 +6,7 @@ Require Export Classical.
(* Zenon *)
(* Copyright 2004 INRIA *)
-(* $Id$ *)
+(* $Id: Dp.v 12337 2009-09-17 15:58:14Z glondu $ *)
Lemma zenon_nottrue :
(~True -> False).
diff --git a/plugins/dp/g_dp.ml4 b/plugins/dp/g_dp.ml4
index d28873a0..9c61aad5 100644
--- a/plugins/dp/g_dp.ml4
+++ b/plugins/dp/g_dp.ml4
@@ -8,7 +8,7 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
-(* $Id$ *)
+(* $Id: g_dp.ml4 13323 2010-07-24 15:57:30Z herbelin $ *)
open Dp
diff --git a/plugins/dp/zenon.v b/plugins/dp/zenon.v
index 502465c6..f2400a7f 100644
--- a/plugins/dp/zenon.v
+++ b/plugins/dp/zenon.v
@@ -1,5 +1,5 @@
(* Copyright 2004 INRIA *)
-(* $Id$ *)
+(* $Id: zenon.v 11996 2009-03-20 01:22:58Z letouzey $ *)
Require Export Classical.
diff --git a/plugins/extraction/ExtrOcamlBasic.v b/plugins/extraction/ExtrOcamlBasic.v
index c9556972..882bcae9 100644
--- a/plugins/extraction/ExtrOcamlBasic.v
+++ b/plugins/extraction/ExtrOcamlBasic.v
@@ -8,6 +8,8 @@
(** Extraction to Ocaml : use of basic Ocaml types *)
+Scheme Equality for nat.
+
Extract Inductive bool => bool [ true false ].
Extract Inductive option => option [ Some None ].
Extract Inductive unit => unit [ "()" ].
diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml
index 72429055..ca72f873 100644
--- a/plugins/extraction/common.ml
+++ b/plugins/extraction/common.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: common.ml 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Pp
open Util
diff --git a/plugins/extraction/common.mli b/plugins/extraction/common.mli
index 0d2258a8..619cddfb 100644
--- a/plugins/extraction/common.mli
+++ b/plugins/extraction/common.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: common.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Names
open Libnames
diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml
index 36df8d16..58d8fcb1 100644
--- a/plugins/extraction/extract_env.ml
+++ b/plugins/extraction/extract_env.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: extract_env.ml 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Term
open Declarations
diff --git a/plugins/extraction/extract_env.mli b/plugins/extraction/extract_env.mli
index 7520e6c8..b4516898 100644
--- a/plugins/extraction/extract_env.mli
+++ b/plugins/extraction/extract_env.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: extract_env.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*s This module declares the extraction commands. *)
diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml
index f031094a..057057d1 100644
--- a/plugins/extraction/extraction.ml
+++ b/plugins/extraction/extraction.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: extraction.ml 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Util
diff --git a/plugins/extraction/extraction.mli b/plugins/extraction/extraction.mli
index 394e5ab7..0574b009 100644
--- a/plugins/extraction/extraction.mli
+++ b/plugins/extraction/extraction.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: extraction.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*s Extraction from Coq terms to Miniml. *)
diff --git a/plugins/extraction/haskell.ml b/plugins/extraction/haskell.ml
index dd1e7149..57b7c365 100644
--- a/plugins/extraction/haskell.ml
+++ b/plugins/extraction/haskell.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: haskell.ml 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*s Production of Haskell syntax. *)
diff --git a/plugins/extraction/haskell.mli b/plugins/extraction/haskell.mli
index 915b8a95..0b68e73b 100644
--- a/plugins/extraction/haskell.mli
+++ b/plugins/extraction/haskell.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: haskell.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
val haskell_descr : Miniml.language_descr
diff --git a/plugins/extraction/miniml.mli b/plugins/extraction/miniml.mli
index d768ec96..7ff11b90 100644
--- a/plugins/extraction/miniml.mli
+++ b/plugins/extraction/miniml.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: miniml.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*s Target language for extraction: a core ML called MiniML. *)
diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml
index 2c63e588..745a78fe 100644
--- a/plugins/extraction/mlutil.ml
+++ b/plugins/extraction/mlutil.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: mlutil.ml 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Pp
diff --git a/plugins/extraction/mlutil.mli b/plugins/extraction/mlutil.mli
index a692e6d5..d6b85f12 100644
--- a/plugins/extraction/mlutil.mli
+++ b/plugins/extraction/mlutil.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: mlutil.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Util
open Names
diff --git a/plugins/extraction/modutil.ml b/plugins/extraction/modutil.ml
index 8369ba91..15145344 100644
--- a/plugins/extraction/modutil.ml
+++ b/plugins/extraction/modutil.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: modutil.ml 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Names
open Declarations
diff --git a/plugins/extraction/modutil.mli b/plugins/extraction/modutil.mli
index 5a159dc7..bb405d60 100644
--- a/plugins/extraction/modutil.mli
+++ b/plugins/extraction/modutil.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: modutil.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Names
open Declarations
diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml
index ae8ec249..36ca3713 100644
--- a/plugins/extraction/ocaml.ml
+++ b/plugins/extraction/ocaml.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: ocaml.ml 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*s Production of Ocaml syntax. *)
diff --git a/plugins/extraction/ocaml.mli b/plugins/extraction/ocaml.mli
index 646b1c8b..477b4351 100644
--- a/plugins/extraction/ocaml.mli
+++ b/plugins/extraction/ocaml.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: ocaml.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
val ocaml_descr : Miniml.language_descr
diff --git a/plugins/extraction/scheme.ml b/plugins/extraction/scheme.ml
index 82fac0b6..fa293ba1 100644
--- a/plugins/extraction/scheme.ml
+++ b/plugins/extraction/scheme.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: scheme.ml 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*s Production of Scheme syntax. *)
diff --git a/plugins/extraction/scheme.mli b/plugins/extraction/scheme.mli
index 7bb97cf9..e413d31e 100644
--- a/plugins/extraction/scheme.mli
+++ b/plugins/extraction/scheme.mli
@@ -6,6 +6,6 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: scheme.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
val scheme_descr : Miniml.language_descr
diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml
index e33e1e06..fd640388 100644
--- a/plugins/extraction/table.ml
+++ b/plugins/extraction/table.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: table.ml 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Names
open Term
diff --git a/plugins/extraction/table.mli b/plugins/extraction/table.mli
index 96592f19..a3199b50 100644
--- a/plugins/extraction/table.mli
+++ b/plugins/extraction/table.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: table.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Names
open Libnames
diff --git a/plugins/field/LegacyField.v b/plugins/field/LegacyField.v
index b0e1bc97..6c825353 100644
--- a/plugins/field/LegacyField.v
+++ b/plugins/field/LegacyField.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: LegacyField.v 13323 2010-07-24 15:57:30Z herbelin $ *)
Require Export LegacyField_Compl.
Require Export LegacyField_Theory.
diff --git a/plugins/field/LegacyField_Compl.v b/plugins/field/LegacyField_Compl.v
index 6d4e49ab..a3b46900 100644
--- a/plugins/field/LegacyField_Compl.v
+++ b/plugins/field/LegacyField_Compl.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: LegacyField_Compl.v 13323 2010-07-24 15:57:30Z herbelin $ *)
Require Import List.
diff --git a/plugins/field/LegacyField_Tactic.v b/plugins/field/LegacyField_Tactic.v
index 1b04c11a..9c92e38a 100644
--- a/plugins/field/LegacyField_Tactic.v
+++ b/plugins/field/LegacyField_Tactic.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: LegacyField_Tactic.v 13323 2010-07-24 15:57:30Z herbelin $ *)
Require Import List.
Require Import LegacyRing.
diff --git a/plugins/field/LegacyField_Theory.v b/plugins/field/LegacyField_Theory.v
index c7eed29a..2407026f 100644
--- a/plugins/field/LegacyField_Theory.v
+++ b/plugins/field/LegacyField_Theory.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: LegacyField_Theory.v 13323 2010-07-24 15:57:30Z herbelin $ *)
Require Import List.
Require Import Peano_dec.
diff --git a/plugins/field/field.ml4 b/plugins/field/field.ml4
index 6d3cb25c..47f52370 100644
--- a/plugins/field/field.ml4
+++ b/plugins/field/field.ml4
@@ -8,7 +8,7 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
-(* $Id$ *)
+(* $Id: field.ml4 13323 2010-07-24 15:57:30Z herbelin $ *)
open Names
open Pp
diff --git a/plugins/firstorder/formula.ml b/plugins/firstorder/formula.ml
index 93c4504c..d039a930 100644
--- a/plugins/firstorder/formula.ml
+++ b/plugins/firstorder/formula.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: formula.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Hipattern
open Names
diff --git a/plugins/firstorder/formula.mli b/plugins/firstorder/formula.mli
index 558eb876..fbb103c0 100644
--- a/plugins/firstorder/formula.mli
+++ b/plugins/firstorder/formula.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: formula.mli 13323 2010-07-24 15:57:30Z herbelin $ *)
open Term
open Names
diff --git a/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.ml4
index 7451bcd2..19b63407 100644
--- a/plugins/firstorder/g_ground.ml4
+++ b/plugins/firstorder/g_ground.ml4
@@ -8,7 +8,7 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
-(* $Id$ *)
+(* $Id: g_ground.ml4 13344 2010-07-28 15:04:36Z msozeau $ *)
open Formula
open Sequent
@@ -54,7 +54,21 @@ let _=
in
declare_int_option gdopt
-let default_solver=(Tacinterp.interp <:tactic<auto with *>>)
+let (set_default_solver, default_solver, print_default_solver) =
+ Tactic_option.declare_tactic_option ~default:(<:tactic<auto with *>>) "Firstorder default solver"
+
+VERNAC COMMAND EXTEND Firstorder_Set_Solver
+| [ "Set" "Firstorder" "Solver" tactic(t) ] -> [
+ set_default_solver
+ (Vernacexpr.use_section_locality ())
+ (Tacinterp.glob_tactic t) ]
+END
+
+VERNAC COMMAND EXTEND Firstorder_Print_Solver
+| [ "Print" "Firstorder" "Solver" ] -> [
+ Pp.msgnl
+ (Pp.(++) (Pp.str"Firstorder solver tactic is ") (print_default_solver ())) ]
+END
let fail_solver=tclFAIL 0 (Pp.str "GTauto failed")
@@ -65,7 +79,7 @@ let gen_ground_tac flag taco ids bases gl=
let solver=
match taco with
Some tac-> tac
- | None-> default_solver in
+ | None-> snd (default_solver ()) in
let startseq gl=
let seq=empty_seq !ground_depth in
extend_with_auto_hints bases (extend_with_ref_list ids seq gl) gl in
@@ -137,7 +151,7 @@ let default_declarative_automation gls =
(Cctac.congruence_tac !congruence_depth []))
(gen_ground_tac true
(Some (tclTHEN
- default_solver
+ (snd (default_solver ()))
(Cctac.congruence_tac !congruence_depth [])))
[] []) gls
diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml
index 766fa0d3..354bcda2 100644
--- a/plugins/firstorder/ground.ml
+++ b/plugins/firstorder/ground.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: ground.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Formula
open Sequent
diff --git a/plugins/firstorder/ground.mli b/plugins/firstorder/ground.mli
index 3daf66d6..ba8051da 100644
--- a/plugins/firstorder/ground.mli
+++ b/plugins/firstorder/ground.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: ground.mli 13323 2010-07-24 15:57:30Z herbelin $ *)
val ground_tac: Tacmach.tactic ->
(Proof_type.goal Tacmach.sigma -> Sequent.t) -> Tacmach.tactic
diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml
index 7da65f08..714604ae 100644
--- a/plugins/firstorder/instances.ml
+++ b/plugins/firstorder/instances.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: instances.ml 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Formula
open Sequent
diff --git a/plugins/firstorder/instances.mli b/plugins/firstorder/instances.mli
index 49716cc6..8b913719 100644
--- a/plugins/firstorder/instances.mli
+++ b/plugins/firstorder/instances.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: instances.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Term
open Tacmach
diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml
index a35173cd..9cff67dc 100644
--- a/plugins/firstorder/rules.ml
+++ b/plugins/firstorder/rules.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: rules.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Util
open Names
diff --git a/plugins/firstorder/rules.mli b/plugins/firstorder/rules.mli
index 070c1dbe..ec6d2bd0 100644
--- a/plugins/firstorder/rules.mli
+++ b/plugins/firstorder/rules.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: rules.mli 13323 2010-07-24 15:57:30Z herbelin $ *)
open Term
open Tacmach
diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml
index 43be5714..1d439693 100644
--- a/plugins/firstorder/sequent.ml
+++ b/plugins/firstorder/sequent.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: sequent.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Term
open Util
diff --git a/plugins/firstorder/sequent.mli b/plugins/firstorder/sequent.mli
index c310aaff..1232f1e8 100644
--- a/plugins/firstorder/sequent.mli
+++ b/plugins/firstorder/sequent.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: sequent.mli 13323 2010-07-24 15:57:30Z herbelin $ *)
open Term
open Util
diff --git a/plugins/firstorder/unify.ml b/plugins/firstorder/unify.ml
index 27eca654..835b0409 100644
--- a/plugins/firstorder/unify.ml
+++ b/plugins/firstorder/unify.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: unify.ml 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Util
open Formula
diff --git a/plugins/firstorder/unify.mli b/plugins/firstorder/unify.mli
index 1412a23e..af2ce01d 100644
--- a/plugins/firstorder/unify.mli
+++ b/plugins/firstorder/unify.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: unify.mli 13323 2010-07-24 15:57:30Z herbelin $ *)
open Term
diff --git a/plugins/fourier/Fourier.v b/plugins/fourier/Fourier.v
index 2304ddbe..05e85cde 100644
--- a/plugins/fourier/Fourier.v
+++ b/plugins/fourier/Fourier.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: Fourier.v 13323 2010-07-24 15:57:30Z herbelin $ *)
(* "Fourier's method to solve linear inequations/equations systems.".*)
diff --git a/plugins/fourier/Fourier_util.v b/plugins/fourier/Fourier_util.v
index 152bbc04..3cd26cb8 100644
--- a/plugins/fourier/Fourier_util.v
+++ b/plugins/fourier/Fourier_util.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: Fourier_util.v 13323 2010-07-24 15:57:30Z herbelin $ *)
Require Export Rbase.
Comments "Lemmas used by the tactic Fourier".
diff --git a/plugins/fourier/fourier.ml b/plugins/fourier/fourier.ml
index 081246da..16123fd7 100644
--- a/plugins/fourier/fourier.ml
+++ b/plugins/fourier/fourier.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: fourier.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
(* Méthode d'élimination de Fourier *)
(* Référence:
diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml
index 0af2849e..e9392e78 100644
--- a/plugins/fourier/fourierR.ml
+++ b/plugins/fourier/fourierR.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: fourierR.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
diff --git a/plugins/fourier/g_fourier.ml4 b/plugins/fourier/g_fourier.ml4
index c6976ff7..d3b8228d 100644
--- a/plugins/fourier/g_fourier.ml4
+++ b/plugins/fourier/g_fourier.ml4
@@ -8,7 +8,7 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
-(* $Id$ *)
+(* $Id: g_fourier.ml4 13323 2010-07-24 15:57:30Z herbelin $ *)
open FourierR
diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml
index e2cad944..3590e698 100644
--- a/plugins/funind/functional_principles_proofs.ml
+++ b/plugins/funind/functional_principles_proofs.ml
@@ -1345,7 +1345,6 @@ and acc_inv_id = Recdef.acc_inv_id
and ltof_ref = Recdef.ltof_ref
and acc_rel = Recdef.acc_rel
and well_founded = Recdef.well_founded
-and delayed_force = Recdef.delayed_force
and h_intros = Recdef.h_intros
and list_rewrite = Recdef.list_rewrite
and evaluable_of_global_reference = Recdef.evaluable_of_global_reference
diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml
index 38f42844..f5a5fbd4 100644
--- a/plugins/funind/indfun.ml
+++ b/plugins/funind/indfun.ml
@@ -169,9 +169,8 @@ let build_newrecursive
let arityc = Topconstr.prod_constr_expr arityc bl in
let arity = Constrintern.interp_type sigma env0 arityc in
let impl = Constrintern.compute_internalization_data env0 Constrintern.Recursive arity [] in
- (Environ.push_named (recname,None,arity) env, (recname,impl) :: impls))
+ (Environ.push_named (recname,None,arity) env, (recname, impl) :: impls))
(env0,[]) lnameargsardef in
- let rec_impls = Constrintern.set_internalization_env_params rec_impls [] in
let recdef =
(* Declare local notations *)
let fs = States.freeze() in
diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml
index 7b592c2a..9c4cc78a 100644
--- a/plugins/funind/recdef.ml
+++ b/plugins/funind/recdef.ml
@@ -8,7 +8,7 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
-(* $Id$ *)
+(* $Id: recdef.ml 13332 2010-07-26 22:12:43Z msozeau $ *)
open Term
open Termops
@@ -281,8 +281,6 @@ let find_reference sl s =
(List.map id_of_string (List.rev sl)))
(id_of_string s)));;
-let delayed_force f = f ()
-
let le_lt_SS = function () -> (constant ["Recdef"] "le_lt_SS")
let le_lt_n_Sm = function () -> (coq_base_constant "le_lt_n_Sm")
diff --git a/plugins/micromega/g_micromega.ml4 b/plugins/micromega/g_micromega.ml4
index 2296c6e2..3b667bf6 100644
--- a/plugins/micromega/g_micromega.ml4
+++ b/plugins/micromega/g_micromega.ml4
@@ -14,7 +14,7 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
-(* $Id$ *)
+(* $Id: g_micromega.ml4 13323 2010-07-24 15:57:30Z herbelin $ *)
open Quote
open Ring
diff --git a/plugins/nsatz/Nsatz_domain.v b/plugins/nsatz/Nsatz.v
index 5e0ae4ef..aa32b386 100644
--- a/plugins/nsatz/Nsatz_domain.v
+++ b/plugins/nsatz/Nsatz.v
@@ -7,13 +7,14 @@
(************************************************************************)
(*
- Tactic nsatz: proofs of polynomials equalities with variables in R.
- Uses Hilbert Nullstellensatz and Buchberger algorithm.
- Thanks to B.Gregoire for the verification of the certicate
- and L.Thery for help on ring tactic,
- and to B.Barras for modularization of the ocaml code.
- Example: see test-suite/success/Nsatz.v
- L.Pottier, june 2010
+ Tactic nsatz: proofs of polynomials equalities in a domain (ring without zero divisor).
+ Reification is done by type classes, following a technique shown by Mathieu
+Sozeau. Verification of certificate is done by a code written by Benjamin
+Gregoire, following an idea of Laurent Théry.
+
+Examples: see test-suite/success/Nsatz.v
+
+Loïc Pottier, july 2010
*)
Require Import List.
@@ -22,10 +23,10 @@ Require Import BinPos.
Require Import BinList.
Require Import Znumtheory.
Require Import Ring_polynom Ring_tac InitialRing.
+Require Export Morphisms Setoid Bool.
Declare ML Module "nsatz_plugin".
-
Class Zero (A : Type) := {zero : A}.
Notation "0" := zero.
Class One (A : Type) := {one : A}.
@@ -40,25 +41,37 @@ Class Opposite (A : Type) := {opposite : A -> A}.
Notation "- x" := (opposite x).
Class Ring (R:Type) := {
- ring0: R; ring1: R;
- ring_plus: R->R->R; ring_mult: R->R->R;
- ring_sub: R->R->R; ring_opp: R->R;
- ring_ring:
- ring_theory ring0 ring1 ring_plus ring_mult ring_sub
- ring_opp (@eq R)}.
+ ring0: R; ring1: R;
+ ring_plus: R->R->R; ring_mult: R->R->R;
+ ring_sub: R->R->R; ring_opp: R->R;
+ ring_eq : R -> R -> Prop;
+ ring_ring:
+ ring_theory ring0 ring1 ring_plus ring_mult ring_sub
+ ring_opp ring_eq;
+ ring_setoid: Equivalence ring_eq;
+ ring_plus_comp: Proper (ring_eq==>ring_eq==>ring_eq) ring_plus;
+ ring_mult_comp: Proper (ring_eq==>ring_eq==>ring_eq) ring_mult;
+ ring_sub_comp: Proper (ring_eq==>ring_eq==>ring_eq) ring_sub;
+ ring_opp_comp: Proper (ring_eq==>ring_eq) ring_opp
+}.
Class Domain (R : Type) := {
domain_ring:> Ring R;
domain_axiom_product:
- forall x y, ring_mult x y = ring0 -> x = ring0 \/ y = ring0;
- domain_axiom_one_zero: ring1 <> ring0}.
-
-Ltac ring2 := simpl; ring.
+ forall x y, ring_eq (ring_mult x y) ring0 -> (ring_eq x ring0) \/ (ring_eq y ring0);
+ domain_axiom_one_zero: not (ring_eq ring1 ring0)}.
Section domain.
Variable R: Type.
Variable Rd: Domain R.
+
+Existing Instance ring_setoid.
+Existing Instance ring_plus_comp.
+Existing Instance ring_mult_comp.
+Existing Instance ring_sub_comp.
+Existing Instance ring_opp_comp.
+
Add Ring Rr: (@ring_ring R (@domain_ring R Rd)).
Instance zero_ring : Zero R := {zero := ring0}.
@@ -68,24 +81,27 @@ Instance multiplication_ring : Multiplication R := {multiplication x y := ring_m
Instance subtraction_ring : Subtraction R := {subtraction x y := ring_sub x y}.
Instance opposite_ring : Opposite R := {opposite x := ring_opp x}.
-Lemma psos_r1b: forall x y:R, x - y = 0 -> x = y.
-intros x y H; replace x with ((x - y) + y);
- [rewrite H | idtac]; ring2.
-Qed.
+Infix "==" := ring_eq (at level 70, no associativity).
-Lemma psos_r1: forall x y, x = y -> x - y = 0.
-intros x y H; rewrite H; ring2.
+Lemma psos_r1b: forall x y:R, x - y == 0 -> x == y.
+intros x y H; setoid_replace x with ((x - y) + y); simpl;
+ [setoid_rewrite H | idtac]; simpl; ring.
Qed.
+Lemma psos_r1: forall x y, x == y -> x - y == 0.
+intros x y H; simpl; setoid_rewrite H; simpl; ring.
+Qed.
-Lemma nsatzR_diff: forall x y:R, x<>y -> x - y<>0.
+Lemma nsatzR_diff: forall x y:R, not (x == y) -> not (x - y == 0).
intros.
intro; apply H.
-replace x with ((x - y) + y) by ring2.
-rewrite H0; ring2.
+simpl; setoid_replace x with ((x - y) + y). simpl.
+setoid_rewrite H0.
+simpl; ring.
+simpl. simpl; ring.
Qed.
-(* code de Benjamin *)
+(* adpatation du code de Benjamin aux setoides *)
Require Import ZArith.
Definition PolZ := Pol Z.
@@ -129,42 +145,43 @@ Definition PhiR : list R -> PolZ -> R :=
Definition pow (r : R) (n : nat) := pow_N 1 ring_mult r (Nnat.N_of_nat n).
Definition PEevalR : list R -> PEZ -> R :=
- PEeval 0 ring_plus ring_mult ring_sub ring_opp
+ PEeval 0 ring_plus ring_mult ring_sub ring_opp
(gen_phiZ 0 1 ring_plus ring_mult ring_opp)
Nnat.nat_of_N pow.
Lemma P0Z_correct : forall l, PhiR l P0Z = 0.
Proof. trivial. Qed.
-Lemma Rext: ring_eq_ext ring_plus ring_mult ring_opp eq.
-apply mk_reqe. intros. rewrite H; rewrite H0; trivial.
- intros. rewrite H; rewrite H0; trivial.
-intros. rewrite H; trivial. Qed.
-
-Lemma Rset : Setoid_Theory R eq.
-apply Eqsth.
+Lemma Rext: ring_eq_ext ring_plus ring_mult ring_opp ring_eq.
+apply mk_reqe. intros. setoid_rewrite H; rewrite H0; ring.
+ intros. setoid_rewrite H; setoid_rewrite H0; ring.
+intros. setoid_rewrite H; ring. Qed.
+
+Lemma Rset : Setoid_Theory R ring_eq.
+apply ring_setoid.
Qed.
Lemma PolZadd_correct : forall P' P l,
- PhiR l (PolZadd P P') = ((PhiR l P) + (PhiR l P')).
+ PhiR l (PolZadd P P') == ((PhiR l P) + (PhiR l P')).
Proof.
+simpl.
refine (Padd_ok Rset Rext (Rth_ARth Rset Rext (@ring_ring _ (@domain_ring _ Rd)))
(gen_phiZ_morph Rset Rext (@ring_ring _ (@domain_ring _ Rd)))).
Qed.
Lemma PolZmul_correct : forall P P' l,
- PhiR l (PolZmul P P') = ((PhiR l P) * (PhiR l P')).
+ PhiR l (PolZmul P P') == ((PhiR l P) * (PhiR l P')).
Proof.
refine (Pmul_ok Rset Rext (Rth_ARth Rset Rext (@ring_ring _ (@domain_ring _ Rd)))
(gen_phiZ_morph Rset Rext (@ring_ring _ (@domain_ring _ Rd)))).
Qed.
Lemma R_power_theory
- : power_theory 1 ring_mult eq Nnat.nat_of_N pow.
-apply mkpow_th. unfold pow. intros. rewrite Nnat.N_of_nat_of_N. trivial. Qed.
+ : power_theory 1 ring_mult ring_eq Nnat.nat_of_N pow.
+apply mkpow_th. unfold pow. intros. rewrite Nnat.N_of_nat_of_N. ring. Qed.
Lemma norm_correct :
- forall (l : list R) (pe : PEZ), PEevalR l pe = PhiR l (norm pe).
+ forall (l : list R) (pe : PEZ), PEevalR l pe == PhiR l (norm pe).
Proof.
intros;apply (norm_aux_spec Rset Rext (Rth_ARth Rset Rext (@ring_ring _ (@domain_ring _ Rd)))
(gen_phiZ_morph Rset Rext (@ring_ring _ (@domain_ring _ Rd))) R_power_theory)
@@ -174,7 +191,7 @@ Qed.
Lemma PolZeq_correct : forall P P' l,
PolZeq P P' = true ->
- PhiR l P = PhiR l P'.
+ PhiR l P == PhiR l P'.
Proof.
intros;apply
(Peq_ok Rset Rext (gen_phiZ_morph Rset Rext (@ring_ring _ (@domain_ring _ Rd))));trivial.
@@ -183,17 +200,19 @@ Qed.
Fixpoint Cond0 (A:Type) (Interp:A->R) (l:list A) : Prop :=
match l with
| List.nil => True
- | a::l => Interp a = 0 /\ Cond0 A Interp l
+ | a::l => Interp a == 0 /\ Cond0 A Interp l
end.
Lemma mult_l_correct : forall l la lp,
Cond0 PolZ (PhiR l) lp ->
- PhiR l (mult_l la lp) = 0.
+ PhiR l (mult_l la lp) == 0.
Proof.
- induction la;simpl;intros;trivial.
- destruct lp;trivial.
+ induction la;simpl;intros. ring.
+ destruct lp;trivial. simpl. ring.
simpl in H;destruct H.
- rewrite PolZadd_correct, PolZmul_correct, H, IHla;[ring2 | trivial].
+ setoid_rewrite PolZadd_correct.
+ simpl. setoid_rewrite PolZmul_correct. simpl. setoid_rewrite H.
+ setoid_rewrite IHla. unfold zero. simpl. ring. trivial.
Qed.
Lemma compute_list_correct : forall l lla lp,
@@ -209,7 +228,7 @@ Lemma check_correct :
forall l lpe qe certif,
check lpe qe certif = true ->
Cond0 PEZ (PEevalR l) lpe ->
- PEevalR l qe = 0.
+ PEevalR l qe == 0.
Proof.
unfold check;intros l lpe qe (lla, lq) H2 H1.
apply PolZeq_correct with (l:=l) in H2.
@@ -221,53 +240,53 @@ Proof.
rewrite <- norm_correct;auto.
Qed.
-(* fin du code de Benjamin *)
+(* fin *)
-Lemma pow_not_zero: forall p n, pow p n = 0 -> p = 0.
-induction n. unfold pow; simpl. intros. absurd (1 = 0).
+Lemma pow_not_zero: forall p n, pow p n == 0 -> p == 0.
+induction n. unfold pow; simpl. intros. absurd (1 == 0).
simpl. apply domain_axiom_one_zero.
- trivial. replace (pow p (S n)) with (p * (pow p n)). intros.
-case (@domain_axiom_product _ _ _ _ H). trivial. trivial.
-unfold pow; simpl.
-clear IHn. induction n; try ring2. simpl.
- rewrite pow_pos_Psucc. trivial. exact Rset.
- intros. rewrite H; rewrite H0; trivial.
- intros. ring2. intros. ring2. Qed.
+ trivial. setoid_replace (pow p (S n)) with (p * (pow p n)). intros.
+case (@domain_axiom_product _ _ _ _ H). trivial. trivial.
+unfold pow; simpl.
+clear IHn. induction n; simpl; try ring.
+ rewrite pow_pos_Psucc. ring. exact Rset.
+ intros. setoid_rewrite H; setoid_rewrite H0; ring.
+ intros. simpl; ring. intros. simpl; ring. Qed.
-Lemma Rdomain_pow: forall c p r, ~c= 0 -> c * (pow p r)= 0 -> p = ring0.
-intros. case (@domain_axiom_product _ _ _ _ H0). intros; absurd (c = 0); auto.
-intros. apply pow_not_zero with r. trivial. Qed.
+Lemma Rdomain_pow: forall c p r, ~c == ring0 -> ring_mult c (pow p r) == ring0 -> p == ring0.
+intros. case (@domain_axiom_product _ _ _ _ H0). intros; absurd (c == ring0); auto.
+intros. apply pow_not_zero with r. trivial. Qed.
-Definition R2:= 1 + 1.
+Definition R2:= ring_plus ring1 ring1.
Fixpoint IPR p {struct p}: R :=
match p with
- xH => 1
- | xO xH => 1 + 1
- | xO p1 => R2 + (IPR p1)
- | xI xH => 1 + (1 + 1)
- | xI p1 => 1 + (R2 * (IPR p1))
+ xH => ring1
+ | xO xH => ring_plus ring1 ring1
+ | xO p1 => ring_mult R2 (IPR p1)
+ | xI xH => ring_plus ring1 (ring_plus ring1 ring1)
+ | xI p1 => ring_plus ring1 (ring_mult R2 (IPR p1))
end.
Definition IZR1 z :=
- match z with Z0 => 0
+ match z with Z0 => ring0
| Zpos p => IPR p
- | Zneg p => -(IPR p)
+ | Zneg p => ring_opp(IPR p)
end.
Fixpoint interpret3 t fv {struct t}: R :=
match t with
| (PEadd t1 t2) =>
let v1 := interpret3 t1 fv in
- let v2 := interpret3 t2 fv in (v1 + v2)
+ let v2 := interpret3 t2 fv in (ring_plus v1 v2)
| (PEmul t1 t2) =>
let v1 := interpret3 t1 fv in
- let v2 := interpret3 t2 fv in (v1 * v2)
+ let v2 := interpret3 t2 fv in (ring_mult v1 v2)
| (PEsub t1 t2) =>
let v1 := interpret3 t1 fv in
- let v2 := interpret3 t2 fv in (v1 - v2)
+ let v2 := interpret3 t2 fv in (ring_sub v1 v2)
| (PEopp t1) =>
- let v1 := interpret3 t1 fv in (- v1)
+ let v1 := interpret3 t1 fv in (ring_opp v1)
| (PEpow t1 t2) =>
let v1 := interpret3 t1 fv in pow v1 (Nnat.nat_of_N t2)
| (PEc t1) => (IZR1 t1)
@@ -279,14 +298,11 @@ End domain.
Ltac equalities_to_goal :=
lazymatch goal with
- | H: (@eq _ ?x 0) |- _ => try revert H
- | H: (@eq _ 0 ?x) |- _ =>
- try generalize (sym_equal H); clear H
- | H: (@eq _ ?x ?y) |- _ =>
+ | H: (@ring_eq _ _ ?x ?y) |- _ =>
try generalize (@psos_r1 _ _ _ _ H); clear H
end.
-Ltac nsatz_domain_begin tacsimpl:=
+Ltac nsatz_domain_begin tacsimpl :=
intros;
try apply (@psos_r1b _ _);
repeat equalities_to_goal;
@@ -295,7 +311,7 @@ Ltac nsatz_domain_begin tacsimpl:=
Ltac generalise_eq_hyps:=
repeat
(match goal with
- |h : (?p = ?q)|- _ => revert h
+ |h : (@ring_eq _ _ ?p ?q)|- _ => revert h
end).
Ltac lpol_goal t :=
@@ -328,9 +344,13 @@ Ltac rev l :=
| (cons ?x ?l) => let l' := rev l in append1 x l'
end.
-Ltac nsatz_call_n info nparam p rr lp kont :=
+
+
+Ltac nsatz_call_n info nparam p rr lp kont :=
+ (*idtac "Trying power: " rr;*)
let ll := constr:(PEc info :: PEc nparam :: PEpow p rr :: lp) in
- nsatz_compute ll;
+ nsatz_compute ll;
+ (*idtac "done";*)
match goal with
| |- (?c::PEpow _ ?r::?lq0)::?lci0 = _ -> _ =>
intros _;
@@ -344,7 +364,6 @@ Ltac nsatz_call radicalmax info nparam p lp kont :=
lazymatch n with
| 0%N => fail
| _ =>
-(* idtac "Trying power: " n;*)
(let r := eval compute in (Nminus radicalmax (Npred n)) in
nsatz_call_n info nparam p r lp kont) ||
let n' := eval compute in (Npred n) in try_n n'
@@ -368,7 +387,7 @@ Definition li_find_at (R:Type) (b:R) l i `{Cfind_at R b l i} {H:Cclosed_seq (T:=
Class Creify (R:Type) (e:PExpr Z) (l:list R) (b:R) := {}.
Instance Ireify_zero (R:Type) (Rd:Domain R) l : Creify (PEc 0%Z) l ring0.
Instance Ireify_one (R:Type) (Rd:Domain R) l : Creify (PEc 1%Z) l ring1.
-Instance Ireify_plus (R:Type) (Rd:Domain R) e1 l b1 e2 b2 `{Creify R e1 l b1} `{Creify R e2 l b2}
+Instance Ireify_plus (R:Type) (Rd:Domain R) e1 l b1 e2 b2 `{Creify R e1 l b1} `{Creify R e2 l b2}
: Creify (PEadd e1 e2) l (ring_plus b1 b2).
Instance Ireify_mult (R:Type) (Rd:Domain R) e1 l b1 e2 b2 `{Creify R e1 l b1} `{Creify R e2 l b2}
: Creify (PEmul e1 e2) l (ring_mult b1 b2).
@@ -382,7 +401,7 @@ Instance Ireify_var (R:Type) b l i `{Cfind_at R b l i}
Class Creifylist (R:Type) (le:list (PExpr Z)) (l:list R) (lb:list R) := {}.
Instance Creify_nil (R:Type) l : Creifylist nil l (@nil R).
-Instance Creify_cons (R:Type) e1 l b1 le2 lb2 `{Creify R e1 l b1} `{Creifylist R le2 l lb2}
+Instance Creify_cons (R:Type) e1 l b1 le2 lb2 `{Creify R e1 l b1} `{Creifylist R le2 l lb2}
: Creifylist (e1::le2) l (b1::lb2).
Definition li_reifyl (R:Type) le l lb `{Creifylist R le l lb}
@@ -392,29 +411,29 @@ Unset Implicit Arguments.
Ltac lterm_goal g :=
match g with
- ?b1 = ?b2 => constr:(b1::b2::nil)
- | ?b1 = ?b2 -> ?g => let l := lterm_goal g in constr:(b1::b2::l)
+ ring_eq ?b1 ?b2 => constr:(b1::b2::nil)
+ | ring_eq ?b1 ?b2 -> ?g => let l := lterm_goal g in constr:(b1::b2::l)
end.
-Ltac reify_goal l le lb:=
+Ltac reify_goal l le lb Rd:=
match le with
nil => idtac
- | ?e::?le1 =>
+ | ?e::?le1 =>
match lb with
- ?b::?lb1 =>
+ ?b::?lb1 => (* idtac "b="; idtac b;*)
let x := fresh "B" in
set (x:= b) at 1;
- change x with (@interpret3 _ _ e l);
- clear x;
- reify_goal l le1 lb1
+ change x with (@interpret3 _ Rd e l);
+ clear x;
+ reify_goal l le1 lb1 Rd
end
end.
Ltac get_lpol g :=
match g with
- (interpret3 _ _ ?p _) = _ => constr:(p::nil)
- | (interpret3 _ _ ?p _) = _ -> ?g =>
- let l := get_lpol g in constr:(p::l)
+ ring_eq (interpret3 _ _ ?p _) _ => constr:(p::nil)
+ | ring_eq (interpret3 _ _ ?p _) _ -> ?g =>
+ let l := get_lpol g in constr:(p::l)
end.
Ltac nsatz_domain_generic radicalmax info lparam lvar tacsimpl Rd :=
@@ -422,7 +441,7 @@ Ltac nsatz_domain_generic radicalmax info lparam lvar tacsimpl Rd :=
|- ?g => let lb := lterm_goal g in
(*idtac "lb"; idtac lb;*)
match eval red in (li_reifyl (lb:=lb)) with
- | (?fv, ?le) =>
+ | (?fv, ?le) =>
let fv := match lvar with
(@nil _) => fv
| _ => lvar
@@ -431,64 +450,111 @@ Ltac nsatz_domain_generic radicalmax info lparam lvar tacsimpl Rd :=
let nparam := eval compute in (Z_of_nat (List.length lparam)) in
let fv := parametres_en_tete fv lparam in
(*idtac "variables:"; idtac fv;
- idtac "nparam:"; idtac nparam;*)
+ idtac "nparam:"; idtac nparam; *)
match eval red in (li_reifyl (l:=fv) (lb:=lb)) with
- | (?fv, ?le) =>
- idtac "variables:";idtac fv;
- reify_goal fv le lb;
- match goal with
- |- ?g =>
- let lp := get_lpol g in
+ | (?fv, ?le) =>
+ (*idtac "variables:";idtac fv; idtac le; idtac lb;*)
+ reify_goal fv le lb Rd;
+ match goal with
+ |- ?g =>
+ let lp := get_lpol g in
let lpol := eval compute in (List.rev lp) in
(*idtac "polynomes:"; idtac lpol;*)
tacsimpl; intros;
-
+
let SplitPolyList kont :=
match lpol with
| ?p2::?lp2 => kont p2 lp2
| _ => idtac "polynomial not in the ideal"
- end in
- tacsimpl;
+ end in
+ tacsimpl;
SplitPolyList ltac:(fun p lp =>
set (p21:=p) ;
set (lp21:=lp);
(*idtac "lp:"; idtac lp; *)
- nsatz_call radicalmax info nparam p lp ltac:(fun c r lq lci =>
- set (q := PEmul c (PEpow p21 r));
- let Hg := fresh "Hg" in
- assert (Hg:check lp21 q (lci,lq) = true);
+ nsatz_call radicalmax info nparam p lp ltac:(fun c r lq lci =>
+ set (q := PEmul c (PEpow p21 r));
+ let Hg := fresh "Hg" in
+ assert (Hg:check lp21 q (lci,lq) = true);
[ (vm_compute;reflexivity) || idtac "invalid nsatz certificate"
- | let Hg2 := fresh "Hg" in
- assert (Hg2: interpret3 _ _ q fv = ring0);
- [ tacsimpl;
+ | let Hg2 := fresh "Hg" in
+ assert (Hg2: ring_eq (interpret3 _ Rd q fv) ring0);
+ [ tacsimpl;
apply (@check_correct _ Rd fv lp21 q (lci,lq) Hg);
tacsimpl;
repeat (split;[assumption|idtac]); exact I
- | simpl in Hg2; tacsimpl;
- apply Rdomain_pow with (interpret3 _ _ c fv) (Nnat.nat_of_N r); tacsimpl;
- [ apply domain_axiom_one_zero || idtac "could not prove discrimination result"
- | exact Hg2]
+ | simpl in Hg2; tacsimpl;
+ apply Rdomain_pow with (interpret3 _ Rd c fv) (Nnat.nat_of_N r); auto with domain;
+ tacsimpl; apply domain_axiom_one_zero
+ || (simpl) || idtac "could not prove discrimination result"
]
]
-)
+)
)
end end end end .
-Ltac nsatz_domainpv radicalmax info lparam lvar tacsimpl rd:=
- nsatz_domain_begin tacsimpl;
+Ltac nsatz_domainpv pretac radicalmax info lparam lvar tacsimpl rd :=
+ pretac;
+ nsatz_domain_begin tacsimpl; auto with domain;
nsatz_domain_generic radicalmax info lparam lvar tacsimpl rd.
-Ltac nsatz_domain:=
+Ltac nsatz_domain:=
intros;
match goal with
- |- (@eq ?r _ _ ) =>
- let a := constr:(@Ireify_zero _ _ (@nil r)) in
- match a with
- (@Ireify_zero _ ?rd _) =>
- nsatz_domainpv 6%N 1%Z (@nil r) (@nil r) ltac:(simpl) rd
- end
+ |- (@ring_eq _ (@domain_ring ?r ?rd) _ _ ) =>
+ nsatz_domainpv ltac:idtac 6%N 1%Z (@nil r) (@nil r) ltac:(simpl) rd
end.
+(* Dans R *)
+Require Import Reals.
+Require Import RealField.
+
+Instance Rri : Ring R := {
+ ring0 := 0%R;
+ ring1 := 1%R;
+ ring_plus := Rplus;
+ ring_mult := Rmult;
+ ring_sub := Rminus;
+ ring_opp := Ropp;
+ ring_eq := @eq R;
+ ring_ring := RTheory}.
+
+Lemma Raxiom_one_zero: 1%R <> 0%R.
+discrR.
+Qed.
+
+Instance Rdi : Domain R := {
+ domain_ring := Rri;
+ domain_axiom_product := Rmult_integral;
+ domain_axiom_one_zero := Raxiom_one_zero}.
+
+Hint Resolve ring_setoid ring_plus_comp ring_mult_comp ring_sub_comp ring_opp_comp: domain.
+
+Ltac replaceR:=
+replace 0%R with (@ring0 _ (@domain_ring _ Rdi)) in *;[idtac|reflexivity];
+replace 1%R with (@ring1 _ (@domain_ring _ Rdi)) in *;[idtac|reflexivity];
+replace Rplus with (@ring_plus _ (@domain_ring _ Rdi)) in *;[idtac|reflexivity];
+replace Rmult with (@ring_mult _ (@domain_ring _ Rdi)) in *;[idtac|reflexivity];
+replace Rminus with (@ring_sub _ (@domain_ring _ Rdi)) in *;[idtac|reflexivity];
+replace Ropp with (@ring_opp _ (@domain_ring _ Rdi)) in *;[idtac|reflexivity];
+replace (@eq R) with (@ring_eq _ (@domain_ring _ Rdi)) in *;[idtac|reflexivity].
+
+Ltac simplR:=
+ simpl; replaceR.
+
+Ltac pretacR:=
+ replaceR;
+ replace Rri with (@domain_ring _ Rdi) in *; [idtac | reflexivity].
+
+Ltac nsatz_domainR:=
+ nsatz_domainpv ltac:pretacR 6%N 1%Z (@Datatypes.nil R) (@Datatypes.nil R)
+ ltac:simplR Rdi;
+ discrR.
+
+
+Goal forall x y:R, x = y -> (x*x-x+1)%R = ((y*y-y)+1+0)%R.
+nsatz_domainR.
+Qed.
(* Dans Z *)
@@ -498,7 +564,8 @@ Instance Zri : Ring Z := {
ring_plus := Zplus;
ring_mult := Zmult;
ring_sub := Zminus;
- ring_opp := Zopp;
+ ring_opp := Zopp;
+ ring_eq := (@eq Z);
ring_ring := Zth}.
Lemma Zaxiom_one_zero: 1%Z <> 0%Z.
@@ -510,49 +577,87 @@ Instance Zdi : Domain Z := {
domain_axiom_product := Zmult_integral;
domain_axiom_one_zero := Zaxiom_one_zero}.
+Ltac replaceZ :=
+replace 0%Z with (@ring0 _ (@domain_ring _ Zdi)) in *;[idtac|reflexivity];
+replace 1%Z with (@ring1 _ (@domain_ring _ Zdi)) in *;[idtac|reflexivity];
+replace Zplus with (@ring_plus _ (@domain_ring _ Zdi)) in *;[idtac|reflexivity];
+replace Zmult with (@ring_mult _ (@domain_ring _ Zdi)) in *;[idtac|reflexivity];
+replace Zminus with (@ring_sub _ (@domain_ring _ Zdi)) in *;[idtac|reflexivity];
+replace Zopp with (@ring_opp _ (@domain_ring _ Zdi)) in *;[idtac|reflexivity];
+replace (@eq Z) with (@ring_eq _ (@domain_ring _ Zdi)) in *;[idtac|reflexivity].
Ltac simplZ:=
- simpl;
-replace 0%Z with (@ring0 _ (@domain_ring _ Zdi));[idtac|reflexivity];
-replace 1%Z with (@ring1 _ (@domain_ring _ Zdi));[idtac|reflexivity];
-replace Zplus with (@ring_plus _ (@domain_ring _ Zdi));[idtac|reflexivity];
-replace Zmult with (@ring_mult _ (@domain_ring _ Zdi));[idtac|reflexivity];
-replace Zminus with (@ring_sub _ (@domain_ring _ Zdi));[idtac|reflexivity];
-replace Zopp with (@ring_opp _ (@domain_ring _ Zdi));[idtac|reflexivity].
+ simpl; replaceZ.
-Ltac nsatz_domainZ:= nsatz_domainpv 6%N 1%Z (@nil Z) (@nil Z) ltac:simplZ Zdi.
+Ltac pretacZ :=
+replaceZ;
+replace Zri with (@domain_ring _ Zdi) in *; [idtac | reflexivity].
+Ltac nsatz_domainZ:=
+nsatz_domainpv ltac:pretacZ 6%N 1%Z (@Datatypes.nil Z) (@Datatypes.nil Z) ltac:simplZ Zdi.
-(* Dans R *)
-Require Import Reals.
-Require Import RealField.
-Instance Rri : Ring R := {
- ring0 := 0%R;
- ring1 := 1%R;
- ring_plus := Rplus;
- ring_mult := Rmult;
- ring_sub := Rminus;
- ring_opp := Ropp;
- ring_ring := RTheory}.
+(* Dans Q *)
+Require Import QArith.
-Lemma Raxiom_one_zero: 1%R <> 0%R.
-discrR.
+Instance Qri : Ring Q := {
+ ring0 := 0%Q;
+ ring1 := 1%Q;
+ ring_plus := Qplus;
+ ring_mult := Qmult;
+ ring_sub := Qminus;
+ ring_opp := Qopp;
+ ring_eq := Qeq;
+ ring_ring := Qsrt}.
+
+Lemma Qaxiom_one_zero: not (Qeq 1%Q 0%Q).
+discriminate.
Qed.
-Instance Rdi : Domain R := {
- domain_ring := Rri;
- domain_axiom_product := Rmult_integral;
- domain_axiom_one_zero := Raxiom_one_zero}.
+Instance Qdi : Domain Q := {
+ domain_ring := Qri;
+ domain_axiom_product := Qmult_integral;
+ domain_axiom_one_zero := Qaxiom_one_zero}.
+Ltac replaceQ :=
+replace 0%Q with (@ring0 _ (@domain_ring _ Qdi)) in *;[idtac|reflexivity];
+replace 1%Q with (@ring1 _ (@domain_ring _ Qdi)) in *;[idtac|reflexivity];
+replace Qplus with (@ring_plus _ (@domain_ring _ Qdi)) in *;[idtac|reflexivity];
+replace Qmult with (@ring_mult _ (@domain_ring _ Qdi)) in *;[idtac|reflexivity];
+replace Qminus with (@ring_sub _ (@domain_ring _ Qdi)) in *;[idtac|reflexivity];
+replace Qopp with (@ring_opp _ (@domain_ring _ Qdi)) in *;[idtac|reflexivity];
+replace Qeq with (@ring_eq _ (@domain_ring _ Qdi)) in *;[idtac|reflexivity].
-Ltac simplR:=
- simpl;
-replace 0%R with (@ring0 _ (@domain_ring _ Rdi));[idtac|reflexivity];
-replace 1%R with (@ring1 _ (@domain_ring _ Rdi));[idtac|reflexivity];
-replace Rplus with (@ring_plus _ (@domain_ring _ Rdi));[idtac|reflexivity];
-replace Rmult with (@ring_mult _ (@domain_ring _ Rdi));[idtac|reflexivity];
-replace Rminus with (@ring_sub _ (@domain_ring _ Rdi));[idtac|reflexivity];
-replace Ropp with (@ring_opp _ (@domain_ring _ Rdi));[idtac|reflexivity].
-
-Ltac nsatz_domainR:= nsatz_domainpv 6%N 1%Z (@List.nil R) (@List.nil R) ltac:simplR Rdi.
+Ltac simplQ:=
+ simpl; replaceQ.
+
+Ltac pretacQ :=
+replaceQ;
+replace Qri with (@domain_ring _ Qdi) in *; [idtac | reflexivity].
+
+Ltac nsatz_domainQ:=
+nsatz_domainpv ltac:pretacQ 6%N 1%Z (@Datatypes.nil Q) (@Datatypes.nil Q) ltac:simplQ Qdi.
+
+(* tactique générique *)
+
+Ltac nsatz :=
+ intros;
+ match goal with
+ | |- (@eq R _ _) => nsatz_domainR
+ | |- (@eq Z _ _) => nsatz_domainZ
+ | |- (@Qeq _ _) => nsatz_domainQ
+ | |- _ => nsatz_domain
+ end.
+(*
+Goal forall x y:Q, Qeq x y -> Qeq (x*x-x+1)%Q ((y*y-y)+1+0)%Q.
+nsatz.
+Qed.
+
+Goal forall x y:Z, x = y -> (x*x-x+1)%Z = ((y*y-y)+1+0)%Z.
+nsatz.
+Qed.
+
+Goal forall x y:R, x = y -> (x*x-x+1)%R = ((y*y-y)+1+0)%R.
+nsatz.
+Qed.
+*)
diff --git a/plugins/nsatz/NsatzR.v b/plugins/nsatz/NsatzR.v
deleted file mode 100644
index 41e02c76..00000000
--- a/plugins/nsatz/NsatzR.v
+++ /dev/null
@@ -1,407 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-(*
- Tactic nsatz: proofs of polynomials equalities with variables in R.
- Uses Hilbert Nullstellensatz and Buchberger algorithm.
- Thanks to B.Gregoire and L.Thery for help on ring tactic,
- and to B.Barras for modularization of the ocaml code.
- Example: see test-suite/success/Nsatz.v
- L.Pottier, june 2010
-*)
-
-Require Import List.
-Require Import Setoid.
-Require Import BinPos.
-Require Import BinList.
-Require Import Znumtheory.
-Require Import RealField Rdefinitions Rfunctions RIneq DiscrR.
-Require Import Ring_polynom Ring_tac InitialRing.
-
-Declare ML Module "nsatz_plugin".
-
-Local Open Scope R_scope.
-
-Lemma psos_r1b: forall x y, x - y = 0 -> x = y.
-intros x y H; replace x with ((x - y) + y);
- [rewrite H | idtac]; ring.
-Qed.
-
-Lemma psos_r1: forall x y, x = y -> x - y = 0.
-intros x y H; rewrite H; ring.
-Qed.
-
-Lemma nsatzR_not1: forall x y:R, x<>y -> exists z:R, z*(x-y)-1=0.
-intros.
-exists (1/(x-y)).
-field.
-unfold not.
-unfold not in H.
-intros.
-apply H.
-replace x with ((x-y)+y).
-rewrite H0.
-ring.
-ring.
-Qed.
-
-Lemma nsatzR_not1_0: forall x:R, x<>0 -> exists z:R, z*x-1=0.
-intros.
-exists (1/(x)).
-field.
-auto.
-Qed.
-
-
-Ltac equalities_to_goal :=
- lazymatch goal with
- | H: (@eq R ?x 0) |- _ => try revert H
- | H: (@eq R 0 ?x) |- _ =>
- try generalize (sym_equal H); clear H
- | H: (@eq R ?x ?y) |- _ =>
- try generalize (psos_r1 _ _ H); clear H
- end.
-
-Lemma nsatzR_not2: 1<>0.
-auto with *.
-Qed.
-
-Lemma nsatzR_diff: forall x y:R, x<>y -> x-y<>0.
-intros.
-intro; apply H.
-replace x with (x-y+y) by ring.
-rewrite H0; ring.
-Qed.
-
-(* Removes x<>0 from hypothesis *)
-Ltac nsatzR_not_hyp:=
- match goal with
- | H: ?x<>?y |- _ =>
- match y with
- |0 =>
- let H1:=fresh "Hnsatz" in
- let y:=fresh "x" in
- destruct (@nsatzR_not1_0 _ H) as (y,H1); clear H
- |_ => generalize (@nsatzR_diff _ _ H); clear H; intro
- end
- end.
-
-Ltac nsatzR_not_goal :=
- match goal with
- | |- ?x<>?y :> R => red; intro; apply nsatzR_not2
- | |- False => apply nsatzR_not2
- end.
-
-Ltac nsatzR_begin :=
- intros;
- repeat nsatzR_not_hyp;
- try nsatzR_not_goal;
- try apply psos_r1b;
- repeat equalities_to_goal.
-
-(* code de Benjamin *)
-
-Definition PolZ := Pol Z.
-Definition PEZ := PExpr Z.
-
-Definition P0Z : PolZ := @P0 Z 0%Z.
-
-Definition PolZadd : PolZ -> PolZ -> PolZ :=
- @Padd Z 0%Z Zplus Zeq_bool.
-
-Definition PolZmul : PolZ -> PolZ -> PolZ :=
- @Pmul Z 0%Z 1%Z Zplus Zmult Zeq_bool.
-
-Definition PolZeq := @Peq Z Zeq_bool.
-
-Definition norm :=
- @norm_aux Z 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool.
-
-Fixpoint mult_l (la : list PEZ) (lp: list PolZ) : PolZ :=
- match la, lp with
- | a::la, p::lp => PolZadd (PolZmul (norm a) p) (mult_l la lp)
- | _, _ => P0Z
- end.
-
-Fixpoint compute_list (lla: list (list PEZ)) (lp:list PolZ) :=
- match lla with
- | List.nil => lp
- | la::lla => compute_list lla ((mult_l la lp)::lp)
- end.
-
-Definition check (lpe:list PEZ) (qe:PEZ) (certif: list (list PEZ) * list PEZ) :=
- let (lla, lq) := certif in
- let lp := List.map norm lpe in
- PolZeq (norm qe) (mult_l lq (compute_list lla lp)).
-
-
-(* Correction *)
-Definition PhiR : list R -> PolZ -> R :=
- (Pphi 0 Rplus Rmult (gen_phiZ 0 1 Rplus Rmult Ropp)).
-
-Definition PEevalR : list R -> PEZ -> R :=
- PEeval 0 Rplus Rmult Rminus Ropp (gen_phiZ 0 1 Rplus Rmult Ropp)
- Nnat.nat_of_N pow.
-
-Lemma P0Z_correct : forall l, PhiR l P0Z = 0.
-Proof. trivial. Qed.
-
-
-Lemma PolZadd_correct : forall P' P l,
- PhiR l (PolZadd P P') = (PhiR l P + PhiR l P').
-Proof.
- refine (Padd_ok Rset Rext (Rth_ARth Rset Rext (F_R Rfield))
- (gen_phiZ_morph Rset Rext (F_R Rfield))).
-Qed.
-
-Lemma PolZmul_correct : forall P P' l,
- PhiR l (PolZmul P P') = (PhiR l P * PhiR l P').
-Proof.
- refine (Pmul_ok Rset Rext (Rth_ARth Rset Rext (F_R Rfield))
- (gen_phiZ_morph Rset Rext (F_R Rfield))).
-Qed.
-
-Lemma norm_correct :
- forall (l : list R) (pe : PEZ), PEevalR l pe = PhiR l (norm pe).
-Proof.
- intros;apply (norm_aux_spec Rset Rext (Rth_ARth Rset Rext (F_R Rfield))
- (gen_phiZ_morph Rset Rext (F_R Rfield)) R_power_theory) with (lmp:= List.nil).
- compute;trivial.
-Qed.
-
-Lemma PolZeq_correct : forall P P' l,
- PolZeq P P' = true ->
- PhiR l P = PhiR l P'.
-Proof.
- intros;apply
- (Peq_ok Rset Rext (gen_phiZ_morph Rset Rext (F_R Rfield)));trivial.
-Qed.
-
-Fixpoint Cond0 (A:Type) (Interp:A->R) (l:list A) : Prop :=
- match l with
- | List.nil => True
- | a::l => Interp a = 0 /\ Cond0 A Interp l
- end.
-
-Lemma mult_l_correct : forall l la lp,
- Cond0 PolZ (PhiR l) lp ->
- PhiR l (mult_l la lp) = 0.
-Proof.
- induction la;simpl;intros;trivial.
- destruct lp;trivial.
- simpl in H;destruct H.
- rewrite PolZadd_correct, PolZmul_correct, H, IHla;[ring | trivial].
-Qed.
-
-Lemma compute_list_correct : forall l lla lp,
- Cond0 PolZ (PhiR l) lp ->
- Cond0 PolZ (PhiR l) (compute_list lla lp).
-Proof.
- induction lla;simpl;intros;trivial.
- apply IHlla;simpl;split;trivial.
- apply mult_l_correct;trivial.
-Qed.
-
-Lemma check_correct :
- forall l lpe qe certif,
- check lpe qe certif = true ->
- Cond0 PEZ (PEevalR l) lpe ->
- PEevalR l qe = 0.
-Proof.
- unfold check;intros l lpe qe (lla, lq) H2 H1.
- apply PolZeq_correct with (l:=l) in H2.
- rewrite norm_correct, H2.
- apply mult_l_correct.
- apply compute_list_correct.
- clear H2 lq lla qe;induction lpe;simpl;trivial.
- simpl in H1;destruct H1.
- rewrite <- norm_correct;auto.
-Qed.
-
-(* fin du code de Benjamin *)
-
-Lemma nsatzR_l3:forall c p r, ~c=0 -> c*p^r=0 -> p=0.
-intros.
-elim (Rmult_integral _ _ H0);intros.
- absurd (c=0);auto.
-
- clear H0; induction r; simpl in *.
- contradict H1; discrR.
-
- elim (Rmult_integral _ _ H1); auto.
-Qed.
-
-
-Ltac generalise_eq_hyps:=
- repeat
- (match goal with
- |h : (?p = ?q)|- _ => revert h
- end).
-
-Ltac lpol_goal t :=
- match t with
- | ?a = 0 -> ?b =>
- let r:= lpol_goal b in
- constr:(a::r)
- | ?a = 0 => constr:(a::nil)
- end.
-
-Fixpoint IPR p {struct p}: R :=
- match p with
- xH => 1
- | xO xH => 1 + 1
- | xO p1 => 2 * (IPR p1)
- | xI xH => 1 + (1 + 1)
- | xI p1 => 1 + 2 * (IPR p1)
- end.
-
-Definition IZR1 z :=
- match z with Z0 => 0
- | Zpos p => IPR p
- | Zneg p => -(IPR p)
- end.
-
-Fixpoint interpret3 t fv {struct t}: R :=
- match t with
- | (PEadd t1 t2) =>
- let v1 := interpret3 t1 fv in
- let v2 := interpret3 t2 fv in (v1 + v2)
- | (PEmul t1 t2) =>
- let v1 := interpret3 t1 fv in
- let v2 := interpret3 t2 fv in (v1 * v2)
- | (PEsub t1 t2) =>
- let v1 := interpret3 t1 fv in
- let v2 := interpret3 t2 fv in (v1 - v2)
- | (PEopp t1) =>
- let v1 := interpret3 t1 fv in (-v1)
- | (PEpow t1 t2) =>
- let v1 := interpret3 t1 fv in v1 ^(Nnat.nat_of_N t2)
- | (PEc t1) => (IZR1 t1)
- | (PEX n) => List.nth (pred (nat_of_P n)) fv 0
- end.
-
-(* lp est incluse dans fv. La met en tete. *)
-
-Ltac parametres_en_tete fv lp :=
- match fv with
- | (@nil _) => lp
- | (@cons _ ?x ?fv1) =>
- let res := AddFvTail x lp in
- parametres_en_tete fv1 res
- end.
-
-Ltac append1 a l :=
- match l with
- | (@nil _) => constr:(cons a l)
- | (cons ?x ?l) => let l' := append1 a l in constr:(cons x l')
- end.
-
-Ltac rev l :=
- match l with
- |(@nil _) => l
- | (cons ?x ?l) => let l' := rev l in append1 x l'
- end.
-
-
-Ltac nsatz_call_n info nparam p rr lp kont :=
- nsatz_compute (PEc info :: PEc nparam :: PEpow p rr :: lp);
- match goal with
- | |- (?c::PEpow _ ?r::?lq0)::?lci0 = _ -> _ =>
- intros _;
- set (lci:=lci0);
- set (lq:=lq0);
- kont c rr lq lci
- end.
-
-Ltac nsatz_call radicalmax info nparam p lp kont :=
- let rec try_n n :=
- lazymatch n with
- | 0%N => fail
- | _ =>
-(* idtac "Trying power: " n;*)
- (let r := eval compute in (Nminus radicalmax (Npred n)) in
- nsatz_call_n info nparam p r lp kont) ||
- let n' := eval compute in (Npred n) in try_n n'
- end in
- try_n radicalmax.
-
-
-Ltac nsatzR_gen radicalmax info lparam lvar n RNG lH _rl :=
- get_Pre RNG ();
- let mkFV := Ring_tac.get_RingFV RNG in
- let mkPol := Ring_tac.get_RingMeta RNG in
- generalise_eq_hyps;
- let t := Get_goal in
- let lpol := lpol_goal t in
- intros;
- let fv :=
- match lvar with
- | nil =>
- let fv1 := FV_hypo_tac mkFV ltac:(get_Eq RNG) lH in
- let fv1 := list_fold_right mkFV fv1 lpol in
- rev fv1
- (* heuristique: les dernieres variables auront le poid le plus fort *)
- | _ => lvar
- end in
- check_fv fv;
- (*idtac "variables:";idtac fv;*)
- let nparam := eval compute in (Z_of_nat (List.length lparam)) in
- let fv := parametres_en_tete fv lparam in
- idtac "variables:"; idtac fv;
- (* idtac "nparam:"; idtac nparam;*)
- let lpol := list_fold_right
- ltac:(fun p l => let p' := mkPol p fv in constr:(p'::l))
- (@nil (PExpr Z))
- lpol in
- let lpol := eval compute in (List.rev lpol) in
- (*idtac lpol;*)
- let SplitPolyList kont :=
- match lpol with
- | ?p2::?lp2 => kont p2 lp2
- | _ => idtac "polynomial not in the ideal"
- end in
- SplitPolyList ltac:(fun p lp =>
- set (p21:=p) ;
- set (lp21:=lp);
- nsatz_call radicalmax info nparam p lp ltac:(fun c r lq lci =>
- set (q := PEmul c (PEpow p21 r));
- let Hg := fresh "Hg" in
- assert (Hg:check lp21 q (lci,lq) = true);
- [ (vm_compute;reflexivity) || idtac "invalid nsatz certificate"
- | let Hg2 := fresh "Hg" in
- assert (Hg2: interpret3 q fv = 0);
- [ simpl; apply (@check_correct fv lp21 q (lci,lq) Hg); simpl;
- repeat (split;[assumption|idtac]); exact I
- | simpl in Hg2; simpl;
- apply nsatzR_l3 with (interpret3 c fv) (Nnat.nat_of_N r);simpl;
- [ discrR || idtac "could not prove discrimination result"
- | exact Hg2]
- ]
- ])).
-
-Ltac nsatzRpv radicalmax info lparam lvar:=
- nsatzR_begin;
- intros;
- let G := Get_goal in
- ring_lookup
- (PackRing ltac:(nsatzR_gen radicalmax info lparam lvar ring_subst_niter))
- [] G.
-
-Ltac nsatzR := nsatzRpv 6%N 1%Z (@nil R) (@nil R).
-Ltac nsatzRradical radicalmax := nsatzRpv radicalmax 1%Z (@nil R) (@nil R).
-Ltac nsatzRparameters lparam := nsatzRpv 6%N 1%Z lparam (@nil R).
-
-Tactic Notation "nsatz" := nsatzR.
-Tactic Notation "nsatz" "with" "lexico" :=
- nsatzRpv 6%N 2%Z (@nil R) (@nil R).
-Tactic Notation "nsatz" "with" "lexico" "sugar":=
- nsatzRpv 6%N 3%Z (@nil R) (@nil R).
-Tactic Notation "nsatz" "without" "sugar":=
- nsatzRpv 6%N 0%Z (@nil R) (@nil R).
-
-
diff --git a/plugins/nsatz/NsatzZ.v b/plugins/nsatz/NsatzZ.v
deleted file mode 100644
index b57aa0ed..00000000
--- a/plugins/nsatz/NsatzZ.v
+++ /dev/null
@@ -1,73 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-Require Import Reals ZArith.
-Require Export NsatzR.
-
-Open Scope Z_scope.
-
-Lemma nsatzZhypR: forall x y:Z, x=y -> IZR x = IZR y.
-Proof IZR_eq. (* or f_equal ... *)
-
-Lemma nsatzZconclR: forall x y:Z, IZR x = IZR y -> x = y.
-Proof eq_IZR.
-
-Lemma nsatzZhypnotR: forall x y:Z, x<>y -> IZR x <> IZR y.
-Proof IZR_neq.
-
-Lemma nsatzZconclnotR: forall x y:Z, IZR x <> IZR y -> x <> y.
-Proof.
-intros x y H. contradict H. f_equal. assumption.
-Qed.
-
-Ltac nsatzZtoR1 :=
- repeat
- (match goal with
- | H:(@eq Z ?x ?y) |- _ =>
- generalize (@nsatzZhypR _ _ H); clear H; intro H
- | |- (@eq Z ?x ?y) => apply nsatzZconclR
- | H:not (@eq Z ?x ?y) |- _ =>
- generalize (@nsatzZhypnotR _ _ H); clear H; intro H
- | |- not (@eq Z ?x ?y) => apply nsatzZconclnotR
- end).
-
-Lemma nsatzZR1: forall x y:Z, IZR(x+y) = (IZR x + IZR y)%R.
-Proof plus_IZR.
-
-Lemma nsatzZR2: forall x y:Z, IZR(x*y) = (IZR x * IZR y)%R.
-Proof mult_IZR.
-
-Lemma nsatzZR3: forall x y:Z, IZR(x-y) = (IZR x - IZR y)%R.
-Proof.
-intros; symmetry. apply Z_R_minus.
-Qed.
-
-Lemma nsatzZR4: forall (x:Z) p, IZR(x ^ Zpos p) = (IZR x ^ nat_of_P p)%R.
-Proof.
-intros. rewrite pow_IZR.
-do 2 f_equal.
-apply Zpos_eq_Z_of_nat_o_nat_of_P.
-Qed.
-
-Ltac nsatzZtoR2:=
- repeat
- (rewrite nsatzZR1 in * ||
- rewrite nsatzZR2 in * ||
- rewrite nsatzZR3 in * ||
- rewrite nsatzZR4 in *).
-
-Ltac nsatzZ_begin :=
- intros;
- nsatzZtoR1;
- nsatzZtoR2;
- simpl in *.
- (*cbv beta iota zeta delta [nat_of_P Pmult_nat plus mult] in *.*)
-
-Ltac nsatzZ :=
- nsatzZ_begin; (*idtac "nsatzZ_begin;";*)
- nsatzR.
diff --git a/plugins/nsatz/vo.itarget b/plugins/nsatz/vo.itarget
index 4af4786d..06fc8834 100644
--- a/plugins/nsatz/vo.itarget
+++ b/plugins/nsatz/vo.itarget
@@ -1,3 +1 @@
-NsatzR.vo
-Nsatz_domain.vo
-NsatzZ.vo
+Nsatz.vo
diff --git a/plugins/omega/Omega.v b/plugins/omega/Omega.v
index 65b780dd..fadecf5d 100644
--- a/plugins/omega/Omega.v
+++ b/plugins/omega/Omega.v
@@ -13,7 +13,7 @@
(* *)
(**************************************************************************)
-(* $Id$ *)
+(* $Id: Omega.v 13323 2010-07-24 15:57:30Z herbelin $ *)
(* We do not require [ZArith] anymore, but only what's necessary for Omega *)
Require Export ZArith_base.
diff --git a/plugins/omega/OmegaLemmas.v b/plugins/omega/OmegaLemmas.v
index 56a854d6..ec9faedd 100644
--- a/plugins/omega/OmegaLemmas.v
+++ b/plugins/omega/OmegaLemmas.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
-(*i $Id$ i*)
+(*i $Id: OmegaLemmas.v 12337 2009-09-17 15:58:14Z glondu $ i*)
Require Import ZArith_base.
Open Local Scope Z_scope.
diff --git a/plugins/omega/OmegaPlugin.v b/plugins/omega/OmegaPlugin.v
index c0b0eb47..ee942db0 100644
--- a/plugins/omega/OmegaPlugin.v
+++ b/plugins/omega/OmegaPlugin.v
@@ -6,6 +6,6 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: OmegaPlugin.v 13323 2010-07-24 15:57:30Z herbelin $ *)
Declare ML Module "omega_plugin".
diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml
index 471fb5da..e3f9a309 100644
--- a/plugins/omega/coq_omega.ml
+++ b/plugins/omega/coq_omega.ml
@@ -13,7 +13,7 @@
(* *)
(**************************************************************************)
-(* $Id$ *)
+(* $Id: coq_omega.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Util
open Pp
diff --git a/plugins/omega/g_omega.ml4 b/plugins/omega/g_omega.ml4
index 4be7f2e5..eefa67ec 100644
--- a/plugins/omega/g_omega.ml4
+++ b/plugins/omega/g_omega.ml4
@@ -15,7 +15,7 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
-(* $Id$ *)
+(* $Id: g_omega.ml4 13323 2010-07-24 15:57:30Z herbelin $ *)
open Coq_omega
open Refiner
diff --git a/plugins/quote/Quote.v b/plugins/quote/Quote.v
index ea8f5bf9..b7cc13ae 100644
--- a/plugins/quote/Quote.v
+++ b/plugins/quote/Quote.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: Quote.v 13323 2010-07-24 15:57:30Z herbelin $ *)
Declare ML Module "quote_plugin".
diff --git a/plugins/quote/g_quote.ml4 b/plugins/quote/g_quote.ml4
index ef87a596..83bfb6ed 100644
--- a/plugins/quote/g_quote.ml4
+++ b/plugins/quote/g_quote.ml4
@@ -8,7 +8,7 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
-(* $Id$ *)
+(* $Id: g_quote.ml4 13323 2010-07-24 15:57:30Z herbelin $ *)
open Util
open Tacexpr
diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml
index 760f93b8..b6ca770e 100644
--- a/plugins/quote/quote.ml
+++ b/plugins/quote/quote.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: quote.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
(* The `Quote' tactic *)
diff --git a/plugins/ring/LegacyArithRing.v b/plugins/ring/LegacyArithRing.v
index 27349683..3e30b90f 100644
--- a/plugins/ring/LegacyArithRing.v
+++ b/plugins/ring/LegacyArithRing.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: LegacyArithRing.v 13323 2010-07-24 15:57:30Z herbelin $ *)
(* Instantiation of the Ring tactic for the naturals of Arith $*)
diff --git a/plugins/ring/LegacyNArithRing.v b/plugins/ring/LegacyNArithRing.v
index 7a2f4abc..337c3085 100644
--- a/plugins/ring/LegacyNArithRing.v
+++ b/plugins/ring/LegacyNArithRing.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: LegacyNArithRing.v 13323 2010-07-24 15:57:30Z herbelin $ *)
(* Instantiation of the Ring tactic for the binary natural numbers *)
diff --git a/plugins/ring/LegacyRing.v b/plugins/ring/LegacyRing.v
index 5ab90555..6b655134 100644
--- a/plugins/ring/LegacyRing.v
+++ b/plugins/ring/LegacyRing.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: LegacyRing.v 13323 2010-07-24 15:57:30Z herbelin $ *)
Require Export Bool.
Require Export LegacyRing_theory.
diff --git a/plugins/ring/LegacyRing_theory.v b/plugins/ring/LegacyRing_theory.v
index 74d8f186..fb4c87fb 100644
--- a/plugins/ring/LegacyRing_theory.v
+++ b/plugins/ring/LegacyRing_theory.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: LegacyRing_theory.v 13323 2010-07-24 15:57:30Z herbelin $ *)
Require Export Bool.
diff --git a/plugins/ring/LegacyZArithRing.v b/plugins/ring/LegacyZArithRing.v
index 293ac12e..22fa87c8 100644
--- a/plugins/ring/LegacyZArithRing.v
+++ b/plugins/ring/LegacyZArithRing.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: LegacyZArithRing.v 13323 2010-07-24 15:57:30Z herbelin $ *)
(* Instantiation of the Ring tactic for the binary integers of ZArith *)
diff --git a/plugins/ring/Ring_abstract.v b/plugins/ring/Ring_abstract.v
index 96764e51..e65e1ce8 100644
--- a/plugins/ring/Ring_abstract.v
+++ b/plugins/ring/Ring_abstract.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: Ring_abstract.v 13323 2010-07-24 15:57:30Z herbelin $ *)
Require Import LegacyRing_theory.
Require Import Quote.
diff --git a/plugins/ring/Ring_normalize.v b/plugins/ring/Ring_normalize.v
index 320e1ab2..d68fef4f 100644
--- a/plugins/ring/Ring_normalize.v
+++ b/plugins/ring/Ring_normalize.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: Ring_normalize.v 13323 2010-07-24 15:57:30Z herbelin $ *)
Require Import LegacyRing_theory.
Require Import Quote.
diff --git a/plugins/ring/Setoid_ring.v b/plugins/ring/Setoid_ring.v
index 15495071..3a3dfe84 100644
--- a/plugins/ring/Setoid_ring.v
+++ b/plugins/ring/Setoid_ring.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: Setoid_ring.v 13323 2010-07-24 15:57:30Z herbelin $ *)
Require Export Setoid_ring_theory.
Require Export Quote.
diff --git a/plugins/ring/Setoid_ring_normalize.v b/plugins/ring/Setoid_ring_normalize.v
index 6bd5b419..6a53b519 100644
--- a/plugins/ring/Setoid_ring_normalize.v
+++ b/plugins/ring/Setoid_ring_normalize.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: Setoid_ring_normalize.v 13323 2010-07-24 15:57:30Z herbelin $ *)
Require Import Setoid_ring_theory.
Require Import Quote.
diff --git a/plugins/ring/Setoid_ring_theory.v b/plugins/ring/Setoid_ring_theory.v
index 96910db6..d55f25fc 100644
--- a/plugins/ring/Setoid_ring_theory.v
+++ b/plugins/ring/Setoid_ring_theory.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: Setoid_ring_theory.v 13323 2010-07-24 15:57:30Z herbelin $ *)
Require Export Bool.
Require Export Setoid.
diff --git a/plugins/ring/g_ring.ml4 b/plugins/ring/g_ring.ml4
index dc34fdbc..7fda4920 100644
--- a/plugins/ring/g_ring.ml4
+++ b/plugins/ring/g_ring.ml4
@@ -8,7 +8,7 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
-(* $Id$ *)
+(* $Id: g_ring.ml4 13323 2010-07-24 15:57:30Z herbelin $ *)
open Quote
open Ring
diff --git a/plugins/ring/ring.ml b/plugins/ring/ring.ml
index fc2a04b3..3cdf0117 100644
--- a/plugins/ring/ring.ml
+++ b/plugins/ring/ring.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: ring.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
(* ML part of the Ring tactic *)
diff --git a/plugins/rtauto/Bintree.v b/plugins/rtauto/Bintree.v
index 8e7cf569..a62a0780 100644
--- a/plugins/rtauto/Bintree.v
+++ b/plugins/rtauto/Bintree.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: Bintree.v 13323 2010-07-24 15:57:30Z herbelin $ *)
Require Export List.
Require Export BinPos.
diff --git a/plugins/rtauto/Rtauto.v b/plugins/rtauto/Rtauto.v
index a61a2605..ffa619d0 100644
--- a/plugins/rtauto/Rtauto.v
+++ b/plugins/rtauto/Rtauto.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: Rtauto.v 13323 2010-07-24 15:57:30Z herbelin $ *)
Require Export List.
diff --git a/plugins/rtauto/g_rtauto.ml4 b/plugins/rtauto/g_rtauto.ml4
index 73311f63..22f8ca2a 100644
--- a/plugins/rtauto/g_rtauto.ml4
+++ b/plugins/rtauto/g_rtauto.ml4
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$*)
+(* $Id: g_rtauto.ml4 13323 2010-07-24 15:57:30Z herbelin $*)
(*i camlp4deps: "parsing/grammar.cma" i*)
diff --git a/plugins/rtauto/proof_search.ml b/plugins/rtauto/proof_search.ml
index cf9e7fd3..23530ef8 100644
--- a/plugins/rtauto/proof_search.ml
+++ b/plugins/rtauto/proof_search.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: proof_search.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Term
open Util
diff --git a/plugins/rtauto/proof_search.mli b/plugins/rtauto/proof_search.mli
index 5ccc59a5..685a3059 100644
--- a/plugins/rtauto/proof_search.mli
+++ b/plugins/rtauto/proof_search.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: proof_search.mli 13323 2010-07-24 15:57:30Z herbelin $ *)
type form=
Atom of int
diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml
index 77ef5a9c..e079a83c 100644
--- a/plugins/rtauto/refl_tauto.ml
+++ b/plugins/rtauto/refl_tauto.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: refl_tauto.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
module Search = Explore.Make(Proof_search)
diff --git a/plugins/rtauto/refl_tauto.mli b/plugins/rtauto/refl_tauto.mli
index e8264c83..2ff45f57 100644
--- a/plugins/rtauto/refl_tauto.mli
+++ b/plugins/rtauto/refl_tauto.mli
@@ -5,7 +5,7 @@
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: refl_tauto.mli 13323 2010-07-24 15:57:30Z herbelin $ *)
(* raises Not_found if no proof is found *)
diff --git a/plugins/setoid_ring/newring.ml4 b/plugins/setoid_ring/newring.ml4
index a5187224..8940e565 100644
--- a/plugins/setoid_ring/newring.ml4
+++ b/plugins/setoid_ring/newring.ml4
@@ -8,7 +8,7 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
-(*i $Id$ i*)
+(*i $Id: newring.ml4 13332 2010-07-26 22:12:43Z msozeau $ i*)
open Pp
open Util
@@ -531,7 +531,7 @@ let ring_equality (r,add,mul,opp,req) =
(setoid,op_morph)
| _ ->
let setoid = setoid_of_relation (Global.env ()) r req in
- let signature = [Some (r,req);Some (r,req)],Some(r,req) in
+ let signature = [Some (r,Some req);Some (r,Some req)],Some(r,Some req) in
let add_m, add_m_lem =
try Rewrite.default_morphism signature add
with Not_found ->
@@ -544,7 +544,7 @@ let ring_equality (r,add,mul,opp,req) =
match opp with
| Some opp ->
(let opp_m,opp_m_lem =
- try Rewrite.default_morphism ([Some(r,req)],Some(r,req)) opp
+ try Rewrite.default_morphism ([Some(r,Some req)],Some(r,Some req)) opp
with Not_found ->
error "ring opposite should be declared as a morphism" in
let op_morph =
@@ -1031,7 +1031,7 @@ let field_equality r inv req =
mkApp((Coqlib.build_coq_eq_data()).congr,[|r;r;inv|])
| _ ->
let _setoid = setoid_of_relation (Global.env ()) r req in
- let signature = [Some (r,req)],Some(r,req) in
+ let signature = [Some (r,Some req)],Some(r,Some req) in
let inv_m, inv_m_lem =
try Rewrite.default_morphism signature inv
with Not_found ->
diff --git a/plugins/subtac/eterm.ml b/plugins/subtac/eterm.ml
index 4b95df19..f1bdd640 100644
--- a/plugins/subtac/eterm.ml
+++ b/plugins/subtac/eterm.ml
@@ -141,16 +141,28 @@ let evar_dependencies evm ev =
if Intset.equal deps deps' then deps
else aux deps'
in aux (Intset.singleton ev)
-
-let sort_dependencies evl =
- List.stable_sort
- (fun (id, ev, deps) (id', ev', deps') ->
- if id = id' then 0
- else if Intset.mem id deps' then -1
- else if Intset.mem id' deps then 1
- else Pervasives.compare id id')
- evl
+let move_after (id, ev, deps as obl) l =
+ let rec aux restdeps = function
+ | (id', _, _) as obl' :: tl ->
+ let restdeps' = Intset.remove id' restdeps in
+ if Intset.is_empty restdeps' then
+ obl' :: obl :: tl
+ else obl' :: aux restdeps' tl
+ | [] -> [obl]
+ in aux (Intset.remove id deps) l
+
+let sort_dependencies evl =
+ let rec aux l found list =
+ match l with
+ | (id, ev, deps) as obl :: tl ->
+ let found' = Intset.union found (Intset.singleton id) in
+ if Intset.subset deps found' then
+ aux tl found' (obl :: list)
+ else aux (move_after obl tl) found list
+ | [] -> List.rev list
+ in aux evl Intset.empty []
+
let map_evar_body f = function
| Evar_empty -> Evar_empty
| Evar_defined c -> Evar_defined (f c)
diff --git a/plugins/subtac/eterm.mli b/plugins/subtac/eterm.mli
index d727c19c..262889c8 100644
--- a/plugins/subtac/eterm.mli
+++ b/plugins/subtac/eterm.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: eterm.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Environ
open Tacmach
open Term
diff --git a/plugins/subtac/g_subtac.ml4 b/plugins/subtac/g_subtac.ml4
index 87fd0479..cd8708d5 100644
--- a/plugins/subtac/g_subtac.ml4
+++ b/plugins/subtac/g_subtac.ml4
@@ -14,7 +14,7 @@
Syntax for the subtac terms and types.
Elaborated from correctness/psyntax.ml4 by Jean-Christophe Filliâtre *)
-(* $Id$ *)
+(* $Id: g_subtac.ml4 13332 2010-07-26 22:12:43Z msozeau $ *)
open Flags
@@ -53,7 +53,7 @@ open Constr
let sigref = mkRefC (Qualid (dummy_loc, Libnames.qualid_of_string "Coq.Init.Specif.sig"))
GEXTEND Gram
- GLOBAL: subtac_gallina_loc typeclass_constraint Constr.binder subtac_withtac;
+ GLOBAL: subtac_gallina_loc typeclass_constraint subtac_withtac;
subtac_gallina_loc:
[ [ g = Vernac.gallina -> loc, g
@@ -65,21 +65,12 @@ GEXTEND Gram
| -> None ] ]
;
- Constr.binder_let:
+ Constr.closed_binder:
[[ "("; id=Prim.name; ":"; t=Constr.lconstr; "|"; c=Constr.lconstr; ")" ->
let typ = mkAppC (sigref, [mkLambdaC ([id], default_binder_kind, t, c)]) in
[LocalRawAssum ([id], default_binder_kind, typ)]
] ];
- Constr.binder:
- [ [ "("; id=Prim.name; ":"; c=Constr.lconstr; "|"; p=Constr.lconstr; ")" ->
- ([id],default_binder_kind, mkAppC (sigref, [mkLambdaC ([id], default_binder_kind, c, p)]))
- | "("; id=Prim.name; ":"; c=Constr.lconstr; ")" ->
- ([id],default_binder_kind, c)
- | "("; id=Prim.name; lid=LIST1 Prim.name; ":"; c=Constr.lconstr; ")" ->
- (id::lid,default_binder_kind, c)
- ] ];
-
END
@@ -161,9 +152,11 @@ VERNAC COMMAND EXTEND Subtac_Set_Solver
(Tacinterp.glob_tactic t) ]
END
+open Pp
+
VERNAC COMMAND EXTEND Subtac_Show_Solver
| [ "Show" "Obligation" "Tactic" ] -> [
- Pp.msgnl (Pptactic.pr_glob_tactic (Global.env ()) (Subtac_obligations.default_tactic_expr ())) ]
+ msgnl (str"Program obligation tactic is " ++ Subtac_obligations.print_default_tactic ()) ]
END
VERNAC COMMAND EXTEND Subtac_Show_Obligations
diff --git a/plugins/subtac/subtac.ml b/plugins/subtac/subtac.ml
index c859c690..885f7fb6 100644
--- a/plugins/subtac/subtac.ml
+++ b/plugins/subtac/subtac.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: subtac.ml 13344 2010-07-28 15:04:36Z msozeau $ *)
open Global
open Pp
@@ -76,7 +76,7 @@ let start_proof_com env isevars sopt kind (bl,t) hook =
(Pfedit.get_all_proof_names ())
in
let evm, c, typ, imps =
- Subtac_pretyping.subtac_process env isevars id [] (Topconstr.prod_constr_expr t bl) None
+ Subtac_pretyping.subtac_process ~is_type:true env isevars id [] (Topconstr.prod_constr_expr t bl) None
in
let c = solve_tccs_in_type env id isevars evm c typ in
Lemmas.start_proof id kind c (fun loc gr ->
@@ -138,9 +138,6 @@ let subtac (loc, command) =
Dumpglob.dump_definition lid false "def";
(match expr with
| ProveBody (bl, t) ->
- if Lib.is_modtype () then
- errorlabstrm "Subtac_command.StartProof"
- (str "Proof editing mode not supported in module types");
start_proof_and_print env isevars (Some lid) (Global, DefinitionBody Definition) (bl,t)
(fun _ _ -> ())
| DefineBody (bl, _, c, tycon) ->
@@ -218,33 +215,10 @@ let subtac (loc, command) =
++ x ++ spc () ++ str "and" ++ spc () ++ y
in msg_warning cmds
- | Cases.PatternMatchingError (env, exn) as e ->
- debug 2 (Himsg.explain_pattern_matching_error env exn);
- raise e
+ | Cases.PatternMatchingError (env, exn) as e -> raise e
- | Type_errors.TypeError (env, exn) as e ->
- debug 2 (Himsg.explain_type_error env exn);
- raise e
+ | Type_errors.TypeError (env, exn) as e -> raise e
- | Pretype_errors.PretypeError (env, exn) as e ->
- debug 2 (Himsg.explain_pretype_error env exn);
- raise e
+ | Pretype_errors.PretypeError (env, exn) as e -> raise e
- | (Stdpp.Exc_located (loc, Proof_type.LtacLocated (_,e')) |
- Stdpp.Exc_located (loc, e') as e) ->
- debug 2 (str "Parsing exception: ");
- (match e' with
- | Type_errors.TypeError (env, exn) ->
- debug 2 (Himsg.explain_type_error env exn);
- raise e
-
- | Pretype_errors.PretypeError (env, exn) ->
- debug 2 (Himsg.explain_pretype_error env exn);
- raise e
-
- | e'' -> msg_warning (str "Unexpected exception: " ++ Cerrors.explain_exn e'');
- raise e)
-
- | e ->
- msg_warning (str "Uncatched exception: " ++ Cerrors.explain_exn e);
- raise e
+ | e -> raise e
diff --git a/plugins/subtac/subtac_cases.ml b/plugins/subtac/subtac_cases.ml
index 28cedc8a..f6f8695b 100644
--- a/plugins/subtac/subtac_cases.ml
+++ b/plugins/subtac/subtac_cases.ml
@@ -7,7 +7,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: subtac_cases.ml 13332 2010-07-26 22:12:43Z msozeau $ *)
open Cases
open Util
@@ -23,13 +23,11 @@ open Sign
open Reductionops
open Typeops
open Type_errors
-
open Rawterm
open Retyping
open Pretype_errors
open Evarutil
open Evarconv
-
open Subtac_utils
(************************************************************************)
@@ -125,7 +123,7 @@ type tomatch_stack = tomatch_status list
originating from a subterm in which case real args are not dependent;
it accounts for n+1 binders if dep or n binders if not dep
- [PrProd] types abstracted term ([Abstract]); it accounts for one binder
- - [PrCcl] types the right-hand-side
+ - [PrCcl] types the right-hand side
- Aliases [Alias] have no trace in [predicate_signature]
*)
@@ -1152,7 +1150,7 @@ let rec generalize_problem pb = function
tomatch = Abstract d :: tomatch;
pred = Option.map (generalize_predicate i d) pb'.pred }
-(* No more patterns: typing the right-hand-side of equations *)
+(* No more patterns: typing the right-hand side of equations *)
let build_leaf pb =
let rhs = extract_rhs pb in
let tycon = match pb.pred with
@@ -1514,11 +1512,11 @@ let eq_id avoid id =
let hid' = next_ident_away hid avoid in
hid'
-let mk_eq typ x y = mkApp (Lazy.force eq_ind, [| typ; x ; y |])
-let mk_eq_refl typ x = mkApp (Lazy.force eq_refl, [| typ; x |])
+let mk_eq typ x y = mkApp (delayed_force eq_ind, [| typ; x ; y |])
+let mk_eq_refl typ x = mkApp (delayed_force eq_refl, [| typ; x |])
let mk_JMeq typ x typ' y =
- mkApp (Lazy.force Subtac_utils.jmeq_ind, [| typ; x ; typ'; y |])
-let mk_JMeq_refl typ x = mkApp (Lazy.force Subtac_utils.jmeq_refl, [| typ; x |])
+ mkApp (delayed_force Subtac_utils.jmeq_ind, [| typ; x ; typ'; y |])
+let mk_JMeq_refl typ x = mkApp (delayed_force Subtac_utils.jmeq_refl, [| typ; x |])
let hole = RHole (dummy_loc, Evd.QuestionMark (Evd.Define true))
@@ -1610,7 +1608,7 @@ let vars_of_ctx ctx =
| Some t' when kind_of_term t' = Rel 0 ->
prev,
(RApp (dummy_loc,
- (RRef (dummy_loc, Lazy.force refl_ref)), [hole; RVar (dummy_loc, prev)])) :: vars
+ (RRef (dummy_loc, delayed_force refl_ref)), [hole; RVar (dummy_loc, prev)])) :: vars
| _ ->
match na with
Anonymous -> raise (Invalid_argument "vars_of_ctx")
@@ -1651,7 +1649,7 @@ let build_ineqs prevpatterns pats liftsign =
lift_rel_context len ppat_sign @ sign,
len',
succ n, (* nth pattern *)
- mkApp (Lazy.force eq_ind,
+ mkApp (delayed_force eq_ind,
[| lift (len' + liftsign) curpat_ty;
liftn (len + liftsign) (succ lens) ppat_c ;
lift len' curpat_c |]) ::
@@ -1929,7 +1927,7 @@ let compile_cases loc style (typing_fun, isevars) (tycon : Evarutil.type_constra
let typing_fun tycon env = typing_fun tycon env isevars in
- (* We build the matrix of patterns and right-hand-side *)
+ (* We build the matrix of patterns and right-hand side *)
let matx = matx_of_eqns env eqns in
(* We build the vector of terms to match consistently with the *)
diff --git a/plugins/subtac/subtac_cases.mli b/plugins/subtac/subtac_cases.mli
index 823e9912..a4df1257 100644
--- a/plugins/subtac/subtac_cases.mli
+++ b/plugins/subtac/subtac_cases.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: subtac_cases.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Util
diff --git a/plugins/subtac/subtac_classes.ml b/plugins/subtac/subtac_classes.ml
index f0ff9ba3..b2bf9912 100644
--- a/plugins/subtac/subtac_classes.ml
+++ b/plugins/subtac/subtac_classes.ml
@@ -7,7 +7,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: subtac_classes.ml 13328 2010-07-26 11:05:30Z herbelin $ i*)
open Pretyping
open Evd
@@ -30,11 +30,11 @@ open Util
module SPretyping = Subtac_pretyping.Pretyping
-let interp_constr_evars_gen evdref env ?(impls=([],[])) kind c =
+let interp_constr_evars_gen evdref env ?(impls=[]) kind c =
SPretyping.understand_tcc_evars evdref env kind
(intern_gen (kind=IsType) ~impls ( !evdref) env c)
-let interp_casted_constr_evars evdref env ?(impls=([],[])) c typ =
+let interp_casted_constr_evars evdref env ?(impls=[]) c typ =
interp_constr_evars_gen evdref env ~impls (OfType (Some typ)) c
let interp_context_evars evdref env params =
diff --git a/plugins/subtac/subtac_classes.mli b/plugins/subtac/subtac_classes.mli
index 1c6c473a..57c7aa5b 100644
--- a/plugins/subtac/subtac_classes.mli
+++ b/plugins/subtac/subtac_classes.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: subtac_classes.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Names
diff --git a/plugins/subtac/subtac_coercion.ml b/plugins/subtac/subtac_coercion.ml
index 3f2a5dba..17c7284c 100644
--- a/plugins/subtac/subtac_coercion.ml
+++ b/plugins/subtac/subtac_coercion.ml
@@ -6,7 +6,7 @@
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: subtac_coercion.ml 13332 2010-07-26 22:12:43Z msozeau $ *)
open Util
open Names
@@ -39,7 +39,7 @@ let rec disc_subset x =
(match kind_of_term c with
Ind i ->
let len = Array.length l in
- let sig_ = Lazy.force sig_ in
+ let sig_ = delayed_force sig_ in
if len = 2 && i = Term.destInd sig_.typ
then
let (a, b) = pair_of_array l in
@@ -53,7 +53,7 @@ and disc_exist env x =
| App (c, l) ->
(match kind_of_term c with
Construct c ->
- if c = Term.destConstruct (Lazy.force sig_).intro
+ if c = Term.destConstruct (delayed_force sig_).intro
then Some (l.(0), l.(1), l.(2), l.(3))
else None
| _ -> None)
@@ -66,7 +66,7 @@ module Coercion = struct
let disc_proj_exist env x =
match kind_of_term x with
| App (c, l) ->
- (if Term.eq_constr c (Lazy.force sig_).proj1
+ (if Term.eq_constr c (delayed_force sig_).proj1
&& Array.length l = 3
then disc_exist env l.(2)
else None)
@@ -100,7 +100,7 @@ module Coercion = struct
Some (u, p) ->
let f, ct = aux u in
(Some (fun x ->
- app_opt f (mkApp ((Lazy.force sig_).proj1,
+ app_opt f (mkApp ((delayed_force sig_).proj1,
[| u; p; x |]))),
ct)
| None -> (None, v)
@@ -146,9 +146,9 @@ module Coercion = struct
in
let args = List.rev (restargs @ mkRel 1 :: lift_args 1 tele) in
let pred = mkLambda (n, eqT, applistc (lift 1 c) args) in
- let eq = mkApp (Lazy.force eq_ind, [| eqT; hdx; hdy |]) in
+ let eq = mkApp (delayed_force eq_ind, [| eqT; hdx; hdy |]) in
let evar = make_existential loc env isevars eq in
- let eq_app x = mkApp (Lazy.force eq_rect,
+ let eq_app x = mkApp (delayed_force eq_rect,
[| eqT; hdx; pred; x; hdy; evar|]) in
aux (hdy :: tele) (subst1 hdx restT) (subst1 hdy restT') (succ i) (fun x -> eq_app (co x))
else Some co
@@ -187,8 +187,8 @@ module Coercion = struct
(match kind_of_term c, kind_of_term c' with
Ind i, Ind i' -> (* Inductive types *)
let len = Array.length l in
- let existS = Lazy.force existS in
- let prod = Lazy.force prod in
+ let existS = delayed_force existS in
+ let prod = delayed_force prod in
(* Sigma types *)
if len = Array.length l' && len = 2 && i = i'
&& (i = Term.destInd existS.typ || i = Term.destInd prod.typ)
@@ -279,7 +279,7 @@ module Coercion = struct
Some (u, p) ->
let c = coerce_unify env u y in
let f x =
- app_opt c (mkApp ((Lazy.force sig_).proj1,
+ app_opt c (mkApp ((delayed_force sig_).proj1,
[| u; p; x |]))
in Some f
| None ->
@@ -292,7 +292,7 @@ module Coercion = struct
let evar = make_existential loc env isevars (mkApp (p, [| cx |]))
in
(mkApp
- ((Lazy.force sig_).intro,
+ ((delayed_force sig_).intro,
[| u; p; cx; evar |])))
| None ->
raise NoSubtacCoercion
@@ -496,8 +496,7 @@ module Coercion = struct
with NoCoercion ->
coerce_itf loc env' isevars None t t')
with NoSubtacCoercion ->
- let sigma = isevars in
- error_cannot_coerce env' sigma (t, t'))
+ error_cannot_coerce env' isevars (t, t'))
else isevars
with _ -> isevars
end
diff --git a/plugins/subtac/subtac_command.ml b/plugins/subtac/subtac_command.ml
index f2747225..e7dd7ef1 100644
--- a/plugins/subtac/subtac_command.ml
+++ b/plugins/subtac/subtac_command.ml
@@ -53,7 +53,7 @@ let evar_nf isevars c =
Evarutil.nf_evar !isevars c
let interp_gen kind isevars env
- ?(impls=([],[])) ?(allow_patvar=false) ?(ltacvars=([],[]))
+ ?(impls=[]) ?(allow_patvar=false) ?(ltacvars=([],[]))
c =
let c' = Constrintern.intern_gen (kind=IsType) ~impls ~allow_patvar ~ltacvars ( !isevars) env c in
let c' = SPretyping.understand_tcc_evars isevars env kind c' in
@@ -62,13 +62,13 @@ let interp_gen kind isevars env
let interp_constr isevars env c =
interp_gen (OfType None) isevars env c
-let interp_type_evars isevars env ?(impls=([],[])) c =
+let interp_type_evars isevars env ?(impls=[]) c =
interp_gen IsType isevars env ~impls c
-let interp_casted_constr isevars env ?(impls=([],[])) c typ =
+let interp_casted_constr isevars env ?(impls=[]) c typ =
interp_gen (OfType (Some typ)) isevars env ~impls c
-let interp_casted_constr_evars isevars env ?(impls=([],[])) c typ =
+let interp_casted_constr_evars isevars env ?(impls=[]) c typ =
interp_gen (OfType (Some typ)) isevars env ~impls c
let interp_open_constr isevars env c =
@@ -237,14 +237,18 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation boxed =
let rel = interp_constr isevars env r in
let relty = type_of env !isevars rel in
let relargty =
- let ctx, ar = Reductionops.splay_prod_n env !isevars 2 relty in
- match ctx, kind_of_term ar with
- | [(_, None, t); (_, None, u)], Sort (Prop Null)
- when Reductionops.is_conv env !isevars t u -> t
- | _, _ ->
- user_err_loc (constr_loc r,
- "Subtac_command.build_wellfounded",
- my_print_constr env rel ++ str " is not an homogeneous binary relation.")
+ let error () =
+ user_err_loc (constr_loc r,
+ "Subtac_command.build_wellfounded",
+ my_print_constr env rel ++ str " is not an homogeneous binary relation.")
+ in
+ try
+ let ctx, ar = Reductionops.splay_prod_n env !isevars 2 relty in
+ match ctx, kind_of_term ar with
+ | [(_, None, t); (_, None, u)], Sort (Prop Null)
+ when Reductionops.is_conv env !isevars t u -> t
+ | _, _ -> error ()
+ with _ -> error ()
in
let measure = interp_casted_constr isevars binders_env measure relargty in
let wf_rel, wf_rel_fun, measure_fn =
@@ -252,14 +256,14 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation boxed =
it_mkLambda_or_LetIn measure letbinders,
it_mkLambda_or_LetIn measure binders
in
- let comb = constr_of_global (Lazy.force measure_on_R_ref) in
+ let comb = constr_of_global (delayed_force measure_on_R_ref) in
let wf_rel = mkApp (comb, [| argtyp; relargty; rel; measure |]) in
let wf_rel_fun x y =
mkApp (rel, [| subst1 x measure_body;
subst1 y measure_body |])
in wf_rel, wf_rel_fun, measure
in
- let wf_proof = mkApp (Lazy.force well_founded, [| argtyp ; wf_rel |]) in
+ let wf_proof = mkApp (delayed_force well_founded, [| argtyp ; wf_rel |]) in
let argid' = id_of_string (string_of_id argname ^ "'") in
let wfarg len = (Name argid', None,
mkSubset (Name argid') argtyp
@@ -267,7 +271,7 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation boxed =
in
let intern_bl = wfarg 1 :: [arg] in
let _intern_env = push_rel_context intern_bl env in
- let proj = (Lazy.force sig_).Coqlib.proj1 in
+ let proj = (delayed_force sig_).Coqlib.proj1 in
let wfargpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel 3)) in
let projection = (* in wfarg :: arg :: before *)
mkApp (proj, [| argtyp ; wfargpred ; mkRel 1 |])
@@ -280,7 +284,7 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation boxed =
let intern_fun_binder = (Name (add_suffix recname "'"), None, intern_fun_arity_prod) in
let curry_fun =
let wfpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel (2 * len + 4))) in
- let arg = mkApp ((Lazy.force sig_).intro, [| argtyp; wfpred; lift 1 make; mkRel 1 |]) in
+ let arg = mkApp ((delayed_force sig_).intro, [| argtyp; wfpred; lift 1 make; mkRel 1 |]) in
let app = mkApp (mkRel (2 * len + 2 (* recproof + orig binders + current binders *)), [| arg |]) in
let rcurry = mkApp (rel, [| measure; lift len measure |]) in
let lam = (Name (id_of_string "recproof"), None, rcurry) in
@@ -292,21 +296,20 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation boxed =
let lift_lets = Termops.lift_rel_context 1 letbinders in
let intern_body =
let ctx = (Name recname, None, pi3 curry_fun) :: binders_rel in
- let (r, l, impls, scopes) =
+ let (r, l, impls, scopes) =
Constrintern.compute_internalization_data env
Constrintern.Recursive full_arity impls
in
let newimpls = [(recname, (r, l, impls @
[Some (id_of_string "recproof", Impargs.Manual, (true, false))],
scopes @ [None]))] in
- let newimpls = Constrintern.set_internalization_env_params newimpls [] in
interp_casted_constr isevars ~impls:newimpls
(push_rel_context ctx env) body (lift 1 top_arity)
in
let intern_body_lam = it_mkLambda_or_LetIn intern_body (curry_fun :: lift_lets @ fun_bl) in
let prop = mkLambda (Name argname, argtyp, top_arity_let) in
let def =
- mkApp (constr_of_global (Lazy.force fix_sub_ref),
+ mkApp (constr_of_global (delayed_force fix_sub_ref),
[| argtyp ; wf_rel ;
make_existential dummy_loc ~opaque:(Define false) env isevars wf_proof ;
prop ; intern_body_lam |])
@@ -429,7 +432,7 @@ let interp_recursive fixkind l boxed =
List.fold_left2 (fun env' id t ->
let sort = Retyping.get_type_of env !evdref t in
let fixprot =
- try mkApp (Lazy.force Subtac_utils.fix_proto, [|sort; t|])
+ try mkApp (delayed_force Subtac_utils.fix_proto, [|sort; t|])
with e -> t
in
(id,None,fixprot) :: env')
@@ -438,8 +441,8 @@ let interp_recursive fixkind l boxed =
let env_rec = push_named_context rec_sign env in
(* Get interpretation metadatas *)
- let impls = Constrintern.compute_full_internalization_env env
- Constrintern.Recursive [] fixnames fixtypes fiximps
+ let impls = Constrintern.compute_internalization_env env
+ Constrintern.Recursive fixnames fixtypes fiximps
in
let notations = List.flatten ntnl in
@@ -453,7 +456,7 @@ let interp_recursive fixkind l boxed =
let fixdefs = List.map out_def fixdefs in
(* Instantiate evars and check all are resolved *)
- let evd,_ = Evarconv.consider_remaining_unif_problems env_rec !evdref in
+ let evd = Evarconv.consider_remaining_unif_problems env_rec !evdref in
let evd = Typeclasses.resolve_typeclasses
~onlyargs:true ~split:true ~fail:false env_rec evd
in
@@ -518,8 +521,8 @@ let build_recursive l b =
m ntn false)
| _, _ when List.for_all (fun (n, ro) -> ro = CStructRec) g ->
- let fixl = List.map (fun (((_,id),_,bl,typ,def),ntn) ->
- ({Command.fix_name = id; Command.fix_binders = bl;
+ let fixl = List.map (fun (((_,id),(n,ro),bl,typ,def),ntn) ->
+ ({Command.fix_name = id; Command.fix_binders = bl; Command.fix_annot = n;
Command.fix_body = def; Command.fix_type = typ},ntn)) l
in interp_recursive (IsFixpoint g) fixl b
| _, _ ->
@@ -528,7 +531,7 @@ let build_recursive l b =
let build_corecursive l b =
let fixl = List.map (fun (((_,id),bl,typ,def),ntn) ->
- ({Command.fix_name = id; Command.fix_binders = bl;
+ ({Command.fix_name = id; Command.fix_binders = bl; Command.fix_annot = None;
Command.fix_body = def; Command.fix_type = typ},ntn))
l in
interp_recursive IsCoFixpoint fixl b
diff --git a/plugins/subtac/subtac_command.mli b/plugins/subtac/subtac_command.mli
index 304aa139..0f24915e 100644
--- a/plugins/subtac/subtac_command.mli
+++ b/plugins/subtac/subtac_command.mli
@@ -13,7 +13,7 @@ val interp_gen :
typing_constraint ->
evar_map ref ->
env ->
- ?impls:full_internalization_env ->
+ ?impls:internalization_env ->
?allow_patvar:bool ->
?ltacvars:ltac_sign ->
constr_expr -> constr
@@ -23,12 +23,12 @@ val interp_constr :
val interp_type_evars :
evar_map ref ->
env ->
- ?impls:full_internalization_env ->
+ ?impls:internalization_env ->
constr_expr -> constr
val interp_casted_constr_evars :
evar_map ref ->
env ->
- ?impls:full_internalization_env ->
+ ?impls:internalization_env ->
constr_expr -> types -> constr
val interp_open_constr :
evar_map ref -> env -> constr_expr -> constr
diff --git a/plugins/subtac/subtac_obligations.ml b/plugins/subtac/subtac_obligations.ml
index 2836bc73..1424618f 100644
--- a/plugins/subtac/subtac_obligations.ml
+++ b/plugins/subtac/subtac_obligations.ml
@@ -21,8 +21,8 @@ let ppwarn cmd = Pp.warn (str"Program:" ++ cmd)
let pperror cmd = Util.errorlabstrm "Program" cmd
let error s = pperror (str s)
-let reduce =
- Reductionops.clos_norm_flags Closure.betaiotazeta (Global.env ()) Evd.empty
+let reduce c =
+ Reductionops.clos_norm_flags Closure.betaiota (Global.env ()) Evd.empty c
exception NoObligations of identifier option
@@ -61,16 +61,15 @@ type program_info = {
prg_implicits : (Topconstr.explicitation * (bool * bool * bool)) list;
prg_notations : notations ;
prg_kind : definition_kind;
+ prg_reduce : constr -> constr;
prg_hook : Tacexpr.declaration_hook;
}
let assumption_message id =
Flags.if_verbose message ((string_of_id id) ^ " is assumed")
-let default_tactic : Proof_type.tactic ref = ref Refiner.tclIDTAC
-let default_tactic_expr : Tacexpr.glob_tactic_expr ref = ref (Tacexpr.TacId [])
-
-let set_default_tactic t = default_tactic_expr := t; default_tactic := Tacinterp.eval_tactic t
+let (set_default_tactic, get_default_tactic, print_default_tactic) =
+ Tactic_option.declare_tactic_option "Program tactic"
(* true = All transparent, false = Opaque if possible *)
let proofs_transparency = ref true
@@ -136,10 +135,9 @@ let map_first m =
let from_prg : program_info ProgMap.t ref = ref ProgMap.empty
-let freeze () = !from_prg, !default_tactic_expr
-let unfreeze (v, t) = from_prg := v; set_default_tactic t
-let init () =
- from_prg := ProgMap.empty; set_default_tactic (Tacexpr.TacId [])
+let freeze () = !from_prg
+let unfreeze v = from_prg := v
+let init () = from_prg := ProgMap.empty
(** Beware: if this code is dynamically loaded via dynlink after the start
of Coq, then this [init] function will not be run by [Lib.init ()].
@@ -155,35 +153,16 @@ let _ =
let progmap_union = ProgMap.fold ProgMap.add
-let cache (_, (local, tac)) =
- set_default_tactic tac
-
-let load (_, (local, tac)) =
- if not local then set_default_tactic tac
-
-let subst (s, (local, tac)) =
- (local, Tacinterp.subst_tactic s tac)
-
let (input,output) =
declare_object
{ (default_object "Program state") with
- cache_function = cache;
- load_function = (fun _ -> load);
- open_function = (fun _ -> load);
- classify_function = (fun (local, tac) ->
+ classify_function = (fun () ->
if not (ProgMap.is_empty !from_prg) then
errorlabstrm "Program" (str "Unsolved obligations when closing module:" ++ spc () ++
prlist_with_sep spc (fun x -> Nameops.pr_id x)
(map_keys !from_prg));
- if local then Dispose else Substitute (local, tac));
- subst_function = subst}
+ Dispose) }
-let update_state local =
- Lib.add_anonymous_leaf (input (local, !default_tactic_expr))
-
-let set_default_tactic local t =
- set_default_tactic t; update_state local
-
open Evd
let progmap_remove prg =
@@ -270,7 +249,7 @@ let declare_mutual_definition l =
let subs, typ = (subst_body true x) in
let term = snd (Reductionops.splay_lam_n (Global.env ()) Evd.empty len subs) in
let typ = snd (Reductionops.splay_prod_n (Global.env ()) Evd.empty len typ) in
- reduce term, reduce typ, x.prg_implicits) l)
+ x.prg_reduce term, x.prg_reduce typ, x.prg_implicits) l)
in
(* let fixdefs = List.map reduce_fix fixdefs in *)
let fixkind = Option.get first.prg_fixkind in
@@ -300,8 +279,8 @@ let declare_mutual_definition l =
List.iter progmap_remove l; kn
let declare_obligation prg obl body =
- let body = reduce body in
- let ty = reduce obl.obl_type in
+ let body = prg.prg_reduce body in
+ let ty = prg.prg_reduce obl.obl_type in
match obl.obl_status with
| Expand -> { obl with obl_body = Some body }
| Define opaque ->
@@ -321,9 +300,7 @@ let declare_obligation prg obl body =
print_message (Subtac_utils.definition_message obl.obl_name);
{ obl with obl_body = Some (mkConst constant) }
-let red = Reductionops.nf_betaiota Evd.empty
-
-let init_prog_info n b t deps fixkind notations obls impls kind hook =
+let init_prog_info n b t deps fixkind notations obls impls kind reduce hook =
let obls', b =
match b with
| None ->
@@ -337,13 +314,13 @@ let init_prog_info n b t deps fixkind notations obls impls kind hook =
Array.mapi
(fun i (n, t, l, o, d, tac) ->
{ obl_name = n ; obl_body = None;
- obl_location = l; obl_type = red t; obl_status = o;
+ obl_location = l; obl_type = reduce t; obl_status = o;
obl_deps = d; obl_tac = tac })
obls, b
in
- { prg_name = n ; prg_body = b; prg_type = red t; prg_obligations = (obls', Array.length obls');
+ { prg_name = n ; prg_body = b; prg_type = reduce t; prg_obligations = (obls', Array.length obls');
prg_deps = deps; prg_fixkind = fixkind ; prg_notations = notations ;
- prg_implicits = impls; prg_kind = kind; prg_hook = hook; }
+ prg_implicits = impls; prg_kind = kind; prg_reduce = reduce; prg_hook = hook; }
let get_prog name =
let prg_infos = !from_prg in
@@ -469,7 +446,7 @@ let rec solve_obligation prg num tac =
| _ -> ());
trace (str "Started obligation " ++ int user_num ++ str " proof: " ++
Subtac_utils.my_print_constr (Global.env ()) obl.obl_type);
- Pfedit.by !default_tactic;
+ Pfedit.by (snd (get_default_tactic ()));
Option.iter (fun tac -> Pfedit.set_end_tac (Tacinterp.interp tac)) tac;
Flags.if_verbose (fun () -> msg (Printer.pr_open_subgoals ())) ()
| l -> pperror (str "Obligation " ++ int user_num ++ str " depends on obligation(s) "
@@ -501,7 +478,7 @@ and solve_obligation_by_tac prg obls i tac =
| None ->
match obl.obl_tac with
| Some t -> t
- | None -> !default_tactic
+ | None -> snd (get_default_tactic ())
in
let t = Subtac_utils.solve_by_tac (evar_of_obligation obl) tac in
obls.(i) <- declare_obligation prg obl t;
@@ -579,9 +556,10 @@ let show_term n =
my_print_constr (Global.env ()) prg.prg_type ++ spc () ++ str ":=" ++ fnl ()
++ my_print_constr (Global.env ()) prg.prg_body)
-let add_definition n ?term t ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic ?(hook=fun _ _ -> ()) obls =
+let add_definition n ?term t ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic
+ ?(reduce=reduce) ?(hook=fun _ _ -> ()) obls =
Flags.if_verbose pp (str (string_of_id n) ++ str " has type-checked");
- let prg = init_prog_info n term t [] None [] obls implicits kind hook in
+ let prg = init_prog_info n term t [] None [] obls implicits kind reduce hook in
let obls,_ = prg.prg_obligations in
if Array.length obls = 0 then (
Flags.if_verbose ppnl (str ".");
@@ -596,12 +574,14 @@ let add_definition n ?term t ?(implicits=[]) ?(kind=Global,false,Definition) ?ta
| Remain rem -> Flags.if_verbose (fun () -> show_obligations ~msg:false (Some n)) (); res
| _ -> res)
-let add_mutual_definitions l ?tactic ?(kind=Global,false,Definition) ?(hook=fun _ _ -> ()) notations fixkind =
+let add_mutual_definitions l ?tactic ?(kind=Global,false,Definition) ?(reduce=reduce)
+ ?(hook=fun _ _ -> ()) notations fixkind =
let deps = List.map (fun (n, b, t, imps, obls) -> n) l in
let upd = List.fold_left
(fun acc (n, b, t, imps, obls) ->
- let prg = init_prog_info n (Some b) t deps (Some fixkind) notations obls imps kind hook in
- ProgMap.add n prg acc)
+ let prg = init_prog_info n (Some b) t deps (Some fixkind)
+ notations obls imps kind reduce hook
+ in ProgMap.add n prg acc)
!from_prg l
in
from_prg := upd;
@@ -647,6 +627,3 @@ let next_obligation n tac =
try array_find (fun x -> x.obl_body = None && deps_remaining obls x.obl_deps = []) obls
with Not_found -> anomaly "Could not find a solvable obligation."
in solve_obligation prg i tac
-
-let default_tactic () = !default_tactic
-let default_tactic_expr () = !default_tactic_expr
diff --git a/plugins/subtac/subtac_obligations.mli b/plugins/subtac/subtac_obligations.mli
index 1608c134..bc5fc3e1 100644
--- a/plugins/subtac/subtac_obligations.mli
+++ b/plugins/subtac/subtac_obligations.mli
@@ -3,6 +3,7 @@ open Util
open Libnames
open Evd
open Proof_type
+open Vernacexpr
type obligation_info =
(identifier * Term.types * loc *
@@ -16,8 +17,8 @@ type progress = (* Resolution status of a program *)
| Defined of global_reference (* Defined as id *)
val set_default_tactic : bool -> Tacexpr.glob_tactic_expr -> unit
-val default_tactic : unit -> Proof_type.tactic
-val default_tactic_expr : unit -> Tacexpr.glob_tactic_expr
+val get_default_tactic : unit -> locality_flag * Proof_type.tactic
+val print_default_tactic : unit -> Pp.std_ppcmds
val set_proofs_transparency : bool -> unit (* true = All transparent, false = Opaque if possible *)
val get_proofs_transparency : unit -> bool
@@ -26,6 +27,7 @@ val add_definition : Names.identifier -> ?term:Term.constr -> Term.types ->
?implicits:(Topconstr.explicitation * (bool * bool * bool)) list ->
?kind:Decl_kinds.definition_kind ->
?tactic:Proof_type.tactic ->
+ ?reduce:(Term.constr -> Term.constr) ->
?hook:(Tacexpr.declaration_hook) -> obligation_info -> progress
type notations = (Vernacexpr.lstring * Topconstr.constr_expr * Topconstr.scope_name option) list
@@ -39,6 +41,7 @@ val add_mutual_definitions :
(Topconstr.explicitation * (bool * bool * bool)) list * obligation_info) list ->
?tactic:Proof_type.tactic ->
?kind:Decl_kinds.definition_kind ->
+ ?reduce:(Term.constr -> Term.constr) ->
?hook:Tacexpr.declaration_hook ->
notations ->
fixpoint_kind -> unit
diff --git a/plugins/subtac/subtac_pretyping.ml b/plugins/subtac/subtac_pretyping.ml
index 030bb3c5..23323ab3 100644
--- a/plugins/subtac/subtac_pretyping.ml
+++ b/plugins/subtac/subtac_pretyping.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: subtac_pretyping.ml 13344 2010-07-28 15:04:36Z msozeau $ *)
open Global
open Pp
@@ -70,7 +70,7 @@ let merge_evms x y =
let interp env isevars c tycon =
let j = pretype tycon env isevars ([],[]) c in
let _ = isevars := Evarutil.nf_evar_map !isevars in
- let evd,_ = consider_remaining_unif_problems env !isevars in
+ let evd = consider_remaining_unif_problems env !isevars in
(* let unevd = undefined_evars evd in *)
let unevd' = Typeclasses.resolve_typeclasses ~onlyargs:true ~split:true ~fail:true env evd in
let unevd' = Typeclasses.resolve_typeclasses ~onlyargs:false ~split:true ~fail:false env unevd' in
@@ -86,8 +86,10 @@ let find_with_index x l =
open Vernacexpr
-let coqintern_constr evd env : Topconstr.constr_expr -> Rawterm.rawconstr = Constrintern.intern_constr ( evd) env
-let coqintern_type evd env : Topconstr.constr_expr -> Rawterm.rawconstr = Constrintern.intern_type ( evd) env
+let coqintern_constr evd env : Topconstr.constr_expr -> Rawterm.rawconstr =
+ Constrintern.intern_constr evd env
+let coqintern_type evd env : Topconstr.constr_expr -> Rawterm.rawconstr =
+ Constrintern.intern_type evd env
let env_with_binders env isevars l =
let rec aux ((env, rels) as acc) = function
@@ -109,21 +111,25 @@ let env_with_binders env isevars l =
| [] -> acc
in aux (env, []) l
-let subtac_process env isevars id bl c tycon =
+let subtac_process ?(is_type=false) env isevars id bl c tycon =
let c = Topconstr.abstract_constr_expr c bl in
- let tycon =
+ let tycon, imps =
match tycon with
- None -> empty_tycon
+ None -> empty_tycon, None
| Some t ->
let t = Topconstr.prod_constr_expr t bl in
let t = coqintern_type !isevars env t in
+ let imps = Implicit_quantifiers.implicits_of_rawterm t in
let coqt, ttyp = interp env isevars t empty_tycon in
- mk_tycon coqt
+ mk_tycon coqt, Some imps
in
let c = coqintern_constr !isevars env c in
- let imps = Implicit_quantifiers.implicits_of_rawterm c in
+ let imps = match imps with
+ | Some i -> i
+ | None -> Implicit_quantifiers.implicits_of_rawterm ~with_products:is_type c
+ in
let coqc, ctyp = interp env isevars c tycon in
- let evm = non_instanciated_map env isevars ( !isevars) in
+ let evm = non_instanciated_map env isevars !isevars in
let ty = nf_evar !isevars (match tycon with Some (None, c) -> c | _ -> ctyp) in
evm, coqc, ty, imps
diff --git a/plugins/subtac/subtac_pretyping.mli b/plugins/subtac/subtac_pretyping.mli
index 055c6df2..48906b23 100644
--- a/plugins/subtac/subtac_pretyping.mli
+++ b/plugins/subtac/subtac_pretyping.mli
@@ -16,7 +16,7 @@ val interp :
Rawterm.rawconstr ->
Evarutil.type_constraint -> Term.constr * Term.constr
-val subtac_process : env -> evar_map ref -> identifier -> local_binder list ->
+val subtac_process : ?is_type:bool -> env -> evar_map ref -> identifier -> local_binder list ->
constr_expr -> constr_expr option -> evar_map * constr * types * manual_explicitation list
val subtac_proof : Decl_kinds.definition_kind -> Tacexpr.declaration_hook -> env -> evar_map ref -> identifier -> local_binder list ->
diff --git a/plugins/subtac/subtac_pretyping_F.ml b/plugins/subtac/subtac_pretyping_F.ml
index 16f2031b..7fcd4267 100644
--- a/plugins/subtac/subtac_pretyping_F.ml
+++ b/plugins/subtac/subtac_pretyping_F.ml
@@ -7,7 +7,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: subtac_pretyping_F.ml 13332 2010-07-26 22:12:43Z msozeau $ *)
open Pp
open Util
@@ -166,6 +166,28 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
| RProp c -> judge_of_prop_contents c
| RType _ -> judge_of_new_Type ()
+ let split_tycon_lam loc env evd tycon =
+ let rec real_split evd c =
+ let t = whd_betadeltaiota env evd c in
+ match kind_of_term t with
+ | Prod (na,dom,rng) -> evd, (na, dom, rng)
+ | Evar ev when not (Evd.is_defined_evar evd ev) ->
+ let (evd',prod) = define_evar_as_product evd ev in
+ let (_,dom,rng) = destProd prod in
+ evd',(Anonymous, dom, rng)
+ | _ -> error_not_product_loc loc env evd c
+ in
+ match tycon with
+ | None -> evd,(Anonymous,None,None)
+ | Some (abs, c) ->
+ (match abs with
+ | None ->
+ let evd', (n, dom, rng) = real_split evd c in
+ evd', (n, mk_tycon dom, mk_tycon rng)
+ | Some (init, cur) ->
+ evd, (Anonymous, None, Some (Some (init, succ cur), c)))
+
+
(* [pretype tycon env evdref lvar lmeta cstr] attempts to type [cstr] *)
(* in environment [env], with existential variables [( evdref)] and *)
(* the type constraint tycon *)
@@ -233,7 +255,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
let newenv =
let marked_ftys =
Array.map (fun ty -> let sort = Retyping.get_type_of env !evdref ty in
- mkApp (Lazy.force Subtac_utils.fix_proto, [| sort; ty |]))
+ mkApp (delayed_force Subtac_utils.fix_proto, [| sort; ty |]))
ftys
in
push_rec_types (names,marked_ftys,[||]) env
@@ -355,7 +377,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
evd, Some ty')
evdref tycon
in
- let (name',dom,rng) = evd_comb1 (split_tycon loc env) evdref tycon' in
+ let (name',dom,rng) = evd_comb1 (split_tycon_lam loc env) evdref tycon' in
let dom_valcon = valcon_of_tycon dom in
let j = pretype_type dom_valcon env evdref lvar c1 in
let var = (name,None,j.utj_val) in
@@ -586,11 +608,11 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
(pretype tycon env evdref lvar c).uj_val
| IsType ->
(pretype_type empty_valcon env evdref lvar c).utj_val in
- evdref := fst (consider_remaining_unif_problems env !evdref);
+ evdref := consider_remaining_unif_problems env !evdref;
if resolve_classes then
- evdref :=
- Typeclasses.resolve_typeclasses ~onlyargs:false
+ (evdref := Typeclasses.resolve_typeclasses ~onlyargs:false
~split:true ~fail:fail_evar env !evdref;
+ evdref := consider_remaining_unif_problems env !evdref);
let c = if expand_evar then nf_evar !evdref c' else c' in
if fail_evar then check_evars env Evd.empty !evdref c;
c
@@ -603,7 +625,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
let understand_judgment sigma env c =
let evdref = ref (create_evar_defs sigma) in
let j = pretype empty_tycon env evdref ([],[]) c in
- let evd,_ = consider_remaining_unif_problems env !evdref in
+ let evd = consider_remaining_unif_problems env !evdref in
let j = j_nf_evar evd j in
check_evars env sigma evd (mkCast(j.uj_val,DEFAULTcast, j.uj_type));
j
diff --git a/plugins/subtac/subtac_utils.ml b/plugins/subtac/subtac_utils.ml
index 06a80f68..689b110f 100644
--- a/plugins/subtac/subtac_utils.ml
+++ b/plugins/subtac/subtac_utils.ml
@@ -1,3 +1,5 @@
+(** -*- compile-command: "make -C ../.. plugins/subtac/subtac_plugin.cma" -*- *)
+
open Evd
open Libnames
open Coqlib
@@ -18,14 +20,14 @@ let utils_module = "Utils"
let fixsub_module = subtac_dir @ [fix_sub_module]
let utils_module = subtac_dir @ [utils_module]
let tactics_module = subtac_dir @ ["Tactics"]
-let init_constant dir s = gen_constant contrib_name dir s
-let init_reference dir s = gen_reference contrib_name dir s
+let init_constant dir s () = gen_constant contrib_name dir s
+let init_reference dir s () = gen_reference contrib_name dir s
-let fixsub = lazy (init_constant fixsub_module "Fix_sub")
-let ex_pi1 = lazy (init_constant utils_module "ex_pi1")
-let ex_pi2 = lazy (init_constant utils_module "ex_pi2")
+let fixsub = init_constant fixsub_module "Fix_sub"
+let ex_pi1 = init_constant utils_module "ex_pi1"
+let ex_pi2 = init_constant utils_module "ex_pi2"
-let make_ref l s = lazy (init_reference l s)
+let make_ref l s = init_reference l s
let well_founded_ref = make_ref ["Init";"Wf"] "Well_founded"
let acc_ref = make_ref ["Init";"Wf"] "Acc"
let acc_inv_ref = make_ref ["Init";"Wf"] "Acc_inv"
@@ -41,68 +43,67 @@ let proj1_sig_ref = make_ref "Init.Specif.proj1_sig"
let proj2_sig_ref = make_ref "Init.Specif.proj2_sig"
let build_sig () =
- { proj1 = init_constant ["Init"; "Specif"] "proj1_sig";
- proj2 = init_constant ["Init"; "Specif"] "proj2_sig";
- elim = init_constant ["Init"; "Specif"] "sig_rec";
- intro = init_constant ["Init"; "Specif"] "exist";
- typ = init_constant ["Init"; "Specif"] "sig" }
+ { proj1 = init_constant ["Init"; "Specif"] "proj1_sig" ();
+ proj2 = init_constant ["Init"; "Specif"] "proj2_sig" ();
+ elim = init_constant ["Init"; "Specif"] "sig_rec" ();
+ intro = init_constant ["Init"; "Specif"] "exist" ();
+ typ = init_constant ["Init"; "Specif"] "sig" () }
-let sig_ = lazy (build_sig ())
+let sig_ = build_sig
-let fix_proto = lazy (init_constant tactics_module "fix_proto")
+let fix_proto = init_constant tactics_module "fix_proto"
let fix_proto_ref () =
match Nametab.global (make_ref "Program.Tactics.fix_proto") with
| ConstRef c -> c
| _ -> assert false
-let eq_ind = lazy (init_constant ["Init"; "Logic"] "eq")
-let eq_rec = lazy (init_constant ["Init"; "Logic"] "eq_rec")
-let eq_rect = lazy (init_constant ["Init"; "Logic"] "eq_rect")
-let eq_refl = lazy (init_constant ["Init"; "Logic"] "refl_equal")
-let eq_ind_ref = lazy (init_reference ["Init"; "Logic"] "eq")
-let refl_equal_ref = lazy (init_reference ["Init"; "Logic"] "refl_equal")
+let eq_ind = init_constant ["Init"; "Logic"] "eq"
+let eq_rec = init_constant ["Init"; "Logic"] "eq_rec"
+let eq_rect = init_constant ["Init"; "Logic"] "eq_rect"
+let eq_refl = init_constant ["Init"; "Logic"] "refl_equal"
+let eq_ind_ref = init_reference ["Init"; "Logic"] "eq"
+let refl_equal_ref = init_reference ["Init"; "Logic"] "refl_equal"
-let not_ref = lazy (init_constant ["Init"; "Logic"] "not")
+let not_ref = init_constant ["Init"; "Logic"] "not"
-let and_typ = lazy (Coqlib.build_coq_and ())
+let and_typ = Coqlib.build_coq_and
-let eqdep_ind = lazy (init_constant [ "Logic";"Eqdep"] "eq_dep")
-let eqdep_rec = lazy (init_constant ["Logic";"Eqdep"] "eq_dep_rec")
-let eqdep_ind_ref = lazy (init_reference [ "Logic";"Eqdep"] "eq_dep")
-let eqdep_intro_ref = lazy (init_reference [ "Logic";"Eqdep"] "eq_dep_intro")
+let eqdep_ind = init_constant [ "Logic";"Eqdep"] "eq_dep"
+let eqdep_rec = init_constant ["Logic";"Eqdep"] "eq_dep_rec"
+let eqdep_ind_ref = init_reference [ "Logic";"Eqdep"] "eq_dep"
+let eqdep_intro_ref = init_reference [ "Logic";"Eqdep"] "eq_dep_intro"
let jmeq_ind =
- lazy (check_required_library ["Coq";"Logic";"JMeq"];
- init_constant ["Logic";"JMeq"] "JMeq")
+ init_constant ["Logic";"JMeq"] "JMeq"
+
let jmeq_rec =
- lazy (check_required_library ["Coq";"Logic";"JMeq"];
- init_constant ["Logic";"JMeq"] "JMeq_rec")
+ init_constant ["Logic";"JMeq"] "JMeq_rec"
+
let jmeq_refl =
- lazy (check_required_library ["Coq";"Logic";"JMeq"];
- init_constant ["Logic";"JMeq"] "JMeq_refl")
+ init_constant ["Logic";"JMeq"] "JMeq_refl"
-let ex_ind = lazy (init_constant ["Init"; "Logic"] "ex")
-let ex_intro = lazy (init_reference ["Init"; "Logic"] "ex_intro")
+let ex_ind = init_constant ["Init"; "Logic"] "ex"
+let ex_intro = init_reference ["Init"; "Logic"] "ex_intro"
-let proj1 = lazy (init_constant ["Init"; "Logic"] "proj1")
-let proj2 = lazy (init_constant ["Init"; "Logic"] "proj2")
+let proj1 = init_constant ["Init"; "Logic"] "proj1"
+let proj2 = init_constant ["Init"; "Logic"] "proj2"
-let boolind = lazy (init_constant ["Init"; "Datatypes"] "bool")
-let sumboolind = lazy (init_constant ["Init"; "Specif"] "sumbool")
-let natind = lazy (init_constant ["Init"; "Datatypes"] "nat")
-let intind = lazy (init_constant ["ZArith"; "binint"] "Z")
-let existSind = lazy (init_constant ["Init"; "Specif"] "sigS")
+let boolind = init_constant ["Init"; "Datatypes"] "bool"
+let sumboolind = init_constant ["Init"; "Specif"] "sumbool"
+let natind = init_constant ["Init"; "Datatypes"] "nat"
+let intind = init_constant ["ZArith"; "binint"] "Z"
+let existSind = init_constant ["Init"; "Specif"] "sigS"
-let existS = lazy (build_sigma_type ())
+let existS = build_sigma_type
-let prod = lazy (build_prod ())
+let prod = build_prod
(* orders *)
-let well_founded = lazy (init_constant ["Init"; "Wf"] "well_founded")
-let fix = lazy (init_constant ["Init"; "Wf"] "Fix")
-let acc = lazy (init_constant ["Init"; "Wf"] "Acc")
-let acc_inv = lazy (init_constant ["Init"; "Wf"] "Acc_inv")
+let well_founded = init_constant ["Init"; "Wf"] "well_founded"
+let fix = init_constant ["Init"; "Wf"] "Fix"
+let acc = init_constant ["Init"; "Wf"] "Acc"
+let acc_inv = init_constant ["Init"; "Wf"] "Acc_inv"
let extconstr = Constrextern.extern_constr true (Global.env ())
let extsort s = Constrextern.extern_constr true (Global.env ()) (mkSort s)
@@ -151,8 +152,8 @@ let wf_relations = Hashtbl.create 10
let std_relations () =
let add k v = Hashtbl.add wf_relations k v in
- add (init_constant ["Init"; "Peano"] "lt")
- (lazy (init_constant ["Arith"; "Wf_nat"] "lt_wf"))
+ add (init_constant ["Init"; "Peano"] "lt" ())
+ (init_constant ["Arith"; "Wf_nat"] "lt_wf")
let std_relations = Lazy.lazy_from_fun std_relations
@@ -226,7 +227,6 @@ let goal_fix_kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Fixp
open Tactics
open Tacticals
-let id x = x
let filter_map f l =
let rec aux acc = function
hd :: tl -> (match f hd with Some t -> aux (t :: acc) tl
@@ -257,51 +257,51 @@ let build_dependent_sum l =
(fun typ ->
let tex = mkLambda (Name n, t, typ) in
conttype
- (mkApp (Lazy.force ex_ind, [| t; tex |])))
+ (mkApp (ex_ind (), [| t; tex |])))
in
aux (mkVar n :: names) conttac conttype tl
| (n, t) :: [] ->
(conttac intros, conttype t)
| [] -> raise (Invalid_argument "build_dependent_sum")
- in aux [] id id (List.rev l)
+ in aux [] identity identity (List.rev l)
open Proof_type
open Tacexpr
let mkProj1 a b c =
- mkApp (Lazy.force proj1, [| a; b; c |])
+ mkApp (delayed_force proj1, [| a; b; c |])
let mkProj2 a b c =
- mkApp (Lazy.force proj2, [| a; b; c |])
+ mkApp (delayed_force proj2, [| a; b; c |])
let mk_ex_pi1 a b c =
- mkApp (Lazy.force ex_pi1, [| a; b; c |])
+ mkApp (delayed_force ex_pi1, [| a; b; c |])
let mk_ex_pi2 a b c =
- mkApp (Lazy.force ex_pi2, [| a; b; c |])
+ mkApp (delayed_force ex_pi2, [| a; b; c |])
let mkSubset name typ prop =
- mkApp ((Lazy.force sig_).typ,
+ mkApp ((delayed_force sig_).typ,
[| typ; mkLambda (name, typ, prop) |])
-let mk_eq typ x y = mkApp (Lazy.force eq_ind, [| typ; x ; y |])
-let mk_eq_refl typ x = mkApp (Lazy.force eq_refl, [| typ; x |])
-let mk_JMeq typ x typ' y = mkApp (Lazy.force jmeq_ind, [| typ; x ; typ'; y |])
-let mk_JMeq_refl typ x = mkApp (Lazy.force jmeq_refl, [| typ; x |])
+let mk_eq typ x y = mkApp (delayed_force eq_ind, [| typ; x ; y |])
+let mk_eq_refl typ x = mkApp (delayed_force eq_refl, [| typ; x |])
+let mk_JMeq typ x typ' y = mkApp (delayed_force jmeq_ind, [| typ; x ; typ'; y |])
+let mk_JMeq_refl typ x = mkApp (delayed_force jmeq_refl, [| typ; x |])
let unsafe_fold_right f = function
hd :: tl -> List.fold_right f tl hd
| [] -> raise (Invalid_argument "unsafe_fold_right")
let mk_conj l =
- let conj_typ = Lazy.force and_typ in
+ let conj_typ = delayed_force and_typ in
unsafe_fold_right
(fun c conj ->
mkApp (conj_typ, [| c ; conj |]))
l
let mk_not c =
- let notc = Lazy.force not_ref in
+ let notc = delayed_force not_ref in
mkApp (notc, [| c |])
let and_tac l hook =
@@ -336,7 +336,7 @@ let destruct_ex ext ex =
match kind_of_term c with
App (f, args) ->
(match kind_of_term f with
- Ind i when i = Term.destInd (Lazy.force ex_ind) && Array.length args = 2 ->
+ Ind i when i = Term.destInd (delayed_force ex_ind) && Array.length args = 2 ->
let (dom, rng) =
try (args.(0), args.(1))
with _ -> assert(false)
@@ -477,6 +477,7 @@ let pr_evar_map evd =
let contrib_tactics_path =
make_dirpath (List.map id_of_string ["Tactics";contrib_name;"Coq"])
+
let tactics_tac s =
lazy(make_kn (MPfile contrib_tactics_path) (make_dirpath []) (mk_label s))
diff --git a/plugins/subtac/subtac_utils.mli b/plugins/subtac/subtac_utils.mli
index d0ad334d..f56c2932 100644
--- a/plugins/subtac/subtac_utils.mli
+++ b/plugins/subtac/subtac_utils.mli
@@ -17,53 +17,53 @@ val contrib_name : string
val subtac_dir : string list
val fix_sub_module : string
val fixsub_module : string list
-val init_constant : string list -> string -> constr
-val init_reference : string list -> string -> global_reference
-val fixsub : constr lazy_t
-val well_founded_ref : global_reference lazy_t
-val acc_ref : global_reference lazy_t
-val acc_inv_ref : global_reference lazy_t
-val fix_sub_ref : global_reference lazy_t
-val measure_on_R_ref : global_reference lazy_t
-val fix_measure_sub_ref : global_reference lazy_t
-val refl_ref : global_reference lazy_t
+val init_constant : string list -> string -> constr delayed
+val init_reference : string list -> string -> global_reference delayed
+val fixsub : constr delayed
+val well_founded_ref : global_reference delayed
+val acc_ref : global_reference delayed
+val acc_inv_ref : global_reference delayed
+val fix_sub_ref : global_reference delayed
+val measure_on_R_ref : global_reference delayed
+val fix_measure_sub_ref : global_reference delayed
+val refl_ref : global_reference delayed
val lt_ref : reference
val sig_ref : reference
val proj1_sig_ref : reference
val proj2_sig_ref : reference
val build_sig : unit -> coq_sigma_data
-val sig_ : coq_sigma_data lazy_t
+val sig_ : coq_sigma_data delayed
-val fix_proto : constr lazy_t
+val fix_proto : constr delayed
val fix_proto_ref : unit -> constant
-val eq_ind : constr lazy_t
-val eq_rec : constr lazy_t
-val eq_rect : constr lazy_t
-val eq_refl : constr lazy_t
-
-val not_ref : constr lazy_t
-val and_typ : constr lazy_t
-
-val eqdep_ind : constr lazy_t
-val eqdep_rec : constr lazy_t
-
-val jmeq_ind : constr lazy_t
-val jmeq_rec : constr lazy_t
-val jmeq_refl : constr lazy_t
-
-val boolind : constr lazy_t
-val sumboolind : constr lazy_t
-val natind : constr lazy_t
-val intind : constr lazy_t
-val existSind : constr lazy_t
-val existS : coq_sigma_data lazy_t
-val prod : coq_sigma_data lazy_t
-
-val well_founded : constr lazy_t
-val fix : constr lazy_t
-val acc : constr lazy_t
-val acc_inv : constr lazy_t
+val eq_ind : constr delayed
+val eq_rec : constr delayed
+val eq_rect : constr delayed
+val eq_refl : constr delayed
+
+val not_ref : constr delayed
+val and_typ : constr delayed
+
+val eqdep_ind : constr delayed
+val eqdep_rec : constr delayed
+
+val jmeq_ind : constr delayed
+val jmeq_rec : constr delayed
+val jmeq_refl : constr delayed
+
+val boolind : constr delayed
+val sumboolind : constr delayed
+val natind : constr delayed
+val intind : constr delayed
+val existSind : constr delayed
+val existS : coq_sigma_data delayed
+val prod : coq_sigma_data delayed
+
+val well_founded : constr delayed
+val fix : constr delayed
+val acc : constr delayed
+val acc_inv : constr delayed
val extconstr : constr -> constr_expr
val extsort : sorts -> constr_expr
@@ -81,7 +81,7 @@ val my_print_tycon_type : env -> type_constraint_type -> std_ppcmds
val debug : int -> std_ppcmds -> unit
val debug_msg : int -> std_ppcmds -> std_ppcmds
val trace : std_ppcmds -> unit
-val wf_relations : (constr, constr lazy_t) Hashtbl.t
+val wf_relations : (constr, constr delayed) Hashtbl.t
type binders = local_binder list
val app_opt : ('a -> 'a) option -> 'a -> 'a
diff --git a/plugins/syntax/ascii_syntax.ml b/plugins/syntax/ascii_syntax.ml
index 19473dfa..ae3afff4 100644
--- a/plugins/syntax/ascii_syntax.ml
+++ b/plugins/syntax/ascii_syntax.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
-(*i $Id$ i*)
+(*i $Id: ascii_syntax.ml 12406 2009-10-21 15:12:52Z soubiran $ i*)
open Pp
open Util
diff --git a/plugins/syntax/nat_syntax.ml b/plugins/syntax/nat_syntax.ml
index 89419d5e..1e9a055f 100644
--- a/plugins/syntax/nat_syntax.ml
+++ b/plugins/syntax/nat_syntax.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: nat_syntax.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
(* This file defines the printer for natural numbers in [nat] *)
diff --git a/plugins/syntax/numbers_syntax.ml b/plugins/syntax/numbers_syntax.ml
index 162588ac..787577b2 100644
--- a/plugins/syntax/numbers_syntax.ml
+++ b/plugins/syntax/numbers_syntax.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: numbers_syntax.ml 13323 2010-07-24 15:57:30Z herbelin $ i*)
(* digit-based syntax for int31, bigN bigZ and bigQ *)
diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml
index f8e8e210..af1477f1 100644
--- a/plugins/syntax/r_syntax.ml
+++ b/plugins/syntax/r_syntax.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: r_syntax.ml 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Pp
open Util
diff --git a/plugins/syntax/string_syntax.ml b/plugins/syntax/string_syntax.ml
index bc02357a..534605c8 100644
--- a/plugins/syntax/string_syntax.ml
+++ b/plugins/syntax/string_syntax.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
-(*i $Id$ i*)
+(*i $Id: string_syntax.ml 12337 2009-09-17 15:58:14Z glondu $ i*)
open Pp
open Util
diff --git a/plugins/syntax/z_syntax.ml b/plugins/syntax/z_syntax.ml
index 931bd77d..87f14a64 100644
--- a/plugins/syntax/z_syntax.ml
+++ b/plugins/syntax/z_syntax.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: z_syntax.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Pcoq
open Pp
diff --git a/plugins/xml/xml.mli b/plugins/xml/xml.mli
index cfa050d7..2a9d1de4 100644
--- a/plugins/xml/xml.mli
+++ b/plugins/xml/xml.mli
@@ -12,7 +12,7 @@
(* http://helm.cs.unibo.it *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: xml.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(* Tokens for XML cdata, empty elements and not-empty elements *)
(* Usage: *)
diff --git a/plugins/xml/xmlcommand.mli b/plugins/xml/xmlcommand.mli
index fc9fbf32..476ad630 100644
--- a/plugins/xml/xmlcommand.mli
+++ b/plugins/xml/xmlcommand.mli
@@ -12,7 +12,7 @@
(* http://helm.cs.unibo.it *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: xmlcommand.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(* print_global qid fn *)
(* where qid is a long name denoting a definition/theorem or *)
diff --git a/plugins/xml/xmlentries.ml4 b/plugins/xml/xmlentries.ml4
index a6d815da..bf6c7388 100644
--- a/plugins/xml/xmlentries.ml4
+++ b/plugins/xml/xmlentries.ml4
@@ -14,7 +14,7 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
-(* $Id$ *)
+(* $Id: xmlentries.ml4 13323 2010-07-24 15:57:30Z herbelin $ *)
open Util;;
open Vernacinterp;;
diff --git a/pretyping/cases.ml b/pretyping/cases.ml
index eb02f7ae..9027315e 100644
--- a/pretyping/cases.ml
+++ b/pretyping/cases.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: cases.ml 13329 2010-07-26 11:05:39Z herbelin $ *)
open Util
open Names
@@ -1054,7 +1054,7 @@ let rec generalize_problem names pb = function
tomatch = Abstract d :: tomatch;
pred = generalize_predicate names i d pb.tomatch pb'.pred }
-(* No more patterns: typing the right-hand-side of equations *)
+(* No more patterns: typing the right-hand side of equations *)
let build_leaf pb =
let rhs = extract_rhs pb in
let j = pb.typing_function (mk_tycon pb.pred) rhs.rhs_env pb.evdref rhs.it in
@@ -1690,7 +1690,7 @@ let prepare_predicate loc typing_fun evdref env tomatchs sign tycon pred =
let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, eqns) =
- (* We build the matrix of patterns and right-hand-side *)
+ (* We build the matrix of patterns and right-hand side *)
let matx = matx_of_eqns env tomatchl eqns in
(* We build the vector of terms to match consistently with the *)
diff --git a/pretyping/cases.mli b/pretyping/cases.mli
index 8b8ab3db..7bc635fb 100644
--- a/pretyping/cases.mli
+++ b/pretyping/cases.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: cases.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Util
diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml
index b5550c19..ec71159b 100644
--- a/pretyping/cbv.ml
+++ b/pretyping/cbv.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: cbv.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Util
open Pp
diff --git a/pretyping/cbv.mli b/pretyping/cbv.mli
index c0081174..5486b064 100644
--- a/pretyping/cbv.mli
+++ b/pretyping/cbv.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: cbv.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Names
diff --git a/pretyping/classops.ml b/pretyping/classops.ml
index 4079728c..17f18a9b 100644
--- a/pretyping/classops.ml
+++ b/pretyping/classops.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: classops.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Util
open Pp
diff --git a/pretyping/classops.mli b/pretyping/classops.mli
index 54e57131..f905e392 100644
--- a/pretyping/classops.mli
+++ b/pretyping/classops.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: classops.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Names
diff --git a/pretyping/clenv.ml b/pretyping/clenv.ml
index 412763d7..a41cdd6f 100644
--- a/pretyping/clenv.ml
+++ b/pretyping/clenv.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: clenv.ml 13332 2010-07-26 22:12:43Z msozeau $ *)
open Pp
open Util
@@ -128,7 +128,7 @@ let clenv_conv_leq env sigma t c bound =
let evd = Evd.create_goal_evar_defs sigma in
let evars,args,_ = clenv_environments_evars env evd (Some bound) ty in
let evars = Evarconv.the_conv_x_leq env t (applist (c,args)) evars in
- let evars,_ = Evarconv.consider_remaining_unif_problems env evars in
+ let evars = Evarconv.consider_remaining_unif_problems env evars in
let args = List.map (whd_evar evars) args in
check_evars env sigma evars (applist (c,args));
args
@@ -454,18 +454,23 @@ let clenv_constrain_dep_args hyps_only bl clenv =
(****************************************************************)
(* Clausal environment for an application *)
-let make_clenv_binding_gen hyps_only n gls (c,t) = function
+
+let make_clenv_binding_gen hyps_only n env sigma (c,t) = function
| ImplicitBindings largs ->
- let clause = mk_clenv_from_n gls n (c,t) in
+ let clause = mk_clenv_from_env env sigma n (c,t) in
clenv_constrain_dep_args hyps_only largs clause
| ExplicitBindings lbind ->
- let clause = mk_clenv_rename_from_n gls n (c,t) in
- clenv_match_args lbind clause
+ let clause = mk_clenv_from_env env sigma n
+ (c,rename_bound_vars_as_displayed [] t)
+ in clenv_match_args lbind clause
| NoBindings ->
- mk_clenv_from_n gls n (c,t)
+ mk_clenv_from_env env sigma n (c,t)
-let make_clenv_binding_apply gls n = make_clenv_binding_gen true n gls
-let make_clenv_binding = make_clenv_binding_gen false None
+let make_clenv_binding_env_apply env sigma n =
+ make_clenv_binding_gen true n env sigma
+
+let make_clenv_binding_apply gls n = make_clenv_binding_gen true n (pf_env gls) gls.sigma
+let make_clenv_binding gls = make_clenv_binding_gen false None (pf_env gls) gls.sigma
(****************************************************************)
(* Pretty-print *)
diff --git a/pretyping/clenv.mli b/pretyping/clenv.mli
index aec9e7c9..b50e313c 100644
--- a/pretyping/clenv.mli
+++ b/pretyping/clenv.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: clenv.mli 13332 2010-07-26 22:12:43Z msozeau $ i*)
(*i*)
open Util
@@ -111,6 +111,9 @@ val clenv_unify_meta_types : ?flags:unify_flags -> clausenv -> clausenv
val make_clenv_binding_apply :
evar_info sigma -> int option -> constr * constr -> constr bindings ->
clausenv
+val make_clenv_binding_env_apply :
+ env -> evar_map -> int option -> constr * constr -> constr bindings ->
+ clausenv
val make_clenv_binding :
evar_info sigma -> constr * constr -> constr bindings -> clausenv
diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml
index 48a8d28e..dd099aa1 100644
--- a/pretyping/coercion.ml
+++ b/pretyping/coercion.ml
@@ -5,7 +5,7 @@
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: coercion.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Util
open Names
diff --git a/pretyping/coercion.mli b/pretyping/coercion.mli
index 89be8069..00848dac 100644
--- a/pretyping/coercion.mli
+++ b/pretyping/coercion.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: coercion.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Util
diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml
index c0e5234b..e435484e 100644
--- a/pretyping/detyping.ml
+++ b/pretyping/detyping.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: detyping.ml 13329 2010-07-26 11:05:39Z herbelin $ *)
open Pp
open Util
@@ -364,6 +364,8 @@ let detype_sort = function
| Prop c -> RProp c
| Type u -> RType (Some u)
+type binder_kind = BProd | BLambda | BLetIn
+
(**********************************************************************)
(* Main detyping function *)
diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli
index ecf724ca..cdb840b6 100644
--- a/pretyping/detyping.mli
+++ b/pretyping/detyping.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: detyping.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Util
diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml
index 20957e07..51183be3 100644
--- a/pretyping/evarconv.ml
+++ b/pretyping/evarconv.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: evarconv.ml 13332 2010-07-26 22:12:43Z msozeau $ *)
open Pp
open Util
@@ -551,10 +551,10 @@ let apply_conversion_problem_heuristic env evd pbty t1 t2 =
let consider_remaining_unif_problems env evd =
let (evd,pbs) = extract_all_conv_pbs evd in
List.fold_left
- (fun (evd,b as p) (pbty,env,t1,t2) ->
- if b then apply_conversion_problem_heuristic env evd pbty t1 t2 else p)
- (evd,true)
- pbs
+ (fun evd (pbty,env,t1,t2) ->
+ let evd', b = apply_conversion_problem_heuristic env evd pbty t1 t2 in
+ if b then evd' else Pretype_errors.error_cannot_unify env evd (t1, t2))
+ evd pbs
(* Main entry points *)
diff --git a/pretyping/evarconv.mli b/pretyping/evarconv.mli
index add7ccd4..b0702038 100644
--- a/pretyping/evarconv.mli
+++ b/pretyping/evarconv.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: evarconv.mli 13332 2010-07-26 22:12:43Z msozeau $ i*)
(*i*)
open Term
@@ -34,7 +34,7 @@ val evar_eqappr_x :
evar_map * bool
(*i*)
-val consider_remaining_unif_problems : env -> evar_map -> evar_map * bool
+val consider_remaining_unif_problems : env -> evar_map -> evar_map
val check_conv_record : constr * types list -> constr * types list ->
constr * constr list * (constr list * constr list) *
diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml
index ac653c75..09ec8dda 100644
--- a/pretyping/evarutil.ml
+++ b/pretyping/evarutil.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: evarutil.ml 13332 2010-07-26 22:12:43Z msozeau $ *)
open Util
open Pp
@@ -1434,6 +1434,10 @@ let judge_of_new_Type () = Typeops.judge_of_type (new_univ ())
constraint on its domain and codomain. If the input constraint is
an evar instantiate it with the product of 2 new evars. *)
+let unlift_tycon init cur c =
+ if cur = 1 then None, c
+ else Some (init, pred cur), c
+
let split_tycon loc env evd tycon =
let rec real_split evd c =
let t = whd_betadeltaiota env evd c in
@@ -1453,14 +1457,7 @@ let split_tycon loc env evd tycon =
let evd', (n, dom, rng) = real_split evd c in
evd', (n, mk_tycon dom, mk_tycon rng)
| Some (init, cur) ->
- if cur = 0 then
- let evd', (x, dom, rng) = real_split evd c in
- evd, (Anonymous,
- Some (None, dom),
- Some (None, rng))
- else
- evd, (Anonymous, None,
- Some (if cur = 1 then None,c else Some (init, pred cur), c)))
+ evd, (Anonymous, None, Some (unlift_tycon init cur c)))
let valcon_of_tycon x =
match x with
diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli
index d0b65d54..d677b972 100644
--- a/pretyping/evarutil.mli
+++ b/pretyping/evarutil.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: evarutil.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Util
diff --git a/pretyping/evd.ml b/pretyping/evd.ml
index 109fea4a..77442584 100644
--- a/pretyping/evd.ml
+++ b/pretyping/evd.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: evd.ml 13332 2010-07-26 22:12:43Z msozeau $ *)
open Pp
open Util
@@ -498,7 +498,8 @@ let create_evar_defs sigma = { sigma with
conv_pbs=[]; last_mods=ExistentialSet.empty; metas=Metamap.empty }
(* spiwack: tentatively deprecated *)
let create_goal_evar_defs sigma = { sigma with
- conv_pbs=[]; last_mods=ExistentialSet.empty; metas=Metamap.empty }
+ (* conv_pbs=[]; last_mods=ExistentialSet.empty; metas=Metamap.empty } *)
+ metas=Metamap.empty }
let empty = {
evars=EvarMap.empty;
conv_pbs=[];
diff --git a/pretyping/evd.mli b/pretyping/evd.mli
index ea484b5f..ce4e1b28 100644
--- a/pretyping/evd.mli
+++ b/pretyping/evd.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: evd.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Util
diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml
index f83aff69..927af594 100644
--- a/pretyping/indrec.ml
+++ b/pretyping/indrec.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: indrec.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
(* File initially created by Christine Paulin, 1996 *)
diff --git a/pretyping/indrec.mli b/pretyping/indrec.mli
index ea5d13dc..188ad74d 100644
--- a/pretyping/indrec.mli
+++ b/pretyping/indrec.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: indrec.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Names
diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml
index 03589c4f..85c865fa 100644
--- a/pretyping/inductiveops.ml
+++ b/pretyping/inductiveops.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: inductiveops.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Util
open Names
diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli
index 7f29cba9..251c6b2e 100644
--- a/pretyping/inductiveops.mli
+++ b/pretyping/inductiveops.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: inductiveops.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Names
open Term
diff --git a/pretyping/matching.ml b/pretyping/matching.ml
index 843122e7..6ee67bf2 100644
--- a/pretyping/matching.ml
+++ b/pretyping/matching.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: matching.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
(*i*)
open Util
diff --git a/pretyping/matching.mli b/pretyping/matching.mli
index 7677c076..25863129 100644
--- a/pretyping/matching.mli
+++ b/pretyping/matching.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: matching.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Names
diff --git a/pretyping/namegen.ml b/pretyping/namegen.ml
index 3c95d1ea..6e3e2f7c 100644
--- a/pretyping/namegen.ml
+++ b/pretyping/namegen.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: namegen.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
(* Created from contents that was formerly in termops.ml and
nameops.ml, Nov 2009 *)
diff --git a/pretyping/namegen.mli b/pretyping/namegen.mli
index fa89426c..419624b8 100644
--- a/pretyping/namegen.mli
+++ b/pretyping/namegen.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: namegen.mli 13323 2010-07-24 15:57:30Z herbelin $ *)
open Names
open Term
diff --git a/pretyping/pattern.ml b/pretyping/pattern.ml
index 4f62252f..d1c4cfc1 100644
--- a/pretyping/pattern.ml
+++ b/pretyping/pattern.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: pattern.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Util
open Names
diff --git a/pretyping/pattern.mli b/pretyping/pattern.mli
index 92344e47..fbc6bbaa 100644
--- a/pretyping/pattern.mli
+++ b/pretyping/pattern.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: pattern.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Pp
diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml
index 9f441c21..6befdedc 100644
--- a/pretyping/pretype_errors.ml
+++ b/pretyping/pretype_errors.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: pretype_errors.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Util
open Stdpp
diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli
index ad122127..496e16d2 100644
--- a/pretyping/pretype_errors.mli
+++ b/pretyping/pretype_errors.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: pretype_errors.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Pp
diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index 5438d982..7b4b5e07 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: pretyping.ml 13332 2010-07-26 22:12:43Z msozeau $ *)
open Pp
open Util
@@ -684,11 +684,14 @@ module Pretyping_F (Coercion : Coercion.S) = struct
(pretype tycon env evdref lvar c).uj_val
| IsType ->
(pretype_type empty_valcon env evdref lvar c).utj_val in
- evdref := fst (consider_remaining_unif_problems env !evdref);
- if resolve_classes then
- evdref :=
- Typeclasses.resolve_typeclasses ~onlyargs:false
- ~split:true ~fail:fail_evar env !evdref;
+ if resolve_classes then (
+ evdref := Typeclasses.resolve_typeclasses ~onlyargs:false
+ ~split:true ~fail:fail_evar env !evdref);
+ evdref := (try consider_remaining_unif_problems env !evdref
+ with e when not resolve_classes ->
+ consider_remaining_unif_problems env
+ (Typeclasses.resolve_typeclasses ~onlyargs:false
+ ~split:true ~fail:fail_evar env !evdref));
let c = if expand_evar then nf_evar !evdref c' else c' in
if fail_evar then check_evars env Evd.empty !evdref c;
c
@@ -701,7 +704,7 @@ module Pretyping_F (Coercion : Coercion.S) = struct
let understand_judgment sigma env c =
let evdref = ref (create_evar_defs sigma) in
let j = pretype empty_tycon env evdref ([],[]) c in
- let evd,_ = consider_remaining_unif_problems env !evdref in
+ let evd = consider_remaining_unif_problems env !evdref in
let evd = Typeclasses.resolve_typeclasses ~onlyargs:true ~split:false
~fail:true env evd
in
diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli
index ea6b43fb..7d08026f 100644
--- a/pretyping/pretyping.mli
+++ b/pretyping/pretyping.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: pretyping.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Names
diff --git a/pretyping/rawterm.ml b/pretyping/rawterm.ml
index 492d9a73..afb942fb 100644
--- a/pretyping/rawterm.ml
+++ b/pretyping/rawterm.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: rawterm.ml 13329 2010-07-26 11:05:39Z herbelin $ *)
(*i*)
open Util
@@ -34,8 +34,6 @@ type patvar = identifier
type rawsort = RProp of Term.contents | RType of Univ.universe option
-type binder_kind = BProd | BLambda | BLetIn
-
type binding_kind = Lib.binding_kind = Explicit | Implicit
type quantified_hypothesis = AnonHyp of int | NamedHyp of identifier
@@ -185,6 +183,36 @@ let map_rawconstr_with_binders_loc loc g f e = function
| RDynamic (_,x) -> RDynamic (loc,x)
*)
+let fold_rawconstr f acc =
+ let rec fold acc = function
+ | RVar _ -> acc
+ | RApp (_,c,args) -> List.fold_left fold (fold acc c) args
+ | RLambda (_,_,_,b,c) | RProd (_,_,_,b,c) | RLetIn (_,_,b,c) ->
+ fold (fold acc b) c
+ | RCases (_,_,rtntypopt,tml,pl) ->
+ List.fold_left fold_pattern
+ (List.fold_left fold (Option.fold_left fold acc rtntypopt) (List.map fst tml))
+ pl
+ | RLetTuple (_,_,rtntyp,b,c) ->
+ fold (fold (fold_return_type acc rtntyp) b) c
+ | RIf (_,c,rtntyp,b1,b2) ->
+ fold (fold (fold (fold_return_type acc rtntyp) c) b1) b2
+ | RRec (_,_,_,bl,tyl,bv) ->
+ let acc = Array.fold_left
+ (List.fold_left (fun acc (na,k,bbd,bty) ->
+ fold (Option.fold_left fold acc bbd) bty)) acc bl in
+ Array.fold_left fold (Array.fold_left fold acc tyl) bv
+ | RCast (_,c,k) -> fold (match k with CastConv (_, t) -> fold acc t | CastCoerce -> acc) c
+ | (RSort _ | RHole _ | RRef _ | REvar _ | RPatVar _ | RDynamic _) -> acc
+
+ and fold_pattern acc (_,idl,p,c) = fold acc c
+
+ and fold_return_type acc (na,tyopt) = Option.fold_left fold acc tyopt
+
+ in fold acc
+
+let iter_rawconstr f = fold_rawconstr (fun () -> f) ()
+
let occur_rawconstr id =
let rec occur = function
| RVar (loc,id') -> id = id'
diff --git a/pretyping/rawterm.mli b/pretyping/rawterm.mli
index c9dbe4bf..39ff74a3 100644
--- a/pretyping/rawterm.mli
+++ b/pretyping/rawterm.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: rawterm.mli 13329 2010-07-26 11:05:39Z herbelin $ i*)
(*i*)
open Util
@@ -38,8 +38,6 @@ type patvar = identifier
type rawsort = RProp of Term.contents | RType of Univ.universe option
-type binder_kind = BProd | BLambda | BLetIn
-
type binding_kind = Lib.binding_kind = Explicit | Implicit
type quantified_hypothesis = AnonHyp of int | NamedHyp of identifier
@@ -110,6 +108,8 @@ val map_rawconstr_with_binders_loc : loc ->
('a -> rawconstr -> rawconstr) -> 'a -> rawconstr -> rawconstr
i*)
+val fold_rawconstr : ('a -> rawconstr -> 'a) -> 'a -> rawconstr -> 'a
+val iter_rawconstr : (rawconstr -> unit) -> rawconstr -> unit
val occur_rawconstr : identifier -> rawconstr -> bool
val free_rawvars : rawconstr -> identifier list
val loc_of_rawconstr : rawconstr -> loc
diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml
index 47178d06..68ae9208 100644
--- a/pretyping/recordops.ml
+++ b/pretyping/recordops.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: recordops.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Util
open Pp
diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli
index da883b19..3d97d8b2 100644
--- a/pretyping/recordops.mli
+++ b/pretyping/recordops.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: recordops.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Names
diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml
index 7519e508..556134de 100644
--- a/pretyping/reductionops.ml
+++ b/pretyping/reductionops.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: reductionops.ml 13354 2010-07-29 16:44:45Z barras $ *)
open Pp
open Util
@@ -525,9 +525,11 @@ let nf_evar =
(* Note by HH [oct 08] : why would it be the job of clos_norm_flags to add
a [nf_evar] here *)
let clos_norm_flags flgs env sigma t =
- norm_val
- (create_clos_infos ~evars:(safe_evar_value sigma) flgs env)
- (inject t)
+ try
+ norm_val
+ (create_clos_infos ~evars:(safe_evar_value sigma) flgs env)
+ (inject t)
+ with Anomaly _ -> error "Tried to normalized ill-typed term"
let nf_beta = clos_norm_flags Closure.beta empty_env
let nf_betaiota = clos_norm_flags Closure.betaiota empty_env
@@ -586,9 +588,11 @@ let nf_betaiota_preserving_vm_cast =
(* lazy weak head reduction functions *)
let whd_flags flgs env sigma t =
- whd_val
- (create_clos_infos ~evars:(safe_evar_value sigma) flgs env)
- (inject t)
+ try
+ whd_val
+ (create_clos_infos ~evars:(safe_evar_value sigma) flgs env)
+ (inject t)
+ with Anomaly _ -> error "Tried to normalized ill-typed term"
(********************************************************************)
(* Conversion *)
@@ -620,6 +624,7 @@ let test_conversion (f:?evars:'a->'b) env sigma x y =
try let _ =
f ~evars:(safe_evar_value sigma) env x y in true
with NotConvertible -> false
+ | Anomaly _ -> error "Conversion test raised an anomaly"
let is_conv env sigma = test_conversion Reduction.conv env sigma
let is_conv_leq env sigma = test_conversion Reduction.conv_leq env sigma
@@ -628,6 +633,7 @@ let is_fconv = function | CONV -> is_conv | CUMUL -> is_conv_leq
let test_trans_conversion f reds env sigma x y =
try let _ = f reds env (nf_evar sigma x) (nf_evar sigma y) in true
with NotConvertible -> false
+ | Anomaly _ -> error "Conversion test raised an anomaly"
let is_trans_conv reds env sigma = test_trans_conversion Reduction.trans_conv reds env sigma
let is_trans_conv_leq reds env sigma = test_trans_conversion Reduction.trans_conv_leq reds env sigma
diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli
index ab4c6f5d..f557df00 100644
--- a/pretyping/reductionops.mli
+++ b/pretyping/reductionops.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: reductionops.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Names
diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml
index d736031f..e4a85b84 100644
--- a/pretyping/retyping.ml
+++ b/pretyping/retyping.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: retyping.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Util
open Term
diff --git a/pretyping/retyping.mli b/pretyping/retyping.mli
index 7b53da7e..98a3ff42 100644
--- a/pretyping/retyping.mli
+++ b/pretyping/retyping.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: retyping.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Names
diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml
index 3089b7ca..49ccb80c 100644
--- a/pretyping/tacred.ml
+++ b/pretyping/tacred.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: tacred.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Pp
open Util
diff --git a/pretyping/tacred.mli b/pretyping/tacred.mli
index d5703d6b..064d2ce4 100644
--- a/pretyping/tacred.mli
+++ b/pretyping/tacred.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: tacred.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Names
diff --git a/pretyping/termops.ml b/pretyping/termops.ml
index f746245f..a2759688 100644
--- a/pretyping/termops.ml
+++ b/pretyping/termops.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: termops.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Pp
open Util
diff --git a/pretyping/termops.mli b/pretyping/termops.mli
index f13df9d2..7977fe28 100644
--- a/pretyping/termops.mli
+++ b/pretyping/termops.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: termops.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Util
open Pp
diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml
index da17c299..d75032e7 100644
--- a/pretyping/typeclasses.ml
+++ b/pretyping/typeclasses.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: typeclasses.ml 13332 2010-07-26 22:12:43Z msozeau $ i*)
(*i*)
open Names
@@ -106,6 +106,29 @@ let _ =
Summary.unfreeze_function = unfreeze;
Summary.init_function = init }
+let class_info c =
+ try Gmap.find c !classes
+ with _ -> not_a_class (Global.env()) (constr_of_global c)
+
+let global_class_of_constr env c =
+ try class_info (global_of_constr c)
+ with Not_found -> not_a_class env c
+
+let dest_class_app env c =
+ let cl, args = decompose_app c in
+ global_class_of_constr env cl, args
+
+let class_of_constr c = try Some (fst (dest_class_app (Global.env ()) c)) with _ -> None
+
+let rec is_class_type evd c =
+ match kind_of_term c with
+ | Prod (_, _, t) -> is_class_type evd t
+ | Evar (e, _) when is_defined evd e -> is_class_type evd (Evarutil.nf_evar evd c)
+ | _ -> class_of_constr c <> None
+
+let is_class_evar evd evi =
+ is_class_type evd evi.Evd.evar_concl
+
(*
* classes persistent object
*)
@@ -153,8 +176,15 @@ let discharge_class (_,cl) =
| ConstRef cst -> Lib.section_segment_of_constant cst
| IndRef (ind,_) -> Lib.section_segment_of_mutual_inductive ind in
let discharge_context ctx' subst (grs, ctx) =
- let grs' = List.map (fun _ -> None) subst @
- list_smartmap (Option.smartmap (fun (gr, b) -> Lib.discharge_global gr, b)) grs
+ let grs' =
+ let newgrs = List.map (fun (_, _, t) ->
+ match class_of_constr t with
+ | None -> None
+ | Some tc -> Some (tc.cl_impl, true))
+ ctx'
+ in
+ list_smartmap (Option.smartmap (fun (gr, b) -> Lib.discharge_global gr, b)) grs
+ @ newgrs
in grs', discharge_rel_context subst 1 ctx @ ctx' in
let cl_impl' = Lib.discharge_global cl.cl_impl in
if cl_impl' == cl.cl_impl then cl else
@@ -265,10 +295,6 @@ let add_inductive_class ind =
* interface functions
*)
-let class_info c =
- try Gmap.find c !classes
- with _ -> not_a_class (Global.env()) (constr_of_global c)
-
let instance_constructor cl args =
let lenpars = List.length (List.filter (fun (na, b, t) -> b = None) (snd cl.cl_context)) in
let pars = fst (list_chop lenpars args) in
@@ -322,16 +348,6 @@ let is_implicit_arg k =
| InternalHole -> true
| _ -> false
-let global_class_of_constr env c =
- try class_info (global_of_constr c)
- with Not_found -> not_a_class env c
-
-let dest_class_app env c =
- let cl, args = decompose_app c in
- global_class_of_constr env cl, args
-
-let class_of_constr c = try Some (fst (dest_class_app (Global.env ()) c)) with _ -> None
-
(* To embed a boolean for resolvability status.
This is essentially a hack to mark which evars correspond to
goals and do not need to be resolved when we have nested [resolve_all_evars]
@@ -356,15 +372,6 @@ let mark_unresolvables sigma =
Evd.add evs ev (mark_unresolvable evi))
sigma Evd.empty
-let rec is_class_type evd c =
- match kind_of_term c with
- | Prod (_, _, t) -> is_class_type evd t
- | Evar (e, _) when is_defined evd e -> is_class_type evd (Evarutil.nf_evar evd c)
- | _ -> class_of_constr c <> None
-
-let is_class_evar evd evi =
- is_class_type evd evi.Evd.evar_concl
-
let has_typeclasses evd =
Evd.fold (fun ev evi has -> has ||
(evi.evar_body = Evar_empty && is_class_evar evd evi && is_resolvable evi))
diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli
index 80387ec5..8e1c2a92 100644
--- a/pretyping/typeclasses.mli
+++ b/pretyping/typeclasses.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: typeclasses.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Names
diff --git a/pretyping/typeclasses_errors.ml b/pretyping/typeclasses_errors.ml
index eb24c731..b3ab1f07 100644
--- a/pretyping/typeclasses_errors.ml
+++ b/pretyping/typeclasses_errors.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: typeclasses_errors.ml 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Names
diff --git a/pretyping/typeclasses_errors.mli b/pretyping/typeclasses_errors.mli
index 4ec5ad70..94e1a57d 100644
--- a/pretyping/typeclasses_errors.mli
+++ b/pretyping/typeclasses_errors.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: typeclasses_errors.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Names
diff --git a/pretyping/typing.ml b/pretyping/typing.ml
index 43880615..82b59d16 100644
--- a/pretyping/typing.ml
+++ b/pretyping/typing.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: typing.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Util
open Names
diff --git a/pretyping/typing.mli b/pretyping/typing.mli
index 49a6a23e..32b64c5f 100644
--- a/pretyping/typing.mli
+++ b/pretyping/typing.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: typing.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Term
diff --git a/pretyping/unification.ml b/pretyping/unification.ml
index a096a074..02af6090 100644
--- a/pretyping/unification.ml
+++ b/pretyping/unification.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: unification.ml 13332 2010-07-26 22:12:43Z msozeau $ *)
open Pp
open Util
@@ -573,12 +573,9 @@ let is_mimick_head f =
let try_to_coerce env evd c cty tycon =
let j = make_judge c cty in
let (evd',j') = inh_conv_coerce_rigid_to dummy_loc env evd j tycon in
- let (evd',b) = Evarconv.consider_remaining_unif_problems env evd' in
- if b then
- let evd' = Evd.map_metas_fvalue (nf_evar evd') evd' in
+ let evd' = Evarconv.consider_remaining_unif_problems env evd' in
+ let evd' = Evd.map_metas_fvalue (nf_evar evd') evd' in
(evd',j'.uj_val)
- else
- error "Cannot solve unification constraints"
let w_coerce_to_type env evd c cty mvty =
let evd,mvty = pose_all_metas_as_evars env evd mvty in
@@ -634,9 +631,7 @@ let order_metas metas =
let solve_simple_evar_eqn env evd ev rhs =
let evd,b = solve_simple_eqn Evarconv.evar_conv_x env evd (None,ev,rhs) in
if not b then error_cannot_unify env evd (mkEvar ev,rhs);
- let (evd,b) = Evarconv.consider_remaining_unif_problems env evd in
- if not b then error "Cannot solve unification constraints";
- evd
+ Evarconv.consider_remaining_unif_problems env evd
(* [w_merge env sigma b metas evars] merges common instances in metas
or in evars, possibly generating new unification problems; if [b]
@@ -656,11 +651,16 @@ let w_merge env with_types flags (evd,metas,evars) =
else begin
let rhs' = subst_meta_instances metas rhs in
match kind_of_term rhs with
- | App (f,cl) when is_mimick_head f & occur_meta rhs' ->
+ | App (f,cl) when occur_meta rhs' ->
if occur_evar evn rhs' then
error_occur_check env evd evn rhs';
- let evd' = mimick_evar evd flags f (Array.length cl) evn in
- w_merge_rec evd' metas evars eqns
+ if is_mimick_head f then
+ let evd' = mimick_evar evd flags f (Array.length cl) evn in
+ w_merge_rec evd' metas evars eqns
+ else
+ let evd', rhs'' = pose_all_metas_as_evars env evd rhs' in
+ w_merge_rec (solve_simple_evar_eqn env evd' ev rhs'')
+ metas evars' eqns
| _ ->
w_merge_rec (solve_simple_evar_eqn env evd ev rhs')
metas evars' eqns
diff --git a/pretyping/unification.mli b/pretyping/unification.mli
index 7a91ce66..419d5d4f 100644
--- a/pretyping/unification.mli
+++ b/pretyping/unification.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: unification.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Term
diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml
index 2de542cd..2c8705d5 100644
--- a/pretyping/vnorm.ml
+++ b/pretyping/vnorm.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: vnorm.ml 13351 2010-07-29 15:26:31Z barras $ i*)
open Names
open Declarations
@@ -117,7 +117,7 @@ let build_branches_type env (mind,_ as _ind) mib mip params dep p =
let carity = snd (rtbl.(i)) in
let crealargs = Array.sub cargs nparams (Array.length cargs - nparams) in
let codom =
- let papp = mkApp(p,crealargs) in
+ let papp = mkApp(lift (List.length decl) p,crealargs) in
if dep then
let cstr = ith_constructor_of_inductive ind (i+1) in
let relargs = Array.init carity (fun i -> mkRel (carity-i)) in
diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml
index de2ba7c9..5f0f5e7d 100644
--- a/proofs/clenvtac.ml
+++ b/proofs/clenvtac.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: clenvtac.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Pp
open Util
diff --git a/proofs/clenvtac.mli b/proofs/clenvtac.mli
index 72b812ce..3840cc0a 100644
--- a/proofs/clenvtac.mli
+++ b/proofs/clenvtac.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: clenvtac.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Util
diff --git a/proofs/decl_expr.mli b/proofs/decl_expr.mli
index 91f0a9ff..24cf2c1d 100644
--- a/proofs/decl_expr.mli
+++ b/proofs/decl_expr.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: decl_expr.mli 13323 2010-07-24 15:57:30Z herbelin $ *)
open Names
open Util
diff --git a/proofs/decl_mode.ml b/proofs/decl_mode.ml
index d28d9a0d..8810820d 100644
--- a/proofs/decl_mode.ml
+++ b/proofs/decl_mode.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: decl_mode.ml 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Names
open Term
diff --git a/proofs/decl_mode.mli b/proofs/decl_mode.mli
index b6e77b43..b309c9f0 100644
--- a/proofs/decl_mode.mli
+++ b/proofs/decl_mode.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: decl_mode.mli 13323 2010-07-24 15:57:30Z herbelin $ *)
open Names
open Term
diff --git a/proofs/evar_refiner.ml b/proofs/evar_refiner.ml
index a5a0cde4..484d5332 100644
--- a/proofs/evar_refiner.ml
+++ b/proofs/evar_refiner.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: evar_refiner.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Util
open Names
diff --git a/proofs/evar_refiner.mli b/proofs/evar_refiner.mli
index e4303f42..3f7f88d1 100644
--- a/proofs/evar_refiner.mli
+++ b/proofs/evar_refiner.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: evar_refiner.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Names
diff --git a/proofs/logic.ml b/proofs/logic.ml
index 83dc497c..fda14f53 100644
--- a/proofs/logic.ml
+++ b/proofs/logic.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: logic.ml 13332 2010-07-26 22:12:43Z msozeau $ *)
open Pp
open Util
@@ -58,7 +58,7 @@ let rec catchable_exception = function
(* unification errors *)
| PretypeError(_,(CannotUnify _|CannotUnifyLocal _|CannotGeneralize _
|NoOccurrenceFound _|CannotUnifyBindingType _|NotClean _
- |CannotFindWellTypedAbstraction _
+ |CannotFindWellTypedAbstraction _|OccurCheck _
|UnsolvableImplicit _)) -> true
| Typeclasses_errors.TypeClassError
(_, Typeclasses_errors.UnsatisfiableConstraints _) -> true
diff --git a/proofs/logic.mli b/proofs/logic.mli
index c7cf6472..960505ed 100644
--- a/proofs/logic.mli
+++ b/proofs/logic.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: logic.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Names
diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml
index 3adfd522..171db848 100644
--- a/proofs/pfedit.ml
+++ b/proofs/pfedit.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: pfedit.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Pp
open Util
diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli
index b5003425..1b284f8d 100644
--- a/proofs/pfedit.mli
+++ b/proofs/pfedit.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: pfedit.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Util
diff --git a/proofs/proof_trees.ml b/proofs/proof_trees.ml
index b352fdc8..4c55af90 100644
--- a/proofs/proof_trees.ml
+++ b/proofs/proof_trees.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: proof_trees.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Closure
open Util
diff --git a/proofs/proof_trees.mli b/proofs/proof_trees.mli
index 477c3162..0a2c6e9a 100644
--- a/proofs/proof_trees.mli
+++ b/proofs/proof_trees.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: proof_trees.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Util
diff --git a/proofs/proof_type.ml b/proofs/proof_type.ml
index f7c937bd..d11e6676 100644
--- a/proofs/proof_type.ml
+++ b/proofs/proof_type.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ *)
+(*i $Id: proof_type.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
(*i*)
open Environ
diff --git a/proofs/proof_type.mli b/proofs/proof_type.mli
index c6f0658b..5f8a63b0 100644
--- a/proofs/proof_type.mli
+++ b/proofs/proof_type.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: proof_type.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Environ
diff --git a/proofs/redexpr.ml b/proofs/redexpr.ml
index f7d83c0a..77a5db12 100644
--- a/proofs/redexpr.ml
+++ b/proofs/redexpr.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: redexpr.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Pp
open Util
diff --git a/proofs/redexpr.mli b/proofs/redexpr.mli
index 93c34d86..ce0cb8e7 100644
--- a/proofs/redexpr.mli
+++ b/proofs/redexpr.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: redexpr.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Names
open Term
diff --git a/proofs/refiner.ml b/proofs/refiner.ml
index e0ed7861..ddb7eefc 100644
--- a/proofs/refiner.ml
+++ b/proofs/refiner.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: refiner.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Pp
open Util
diff --git a/proofs/refiner.mli b/proofs/refiner.mli
index 2b213c3f..7126533d 100644
--- a/proofs/refiner.mli
+++ b/proofs/refiner.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: refiner.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Term
diff --git a/proofs/tacexpr.ml b/proofs/tacexpr.ml
index 8761bfae..00dfb122 100644
--- a/proofs/tacexpr.ml
+++ b/proofs/tacexpr.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: tacexpr.ml 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Names
open Topconstr
diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml
index 60e79c19..55996f33 100644
--- a/proofs/tacmach.ml
+++ b/proofs/tacmach.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: tacmach.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Pp
open Util
diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli
index 489786ef..30851b95 100644
--- a/proofs/tacmach.mli
+++ b/proofs/tacmach.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: tacmach.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Names
diff --git a/proofs/tactic_debug.ml b/proofs/tactic_debug.ml
index 6455420c..75783ab4 100644
--- a/proofs/tactic_debug.ml
+++ b/proofs/tactic_debug.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: tactic_debug.ml 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Names
open Constrextern
diff --git a/proofs/tactic_debug.mli b/proofs/tactic_debug.mli
index 8a6a22c6..8f74eae6 100644
--- a/proofs/tactic_debug.mli
+++ b/proofs/tactic_debug.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: tactic_debug.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Environ
open Pattern
diff --git a/scripts/coqc.ml b/scripts/coqc.ml
index c091d030..7185b140 100644
--- a/scripts/coqc.ml
+++ b/scripts/coqc.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: coqc.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
(* Afin de rendre Coq plus portable, ce programme Caml remplace le script
coqc.
diff --git a/scripts/coqmktop.ml b/scripts/coqmktop.ml
index d1f15f8e..ada14fda 100644
--- a/scripts/coqmktop.ml
+++ b/scripts/coqmktop.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: coqmktop.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
(* coqmktop is a script to link Coq, analogous to ocamlmktop.
The command line contains options specific to coqmktop, options for the
diff --git a/tactics/auto.ml b/tactics/auto.ml
index e53e05d0..faf0482b 100644
--- a/tactics/auto.ml
+++ b/tactics/auto.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: auto.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Pp
open Util
diff --git a/tactics/auto.mli b/tactics/auto.mli
index 09af7f8c..9a0719fc 100644
--- a/tactics/auto.mli
+++ b/tactics/auto.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: auto.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Util
diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml
index c81dcfed..09f80377 100644
--- a/tactics/autorewrite.ml
+++ b/tactics/autorewrite.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: autorewrite.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Equality
open Hipattern
diff --git a/tactics/autorewrite.mli b/tactics/autorewrite.mli
index d6fa2455..b7300cba 100644
--- a/tactics/autorewrite.mli
+++ b/tactics/autorewrite.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: autorewrite.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Term
diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml
index cf536bfd..73aac029 100644
--- a/tactics/btermdn.ml
+++ b/tactics/btermdn.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: btermdn.ml 13332 2010-07-26 22:12:43Z msozeau $ *)
open Term
open Names
@@ -79,8 +79,7 @@ struct
| Var id when not (Idpred.mem id idpred) -> Dn.Label(Term_dn.GRLabel (VarRef id),l)
| Prod (n, d, c) -> Dn.Label(Term_dn.ProdLabel, [d; c])
| Lambda (n, d, c) -> Dn.Label(Term_dn.LambdaLabel, [d; c] @ l)
- | Sort s when is_small s -> Dn.Label(Term_dn.SortLabel (Some s), [])
- | Sort _ -> Dn.Label(Term_dn.SortLabel None, [])
+ | Sort _ -> Dn.Label(Term_dn.SortLabel, [])
| Evar _ -> Dn.Everything
| _ -> Dn.Nothing
diff --git a/tactics/btermdn.mli b/tactics/btermdn.mli
index 859890a4..14f9fb23 100644
--- a/tactics/btermdn.mli
+++ b/tactics/btermdn.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: btermdn.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Term
diff --git a/tactics/class_tactics.ml4 b/tactics/class_tactics.ml4
index 7105e84d..afd13b4c 100644
--- a/tactics/class_tactics.ml4
+++ b/tactics/class_tactics.ml4
@@ -8,7 +8,7 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
-(* $Id$ *)
+(* $Id: class_tactics.ml4 13332 2010-07-26 22:12:43Z msozeau $ *)
open Pp
open Util
@@ -69,7 +69,7 @@ let evar_filter evi =
{ evi with
evar_hyps = Environ.val_of_named_context hyps';
evar_filter = List.map (fun _ -> true) hyps' }
-
+
let evars_to_goals p evm =
let goals, evm' =
Evd.fold
@@ -85,6 +85,7 @@ let evars_to_goals p evm =
if goals = [] then None
else
let goals = List.rev goals in
+ let evm' = evars_reset_evd evm' evm in
Some (goals, evm')
(** Typeclasses instance search tactic / eauto *)
@@ -331,7 +332,14 @@ let or_tac (x : 'a tac) (y : 'a tac) : 'a tac =
{ skft = fun sk fk gls -> x.skft sk (fun () -> y.skft sk fk gls) gls }
let solve_tac (x : 'a tac) : 'a tac =
- { skft = fun sk fk gls -> x.skft (fun ({it = gls},_ as res) fk -> if gls = [] then sk res fk else fk ()) fk gls }
+ { skft = fun sk fk gls -> x.skft (fun ({it = gls},_ as res) fk ->
+ if gls = [] then sk res fk else fk ()) fk gls }
+
+let solve_unif_tac : atac =
+ { skft = fun sk fk {it = gl; sigma = s} ->
+ try let s' = Evarconv.consider_remaining_unif_problems (Global.env ()) s in
+ normevars_tac.skft sk fk ({it=gl; sigma=s'})
+ with _ -> fk () }
let hints_tac hints =
{ skft = fun sk fk {it = gl,info; sigma = s} ->
@@ -456,7 +464,6 @@ let then_tac (first : atac) (second : atac) : atac =
let run_tac (t : 'a tac) (gl : autogoal sigma) : auto_result option =
t.skft (fun x _ -> Some x) (fun _ -> None) gl
-
type run_list_res = (auto_result * run_list_res fk) option
let run_list_tac (t : 'a tac) p goals (gl : autogoal list sigma) : run_list_res =
@@ -491,7 +498,7 @@ let run_on_evars ?(only_classes=true) ?(st=full_transparent_state) p evm tac =
let res = run_list_tac tac p goals (make_autogoals ~only_classes ~st goals evm') in
match get_result res with
| None -> raise Not_found
- | Some (evm', fk) -> Some (Evd.evars_reset_evd evm' evm, fk)
+ | Some (evm', fk) -> Some (evars_reset_evd evm' evm, fk)
let eauto_tac hints =
fix (or_tac (then_tac normevars_tac (hints_tac hints)) intro_tac)
@@ -551,16 +558,31 @@ let rec merge_deps deps = function
else hd :: merge_deps deps tl
let evars_of_evi evi =
- Intset.union (Evarutil.evars_of_term evi.evar_concl)
- (match evi.evar_body with
- | Evar_defined b -> Evarutil.evars_of_term b
- | Evar_empty -> Intset.empty)
+ Intset.union (evars_of_term evi.evar_concl)
+ (Intset.union
+ (match evi.evar_body with
+ | Evar_empty -> Intset.empty
+ | Evar_defined b -> evars_of_term b)
+ (Evarutil.evars_of_named_context (evar_filtered_context evi)))
+
+let deps_of_constraints cstrs deps =
+ List.fold_right (fun (_, _, x, y) deps ->
+ let evs = Intset.union (evars_of_term x) (evars_of_term y) in
+ merge_deps evs deps)
+ cstrs deps
+
+let evar_dependencies evm =
+ Evd.fold
+ (fun ev evi acc ->
+ merge_deps (Intset.union (Intset.singleton ev)
+ (evars_of_evi evi)) acc)
+ evm []
let split_evars evm =
- Evd.fold (fun ev evi acc ->
- let deps = Intset.union (Intset.singleton ev) (evars_of_evi evi) in
- merge_deps deps acc)
- evm []
+ let _, cstrs = extract_all_conv_pbs evm in
+ let evmdeps = evar_dependencies evm in
+ let deps = deps_of_constraints cstrs evmdeps in
+ List.sort Intset.compare deps
let select_evars evs evm =
Evd.fold (fun ev evi acc ->
diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml
index 44bde497..9ea4892e 100644
--- a/tactics/contradiction.ml
+++ b/tactics/contradiction.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: contradiction.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Util
open Term
diff --git a/tactics/contradiction.mli b/tactics/contradiction.mli
index 14dcb469..7306f875 100644
--- a/tactics/contradiction.mli
+++ b/tactics/contradiction.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: contradiction.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Names
diff --git a/tactics/decl_interp.ml b/tactics/decl_interp.ml
index eebce493..7866d640 100644
--- a/tactics/decl_interp.ml
+++ b/tactics/decl_interp.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: decl_interp.ml 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Util
open Names
diff --git a/tactics/decl_interp.mli b/tactics/decl_interp.mli
index 2d8b2c1d..859db444 100644
--- a/tactics/decl_interp.mli
+++ b/tactics/decl_interp.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: decl_interp.mli 13323 2010-07-24 15:57:30Z herbelin $ *)
open Tacinterp
open Decl_expr
diff --git a/tactics/decl_proof_instr.ml b/tactics/decl_proof_instr.ml
index 02a0050d..f9a51afe 100644
--- a/tactics/decl_proof_instr.ml
+++ b/tactics/decl_proof_instr.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: decl_proof_instr.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Util
open Pp
diff --git a/tactics/decl_proof_instr.mli b/tactics/decl_proof_instr.mli
index 170269dc..6f8126ed 100644
--- a/tactics/decl_proof_instr.mli
+++ b/tactics/decl_proof_instr.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: decl_proof_instr.mli 13323 2010-07-24 15:57:30Z herbelin $ *)
open Refiner
open Names
diff --git a/tactics/dhyp.ml b/tactics/dhyp.ml
index 4a779edb..5b7e7e94 100644
--- a/tactics/dhyp.ml
+++ b/tactics/dhyp.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: dhyp.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
(* Chet's comments about this tactic :
diff --git a/tactics/dhyp.mli b/tactics/dhyp.mli
index 5af4e56b..a4be2e42 100644
--- a/tactics/dhyp.mli
+++ b/tactics/dhyp.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: dhyp.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Names
diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4
index d101b9d7..2b25ad73 100644
--- a/tactics/eauto.ml4
+++ b/tactics/eauto.ml4
@@ -8,7 +8,7 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
-(* $Id$ *)
+(* $Id: eauto.ml4 13344 2010-07-28 15:04:36Z msozeau $ *)
open Pp
open Util
@@ -396,7 +396,7 @@ END
let cons a l = a :: l
-let autounfold db cl =
+let autounfolds db occs =
let unfolds = List.concat (List.map (fun dbname ->
let db = try searchtable_map dbname
with Not_found -> errorlabstrm "autounfold" (str "Unknown database " ++ str dbname)
@@ -404,7 +404,15 @@ let autounfold db cl =
let (ids, csts) = Hint_db.unfolds db in
Cset.fold (fun cst -> cons (all_occurrences, EvalConstRef cst)) csts
(Idset.fold (fun id -> cons (all_occurrences, EvalVarRef id)) ids [])) db)
- in unfold_option unfolds cl
+ in unfold_option unfolds
+
+let autounfold db cls gl =
+ let cls = concrete_clause_of cls gl in
+ let tac = autounfolds db in
+ tclMAP (function
+ | OnHyp (id,occs,where) -> tac occs (Some (id,where))
+ | OnConcl occs -> tac occs None)
+ cls gl
let autosimpl db cl =
let unfold_of_elts constr (b, elts) =
@@ -419,12 +427,13 @@ let autosimpl db cl =
unfold_of_elts (fun x -> EvalVarRef x) (Idpred.elements ids)) db)
in unfold_option unfolds cl
+open Extraargs
+
TACTIC EXTEND autounfold
-| [ "autounfold" hintbases(db) "in" hyp(id) ] ->
- [ autounfold (match db with None -> ["core"] | Some x -> x) (Some (id, InHyp)) ]
-| [ "autounfold" hintbases(db) ] ->
- [ autounfold (match db with None -> ["core"] | Some x -> x) None ]
- END
+| [ "autounfold" hintbases(db) in_arg_hyp(id) ] ->
+ [ autounfold (match db with None -> Auto.current_db_names () | Some [] -> ["core"] | Some x -> x)
+ (glob_in_arg_hyp_to_clause id) ]
+END
let unfold_head env (ids, csts) c =
let rec aux c =
@@ -498,7 +507,7 @@ TACTIC EXTEND autounfoldify
let db = match kind_of_term x with
| Const c -> string_of_label (con_label c)
| _ -> assert false
- in autounfold ["core";db] None ]
+ in autounfold ["core";db] onConcl ]
END
TACTIC EXTEND unify
diff --git a/tactics/eauto.mli b/tactics/eauto.mli
index 331d2b44..eb90b1b6 100644
--- a/tactics/eauto.mli
+++ b/tactics/eauto.mli
@@ -17,6 +17,8 @@ open Environ
open Explore
(*i*)
+val hintbases : hint_db_name list option Pcoq.Gram.Entry.e
+val wit_hintbases : hint_db_name list option typed_abstract_argument_type
val rawwit_hintbases : hint_db_name list option raw_abstract_argument_type
val rawwit_auto_using : constr_expr list raw_abstract_argument_type
@@ -36,4 +38,4 @@ val eauto_with_bases :
bool * int ->
Term.constr list -> Auto.hint_db list -> Proof_type.tactic
-val autounfold : hint_db_name list -> Tacticals.goal_location -> tactic
+val autounfold : hint_db_name list -> Tacticals.clause -> tactic
diff --git a/tactics/elim.ml b/tactics/elim.ml
index 7f1d4249..0372a88d 100644
--- a/tactics/elim.ml
+++ b/tactics/elim.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: elim.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Pp
open Util
diff --git a/tactics/elim.mli b/tactics/elim.mli
index 8ea6695a..fa18ab0b 100644
--- a/tactics/elim.mli
+++ b/tactics/elim.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: elim.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Names
diff --git a/tactics/elimschemes.ml b/tactics/elimschemes.ml
index 77c878fc..c82e8f64 100644
--- a/tactics/elimschemes.ml
+++ b/tactics/elimschemes.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: elimschemes.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
(* Created by Hugo Herbelin from contents related to inductive schemes
initially developed by Christine Paulin (induction schemes), Vincent
diff --git a/tactics/elimschemes.mli b/tactics/elimschemes.mli
index 795add12..ba0389e5 100644
--- a/tactics/elimschemes.mli
+++ b/tactics/elimschemes.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: elimschemes.mli 13323 2010-07-24 15:57:30Z herbelin $ *)
open Ind_tables
diff --git a/tactics/eqdecide.ml4 b/tactics/eqdecide.ml4
index 7ed6bf1e..90e4b44c 100644
--- a/tactics/eqdecide.ml4
+++ b/tactics/eqdecide.ml4
@@ -14,7 +14,7 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
-(* $Id$ *)
+(* $Id: eqdecide.ml4 13323 2010-07-24 15:57:30Z herbelin $ *)
open Util
open Names
diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml
index 9972c2a5..22c3b47f 100644
--- a/tactics/eqschemes.ml
+++ b/tactics/eqschemes.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: eqschemes.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
(* File created by Hugo Herbelin, Nov 2009 *)
diff --git a/tactics/eqschemes.mli b/tactics/eqschemes.mli
index ae3b1578..447fb359 100644
--- a/tactics/eqschemes.mli
+++ b/tactics/eqschemes.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: eqschemes.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(* This file builds schemes relative to equality inductive types *)
diff --git a/tactics/equality.ml b/tactics/equality.ml
index 68f0cc7c..6b16adb4 100644
--- a/tactics/equality.ml
+++ b/tactics/equality.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: equality.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Pp
open Util
diff --git a/tactics/equality.mli b/tactics/equality.mli
index 7c09ae09..f14b3867 100644
--- a/tactics/equality.mli
+++ b/tactics/equality.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: equality.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Util
diff --git a/tactics/evar_tactics.ml b/tactics/evar_tactics.ml
index 78757939..3e2191d1 100644
--- a/tactics/evar_tactics.ml
+++ b/tactics/evar_tactics.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: evar_tactics.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Term
open Util
diff --git a/tactics/evar_tactics.mli b/tactics/evar_tactics.mli
index ed4a33ae..78412150 100644
--- a/tactics/evar_tactics.mli
+++ b/tactics/evar_tactics.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: evar_tactics.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Tacmach
open Names
diff --git a/tactics/extraargs.ml4 b/tactics/extraargs.ml4
index bb63f6b9..c9b2a969 100644
--- a/tactics/extraargs.ml4
+++ b/tactics/extraargs.ml4
@@ -8,7 +8,7 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
-(* $Id$ *)
+(* $Id: extraargs.ml4 13323 2010-07-24 15:57:30Z herbelin $ *)
open Pp
open Pcoq
diff --git a/tactics/extraargs.mli b/tactics/extraargs.mli
index 22a0c2da..e53fc604 100644
--- a/tactics/extraargs.mli
+++ b/tactics/extraargs.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: extraargs.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Tacexpr
open Term
diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4
index 7afd0543..e1ac42c2 100644
--- a/tactics/extratactics.ml4
+++ b/tactics/extratactics.ml4
@@ -8,7 +8,7 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
-(* $Id$ *)
+(* $Id: extratactics.ml4 13323 2010-07-24 15:57:30Z herbelin $ *)
open Pp
open Pcoq
diff --git a/tactics/extratactics.mli b/tactics/extratactics.mli
index 50757148..cfbc8f3d 100644
--- a/tactics/extratactics.mli
+++ b/tactics/extratactics.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: extratactics.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Proof_type
diff --git a/tactics/hiddentac.ml b/tactics/hiddentac.ml
index 12ecbd9a..220c00d3 100644
--- a/tactics/hiddentac.ml
+++ b/tactics/hiddentac.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: hiddentac.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Term
open Proof_type
diff --git a/tactics/hiddentac.mli b/tactics/hiddentac.mli
index 7bd57cdd..1724bf9c 100644
--- a/tactics/hiddentac.mli
+++ b/tactics/hiddentac.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: hiddentac.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Names
diff --git a/tactics/hipattern.ml4 b/tactics/hipattern.ml4
index 3dc9403c..dfa596d3 100644
--- a/tactics/hipattern.ml4
+++ b/tactics/hipattern.ml4
@@ -8,7 +8,7 @@
(*i camlp4deps: "parsing/grammar.cma parsing/q_constr.cmo" i*)
-(* $Id$ *)
+(* $Id: hipattern.ml4 13323 2010-07-24 15:57:30Z herbelin $ *)
open Pp
open Util
diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli
index f486f348..cf4cdd0d 100644
--- a/tactics/hipattern.mli
+++ b/tactics/hipattern.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: hipattern.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Util
diff --git a/tactics/inv.ml b/tactics/inv.ml
index 7290b66b..430f7d5f 100644
--- a/tactics/inv.ml
+++ b/tactics/inv.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: inv.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Pp
open Util
diff --git a/tactics/inv.mli b/tactics/inv.mli
index 033082e9..eb899699 100644
--- a/tactics/inv.mli
+++ b/tactics/inv.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: inv.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Util
diff --git a/tactics/leminv.ml b/tactics/leminv.ml
index c102d8ec..76432dd8 100644
--- a/tactics/leminv.ml
+++ b/tactics/leminv.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: leminv.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Pp
open Util
diff --git a/tactics/nbtermdn.ml b/tactics/nbtermdn.ml
index 26167978..bdea29df 100644
--- a/tactics/nbtermdn.ml
+++ b/tactics/nbtermdn.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: nbtermdn.ml 13332 2010-07-26 22:12:43Z msozeau $ *)
open Util
open Names
@@ -117,7 +117,7 @@ let constr_val_discr_st (idpred,cpred) t =
| Var id when not (Idpred.mem id idpred) -> Dn.Label(Term_dn.GRLabel (VarRef id),l)
| Prod (n, d, c) -> Dn.Label(Term_dn.ProdLabel, [d; c])
| Lambda (n, d, c) -> Dn.Label(Term_dn.LambdaLabel, [d; c] @ l)
- | Sort s -> Dn.Label(Term_dn.SortLabel (Some s), [])
+ | Sort _ -> Dn.Label(Term_dn.SortLabel, [])
| Evar _ -> Dn.Everything
| _ -> Dn.Nothing
diff --git a/tactics/nbtermdn.mli b/tactics/nbtermdn.mli
index 3b90b12a..36c54bd3 100644
--- a/tactics/nbtermdn.mli
+++ b/tactics/nbtermdn.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: nbtermdn.mli 13332 2010-07-26 22:12:43Z msozeau $ i*)
(*i*)
open Term
@@ -24,7 +24,7 @@ sig
| GRLabel of global_reference
| ProdLabel
| LambdaLabel
- | SortLabel of sorts option
+ | SortLabel
end
type 'na t
diff --git a/tactics/refine.ml b/tactics/refine.ml
index 87769ccb..06a78011 100644
--- a/tactics/refine.ml
+++ b/tactics/refine.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: refine.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
(* JCF -- 6 janvier 1998 EXPERIMENTAL *)
diff --git a/tactics/refine.mli b/tactics/refine.mli
index e847a749..55b4033b 100644
--- a/tactics/refine.mli
+++ b/tactics/refine.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: refine.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Tacmach
diff --git a/tactics/rewrite.ml4 b/tactics/rewrite.ml4
index 010fd088..9d99ad96 100644
--- a/tactics/rewrite.ml4
+++ b/tactics/rewrite.ml4
@@ -135,8 +135,7 @@ let rewrite_relation = lazy (gen_constant ["Classes"; "RelationClasses"] "rewrit
let arrow_morphism a b =
if isprop a && isprop b then
Lazy.force impl
- else
- mkApp(Lazy.force arrow, [|a;b|])
+ else Lazy.force arrow
let setoid_refl pars x =
applistc (Lazy.force setoid_refl_proj) (pars @ [x])
@@ -176,17 +175,18 @@ let new_cstr_evar (goal,cstr) env t =
let cstr', t = Evarutil.new_evar cstr env t in
(goal, cstr'), t
-let build_signature evars env m (cstrs : 'a option list) (finalcstr : 'a option) (f : 'a -> constr) =
+let build_signature evars env m (cstrs : (types * types option) option list)
+ (finalcstr : (types * types option) option) =
let new_evar evars env t =
new_cstr_evar evars env
(* ~src:(dummy_loc, ImplicitArg (ConstRef (Lazy.force respectful), (n, Some na))) *) t
in
let mk_relty evars env ty obj =
match obj with
- | None ->
+ | None | Some (_, None) ->
let relty = mk_relation ty in
new_evar evars env relty
- | Some x -> evars, f x
+ | Some (x, Some rel) -> evars, rel
in
let rec aux env evars ty l =
let t = Reductionops.whd_betadeltaiota env (fst evars) ty in
@@ -209,12 +209,11 @@ let build_signature evars env m (cstrs : 'a option list) (finalcstr : 'a option)
| _, obj :: _ -> anomaly "build_signature: not enough products"
| _, [] ->
(match finalcstr with
- | None ->
+ | None | Some (_, None) ->
let t = Reductionops.nf_betaiota (fst evars) ty in
let evars, rel = mk_relty evars env t None in
evars, t, rel, [t, Some rel]
- | Some codom -> let (t, rel) = codom in
- evars, t, rel, [t, Some rel])
+ | Some (t, Some rel) -> evars, t, rel, [t, Some rel])
in aux env evars m cstrs
let proper_proof env evars carrier relation x =
@@ -248,7 +247,7 @@ type hypinfo = {
l2r : bool;
c1 : constr;
c2 : constr;
- c : constr option;
+ c : constr with_bindings option;
abs : (constr * types) option;
}
@@ -256,25 +255,35 @@ let evd_convertible env evd x y =
try ignore(Evarconv.the_conv_x env x y evd); true
with _ -> false
-let decompose_applied_relation env sigma c left2right =
+let rec decompose_app_rel env evd t =
+ match kind_of_term t with
+ | App (f, args) ->
+ if Array.length args > 1 then
+ let fargs, args = array_chop (Array.length args - 2) args in
+ mkApp (f, fargs), args
+ else
+ let (f', args) = decompose_app_rel env evd args.(0) in
+ let ty = Typing.type_of env evd args.(0) in
+ let f'' = mkLambda (Name (id_of_string "x"), ty,
+ mkLambda (Name (id_of_string "y"), lift 1 ty,
+ mkApp (lift 2 f, [| mkApp (lift 2 f', [| mkRel 2; mkRel 1 |]) |])))
+ in (f'', args)
+ | _ -> error "The term provided is not an applied relation."
+
+let decompose_applied_relation env sigma (c,l) left2right =
let ctype = Typing.type_of env sigma c in
let find_rel ty =
- let eqclause = Clenv.mk_clenv_from_env env sigma None (c,ty) in
- let (equiv, args) = decompose_app (Clenv.clenv_type eqclause) in
- let rec split_last_two = function
- | [c1;c2] -> [],(c1, c2)
- | x::y::z ->
- let l,res = split_last_two (y::z) in x::l, res
- | _ -> error "The term provided is not an applied relation." in
- let others,(c1,c2) = split_last_two args in
+ let eqclause = Clenv.make_clenv_binding_env_apply env sigma None (c,ty) l in
+ let (equiv, args) = decompose_app_rel env sigma (Clenv.clenv_type eqclause) in
+ let c1 = args.(0) and c2 = args.(1) in
let ty1, ty2 =
Typing.type_of env eqclause.evd c1, Typing.type_of env eqclause.evd c2
in
if not (evd_convertible env eqclause.evd ty1 ty2) then None
else
Some { cl=eqclause; prf=(Clenv.clenv_value eqclause);
- car=ty1; rel=mkApp (equiv, Array.of_list others);
- l2r=left2right; c1=c1; c2=c2; c=Some c; abs=None }
+ car=ty1; rel = equiv;
+ l2r=left2right; c1=c1; c2=c2; c=Some (c,l); abs=None }
in
match find_rel ctype with
| Some c -> c
@@ -398,27 +407,53 @@ let rec decomp_pointwise n c =
if n = 0 then c
else
match kind_of_term c with
- | App (pointwise, [| a; b; relb |]) -> decomp_pointwise (pred n) relb
- | _ -> raise Not_found
+ | App (f, [| a; b; relb |]) when eq_constr f (Lazy.force pointwise_relation) ->
+ decomp_pointwise (pred n) relb
+ | App (f, [| a; b; arelb |]) when eq_constr f (Lazy.force forall_relation) ->
+ decomp_pointwise (pred n) (Reductionops.beta_applist (arelb, [mkRel 1]))
+ | _ -> raise (Invalid_argument "decomp_pointwise")
+
+let rec apply_pointwise rel = function
+ | arg :: args ->
+ (match kind_of_term rel with
+ | App (f, [| a; b; relb |]) when eq_constr f (Lazy.force pointwise_relation) ->
+ apply_pointwise relb args
+ | App (f, [| a; b; arelb |]) when eq_constr f (Lazy.force forall_relation) ->
+ apply_pointwise (Reductionops.beta_applist (arelb, [arg])) args
+ | _ -> raise (Invalid_argument "apply_pointwise"))
+ | [] -> rel
+
+let pointwise_or_dep_relation n t car rel =
+ if noccurn 1 car then
+ mkApp (Lazy.force pointwise_relation, [| t; lift (-1) car; lift (-1) rel |])
+ else
+ mkApp (Lazy.force forall_relation,
+ [| t; mkLambda (n, t, car); mkLambda (n, t, rel) |])
-let lift_cstr env sigma evars args cstr =
+let lift_cstr env sigma evars (args : constr list) ty cstr =
let cstr =
- let start =
+ let start env car =
match cstr with
- | Some codom -> codom
- | None ->
- let car = Evarutil.e_new_evar evars env (new_Type ()) in
- let rel = Evarutil.e_new_evar evars env (mk_relation car) in
- (car, rel)
+ | None | Some (_, None) ->
+ Evarutil.e_new_evar evars env (mk_relation car)
+ | Some (ty, Some rel) -> rel
in
- Array.fold_right
- (fun arg (car, rel) ->
- let ty = Typing.type_of env sigma arg in
- let car' = mkProd (Anonymous, ty, car) in
- let rel' = mkApp (Lazy.force pointwise_relation, [| ty; car; rel |]) in
- (car', rel'))
- args start
- in Some cstr
+ let rec aux env prod n =
+ if n = 0 then start env prod
+ else
+ match kind_of_term (Reduction.whd_betadeltaiota env prod) with
+ | Prod (na, ty, b) ->
+ if noccurn 1 b then
+ let b' = lift (-1) b in
+ let rb = aux env b' (pred n) in
+ mkApp (Lazy.force pointwise_relation, [| ty; b'; rb |])
+ else
+ let rb = aux (Environ.push_rel (na, None, ty) env) b (pred n) in
+ mkApp (Lazy.force forall_relation,
+ [| ty; mkLambda (na, ty, b); mkLambda (na, ty, rb) |])
+ | _ -> assert false
+ in aux env ty (List.length args)
+ in Some (ty, cstr)
let unlift_cstr env sigma = function
| None -> None
@@ -430,12 +465,17 @@ let default_flags = { under_lambdas = true; on_morphisms = true; }
type evars = evar_map * evar_map (* goal evars, constraint evars *)
+type rewrite_proof =
+ | RewPrf of constr * constr
+ | RewCast of cast_kind
+
+let get_rew_rel = function RewPrf (rel, prf) -> Some rel | _ -> None
+
type rewrite_result_info = {
rew_car : constr;
- rew_rel : constr;
rew_from : constr;
rew_to : constr;
- rew_prf : constr;
+ rew_prf : rewrite_proof;
rew_evars : evars;
}
@@ -444,7 +484,13 @@ type rewrite_result = rewrite_result_info option
type strategy = Environ.env -> evar_map -> constr -> types ->
constr option -> evars -> rewrite_result option
-let resolve_subrelation env sigma car rel rel' res =
+let get_rew_prf r = match r.rew_prf with
+ | RewPrf (rel, prf) -> prf
+ | RewCast c ->
+ mkCast (mkApp (Coqlib.build_coq_eq_refl (), [| r.rew_car; r.rew_from |]),
+ c, mkApp (Coqlib.build_coq_eq (), [| r.rew_car; r.rew_from; r.rew_to |]))
+
+let resolve_subrelation env sigma car rel prf rel' res =
if eq_constr rel rel' then res
else
(* try let evd' = Evarconv.the_conv_x env rel rel' res.rew_evars in *)
@@ -452,12 +498,11 @@ let resolve_subrelation env sigma car rel rel' res =
(* with NotConvertible -> *)
let app = mkApp (Lazy.force subrelation, [|car; rel; rel'|]) in
let evars, subrel = new_cstr_evar res.rew_evars env app in
+ let appsub = mkApp (subrel, [| res.rew_from ; res.rew_to ; prf |]) in
{ res with
- rew_prf = mkApp (subrel, [| res.rew_from ; res.rew_to ; res.rew_prf |]);
- rew_rel = rel';
+ rew_prf = RewPrf (rel', appsub);
rew_evars = evars }
-
let resolve_morphism env sigma oldt m ?(fnewt=fun x -> x) args args' cstr evars =
let evars, morph_instance, proj, sigargs, m', args, args' =
let first = try (array_find args' (fun i b -> b <> None))
@@ -466,9 +511,11 @@ let resolve_morphism env sigma oldt m ?(fnewt=fun x -> x) args args' cstr evars
let morphargs', morphobjs' = array_chop first args' in
let appm = mkApp(m, morphargs) in
let appmtype = Typing.type_of env sigma appm in
- let cstrs = List.map (Option.map (fun r -> r.rew_car, r.rew_rel)) (Array.to_list morphobjs') in
+ let cstrs = List.map (Option.map (fun r -> r.rew_car, get_rew_rel r.rew_prf)) (Array.to_list morphobjs') in
(* Desired signature *)
- let evars, appmtype', signature, sigargs = build_signature evars env appmtype cstrs cstr (fun (a,r) -> r) in
+ let evars, appmtype', signature, sigargs =
+ build_signature evars env appmtype cstrs cstr
+ in
(* Actual signature found *)
let cl_args = [| appmtype' ; signature ; appm |] in
let app = mkApp (Lazy.force proper_type, cl_args) in
@@ -492,7 +539,7 @@ let resolve_morphism env sigma oldt m ?(fnewt=fun x -> x) args args' cstr evars
let evars, proof = proper_proof env evars carrier relation x in
[ proof ; x ; x ] @ acc, subst, evars, sigargs, x :: typeargs'
| Some r ->
- [ r.rew_prf; r.rew_to; x ] @ acc, subst, evars, sigargs, r.rew_to :: typeargs')
+ [ get_rew_prf r; r.rew_to; x ] @ acc, subst, evars, sigargs, r.rew_to :: typeargs')
| None ->
if y <> None then error "Cannot rewrite the argument of a dependent function";
x :: acc, x :: subst, evars, sigargs, x :: typeargs')
@@ -504,10 +551,10 @@ let resolve_morphism env sigma oldt m ?(fnewt=fun x -> x) args args' cstr evars
[ a, Some r ] -> evars, proof, a, r, oldt, fnewt newt
| _ -> assert(false)
-let apply_constraint env sigma car rel cstr res =
+let apply_constraint env sigma car rel prf cstr res =
match cstr with
| None -> res
- | Some r -> resolve_subrelation env sigma car rel r res
+ | Some r -> resolve_subrelation env sigma car rel prf r res
let eq_env x y = x == y
@@ -523,12 +570,14 @@ let apply_rule hypinfo loccs : strategy =
match unif with
| Some (env', (prf, (car, rel, c1, c2))) when is_occ !occ ->
begin
- let goalevars = Evd.evar_merge (fst evars)
- (Evd.undefined_evars (Evarutil.nf_evar_map env'.evd))
- in
- let res = { rew_car = ty; rew_rel = rel; rew_from = c1;
- rew_to = c2; rew_prf = prf; rew_evars = goalevars, snd evars }
- in Some (Some (apply_constraint env sigma car rel cstr res))
+ if eq_constr t c2 then Some None
+ else
+ let goalevars = Evd.evar_merge (fst evars)
+ (Evd.undefined_evars (Evarutil.nf_evar_map env'.evd))
+ in
+ let res = { rew_car = ty; rew_from = c1;
+ rew_to = c2; rew_prf = RewPrf (rel, prf); rew_evars = goalevars, snd evars }
+ in Some (Some (apply_constraint env sigma car rel prf cstr res))
end
| _ -> None
@@ -539,24 +588,79 @@ let apply_lemma (evm,c) left2right loccs : strategy =
apply_rule hypinfo loccs env sigma
let make_leibniz_proof c ty r =
- let prf = mkApp (Lazy.force coq_f_equal,
- [| r.rew_car; ty;
- mkLambda (Anonymous, r.rew_car, c (mkRel 1));
- r.rew_from; r.rew_to; r.rew_prf |])
+ let prf =
+ match r.rew_prf with
+ | RewPrf (rel, prf) ->
+ let rel = mkApp (Lazy.force coq_eq, [| ty |]) in
+ let prf =
+ mkApp (Lazy.force coq_f_equal,
+ [| r.rew_car; ty;
+ mkLambda (Anonymous, r.rew_car, c (mkRel 1));
+ r.rew_from; r.rew_to; prf |])
+ in RewPrf (rel, prf)
+ | RewCast k -> r.rew_prf
in
- { r with rew_car = ty; rew_rel = mkApp (Lazy.force coq_eq, [| ty |]);
+ { r with rew_car = ty;
rew_from = c r.rew_from; rew_to = c r.rew_to; rew_prf = prf }
-let pointwise_or_dep_relation n t car rel =
- if noccurn 1 car then
- mkApp (Lazy.force pointwise_relation, [| t; lift (-1) car; lift (-1) rel |])
- else
- mkApp (Lazy.force forall_relation,
- [| t; mkLambda (n, t, car); mkLambda (n, t, rel) |])
-
+open Elimschemes
+
+let reset_env env =
+ let env' = Global.env_of_context (Environ.named_context_val env) in
+ Environ.push_rel_context (Environ.rel_context env) env'
+
+let fold_match ?(force=false) env sigma c =
+ let (ci, p, c, brs) = destCase c in
+ let cty = Retyping.get_type_of env sigma c in
+ let dep, pred, exists, sk =
+ let env', ctx, body =
+ let ctx, pred = decompose_lam_assum p in
+ let env' = Environ.push_rel_context ctx env in
+ env', ctx, pred
+ in
+ let sortp = Retyping.get_sort_family_of env' sigma body in
+ let sortc = Retyping.get_sort_family_of env sigma cty in
+ let dep = not (noccurn 1 body) in
+ let pred = if dep then p else
+ it_mkProd_or_LetIn (subst1 mkProp body) (List.tl ctx)
+ in
+ let sk =
+ if sortp = InProp then
+ if sortc = InProp then
+ if dep then case_dep_scheme_kind_from_prop
+ else case_scheme_kind_from_prop
+ else (
+ if dep
+ then case_dep_scheme_kind_from_type_in_prop
+ else case_scheme_kind_from_type)
+ else ((* sortc <> InProp by typing *)
+ if dep
+ then case_dep_scheme_kind_from_type
+ else case_scheme_kind_from_type)
+ in
+ let exists = Ind_tables.check_scheme sk ci.ci_ind in
+ if exists || force then
+ dep, pred, exists, Ind_tables.find_scheme sk ci.ci_ind
+ else raise Not_found
+ in
+ let app =
+ let ind, args = Inductive.find_rectype env cty in
+ let pars, args = list_chop ci.ci_npar args in
+ let meths = List.map (fun br -> br) (Array.to_list brs) in
+ applist (mkConst sk, pars @ [pred] @ meths @ args @ [c])
+ in
+ sk, (if exists then env else reset_env env), app
+
+let unfold_match env sigma sk app =
+ match kind_of_term app with
+ | App (f', args) when f' = mkConst sk ->
+ let v = Environ.constant_value (Global.env ()) sk in
+ Reductionops.whd_beta sigma (mkApp (v, args))
+ | _ -> app
+
let subterm all flags (s : strategy) : strategy =
let rec aux env sigma t ty cstr evars =
- let cstr' = Option.map (fun c -> (ty, c)) cstr in
+ let cstr' = Option.map (fun c -> (ty, Some c)) cstr in
match kind_of_term t with
| App (m, args) ->
let rewrite_args success =
@@ -578,29 +682,39 @@ let subterm all flags (s : strategy) : strategy =
| Some true ->
let args' = Array.of_list (List.rev args') in
let evars', prf, car, rel, c1, c2 = resolve_morphism env sigma t m args args' cstr' evars' in
- let res = { rew_car = ty; rew_rel = rel; rew_from = c1;
- rew_to = c2; rew_prf = prf; rew_evars = evars' } in
+ let res = { rew_car = ty; rew_from = c1;
+ rew_to = c2; rew_prf = RewPrf (rel, prf);
+ rew_evars = evars' }
+ in
Some (Some res)
in
if flags.on_morphisms then
let evarsref = ref (snd evars) in
- let cstr' = lift_cstr env sigma evarsref args cstr' in
- let m' = s env sigma m (Typing.type_of env sigma m)
- (Option.map snd cstr') (fst evars, !evarsref)
- in
+ let mty = Typing.type_of env sigma m in
+ let argsl = Array.to_list args in
+ let cstr' = lift_cstr env sigma evarsref argsl mty None in
+ let m' = s env sigma m mty (Option.map snd cstr') (fst evars, !evarsref) in
match m' with
| None -> rewrite_args None (* Standard path, try rewrite on arguments *)
| Some None -> rewrite_args (Some false)
| Some (Some r) ->
(* We rewrote the function and get a proof of pointwise rel for the arguments.
We just apply it. *)
- let nargs = Array.length args in
+ let prf = match r.rew_prf with
+ | RewPrf (rel, prf) ->
+ RewPrf (apply_pointwise rel argsl, mkApp (prf, args))
+ | x -> x
+ in
let res =
- { rew_car = decomp_prod env (fst r.rew_evars) nargs r.rew_car;
- rew_rel = decomp_pointwise nargs r.rew_rel;
+ { rew_car = prod_appvect r.rew_car args;
rew_from = mkApp(r.rew_from, args); rew_to = mkApp(r.rew_to, args);
- rew_prf = mkApp (r.rew_prf, args); rew_evars = r.rew_evars }
- in Some (Some res)
+ rew_prf = prf;
+ rew_evars = r.rew_evars }
+ in
+ match prf with
+ | RewPrf (rel, prf) ->
+ Some (Some (apply_constraint env sigma res.rew_car rel prf cstr res))
+ | _ -> Some (Some res)
else rewrite_args None
| Prod (n, x, b) when noccurn 1 b ->
@@ -637,18 +751,24 @@ let subterm all flags (s : strategy) : strategy =
let b' = s env' sigma b (Typing.type_of env' sigma b) (unlift_cstr env sigma cstr) evars in
(match b' with
| Some (Some r) ->
- Some (Some { r with
- rew_prf = mkLambda (n, t, r.rew_prf);
- rew_car = mkProd (n, t, r.rew_car);
- rew_rel = pointwise_or_dep_relation n t r.rew_car r.rew_rel;
- rew_from = mkLambda(n, t, r.rew_from);
- rew_to = mkLambda (n, t, r.rew_to) })
+ let prf = match r.rew_prf with
+ | RewPrf (rel, prf) ->
+ let rel = pointwise_or_dep_relation n t r.rew_car rel in
+ let prf = mkLambda (n, t, prf) in
+ RewPrf (rel, prf)
+ | x -> x
+ in
+ Some (Some { r with
+ rew_prf = prf;
+ rew_car = mkProd (n, t, r.rew_car);
+ rew_from = mkLambda(n, t, r.rew_from);
+ rew_to = mkLambda (n, t, r.rew_to) })
| _ -> b')
| Case (ci, p, c, brs) ->
let cty = Typing.type_of env sigma c in
- let cstr = Some (mkApp (Lazy.force coq_eq, [| cty |])) in
- let c' = s env sigma c cty cstr evars in
+ let cstr' = Some (mkApp (Lazy.force coq_eq, [| cty |])) in
+ let c' = s env sigma c cty cstr' evars in
(match c' with
| Some (Some r) ->
Some (Some (make_leibniz_proof (fun x -> mkCase (ci, p, x, brs)) ty r))
@@ -668,7 +788,14 @@ let subterm all flags (s : strategy) : strategy =
let ctxc x = mkCase (ci, p, c, Array.of_list (List.rev (brs' x))) in
Some (Some (make_leibniz_proof ctxc ty r))
| None -> x
- else x)
+ else
+ match try Some (fold_match env sigma t) with Not_found -> None with
+ | None -> x
+ | Some (cst, _, t') ->
+ match aux env sigma t' ty cstr evars with
+ | Some (Some prf) -> Some (Some { prf with
+ rew_from = t; rew_to = unfold_match env sigma cst prf.rew_to })
+ | x' -> x)
| _ -> if all then Some None else None
in aux
@@ -676,19 +803,27 @@ let subterm all flags (s : strategy) : strategy =
let all_subterms = subterm true default_flags
let one_subterm = subterm false default_flags
-(** Requires transitivity of the rewrite step, not tail-recursive. *)
+(** Requires transitivity of the rewrite step, if not a reduction.
+ Not tail-recursive. *)
let transitivity env sigma (res : rewrite_result_info) (next : strategy) : rewrite_result option =
- match next env sigma res.rew_to res.rew_car (Some res.rew_rel) res.rew_evars with
+ match next env sigma res.rew_to res.rew_car (get_rew_rel res.rew_prf) res.rew_evars with
| None -> None
| Some None -> Some (Some res)
| Some (Some res') ->
- let prfty = mkApp (Lazy.force transitive_type, [| res.rew_car ; res.rew_rel |]) in
- let evars, prf = new_cstr_evar res'.rew_evars env prfty in
- let prf = mkApp (prf, [|res.rew_from; res'.rew_from; res'.rew_to;
- res.rew_prf; res'.rew_prf |])
- in Some (Some { res' with rew_from = res.rew_from; rew_evars = evars; rew_prf = prf })
-
+ match res.rew_prf with
+ | RewCast c -> Some (Some { res' with rew_from = res.rew_from })
+ | RewPrf (rew_rel, rew_prf) ->
+ match res'.rew_prf with
+ | RewCast _ -> Some (Some ({ res with rew_to = res'.rew_to }))
+ | RewPrf (res'_rel, res'_prf) ->
+ let prfty = mkApp (Lazy.force transitive_type, [| res.rew_car; rew_rel |]) in
+ let evars, prf = new_cstr_evar res'.rew_evars env prfty in
+ let prf = mkApp (prf, [|res.rew_from; res'.rew_from; res'.rew_to;
+ rew_prf; res'_prf |])
+ in Some (Some { res' with rew_from = res.rew_from;
+ rew_evars = evars; rew_prf = RewPrf (res'_rel, prf) })
+
(** Rewriting strategies.
Inspired by ELAN's rewriting strategies:
@@ -714,8 +849,8 @@ module Strategies =
let mty = mkApp (Lazy.force proper_proxy_type, [| ty ; rel; t |]) in
new_cstr_evar evars env mty
in
- Some (Some { rew_car = ty; rew_rel = rel; rew_from = t; rew_to = t;
- rew_prf = proof; rew_evars = evars })
+ Some (Some { rew_car = ty; rew_from = t; rew_to = t;
+ rew_prf = RewPrf (rel, proof); rew_evars = evars })
let progress (s : strategy) : strategy =
fun env sigma t ty cstr evars ->
@@ -769,13 +904,24 @@ module Strategies =
let old_hints (db : string) : strategy =
let rules = Autorewrite.find_rewrites db in
- lemmas (List.map (fun hint -> (inj_open hint.Autorewrite.rew_lemma, hint.Autorewrite.rew_l2r)) rules)
+ lemmas (List.map (fun hint -> (inj_open (hint.Autorewrite.rew_lemma, NoBindings), hint.Autorewrite.rew_l2r)) rules)
let hints (db : string) : strategy =
fun env sigma t ty cstr evars ->
- let rules = Autorewrite.find_matches db t in
- lemmas (List.map (fun hint -> (inj_open hint.Autorewrite.rew_lemma, hint.Autorewrite.rew_l2r)) rules)
- env sigma t ty cstr evars
+ let rules = Autorewrite.find_matches db t in
+ lemmas (List.map (fun hint -> (inj_open (hint.Autorewrite.rew_lemma, NoBindings), hint.Autorewrite.rew_l2r)) rules)
+ env sigma t ty cstr evars
+
+ let reduce (r : Redexpr.red_expr) : strategy =
+ let rfn, ckind = Redexpr.reduction_of_red_expr r in
+ fun env sigma t ty cstr evars ->
+ let t' = rfn env sigma t in
+ if eq_constr t' t then
+ Some None
+ else
+ Some (Some { rew_car = ty; rew_from = t; rew_to = t';
+ rew_prf = RewCast ckind; rew_evars = evars })
+
end
@@ -787,7 +933,7 @@ let rewrite_strat flags occs hyp =
Strategies.choice app (subterm true flags (fun env -> aux () env))
in aux ()
-let rewrite_with (evm,c) left2right loccs : strategy =
+let rewrite_with {it = c; sigma = evm} left2right loccs : strategy =
fun env sigma ->
let evars = Evd.merge sigma evm in
let hypinfo = ref (decompose_applied_relation env evars c left2right) in
@@ -803,7 +949,7 @@ let apply_strategy (s : strategy) env sigma concl cstr evars =
| Some None -> Some None
| Some (Some res) ->
evars := res.rew_evars;
- Some (Some (res.rew_prf, (res.rew_car, res.rew_rel, res.rew_from, res.rew_to)))
+ Some (Some (res.rew_prf, (res.rew_car, res.rew_from, res.rew_to)))
let split_evars_once sigma evd =
Evd.fold (fun ev evi deps ->
@@ -834,6 +980,12 @@ let solve_constraints env evars =
let nf_zeta =
Reductionops.clos_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA])
+let map_rewprf f = function
+ | RewPrf (rel, prf) -> RewPrf (f rel, f prf)
+ | RewCast c -> RewCast c
+
+exception RewriteFailure
+
let cl_rewrite_clause_aux ?(abs=None) strat goal_meta clause gl =
let concl, is_hyp =
match clause with
@@ -852,12 +1004,14 @@ let cl_rewrite_clause_aux ?(abs=None) strat goal_meta clause gl =
let env = pf_env gl in
let eq = apply_strategy strat env sigma concl (Some cstr) evars in
match eq with
- | Some (Some (p, (_, _, oldt, newt))) ->
+ | Some (Some (p, (car, oldt, newt))) ->
(try
let cstrevars = !evars in
let evars = solve_constraints env cstrevars in
- let p = Evarutil.nf_evar evars p in
- let p = nf_zeta env evars p in
+ let p = map_rewprf
+ (fun p -> nf_zeta env evars (Evarutil.nf_evar evars p))
+ p
+ in
let newt = Evarutil.nf_evar evars newt in
let abs = Option.map (fun (x, y) ->
Evarutil.nf_evar evars x, Evarutil.nf_evar evars y) abs in
@@ -865,27 +1019,36 @@ let cl_rewrite_clause_aux ?(abs=None) strat goal_meta clause gl =
let rewtac =
match is_hyp with
| Some id ->
- let term =
- match abs with
- | None -> p
- | Some (t, ty) ->
- mkApp (mkLambda (Name (id_of_string "lemma"), ty, p), [| t |])
- in
- cut_replacing id newt
- (Tacmach.refine_no_check (mkApp (term, [| mkVar id |])))
+ (match p with
+ | RewPrf (rel, p) ->
+ let term =
+ match abs with
+ | None -> p
+ | Some (t, ty) ->
+ mkApp (mkLambda (Name (id_of_string "lemma"), ty, p), [| t |])
+ in
+ cut_replacing id newt
+ (Tacmach.refine_no_check (mkApp (term, [| mkVar id |])))
+ | RewCast c ->
+ change_in_hyp None newt (id, InHypTypeOnly))
+
| None ->
- (match abs with
- | None ->
- let name = next_name_away_with_default "H" Anonymous (pf_ids_of_hyps gl) in
- tclTHENLAST
- (Tacmach.internal_cut_no_check false name newt)
- (tclTHEN (Tactics.revert [name]) (Tacmach.refine_no_check p))
- | Some (t, ty) ->
- Tacmach.refine_no_check
- (mkApp (mkLambda (Name (id_of_string "newt"), newt,
- mkLambda (Name (id_of_string "lemma"), ty,
- mkApp (p, [| mkRel 2 |]))),
- [| mkMeta goal_meta; t |])))
+ (match p with
+ | RewPrf (rel, p) ->
+ (match abs with
+ | None ->
+ let name = next_name_away_with_default "H" Anonymous (pf_ids_of_hyps gl) in
+ tclTHENLAST
+ (Tacmach.internal_cut_no_check false name newt)
+ (tclTHEN (Tactics.revert [name]) (Tacmach.refine_no_check p))
+ | Some (t, ty) ->
+ Tacmach.refine_no_check
+ (mkApp (mkLambda (Name (id_of_string "newt"), newt,
+ mkLambda (Name (id_of_string "lemma"), ty,
+ mkApp (p, [| mkRel 2 |]))),
+ [| mkMeta goal_meta; t |])))
+ | RewCast c ->
+ change_in_concl None newt)
in
let evartac =
if not (undef = Evd.empty) then
@@ -900,14 +1063,14 @@ let cl_rewrite_clause_aux ?(abs=None) strat goal_meta clause gl =
++ fnl () ++ Himsg.explain_typeclass_error env e)) gl)
| Some None ->
tclFAIL 0 (str"setoid rewrite failed: no progress made") gl
- | None -> raise Not_found
+ | None -> raise RewriteFailure
let cl_rewrite_clause_strat strat clause gl =
init_setoid ();
let meta = Evarutil.new_meta() in
let gl = { gl with sigma = Typeclasses.mark_unresolvables gl.sigma } in
try cl_rewrite_clause_aux strat meta clause gl
- with Not_found ->
+ with RewriteFailure ->
tclFAIL 0 (str"setoid rewrite failed: strategy failed") gl
let cl_rewrite_clause l left2right occs clause gl =
@@ -939,11 +1102,13 @@ let glob_strategy ist l = l
let subst_strategy evm l = l
let apply_constr_expr c l2r occs = fun env sigma ->
- let c = Constrintern.interp_open_constr sigma env c in
- apply_lemma c l2r occs env sigma
+ let evd, c = Constrintern.interp_open_constr sigma env c in
+ apply_lemma (evd, (c, NoBindings)) l2r occs env sigma
-let interp_constr_list env sigma cs =
- List.map (fun c -> Constrintern.interp_open_constr sigma env c, true) cs
+let interp_constr_list env sigma =
+ List.map (fun c ->
+ let evd, c = Constrintern.interp_open_constr sigma env c in
+ (evd, (c, NoBindings)), true)
open Pcoq
@@ -980,15 +1145,18 @@ ARGUMENT EXTEND rewstrategy TYPED AS strategy
| [ "choice" rewstrategy(h) rewstrategy(h') ] -> [ Strategies.choice h h' ]
| [ "old_hints" preident(h) ] -> [ Strategies.old_hints h ]
| [ "hints" preident(h) ] -> [ Strategies.hints h ]
- | [ "terms" constr_list(h) ] -> [ fun env sigma -> Strategies.lemmas (interp_constr_list env sigma h) env sigma ]
+ | [ "terms" constr_list(h) ] -> [ fun env sigma ->
+ Strategies.lemmas (interp_constr_list env sigma h) env sigma ]
+ | [ "eval" red_expr(r) ] -> [ fun env sigma ->
+ Strategies.reduce (Tacinterp.interp_redexp env sigma r) env sigma ]
END
TACTIC EXTEND class_rewrite
-| [ "clrewrite" orient(o) open_constr(c) "in" hyp(id) "at" occurrences(occ) ] -> [ cl_rewrite_clause c o (occurrences_of occ) (Some id) ]
-| [ "clrewrite" orient(o) open_constr(c) "at" occurrences(occ) "in" hyp(id) ] -> [ cl_rewrite_clause c o (occurrences_of occ) (Some id) ]
-| [ "clrewrite" orient(o) open_constr(c) "in" hyp(id) ] -> [ cl_rewrite_clause c o all_occurrences (Some id) ]
-| [ "clrewrite" orient(o) open_constr(c) "at" occurrences(occ) ] -> [ cl_rewrite_clause c o (occurrences_of occ) None ]
-| [ "clrewrite" orient(o) open_constr(c) ] -> [ cl_rewrite_clause c o all_occurrences None ]
+| [ "clrewrite" orient(o) constr_with_bindings(c) "in" hyp(id) "at" occurrences(occ) ] -> [ cl_rewrite_clause c o (occurrences_of occ) (Some id) ]
+| [ "clrewrite" orient(o) constr_with_bindings(c) "at" occurrences(occ) "in" hyp(id) ] -> [ cl_rewrite_clause c o (occurrences_of occ) (Some id) ]
+| [ "clrewrite" orient(o) constr_with_bindings(c) "in" hyp(id) ] -> [ cl_rewrite_clause c o all_occurrences (Some id) ]
+| [ "clrewrite" orient(o) constr_with_bindings(c) "at" occurrences(occ) ] -> [ cl_rewrite_clause c o (occurrences_of occ) None ]
+| [ "clrewrite" orient(o) constr_with_bindings(c) ] -> [ cl_rewrite_clause c o all_occurrences None ]
END
TACTIC EXTEND class_rewrite_strat
@@ -998,7 +1166,7 @@ END
let clsubstitute o c =
- let is_tac id = match kind_of_term (snd c) with Var id' when id' = id -> true | _ -> false in
+ let is_tac id = match kind_of_term (fst c.it) with Var id' when id' = id -> true | _ -> false in
Tacticals.onAllHypsAndConcl
(fun cl ->
match cl with
@@ -1006,22 +1174,22 @@ let clsubstitute o c =
| _ -> tclTRY (cl_rewrite_clause c o all_occurrences cl))
TACTIC EXTEND substitute
-| [ "substitute" orient(o) open_constr(c) ] -> [ clsubstitute o c ]
+| [ "substitute" orient(o) constr_with_bindings(c) ] -> [ clsubstitute o c ]
END
(* Compatibility with old Setoids *)
TACTIC EXTEND setoid_rewrite
- [ "setoid_rewrite" orient(o) open_constr(c) ]
+ [ "setoid_rewrite" orient(o) constr_with_bindings(c) ]
-> [ cl_rewrite_clause c o all_occurrences None ]
- | [ "setoid_rewrite" orient(o) open_constr(c) "in" hyp(id) ] ->
+ | [ "setoid_rewrite" orient(o) constr_with_bindings(c) "in" hyp(id) ] ->
[ cl_rewrite_clause c o all_occurrences (Some id)]
- | [ "setoid_rewrite" orient(o) open_constr(c) "at" occurrences(occ) ] ->
+ | [ "setoid_rewrite" orient(o) constr_with_bindings(c) "at" occurrences(occ) ] ->
[ cl_rewrite_clause c o (occurrences_of occ) None]
- | [ "setoid_rewrite" orient(o) open_constr(c) "at" occurrences(occ) "in" hyp(id)] ->
+ | [ "setoid_rewrite" orient(o) constr_with_bindings(c) "at" occurrences(occ) "in" hyp(id)] ->
[ cl_rewrite_clause c o (occurrences_of occ) (Some id)]
- | [ "setoid_rewrite" orient(o) open_constr(c) "in" hyp(id) "at" occurrences(occ)] ->
+ | [ "setoid_rewrite" orient(o) constr_with_bindings(c) "in" hyp(id) "at" occurrences(occ)] ->
[ cl_rewrite_clause c o (occurrences_of occ) (Some id)]
END
@@ -1104,12 +1272,12 @@ let declare_relation ?(binders=[]) a aeq n refl symm trans =
(Ident (dummy_loc,id_of_string "Equivalence_Symmetric"), lemma2);
(Ident (dummy_loc,id_of_string "Equivalence_Transitive"), lemma3)])
-type 'a binders_let_argtype = (local_binder list, 'a) Genarg.abstract_argument_type
+type 'a binders_argtype = (local_binder list, 'a) Genarg.abstract_argument_type
-let (wit_binders_let : Genarg.tlevel binders_let_argtype),
- (globwit_binders_let : Genarg.glevel binders_let_argtype),
- (rawwit_binders_let : Genarg.rlevel binders_let_argtype) =
- Genarg.create_arg "binders_let"
+let (wit_binders : Genarg.tlevel binders_argtype),
+ (globwit_binders : Genarg.glevel binders_argtype),
+ (rawwit_binders : Genarg.rlevel binders_argtype) =
+ Genarg.create_arg "binders"
open Pcoq.Constr
@@ -1147,35 +1315,35 @@ VERNAC COMMAND EXTEND AddRelation3
END
VERNAC COMMAND EXTEND AddParametricRelation
- | [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq)
+ | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq)
"reflexivity" "proved" "by" constr(lemma1)
"symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] ->
[ declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) None ]
- | [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq)
+ | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq)
"reflexivity" "proved" "by" constr(lemma1)
"as" ident(n) ] ->
[ declare_relation ~binders:b a aeq n (Some lemma1) None None ]
- | [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq) "as" ident(n) ] ->
+ | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "as" ident(n) ] ->
[ declare_relation ~binders:b a aeq n None None None ]
END
VERNAC COMMAND EXTEND AddParametricRelation2
- [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2)
+ [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2)
"as" ident(n) ] ->
[ declare_relation ~binders:b a aeq n None (Some lemma2) None ]
- | [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] ->
+ | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] ->
[ declare_relation ~binders:b a aeq n None (Some lemma2) (Some lemma3) ]
END
VERNAC COMMAND EXTEND AddParametricRelation3
- [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1)
+ [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1)
"transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] ->
[ declare_relation ~binders:b a aeq n (Some lemma1) None (Some lemma3) ]
- | [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1)
+ | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1)
"symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3)
"as" ident(n) ] ->
[ declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) (Some lemma3) ]
- | [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3)
+ | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3)
"as" ident(n) ] ->
[ declare_relation ~binders:b a aeq n None None (Some lemma3) ]
END
@@ -1242,7 +1410,7 @@ let build_morphism_signature m =
| _ -> []
in aux t
in
- let evars, t', sig_, cstrs = build_signature !isevars env t cstrs None snd in
+ let evars, t', sig_, cstrs = build_signature !isevars env t cstrs None in
let _ = isevars := evars in
let _ = List.iter
(fun (ty, rel) ->
@@ -1264,7 +1432,7 @@ let default_morphism sign m =
let env = Global.env () in
let t = Typing.type_of env Evd.empty m in
let evars, _, sign, cstrs =
- build_signature (Evd.empty,Evd.empty) env t (fst sign) (snd sign) (fun (ty, rel) -> rel)
+ build_signature (Evd.empty,Evd.empty) env t (fst sign) (snd sign)
in
let morph =
mkApp (Lazy.force proper_type, [| t; sign; m |])
@@ -1324,13 +1492,13 @@ let add_morphism glob binders m s n =
VERNAC COMMAND EXTEND AddSetoid1
[ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] ->
[ add_setoid [] a aeq t n ]
- | [ "Add" "Parametric" "Setoid" binders_let(binders) ":" constr(a) constr(aeq) constr(t) "as" ident(n) ] ->
+ | [ "Add" "Parametric" "Setoid" binders(binders) ":" constr(a) constr(aeq) constr(t) "as" ident(n) ] ->
[ add_setoid binders a aeq t n ]
| [ "Add" "Morphism" constr(m) ":" ident(n) ] ->
[ add_morphism_infer (not (Vernacexpr.use_section_locality ())) m n ]
| [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] ->
[ add_morphism (not (Vernacexpr.use_section_locality ())) [] m s n ]
- | [ "Add" "Parametric" "Morphism" binders_let(binders) ":" constr(m)
+ | [ "Add" "Parametric" "Morphism" binders(binders) ":" constr(m)
"with" "signature" lconstr(s) "as" ident(n) ] ->
[ add_morphism (not (Vernacexpr.use_section_locality ())) binders m s n ]
END
@@ -1390,16 +1558,16 @@ let unification_rewrite l2r c1 c2 cl car rel but gl =
let cl' = { cl' with templval = mk_freelisted prf ; templtyp = mk_freelisted prfty } in
{cl=cl'; prf=(mkRel 1); car=car; rel=rel; l2r=l2r; c1=c1; c2=c2; c=None; abs=Some (prf, prfty)}
-let get_hyp gl evars c clause l2r =
- let hi = decompose_applied_relation (pf_env gl) evars c l2r in
+let get_hyp gl evars (c,l) clause l2r =
+ let hi = decompose_applied_relation (pf_env gl) evars (c,l) l2r in
let but = match clause with Some id -> pf_get_hyp_typ gl id | None -> pf_concl gl in
unification_rewrite hi.l2r hi.c1 hi.c2 hi.cl hi.car hi.rel but gl
-let general_rewrite_flags = { under_lambdas = false; on_morphisms = false }
+let general_rewrite_flags = { under_lambdas = false; on_morphisms = true }
-let apply_lemma gl c cl l2r occs =
+let apply_lemma gl (c,l) cl l2r occs =
let sigma = project gl in
- let hypinfo = ref (get_hyp gl sigma c cl l2r) in
+ let hypinfo = ref (get_hyp gl sigma (c,l) cl l2r) in
let app = apply_rule hypinfo occs in
let rec aux () =
Strategies.choice app (subterm true general_rewrite_flags (fun env -> aux () env))
@@ -1407,12 +1575,12 @@ let apply_lemma gl c cl l2r occs =
let general_s_rewrite cl l2r occs (c,l) ~new_goals gl =
let meta = Evarutil.new_meta() in
- let hypinfo, strat = apply_lemma gl c cl l2r occs in
+ let hypinfo, strat = apply_lemma gl (c,l) cl l2r occs in
try
tclTHEN
(Refiner.tclEVARS hypinfo.cl.evd)
(cl_rewrite_clause_aux ~abs:hypinfo.abs strat meta cl) gl
- with Not_found ->
+ with RewriteFailure ->
let {l2r=l2r; c1=x; c2=y} = hypinfo in
raise (Pretype_errors.PretypeError
(pf_env gl,
@@ -1441,18 +1609,10 @@ let not_declared env ty rel =
tclFAIL 0 (str" The relation " ++ Printer.pr_constr_env env rel ++ str" is not a declared " ++
str ty ++ str" relation. Maybe you need to require the Setoid library")
-let relation_of_constr env c =
- match kind_of_term c with
- | App (f, args) when Array.length args >= 2 ->
- let relargs, args = array_chop (Array.length args - 2) args in
- mkApp (f, relargs), args
- | _ -> errorlabstrm "relation_of_constr"
- (str "The term " ++ Printer.pr_constr_env env c ++ str" is not an applied relation.")
-
let setoid_proof gl ty fn fallback =
let env = pf_env gl in
try
- let rel, args = relation_of_constr env (pf_concl gl) in
+ let rel, args = decompose_app_rel env (project gl) (pf_concl gl) in
let evm, car = project gl, pf_type_of gl args.(0) in
fn env evm car rel gl
with e ->
@@ -1460,7 +1620,7 @@ let setoid_proof gl ty fn fallback =
with Hipattern.NoEquationFound ->
match e with
| Not_found ->
- let rel, args = relation_of_constr env (pf_concl gl) in
+ let rel, args = decompose_app_rel env (project gl) (pf_concl gl) in
not_declared env ty rel gl
| _ -> raise e
@@ -1480,8 +1640,7 @@ let setoid_transitivity c gl =
let proof = get_transitive_proof env evm car rel in
match c with
| None -> eapply proof
- | Some c ->
- apply_with_bindings (proof,Rawterm.ExplicitBindings [ dummy_loc, Rawterm.NamedHyp (id_of_string "y"), c ]))
+ | Some c -> apply_with_bindings (proof,Rawterm.ImplicitBindings [ c ]))
(transitivity_red true c)
let setoid_symmetry_in id gl =
@@ -1539,3 +1698,25 @@ let implify id gl =
TACTIC EXTEND implify
[ "implify" hyp(n) ] -> [ implify n ]
END
+
+let rec fold_matches env sigma c =
+ map_constr_with_full_binders Environ.push_rel
+ (fun env c ->
+ match kind_of_term c with
+ | Case _ ->
+ let cst, env, c' = fold_match ~force:true env sigma c in
+ fold_matches env sigma c'
+ | _ -> fold_matches env sigma c)
+ env c
+
+TACTIC EXTEND fold_match
+[ "fold_match" constr(c) ] -> [ fun gl ->
+ let _, _, c' = fold_match ~force:true (pf_env gl) (project gl) c in
+ change (Some (snd (pattern_of_constr (project gl) c))) c' onConcl gl ]
+END
+
+TACTIC EXTEND fold_matches
+| [ "fold_matches" constr(c) ] -> [ fun gl ->
+ let c' = fold_matches (pf_env gl) (project gl) c in
+ change (Some (snd (pattern_of_constr (project gl) c))) c' onConcl gl ]
+END
diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml
index 291df0fe..95e44c40 100644
--- a/tactics/tacinterp.ml
+++ b/tactics/tacinterp.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: tacinterp.ml 13360 2010-07-30 08:47:08Z herbelin $ *)
open Constrintern
open Closure
@@ -2415,7 +2415,9 @@ and interp_atomic ist gl tac =
| TacChange (Some op,c,cl) ->
let sign,op = interp_typed_pattern ist env sigma op in
h_change (Some op)
- (pf_interp_constr ist (extend_gl_hyps gl sign) c)
+ (try pf_interp_constr ist (extend_gl_hyps gl sign) c
+ with Not_found | Anomaly _ (* Hack *) ->
+ errorlabstrm "" (strbrk "Failed to get enough information from the left-hand side to type the right-hand side."))
(interp_clause ist gl cl)
(* Equivalence relations *)
diff --git a/tactics/tacinterp.mli b/tactics/tacinterp.mli
index 854664e9..82f4d99a 100644
--- a/tactics/tacinterp.mli
+++ b/tactics/tacinterp.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: tacinterp.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Pp
diff --git a/tactics/tactic_option.ml b/tactics/tactic_option.ml
new file mode 100644
index 00000000..df5a3283
--- /dev/null
+++ b/tactics/tactic_option.ml
@@ -0,0 +1,57 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id: subtac.ml 12623 2010-01-04 17:50:38Z letouzey $ *)
+
+open Libobject
+open Proof_type
+open Pp
+
+let declare_tactic_option ?(default=Tacexpr.TacId []) name =
+ let default_tactic_expr : Tacexpr.glob_tactic_expr ref = ref default in
+ let default_tactic : Proof_type.tactic ref = ref (Tacinterp.eval_tactic !default_tactic_expr) in
+ let locality = ref false in
+ let set_default_tactic local t =
+ locality := local;
+ default_tactic_expr := t; default_tactic := Tacinterp.eval_tactic t
+ in
+ let cache (_, (local, tac)) = set_default_tactic local tac in
+ let load (_, (local, tac)) =
+ if not local then set_default_tactic local tac
+ in
+ let subst (s, (local, tac)) =
+ (local, Tacinterp.subst_tactic s tac)
+ in
+ let input, _output =
+ declare_object
+ { (default_object name) with
+ cache_function = cache;
+ load_function = (fun _ -> load);
+ open_function = (fun _ -> load);
+ classify_function = (fun (local, tac) ->
+ if local then Dispose else Substitute (local, tac));
+ subst_function = subst}
+ in
+ let put local tac =
+ set_default_tactic local tac;
+ Lib.add_anonymous_leaf (input (local, tac))
+ in
+ let get () = !locality, !default_tactic in
+ let print () =
+ Pptactic.pr_glob_tactic (Global.env ()) !default_tactic_expr ++
+ (if !locality then str" (locally defined)" else str" (globally defined)")
+ in
+ let freeze () = !locality, !default_tactic_expr in
+ let unfreeze (local, t) = set_default_tactic local t in
+ let init () = () in
+ Summary.declare_summary name
+ { Summary.freeze_function = freeze;
+ Summary.unfreeze_function = unfreeze;
+ Summary.init_function = init };
+ put, get, print
+
diff --git a/tactics/tactic_option.mli b/tactics/tactic_option.mli
new file mode 100644
index 00000000..890ba98e
--- /dev/null
+++ b/tactics/tactic_option.mli
@@ -0,0 +1,18 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id: subtac.ml 12623 2010-01-04 17:50:38Z letouzey $ *)
+
+open Proof_type
+open Tacexpr
+open Vernacexpr
+
+val declare_tactic_option : ?default:Tacexpr.glob_tactic_expr -> string ->
+ (* put *) (locality_flag -> glob_tactic_expr -> unit) *
+ (* get *) (unit -> locality_flag * tactic) *
+ (* print *) (unit -> Pp.std_ppcmds)
diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml
index 59a8b794..171a35c0 100644
--- a/tactics/tacticals.ml
+++ b/tactics/tacticals.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: tacticals.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Pp
open Util
diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli
index 90508436..af74e382 100644
--- a/tactics/tacticals.mli
+++ b/tactics/tacticals.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: tacticals.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Pp
diff --git a/tactics/tactics.ml b/tactics/tactics.ml
index e09707ab..9e4be0af 100644
--- a/tactics/tactics.ml
+++ b/tactics/tactics.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: tactics.ml 13332 2010-07-26 22:12:43Z msozeau $ *)
open Pp
open Util
@@ -2320,6 +2320,9 @@ let linear vars args =
true
with Seen -> false
+let is_defined_variable env id =
+ pi2 (lookup_named id env) <> None
+
let abstract_args gl generalize_vars dep id defined f args =
let sigma = project gl in
let env = pf_env gl in
@@ -2347,7 +2350,7 @@ let abstract_args gl generalize_vars dep id defined f args =
let liftargty = lift lenctx argty in
let leq = constr_cmp Reduction.CUMUL liftargty ty in
match kind_of_term arg with
- | Var id when leq && not (Idset.mem id nongenvars) ->
+ | Var id when not (is_defined_variable env id) && leq && not (Idset.mem id nongenvars) ->
(subst1 arg arity, ctx, ctxenv, mkApp (c, [|arg|]), args, eqs, refls,
Idset.add id nongenvars, Idset.remove id vars, env)
| _ ->
@@ -2374,7 +2377,7 @@ let abstract_args gl generalize_vars dep id defined f args =
let parvars = ids_of_constr ~all:true Idset.empty f' in
if not (linear parvars args') then true, f, args
else
- match array_find_i (fun i x -> not (isVar x)) args' with
+ match array_find_i (fun i x -> not (isVar x) || is_defined_variable env (destVar x)) args' with
| None -> false, f', args'
| Some nonvar ->
let before, after = array_chop nonvar args' in
diff --git a/tactics/tactics.mli b/tactics/tactics.mli
index 92477e23..bfc32654 100644
--- a/tactics/tactics.mli
+++ b/tactics/tactics.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: tactics.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Util
diff --git a/tactics/tactics.mllib b/tactics/tactics.mllib
index 0a634138..b885b152 100644
--- a/tactics/tactics.mllib
+++ b/tactics/tactics.mllib
@@ -21,3 +21,4 @@ Evar_tactics
Autorewrite
Decl_interp
Decl_proof_instr
+Tactic_option
diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4
index 6091e3d1..a7e7613d 100644
--- a/tactics/tauto.ml4
+++ b/tactics/tauto.ml4
@@ -8,7 +8,7 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
-(*i $Id$ i*)
+(*i $Id: tauto.ml4 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Term
open Hipattern
diff --git a/tactics/termdn.ml b/tactics/termdn.ml
index 828fc065..f9f086d9 100644
--- a/tactics/termdn.ml
+++ b/tactics/termdn.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: termdn.ml 13332 2010-07-26 22:12:43Z msozeau $ *)
open Util
open Names
@@ -33,7 +33,7 @@ struct
| GRLabel of global_reference
| ProdLabel
| LambdaLabel
- | SortLabel of sorts option
+ | SortLabel
module Y = struct
type t = term_label
@@ -97,12 +97,7 @@ let constr_pat_discr_st (idpred,cpred) t =
Some (GRLabel ref, args)
| PProd (_, d, c), [] -> Some (ProdLabel, [d ; c])
| PLambda (_, d, c), l -> Some (LambdaLabel, [d ; c] @ l)
- | PSort s, [] ->
- let s' = match s with
- | RProp c -> Some (Prop c)
- | RType _ -> None
- (* Don't try to be clever about type levels here *)
- in Some (SortLabel s', [])
+ | PSort s, [] -> Some (SortLabel, [])
| _ -> None
open Dn
@@ -125,8 +120,7 @@ let constr_val_discr_st (idpred,cpred) t =
| Var id when not (Idpred.mem id idpred) -> Label(GRLabel (VarRef id),l)
| Prod (n, d, c) -> Label(ProdLabel, [d; c])
| Lambda (n, d, c) -> Label(LambdaLabel, [d; c] @ l)
- | Sort s when is_small s -> Label(SortLabel (Some s), [])
- | Sort _ -> Label (SortLabel None, [])
+ | Sort _ -> Label (SortLabel, [])
| Evar _ -> Everything
| _ -> Nothing
diff --git a/tactics/termdn.mli b/tactics/termdn.mli
index b7c9f273..e778de8d 100644
--- a/tactics/termdn.mli
+++ b/tactics/termdn.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: termdn.mli 13332 2010-07-26 22:12:43Z msozeau $ i*)
(*i*)
open Term
@@ -58,7 +58,7 @@ sig
| GRLabel of global_reference
| ProdLabel
| LambdaLabel
- | SortLabel of sorts option
+ | SortLabel
val constr_pat_discr_st : transparent_state ->
constr_pattern -> (term_label * constr_pattern list) option
diff --git a/test-suite/bugs/closed/2319.v b/test-suite/bugs/closed/2319.v
new file mode 100644
index 00000000..e06fb975
--- /dev/null
+++ b/test-suite/bugs/closed/2319.v
@@ -0,0 +1,13 @@
+Section S.
+
+ CoInductive A (X: Type) := mkA: A X -> A X.
+ Variable T : Type.
+
+ (* This used to loop (bug #2319) *)
+ Timeout 5 Eval vm_compute in cofix s : A T := mkA T s.
+
+ CoFixpoint s : A T := mkA T s
+ with t : A unit := mkA unit (mkA unit t).
+ Timeout 5 Eval vm_compute in s.
+
+End S. \ No newline at end of file
diff --git a/test-suite/bugs/closed/shouldsucceed/1507.v b/test-suite/bugs/closed/shouldsucceed/1507.v
index f1872a2b..ea72ba89 100644
--- a/test-suite/bugs/closed/shouldsucceed/1507.v
+++ b/test-suite/bugs/closed/shouldsucceed/1507.v
@@ -2,7 +2,7 @@
Implementing reals a la Stolzenberg
Danko Ilik, March 2007
- svn revision: $Id$
+ svn revision: $Id: 1507.v 12337 2009-09-17 15:58:14Z glondu $
XField.v -- (unfinished) axiomatisation of the theories of real and
rational intervals.
diff --git a/test-suite/bugs/closed/shouldsucceed/2145.v b/test-suite/bugs/closed/shouldsucceed/2145.v
index b6c5da65..4dc0de74 100644
--- a/test-suite/bugs/closed/shouldsucceed/2145.v
+++ b/test-suite/bugs/closed/shouldsucceed/2145.v
@@ -1,7 +1,7 @@
(* Test robustness of Groebner tactic in presence of disequalities *)
Require Export Reals.
-Require Export NsatzR.
+Require Export Nsatz.
Open Scope R_scope.
@@ -15,6 +15,6 @@ Lemma essai :
Proof.
intros.
(* clear H. groebner used not to work when H was not cleared *)
-nsatzR.
+nsatz.
Qed.
diff --git a/test-suite/bugs/closed/shouldsucceed/2262.v b/test-suite/bugs/closed/shouldsucceed/2262.v
new file mode 100644
index 00000000..b61f18b8
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2262.v
@@ -0,0 +1,11 @@
+
+
+Generalizable Variables A.
+Class Test A := { test : A }.
+
+Lemma mylemma : forall `{Test A}, test = test.
+Admitted. (* works fine *)
+
+Definition mylemma' := forall `{Test A}, test = test.
+About mylemma'.
+
diff --git a/test-suite/bugs/closed/shouldsucceed/2303.v b/test-suite/bugs/closed/shouldsucceed/2303.v
new file mode 100644
index 00000000..e614b9b5
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2303.v
@@ -0,0 +1,4 @@
+Class A := a: unit.
+Class B (x: unit).
+Axiom H: forall x: A, @B x -> x = x -> unit.
+Definition Field (z: A) (m: @B z) x := (@H _ _ x) = z.
diff --git a/test-suite/bugs/closed/shouldsucceed/2347.v b/test-suite/bugs/closed/shouldsucceed/2347.v
new file mode 100644
index 00000000..e433f158
--- /dev/null
+++ b/test-suite/bugs/closed/shouldsucceed/2347.v
@@ -0,0 +1,10 @@
+Require Import EquivDec List.
+Generalizable All Variables.
+
+Program Definition list_eqdec `(eqa : EqDec A eq) : EqDec (list A) eq :=
+ (fun (x y : list A) => _).
+Admit Obligations of list_eqdec.
+
+Program Definition list_eqdec' `(eqa : EqDec A eq) : EqDec (list A) eq :=
+ (fun _ : nat => (fun (x y : list A) => _)) 0.
+Admit Obligations of list_eqdec'.
diff --git a/test-suite/output/Notations.out b/test-suite/output/Notations.out
index 924030ba..215d9b68 100644
--- a/test-suite/output/Notations.out
+++ b/test-suite/output/Notations.out
@@ -46,6 +46,32 @@ fun x : nat => ifn x is succ n then n else 0
: bool
-4
: Z
+The command has indeed failed with message:
+=> Error: x should not be bound in a recursive pattern of the right-hand side.
+The command has indeed failed with message:
+=> Error: in the right-hand side, y and z should appear in
+ term position as part of a recursive pattern.
+The command has indeed failed with message:
+=> Error: The reference w was not found in the current environment.
+The command has indeed failed with message:
+=> Error: x is unbound in the right-hand side.
+The command has indeed failed with message:
+=> Error: in the right-hand side, y and z should appear in
+ term position as part of a recursive pattern.
+The command has indeed failed with message:
+=> Error: z is expected to occur in binding position in the right-hand side.
+The command has indeed failed with message:
+=> Error: as y is a non-closed binder, no such "," is allowed to occur.
+The command has indeed failed with message:
+=> Error: Cannot find where the recursive pattern starts.
+The command has indeed failed with message:
+=> Error: Cannot find where the recursive pattern starts.
+The command has indeed failed with message:
+=> Error: Cannot find where the recursive pattern starts.
+The command has indeed failed with message:
+=> Error: Cannot find where the recursive pattern starts.
+The command has indeed failed with message:
+=> Error: Both ends of the recursive pattern are the same.
SUM (nat * nat) nat
: Set
FST (0; 1)
@@ -59,6 +85,8 @@ Defining 'I' as keyword
: Prop
[|1, 2, 3; 4, 5, 6|]
: Z * Z * Z * (Z * Z * Z)
+[|0 * (1, 2, 3); (4, 5, 6) * false|]
+ : Z * Z * (Z * Z) * (Z * Z) * (Z * bool * (Z * bool) * (Z * bool))
fun f : Z -> Z -> Z -> Z => {|f; 0; 1; 2|}:Z
: (Z -> Z -> Z -> Z) -> Z
plus
diff --git a/test-suite/output/Notations.v b/test-suite/output/Notations.v
index f041b9b7..b8f8f48f 100644
--- a/test-suite/output/Notations.v
+++ b/test-suite/output/Notations.v
@@ -121,6 +121,39 @@ Notation "- 4" := (-2 + -2).
Check -4.
(**********************************************************************)
+(* Check ill-formed recursive notations *)
+
+(* Recursive variables not part of a recursive pattern *)
+Fail Notation "( x , y , .. , z )" := (pair x .. (pair y z) ..).
+
+(* No recursive notation *)
+Fail Notation "( x , y , .. , z )" := (pair x (pair y z)).
+
+(* Left-unbound variable *)
+Fail Notation "( x , y , .. , z )" := (pair x .. (pair y w) ..).
+
+(* Right-unbound variable *)
+Fail Notation "( x , y , .. , z )" := (pair y .. (pair z 0) ..).
+
+(* Not the right kind of recursive pattern *)
+Fail Notation "( x , y , .. , z )" := (ex (fun z => .. (ex (fun y => x)) ..)).
+Fail Notation "( x -- y , .. , z )" := (pair y .. (pair z 0) ..)
+ (y closed binder, z closed binder).
+
+(* No separator allowed with open binders *)
+Fail Notation "( x -- y , .. , z )" := (ex (fun z => .. (ex (fun y => x)) ..))
+ (y binder, z binder).
+
+(* Ends of pattern do not match *)
+Fail Notation "( x , y , .. , z )" := (pair y .. (pair (plus z) 0) ..).
+Fail Notation "( x , y , .. , z )" := (pair y .. (plus z 0) ..).
+Fail Notation "( x1 , x2 , y , .. , z )" := (y y .. (x2 z 0) ..).
+Fail Notation "( x1 , x2 , y , .. , z )" := (x1 y .. (x2 z 0) ..).
+
+(* Ends of pattern are the same *)
+Fail Notation "( x , y , .. , z )" := (pair .. (pair (pair y z) x) .. x).
+
+(**********************************************************************)
(* Check preservation of scopes at printing time *)
Notation SUM := sum.
@@ -163,6 +196,12 @@ Notation "[| x , y , .. , z ; a , b , .. , c |]" :=
(pair (pair .. (pair x y) .. z) (pair .. (pair a b) .. c)).
Check [|1,2,3;4,5,6|].
+Notation "[| t * ( x , y , .. , z ) ; ( a , b , .. , c ) * u |]" :=
+ (pair (pair .. (pair (pair t x) (pair t y)) .. (pair t z))
+ (pair .. (pair (pair a u) (pair b u)) .. (pair c u)))
+ (t at level 39).
+Check [|0*(1,2,3);(4,5,6)*false|].
+
(**********************************************************************)
(* Test recursive notations involving applications *)
(* Caveat: does not work for applied constant because constants are *)
diff --git a/test-suite/output/Notations2.out b/test-suite/output/Notations2.out
index 20d20d82..6731d505 100644
--- a/test-suite/output/Notations2.out
+++ b/test-suite/output/Notations2.out
@@ -10,3 +10,18 @@ end
: nat
let '(a, _, _) := (2, 3, 4) in a
: nat
+∃ n p : nat, n + p = 0
+ : Prop
+∀ n p : nat, n + p = 0
+ : Prop
+λ n p : nat, n + p = 0
+ : nat -> nat -> Prop
+λ (A : Type) (n p : A), n = p
+ : ∀ A : Type, A -> A -> Prop
+λ A : Type, ∃ n p : A, n = p
+ : Type -> Prop
+λ A : Type, ∀ n p : A, n = p
+ : Type -> Prop
+Defining 'let'' as keyword
+let' f (x y z : nat) (_ : bool) := x + y + z + 1 in f 0 1 2
+ : bool -> nat
diff --git a/test-suite/output/Notations2.v b/test-suite/output/Notations2.v
index 2e136edf..57d8ebbc 100644
--- a/test-suite/output/Notations2.v
+++ b/test-suite/output/Notations2.v
@@ -24,3 +24,44 @@ Check forall (A: Set) (le: A -> A -> Prop) (x y: A), le x y \/ le y x.
Remove Printing Let prod.
Check match (0,0,0) with (x,y,z) => x+y+z end.
Check let '(a,b,c) := ((2,3),4) in a.
+
+(* Test notations with binders *)
+
+Notation "∃ x .. y , P":=
+ (ex (fun x => .. (ex (fun y => P)) ..)) (x binder, y binder, at level 200).
+
+Check (∃ n p, n+p=0).
+
+Notation "∀ x .. y , P":= (forall x, .. (forall y, P) ..)
+ (x binder, at level 200, right associativity).
+
+Check (∀ n p, n+p=0).
+
+Notation "'λ' x .. y , P":= (fun x, .. (fun y, P) ..)
+ (y binder, at level 200, right associativity).
+
+Check (λ n p, n+p=0).
+
+Generalizable Variable A.
+
+Check `(λ n p : A, n=p).
+Check `(∃ n p : A, n=p).
+Check `(∀ n p : A, n=p).
+
+Notation "'let'' f x .. y := t 'in' u":=
+ (let f := fun x => .. (fun y => t) .. in u)
+ (f ident, x closed binder, y closed binder, at level 200,
+ right associativity).
+
+Check let' f x y z (a:bool) := x+y+z+1 in f 0 1 2.
+
+(* This one is not fully satisfactory because binders in the same type
+ are re-factorized and parentheses are needed even for atomic binder
+
+Notation "'mylet' f [ x ; .. ; y ] := t 'in' u":=
+ (let f := fun x => .. (fun y => t) .. in u)
+ (f ident, x closed binder, y closed binder, at level 200,
+ right associativity).
+
+Check mylet f [x;y;z;(a:bool)] := x+y+z+1 in f 0 1 2.
+*)
diff --git a/test-suite/output/Search.out b/test-suite/output/Search.out
index 99e736dd..154d9cdd 100644
--- a/test-suite/output/Search.out
+++ b/test-suite/output/Search.out
@@ -2,29 +2,11 @@ le_S: forall n m : nat, n <= m -> n <= S m
le_n: forall n : nat, n <= n
false: bool
true: bool
-sumor_beq:
- forall (A : Type) (B : Prop),
- (A -> A -> bool) -> (B -> B -> bool) -> A + {B} -> A + {B} -> bool
-sumbool_beq:
- forall A B : Prop,
- (A -> A -> bool) -> (B -> B -> bool) -> {A} + {B} -> {A} + {B} -> bool
xorb: bool -> bool -> bool
-sum_beq:
- forall A B : Type,
- (A -> A -> bool) -> (B -> B -> bool) -> A + B -> A + B -> bool
-prod_beq:
- forall A B : Type,
- (A -> A -> bool) -> (B -> B -> bool) -> A * B -> A * B -> bool
orb: bool -> bool -> bool
-option_beq: forall A : Type, (A -> A -> bool) -> option A -> option A -> bool
negb: bool -> bool
-nat_beq: nat -> nat -> bool
-list_beq: forall A : Type, (A -> A -> bool) -> list A -> list A -> bool
implb: bool -> bool -> bool
-comparison_beq: comparison -> comparison -> bool
-bool_beq: bool -> bool -> bool
andb: bool -> bool -> bool
-Empty_set_beq: Empty_set -> Empty_set -> bool
pred_Sn: forall n : nat, n = pred (S n)
plus_n_Sm: forall n m : nat, S (n + m) = n + S m
plus_n_O: forall n : nat, n = n + 0
diff --git a/test-suite/output/SearchPattern.out b/test-suite/output/SearchPattern.out
index 1a87f4cc..c87eaadc 100644
--- a/test-suite/output/SearchPattern.out
+++ b/test-suite/output/SearchPattern.out
@@ -1,28 +1,10 @@
false: bool
true: bool
-sumor_beq:
- forall (A : Type) (B : Prop),
- (A -> A -> bool) -> (B -> B -> bool) -> A + {B} -> A + {B} -> bool
-sumbool_beq:
- forall A B : Prop,
- (A -> A -> bool) -> (B -> B -> bool) -> {A} + {B} -> {A} + {B} -> bool
xorb: bool -> bool -> bool
-sum_beq:
- forall A B : Type,
- (A -> A -> bool) -> (B -> B -> bool) -> A + B -> A + B -> bool
-prod_beq:
- forall A B : Type,
- (A -> A -> bool) -> (B -> B -> bool) -> A * B -> A * B -> bool
orb: bool -> bool -> bool
-option_beq: forall A : Type, (A -> A -> bool) -> option A -> option A -> bool
negb: bool -> bool
-nat_beq: nat -> nat -> bool
-list_beq: forall A : Type, (A -> A -> bool) -> list A -> list A -> bool
implb: bool -> bool -> bool
-comparison_beq: comparison -> comparison -> bool
-bool_beq: bool -> bool -> bool
andb: bool -> bool -> bool
-Empty_set_beq: Empty_set -> Empty_set -> bool
S: nat -> nat
O: nat
pred: nat -> nat
diff --git a/test-suite/success/Field.v b/test-suite/success/Field.v
index b5fba17b..cb90e742 100644
--- a/test-suite/success/Field.v
+++ b/test-suite/success/Field.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: Field.v 13323 2010-07-24 15:57:30Z herbelin $ *)
(**** Tests of Field with real numbers ****)
diff --git a/test-suite/success/Nsatz.v b/test-suite/success/Nsatz.v
index fde9f470..518d22e9 100644
--- a/test-suite/success/Nsatz.v
+++ b/test-suite/success/Nsatz.v
@@ -1,4 +1,74 @@
-Require Import NsatzR ZArith Reals List Ring_polynom.
+Require Import Nsatz ZArith Reals List Ring_polynom.
+
+(* Example with a generic domain *)
+
+Variable A: Type.
+Variable Ad: Domain A.
+
+Definition Ari : Ring A:= (@domain_ring A Ad).
+Existing Instance Ari.
+
+Existing Instance ring_setoid.
+Existing Instance ring_plus_comp.
+Existing Instance ring_mult_comp.
+Existing Instance ring_sub_comp.
+Existing Instance ring_opp_comp.
+
+Add Ring Ar: (@ring_ring A (@domain_ring A Ad)).
+
+Instance zero_ring2 : Zero A := {zero := ring0}.
+Instance one_ring2 : One A := {one := ring1}.
+Instance addition_ring2 : Addition A := {addition x y := ring_plus x y}.
+Instance multiplication_ring2 : Multiplication A := {multiplication x y := ring_mult x y}.
+Instance subtraction_ring2 : Subtraction A := {subtraction x y := ring_sub x y}.
+Instance opposite_ring2 : Opposite A := {opposite x := ring_opp x}.
+
+Infix "==" := ring_eq (at level 70, no associativity).
+
+Ltac nsatzA := simpl; unfold Ari; nsatz_domain.
+
+Goal forall x y:A, x == y -> x+0 == y*1+0.
+nsatzA.
+Qed.
+
+Lemma example3 : forall x y z,
+ x+y+z==0 ->
+ x*y+x*z+y*z==0->
+ x*y*z==0 -> x*x*x==0.
+Proof.
+Time nsatzA.
+Admitted.
+
+Lemma example4 : forall x y z u,
+ x+y+z+u==0 ->
+ x*y+x*z+x*u+y*z+y*u+z*u==0->
+ x*y*z+x*y*u+x*z*u+y*z*u==0->
+ x*y*z*u==0 -> x*x*x*x==0.
+Proof.
+Time nsatzA.
+Qed.
+
+Lemma example5 : forall x y z u v,
+ x+y+z+u+v==0 ->
+ x*y+x*z+x*u+x*v+y*z+y*u+y*v+z*u+z*v+u*v==0->
+ x*y*z+x*y*u+x*y*v+x*z*u+x*z*v+x*u*v+y*z*u+y*z*v+y*u*v+z*u*v==0->
+ x*y*z*u+y*z*u*v+z*u*v*x+u*v*x*y+v*x*y*z==0 ->
+ x*y*z*u*v==0 -> x*x*x*x*x ==0.
+Proof.
+Time nsatzA.
+Qed.
+
+Goal forall x y:Z, x = y -> (x+0)%Z = (y*1+0)%Z.
+nsatz.
+Qed.
+
+Goal forall x y:R, x = y -> (x+0)%R = (y*1+0)%R.
+nsatz.
+Qed.
+
+Goal forall a b c x:R, a = b -> b = c -> (a*a)%R = (c*c)%R.
+nsatz.
+Qed.
Section Examples.
@@ -16,12 +86,12 @@ Lemma example1 : forall x y,
x*y=0 ->
x^2=0.
Proof.
- nsatzR.
+ nsatz.
Qed.
Lemma example2 : forall x, x^2=0 -> x=0.
Proof.
- nsatzR.
+ nsatz.
Qed.
(*
@@ -29,12 +99,12 @@ Notation X := (PEX Z 3).
Notation Y := (PEX Z 2).
Notation Z_ := (PEX Z 1).
*)
-Lemma example3 : forall x y z,
+Lemma example3b : forall x y z,
x+y+z=0 ->
x*y+x*z+y*z=0->
x*y*z=0 -> x^3=0.
Proof.
-Time nsatzR.
+Time nsatz.
Qed.
(*
@@ -43,13 +113,13 @@ Notation Y := (PEX Z 3).
Notation Z_ := (PEX Z 2).
Notation U := (PEX Z 1).
*)
-Lemma example4 : forall x y z u,
+Lemma example4b : forall x y z u,
x+y+z+u=0 ->
x*y+x*z+x*u+y*z+y*u+z*u=0->
x*y*z+x*y*u+x*z*u+y*z*u=0->
x*y*z*u=0 -> x^4=0.
Proof.
-Time nsatzR.
+Time nsatz.
Qed.
(*
@@ -64,20 +134,20 @@ Notation "x :: y" := (List.app x y)
(at level 60, right associativity, format "x :: y").
*)
-Lemma example5 : forall x y z u v,
+Lemma example5b : forall x y z u v,
x+y+z+u+v=0 ->
x*y+x*z+x*u+x*v+y*z+y*u+y*v+z*u+z*v+u*v=0->
x*y*z+x*y*u+x*y*v+x*z*u+x*z*v+x*u*v+y*z*u+y*z*v+y*u*v+z*u*v=0->
x*y*z*u+y*z*u*v+z*u*v*x+u*v*x*y+v*x*y*z=0 ->
x*y*z*u*v=0 -> x^5=0.
Proof.
-Time nsatzR.
+Time nsatz.
Qed.
End Examples.
Section Geometry.
-Require Export Reals NsatzR.
+
Open Scope R_scope.
Record point:Type:={
@@ -169,6 +239,7 @@ Ltac geo_begin:=
(* Examples *)
+
Lemma Thales: forall O A B C D:point,
collinear O A C -> collinear O B D ->
parallel A B C D ->
@@ -176,26 +247,7 @@ Lemma Thales: forall O A B C D:point,
/\ distance2 O B * distance2 C D = distance2 O D * distance2 A B)
\/ collinear O A B.
repeat geo_begin.
-(*
Time nsatz.
-*)
-Time nsatz without sugar.
-(*
-Time nsatz with lexico sugar.
-Time nsatz with lexico.
-*)
-(*
-Time nsatzRpv 1%N 1%Z (@nil R) (@nil R). (* revlex, sugar, no div *)
-(*Finished transaction in 1. secs (0.479927u,0.s)*)
-Time nsatzRpv 1%N 0%Z (@nil R) (@nil R). (* revlex, no sugar, no div *)
-(*Finished transaction in 0. secs (0.543917u,0.s)*)
-Time nsatzRpv 1%N 2%Z (@nil R) (@nil R). (* lex, no sugar, no div *)
-(*Finished transaction in 0. secs (0.586911u,0.s)*)
-Time nsatzRpv 1%N 3%Z (@nil R) (@nil R). (* lex, sugar, no div *)
-(*Finished transaction in 0. secs (0.481927u,0.s)*)
-Time nsatzRpv 1%N 5%Z (@nil R) (@nil R). (* revlex, sugar, div *)
-(*Finished transaction in 1. secs (0.601909u,0.s)*)
-*)
Time nsatz.
Qed.
@@ -209,8 +261,26 @@ Lemma hauteurs:forall A B C A1 B1 C1 H:point,
\/ collinear A B C.
geo_begin.
-Time nsatz.
-(*Finished transaction in 3. secs (2.43263u,0.010998s)*)
+
+(* Time nsatzRpv 2%N 1%Z (@nil R) (@nil R).*)
+(*Finished transaction in 3. secs (2.363641u,0.s)*)
+(*Time nsatz_domainR. trop long! *)
+Time
+ let lv := constr:(Y A1
+ :: X A1
+ :: Y B1
+ :: X B1
+ :: Y A0
+ :: Y B
+ :: X B
+ :: X A0
+ :: X H
+ :: Y C
+ :: Y C1 :: Y H :: X C1 :: X C :: (@Datatypes.nil R)) in
+ nsatz_domainpv ltac:pretacR 2%N 1%Z (@Datatypes.nil R) lv ltac:simplR Rdi;
+ discrR.
+(* Finished transaction in 6. secs (5.579152u,0.001s) *)
Qed.
End Geometry.
+
diff --git a/test-suite/success/Nsatz_domain.v b/test-suite/success/Nsatz_domain.v
deleted file mode 100644
index 8a30b47f..00000000
--- a/test-suite/success/Nsatz_domain.v
+++ /dev/null
@@ -1,274 +0,0 @@
-Require Import Nsatz_domain ZArith Reals List Ring_polynom.
-
-Variable A: Type.
-Variable Ad: Domain A.
-
-Add Ring Ar1: (@ring_ring A (@domain_ring _ Ad)).
-
-Instance Ari : Ring A := {
- ring0 := @ring0 A (@domain_ring _ Ad);
- ring1 := @ring1 A (@domain_ring _ Ad);
- ring_plus := @ring_plus A (@domain_ring _ Ad);
- ring_mult := @ring_mult A (@domain_ring _ Ad);
- ring_sub := @ring_sub A (@domain_ring _ Ad);
- ring_opp := @ring_opp A (@domain_ring _ Ad);
- ring_ring := @ring_ring A (@domain_ring _ Ad)}.
-
-Instance Adi : Domain A := {
- domain_ring := Ari;
- domain_axiom_product := @domain_axiom_product A Ad;
- domain_axiom_one_zero := @domain_axiom_one_zero A Ad}.
-
-Instance zero_ring2 : Zero A := {zero := ring0}.
-Instance one_ring2 : One A := {one := ring1}.
-Instance addition_ring2 : Addition A := {addition x y := ring_plus x y}.
-Instance multiplication_ring2 : Multiplication A := {multiplication x y := ring_mult x y}.
-Instance subtraction_ring2 : Subtraction A := {subtraction x y := ring_sub x y}.
-Instance opposite_ring2 : Opposite A := {opposite x := ring_opp x}.
-
-Goal forall x y:A, x = y -> x+0 = y*1+0.
-nsatz_domain.
-Qed.
-
-Goal forall a b c:A, a = b -> b = c -> c = a.
-nsatz_domain.
-Qed.
-
-Goal forall a b c:A, a = b -> b = c -> a = c.
-nsatz_domain.
-Qed.
-
-Goal forall a b c x:A, a = b -> b = c -> a*a = c*c.
-nsatz_domain.
-Qed.
-
-Goal forall x y:Z, x = y -> (x+0)%Z = (y*1+0)%Z.
-nsatz_domainZ.
-Qed.
-
-Goal forall x y:R, x = y -> (x+0)%R = (y*1+0)%R.
-nsatz_domainR.
-Qed.
-
-Goal forall a b c x:R, a = b -> b = c -> (a*a)%R = (c*c)%R.
-nsatz_domainR.
-Qed.
-
-Section Examples.
-
-Delimit Scope PE_scope with PE.
-Infix "+" := PEadd : PE_scope.
-Infix "*" := PEmul : PE_scope.
-Infix "-" := PEsub : PE_scope.
-Infix "^" := PEpow : PE_scope.
-Notation "[ n ]" := (@PEc Z n) (at level 0).
-
-Open Scope R_scope.
-
-Lemma example1 : forall x y,
- x+y=0 ->
- x*y=0 ->
- x^2=0.
-Proof.
- nsatz_domainR.
-Qed.
-
-Lemma example2 : forall x, x^2=0 -> x=0.
-Proof.
- nsatz_domainR.
-Qed.
-
-(*
-Notation X := (PEX Z 3).
-Notation Y := (PEX Z 2).
-Notation Z_ := (PEX Z 1).
-*)
-Lemma example3 : forall x y z,
- x+y+z=0 ->
- x*y+x*z+y*z=0->
- x*y*z=0 -> x^3=0.
-Proof.
-Time nsatz_domainR.
-simpl.
-discrR.
-Qed.
-
-(*
-Notation X := (PEX Z 4).
-Notation Y := (PEX Z 3).
-Notation Z_ := (PEX Z 2).
-Notation U := (PEX Z 1).
-*)
-Lemma example4 : forall x y z u,
- x+y+z+u=0 ->
- x*y+x*z+x*u+y*z+y*u+z*u=0->
- x*y*z+x*y*u+x*z*u+y*z*u=0->
- x*y*z*u=0 -> x^4=0.
-Proof.
-Time nsatz_domainR.
-Qed.
-
-(*
-Notation x_ := (PEX Z 5).
-Notation y_ := (PEX Z 4).
-Notation z_ := (PEX Z 3).
-Notation u_ := (PEX Z 2).
-Notation v_ := (PEX Z 1).
-Notation "x :: y" := (List.cons x y)
-(at level 60, right associativity, format "'[hv' x :: '/' y ']'").
-Notation "x :: y" := (List.app x y)
-(at level 60, right associativity, format "x :: y").
-*)
-
-Lemma example5 : forall x y z u v,
- x+y+z+u+v=0 ->
- x*y+x*z+x*u+x*v+y*z+y*u+y*v+z*u+z*v+u*v=0->
- x*y*z+x*y*u+x*y*v+x*z*u+x*z*v+x*u*v+y*z*u+y*z*v+y*u*v+z*u*v=0->
- x*y*z*u+y*z*u*v+z*u*v*x+u*v*x*y+v*x*y*z=0 ->
- x*y*z*u*v=0 -> x^5=0.
-Proof.
-Time nsatz_domainR.
-Qed.
-
-End Examples.
-
-Section Geometry.
-
-Open Scope R_scope.
-
-Record point:Type:={
- X:R;
- Y:R}.
-
-Definition collinear(A B C:point):=
- (X A - X B)*(Y C - Y B)-(Y A - Y B)*(X C - X B)=0.
-
-Definition parallel (A B C D:point):=
- ((X A)-(X B))*((Y C)-(Y D))=((Y A)-(Y B))*((X C)-(X D)).
-
-Definition notparallel (A B C D:point)(x:R):=
- x*(((X A)-(X B))*((Y C)-(Y D))-((Y A)-(Y B))*((X C)-(X D)))=1.
-
-Definition orthogonal (A B C D:point):=
- ((X A)-(X B))*((X C)-(X D))+((Y A)-(Y B))*((Y C)-(Y D))=0.
-
-Definition equal2(A B:point):=
- (X A)=(X B) /\ (Y A)=(Y B).
-
-Definition equal3(A B:point):=
- ((X A)-(X B))^2+((Y A)-(Y B))^2 = 0.
-
-Definition nequal2(A B:point):=
- (X A)<>(X B) \/ (Y A)<>(Y B).
-
-Definition nequal3(A B:point):=
- not (((X A)-(X B))^2+((Y A)-(Y B))^2 = 0).
-
-Definition middle(A B I:point):=
- 2*(X I)=(X A)+(X B) /\ 2*(Y I)=(Y A)+(Y B).
-
-Definition distance2(A B:point):=
- (X B - X A)^2 + (Y B - Y A)^2.
-
-(* AB = CD *)
-Definition samedistance2(A B C D:point):=
- (X B - X A)^2 + (Y B - Y A)^2 = (X D - X C)^2 + (Y D - Y C)^2.
-Definition determinant(A O B:point):=
- (X A - X O)*(Y B - Y O) - (Y A - Y O)*(X B - X O).
-Definition scalarproduct(A O B:point):=
- (X A - X O)*(X B - X O) + (Y A - Y O)*(Y B - Y O).
-Definition norm2(A O B:point):=
- ((X A - X O)^2+(Y A - Y O)^2)*((X B - X O)^2+(Y B - Y O)^2).
-
-
-Lemma a1:forall A B C:Prop, ((A\/B)/\(A\/C)) -> (A\/(B/\C)).
-intuition.
-Qed.
-
-Lemma a2:forall A B C:Prop, ((A\/C)/\(B\/C)) -> ((A/\B)\/C).
-intuition.
-Qed.
-
-Lemma a3:forall a b c d:R, (a-b)*(c-d)=0 -> (a=b \/ c=d).
-intros.
-assert ( (a-b = 0) \/ (c-d = 0)).
-apply Rmult_integral.
-trivial.
-destruct H0.
-left; nsatz_domainR.
-right; nsatz_domainR.
-Qed.
-
-Ltac geo_unfold :=
- unfold collinear; unfold parallel; unfold notparallel; unfold orthogonal;
- unfold equal2; unfold equal3; unfold nequal2; unfold nequal3;
- unfold middle; unfold samedistance2;
- unfold determinant; unfold scalarproduct; unfold norm2; unfold distance2.
-
-Ltac geo_end :=
- repeat (
- repeat (match goal with h:_/\_ |- _ => decompose [and] h; clear h end);
- repeat (apply a1 || apply a2 || apply a3);
- repeat split).
-
-Ltac geo_rewrite_hyps:=
- repeat (match goal with
- | h:X _ = _ |- _ => rewrite h in *; clear h
- | h:Y _ = _ |- _ => rewrite h in *; clear h
- end).
-
-Ltac geo_begin:=
- geo_unfold;
- intros;
- geo_rewrite_hyps;
- geo_end.
-
-(* Examples *)
-
-Lemma Thales: forall O A B C D:point,
- collinear O A C -> collinear O B D ->
- parallel A B C D ->
- (distance2 O B * distance2 O C = distance2 O D * distance2 O A
- /\ distance2 O B * distance2 C D = distance2 O D * distance2 A B)
- \/ collinear O A B.
-repeat geo_begin.
-
-Time nsatz_domainR.
-simpl;discrR.
-Time nsatz_domainR.
-simpl;discrR.
-Qed.
-
-Require Import NsatzR.
-
-Lemma hauteurs:forall A B C A1 B1 C1 H:point,
- collinear B C A1 -> orthogonal A A1 B C ->
- collinear A C B1 -> orthogonal B B1 A C ->
- collinear A B C1 -> orthogonal C C1 A B ->
- collinear A A1 H -> collinear B B1 H ->
-
- collinear C C1 H
- \/ collinear A B C.
-
-geo_begin.
-(* Time nsatzRpv 2%N 1%Z (@nil R) (@nil R).*)
-(*Finished transaction in 3. secs (2.363641u,0.s)*)
-(*Time nsatz_domainR. trop long! *)
-(* en fait nsatz_domain ne tient pas encore compte de la liste des variables! ;-) *)
-Time
- let lv := constr:(Y A1
- :: X A1
- :: Y B1
- :: X B1
- :: Y A0
- :: Y B
- :: X B
- :: X A0
- :: X H
- :: Y C
- :: Y C1 :: Y H :: X C1 :: X C ::nil) in
- nsatz_domainpv 2%N 1%Z (@List.nil R) lv ltac:simplR Rdi.
-(* Finished transaction in 6. secs (5.579152u,0.001s) *)
-Qed.
-
-End Geometry.
diff --git a/test-suite/success/Tauto.v b/test-suite/success/Tauto.v
index b9326c64..6322ed2b 100644
--- a/test-suite/success/Tauto.v
+++ b/test-suite/success/Tauto.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: Tauto.v 13323 2010-07-24 15:57:30Z herbelin $ *)
(**** Tactics Tauto and Intuition ****)
diff --git a/test-suite/success/Typeclasses.v b/test-suite/success/Typeclasses.v
index 55351a47..30a2a742 100644
--- a/test-suite/success/Typeclasses.v
+++ b/test-suite/success/Typeclasses.v
@@ -8,9 +8,9 @@ Reserved Notation "x >>= y" (at level 65, left associativity).
Record Monad {m : Type -> Type} := {
- unit : Π {α}, α -> m α where "'return' t" := (unit t) ;
- bind : Π {α β}, m α -> (α -> m β) -> m β where "x >>= y" := (bind x y) ;
- bind_unit_left : Π {α β} (a : α) (f : α -> m β), return a >>= f = f a }.
+ unit : forall {α}, α -> m α where "'return' t" := (unit t) ;
+ bind : forall {α β}, m α -> (α -> m β) -> m β where "x >>= y" := (bind x y) ;
+ bind_unit_left : forall {α β} (a : α) (f : α -> m β), return a >>= f = f a }.
Print Visibility.
Print unit.
diff --git a/theories/Arith/Arith.v b/theories/Arith/Arith.v
index 3cf607d9..0f5ef9d0 100644
--- a/theories/Arith/Arith.v
+++ b/theories/Arith/Arith.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Arith.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export Arith_base.
Require Export ArithRing.
diff --git a/theories/Arith/Arith_base.v b/theories/Arith/Arith_base.v
index e975f273..c5135f63 100644
--- a/theories/Arith/Arith_base.v
+++ b/theories/Arith/Arith_base.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Arith_base.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export Le.
Require Export Lt.
diff --git a/theories/Arith/Between.v b/theories/Arith/Between.v
index 8ab49f25..2ccf802d 100644
--- a/theories/Arith/Between.v
+++ b/theories/Arith/Between.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Between.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Le.
Require Import Lt.
diff --git a/theories/Arith/Bool_nat.v b/theories/Arith/Bool_nat.v
index 5904e989..9ace38b1 100644
--- a/theories/Arith/Bool_nat.v
+++ b/theories/Arith/Bool_nat.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: Bool_nat.v 13323 2010-07-24 15:57:30Z herbelin $ *)
Require Export Compare_dec.
Require Export Peano_dec.
diff --git a/theories/Arith/Compare.v b/theories/Arith/Compare.v
index cdba76eb..2775d132 100644
--- a/theories/Arith/Compare.v
+++ b/theories/Arith/Compare.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Compare.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** Equality is decidable on [nat] *)
diff --git a/theories/Arith/Compare_dec.v b/theories/Arith/Compare_dec.v
index 5d20261c..0811fea7 100644
--- a/theories/Arith/Compare_dec.v
+++ b/theories/Arith/Compare_dec.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Compare_dec.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Le.
Require Import Lt.
diff --git a/theories/Arith/Div2.v b/theories/Arith/Div2.v
index 0a3b7dcc..adbca442 100644
--- a/theories/Arith/Div2.v
+++ b/theories/Arith/Div2.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Div2.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Lt.
Require Import Plus.
diff --git a/theories/Arith/EqNat.v b/theories/Arith/EqNat.v
index edf31c62..e49e5d14 100644
--- a/theories/Arith/EqNat.v
+++ b/theories/Arith/EqNat.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: EqNat.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** Equality on natural numbers *)
diff --git a/theories/Arith/Euclid.v b/theories/Arith/Euclid.v
index 78185715..54f4f013 100644
--- a/theories/Arith/Euclid.v
+++ b/theories/Arith/Euclid.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Euclid.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Mult.
Require Import Compare_dec.
diff --git a/theories/Arith/Even.v b/theories/Arith/Even.v
index 266d51fc..527ad748 100644
--- a/theories/Arith/Even.v
+++ b/theories/Arith/Even.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Even.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** Here we define the predicates [even] and [odd] by mutual induction
and we prove the decidability and the exclusion of those predicates.
diff --git a/theories/Arith/Factorial.v b/theories/Arith/Factorial.v
index aa8bb7bd..5385bf61 100644
--- a/theories/Arith/Factorial.v
+++ b/theories/Arith/Factorial.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Factorial.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Plus.
Require Import Mult.
diff --git a/theories/Arith/Gt.v b/theories/Arith/Gt.v
index bcf38c02..eda051df 100644
--- a/theories/Arith/Gt.v
+++ b/theories/Arith/Gt.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Gt.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** Theorems about [gt] in [nat]. [gt] is defined in [Init/Peano.v] as:
<<
diff --git a/theories/Arith/Le.v b/theories/Arith/Le.v
index a8b86ab7..f24667d0 100644
--- a/theories/Arith/Le.v
+++ b/theories/Arith/Le.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Le.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** Order on natural numbers. [le] is defined in [Init/Peano.v] as:
<<
diff --git a/theories/Arith/Lt.v b/theories/Arith/Lt.v
index 68ac6e73..0032741e 100644
--- a/theories/Arith/Lt.v
+++ b/theories/Arith/Lt.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Lt.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** Theorems about [lt] in nat. [lt] is defined in library [Init/Peano.v] as:
<<
diff --git a/theories/Arith/Max.v b/theories/Arith/Max.v
index 3a566321..b4c4d7ad 100644
--- a/theories/Arith/Max.v
+++ b/theories/Arith/Max.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Max.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** THIS FILE IS DEPRECATED. Use [MinMax] instead. *)
diff --git a/theories/Arith/Min.v b/theories/Arith/Min.v
index f646c80a..81142249 100644
--- a/theories/Arith/Min.v
+++ b/theories/Arith/Min.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Min.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** THIS FILE IS DEPRECATED. Use [MinMax] instead. *)
diff --git a/theories/Arith/Minus.v b/theories/Arith/Minus.v
index 74d2c9a8..39062348 100644
--- a/theories/Arith/Minus.v
+++ b/theories/Arith/Minus.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Minus.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** [minus] (difference between two natural numbers) is defined in [Init/Peano.v] as:
<<
diff --git a/theories/Arith/Mult.v b/theories/Arith/Mult.v
index bfefb967..3ba98472 100644
--- a/theories/Arith/Mult.v
+++ b/theories/Arith/Mult.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Mult.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export Plus.
Require Export Minus.
diff --git a/theories/Arith/Peano_dec.v b/theories/Arith/Peano_dec.v
index 5eb86168..908f99f0 100644
--- a/theories/Arith/Peano_dec.v
+++ b/theories/Arith/Peano_dec.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Peano_dec.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Decidable.
diff --git a/theories/Arith/Plus.v b/theories/Arith/Plus.v
index 2ea65696..3c5f28b6 100644
--- a/theories/Arith/Plus.v
+++ b/theories/Arith/Plus.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Plus.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** Properties of addition. [add] is defined in [Init/Peano.v] as:
<<
diff --git a/theories/Arith/Wf_nat.v b/theories/Arith/Wf_nat.v
index a42c38eb..07ab1c3e 100644
--- a/theories/Arith/Wf_nat.v
+++ b/theories/Arith/Wf_nat.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Wf_nat.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** Well-founded relations and natural numbers *)
diff --git a/theories/Bool/Bool.v b/theories/Bool/Bool.v
index 43ffde86..8f3c29c6 100644
--- a/theories/Bool/Bool.v
+++ b/theories/Bool/Bool.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Bool.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** The type [bool] is defined in the prelude as
[Inductive bool : Set := true : bool | false : bool] *)
diff --git a/theories/Bool/BoolEq.v b/theories/Bool/BoolEq.v
index 2c3952e7..9a006e80 100644
--- a/theories/Bool/BoolEq.v
+++ b/theories/Bool/BoolEq.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: BoolEq.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(* Cuihtlauac Alvarado - octobre 2000 *)
(** Properties of a boolean equality *)
diff --git a/theories/Bool/Bvector.v b/theories/Bool/Bvector.v
index 5190a246..3f3acccf 100644
--- a/theories/Bool/Bvector.v
+++ b/theories/Bool/Bvector.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Bvector.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** Bit vectors. Contribution by Jean Duprat (ENS Lyon). *)
diff --git a/theories/Bool/DecBool.v b/theories/Bool/DecBool.v
index 746507c4..f3123a7a 100644
--- a/theories/Bool/DecBool.v
+++ b/theories/Bool/DecBool.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: DecBool.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Set Implicit Arguments.
diff --git a/theories/Bool/IfProp.v b/theories/Bool/IfProp.v
index 2d0f15a1..dcab1446 100644
--- a/theories/Bool/IfProp.v
+++ b/theories/Bool/IfProp.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: IfProp.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Bool.
diff --git a/theories/Bool/Sumbool.v b/theories/Bool/Sumbool.v
index 7945fbae..543ff67d 100644
--- a/theories/Bool/Sumbool.v
+++ b/theories/Bool/Sumbool.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Sumbool.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** Here are collected some results about the type sumbool (see INIT/Specif.v)
[sumbool A B], which is written [{A}+{B}], is the informative
diff --git a/theories/Bool/Zerob.v b/theories/Bool/Zerob.v
index 1c6b84ce..a89138d1 100644
--- a/theories/Bool/Zerob.v
+++ b/theories/Bool/Zerob.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Zerob.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Arith.
Require Import Bool.
diff --git a/theories/Classes/EquivDec.v b/theories/Classes/EquivDec.v
index 5748a5f3..cc6e8936 100644
--- a/theories/Classes/EquivDec.v
+++ b/theories/Classes/EquivDec.v
@@ -12,7 +12,7 @@
Institution: LRI, CNRS UMR 8623 - University Paris Sud
*)
-(* $Id$ *)
+(* $Id: EquivDec.v 13323 2010-07-24 15:57:30Z herbelin $ *)
(** Export notations. *)
diff --git a/theories/Classes/Equivalence.v b/theories/Classes/Equivalence.v
index 65231ce1..3d8c3434 100644
--- a/theories/Classes/Equivalence.v
+++ b/theories/Classes/Equivalence.v
@@ -12,7 +12,7 @@
Institution: LRI, CNRS UMR 8623 - University Paris Sud
*)
-(* $Id$ *)
+(* $Id: Equivalence.v 13323 2010-07-24 15:57:30Z herbelin $ *)
Require Import Coq.Program.Basics.
Require Import Coq.Program.Tactics.
diff --git a/theories/Classes/Init.v b/theories/Classes/Init.v
index 6e576c96..8cc1216b 100644
--- a/theories/Classes/Init.v
+++ b/theories/Classes/Init.v
@@ -13,7 +13,7 @@
Institution: LRI, CNRS UMR 8623 - University Paris Sud
*)
-(* $Id$ *)
+(* $Id: Init.v 13323 2010-07-24 15:57:30Z herbelin $ *)
(** Hints for the proof search: these combinators should be considered rigid. *)
diff --git a/theories/Classes/Morphisms.v b/theories/Classes/Morphisms.v
index 9895c5a4..d31829e1 100644
--- a/theories/Classes/Morphisms.v
+++ b/theories/Classes/Morphisms.v
@@ -13,7 +13,7 @@
Institution: LRI, CNRS UMR 8623 - University Paris Sud
*)
-(* $Id$ *)
+(* $Id: Morphisms.v 13359 2010-07-30 08:46:55Z herbelin $ *)
Require Import Coq.Program.Basics.
Require Import Coq.Program.Tactics.
@@ -23,6 +23,12 @@ Require Export Coq.Classes.RelationClasses.
Generalizable All Variables.
Local Obligation Tactic := simpl_relation.
+Local Notation "'λ' x .. y , t" := (fun x => .. (fun y => t) ..)
+ (at level 200, x binder, y binder, right associativity).
+
+Local Notation "'Π' x .. y , P" := (forall x, .. (forall y, P) ..)
+ (at level 200, x binder, y binder, right associativity) : type_scope.
+
(** * Morphisms.
We now turn to the definition of [Proper] and declare standard instances.
diff --git a/theories/Classes/RelationClasses.v b/theories/Classes/RelationClasses.v
index 89c23b3e..1aad3cec 100644
--- a/theories/Classes/RelationClasses.v
+++ b/theories/Classes/RelationClasses.v
@@ -15,7 +15,7 @@
Institution: LRI, CNRS UMR 8623 - University Paris Sud
*)
-(* $Id$ *)
+(* $Id: RelationClasses.v 13344 2010-07-28 15:04:36Z msozeau $ *)
Require Export Coq.Classes.Init.
Require Import Coq.Program.Basics.
@@ -76,7 +76,7 @@ Hint Extern 4 => solve_relation : relations.
Generalizable Variables A B C D R S T U l eqA eqB eqC eqD.
-Program Lemma flip_Reflexive `(Reflexive A R) : Reflexive (flip R).
+Lemma flip_Reflexive `{Reflexive A R} : Reflexive (flip R).
Proof. tauto. Qed.
Hint Extern 3 (Reflexive (flip _)) => apply flip_Reflexive : typeclass_instances.
diff --git a/theories/Classes/SetoidClass.v b/theories/Classes/SetoidClass.v
index ff91bd91..b20f9d88 100644
--- a/theories/Classes/SetoidClass.v
+++ b/theories/Classes/SetoidClass.v
@@ -12,7 +12,7 @@
Institution: LRI, CNRS UMR 8623 - University Paris Sud
*)
-(* $Id$ *)
+(* $Id: SetoidClass.v 13323 2010-07-24 15:57:30Z herbelin $ *)
Set Implicit Arguments.
Unset Strict Implicit.
diff --git a/theories/Classes/SetoidDec.v b/theories/Classes/SetoidDec.v
index 6e92a5de..fe775abb 100644
--- a/theories/Classes/SetoidDec.v
+++ b/theories/Classes/SetoidDec.v
@@ -13,13 +13,16 @@
Institution: LRI, CNRS UMR 8623 - University Paris Sud
*)
-(* $Id$ *)
+(* $Id: SetoidDec.v 13359 2010-07-30 08:46:55Z herbelin $ *)
Set Implicit Arguments.
Unset Strict Implicit.
Generalizable Variables A B .
+Local Notation "'λ' x .. y , t" := (fun x => .. (fun y => t) ..)
+ (at level 200, x binder, y binder, right associativity).
+
(** Export notations. *)
Require Export Coq.Classes.SetoidClass.
diff --git a/theories/Classes/SetoidTactics.v b/theories/Classes/SetoidTactics.v
index fd3b9f3b..0d43de5a 100644
--- a/theories/Classes/SetoidTactics.v
+++ b/theories/Classes/SetoidTactics.v
@@ -12,7 +12,7 @@
Institution: LRI, CNRS UMR 8623 - University Paris Sud
*)
-(* $Id$ *)
+(* $Id: SetoidTactics.v 13323 2010-07-24 15:57:30Z herbelin $ *)
Require Import Coq.Classes.Morphisms Coq.Classes.Morphisms_Prop.
Require Export Coq.Classes.RelationClasses Coq.Relations.Relation_Definitions.
diff --git a/theories/FSets/FMapAVL.v b/theories/FSets/FMapAVL.v
index 8158324e..7b64ded7 100644
--- a/theories/FSets/FMapAVL.v
+++ b/theories/FSets/FMapAVL.v
@@ -8,7 +8,7 @@
(* Finite map library. *)
-(* $Id$ *)
+(* $Id: FMapAVL.v 13090 2010-06-08 13:56:14Z herbelin $ *)
(** * FMapAVL *)
diff --git a/theories/FSets/FMapFacts.v b/theories/FSets/FMapFacts.v
index 4c59971c..8944f7ce 100644
--- a/theories/FSets/FMapFacts.v
+++ b/theories/FSets/FMapFacts.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
-(* $Id$ *)
+(* $Id: FMapFacts.v 12459 2009-11-02 18:51:43Z letouzey $ *)
(** * Finite maps library *)
diff --git a/theories/FSets/FMapFullAVL.v b/theories/FSets/FMapFullAVL.v
index e4f8b4df..2b9e7077 100644
--- a/theories/FSets/FMapFullAVL.v
+++ b/theories/FSets/FMapFullAVL.v
@@ -8,7 +8,7 @@
(* Finite map library. *)
-(* $Id$ *)
+(* $Id: FMapFullAVL.v 13090 2010-06-08 13:56:14Z herbelin $ *)
(** * FMapFullAVL
diff --git a/theories/FSets/FMapInterface.v b/theories/FSets/FMapInterface.v
index e60cca9d..bbfecfb1 100644
--- a/theories/FSets/FMapInterface.v
+++ b/theories/FSets/FMapInterface.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
-(* $Id$ *)
+(* $Id: FMapInterface.v 12640 2010-01-07 15:32:49Z letouzey $ *)
(** * Finite map library *)
diff --git a/theories/FSets/FMapList.v b/theories/FSets/FMapList.v
index 56fc35d8..4b7f183c 100644
--- a/theories/FSets/FMapList.v
+++ b/theories/FSets/FMapList.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
-(* $Id$ *)
+(* $Id: FMapList.v 12458 2009-11-02 18:50:33Z letouzey $ *)
(** * Finite map library *)
diff --git a/theories/FSets/FMapPositive.v b/theories/FSets/FMapPositive.v
index 7c5a4fa1..30bce2db 100644
--- a/theories/FSets/FMapPositive.v
+++ b/theories/FSets/FMapPositive.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
-(* $Id$ *)
+(* $Id: FMapPositive.v 13297 2010-07-19 23:32:42Z letouzey $ *)
(** * FMapPositive : an implementation of FMapInterface for [positive] keys. *)
diff --git a/theories/FSets/FMapWeakList.v b/theories/FSets/FMapWeakList.v
index 38ed172b..db479ea8 100644
--- a/theories/FSets/FMapWeakList.v
+++ b/theories/FSets/FMapWeakList.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
-(* $Id$ *)
+(* $Id: FMapWeakList.v 12458 2009-11-02 18:50:33Z letouzey $ *)
(** * Finite map library *)
diff --git a/theories/FSets/FMaps.v b/theories/FSets/FMaps.v
index 6b110240..75904202 100644
--- a/theories/FSets/FMaps.v
+++ b/theories/FSets/FMaps.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
-(* $Id$ *)
+(* $Id: FMaps.v 10699 2008-03-19 20:56:43Z letouzey $ *)
Require Export OrderedType OrderedTypeEx OrderedTypeAlt.
diff --git a/theories/FSets/FSetAVL.v b/theories/FSets/FSetAVL.v
index bc6c731f..2cbba723 100644
--- a/theories/FSets/FSetAVL.v
+++ b/theories/FSets/FSetAVL.v
@@ -7,7 +7,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
-(* $Id$ *)
+(* $Id: FSetAVL.v 12641 2010-01-07 15:32:52Z letouzey $ *)
(** * FSetAVL : Implementation of FSetInterface via AVL trees *)
diff --git a/theories/FSets/FSetBridge.v b/theories/FSets/FSetBridge.v
index 7f8c51d6..c2d921be 100644
--- a/theories/FSets/FSetBridge.v
+++ b/theories/FSets/FSetBridge.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
-(* $Id$ *)
+(* $Id: FSetBridge.v 13253 2010-07-07 08:39:30Z letouzey $ *)
(** * Finite sets library *)
diff --git a/theories/FSets/FSetDecide.v b/theories/FSets/FSetDecide.v
index b7d6382e..497f4e6d 100644
--- a/theories/FSets/FSetDecide.v
+++ b/theories/FSets/FSetDecide.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
-(* $Id$ *)
+(* $Id: FSetDecide.v 13171 2010-06-18 21:45:40Z letouzey $ *)
(**************************************************************)
(* FSetDecide.v *)
diff --git a/theories/FSets/FSetEqProperties.v b/theories/FSets/FSetEqProperties.v
index ec0c6a55..ac55aef5 100644
--- a/theories/FSets/FSetEqProperties.v
+++ b/theories/FSets/FSetEqProperties.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
-(* $Id$ *)
+(* $Id: FSetEqProperties.v 12400 2009-10-19 13:14:18Z letouzey $ *)
(** * Finite sets library *)
diff --git a/theories/FSets/FSetFacts.v b/theories/FSets/FSetFacts.v
index b750edfc..45b43d83 100644
--- a/theories/FSets/FSetFacts.v
+++ b/theories/FSets/FSetFacts.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
-(* $Id$ *)
+(* $Id: FSetFacts.v 12461 2009-11-03 08:24:06Z letouzey $ *)
(** * Finite sets library *)
diff --git a/theories/FSets/FSetInterface.v b/theories/FSets/FSetInterface.v
index 8aede552..f366ed3e 100644
--- a/theories/FSets/FSetInterface.v
+++ b/theories/FSets/FSetInterface.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
-(* $Id$ *)
+(* $Id: FSetInterface.v 12640 2010-01-07 15:32:49Z letouzey $ *)
(** * Finite set library *)
diff --git a/theories/FSets/FSetList.v b/theories/FSets/FSetList.v
index f83259c4..9408ba05 100644
--- a/theories/FSets/FSetList.v
+++ b/theories/FSets/FSetList.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
-(* $Id$ *)
+(* $Id: FSetList.v 12641 2010-01-07 15:32:52Z letouzey $ *)
(** * Finite sets library *)
diff --git a/theories/FSets/FSetProperties.v b/theories/FSets/FSetProperties.v
index 84c26dac..59e19cd3 100644
--- a/theories/FSets/FSetProperties.v
+++ b/theories/FSets/FSetProperties.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
-(* $Id$ *)
+(* $Id: FSetProperties.v 12400 2009-10-19 13:14:18Z letouzey $ *)
(** * Finite sets library *)
diff --git a/theories/FSets/FSetToFiniteSet.v b/theories/FSets/FSetToFiniteSet.v
index 01138270..2aa1b433 100644
--- a/theories/FSets/FSetToFiniteSet.v
+++ b/theories/FSets/FSetToFiniteSet.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
-(* $Id$ *)
+(* $Id: FSetToFiniteSet.v 12363 2009-09-28 15:04:07Z letouzey $ *)
(** * Finite sets library : conversion to old [Finite_sets] *)
diff --git a/theories/FSets/FSetWeakList.v b/theories/FSets/FSetWeakList.v
index 711cbd9a..b55db37a 100644
--- a/theories/FSets/FSetWeakList.v
+++ b/theories/FSets/FSetWeakList.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
-(* $Id$ *)
+(* $Id: FSetWeakList.v 12641 2010-01-07 15:32:52Z letouzey $ *)
(** * Finite sets library *)
diff --git a/theories/FSets/FSets.v b/theories/FSets/FSets.v
index 62a95734..a725c1eb 100644
--- a/theories/FSets/FSets.v
+++ b/theories/FSets/FSets.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
-(* $Id$ *)
+(* $Id: FSets.v 13297 2010-07-19 23:32:42Z letouzey $ *)
Require Export OrderedType.
Require Export OrderedTypeEx.
diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v
index 62e0d398..7f2ea63d 100644
--- a/theories/Init/Datatypes.v
+++ b/theories/Init/Datatypes.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Datatypes.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Set Implicit Arguments.
diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v
index 16c32b35..4c9bd919 100644
--- a/theories/Init/Logic.v
+++ b/theories/Init/Logic.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Logic.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Set Implicit Arguments.
diff --git a/theories/Init/Logic_Type.v b/theories/Init/Logic_Type.v
index d002c967..b9ea3095 100644
--- a/theories/Init/Logic_Type.v
+++ b/theories/Init/Logic_Type.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Logic_Type.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** This module defines type constructors for types in [Type]
([Datatypes.v] and [Logic.v] defined them for types in [Set]) *)
diff --git a/theories/Init/Notations.v b/theories/Init/Notations.v
index e8a11952..0eba44b3 100644
--- a/theories/Init/Notations.v
+++ b/theories/Init/Notations.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Notations.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** These are the notations whose level and associativity are imposed by Coq *)
diff --git a/theories/Init/Peano.v b/theories/Init/Peano.v
index e86939c8..a6f94752 100644
--- a/theories/Init/Peano.v
+++ b/theories/Init/Peano.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Peano.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** The type [nat] of Peano natural numbers (built from [O] and [S])
is defined in [Datatypes.v] *)
diff --git a/theories/Init/Prelude.v b/theories/Init/Prelude.v
index d7625147..63d53560 100644
--- a/theories/Init/Prelude.v
+++ b/theories/Init/Prelude.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Prelude.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export Notations.
Require Export Logic.
diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v
index 26c0194e..436a7957 100644
--- a/theories/Init/Specif.v
+++ b/theories/Init/Specif.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Specif.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** Basic specifications : sets that may contain logical information *)
diff --git a/theories/Init/Tactics.v b/theories/Init/Tactics.v
index 3a845e6a..58920228 100644
--- a/theories/Init/Tactics.v
+++ b/theories/Init/Tactics.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Tactics.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Notations.
Require Import Logic.
diff --git a/theories/Init/Wf.v b/theories/Init/Wf.v
index a7887913..be7becda 100644
--- a/theories/Init/Wf.v
+++ b/theories/Init/Wf.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Wf.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** * This module proves the validity of
- well-founded recursion (also known as course of values)
diff --git a/theories/Lists/List.v b/theories/Lists/List.v
index bc55ef02..c4957578 100644
--- a/theories/Lists/List.v
+++ b/theories/Lists/List.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: List.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Le Gt Minus Min Bool.
diff --git a/theories/Lists/ListSet.v b/theories/Lists/ListSet.v
index 9978f5bc..2833ca3e 100644
--- a/theories/Lists/ListSet.v
+++ b/theories/Lists/ListSet.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: ListSet.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** A Library for finite sets, implemented as lists *)
diff --git a/theories/Lists/ListTactics.v b/theories/Lists/ListTactics.v
index c7d37dd9..5de2780a 100644
--- a/theories/Lists/ListTactics.v
+++ b/theories/Lists/ListTactics.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: ListTactics.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import BinPos.
Require Import List.
diff --git a/theories/Lists/SetoidList.v b/theories/Lists/SetoidList.v
index d42e71e5..ec31f37d 100644
--- a/theories/Lists/SetoidList.v
+++ b/theories/Lists/SetoidList.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
-(* $Id$ *)
+(* $Id: SetoidList.v 12919 2010-04-10 16:30:44Z herbelin $ *)
Require Export List.
Require Export Sorting.
diff --git a/theories/Lists/Streams.v b/theories/Lists/Streams.v
index feb8c654..e07347a0 100644
--- a/theories/Lists/Streams.v
+++ b/theories/Lists/Streams.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Streams.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Set Implicit Arguments.
diff --git a/theories/Lists/TheoryList.v b/theories/Lists/TheoryList.v
index bb5c7b17..aa1b099b 100644
--- a/theories/Lists/TheoryList.v
+++ b/theories/Lists/TheoryList.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: TheoryList.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** Some programs and results about lists following CAML Manual *)
diff --git a/theories/Logic/Berardi.v b/theories/Logic/Berardi.v
index 7d9fb802..c4c8bbe2 100644
--- a/theories/Logic/Berardi.v
+++ b/theories/Logic/Berardi.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Berardi.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** This file formalizes Berardi's paradox which says that in
the calculus of constructions, excluded middle (EM) and axiom of
diff --git a/theories/Logic/ChoiceFacts.v b/theories/Logic/ChoiceFacts.v
index 959670cb..34ebc329 100644
--- a/theories/Logic/ChoiceFacts.v
+++ b/theories/Logic/ChoiceFacts.v
@@ -7,7 +7,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: ChoiceFacts.v 12363 2009-09-28 15:04:07Z letouzey $ i*)
+(*i $Id: ChoiceFacts.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** Some facts and definitions concerning choice and description in
intuitionistic logic.
diff --git a/theories/Logic/Classical.v b/theories/Logic/Classical.v
index b2cca5c2..d6c79882 100644
--- a/theories/Logic/Classical.v
+++ b/theories/Logic/Classical.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Classical.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** Classical Logic *)
diff --git a/theories/Logic/ClassicalChoice.v b/theories/Logic/ClassicalChoice.v
index 50ce871b..08a34bc8 100644
--- a/theories/Logic/ClassicalChoice.v
+++ b/theories/Logic/ClassicalChoice.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: ClassicalChoice.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** This file provides classical logic and functional choice; this
especially provides both indefinite descriptions and choice functions
diff --git a/theories/Logic/ClassicalDescription.v b/theories/Logic/ClassicalDescription.v
index 793c6ab7..f9896669 100644
--- a/theories/Logic/ClassicalDescription.v
+++ b/theories/Logic/ClassicalDescription.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: ClassicalDescription.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** This file provides classical logic and definite description, which is
equivalent to providing classical logic and Church's iota operator *)
diff --git a/theories/Logic/ClassicalEpsilon.v b/theories/Logic/ClassicalEpsilon.v
index 53989d07..c45bc052 100644
--- a/theories/Logic/ClassicalEpsilon.v
+++ b/theories/Logic/ClassicalEpsilon.v
@@ -7,7 +7,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: ClassicalEpsilon.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** This file provides classical logic and indefinite description under
the form of Hilbert's epsilon operator *)
diff --git a/theories/Logic/ClassicalFacts.v b/theories/Logic/ClassicalFacts.v
index c5822bac..cd885592 100644
--- a/theories/Logic/ClassicalFacts.v
+++ b/theories/Logic/ClassicalFacts.v
@@ -7,7 +7,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: ClassicalFacts.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** Some facts and definitions about classical logic
diff --git a/theories/Logic/ClassicalUniqueChoice.v b/theories/Logic/ClassicalUniqueChoice.v
index 6c1c68cf..ea0898d4 100644
--- a/theories/Logic/ClassicalUniqueChoice.v
+++ b/theories/Logic/ClassicalUniqueChoice.v
@@ -7,7 +7,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: ClassicalUniqueChoice.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** This file provides classical logic and unique choice; this is
weaker than providing iota operator and classical logic as the
diff --git a/theories/Logic/Classical_Pred_Set.v b/theories/Logic/Classical_Pred_Set.v
index 3f30abe5..b95373e5 100644
--- a/theories/Logic/Classical_Pred_Set.v
+++ b/theories/Logic/Classical_Pred_Set.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Classical_Pred_Set.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** This file is obsolete, use Classical_Pred_Type.v via Classical.v
instead *)
diff --git a/theories/Logic/Classical_Pred_Type.v b/theories/Logic/Classical_Pred_Type.v
index 638c58d2..32f0a6ac 100644
--- a/theories/Logic/Classical_Pred_Type.v
+++ b/theories/Logic/Classical_Pred_Type.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Classical_Pred_Type.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** Classical Predicate Logic on Type *)
diff --git a/theories/Logic/Classical_Prop.v b/theories/Logic/Classical_Prop.v
index 91392ca6..77715ce3 100644
--- a/theories/Logic/Classical_Prop.v
+++ b/theories/Logic/Classical_Prop.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Classical_Prop.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** Classical Propositional Logic *)
diff --git a/theories/Logic/Classical_Type.v b/theories/Logic/Classical_Type.v
index 2f5c9726..2319638f 100644
--- a/theories/Logic/Classical_Type.v
+++ b/theories/Logic/Classical_Type.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Classical_Type.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** This file is obsolete, use Classical.v instead *)
diff --git a/theories/Logic/ConstructiveEpsilon.v b/theories/Logic/ConstructiveEpsilon.v
index 90aa0f30..738ca1d5 100644
--- a/theories/Logic/ConstructiveEpsilon.v
+++ b/theories/Logic/ConstructiveEpsilon.v
@@ -6,9 +6,9 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: ConstructiveEpsilon.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
-(*i $Id: ConstructiveEpsilon.v 12112 2009-04-28 15:47:34Z herbelin $ i*)
+(*i $Id: ConstructiveEpsilon.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** This module proves the constructive description schema, which
infers the sigma-existence (i.e., [Set]-existence) of a witness to a
diff --git a/theories/Logic/Decidable.v b/theories/Logic/Decidable.v
index df9acbcc..ac4f686b 100644
--- a/theories/Logic/Decidable.v
+++ b/theories/Logic/Decidable.v
@@ -5,7 +5,7 @@
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Decidable.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** Properties of decidable propositions *)
diff --git a/theories/Logic/Description.v b/theories/Logic/Description.v
index c569dc46..deedf35b 100644
--- a/theories/Logic/Description.v
+++ b/theories/Logic/Description.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Description.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** This file provides a constructive form of definite description; it
allows to build functions from the proof of their existence in any
diff --git a/theories/Logic/Diaconescu.v b/theories/Logic/Diaconescu.v
index 4c4785cf..ff640af7 100644
--- a/theories/Logic/Diaconescu.v
+++ b/theories/Logic/Diaconescu.v
@@ -7,7 +7,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Diaconescu.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** Diaconescu showed that the Axiom of Choice entails Excluded-Middle
in topoi [Diaconescu75]. Lacas and Werner adapted the proof to show
diff --git a/theories/Logic/Epsilon.v b/theories/Logic/Epsilon.v
index 9cea8dfd..4ec0c83d 100644
--- a/theories/Logic/Epsilon.v
+++ b/theories/Logic/Epsilon.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Epsilon.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** This file provides indefinite description under the form of
Hilbert's epsilon operator; it does not assume classical logic. *)
diff --git a/theories/Logic/Eqdep.v b/theories/Logic/Eqdep.v
index ed9d1a9f..53b19ff6 100644
--- a/theories/Logic/Eqdep.v
+++ b/theories/Logic/Eqdep.v
@@ -7,7 +7,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Eqdep.v 13332 2010-07-26 22:12:43Z msozeau $ i*)
(** This file axiomatizes the invariance by substitution of reflexive
equality proofs [[Streicher93]] and exports its consequences, such
@@ -31,5 +31,5 @@ Export EqdepTheory.
(** Exported hints *)
-Hint Resolve eq_dep_eq: core v62.
-Hint Resolve inj_pair2 inj_pairT2: core.
+Hint Resolve eq_dep_eq: eqdep v62.
+Hint Resolve inj_pair2 inj_pairT2: eqdep.
diff --git a/theories/Logic/EqdepFacts.v b/theories/Logic/EqdepFacts.v
index 15a36dd4..3e49c759 100644
--- a/theories/Logic/EqdepFacts.v
+++ b/theories/Logic/EqdepFacts.v
@@ -7,7 +7,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: EqdepFacts.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** This file defines dependent equality and shows its equivalence with
equality on dependent pairs (inhabiting sigma-types). It derives
diff --git a/theories/Logic/Eqdep_dec.v b/theories/Logic/Eqdep_dec.v
index 0ad7e909..c45643e4 100644
--- a/theories/Logic/Eqdep_dec.v
+++ b/theories/Logic/Eqdep_dec.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Eqdep_dec.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** We prove that there is only one proof of [x=x], i.e [refl_equal x].
This holds if the equality upon the set of [x] is decidable.
diff --git a/theories/Logic/FunctionalExtensionality.v b/theories/Logic/FunctionalExtensionality.v
index 5e9953d4..4def8910 100644
--- a/theories/Logic/FunctionalExtensionality.v
+++ b/theories/Logic/FunctionalExtensionality.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: FunctionalExtensionality.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** This module states the axiom of (dependent) functional extensionality and (dependent) eta-expansion.
It introduces a tactic [extensionality] to apply the axiom of extensionality to an equality goal. *)
diff --git a/theories/Logic/IndefiniteDescription.v b/theories/Logic/IndefiniteDescription.v
index 05c04952..e0537238 100644
--- a/theories/Logic/IndefiniteDescription.v
+++ b/theories/Logic/IndefiniteDescription.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: IndefiniteDescription.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** This file provides a constructive form of indefinite description that
allows to build choice functions; this is weaker than Hilbert's
diff --git a/theories/Logic/JMeq.v b/theories/Logic/JMeq.v
index 06903c3b..3de77074 100644
--- a/theories/Logic/JMeq.v
+++ b/theories/Logic/JMeq.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: JMeq.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** John Major's Equality as proposed by Conor McBride
diff --git a/theories/Logic/RelationalChoice.v b/theories/Logic/RelationalChoice.v
index 85da26b3..e0a10d46 100644
--- a/theories/Logic/RelationalChoice.v
+++ b/theories/Logic/RelationalChoice.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: RelationalChoice.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** This file axiomatizes the relational form of the axiom of choice *)
diff --git a/theories/NArith/BinNat.v b/theories/NArith/BinNat.v
index 332e2104..e44b39f5 100644
--- a/theories/NArith/BinNat.v
+++ b/theories/NArith/BinNat.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: BinNat.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import BinPos.
Unset Boxed Definitions.
diff --git a/theories/NArith/BinPos.v b/theories/NArith/BinPos.v
index 9cfb8893..a8f78df0 100644
--- a/theories/NArith/BinPos.v
+++ b/theories/NArith/BinPos.v
@@ -7,7 +7,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: BinPos.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Unset Boxed Definitions.
diff --git a/theories/NArith/NArith.v b/theories/NArith/NArith.v
index 9b659750..9d2424bc 100644
--- a/theories/NArith/NArith.v
+++ b/theories/NArith/NArith.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: NArith.v 13323 2010-07-24 15:57:30Z herbelin $ *)
(** Library for binary natural numbers *)
diff --git a/theories/NArith/Ndec.v b/theories/NArith/Ndec.v
index dbea23e3..d6b1e718 100644
--- a/theories/NArith/Ndec.v
+++ b/theories/NArith/Ndec.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Ndec.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Bool.
Require Import Sumbool.
diff --git a/theories/NArith/Ndigits.v b/theories/NArith/Ndigits.v
index e21f1976..5151236f 100644
--- a/theories/NArith/Ndigits.v
+++ b/theories/NArith/Ndigits.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Ndigits.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Bool.
Require Import Bvector.
diff --git a/theories/NArith/Ndist.v b/theories/NArith/Ndist.v
index bbf38794..0e920242 100644
--- a/theories/NArith/Ndist.v
+++ b/theories/NArith/Ndist.v
@@ -5,7 +5,7 @@
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Ndist.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Arith.
Require Import Min.
diff --git a/theories/NArith/Nnat.v b/theories/NArith/Nnat.v
index dec7e927..49bbf7b7 100644
--- a/theories/NArith/Nnat.v
+++ b/theories/NArith/Nnat.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Nnat.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Arith_base.
Require Import Compare_dec.
diff --git a/theories/NArith/Pnat.v b/theories/NArith/Pnat.v
index 9f995502..1952470d 100644
--- a/theories/NArith/Pnat.v
+++ b/theories/NArith/Pnat.v
@@ -7,7 +7,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Pnat.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import BinPos.
diff --git a/theories/Numbers/BigNumPrelude.v b/theories/Numbers/BigNumPrelude.v
index 356cbb26..97b6b077 100644
--- a/theories/Numbers/BigNumPrelude.v
+++ b/theories/Numbers/BigNumPrelude.v
@@ -8,7 +8,7 @@
(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: BigNumPrelude.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** * BigNumPrelude *)
diff --git a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v
index 669dc741..29186694 100644
--- a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v
+++ b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v
@@ -8,7 +8,7 @@
(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: CyclicAxioms.v 13323 2010-07-24 15:57:30Z herbelin $ *)
(** * Signature and specification of a bounded integer structure *)
diff --git a/theories/Numbers/Cyclic/Abstract/NZCyclic.v b/theories/Numbers/Cyclic/Abstract/NZCyclic.v
index 3636ebec..e5bc043d 100644
--- a/theories/Numbers/Cyclic/Abstract/NZCyclic.v
+++ b/theories/Numbers/Cyclic/Abstract/NZCyclic.v
@@ -8,7 +8,7 @@
(* Evgeny Makarov, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: NZCyclic.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export NZAxioms.
Require Import BigNumPrelude.
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v
index 868b7247..f49201d8 100644
--- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v
+++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v
@@ -8,7 +8,7 @@
(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: DoubleAdd.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Set Implicit Arguments.
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v
index a7985c4f..ba2a1770 100644
--- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v
+++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v
@@ -8,7 +8,7 @@
(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: DoubleBase.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Set Implicit Arguments.
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v
index cbac8723..4a60a10b 100644
--- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v
+++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v
@@ -8,7 +8,7 @@
(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: DoubleCyclic.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Set Implicit Arguments.
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v
index 48750fa7..5ddadd12 100644
--- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v
+++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v
@@ -8,7 +8,7 @@
(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: DoubleDiv.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Set Implicit Arguments.
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v
index f241cc54..3ada7d40 100644
--- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v
+++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v
@@ -8,7 +8,7 @@
(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: DoubleDivn1.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Set Implicit Arguments.
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v
index 26af1cc8..3989791c 100644
--- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v
+++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v
@@ -8,7 +8,7 @@
(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: DoubleLift.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Set Implicit Arguments.
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v
index fafb7d1d..7ddb0468 100644
--- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v
+++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v
@@ -8,7 +8,7 @@
(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: DoubleMul.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Set Implicit Arguments.
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v
index 4c93d758..d468318d 100644
--- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v
+++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v
@@ -8,7 +8,7 @@
(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: DoubleSqrt.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Set Implicit Arguments.
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v
index 7ecec835..7cb97f28 100644
--- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v
+++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v
@@ -8,7 +8,7 @@
(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: DoubleSub.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Set Implicit Arguments.
diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v
index dde0c142..e9955c6d 100644
--- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v
+++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v
@@ -8,7 +8,7 @@
(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: DoubleType.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Set Implicit Arguments.
diff --git a/theories/Numbers/Cyclic/Int31/Cyclic31.v b/theories/Numbers/Cyclic/Int31/Cyclic31.v
index f581657e..8ec359a0 100644
--- a/theories/Numbers/Cyclic/Int31/Cyclic31.v
+++ b/theories/Numbers/Cyclic/Int31/Cyclic31.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Cyclic31.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** * Int31 numbers defines indeed a cyclic structure : Z/(2^31)Z *)
diff --git a/theories/Numbers/Cyclic/Int31/Int31.v b/theories/Numbers/Cyclic/Int31/Int31.v
index 3c72b785..2485c353 100644
--- a/theories/Numbers/Cyclic/Int31/Int31.v
+++ b/theories/Numbers/Cyclic/Int31/Int31.v
@@ -8,7 +8,7 @@
(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Int31.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import NaryFunctions.
Require Import Wf_nat.
diff --git a/theories/Numbers/Cyclic/Int31/Ring31.v b/theories/Numbers/Cyclic/Int31/Ring31.v
index ff55bc51..2864c81f 100644
--- a/theories/Numbers/Cyclic/Int31/Ring31.v
+++ b/theories/Numbers/Cyclic/Int31/Ring31.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Ring31.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** * Int31 numbers defines Z/(2^31)Z, and can hence be equipped
with a ring structure and a ring tactic *)
diff --git a/theories/Numbers/Cyclic/ZModulo/ZModulo.v b/theories/Numbers/Cyclic/ZModulo/ZModulo.v
index ced812e2..bebc67a0 100644
--- a/theories/Numbers/Cyclic/ZModulo/ZModulo.v
+++ b/theories/Numbers/Cyclic/ZModulo/ZModulo.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: ZModulo.v 13323 2010-07-24 15:57:30Z herbelin $ *)
(** * Type [Z] viewed modulo a particular constant corresponds to [Z/nZ]
as defined abstractly in CyclicAxioms. *)
diff --git a/theories/Numbers/Integer/Abstract/ZAdd.v b/theories/Numbers/Integer/Abstract/ZAdd.v
index 71ca5e11..f120f881 100644
--- a/theories/Numbers/Integer/Abstract/ZAdd.v
+++ b/theories/Numbers/Integer/Abstract/ZAdd.v
@@ -8,7 +8,7 @@
(* Evgeny Makarov, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: ZAdd.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export ZBase.
diff --git a/theories/Numbers/Integer/Abstract/ZAddOrder.v b/theories/Numbers/Integer/Abstract/ZAddOrder.v
index 96213eab..2d607010 100644
--- a/theories/Numbers/Integer/Abstract/ZAddOrder.v
+++ b/theories/Numbers/Integer/Abstract/ZAddOrder.v
@@ -8,7 +8,7 @@
(* Evgeny Makarov, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: ZAddOrder.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export ZLt.
diff --git a/theories/Numbers/Integer/Abstract/ZAxioms.v b/theories/Numbers/Integer/Abstract/ZAxioms.v
index 13d32304..c52fe299 100644
--- a/theories/Numbers/Integer/Abstract/ZAxioms.v
+++ b/theories/Numbers/Integer/Abstract/ZAxioms.v
@@ -8,7 +8,7 @@
(* Evgeny Makarov, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: ZAxioms.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export NZAxioms.
diff --git a/theories/Numbers/Integer/Abstract/ZBase.v b/theories/Numbers/Integer/Abstract/ZBase.v
index 244eb92c..a42e8230 100644
--- a/theories/Numbers/Integer/Abstract/ZBase.v
+++ b/theories/Numbers/Integer/Abstract/ZBase.v
@@ -8,7 +8,7 @@
(* Evgeny Makarov, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: ZBase.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export Decidable.
Require Export ZAxioms.
diff --git a/theories/Numbers/Integer/Abstract/ZLt.v b/theories/Numbers/Integer/Abstract/ZLt.v
index 14f2ef62..2e019a57 100644
--- a/theories/Numbers/Integer/Abstract/ZLt.v
+++ b/theories/Numbers/Integer/Abstract/ZLt.v
@@ -8,7 +8,7 @@
(* Evgeny Makarov, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: ZLt.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export ZMul.
diff --git a/theories/Numbers/Integer/Abstract/ZMul.v b/theories/Numbers/Integer/Abstract/ZMul.v
index 5856c6d9..5be20268 100644
--- a/theories/Numbers/Integer/Abstract/ZMul.v
+++ b/theories/Numbers/Integer/Abstract/ZMul.v
@@ -8,7 +8,7 @@
(* Evgeny Makarov, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: ZMul.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export ZAdd.
diff --git a/theories/Numbers/Integer/Abstract/ZMulOrder.v b/theories/Numbers/Integer/Abstract/ZMulOrder.v
index 69b9c986..d5ec8005 100644
--- a/theories/Numbers/Integer/Abstract/ZMulOrder.v
+++ b/theories/Numbers/Integer/Abstract/ZMulOrder.v
@@ -8,7 +8,7 @@
(* Evgeny Makarov, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: ZMulOrder.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export ZAddOrder.
diff --git a/theories/Numbers/Integer/Abstract/ZProperties.v b/theories/Numbers/Integer/Abstract/ZProperties.v
index 7cc064d9..09ece42a 100644
--- a/theories/Numbers/Integer/Abstract/ZProperties.v
+++ b/theories/Numbers/Integer/Abstract/ZProperties.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: ZProperties.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export ZAxioms ZMulOrder ZSgnAbs.
diff --git a/theories/Numbers/Integer/BigZ/BigZ.v b/theories/Numbers/Integer/BigZ/BigZ.v
index 180081d9..7f9e2d91 100644
--- a/theories/Numbers/Integer/BigZ/BigZ.v
+++ b/theories/Numbers/Integer/BigZ/BigZ.v
@@ -8,7 +8,7 @@
(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: BigZ.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export BigN.
Require Import ZProperties ZDivFloor ZSig ZSigZAxioms ZMake.
diff --git a/theories/Numbers/Integer/BigZ/ZMake.v b/theories/Numbers/Integer/BigZ/ZMake.v
index 70fe97d9..c61e198d 100644
--- a/theories/Numbers/Integer/BigZ/ZMake.v
+++ b/theories/Numbers/Integer/BigZ/ZMake.v
@@ -8,7 +8,7 @@
(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: ZMake.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import ZArith.
Require Import BigNumPrelude.
diff --git a/theories/Numbers/Integer/Binary/ZBinary.v b/theories/Numbers/Integer/Binary/ZBinary.v
index a904cdba..9c8f80c9 100644
--- a/theories/Numbers/Integer/Binary/ZBinary.v
+++ b/theories/Numbers/Integer/Binary/ZBinary.v
@@ -8,7 +8,7 @@
(* Evgeny Makarov, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: ZBinary.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import ZAxioms ZProperties.
diff --git a/theories/Numbers/Integer/NatPairs/ZNatPairs.v b/theories/Numbers/Integer/NatPairs/ZNatPairs.v
index 45c5db77..830e1ad7 100644
--- a/theories/Numbers/Integer/NatPairs/ZNatPairs.v
+++ b/theories/Numbers/Integer/NatPairs/ZNatPairs.v
@@ -8,7 +8,7 @@
(* Evgeny Makarov, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: ZNatPairs.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import NProperties. (* The most complete file for N *)
Require Export ZProperties. (* The most complete file for Z *)
diff --git a/theories/Numbers/Integer/SpecViaZ/ZSig.v b/theories/Numbers/Integer/SpecViaZ/ZSig.v
index b2c23685..957e1c70 100644
--- a/theories/Numbers/Integer/SpecViaZ/ZSig.v
+++ b/theories/Numbers/Integer/SpecViaZ/ZSig.v
@@ -8,7 +8,7 @@
(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: ZSig.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import ZArith Znumtheory.
diff --git a/theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v b/theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v
index bb8d543e..142e613b 100644
--- a/theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v
+++ b/theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: ZSigZAxioms.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import ZArith ZAxioms ZDivFloor ZSig.
diff --git a/theories/Numbers/NaryFunctions.v b/theories/Numbers/NaryFunctions.v
index 83487d22..b0aad5b5 100644
--- a/theories/Numbers/NaryFunctions.v
+++ b/theories/Numbers/NaryFunctions.v
@@ -8,7 +8,7 @@
(* Pierre Letouzey, Jerome Vouillon, PPS, Paris 7, 2008 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: NaryFunctions.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Local Open Scope type_scope.
diff --git a/theories/Numbers/NatInt/NZAdd.v b/theories/Numbers/NatInt/NZAdd.v
index ee73a22a..6f1b879c 100644
--- a/theories/Numbers/NatInt/NZAdd.v
+++ b/theories/Numbers/NatInt/NZAdd.v
@@ -8,7 +8,7 @@
(* Evgeny Makarov, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: NZAdd.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import NZAxioms NZBase.
diff --git a/theories/Numbers/NatInt/NZAddOrder.v b/theories/Numbers/NatInt/NZAddOrder.v
index ca359346..7c06226f 100644
--- a/theories/Numbers/NatInt/NZAddOrder.v
+++ b/theories/Numbers/NatInt/NZAddOrder.v
@@ -8,7 +8,7 @@
(* Evgeny Makarov, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: NZAddOrder.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import NZAxioms NZBase NZMul NZOrder.
diff --git a/theories/Numbers/NatInt/NZAxioms.v b/theories/Numbers/NatInt/NZAxioms.v
index bb13d051..389f4eb2 100644
--- a/theories/Numbers/NatInt/NZAxioms.v
+++ b/theories/Numbers/NatInt/NZAxioms.v
@@ -8,7 +8,7 @@
(** Initial Author : Evgeny Makarov, INRIA, 2007 *)
-(*i $Id$ i*)
+(*i $Id: NZAxioms.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export Equalities Orders NumPrelude GenericMinMax.
diff --git a/theories/Numbers/NatInt/NZBase.v b/theories/Numbers/NatInt/NZBase.v
index f83af8f0..b5df1669 100644
--- a/theories/Numbers/NatInt/NZBase.v
+++ b/theories/Numbers/NatInt/NZBase.v
@@ -8,7 +8,7 @@
(* Evgeny Makarov, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: NZBase.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import NZAxioms.
diff --git a/theories/Numbers/NatInt/NZDomain.v b/theories/Numbers/NatInt/NZDomain.v
index d8e45ff5..af3e4861 100644
--- a/theories/Numbers/NatInt/NZDomain.v
+++ b/theories/Numbers/NatInt/NZDomain.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: NZDomain.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export NumPrelude NZAxioms.
Require Import NZBase NZOrder NZAddOrder Plus Minus.
diff --git a/theories/Numbers/NatInt/NZMul.v b/theories/Numbers/NatInt/NZMul.v
index 14981a22..b55f58cb 100644
--- a/theories/Numbers/NatInt/NZMul.v
+++ b/theories/Numbers/NatInt/NZMul.v
@@ -8,7 +8,7 @@
(* Evgeny Makarov, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: NZMul.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import NZAxioms NZBase NZAdd.
diff --git a/theories/Numbers/NatInt/NZMulOrder.v b/theories/Numbers/NatInt/NZMulOrder.v
index 35922519..dee1a803 100644
--- a/theories/Numbers/NatInt/NZMulOrder.v
+++ b/theories/Numbers/NatInt/NZMulOrder.v
@@ -8,7 +8,7 @@
(* Evgeny Makarov, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: NZMulOrder.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import NZAxioms.
Require Import NZAddOrder.
diff --git a/theories/Numbers/NatInt/NZOrder.v b/theories/Numbers/NatInt/NZOrder.v
index 3f00cd20..5d7bb701 100644
--- a/theories/Numbers/NatInt/NZOrder.v
+++ b/theories/Numbers/NatInt/NZOrder.v
@@ -8,7 +8,7 @@
(* Evgeny Makarov, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: NZOrder.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import NZAxioms NZBase Decidable OrdersTac.
diff --git a/theories/Numbers/NatInt/NZProperties.v b/theories/Numbers/NatInt/NZProperties.v
index 7a7601bd..92dffed3 100644
--- a/theories/Numbers/NatInt/NZProperties.v
+++ b/theories/Numbers/NatInt/NZProperties.v
@@ -8,7 +8,7 @@
(* Evgeny Makarov, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: NZProperties.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export NZAxioms NZMulOrder.
diff --git a/theories/Numbers/Natural/Abstract/NAdd.v b/theories/Numbers/Natural/Abstract/NAdd.v
index 4ae8b393..305ccfd0 100644
--- a/theories/Numbers/Natural/Abstract/NAdd.v
+++ b/theories/Numbers/Natural/Abstract/NAdd.v
@@ -8,7 +8,7 @@
(* Evgeny Makarov, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: NAdd.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export NBase.
diff --git a/theories/Numbers/Natural/Abstract/NAddOrder.v b/theories/Numbers/Natural/Abstract/NAddOrder.v
index 729618ef..a4b8c759 100644
--- a/theories/Numbers/Natural/Abstract/NAddOrder.v
+++ b/theories/Numbers/Natural/Abstract/NAddOrder.v
@@ -8,7 +8,7 @@
(* Evgeny Makarov, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: NAddOrder.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export NOrder.
diff --git a/theories/Numbers/Natural/Abstract/NAxioms.v b/theories/Numbers/Natural/Abstract/NAxioms.v
index 309dff8f..1a7c436b 100644
--- a/theories/Numbers/Natural/Abstract/NAxioms.v
+++ b/theories/Numbers/Natural/Abstract/NAxioms.v
@@ -8,7 +8,7 @@
(* Evgeny Makarov, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: NAxioms.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export NZAxioms.
diff --git a/theories/Numbers/Natural/Abstract/NBase.v b/theories/Numbers/Natural/Abstract/NBase.v
index 48bdfabf..5f262a82 100644
--- a/theories/Numbers/Natural/Abstract/NBase.v
+++ b/theories/Numbers/Natural/Abstract/NBase.v
@@ -8,7 +8,7 @@
(* Evgeny Makarov, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: NBase.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export Decidable.
Require Export NAxioms.
diff --git a/theories/Numbers/Natural/Abstract/NDefOps.v b/theories/Numbers/Natural/Abstract/NDefOps.v
index ca2b1b7e..238518ba 100644
--- a/theories/Numbers/Natural/Abstract/NDefOps.v
+++ b/theories/Numbers/Natural/Abstract/NDefOps.v
@@ -8,7 +8,7 @@
(* Evgeny Makarov, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: NDefOps.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Bool. (* To get the orb and negb function *)
Require Import RelationPairs.
diff --git a/theories/Numbers/Natural/Abstract/NIso.v b/theories/Numbers/Natural/Abstract/NIso.v
index c3e5e27c..79516623 100644
--- a/theories/Numbers/Natural/Abstract/NIso.v
+++ b/theories/Numbers/Natural/Abstract/NIso.v
@@ -8,7 +8,7 @@
(* Evgeny Makarov, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: NIso.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import NBase.
diff --git a/theories/Numbers/Natural/Abstract/NMulOrder.v b/theories/Numbers/Natural/Abstract/NMulOrder.v
index 9471ac6c..2b00e893 100644
--- a/theories/Numbers/Natural/Abstract/NMulOrder.v
+++ b/theories/Numbers/Natural/Abstract/NMulOrder.v
@@ -8,7 +8,7 @@
(* Evgeny Makarov, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: NMulOrder.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export NAddOrder.
diff --git a/theories/Numbers/Natural/Abstract/NOrder.v b/theories/Numbers/Natural/Abstract/NOrder.v
index 766facd5..cebf35a7 100644
--- a/theories/Numbers/Natural/Abstract/NOrder.v
+++ b/theories/Numbers/Natural/Abstract/NOrder.v
@@ -8,7 +8,7 @@
(* Evgeny Makarov, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: NOrder.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export NAdd.
diff --git a/theories/Numbers/Natural/Abstract/NProperties.v b/theories/Numbers/Natural/Abstract/NProperties.v
index f20c352e..3269972d 100644
--- a/theories/Numbers/Natural/Abstract/NProperties.v
+++ b/theories/Numbers/Natural/Abstract/NProperties.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: NProperties.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export NAxioms NSub.
diff --git a/theories/Numbers/Natural/Abstract/NStrongRec.v b/theories/Numbers/Natural/Abstract/NStrongRec.v
index 86e1d93a..f5f47128 100644
--- a/theories/Numbers/Natural/Abstract/NStrongRec.v
+++ b/theories/Numbers/Natural/Abstract/NStrongRec.v
@@ -8,7 +8,7 @@
(* Evgeny Makarov, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: NStrongRec.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** This file defined the strong (course-of-value, well-founded) recursion
and proves its properties *)
diff --git a/theories/Numbers/Natural/Abstract/NSub.v b/theories/Numbers/Natural/Abstract/NSub.v
index 8df327d6..8d16c516 100644
--- a/theories/Numbers/Natural/Abstract/NSub.v
+++ b/theories/Numbers/Natural/Abstract/NSub.v
@@ -8,7 +8,7 @@
(* Evgeny Makarov, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: NSub.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export NMulOrder.
diff --git a/theories/Numbers/Natural/BigN/NMake_gen.ml b/theories/Numbers/Natural/BigN/NMake_gen.ml
index 5bcf5e9a..8f6c59fd 100644
--- a/theories/Numbers/Natural/BigN/NMake_gen.ml
+++ b/theories/Numbers/Natural/BigN/NMake_gen.ml
@@ -8,7 +8,7 @@
(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: NMake_gen.ml 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*S NMake_gen.ml : this file generates NMake.v *)
diff --git a/theories/Numbers/Natural/BigN/Nbasic.v b/theories/Numbers/Natural/BigN/Nbasic.v
index 163712b6..a531b92e 100644
--- a/theories/Numbers/Natural/BigN/Nbasic.v
+++ b/theories/Numbers/Natural/BigN/Nbasic.v
@@ -8,7 +8,7 @@
(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Nbasic.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import ZArith.
Require Import BigNumPrelude.
diff --git a/theories/Numbers/Natural/Binary/NBinary.v b/theories/Numbers/Natural/Binary/NBinary.v
index 1fae59eb..b83e5477 100644
--- a/theories/Numbers/Natural/Binary/NBinary.v
+++ b/theories/Numbers/Natural/Binary/NBinary.v
@@ -8,7 +8,7 @@
(* Evgeny Makarov, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: NBinary.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import BinPos.
Require Export BinNat.
diff --git a/theories/Numbers/Natural/Peano/NPeano.v b/theories/Numbers/Natural/Peano/NPeano.v
index 5b468a90..4a5364fd 100644
--- a/theories/Numbers/Natural/Peano/NPeano.v
+++ b/theories/Numbers/Natural/Peano/NPeano.v
@@ -8,7 +8,7 @@
(* Evgeny Makarov, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: NPeano.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Arith MinMax NAxioms NProperties.
diff --git a/theories/Numbers/Natural/SpecViaZ/NSig.v b/theories/Numbers/Natural/SpecViaZ/NSig.v
index 6ccbd2f0..89111937 100644
--- a/theories/Numbers/Natural/SpecViaZ/NSig.v
+++ b/theories/Numbers/Natural/SpecViaZ/NSig.v
@@ -8,7 +8,7 @@
(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: NSig.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import ZArith Znumtheory.
diff --git a/theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v b/theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v
index 73e7953f..2c35242a 100644
--- a/theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v
+++ b/theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: NSigNAxioms.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import ZArith Nnat NAxioms NDiv NSig.
diff --git a/theories/Numbers/NumPrelude.v b/theories/Numbers/NumPrelude.v
index 69f6e24b..f923a53b 100644
--- a/theories/Numbers/NumPrelude.v
+++ b/theories/Numbers/NumPrelude.v
@@ -8,7 +8,7 @@
(* Evgeny Makarov, INRIA, 2007 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: NumPrelude.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export Setoid Morphisms.
diff --git a/theories/Numbers/Rational/SpecViaQ/QSig.v b/theories/Numbers/Rational/SpecViaQ/QSig.v
index 0982226c..10d0c5f7 100644
--- a/theories/Numbers/Rational/SpecViaQ/QSig.v
+++ b/theories/Numbers/Rational/SpecViaQ/QSig.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: QSig.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import QArith Qpower Qminmax Orders RelationPairs GenericMinMax.
diff --git a/theories/Program/Basics.v b/theories/Program/Basics.v
index f4017024..a298032f 100644
--- a/theories/Program/Basics.v
+++ b/theories/Program/Basics.v
@@ -6,7 +6,7 @@
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: Basics.v 13323 2010-07-24 15:57:30Z herbelin $ *)
(** Standard functions and combinators.
diff --git a/theories/Program/Combinators.v b/theories/Program/Combinators.v
index 39fb4093..e61c7027 100644
--- a/theories/Program/Combinators.v
+++ b/theories/Program/Combinators.v
@@ -6,7 +6,7 @@
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: Combinators.v 13323 2010-07-24 15:57:30Z herbelin $ *)
(** * Proofs about standard combinators, exports functional extensionality.
diff --git a/theories/Program/Equality.v b/theories/Program/Equality.v
index 1e139497..2764d1b4 100644
--- a/theories/Program/Equality.v
+++ b/theories/Program/Equality.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Equality.v 13359 2010-07-30 08:46:55Z herbelin $ i*)
(** Tactics related to (dependent) equality and proof irrelevance. *)
@@ -15,6 +15,9 @@ Require Export JMeq.
Require Import Coq.Program.Tactics.
+Local Notation "'Π' x .. y , P" := (forall x, .. (forall y, P) ..)
+ (at level 200, x binder, y binder, right associativity) : type_scope.
+
Ltac is_ground_goal :=
match goal with
|- ?T => is_ground T
diff --git a/theories/Program/Program.v b/theories/Program/Program.v
index 71be3478..929fc47c 100644
--- a/theories/Program/Program.v
+++ b/theories/Program/Program.v
@@ -5,7 +5,7 @@
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: Program.v 13323 2010-07-24 15:57:30Z herbelin $ *)
Require Export Coq.Program.Utils.
Require Export Coq.Program.Wf.
diff --git a/theories/Program/Subset.v b/theories/Program/Subset.v
index ce5f1068..9d82fde8 100644
--- a/theories/Program/Subset.v
+++ b/theories/Program/Subset.v
@@ -5,7 +5,7 @@
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: Subset.v 13323 2010-07-24 15:57:30Z herbelin $ *)
(** Tactics related to subsets and proof irrelevance. *)
diff --git a/theories/Program/Syntax.v b/theories/Program/Syntax.v
index 05bf2ea6..0e6b2909 100644
--- a/theories/Program/Syntax.v
+++ b/theories/Program/Syntax.v
@@ -5,7 +5,7 @@
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: Syntax.v 13323 2010-07-24 15:57:30Z herbelin $ *)
(** Custom notations and implicits for Coq prelude definitions.
diff --git a/theories/Program/Tactics.v b/theories/Program/Tactics.v
index 91a8edff..333dd7a6 100644
--- a/theories/Program/Tactics.v
+++ b/theories/Program/Tactics.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Tactics.v 13332 2010-07-26 22:12:43Z msozeau $ i*)
(** This module implements various tactics used to simplify the goals produced by Program,
which are also generally useful. *)
@@ -101,7 +101,7 @@ Ltac revert_last :=
[ H : _ |- _ ] => revert H
end.
-(** Reapeateadly reverse the last hypothesis, putting everything in the goal. *)
+(** Repeatedly reverse the last hypothesis, putting everything in the goal. *)
Ltac reverse := repeat revert_last.
diff --git a/theories/Program/Utils.v b/theories/Program/Utils.v
index f2aad800..b2b5d4be 100644
--- a/theories/Program/Utils.v
+++ b/theories/Program/Utils.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Utils.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** Various syntaxic shortands that are useful with [Program]. *)
diff --git a/theories/Program/Wf.v b/theories/Program/Wf.v
index d16e900f..4159f436 100644
--- a/theories/Program/Wf.v
+++ b/theories/Program/Wf.v
@@ -5,7 +5,7 @@
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: Wf.v 13332 2010-07-26 22:12:43Z msozeau $ *)
(** Reformulation of the Wf module using subsets where possible, providing
the support for [Program]'s treatment of well-founded definitions. *)
@@ -214,7 +214,7 @@ Ltac fold_sub f :=
match goal with
| [ |- ?T ] =>
match T with
- appcontext C [ @Fix_sub _ _ _ _ ?arg ] =>
+ appcontext C [ @Fix_sub _ _ _ _ _ ?arg ] =>
let app := context C [ f arg ] in
change app
end
@@ -251,6 +251,6 @@ Module WfExtensionality.
Ltac unfold_sub f fargs :=
set (call:=fargs) ; unfold f in call ; unfold call ; clear call ;
- rewrite fix_sub_eq_ext ; repeat fold_sub fargs ; simpl proj1_sig.
+ rewrite fix_sub_eq_ext ; repeat fold_sub f ; simpl proj1_sig.
End WfExtensionality.
diff --git a/theories/QArith/QArith.v b/theories/QArith/QArith.v
index 1b3ca6d6..c7f41de4 100644
--- a/theories/QArith/QArith.v
+++ b/theories/QArith/QArith.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: QArith.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export QArith_base.
Require Export Qring.
diff --git a/theories/QArith/QArith_base.v b/theories/QArith/QArith_base.v
index 9540968d..6b33c254 100644
--- a/theories/QArith/QArith_base.v
+++ b/theories/QArith/QArith_base.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: QArith_base.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export ZArith.
Require Export ZArithRing.
diff --git a/theories/QArith/Qcanon.v b/theories/QArith/Qcanon.v
index eb1508b3..4a2347d7 100644
--- a/theories/QArith/Qcanon.v
+++ b/theories/QArith/Qcanon.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Qcanon.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Field.
Require Import QArith.
diff --git a/theories/QArith/Qfield.v b/theories/QArith/Qfield.v
index 00500e31..0cf5413e 100644
--- a/theories/QArith/Qfield.v
+++ b/theories/QArith/Qfield.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Qfield.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export Field.
Require Export QArith_base.
diff --git a/theories/QArith/Qreals.v b/theories/QArith/Qreals.v
index 54682197..67bb0ffa 100644
--- a/theories/QArith/Qreals.v
+++ b/theories/QArith/Qreals.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Qreals.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export Rbase.
Require Export QArith_base.
diff --git a/theories/QArith/Qreduction.v b/theories/QArith/Qreduction.v
index 2fa2585d..456d305d 100644
--- a/theories/QArith/Qreduction.v
+++ b/theories/QArith/Qreduction.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Qreduction.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** Normalisation functions for rational numbers. *)
diff --git a/theories/QArith/Qring.v b/theories/QArith/Qring.v
index 8943dc31..7f7a2d09 100644
--- a/theories/QArith/Qring.v
+++ b/theories/QArith/Qring.v
@@ -6,6 +6,6 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Qring.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export Qfield.
diff --git a/theories/Reals/Alembert.v b/theories/Reals/Alembert.v
index dbee0b67..212eea7a 100644
--- a/theories/Reals/Alembert.v
+++ b/theories/Reals/Alembert.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Alembert.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Rbase.
Require Import Rfunctions.
diff --git a/theories/Reals/AltSeries.v b/theories/Reals/AltSeries.v
index e17bf53d..de9f8827 100644
--- a/theories/Reals/AltSeries.v
+++ b/theories/Reals/AltSeries.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
- (*i $Id$ i*)
+ (*i $Id: AltSeries.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Rbase.
Require Import Rfunctions.
diff --git a/theories/Reals/ArithProp.v b/theories/Reals/ArithProp.v
index c0f7e830..84fa8fe1 100644
--- a/theories/Reals/ArithProp.v
+++ b/theories/Reals/ArithProp.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
- (*i $Id$ i*)
+ (*i $Id: ArithProp.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Rbase.
Require Import Rbasic_fun.
diff --git a/theories/Reals/Binomial.v b/theories/Reals/Binomial.v
index 9e3ffa6d..ab352910 100644
--- a/theories/Reals/Binomial.v
+++ b/theories/Reals/Binomial.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
- (*i $Id$ i*)
+ (*i $Id: Binomial.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Rbase.
Require Import Rfunctions.
diff --git a/theories/Reals/Cauchy_prod.v b/theories/Reals/Cauchy_prod.v
index 713e2c04..279fd3d1 100644
--- a/theories/Reals/Cauchy_prod.v
+++ b/theories/Reals/Cauchy_prod.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
- (*i $Id$ i*)
+ (*i $Id: Cauchy_prod.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Rbase.
Require Import Rfunctions.
diff --git a/theories/Reals/Cos_plus.v b/theories/Reals/Cos_plus.v
index 4e4c2b60..e3854afb 100644
--- a/theories/Reals/Cos_plus.v
+++ b/theories/Reals/Cos_plus.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
- (*i $Id$ i*)
+ (*i $Id: Cos_plus.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Rbase.
Require Import Rfunctions.
diff --git a/theories/Reals/Cos_rel.v b/theories/Reals/Cos_rel.v
index 54332d83..99e39169 100644
--- a/theories/Reals/Cos_rel.v
+++ b/theories/Reals/Cos_rel.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Cos_rel.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Rbase.
Require Import Rfunctions.
diff --git a/theories/Reals/DiscrR.v b/theories/Reals/DiscrR.v
index 08b48898..66ee4eb0 100644
--- a/theories/Reals/DiscrR.v
+++ b/theories/Reals/DiscrR.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: DiscrR.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import RIneq.
Require Import Omega.
diff --git a/theories/Reals/Exp_prop.v b/theories/Reals/Exp_prop.v
index 5d46ceae..57198a5e 100644
--- a/theories/Reals/Exp_prop.v
+++ b/theories/Reals/Exp_prop.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Exp_prop.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Rbase.
Require Import Rfunctions.
diff --git a/theories/Reals/Integration.v b/theories/Reals/Integration.v
index 2062db7d..569e122a 100644
--- a/theories/Reals/Integration.v
+++ b/theories/Reals/Integration.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Integration.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export NewtonInt.
Require Export RiemannInt_SF.
diff --git a/theories/Reals/LegacyRfield.v b/theories/Reals/LegacyRfield.v
index a4bb5f72..1528ed64 100644
--- a/theories/Reals/LegacyRfield.v
+++ b/theories/Reals/LegacyRfield.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: LegacyRfield.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export Raxioms.
Require Export LegacyField.
diff --git a/theories/Reals/MVT.v b/theories/Reals/MVT.v
index d69e7ed5..87275e7f 100644
--- a/theories/Reals/MVT.v
+++ b/theories/Reals/MVT.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: MVT.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Rbase.
Require Import Rfunctions.
diff --git a/theories/Reals/NewtonInt.v b/theories/Reals/NewtonInt.v
index 8828c7eb..cfd5d561 100644
--- a/theories/Reals/NewtonInt.v
+++ b/theories/Reals/NewtonInt.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: NewtonInt.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Rbase.
Require Import Rfunctions.
diff --git a/theories/Reals/PSeries_reg.v b/theories/Reals/PSeries_reg.v
index a459fe19..1e882b7a 100644
--- a/theories/Reals/PSeries_reg.v
+++ b/theories/Reals/PSeries_reg.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: PSeries_reg.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Rbase.
Require Import Rfunctions.
diff --git a/theories/Reals/PartSum.v b/theories/Reals/PartSum.v
index e658b900..b1c0c4f9 100644
--- a/theories/Reals/PartSum.v
+++ b/theories/Reals/PartSum.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: PartSum.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Rbase.
Require Import Rfunctions.
diff --git a/theories/Reals/RIneq.v b/theories/Reals/RIneq.v
index 55e14289..5c0cf3e7 100644
--- a/theories/Reals/RIneq.v
+++ b/theories/Reals/RIneq.v
@@ -7,7 +7,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: RIneq.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*********************************************************)
(** * Basic lemmas for the classical real numbers *)
diff --git a/theories/Reals/RList.v b/theories/Reals/RList.v
index 36d04297..85ad4378 100644
--- a/theories/Reals/RList.v
+++ b/theories/Reals/RList.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: RList.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Rbase.
Require Import Rfunctions.
diff --git a/theories/Reals/R_Ifp.v b/theories/Reals/R_Ifp.v
index cf7bdfef..946a8833 100644
--- a/theories/Reals/R_Ifp.v
+++ b/theories/Reals/R_Ifp.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: R_Ifp.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(**********************************************************)
(** Complements for the reals.Integer and fractional part *)
diff --git a/theories/Reals/R_sqr.v b/theories/Reals/R_sqr.v
index fc8149fb..317f523b 100644
--- a/theories/Reals/R_sqr.v
+++ b/theories/Reals/R_sqr.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: R_sqr.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Rbase.
Require Import Rbasic_fun.
diff --git a/theories/Reals/R_sqrt.v b/theories/Reals/R_sqrt.v
index ccecafc1..6eab48c0 100644
--- a/theories/Reals/R_sqrt.v
+++ b/theories/Reals/R_sqrt.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: R_sqrt.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Rbase.
Require Import Rfunctions.
diff --git a/theories/Reals/Ranalysis.v b/theories/Reals/Ranalysis.v
index 17c6e90c..885d97ac 100644
--- a/theories/Reals/Ranalysis.v
+++ b/theories/Reals/Ranalysis.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Ranalysis.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Rbase.
Require Import Rfunctions.
diff --git a/theories/Reals/Ranalysis1.v b/theories/Reals/Ranalysis1.v
index 5d0a7f5a..def01d6f 100644
--- a/theories/Reals/Ranalysis1.v
+++ b/theories/Reals/Ranalysis1.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Ranalysis1.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Rbase.
Require Import Rfunctions.
diff --git a/theories/Reals/Ranalysis2.v b/theories/Reals/Ranalysis2.v
index 838fbaed..b8610d12 100644
--- a/theories/Reals/Ranalysis2.v
+++ b/theories/Reals/Ranalysis2.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Ranalysis2.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Rbase.
Require Import Rfunctions.
diff --git a/theories/Reals/Ranalysis3.v b/theories/Reals/Ranalysis3.v
index 3925b33c..1848ca52 100644
--- a/theories/Reals/Ranalysis3.v
+++ b/theories/Reals/Ranalysis3.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Ranalysis3.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Rbase.
Require Import Rfunctions.
diff --git a/theories/Reals/Ranalysis4.v b/theories/Reals/Ranalysis4.v
index 78d37a1f..97b6d52b 100644
--- a/theories/Reals/Ranalysis4.v
+++ b/theories/Reals/Ranalysis4.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Ranalysis4.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Rbase.
Require Import Rfunctions.
diff --git a/theories/Reals/Raxioms.v b/theories/Reals/Raxioms.v
index f7278562..dca2782c 100644
--- a/theories/Reals/Raxioms.v
+++ b/theories/Reals/Raxioms.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Raxioms.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*********************************************************)
(** Axiomatisation of the classical reals *)
diff --git a/theories/Reals/Rbase.v b/theories/Reals/Rbase.v
index e3e36b11..ab005daf 100644
--- a/theories/Reals/Rbase.v
+++ b/theories/Reals/Rbase.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Rbase.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export Rdefinitions.
Require Export Raxioms.
diff --git a/theories/Reals/Rbasic_fun.v b/theories/Reals/Rbasic_fun.v
index 241232e9..39f2bf6f 100644
--- a/theories/Reals/Rbasic_fun.v
+++ b/theories/Reals/Rbasic_fun.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Rbasic_fun.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*********************************************************)
(** Complements for the real numbers *)
diff --git a/theories/Reals/Rcomplete.v b/theories/Reals/Rcomplete.v
index af91ae3d..6e66e904 100644
--- a/theories/Reals/Rcomplete.v
+++ b/theories/Reals/Rcomplete.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Rcomplete.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Rbase.
Require Import Rfunctions.
diff --git a/theories/Reals/Rdefinitions.v b/theories/Reals/Rdefinitions.v
index 311c7a26..301e0dcf 100644
--- a/theories/Reals/Rdefinitions.v
+++ b/theories/Reals/Rdefinitions.v
@@ -5,7 +5,7 @@
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Rdefinitions.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*********************************************************)
diff --git a/theories/Reals/Rderiv.v b/theories/Reals/Rderiv.v
index 7aa26fca..2b8c95f7 100644
--- a/theories/Reals/Rderiv.v
+++ b/theories/Reals/Rderiv.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Rderiv.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*********************************************************)
(** Definition of the derivative,continuity *)
diff --git a/theories/Reals/Reals.v b/theories/Reals/Reals.v
index 3621a7da..f0ce1353 100644
--- a/theories/Reals/Reals.v
+++ b/theories/Reals/Reals.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Reals.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** The library REALS is divided in 6 parts :
- Rbase: basic lemmas on R
diff --git a/theories/Reals/Rfunctions.v b/theories/Reals/Rfunctions.v
index 2e028411..f56b68c6 100644
--- a/theories/Reals/Rfunctions.v
+++ b/theories/Reals/Rfunctions.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Rfunctions.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i Some properties about pow and sum have been made with John Harrison i*)
(*i Some Lemmas (about pow and powerRZ) have been done by Laurent Thery i*)
diff --git a/theories/Reals/Rgeom.v b/theories/Reals/Rgeom.v
index 5f96d5e7..703ecfd4 100644
--- a/theories/Reals/Rgeom.v
+++ b/theories/Reals/Rgeom.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Rgeom.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Rbase.
Require Import Rfunctions.
diff --git a/theories/Reals/RiemannInt.v b/theories/Reals/RiemannInt.v
index 53a81ac2..4534a468 100644
--- a/theories/Reals/RiemannInt.v
+++ b/theories/Reals/RiemannInt.v
@@ -7,7 +7,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: RiemannInt.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Rfunctions.
Require Import SeqSeries.
diff --git a/theories/Reals/RiemannInt_SF.v b/theories/Reals/RiemannInt_SF.v
index cfb991f9..976050f7 100644
--- a/theories/Reals/RiemannInt_SF.v
+++ b/theories/Reals/RiemannInt_SF.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: RiemannInt_SF.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Rbase.
Require Import Rfunctions.
diff --git a/theories/Reals/Rlimit.v b/theories/Reals/Rlimit.v
index d2a65f42..72aa9971 100644
--- a/theories/Reals/Rlimit.v
+++ b/theories/Reals/Rlimit.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Rlimit.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*********************************************************)
(** Definition of the limit *)
diff --git a/theories/Reals/Rpow_def.v b/theories/Reals/Rpow_def.v
index e8f034b6..60fc4ca9 100644
--- a/theories/Reals/Rpow_def.v
+++ b/theories/Reals/Rpow_def.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: Rpow_def.v 13323 2010-07-24 15:57:30Z herbelin $ *)
Require Import Rdefinitions.
diff --git a/theories/Reals/Rpower.v b/theories/Reals/Rpower.v
index 35c90d24..4c3a04f6 100644
--- a/theories/Reals/Rpower.v
+++ b/theories/Reals/Rpower.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Rpower.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i Due to L.Thery i*)
(************************************************************)
diff --git a/theories/Reals/Rprod.v b/theories/Reals/Rprod.v
index 30b62643..e4269eb7 100644
--- a/theories/Reals/Rprod.v
+++ b/theories/Reals/Rprod.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Rprod.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Compare.
Require Import Rbase.
diff --git a/theories/Reals/Rseries.v b/theories/Reals/Rseries.v
index 646b2bc0..f7e05fce 100644
--- a/theories/Reals/Rseries.v
+++ b/theories/Reals/Rseries.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Rseries.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Rbase.
Require Import Rfunctions.
diff --git a/theories/Reals/Rsigma.v b/theories/Reals/Rsigma.v
index 54a13e78..4cfca607 100644
--- a/theories/Reals/Rsigma.v
+++ b/theories/Reals/Rsigma.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Rsigma.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Rbase.
Require Import Rfunctions.
diff --git a/theories/Reals/Rsqrt_def.v b/theories/Reals/Rsqrt_def.v
index 4c2b423e..9f606fe3 100644
--- a/theories/Reals/Rsqrt_def.v
+++ b/theories/Reals/Rsqrt_def.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Rsqrt_def.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Sumbool.
Require Import Rbase.
diff --git a/theories/Reals/Rtopology.v b/theories/Reals/Rtopology.v
index b37de502..9b332eea 100644
--- a/theories/Reals/Rtopology.v
+++ b/theories/Reals/Rtopology.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Rtopology.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Rbase.
Require Import Rfunctions.
diff --git a/theories/Reals/Rtrigo.v b/theories/Reals/Rtrigo.v
index 46914093..bdbea3a6 100644
--- a/theories/Reals/Rtrigo.v
+++ b/theories/Reals/Rtrigo.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Rtrigo.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Rbase.
Require Import Rfunctions.
diff --git a/theories/Reals/Rtrigo_alt.v b/theories/Reals/Rtrigo_alt.v
index d485ad29..9718d20d 100644
--- a/theories/Reals/Rtrigo_alt.v
+++ b/theories/Reals/Rtrigo_alt.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Rtrigo_alt.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Rbase.
Require Import Rfunctions.
diff --git a/theories/Reals/Rtrigo_calc.v b/theories/Reals/Rtrigo_calc.v
index b1d47191..9fd7d37c 100644
--- a/theories/Reals/Rtrigo_calc.v
+++ b/theories/Reals/Rtrigo_calc.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Rtrigo_calc.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Rbase.
Require Import Rfunctions.
diff --git a/theories/Reals/Rtrigo_def.v b/theories/Reals/Rtrigo_def.v
index eb1347a2..b3c4ca23 100644
--- a/theories/Reals/Rtrigo_def.v
+++ b/theories/Reals/Rtrigo_def.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Rtrigo_def.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Rbase.
Require Import Rfunctions.
diff --git a/theories/Reals/Rtrigo_fun.v b/theories/Reals/Rtrigo_fun.v
index e3338c44..2cb5eadd 100644
--- a/theories/Reals/Rtrigo_fun.v
+++ b/theories/Reals/Rtrigo_fun.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Rtrigo_fun.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Rbase.
Require Import Rfunctions.
diff --git a/theories/Reals/Rtrigo_reg.v b/theories/Reals/Rtrigo_reg.v
index c5ac16ac..7e771444 100644
--- a/theories/Reals/Rtrigo_reg.v
+++ b/theories/Reals/Rtrigo_reg.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Rtrigo_reg.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Rbase.
Require Import Rfunctions.
diff --git a/theories/Reals/SeqProp.v b/theories/Reals/SeqProp.v
index 0dcb5ccf..f984dc9c 100644
--- a/theories/Reals/SeqProp.v
+++ b/theories/Reals/SeqProp.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: SeqProp.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Rbase.
Require Import Rfunctions.
diff --git a/theories/Reals/SeqSeries.v b/theories/Reals/SeqSeries.v
index e13c366e..35320589 100644
--- a/theories/Reals/SeqSeries.v
+++ b/theories/Reals/SeqSeries.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: SeqSeries.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Rbase.
Require Import Rfunctions.
diff --git a/theories/Reals/SplitAbsolu.v b/theories/Reals/SplitAbsolu.v
index 06768612..cf050684 100644
--- a/theories/Reals/SplitAbsolu.v
+++ b/theories/Reals/SplitAbsolu.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: SplitAbsolu.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Rbasic_fun.
diff --git a/theories/Reals/SplitRmult.v b/theories/Reals/SplitRmult.v
index 7ad0dedc..6eb10370 100644
--- a/theories/Reals/SplitRmult.v
+++ b/theories/Reals/SplitRmult.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: SplitRmult.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i Lemma mult_non_zero :(r1,r2:R)``r1<>0`` /\ ``r2<>0`` -> ``r1*r2<>0``. i*)
diff --git a/theories/Reals/Sqrt_reg.v b/theories/Reals/Sqrt_reg.v
index 2f897e73..9eea1c53 100644
--- a/theories/Reals/Sqrt_reg.v
+++ b/theories/Reals/Sqrt_reg.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Sqrt_reg.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Rbase.
Require Import Rfunctions.
diff --git a/theories/Relations/Operators_Properties.v b/theories/Relations/Operators_Properties.v
index a2f4771e..ab431878 100644
--- a/theories/Relations/Operators_Properties.v
+++ b/theories/Relations/Operators_Properties.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Operators_Properties.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(************************************************************************)
(** * Some properties of the operators on relations *)
diff --git a/theories/Relations/Relation_Definitions.v b/theories/Relations/Relation_Definitions.v
index 48e65a1d..71338aa5 100644
--- a/theories/Relations/Relation_Definitions.v
+++ b/theories/Relations/Relation_Definitions.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Relation_Definitions.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Section Relation_Definition.
diff --git a/theories/Relations/Relation_Operators.v b/theories/Relations/Relation_Operators.v
index a4e4b3e6..8aba6275 100644
--- a/theories/Relations/Relation_Operators.v
+++ b/theories/Relations/Relation_Operators.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Relation_Operators.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(************************************************************************)
(** * Bruno Barras, Cristina Cornes *)
diff --git a/theories/Relations/Relations.v b/theories/Relations/Relations.v
index 22d17493..f98db89b 100644
--- a/theories/Relations/Relations.v
+++ b/theories/Relations/Relations.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Relations.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export Relation_Definitions.
Require Export Relation_Operators.
diff --git a/theories/Setoids/Setoid.v b/theories/Setoids/Setoid.v
index 3262c7ef..8afaedd6 100644
--- a/theories/Setoids/Setoid.v
+++ b/theories/Setoids/Setoid.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$: i*)
+(*i $Id: Setoid.v 13323 2010-07-24 15:57:30Z herbelin $: i*)
Require Export Coq.Classes.SetoidTactics.
diff --git a/theories/Sets/Classical_sets.v b/theories/Sets/Classical_sets.v
index 824fd036..b20423e0 100644
--- a/theories/Sets/Classical_sets.v
+++ b/theories/Sets/Classical_sets.v
@@ -24,7 +24,7 @@
(* in Summer 1995. Several developments by E. Ledinot were an inspiration. *)
(****************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Classical_sets.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export Ensembles.
Require Export Constructive_sets.
diff --git a/theories/Sets/Constructive_sets.v b/theories/Sets/Constructive_sets.v
index 8e0ab3b0..bb7235ff 100644
--- a/theories/Sets/Constructive_sets.v
+++ b/theories/Sets/Constructive_sets.v
@@ -24,7 +24,7 @@
(* in Summer 1995. Several developments by E. Ledinot were an inspiration. *)
(****************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Constructive_sets.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export Ensembles.
diff --git a/theories/Sets/Cpo.v b/theories/Sets/Cpo.v
index 0781781a..8591aef1 100644
--- a/theories/Sets/Cpo.v
+++ b/theories/Sets/Cpo.v
@@ -24,7 +24,7 @@
(* in Summer 1995. Several developments by E. Ledinot were an inspiration. *)
(****************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Cpo.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export Ensembles.
Require Export Relations_1.
diff --git a/theories/Sets/Ensembles.v b/theories/Sets/Ensembles.v
index c96c21b4..1fee462d 100644
--- a/theories/Sets/Ensembles.v
+++ b/theories/Sets/Ensembles.v
@@ -24,7 +24,7 @@
(* in Summer 1995. Several developments by E. Ledinot were an inspiration. *)
(****************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Ensembles.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Section Ensembles.
Variable U : Type.
diff --git a/theories/Sets/Finite_sets.v b/theories/Sets/Finite_sets.v
index cad440b4..f690e894 100644
--- a/theories/Sets/Finite_sets.v
+++ b/theories/Sets/Finite_sets.v
@@ -24,7 +24,7 @@
(* in Summer 1995. Several developments by E. Ledinot were an inspiration. *)
(****************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Finite_sets.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Ensembles.
diff --git a/theories/Sets/Finite_sets_facts.v b/theories/Sets/Finite_sets_facts.v
index cc41a2ea..d351cc74 100644
--- a/theories/Sets/Finite_sets_facts.v
+++ b/theories/Sets/Finite_sets_facts.v
@@ -24,7 +24,7 @@
(* in Summer 1995. Several developments by E. Ledinot were an inspiration. *)
(****************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Finite_sets_facts.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export Finite_sets.
Require Export Constructive_sets.
diff --git a/theories/Sets/Image.v b/theories/Sets/Image.v
index c48c844c..a58e12e6 100644
--- a/theories/Sets/Image.v
+++ b/theories/Sets/Image.v
@@ -24,7 +24,7 @@
(* in Summer 1995. Several developments by E. Ledinot were an inspiration. *)
(****************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Image.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export Finite_sets.
Require Export Constructive_sets.
diff --git a/theories/Sets/Infinite_sets.v b/theories/Sets/Infinite_sets.v
index 210205ed..c85cd8d2 100644
--- a/theories/Sets/Infinite_sets.v
+++ b/theories/Sets/Infinite_sets.v
@@ -24,7 +24,7 @@
(* in Summer 1995. Several developments by E. Ledinot were an inspiration. *)
(****************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Infinite_sets.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export Finite_sets.
Require Export Constructive_sets.
diff --git a/theories/Sets/Integers.v b/theories/Sets/Integers.v
index 29208d03..37173094 100644
--- a/theories/Sets/Integers.v
+++ b/theories/Sets/Integers.v
@@ -24,7 +24,7 @@
(* in Summer 1995. Several developments by E. Ledinot were an inspiration. *)
(****************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Integers.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export Finite_sets.
Require Export Constructive_sets.
diff --git a/theories/Sets/Multiset.v b/theories/Sets/Multiset.v
index 07fe2721..685a680f 100644
--- a/theories/Sets/Multiset.v
+++ b/theories/Sets/Multiset.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Multiset.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(* G. Huet 1-9-95 *)
diff --git a/theories/Sets/Partial_Order.v b/theories/Sets/Partial_Order.v
index 95eb5102..671c9690 100644
--- a/theories/Sets/Partial_Order.v
+++ b/theories/Sets/Partial_Order.v
@@ -24,7 +24,7 @@
(* in Summer 1995. Several developments by E. Ledinot were an inspiration. *)
(****************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Partial_Order.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export Ensembles.
Require Export Relations_1.
diff --git a/theories/Sets/Permut.v b/theories/Sets/Permut.v
index e1caff4f..844989c0 100644
--- a/theories/Sets/Permut.v
+++ b/theories/Sets/Permut.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Permut.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(* G. Huet 1-9-95 *)
diff --git a/theories/Sets/Powerset.v b/theories/Sets/Powerset.v
index b6df89f3..ae9dbb43 100644
--- a/theories/Sets/Powerset.v
+++ b/theories/Sets/Powerset.v
@@ -24,7 +24,7 @@
(* in Summer 1995. Several developments by E. Ledinot were an inspiration. *)
(****************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Powerset.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export Ensembles.
Require Export Relations_1.
diff --git a/theories/Sets/Powerset_Classical_facts.v b/theories/Sets/Powerset_Classical_facts.v
index 93cb653a..f9da4816 100644
--- a/theories/Sets/Powerset_Classical_facts.v
+++ b/theories/Sets/Powerset_Classical_facts.v
@@ -24,7 +24,7 @@
(* in Summer 1995. Several developments by E. Ledinot were an inspiration. *)
(****************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Powerset_Classical_facts.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export Ensembles.
Require Export Constructive_sets.
diff --git a/theories/Sets/Powerset_facts.v b/theories/Sets/Powerset_facts.v
index 7186881a..ab5bbaf9 100644
--- a/theories/Sets/Powerset_facts.v
+++ b/theories/Sets/Powerset_facts.v
@@ -24,7 +24,7 @@
(* in Summer 1995. Several developments by E. Ledinot were an inspiration. *)
(****************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Powerset_facts.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export Ensembles.
Require Export Constructive_sets.
diff --git a/theories/Sets/Relations_1.v b/theories/Sets/Relations_1.v
index 54a5bd01..4677219e 100644
--- a/theories/Sets/Relations_1.v
+++ b/theories/Sets/Relations_1.v
@@ -24,7 +24,7 @@
(* in Summer 1995. Several developments by E. Ledinot were an inspiration. *)
(****************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Relations_1.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Section Relations_1.
Variable U : Type.
diff --git a/theories/Sets/Relations_1_facts.v b/theories/Sets/Relations_1_facts.v
index a8d8209b..b6c0df25 100644
--- a/theories/Sets/Relations_1_facts.v
+++ b/theories/Sets/Relations_1_facts.v
@@ -24,7 +24,7 @@
(* in Summer 1995. Several developments by E. Ledinot were an inspiration. *)
(****************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Relations_1_facts.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export Relations_1.
diff --git a/theories/Sets/Relations_2.v b/theories/Sets/Relations_2.v
index e9cba979..9f7c831c 100644
--- a/theories/Sets/Relations_2.v
+++ b/theories/Sets/Relations_2.v
@@ -24,7 +24,7 @@
(* in Summer 1995. Several developments by E. Ledinot were an inspiration. *)
(****************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Relations_2.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export Relations_1.
diff --git a/theories/Sets/Relations_2_facts.v b/theories/Sets/Relations_2_facts.v
index cbd596c3..039bae87 100644
--- a/theories/Sets/Relations_2_facts.v
+++ b/theories/Sets/Relations_2_facts.v
@@ -24,7 +24,7 @@
(* in Summer 1995. Several developments by E. Ledinot were an inspiration. *)
(****************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Relations_2_facts.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export Relations_1.
Require Export Relations_1_facts.
diff --git a/theories/Sets/Relations_3.v b/theories/Sets/Relations_3.v
index 99a68efc..d4a3d87c 100644
--- a/theories/Sets/Relations_3.v
+++ b/theories/Sets/Relations_3.v
@@ -24,7 +24,7 @@
(* in Summer 1995. Several developments by E. Ledinot were an inspiration. *)
(****************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Relations_3.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export Relations_1.
Require Export Relations_2.
diff --git a/theories/Sets/Relations_3_facts.v b/theories/Sets/Relations_3_facts.v
index f85128ae..1a22aff9 100644
--- a/theories/Sets/Relations_3_facts.v
+++ b/theories/Sets/Relations_3_facts.v
@@ -24,7 +24,7 @@
(* in Summer 1995. Several developments by E. Ledinot were an inspiration. *)
(****************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Relations_3_facts.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export Relations_1.
Require Export Relations_1_facts.
diff --git a/theories/Sets/Uniset.v b/theories/Sets/Uniset.v
index 9803edc8..78da067d 100644
--- a/theories/Sets/Uniset.v
+++ b/theories/Sets/Uniset.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Uniset.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** Sets as characteristic functions *)
diff --git a/theories/Sorting/Heap.v b/theories/Sorting/Heap.v
index 2e463120..eb53f061 100644
--- a/theories/Sorting/Heap.v
+++ b/theories/Sorting/Heap.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Heap.v 13346 2010-07-28 17:17:32Z msozeau $ i*)
(** This file is deprecated, for a tree on list, use [Mergesort.v]. *)
@@ -136,45 +136,46 @@ Section defs.
(munion (list_contents _ eqA_dec l1) (list_contents _ eqA_dec l2)) ->
(forall a, HdRel leA a l1 -> HdRel leA a l2 -> HdRel leA a l) ->
merge_lem l1 l2.
-
+ Require Import Morphisms.
+
+ Instance: Equivalence (@meq A).
+ Proof. constructor; auto with datatypes. red. apply meq_trans. Defined.
+
+ Instance: Proper (@meq A ++> @meq _ ++> @meq _) (@munion A).
+ Proof. intros x y H x' y' H'. now apply meq_congr. Qed.
+
Lemma merge :
forall l1:list A, Sorted leA l1 ->
forall l2:list A, Sorted leA l2 -> merge_lem l1 l2.
Proof.
- simple induction 1; intros.
+ fix 1; intros; destruct l1.
apply merge_exist with l2; auto with datatypes.
- elim H2; intros.
- apply merge_exist with (a :: l); simpl in |- *; auto using cons_sort with datatypes.
+ rename l1 into l.
+ revert l2 H0. fix 1. intros.
+ destruct l2 as [|a0 l0].
+ apply merge_exist with (a :: l); simpl; auto with datatypes.
elim (leA_dec a a0); intros.
(* 1 (leA a a0) *)
- cut (merge_lem l (a0 :: l0)); auto using cons_sort with datatypes.
- intros [l3 l3sorted l3contents Hrec].
- apply merge_exist with (a :: l3); simpl in |- *;
+ apply Sorted_inv in H. destruct H.
+ destruct (merge l H (a0 :: l0) H0).
+ apply merge_exist with (a :: l1). clear merge merge0.
auto using cons_sort, cons_leA with datatypes.
- apply meq_trans with
- (munion (singletonBag a)
- (munion (list_contents _ eqA_dec l)
- (list_contents _ eqA_dec (a0 :: l0)))).
- apply meq_right; trivial with datatypes.
- apply meq_sym; apply munion_ass.
- intros; apply cons_leA.
+ simpl. rewrite m. now rewrite munion_ass.
+ intros. apply cons_leA.
apply (@HdRel_inv _ leA) with l; trivial with datatypes.
(* 2 (leA a0 a) *)
- elim X0; simpl in |- *; intros.
- apply merge_exist with (a0 :: l3); simpl in |- *;
+ apply Sorted_inv in H0. destruct H0.
+ destruct (merge0 l0 H0). clear merge merge0.
+ apply merge_exist with (a0 :: l1);
auto using cons_sort, cons_leA with datatypes.
- apply meq_trans with
- (munion (singletonBag a0)
- (munion (munion (singletonBag a) (list_contents _ eqA_dec l))
- (list_contents _ eqA_dec l0))).
- apply meq_right; trivial with datatypes.
- apply munion_perm_left.
- intros; apply cons_leA; apply HdRel_inv with (l:=l0); trivial with datatypes.
+ simpl; rewrite m. simpl. setoid_rewrite munion_ass at 1. rewrite munion_comm.
+ repeat rewrite munion_ass. setoid_rewrite munion_comm at 3. reflexivity.
+ intros. apply cons_leA.
+ apply (@HdRel_inv _ leA) with l0; trivial with datatypes.
Qed.
-
(** ** From trees to multisets *)
(** contents of a tree as a multiset *)
diff --git a/theories/Sorting/Mergesort.v b/theories/Sorting/Mergesort.v
index f52a24b4..e576db2b 100644
--- a/theories/Sorting/Mergesort.v
+++ b/theories/Sorting/Mergesort.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Mergesort.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** A modular implementation of mergesort (the complexity is O(n.log n) in
the length of the list) *)
diff --git a/theories/Sorting/PermutEq.v b/theories/Sorting/PermutEq.v
index 1388df6a..00a09051 100644
--- a/theories/Sorting/PermutEq.v
+++ b/theories/Sorting/PermutEq.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: PermutEq.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Relations Setoid SetoidList List Multiset PermutSetoid Permutation.
diff --git a/theories/Sorting/PermutSetoid.v b/theories/Sorting/PermutSetoid.v
index f5f91887..e47e2b84 100644
--- a/theories/Sorting/PermutSetoid.v
+++ b/theories/Sorting/PermutSetoid.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: PermutSetoid.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Omega Relations Multiset SetoidList.
diff --git a/theories/Sorting/Permutation.v b/theories/Sorting/Permutation.v
index f88c29cb..1e145f57 100644
--- a/theories/Sorting/Permutation.v
+++ b/theories/Sorting/Permutation.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Permutation.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*********************************************************************)
(** ** List permutations as a composition of adjacent transpositions *)
diff --git a/theories/Sorting/Sorted.v b/theories/Sorting/Sorted.v
index 7d75d60a..ab399d40 100644
--- a/theories/Sorting/Sorted.v
+++ b/theories/Sorting/Sorted.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Sorted.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(* Made by Hugo Herbelin *)
diff --git a/theories/Sorting/Sorting.v b/theories/Sorting/Sorting.v
index 85d89441..860e0517 100644
--- a/theories/Sorting/Sorting.v
+++ b/theories/Sorting/Sorting.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Sorting.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export Sorted.
Require Export Mergesort.
diff --git a/theories/Strings/Ascii.v b/theories/Strings/Ascii.v
index de1684b4..31a18f25 100644
--- a/theories/Strings/Ascii.v
+++ b/theories/Strings/Ascii.v
@@ -7,7 +7,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: Ascii.v 13323 2010-07-24 15:57:30Z herbelin $ *)
(** Contributed by Laurent Théry (INRIA);
Adapted to Coq V8 by the Coq Development Team *)
diff --git a/theories/Strings/String.v b/theories/Strings/String.v
index c2d59679..4b7c1c2d 100644
--- a/theories/Strings/String.v
+++ b/theories/Strings/String.v
@@ -7,7 +7,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: String.v 13323 2010-07-24 15:57:30Z herbelin $ *)
(** Contributed by Laurent Théry (INRIA);
Adapted to Coq V8 by the Coq Development Team *)
diff --git a/theories/Structures/DecidableType.v b/theories/Structures/DecidableType.v
index 2c72e30b..18153436 100644
--- a/theories/Structures/DecidableType.v
+++ b/theories/Structures/DecidableType.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
-(* $Id$ *)
+(* $Id: DecidableType.v 12641 2010-01-07 15:32:52Z letouzey $ *)
Require Export SetoidList.
Require Equalities.
diff --git a/theories/Structures/DecidableTypeEx.v b/theories/Structures/DecidableTypeEx.v
index 4407ead4..ac1f014b 100644
--- a/theories/Structures/DecidableTypeEx.v
+++ b/theories/Structures/DecidableTypeEx.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
-(* $Id$ *)
+(* $Id: DecidableTypeEx.v 12641 2010-01-07 15:32:52Z letouzey $ *)
Require Import DecidableType OrderedType OrderedTypeEx.
Set Implicit Arguments.
diff --git a/theories/Structures/Equalities.v b/theories/Structures/Equalities.v
index 487b1d0c..d205c0e0 100644
--- a/theories/Structures/Equalities.v
+++ b/theories/Structures/Equalities.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
-(* $Id$ *)
+(* $Id: Equalities.v 12662 2010-01-13 16:53:01Z letouzey $ *)
Require Export RelationClasses.
diff --git a/theories/Structures/OrderedType.v b/theories/Structures/OrderedType.v
index 72fbe796..57f491d2 100644
--- a/theories/Structures/OrderedType.v
+++ b/theories/Structures/OrderedType.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
-(* $Id$ *)
+(* $Id: OrderedType.v 12732 2010-02-10 22:46:59Z letouzey $ *)
Require Export SetoidList Morphisms OrdersTac.
Set Implicit Arguments.
diff --git a/theories/Structures/OrderedTypeAlt.v b/theories/Structures/OrderedTypeAlt.v
index 23ae4c85..f6c1532b 100644
--- a/theories/Structures/OrderedTypeAlt.v
+++ b/theories/Structures/OrderedTypeAlt.v
@@ -5,7 +5,7 @@
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
-(* $Id$ *)
+(* $Id: OrderedTypeAlt.v 12384 2009-10-13 14:39:51Z letouzey $ *)
Require Import OrderedType.
diff --git a/theories/Structures/OrderedTypeEx.v b/theories/Structures/OrderedTypeEx.v
index b4dbceba..128cd576 100644
--- a/theories/Structures/OrderedTypeEx.v
+++ b/theories/Structures/OrderedTypeEx.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
-(* $Id$ *)
+(* $Id: OrderedTypeEx.v 13297 2010-07-19 23:32:42Z letouzey $ *)
Require Import OrderedType.
Require Import ZArith.
diff --git a/theories/Structures/Orders.v b/theories/Structures/Orders.v
index bddd461a..5567b743 100644
--- a/theories/Structures/Orders.v
+++ b/theories/Structures/Orders.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
-(* $Id$ *)
+(* $Id: Orders.v 13276 2010-07-10 14:34:44Z letouzey $ *)
Require Export Relations Morphisms Setoid Equalities.
Set Implicit Arguments.
diff --git a/theories/Structures/OrdersAlt.v b/theories/Structures/OrdersAlt.v
index d86b02a1..21ef8eb8 100644
--- a/theories/Structures/OrdersAlt.v
+++ b/theories/Structures/OrdersAlt.v
@@ -11,7 +11,7 @@
* Institution: LRI, CNRS UMR 8623 - Université Paris Sud
* 91405 Orsay, France *)
-(* $Id$ *)
+(* $Id: OrdersAlt.v 12754 2010-02-12 16:21:48Z letouzey $ *)
Require Import OrderedType Orders.
Set Implicit Arguments.
diff --git a/theories/Structures/OrdersEx.v b/theories/Structures/OrdersEx.v
index 56f1d5de..9f83d82b 100644
--- a/theories/Structures/OrdersEx.v
+++ b/theories/Structures/OrdersEx.v
@@ -11,7 +11,7 @@
* Institution: LRI, CNRS UMR 8623 - Université Paris Sud
* 91405 Orsay, France *)
-(* $Id$ *)
+(* $Id: OrdersEx.v 12641 2010-01-07 15:32:52Z letouzey $ *)
Require Import Orders NatOrderedType POrderedType NOrderedType
ZOrderedType RelationPairs EqualitiesFacts.
diff --git a/theories/Unicode/Utf8_core.v b/theories/Unicode/Utf8_core.v
new file mode 100644
index 00000000..a42de3ab
--- /dev/null
+++ b/theories/Unicode/Utf8_core.v
@@ -0,0 +1,25 @@
+(* -*- coding:utf-8 -*- *)
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* Logic *)
+Notation "∀ x .. y , P" := (forall x, .. (forall y, P) ..)
+ (at level 200, x binder, y binder, right associativity) : type_scope.
+Notation "∃ x .. y , P" := (exists x, .. (exists y, P) ..)
+ (at level 200, x binder, y binder, right associativity) : type_scope.
+
+Notation "x ∨ y" := (x \/ y) (at level 85, right associativity) : type_scope.
+Notation "x ∧ y" := (x /\ y) (at level 80, right associativity) : type_scope.
+Notation "x → y" := (x -> y) (at level 90, right associativity): type_scope.
+Notation "x ↔ y" := (x <-> y) (at level 95, no associativity): type_scope.
+Notation "¬ x" := (~x) (at level 75, right associativity) : type_scope.
+Notation "x ≠ y" := (x <> y) (at level 70) : type_scope.
+
+(* Abstraction *)
+Notation "'λ' x .. y , t" := (fun x => .. (fun y => t) ..)
+ (at level 200, x binder, y binder, right associativity).
diff --git a/theories/Unicode/vo.itarget b/theories/Unicode/vo.itarget
index 243a40b7..7be1b996 100644
--- a/theories/Unicode/vo.itarget
+++ b/theories/Unicode/vo.itarget
@@ -1 +1,2 @@
Utf8.vo
+Utf8_core.vo
diff --git a/theories/Wellfounded/Disjoint_Union.v b/theories/Wellfounded/Disjoint_Union.v
index 30041b86..7fbddb9e 100644
--- a/theories/Wellfounded/Disjoint_Union.v
+++ b/theories/Wellfounded/Disjoint_Union.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Disjoint_Union.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** Author: Cristina Cornes
From : Constructing Recursion Operators in Type Theory
diff --git a/theories/Wellfounded/Inclusion.v b/theories/Wellfounded/Inclusion.v
index 80b2e73c..0a72a77a 100644
--- a/theories/Wellfounded/Inclusion.v
+++ b/theories/Wellfounded/Inclusion.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Inclusion.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** Author: Bruno Barras *)
diff --git a/theories/Wellfounded/Inverse_Image.v b/theories/Wellfounded/Inverse_Image.v
index 762d26a9..6aa7a878 100644
--- a/theories/Wellfounded/Inverse_Image.v
+++ b/theories/Wellfounded/Inverse_Image.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Inverse_Image.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** Author: Bruno Barras *)
diff --git a/theories/Wellfounded/Lexicographic_Exponentiation.v b/theories/Wellfounded/Lexicographic_Exponentiation.v
index f27746c8..db7b106f 100644
--- a/theories/Wellfounded/Lexicographic_Exponentiation.v
+++ b/theories/Wellfounded/Lexicographic_Exponentiation.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Lexicographic_Exponentiation.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** Author: Cristina Cornes
diff --git a/theories/Wellfounded/Lexicographic_Product.v b/theories/Wellfounded/Lexicographic_Product.v
index 8a955c34..29fabbc2 100644
--- a/theories/Wellfounded/Lexicographic_Product.v
+++ b/theories/Wellfounded/Lexicographic_Product.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Lexicographic_Product.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** Authors: Bruno Barras, Cristina Cornes *)
diff --git a/theories/Wellfounded/Transitive_Closure.v b/theories/Wellfounded/Transitive_Closure.v
index 7c373495..c5cd239a 100644
--- a/theories/Wellfounded/Transitive_Closure.v
+++ b/theories/Wellfounded/Transitive_Closure.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Transitive_Closure.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** Author: Bruno Barras *)
diff --git a/theories/Wellfounded/Union.v b/theories/Wellfounded/Union.v
index 50777a3e..3bc7470f 100644
--- a/theories/Wellfounded/Union.v
+++ b/theories/Wellfounded/Union.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Union.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** Author: Bruno Barras *)
diff --git a/theories/Wellfounded/Well_Ordering.v b/theories/Wellfounded/Well_Ordering.v
index 8d298058..0f675cfa 100644
--- a/theories/Wellfounded/Well_Ordering.v
+++ b/theories/Wellfounded/Well_Ordering.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Well_Ordering.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** Author: Cristina Cornes.
From: Constructing Recursion Operators in Type Theory
diff --git a/theories/Wellfounded/Wellfounded.v b/theories/Wellfounded/Wellfounded.v
index 77d82219..1ab6ac87 100644
--- a/theories/Wellfounded/Wellfounded.v
+++ b/theories/Wellfounded/Wellfounded.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Wellfounded.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Export Disjoint_Union.
Require Export Inclusion.
diff --git a/theories/ZArith/BinInt.v b/theories/ZArith/BinInt.v
index 5dbeffa4..2a615311 100644
--- a/theories/ZArith/BinInt.v
+++ b/theories/ZArith/BinInt.v
@@ -7,7 +7,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: BinInt.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(***********************************************************)
(** Binary Integers (Pierre Crégut, CNET, Lannion, France) *)
diff --git a/theories/ZArith/Int.v b/theories/ZArith/Int.v
index 30c08fdc..c0123ca8 100644
--- a/theories/ZArith/Int.v
+++ b/theories/ZArith/Int.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
-(* $Id$ *)
+(* $Id: Int.v 12363 2009-09-28 15:04:07Z letouzey $ *)
(** * An light axiomatization of integers (used in FSetAVL). *)
diff --git a/theories/ZArith/Wf_Z.v b/theories/ZArith/Wf_Z.v
index f073463f..d449100c 100644
--- a/theories/ZArith/Wf_Z.v
+++ b/theories/ZArith/Wf_Z.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Wf_Z.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import BinInt.
Require Import Zcompare.
diff --git a/theories/ZArith/ZArith.v b/theories/ZArith/ZArith.v
index e3937278..96d42077 100644
--- a/theories/ZArith/ZArith.v
+++ b/theories/ZArith/ZArith.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: ZArith.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** Library for manipulating integers based on binary encoding *)
diff --git a/theories/ZArith/ZArith_base.v b/theories/ZArith/ZArith_base.v
index 6a60a021..4af8eb8f 100644
--- a/theories/ZArith/ZArith_base.v
+++ b/theories/ZArith/ZArith_base.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: ZArith_base.v 13323 2010-07-24 15:57:30Z herbelin $ *)
(** Library for manipulating integers based on binary encoding.
These are the basic modules, required by [Omega] and [Ring] for instance.
diff --git a/theories/ZArith/ZArith_dec.v b/theories/ZArith/ZArith_dec.v
index c4d7cef4..1c5efb07 100644
--- a/theories/ZArith/ZArith_dec.v
+++ b/theories/ZArith/ZArith_dec.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: ZArith_dec.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Sumbool.
diff --git a/theories/ZArith/Zabs.v b/theories/ZArith/Zabs.v
index 2c1b8e74..0057c29c 100644
--- a/theories/ZArith/Zabs.v
+++ b/theories/ZArith/Zabs.v
@@ -6,7 +6,7 @@
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Zabs.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** Binary Integers (Pierre Crégut (CNET, Lannion, France) *)
diff --git a/theories/ZArith/Zbool.v b/theories/ZArith/Zbool.v
index fcc2f5b8..79cef8f9 100644
--- a/theories/ZArith/Zbool.v
+++ b/theories/ZArith/Zbool.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: Zbool.v 13323 2010-07-24 15:57:30Z herbelin $ *)
Require Import BinInt.
Require Import Zeven.
diff --git a/theories/ZArith/Zcomplements.v b/theories/ZArith/Zcomplements.v
index d8a5781c..2163e211 100644
--- a/theories/ZArith/Zcomplements.v
+++ b/theories/ZArith/Zcomplements.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Zcomplements.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import ZArithRing.
Require Import ZArith_base.
diff --git a/theories/ZArith/Zdigits.v b/theories/ZArith/Zdigits.v
index 71466e9e..78a78007 100644
--- a/theories/ZArith/Zdigits.v
+++ b/theories/ZArith/Zdigits.v
@@ -7,7 +7,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Zdigits.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** Bit vectors interpreted as integers.
Contribution by Jean Duprat (ENS Lyon). *)
diff --git a/theories/ZArith/Zdiv.v b/theories/ZArith/Zdiv.v
index 78dd7050..0f2268cd 100644
--- a/theories/ZArith/Zdiv.v
+++ b/theories/ZArith/Zdiv.v
@@ -7,7 +7,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Zdiv.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(* Contribution by Claude Marché and Xavier Urbain *)
diff --git a/theories/ZArith/Zeven.v b/theories/ZArith/Zeven.v
index d4fdaca8..3923d8aa 100644
--- a/theories/ZArith/Zeven.v
+++ b/theories/ZArith/Zeven.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Zeven.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import BinInt.
diff --git a/theories/ZArith/Zgcd_alt.v b/theories/ZArith/Zgcd_alt.v
index e5767ddd..26c3c0c2 100644
--- a/theories/ZArith/Zgcd_alt.v
+++ b/theories/ZArith/Zgcd_alt.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Zgcd_alt.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** * Zgcd_alt : an alternate version of Zgcd, based on Euler's algorithm *)
diff --git a/theories/ZArith/Zhints.v b/theories/ZArith/Zhints.v
index f41e2f01..5dd8c23c 100644
--- a/theories/ZArith/Zhints.v
+++ b/theories/ZArith/Zhints.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Zhints.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** This file centralizes the lemmas about [Z], classifying them
according to the way they can be used in automatic search *)
diff --git a/theories/ZArith/Zlogarithm.v b/theories/ZArith/Zlogarithm.v
index 0666380a..67650b0c 100644
--- a/theories/ZArith/Zlogarithm.v
+++ b/theories/ZArith/Zlogarithm.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Zlogarithm.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(**********************************************************************)
(** The integer logarithms with base 2.
diff --git a/theories/ZArith/Zmax.v b/theories/ZArith/Zmax.v
index 48b9c858..7285ec5a 100644
--- a/theories/ZArith/Zmax.v
+++ b/theories/ZArith/Zmax.v
@@ -5,7 +5,7 @@
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Zmax.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** THIS FILE IS DEPRECATED. Use [Zminmax] instead. *)
diff --git a/theories/ZArith/Zmin.v b/theories/ZArith/Zmin.v
index f9b23fde..5b1564d6 100644
--- a/theories/ZArith/Zmin.v
+++ b/theories/ZArith/Zmin.v
@@ -5,7 +5,7 @@
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Zmin.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** THIS FILE IS DEPRECATED. Use [Zminmax] instead. *)
diff --git a/theories/ZArith/Zmisc.v b/theories/ZArith/Zmisc.v
index 50d4c7f8..f625f762 100644
--- a/theories/ZArith/Zmisc.v
+++ b/theories/ZArith/Zmisc.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Zmisc.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Wf_nat.
Require Import BinInt.
diff --git a/theories/ZArith/Znat.v b/theories/ZArith/Znat.v
index cd258af3..0feb4df1 100644
--- a/theories/ZArith/Znat.v
+++ b/theories/ZArith/Znat.v
@@ -7,7 +7,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Znat.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** Binary Integers (Pierre Crégut, CNET, Lannion, France) *)
diff --git a/theories/ZArith/Znumtheory.v b/theories/ZArith/Znumtheory.v
index 4347d70c..c3394ed4 100644
--- a/theories/ZArith/Znumtheory.v
+++ b/theories/ZArith/Znumtheory.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Znumtheory.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import ZArith_base.
Require Import ZArithRing.
diff --git a/theories/ZArith/Zorder.v b/theories/ZArith/Zorder.v
index 13112e01..a691d269 100644
--- a/theories/ZArith/Zorder.v
+++ b/theories/ZArith/Zorder.v
@@ -6,7 +6,7 @@
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Zorder.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** Binary Integers (Pierre Crégut, CNET, Lannion, France) *)
diff --git a/theories/ZArith/Zpow_facts.v b/theories/ZArith/Zpow_facts.v
index 84b49799..226a573c 100644
--- a/theories/ZArith/Zpow_facts.v
+++ b/theories/ZArith/Zpow_facts.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Zpow_facts.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import ZArith_base.
Require Import ZArithRing.
diff --git a/theories/ZArith/Zpower.v b/theories/ZArith/Zpower.v
index 6e30ca08..e7c2fc57 100644
--- a/theories/ZArith/Zpower.v
+++ b/theories/ZArith/Zpower.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: Zpower.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
Require Import Wf_nat.
Require Import ZArith_base.
diff --git a/theories/ZArith/Zsqrt.v b/theories/ZArith/Zsqrt.v
index 1e9db3d1..8d4f70e9 100644
--- a/theories/ZArith/Zsqrt.v
+++ b/theories/ZArith/Zsqrt.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: Zsqrt.v 13323 2010-07-24 15:57:30Z herbelin $ *)
Require Import ZArithRing.
Require Import Omega.
diff --git a/theories/ZArith/Zwf.v b/theories/ZArith/Zwf.v
index 03678a27..cc4687ee 100644
--- a/theories/ZArith/Zwf.v
+++ b/theories/ZArith/Zwf.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: Zwf.v 13323 2010-07-24 15:57:30Z herbelin $ *)
Require Import ZArith_base.
Require Export Wf_nat.
diff --git a/theories/ZArith/auxiliary.v b/theories/ZArith/auxiliary.v
index bd2033b8..f50e7bf7 100644
--- a/theories/ZArith/auxiliary.v
+++ b/theories/ZArith/auxiliary.v
@@ -7,7 +7,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: auxiliary.v 13323 2010-07-24 15:57:30Z herbelin $ i*)
(** Binary Integers (Pierre Crégut, CNET, Lannion, France) *)
diff --git a/tools/coq_makefile.ml4 b/tools/coq_makefile.ml4
index 6be4d188..e4a3d5a4 100644
--- a/tools/coq_makefile.ml4
+++ b/tools/coq_makefile.ml4
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: coq_makefile.ml4 13323 2010-07-24 15:57:30Z herbelin $ *)
(* créer un Makefile pour un développement Coq automatiquement *)
diff --git a/tools/coq_tex.ml4 b/tools/coq_tex.ml4
index f2f7ebc4..647e6d7e 100644
--- a/tools/coq_tex.ml4
+++ b/tools/coq_tex.ml4
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: coq_tex.ml4 13323 2010-07-24 15:57:30Z herbelin $ *)
(* coq-tex
* JCF, 16/1/98
diff --git a/tools/coqdep.ml b/tools/coqdep.ml
index 08bd8ba0..9bc8965d 100644
--- a/tools/coqdep.ml
+++ b/tools/coqdep.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: coqdep.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Printf
open Coqdep_lexer
diff --git a/tools/coqdep_boot.ml b/tools/coqdep_boot.ml
index 7de7d395..d50d1604 100644
--- a/tools/coqdep_boot.ml
+++ b/tools/coqdep_boot.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: coqdep_boot.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Coqdep_common
diff --git a/tools/coqdep_lexer.mll b/tools/coqdep_lexer.mll
index a0880d7f..3a2bc4d3 100644
--- a/tools/coqdep_lexer.mll
+++ b/tools/coqdep_lexer.mll
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: coqdep_lexer.mll 13323 2010-07-24 15:57:30Z herbelin $ i*)
{
diff --git a/tools/coqdoc/alpha.ml b/tools/coqdoc/alpha.ml
index 34b27253..664ead9a 100644
--- a/tools/coqdoc/alpha.ml
+++ b/tools/coqdoc/alpha.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: alpha.ml 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Cdglobals
diff --git a/tools/coqdoc/alpha.mli b/tools/coqdoc/alpha.mli
index cecfe1a6..00b3d11b 100644
--- a/tools/coqdoc/alpha.mli
+++ b/tools/coqdoc/alpha.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: alpha.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(* Alphabetic order. *)
diff --git a/tools/coqdoc/cpretty.mli b/tools/coqdoc/cpretty.mli
index 76d85455..2a0a9091 100644
--- a/tools/coqdoc/cpretty.mli
+++ b/tools/coqdoc/cpretty.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: cpretty.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Index
diff --git a/tools/coqdoc/cpretty.mll b/tools/coqdoc/cpretty.mll
index 9367faed..d24093ff 100644
--- a/tools/coqdoc/cpretty.mll
+++ b/tools/coqdoc/cpretty.mll
@@ -7,7 +7,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: cpretty.mll 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*s Utility functions for the scanners *)
diff --git a/tools/coqdoc/index.ml b/tools/coqdoc/index.ml
index 95950fb0..e8f30853 100644
--- a/tools/coqdoc/index.ml
+++ b/tools/coqdoc/index.ml
@@ -7,7 +7,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: index.ml 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Filename
open Lexing
diff --git a/tools/coqdoc/index.mli b/tools/coqdoc/index.mli
index bf1d6568..72cd7a9f 100644
--- a/tools/coqdoc/index.mli
+++ b/tools/coqdoc/index.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: index.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Cdglobals
diff --git a/tools/coqdoc/main.ml b/tools/coqdoc/main.ml
index 6b750556..06d57f5e 100644
--- a/tools/coqdoc/main.ml
+++ b/tools/coqdoc/main.ml
@@ -7,7 +7,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: main.ml 13323 2010-07-24 15:57:30Z herbelin $ i*)
(* Modified by Lionel Elie Mamane <lionel@mamane.lu> on 9 & 10 Mar 2004:
* - handling of absolute filenames (function coq_module)
diff --git a/tools/coqdoc/output.ml b/tools/coqdoc/output.ml
index dda704fa..0b3718ab 100644
--- a/tools/coqdoc/output.ml
+++ b/tools/coqdoc/output.ml
@@ -7,7 +7,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: output.ml 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Cdglobals
open Index
diff --git a/tools/coqdoc/output.mli b/tools/coqdoc/output.mli
index 60408689..dd37c6ad 100644
--- a/tools/coqdoc/output.mli
+++ b/tools/coqdoc/output.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: output.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Cdglobals
open Index
diff --git a/tools/coqwc.mll b/tools/coqwc.mll
index 173ed2ed..f95a553a 100644
--- a/tools/coqwc.mll
+++ b/tools/coqwc.mll
@@ -9,7 +9,7 @@
(* coqwc - counts the lines of spec, proof and comments in Coq sources
* Copyright (C) 2003 Jean-Christophe Filliâtre *)
-(*i $Id$ i*)
+(*i $Id: coqwc.mll 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*s {\bf coqwc.} Counts the lines of spec, proof and comments in a Coq source.
It assumes the files to be lexically well-formed. *)
diff --git a/tools/gallina.ml b/tools/gallina.ml
index fe9766ec..a7b7d344 100644
--- a/tools/gallina.ml
+++ b/tools/gallina.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: gallina.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Gallina_lexer
diff --git a/tools/gallina_lexer.mll b/tools/gallina_lexer.mll
index 9622beee..d025b8c0 100644
--- a/tools/gallina_lexer.mll
+++ b/tools/gallina_lexer.mll
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: gallina_lexer.mll 13323 2010-07-24 15:57:30Z herbelin $ *)
{
open Lexing
diff --git a/toplevel/auto_ind_decl.ml b/toplevel/auto_ind_decl.ml
index 809af337..6064c3d4 100644
--- a/toplevel/auto_ind_decl.ml
+++ b/toplevel/auto_ind_decl.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: auto_ind_decl.ml 13323 2010-07-24 15:57:30Z herbelin $ i*)
(* This file is about the automatic generation of schemes about
decidable equality, created by Vincent Siles, Oct 2007 *)
diff --git a/toplevel/cerrors.ml b/toplevel/cerrors.ml
index 071731ac..5828f12d 100644
--- a/toplevel/cerrors.ml
+++ b/toplevel/cerrors.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: cerrors.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Pp
open Util
diff --git a/toplevel/cerrors.mli b/toplevel/cerrors.mli
index e2c42d50..00316007 100644
--- a/toplevel/cerrors.mli
+++ b/toplevel/cerrors.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: cerrors.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Pp
diff --git a/toplevel/class.ml b/toplevel/class.ml
index 49b3399c..0ee9dd19 100644
--- a/toplevel/class.ml
+++ b/toplevel/class.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: class.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Util
open Pp
diff --git a/toplevel/class.mli b/toplevel/class.mli
index 7410ed32..057d85ac 100644
--- a/toplevel/class.mli
+++ b/toplevel/class.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: class.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Names
diff --git a/toplevel/classes.ml b/toplevel/classes.ml
index 4c334e0b..435ddb4d 100644
--- a/toplevel/classes.ml
+++ b/toplevel/classes.ml
@@ -7,7 +7,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: classes.ml 13332 2010-07-26 22:12:43Z msozeau $ i*)
(*i*)
open Names
@@ -149,7 +149,7 @@ let new_instance ?(abstract=false) ?(global=false) ctx (instid, bk, cl) props
let tclass = if generalize then CGeneralization (dummy_loc, Implicit, Some AbsPi, tclass) else tclass in
let k, cty, ctx', ctx, len, imps, subst =
let (env', ctx), imps = interp_context_evars evars env ctx in
- let c', imps' = interp_type_evars_impls ~evdref:evars env' tclass in
+ let c', imps' = interp_type_evars_impls ~evdref:evars ~fail_evar:false env' tclass in
let len = List.length ctx in
let imps = imps @ Impargs.lift_implicits len imps' in
let ctx', c = decompose_prod_assum c' in
diff --git a/toplevel/classes.mli b/toplevel/classes.mli
index a19d5dbb..61670e0d 100644
--- a/toplevel/classes.mli
+++ b/toplevel/classes.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: classes.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Names
diff --git a/toplevel/command.ml b/toplevel/command.ml
index 1f6e7e83..9b18ef27 100644
--- a/toplevel/command.ml
+++ b/toplevel/command.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: command.ml 13344 2010-07-28 15:04:36Z msozeau $ *)
open Pp
open Util
@@ -69,8 +69,7 @@ let red_constant_entry n ce = function
let interp_definition boxed bl red_option c ctypopt =
let env = Global.env() in
let evdref = ref Evd.empty in
- let (env_bl, ctx), imps1 =
- interp_context_evars ~fail_anonymous:false evdref env bl in
+ let (env_bl, ctx), imps1 = interp_context_evars evdref env bl in
let imps,ce =
match ctypopt with
None ->
@@ -227,7 +226,7 @@ let interp_mutual_inductive (paramsl,indl) notations finite =
let env0 = Global.env() in
let evdref = ref Evd.empty in
let (env_params, ctx_params), userimpls =
- interp_context_evars ~fail_anonymous:false evdref env0 paramsl
+ interp_context_evars evdref env0 paramsl
in
let indnames = List.map (fun ind -> ind.ind_name) indl in
@@ -244,7 +243,7 @@ let interp_mutual_inductive (paramsl,indl) notations finite =
(* Compute interpretation metadatas *)
let indimpls = List.map (fun (_, impls) -> userimpls @ lift_implicits (List.length userimpls) impls) arities in
let arities = List.map fst arities in
- let impls = compute_full_internalization_env env0 Inductive params indnames fullarities indimpls in
+ let impls = compute_internalization_env env0 (Inductive params) indnames fullarities indimpls in
let mldatas = List.map2 (mk_mltype_data evdref env_params params) arities indnames in
let constructors =
@@ -256,9 +255,9 @@ let interp_mutual_inductive (paramsl,indl) notations finite =
() in
(* Instantiate evars and check all are resolved *)
- let evd,_ = consider_remaining_unif_problems env_params !evdref in
+ let evd = consider_remaining_unif_problems env_params !evdref in
let evd = Typeclasses.resolve_typeclasses ~onlyargs:false ~fail:true env_params evd in
- let sigma = evd in
+ let sigma = evd in
let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map (nf_evar sigma) cl,impsl)) constructors in
let ctx_params = Sign.map_rel_context (nf_evar sigma) ctx_params in
let arities = List.map (nf_evar sigma) arities in
@@ -448,14 +447,19 @@ let check_mutuality env isfix fixl =
type structured_fixpoint_expr = {
fix_name : identifier;
+ fix_annot : identifier located option;
fix_binders : local_binder list;
fix_body : constr_expr option;
fix_type : constr_expr
}
-let interp_fix_context evdref env fix =
- interp_context_evars evdref env fix.fix_binders
-
+let interp_fix_context evdref env isfix fix =
+ let before, after = if isfix then split_at_annot fix.fix_binders fix.fix_annot else [], fix.fix_binders in
+ let (env', ctx), imps = interp_context_evars evdref env before in
+ let (env'', ctx'), imps' = interp_context_evars evdref env' after in
+ let annot = Option.map (fun _ -> List.length (assums_of_rel_context ctx)) fix.fix_annot in
+ ((env'', ctx' @ ctx), imps @ imps', annot)
+
let interp_fix_ccl evdref (env,_) fix =
interp_type_evars evdref env fix.fix_type
@@ -487,8 +491,8 @@ let prepare_recursive_declaration fixnames fixtypes fixdefs =
(* Jump over let-bindings. *)
-let compute_possible_guardness_evidences na fix (ids,_) =
- match index_of_annot fix.fix_binders na with
+let compute_possible_guardness_evidences (ids,_,na) =
+ match na with
| Some i -> [i]
| None ->
(* If recursive argument was not given by user, we try all args.
@@ -507,15 +511,15 @@ let interp_recursive isfix fixl notations =
(* Interp arities allowing for unresolved types *)
let evdref = ref Evd.empty in
- let fixctxs, fiximps =
- List.split (List.map (interp_fix_context evdref env) fixl) in
+ let fixctxs, fiximps, fixannots =
+ list_split3 (List.map (interp_fix_context evdref env isfix) fixl) in
let fixccls = List.map2 (interp_fix_ccl evdref) fixctxs fixl in
let fixtypes = List.map2 build_fix_type fixctxs fixccls in
let fixtypes = List.map (nf_evar !evdref) fixtypes in
let env_rec = push_named_types env fixnames fixtypes in
(* Get interpretation metadatas *)
- let impls = compute_full_internalization_env env Recursive [] fixnames fixtypes fiximps in
+ let impls = compute_internalization_env env Recursive fixnames fixtypes fiximps in
(* Interp bodies with rollback because temp use of notations/implicit *)
let fixdefs =
@@ -525,7 +529,7 @@ let interp_recursive isfix fixl notations =
() in
(* Instantiate evars and check all are resolved *)
- let evd,_ = consider_remaining_unif_problems env_rec !evdref in
+ let evd = consider_remaining_unif_problems env_rec !evdref in
let fixdefs = List.map (Option.map (nf_evar evd)) fixdefs in
let fixtypes = List.map (nf_evar evd) fixtypes in
let fixctxnames = List.map (fun (_,ctx) -> List.map pi1 ctx) fixctxs in
@@ -538,7 +542,7 @@ let interp_recursive isfix fixl notations =
end;
(* Build the fix declaration block *)
- (fixnames,fixdefs,fixtypes),List.combine fixctxnames fiximps
+ (fixnames,fixdefs,fixtypes), list_combine3 fixctxnames fiximps fixannots
let interp_fixpoint = interp_recursive true
let interp_cofixpoint = interp_recursive false
@@ -547,7 +551,7 @@ let declare_fixpoint boxed ((fixnames,fixdefs,fixtypes),fiximps) indexes ntns =
if List.mem None fixdefs then
(* Some bodies to define by proof *)
let thms =
- list_map3 (fun id t imps -> (id,(t,imps))) fixnames fixtypes fiximps in
+ list_map3 (fun id t (len,imps,_) -> (id,(t,(len,imps)))) fixnames fixtypes fiximps in
let init_tac =
Some (List.map (Option.cata Tacmach.refine_no_check Tacticals.tclIDTAC)
fixdefs) in
@@ -558,7 +562,7 @@ let declare_fixpoint boxed ((fixnames,fixdefs,fixtypes),fiximps) indexes ntns =
let fixdefs = List.map Option.get fixdefs in
let fixdecls = prepare_recursive_declaration fixnames fixtypes fixdefs in
let indexes = search_guard dummy_loc (Global.env()) indexes fixdecls in
- let fiximps = List.map snd fiximps in
+ let fiximps = List.map (fun (n,r,p) -> r) fiximps in
let fixdecls =
list_map_i (fun i _ -> mkFix ((indexes,i),fixdecls)) 0 fixnames in
ignore (list_map4 (declare_fix boxed Fixpoint) fixnames fixdecls fixtypes fiximps);
@@ -572,7 +576,7 @@ let declare_cofixpoint boxed ((fixnames,fixdefs,fixtypes),fiximps) ntns =
if List.mem None fixdefs then
(* Some bodies to define by proof *)
let thms =
- list_map3 (fun id t imps -> (id,(t,imps))) fixnames fixtypes fiximps in
+ list_map3 (fun id t (len,imps,_) -> (id,(t,(len,imps)))) fixnames fixtypes fiximps in
let init_tac =
Some (List.map (Option.cata Tacmach.refine_no_check Tacticals.tclIDTAC)
fixdefs) in
@@ -583,7 +587,7 @@ let declare_cofixpoint boxed ((fixnames,fixdefs,fixtypes),fiximps) ntns =
let fixdefs = List.map Option.get fixdefs in
let fixdecls = prepare_recursive_declaration fixnames fixtypes fixdefs in
let fixdecls = list_map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 fixnames in
- let fiximps = List.map snd fiximps in
+ let fiximps = List.map (fun (len,imps,idx) -> imps) fiximps in
ignore (list_map4 (declare_fix boxed CoFixpoint) fixnames fixdecls fixtypes fiximps);
(* Declare the recursive definitions *)
cofixpoint_message fixnames
@@ -592,28 +596,28 @@ let declare_cofixpoint boxed ((fixnames,fixdefs,fixtypes),fiximps) ntns =
List.iter Metasyntax.add_notation_interpretation ntns
let extract_decreasing_argument = function
- | (_,(na,CStructRec),_,_,_) -> na
+ | (na,CStructRec) -> na
| _ -> error
"Only structural decreasing is supported for a non-Program Fixpoint"
let extract_fixpoint_components l =
let fixl, ntnl = List.split l in
- let wfl = List.map extract_decreasing_argument fixl in
- let fixl = List.map (fun ((_,id),_,bl,typ,def) ->
- {fix_name = id; fix_binders = bl; fix_body = def; fix_type = typ}) fixl in
- fixl, List.flatten ntnl, wfl
+ let fixl = List.map (fun ((_,id),ann,bl,typ,def) ->
+ let ann = extract_decreasing_argument ann in
+ {fix_name = id; fix_annot = ann; fix_binders = bl; fix_body = def; fix_type = typ}) fixl in
+ fixl, List.flatten ntnl
let extract_cofixpoint_components l =
let fixl, ntnl = List.split l in
List.map (fun ((_,id),bl,typ,def) ->
- {fix_name = id; fix_binders = bl; fix_body = def; fix_type = typ}) fixl,
+ {fix_name = id; fix_annot = None; fix_binders = bl; fix_body = def; fix_type = typ}) fixl,
List.flatten ntnl
let do_fixpoint l b =
- let fixl,ntns,wfl = extract_fixpoint_components l in
+ let fixl,ntns = extract_fixpoint_components l in
let fix = interp_fixpoint fixl ntns in
let possible_indexes =
- list_map3 compute_possible_guardness_evidences wfl fixl (snd fix) in
+ List.map compute_possible_guardness_evidences (snd fix) in
declare_fixpoint b fix possible_indexes ntns
let do_cofixpoint l b =
diff --git a/toplevel/command.mli b/toplevel/command.mli
index ab94e7d2..f5996905 100644
--- a/toplevel/command.mli
+++ b/toplevel/command.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: command.mli 13332 2010-07-26 22:12:43Z msozeau $ i*)
(*i*)
open Util
@@ -102,6 +102,7 @@ val do_mutual_inductive :
type structured_fixpoint_expr = {
fix_name : identifier;
+ fix_annot : identifier located option;
fix_binders : local_binder list;
fix_body : constr_expr option;
fix_type : constr_expr
@@ -112,8 +113,7 @@ type structured_fixpoint_expr = {
val extract_fixpoint_components :
(fixpoint_expr * decl_notation list) list ->
- structured_fixpoint_expr list * decl_notation list *
- (* possible structural arg: *) lident option list
+ structured_fixpoint_expr list * decl_notation list
val extract_cofixpoint_components :
(cofixpoint_expr * decl_notation list) list ->
@@ -126,20 +126,20 @@ type recursive_preentry =
val interp_fixpoint :
structured_fixpoint_expr list -> decl_notation list ->
- recursive_preentry * (name list * manual_implicits) list
+ recursive_preentry * (name list * manual_implicits * int option) list
val interp_cofixpoint :
structured_fixpoint_expr list -> decl_notation list ->
- recursive_preentry * (name list * manual_implicits) list
+ recursive_preentry * (name list * manual_implicits * int option) list
(* Registering fixpoints and cofixpoints in the environment *)
val declare_fixpoint :
- bool -> recursive_preentry * (name list * manual_implicits) list ->
+ bool -> recursive_preentry * (name list * manual_implicits * int option) list ->
lemma_possible_guards -> decl_notation list -> unit
val declare_cofixpoint :
- bool -> recursive_preentry * (name list * manual_implicits) list ->
+ bool -> recursive_preentry * (name list * manual_implicits * int option) list ->
decl_notation list -> unit
(* Entry points for the vernacular commands Fixpoint and CoFixpoint *)
diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml
index 5f9f96a9..bce38128 100644
--- a/toplevel/coqinit.ml
+++ b/toplevel/coqinit.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: coqinit.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Pp
open System
diff --git a/toplevel/coqinit.mli b/toplevel/coqinit.mli
index 926ecf8f..c2a535dd 100644
--- a/toplevel/coqinit.mli
+++ b/toplevel/coqinit.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: coqinit.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(* Initialization. *)
diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml
index 3d3010dd..f05509a4 100644
--- a/toplevel/coqtop.ml
+++ b/toplevel/coqtop.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: coqtop.ml 13358 2010-07-29 23:10:17Z herbelin $ *)
open Pp
open Util
@@ -281,7 +281,7 @@ let parse_args is_ide =
| "-emacs-U" :: rem -> Flags.print_emacs := true;
Flags.print_emacs_safechar := true; Pp.make_pp_emacs(); parse rem
- | "-unicode" :: rem -> Flags.unicode_syntax := true; parse rem
+ | "-unicode" :: rem -> add_require "Utf8_core"; parse rem
| "-coqlib" :: d :: rem -> Flags.coqlib_spec:=true; Flags.coqlib:=d; parse rem
| "-coqlib" :: [] -> usage ()
diff --git a/toplevel/coqtop.mli b/toplevel/coqtop.mli
index f5e3a464..e80b3252 100644
--- a/toplevel/coqtop.mli
+++ b/toplevel/coqtop.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: coqtop.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(* The Coq main module. The following function [start] will parse the
command line, print the banner, initialize the load path, load the input
diff --git a/toplevel/discharge.ml b/toplevel/discharge.ml
index af02253b..6f74c526 100644
--- a/toplevel/discharge.ml
+++ b/toplevel/discharge.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: discharge.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Names
open Util
diff --git a/toplevel/discharge.mli b/toplevel/discharge.mli
index a2cbb6be..dda4c5d7 100644
--- a/toplevel/discharge.mli
+++ b/toplevel/discharge.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: discharge.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Sign
open Cooking
diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml
index a97bf9bb..a080442c 100644
--- a/toplevel/himsg.ml
+++ b/toplevel/himsg.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: himsg.ml 13332 2010-07-26 22:12:43Z msozeau $ *)
open Pp
open Util
@@ -543,7 +543,7 @@ let explain_unsatisfiable_constraints env evd constr =
match constr with
| None ->
str"Unable to satisfy the following constraints:" ++ fnl() ++
- pr_constraints true env evm
+ pr_constraints true env undef
| Some (ev, k) ->
explain_unsolvable_implicit env (Evd.find evm ev) k None ++ fnl () ++
if List.length (Evd.to_list undef) > 1 then
diff --git a/toplevel/himsg.mli b/toplevel/himsg.mli
index 856583d9..a916e87b 100644
--- a/toplevel/himsg.mli
+++ b/toplevel/himsg.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: himsg.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Pp
diff --git a/toplevel/ind_tables.ml b/toplevel/ind_tables.ml
index 6f692ced..4e28ccac 100644
--- a/toplevel/ind_tables.ml
+++ b/toplevel/ind_tables.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: ind_tables.ml 13323 2010-07-24 15:57:30Z herbelin $ i*)
(* File created by Vincent Siles, Oct 2007, extended into a generic
support for generation of inductive schemes by Hugo Herbelin, Nov 2009 *)
diff --git a/toplevel/indschemes.ml b/toplevel/indschemes.ml
index ef3efa47..29d7a12c 100644
--- a/toplevel/indschemes.ml
+++ b/toplevel/indschemes.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: indschemes.ml 13333 2010-07-27 10:18:30Z vsiles $ *)
(* Created by Hugo Herbelin from contents related to inductive schemes
initially developed by Christine Paulin (induction schemes), Vincent
@@ -54,7 +54,7 @@ let _ =
optread = (fun () -> !elim_flag) ;
optwrite = (fun b -> elim_flag := b) }
-let case_flag = ref true
+let case_flag = ref false
let _ =
declare_bool_option
{ optsync = true;
@@ -63,7 +63,7 @@ let _ =
optread = (fun () -> !case_flag) ;
optwrite = (fun b -> case_flag := b) }
-let eq_flag = ref true
+let eq_flag = ref false
let _ =
declare_bool_option
{ optsync = true;
@@ -292,6 +292,7 @@ let rec split_scheme l =
| (Some id,t)::q -> let l1,l2 = split_scheme q in
( match t with
| InductionScheme (x,y,z) -> ((id,x,smart_global_inductive y,z)::l1),l2
+ | CaseScheme (x,y,z) -> ((id,x,smart_global_inductive y,z)::l1),l2
| EqualityScheme x -> l1,((Some id,smart_global_inductive x)::l2)
)
(*
@@ -299,38 +300,41 @@ let rec split_scheme l =
requested
*)
| (None,t)::q ->
- let l1,l2 = split_scheme q in
- ( match t with
- | InductionScheme (x,y,z) ->
- let ind = smart_global_inductive y in
- let sort_of_ind = Retyping.get_sort_family_of env Evd.empty (mkInd ind) in
- let z' = family_of_sort (interp_sort z) in
- let suffix = (
- match sort_of_ind with
- | InProp ->
- if x then (match z' with
- | InProp -> "_ind_nodep"
- | InSet -> "_rec_nodep"
- | InType -> "_rect_nodep")
- else ( match z' with
- | InProp -> "_ind"
- | InSet -> "_rec"
- | InType -> "_rect" )
- | _ ->
- if x then (match z' with
- | InProp -> "_ind"
- | InSet -> "_rec"
- | InType -> "_rect" )
- else (match z' with
- | InProp -> "_ind_dep"
- | InSet -> "_rec_dep"
- | InType -> "_rect_dep")
- ) in
- let newid = add_suffix (basename_of_global (IndRef ind)) suffix in
- let newref = (dummy_loc,newid) in
+ let l1,l2 = split_scheme q in
+ let names inds recs x y z =
+ let ind = smart_global_inductive y in
+ let sort_of_ind = Retyping.get_sort_family_of env Evd.empty (mkInd ind) in
+ let z' = family_of_sort (interp_sort z) in
+ let suffix = (
+ match sort_of_ind with
+ | InProp ->
+ if x then (match z' with
+ | InProp -> inds ^ "_nodep"
+ | InSet -> recs ^ "_nodep"
+ | InType -> recs ^ "t_nodep")
+ else ( match z' with
+ | InProp -> inds
+ | InSet -> recs
+ | InType -> recs ^ "t" )
+ | _ ->
+ if x then (match z' with
+ | InProp -> inds
+ | InSet -> recs
+ | InType -> recs ^ "t" )
+ else (match z' with
+ | InProp -> inds ^ "_dep"
+ | InSet -> recs ^ "_dep"
+ | InType -> recs ^ "t_dep")
+ ) in
+ let newid = add_suffix (basename_of_global (IndRef ind)) suffix in
+ let newref = (dummy_loc,newid) in
((newref,x,ind,z)::l1),l2
- | EqualityScheme x -> l1,((None,smart_global_inductive x)::l2)
- )
+ in
+ match t with
+ | CaseScheme (x,y,z) -> names "_case" "_case" x y z
+ | InductionScheme (x,y,z) -> names "_ind" "_rec" x y z
+ | EqualityScheme x -> l1,((None,smart_global_inductive x)::l2)
+
let do_mutual_induction_scheme lnamedepindsort =
let lrecnames = List.map (fun ((_,f),_,_,_) -> f) lnamedepindsort
diff --git a/toplevel/indschemes.mli b/toplevel/indschemes.mli
index 76a5e4b7..f763e182 100644
--- a/toplevel/indschemes.mli
+++ b/toplevel/indschemes.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: indschemes.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Util
diff --git a/toplevel/lemmas.ml b/toplevel/lemmas.ml
index 89252e54..7af5d0aa 100644
--- a/toplevel/lemmas.ml
+++ b/toplevel/lemmas.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: lemmas.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
(* Created by Hugo Herbelin from contents related to lemma proofs in
file command.ml, Aug 2009 *)
diff --git a/toplevel/lemmas.mli b/toplevel/lemmas.mli
index e0700341..5327f63f 100644
--- a/toplevel/lemmas.mli
+++ b/toplevel/lemmas.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: lemmas.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Names
diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml
index a297d1d7..6ee00f48 100644
--- a/toplevel/metasyntax.ml
+++ b/toplevel/metasyntax.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: metasyntax.ml 13329 2010-07-26 11:05:39Z herbelin $ *)
open Pp
open Flags
@@ -280,7 +280,7 @@ let rec find_pattern nt xl = function
| [], NonTerminal x' :: l' ->
(out_nt nt,x',List.rev xl),l'
| [], Terminal s :: _ | Terminal s :: _, _ ->
- error ("The token "^s^" occurs on one side of \"..\" but not on the other side.")
+ error ("The token \""^s^"\" occurs on one side of \"..\" but not on the other side.")
| [], Break s :: _ | Break s :: _, _ ->
error ("A break occurs on one side of \"..\" but not on the other side.")
| _, [] ->
@@ -289,23 +289,23 @@ let rec find_pattern nt xl = function
anomaly "Only Terminal or Break expected on left, non-SProdList on right"
let rec interp_list_parser hd = function
- | [] -> [], [], List.rev hd
+ | [] -> [], List.rev hd
| NonTerminal id :: tl when id = ldots_var ->
let hd = List.rev hd in
let ((x,y,sl),tl') = find_pattern (List.hd hd) [] (List.tl hd,tl) in
- let yl,xl,tl'' = interp_list_parser [] tl' in
+ let xyl,tl'' = interp_list_parser [] tl' in
(* We remember each pair of variable denoting a recursive part to *)
(* remove the second copy of it afterwards *)
- (y,x)::yl, x::xl, SProdList (x,sl) :: tl''
+ (x,y)::xyl, SProdList (x,sl) :: tl''
| (Terminal _ | Break _) as s :: tl ->
if hd = [] then
- let yl,xl,tl' = interp_list_parser [] tl in
- yl, xl, s :: tl'
+ let yl,tl' = interp_list_parser [] tl in
+ yl, s :: tl'
else
interp_list_parser (s::hd) tl
| NonTerminal _ as x :: tl ->
- let yl,xl,tl' = interp_list_parser [x] tl in
- yl, xl, List.rev_append hd tl'
+ let xyl,tl' = interp_list_parser [x] tl in
+ xyl, List.rev_append hd tl'
| SProdList _ :: _ -> anomaly "Unexpected SProdList in interp_list_parser"
@@ -345,33 +345,28 @@ let rec get_notation_vars = function
| [] -> []
| NonTerminal id :: sl ->
let vars = get_notation_vars sl in
- if List.mem id vars then
- if id <> ldots_var then
+ if id = ldots_var then vars else
+ if List.mem id vars then
error ("Variable "^string_of_id id^" occurs more than once.")
- else
- vars
- else
- id::vars
+ else
+ id::vars
| (Terminal _ | Break _) :: sl -> get_notation_vars sl
| SProdList _ :: _ -> assert false
let analyze_notation_tokens l =
let l = raw_analyze_notation_tokens l in
let vars = get_notation_vars l in
- let extrarecvars,recvars,l = interp_list_parser [] l in
- (if extrarecvars = [] then [], [], vars, l
- else extrarecvars, recvars, list_subtract vars recvars, l)
-
-let remove_extravars extrarecvars (vars,recvars) =
- let vars =
- List.fold_right (fun (x,y) l ->
- if List.assoc x l <> List.assoc y recvars then
- error
- "Two end variables of a recursive notation are not in the same scope."
- else
- List.remove_assoc x l)
- extrarecvars (List.remove_assoc ldots_var vars) in
- (vars,recvars)
+ let recvars,l = interp_list_parser [] l in
+ recvars, list_subtract vars (List.map snd recvars), l
+
+let error_not_same_scope x y =
+ error ("Variables "^string_of_id x^" and "^string_of_id y^
+ " must be in the same scope.")
+
+let error_both_bound_and_binding x y =
+ errorlabstrm "" (strbrk "The recursive variables " ++ pr_id x ++
+ strbrk " and " ++ pr_id y ++ strbrk " cannot be used as placeholder
+ for both terms and binders.")
(**********************************************************************)
(* Build pretty-printing rules *)
@@ -434,6 +429,13 @@ let rec is_non_terminal = function
let add_break n l = UnpCut (PpBrk(n,0)) :: l
+let check_open_binder isopen sl m =
+ if isopen & sl <> [] then
+ errorlabstrm "" (str "as " ++ pr_id m ++
+ str " is a non-closed binder, no such \"" ++
+ prlist_with_sep spc (function Terminal s -> str s | _ -> assert false) sl
+ ++ strbrk "\" is allowed to occur.")
+
(* Heuristics for building default printing rules *)
type previous_prod_status = NoBreak | CanBreak
@@ -478,7 +480,7 @@ let make_hunks etyps symbols from =
| Terminal s :: prods ->
if is_right_bracket s then
- UnpTerminal s ::make NoBreak prods
+ UnpTerminal s :: make NoBreak prods
else if ws = CanBreak then
add_break 1 (UnpTerminal s :: make NoBreak prods)
else
@@ -489,14 +491,20 @@ let make_hunks etyps symbols from =
| SProdList (m,sl) :: prods ->
let i = list_index m vars in
- let _,prec = precedence_of_entry_type from (List.nth typs (i-1)) in
+ let typ = List.nth typs (i-1) in
+ let _,prec = precedence_of_entry_type from typ in
let sl' =
(* If no separator: add a break *)
if sl = [] then add_break 1 []
(* We add NonTerminal for simulation but remove it afterwards *)
- else snd (list_sep_last (make NoBreak (sl@[NonTerminal m])))
- in
- UnpListMetaVar (i,prec,sl') :: make CanBreak prods
+ else snd (list_sep_last (make NoBreak (sl@[NonTerminal m]))) in
+ let hunk = match typ with
+ | ETConstr _ -> UnpListMetaVar (i,prec,sl')
+ | ETBinder isopen ->
+ check_open_binder isopen sl m;
+ UnpBinderListMetaVar (i,isopen,sl')
+ | _ -> assert false in
+ hunk :: make CanBreak prods
| [] -> []
@@ -559,12 +567,19 @@ let hunks_of_format (from,(vars,typs)) symfmt =
let symbs, l = aux (symbs,fmt) in symbs, u :: l
| SProdList (m,sl) :: symbs, fmt ->
let i = list_index m vars in
- let _,prec = precedence_of_entry_type from (List.nth typs (i-1)) in
+ let typ = List.nth typs (i-1) in
+ let _,prec = precedence_of_entry_type from typ in
let slfmt,fmt = read_recursive_format sl fmt in
let sl, slfmt = aux (sl,slfmt) in
if sl <> [] then error_format ();
let symbs, l = aux (symbs,fmt) in
- symbs, UnpListMetaVar (i,prec,slfmt) :: l
+ let hunk = match typ with
+ | ETConstr _ -> UnpListMetaVar (i,prec,slfmt)
+ | ETBinder isopen ->
+ check_open_binder isopen sl m;
+ UnpBinderListMetaVar (i,isopen,slfmt)
+ | _ -> assert false in
+ symbs, hunk :: l
| symbs, [] -> symbs, []
| _, _ -> error_format ()
in
@@ -632,11 +647,13 @@ let make_production etyps symbols =
(List.map (function Terminal s -> [terminal s]
| Break _ -> []
| _ -> anomaly "Found a non terminal token in recursive notation separator") sl) in
- let typ = match List.assoc x etyps with
- | ETConstr x -> x
- | _ ->
- error "Component of recursive patterns in notation must be constr." in
- expand_list_rule typ tkl x 1 0 [] ll)
+ match List.assoc x etyps with
+ | ETConstr typ -> expand_list_rule typ tkl x 1 0 [] ll
+ | ETBinder o ->
+ distribute
+ [GramConstrNonTerminal (ETBinderList (o,tkl), Some x)] ll
+ | _ ->
+ error "Components of recursive patterns in notation must be terms or binders.")
symbols [[]] in
List.map define_keywords prod
@@ -682,7 +699,7 @@ let error_incompatible_level ntn oldprec prec =
spc() ++ str "while it is now required to be" ++ spc() ++
pr_level ntn prec ++ str ".")
-let cache_one_syntax_extension (prec,ntn,gr,pp) =
+let cache_one_syntax_extension (typs,prec,ntn,gr,pp) =
try
let oldprec = Notation.level_of_notation ntn in
if prec <> oldprec then error_incompatible_level ntn oldprec prec
@@ -690,7 +707,7 @@ let cache_one_syntax_extension (prec,ntn,gr,pp) =
(* Reserve the notation level *)
Notation.declare_notation_level ntn prec;
(* Declare the parsing rule *)
- Egrammar.extend_grammar (Egrammar.Notation (prec,gr));
+ Egrammar.extend_grammar (Egrammar.Notation (prec,typs,gr));
(* Declare the printing rule *)
Notation.declare_notation_printing_rule ntn (pp,fst prec)
@@ -702,8 +719,9 @@ let subst_parsing_rule subst x = x
let subst_printing_rule subst x = x
let subst_syntax_extension (subst,(local,sy)) =
- (local, List.map (fun (prec,ntn,gr,pp) ->
- (prec,ntn, subst_parsing_rule subst gr, subst_printing_rule subst pp)) sy)
+ (local, List.map (fun (typs,prec,ntn,gr,pp) ->
+ (typs,prec,ntn,subst_parsing_rule subst gr,subst_printing_rule subst pp))
+ sy)
let classify_syntax_definition (local,_ as o) =
if local then Dispose else Substitute o
@@ -768,11 +786,59 @@ let set_entry_type etyps (x,typ) =
| ETConstr (n,()), (_,BorderProd (left,_)) ->
ETConstr (n,BorderProd (left,None))
| ETConstr (n,()), (_,InternalProd) -> ETConstr (n,InternalProd)
- | (ETPattern | ETName | ETBigint | ETOther _ | ETReference as t), _ -> t
- | (ETConstrList _, _) -> assert false
+ | (ETPattern | ETName | ETBigint | ETOther _ |
+ ETReference | ETBinder _ as t), _ -> t
+ | (ETBinderList _ |ETConstrList _), _ -> assert false
with Not_found -> ETConstr typ
in (x,typ)
+let join_auxiliary_recursive_types recvars etyps =
+ List.fold_right (fun (x,y) typs ->
+ let xtyp = try Some (List.assoc x etyps) with Not_found -> None in
+ let ytyp = try Some (List.assoc y etyps) with Not_found -> None in
+ match xtyp,ytyp with
+ | None, None -> typs
+ | Some _, None -> typs
+ | None, Some ytyp -> (x,ytyp)::typs
+ | Some xtyp, Some ytyp when xtyp = ytyp -> typs
+ | Some xtyp, Some ytyp ->
+ errorlabstrm ""
+ (strbrk "In " ++ pr_id x ++ str " .. " ++ pr_id y ++
+ strbrk ", both ends have incompatible types."))
+ recvars etyps
+
+let internalization_type_of_entry_type = function
+ | ETConstr _ -> NtnInternTypeConstr
+ | ETBigint | ETReference -> NtnInternTypeConstr
+ | ETBinder _ -> NtnInternTypeBinder
+ | ETName -> NtnInternTypeIdent
+ | ETPattern | ETOther _ -> error "Not supported."
+ | ETBinderList _ | ETConstrList _ -> assert false
+
+let set_internalization_type typs =
+ List.map (down_snd internalization_type_of_entry_type) typs
+
+let make_internalization_vars recvars mainvars typs =
+ let maintyps = List.combine mainvars typs in
+ let extratyps = List.map (fun (x,y) -> (y,List.assoc x maintyps)) recvars in
+ maintyps@extratyps
+
+let make_interpretation_type isrec = function
+ | NtnInternTypeConstr when isrec -> NtnTypeConstrList
+ | NtnInternTypeConstr | NtnInternTypeIdent -> NtnTypeConstr
+ | NtnInternTypeBinder when isrec -> NtnTypeBinderList
+ | NtnInternTypeBinder -> error "Type not allowed in recursive notation."
+
+let make_interpretation_vars recvars allvars =
+ List.iter (fun (x,y) ->
+ if fst (List.assoc x allvars) <> fst (List.assoc y allvars) then
+ error_not_same_scope x y) recvars;
+ let useless_recvars = List.map snd recvars in
+ let mainvars =
+ List.filter (fun (x,_) -> not (List.mem x useless_recvars)) allvars in
+ List.map (fun (x,(sc,typ)) ->
+ (x,(sc,make_interpretation_type (List.mem_assoc x recvars) typ))) mainvars
+
let check_rule_productivity l =
if List.for_all (function NonTerminal _ -> true | _ -> false) l then
error "A notation must include at least one symbol.";
@@ -791,29 +857,31 @@ let find_precedence lev etyps symbols =
error "The level of the leftmost non-terminal cannot be changed."
| ETName | ETBigint | ETReference ->
if lev = None then
- if_verbose msgnl (str "Setting notation at level 0.")
+ ([msgnl,str "Setting notation at level 0."],0)
else
if lev <> Some 0 then
- error "A notation starting with an atomic expression must be at level 0.";
- 0
- | ETPattern | ETOther _ -> (* Give a default ? *)
+ error "A notation starting with an atomic expression must be at level 0."
+ else
+ ([],0)
+ | ETPattern | ETBinder _ | ETOther _ -> (* Give a default ? *)
if lev = None then
error "Need an explicit level."
- else Option.get lev
- | ETConstrList _ -> assert false (* internally used in grammar only *)
+ else [],Option.get lev
+ | ETConstrList _ | ETBinderList _ ->
+ assert false (* internally used in grammar only *)
with Not_found ->
if lev = None then
error "A left-recursive notation must have an explicit level."
- else Option.get lev)
+ else [],Option.get lev)
| Terminal _ ::l when
(match list_last symbols with Terminal _ -> true |_ -> false)
->
if lev = None then
- (if_verbose msgnl (str "Setting notation at level 0."); 0)
- else Option.get lev
+ ([msgnl,str "Setting notation at level 0."], 0)
+ else [],Option.get lev
| _ ->
if lev = None then error "Cannot determine the level.";
- Option.get lev
+ [],Option.get lev
let check_curly_brackets_notation_exists () =
try let _ = Notation.level_of_notation "{ _ }" in ()
@@ -849,13 +917,13 @@ let compute_syntax_data (df,modifiers) =
(* Notation defaults to NONA *)
let assoc = match assoc with None -> Some Gramext.NonA | a -> a in
let toks = split_notation_string df in
- let (extrarecvars,recvars,vars,symbols) = analyze_notation_tokens toks in
+ let (recvars,mainvars,symbols) = analyze_notation_tokens toks in
let ntn_for_interp = make_notation_key symbols in
let symbols' = remove_curly_brackets symbols in
let need_squash = (symbols <> symbols') in
let ntn_for_grammar = make_notation_key symbols' in
check_rule_productivity symbols';
- let n = find_precedence n etyps symbols' in
+ let msgs,n = find_precedence n etyps symbols' in
let innerlevel = NumLevel 200 in
let typs =
find_symbols
@@ -864,12 +932,25 @@ let compute_syntax_data (df,modifiers) =
(NumLevel n,BorderProd(Right,assoc))
symbols' in
(* To globalize... *)
- let typs = List.map (set_entry_type etyps) typs in
- let prec = (n,List.map (assoc_of_type n) typs) in
- let sy_data = (ntn_for_grammar,prec,need_squash,(n,typs,symbols',fmt)) in
+ let etyps = join_auxiliary_recursive_types recvars etyps in
+ let sy_typs = List.map (set_entry_type etyps) typs in
+ let prec = (n,List.map (assoc_of_type n) sy_typs) in
+ let i_typs = set_internalization_type sy_typs in
+ let sy_data = (n,sy_typs,symbols',fmt) in
+ let sy_fulldata = (i_typs,ntn_for_grammar,prec,need_squash,sy_data) in
let df' = ((Lib.library_dp(),Lib.current_dirpath true),df) in
- let i_data = (onlyparse,extrarecvars,recvars,vars,(ntn_for_interp,df')) in
- (i_data,sy_data)
+ let i_data = (onlyparse,recvars,mainvars,(ntn_for_interp,df')) in
+ (* Return relevant data for interpretation and for parsing/printing *)
+ (msgs,i_data,i_typs,sy_fulldata)
+
+let compute_pure_syntax_data (df,mods) =
+ let (msgs,(onlyparse,_,_,_),_,sy_data) = compute_syntax_data (df,mods) in
+ let msgs =
+ if onlyparse then
+ (msg_warning,
+ str "The only parsing modifier has no effect in Reserved Notation.")::msgs
+ else msgs in
+ msgs, sy_data
(**********************************************************************)
(* Registration of notations interpretation *)
@@ -925,9 +1006,9 @@ exception NoSyntaxRule
let recover_syntax ntn =
try
let prec = Notation.level_of_notation ntn in
- let pprule,_ = Notation.find_notation_printing_rule ntn in
- let gr = Egrammar.recover_notation_grammar ntn prec in
- (prec,ntn,gr,pprule)
+ let pp_rule,_ = Notation.find_notation_printing_rule ntn in
+ let typs,pa_rule = Egrammar.recover_notation_grammar ntn prec in
+ (typs,prec,ntn,pa_rule,pp_rule)
with Not_found ->
raise NoSyntaxRule
@@ -935,9 +1016,9 @@ let recover_squash_syntax () = recover_syntax "{ _ }"
let recover_notation_syntax rawntn =
let ntn = contract_notation rawntn in
- let sy_rule = recover_syntax ntn in
+ let (typs,_,_,_,_ as sy_rule) = recover_syntax ntn in
let need_squash = ntn<>rawntn in
- if need_squash then [sy_rule; recover_squash_syntax ()] else [sy_rule]
+ typs,if need_squash then [sy_rule; recover_squash_syntax ()] else [sy_rule]
(**********************************************************************)
(* Main entry point for building parsing and printing rules *)
@@ -952,10 +1033,10 @@ let make_pp_rule (n,typs,symbols,fmt) =
| None -> [UnpBox (PpHOVB 0, make_hunks typs symbols n)]
| Some fmt -> hunks_of_format (n,List.split typs) (symbols,parse_format fmt)
-let make_syntax_rules (ntn,prec,need_squash,sy_data) =
+let make_syntax_rules (i_typs,ntn,prec,need_squash,sy_data) =
let pa_rule = make_pa_rule sy_data ntn in
let pp_rule = make_pp_rule sy_data in
- let sy_rule = (prec,ntn,pa_rule,pp_rule) in
+ let sy_rule = (i_typs,prec,ntn,pa_rule,pp_rule) in
(* By construction, the rule for "{ _ }" is declared, but we need to
redeclare it because the file where it is declared needs not be open
when the current file opens (especially in presence of -nois) *)
@@ -965,31 +1046,35 @@ let make_syntax_rules (ntn,prec,need_squash,sy_data) =
(* Main functions about notations *)
let add_notation_in_scope local df c mods scope =
- let (i_data,sy_data) = compute_syntax_data (df,mods) in
- (* Declare the parsing and printing rules *)
+ let (msgs,i_data,i_typs,sy_data) = compute_syntax_data (df,mods) in
+ (* Prepare the parsing and printing rules *)
let sy_rules = make_syntax_rules sy_data in
- Lib.add_anonymous_leaf (inSyntaxExtension(local,sy_rules));
- (* Declare interpretation *)
- let (onlyparse,extrarecvars,recvars,vars,df') = i_data in
- let (acvars,ac) = interp_aconstr (vars,recvars) c in
- let a = (remove_extravars extrarecvars acvars,ac) in
+ (* Prepare the interpretation *)
+ let (onlyparse,recvars,mainvars,df') = i_data in
+ let i_vars = make_internalization_vars recvars mainvars i_typs in
+ let (acvars,ac) = interp_aconstr i_vars recvars c in
+ let a = (make_interpretation_vars recvars acvars,ac) in
let onlyparse = onlyparse or is_not_printable ac in
+ (* Ready to change the global state *)
+ Flags.if_verbose (List.iter (fun (f,x) -> f x)) msgs;
+ Lib.add_anonymous_leaf (inSyntaxExtension(local,sy_rules));
Lib.add_anonymous_leaf (inNotation (local,scope,a,onlyparse,df'));
df'
let add_notation_interpretation_core local df ?(impls=empty_internalization_env) c scope onlyparse =
let dfs = split_notation_string df in
- let (extrarecvars,recvars,vars,symbs) = analyze_notation_tokens dfs in
- (* Redeclare pa/pp rules *)
- if not (is_numeral symbs) then begin
- let sy_rules = recover_notation_syntax (make_notation_key symbs) in
- Lib.add_anonymous_leaf (inSyntaxExtension (local,sy_rules))
- end;
+ let (recvars,mainvars,symbs) = analyze_notation_tokens dfs in
+ (* Recover types of variables and pa/pp rules; redeclare them if needed *)
+ let i_typs = if not (is_numeral symbs) then begin
+ let i_typs,sy_rules = recover_notation_syntax (make_notation_key symbs) in
+ Lib.add_anonymous_leaf (inSyntaxExtension (local,sy_rules)); i_typs
+ end else [] in
(* Declare interpretation *)
let path = (Lib.library_dp(),Lib.current_dirpath true) in
let df' = (make_notation_key symbs,(path,df)) in
- let (acvars,ac) = interp_aconstr ~impls (vars,recvars) c in
- let a = (remove_extravars extrarecvars acvars,ac) in
+ let i_vars = make_internalization_vars recvars mainvars i_typs in
+ let (acvars,ac) = interp_aconstr ~impls i_vars recvars c in
+ let a = (make_interpretation_vars recvars acvars,ac) in
let onlyparse = onlyparse or is_not_printable ac in
Lib.add_anonymous_leaf (inNotation (local,scope,a,onlyparse,df'));
df'
@@ -997,8 +1082,9 @@ let add_notation_interpretation_core local df ?(impls=empty_internalization_env)
(* Notations without interpretation (Reserved Notation) *)
let add_syntax_extension local ((loc,df),mods) =
- let (_,sy_data) = compute_syntax_data (df,mods) in
+ let msgs,sy_data = compute_pure_syntax_data (df,mods) in
let sy_rules = make_syntax_rules sy_data in
+ Flags.if_verbose (List.iter (fun (f,x) -> f x)) msgs;
Lib.add_anonymous_leaf (inSyntaxExtension(local,sy_rules))
(* Notations with only interpretation *)
@@ -1090,7 +1176,10 @@ let try_interp_name_alias = function
let add_syntactic_definition ident (vars,c) local onlyparse =
let vars,pat =
try [], ARef (try_interp_name_alias (vars,c))
- with Not_found -> let (vars,_),pat = interp_aconstr (vars,[]) c in vars,pat
+ with Not_found ->
+ let i_vars = List.map (fun id -> (id,NtnInternTypeConstr)) vars in
+ let vars,pat = interp_aconstr i_vars [] c in
+ List.map (fun (id,(sc,kind)) -> (id,sc)) vars, pat
in
let onlyparse = onlyparse or is_not_printable pat in
Syntax_def.declare_syntactic_definition local ident onlyparse (vars,pat)
diff --git a/toplevel/metasyntax.mli b/toplevel/metasyntax.mli
index 2fd7749d..d8dd0d52 100644
--- a/toplevel/metasyntax.mli
+++ b/toplevel/metasyntax.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: metasyntax.mli 13328 2010-07-26 11:05:30Z herbelin $ i*)
(*i*)
open Util
@@ -47,7 +47,7 @@ val add_notation_interpretation :
(* Add a notation interpretation for supporting the "where" clause *)
-val set_notation_for_interpretation : Constrintern.full_internalization_env ->
+val set_notation_for_interpretation : Constrintern.internalization_env ->
(lstring * constr_expr * scope_name option) -> unit
(* Add only the parsing/printing rule of a notation *)
diff --git a/toplevel/mltop.ml4 b/toplevel/mltop.ml4
index 5cefe263..e8c06d13 100644
--- a/toplevel/mltop.ml4
+++ b/toplevel/mltop.ml4
@@ -11,7 +11,7 @@
* camlp4deps will not work for this file unless Makefile system enhanced.
*)
-(* $Id$ *)
+(* $Id: mltop.ml4 13323 2010-07-24 15:57:30Z herbelin $ *)
open Util
open Pp
diff --git a/toplevel/mltop.mli b/toplevel/mltop.mli
index c2d65493..12b6f78f 100644
--- a/toplevel/mltop.mli
+++ b/toplevel/mltop.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: mltop.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(* If there is a toplevel under Coq, it is described by the following
record. *)
diff --git a/toplevel/record.ml b/toplevel/record.ml
index ae53b0cf..cd569178 100644
--- a/toplevel/record.ml
+++ b/toplevel/record.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: record.ml 13332 2010-07-26 22:12:43Z msozeau $ *)
open Pp
open Util
@@ -32,7 +32,6 @@ open Topconstr
(********** definition d'un record (structure) **************)
let interp_evars evdref env impls k typ =
- let impls = set_internalization_env_params impls [] in
let typ' = intern_gen true ~impls !evdref env typ in
let imps = Implicit_quantifiers.implicits_of_rawterm typ' in
imps, Pretyping.Default.understand_tcc_evars evdref env k typ'
@@ -48,8 +47,7 @@ let interp_fields_evars evars env nots l =
| Name id -> (id, compute_internalization_data env Constrintern.Method t' impl) :: impls
in
let d = (i,b',t') in
- let impls' = set_internalization_env_params impls [] in
- List.iter (Metasyntax.set_notation_for_interpretation impls') no;
+ List.iter (Metasyntax.set_notation_for_interpretation impls) no;
(push_rel d env, impl :: uimpls, d::params, impls))
(env, [], [], []) nots l
@@ -62,13 +60,13 @@ let binders_of_decls = List.map binder_of_decl
let typecheck_params_and_fields id t ps nots fs =
let env0 = Global.env () in
let evars = ref Evd.empty in
- let (env1,newps), imps = interp_context_evars ~fail_anonymous:false evars env0 ps in
+ let (env1,newps), imps = interp_context_evars evars env0 ps in
let fullarity = it_mkProd_or_LetIn (Option.cata (fun x -> x) (new_Type ()) t) newps in
let env_ar = push_rel_context newps (push_rel (Name id,None,fullarity) env0) in
let env2,impls,newfs,data =
interp_fields_evars evars env_ar nots (binders_of_decls fs)
in
- let evars,_ = Evarconv.consider_remaining_unif_problems env_ar !evars in
+ let evars = Evarconv.consider_remaining_unif_problems env_ar !evars in
let evars = Typeclasses.resolve_typeclasses env_ar evars in
let sigma = evars in
let newps = Evarutil.nf_rel_context_evar sigma newps in
diff --git a/toplevel/record.mli b/toplevel/record.mli
index eae279f3..ea4a3b7e 100644
--- a/toplevel/record.mli
+++ b/toplevel/record.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: record.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Names
diff --git a/toplevel/search.ml b/toplevel/search.ml
index a358f687..0bd552af 100644
--- a/toplevel/search.ml
+++ b/toplevel/search.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: search.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Pp
open Util
diff --git a/toplevel/search.mli b/toplevel/search.mli
index b4b971a7..a73052f2 100644
--- a/toplevel/search.mli
+++ b/toplevel/search.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: search.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
open Pp
open Names
diff --git a/toplevel/toplevel.ml b/toplevel/toplevel.ml
index 64096152..9594c988 100644
--- a/toplevel/toplevel.ml
+++ b/toplevel/toplevel.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: toplevel.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Pp
open Util
diff --git a/toplevel/toplevel.mli b/toplevel/toplevel.mli
index 92c8ddc4..a614c1da 100644
--- a/toplevel/toplevel.mli
+++ b/toplevel/toplevel.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: toplevel.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Pp
diff --git a/toplevel/usage.ml b/toplevel/usage.ml
index dcee9921..22588f2c 100644
--- a/toplevel/usage.ml
+++ b/toplevel/usage.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: usage.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
let version () =
Printf.printf "The Coq Proof Assistant, version %s (%s)\n"
diff --git a/toplevel/usage.mli b/toplevel/usage.mli
index 662f56ad..1167750b 100644
--- a/toplevel/usage.mli
+++ b/toplevel/usage.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: usage.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*s Prints the version number on the standard output and exits (with 0). *)
diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml
index 17792579..7f8bcb9e 100644
--- a/toplevel/vernac.ml
+++ b/toplevel/vernac.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: vernac.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
(* Parsing of vernacular. *)
diff --git a/toplevel/vernac.mli b/toplevel/vernac.mli
index d925614c..dc4d9e2f 100644
--- a/toplevel/vernac.mli
+++ b/toplevel/vernac.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: vernac.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(* Parsing of vernacular. *)
diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml
index 3a5e1da8..254f690c 100644
--- a/toplevel/vernacentries.ml
+++ b/toplevel/vernacentries.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: vernacentries.ml 13329 2010-07-26 11:05:39Z herbelin $ i*)
(* Concrete syntax of the mathematical vernacular MV V2.6 *)
@@ -626,7 +626,6 @@ let vernac_instance abst glob sup inst props pri =
ignore(Classes.new_instance ~abstract:abst ~global:glob sup inst props pri)
let vernac_context l =
- List.iter (fun x -> Dumpglob.dump_local_binder x true "var") l;
Classes.context l
let vernac_declare_instance glob id =
@@ -1079,7 +1078,7 @@ let vernac_global_check c =
let vernac_print = function
| PrintTables -> print_tables ()
- | PrintFullContext -> msg (print_full_context_typ ())
+ | PrintFullContext-> msg (print_full_context_typ ())
| PrintSectionContext qid -> msg (print_sec_context_typ qid)
| PrintInspect n -> msg (inspect n)
| PrintGrammar ent -> Metasyntax.print_grammar ent
diff --git a/toplevel/vernacentries.mli b/toplevel/vernacentries.mli
index 031864fd..10ed35a7 100644
--- a/toplevel/vernacentries.mli
+++ b/toplevel/vernacentries.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: vernacentries.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Names
diff --git a/toplevel/vernacexpr.ml b/toplevel/vernacexpr.ml
index 1f3261e1..5eb220cb 100644
--- a/toplevel/vernacexpr.ml
+++ b/toplevel/vernacexpr.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: vernacexpr.ml 13332 2010-07-26 22:12:43Z msozeau $ i*)
open Util
open Names
@@ -197,6 +197,7 @@ type proof_end =
type scheme =
| InductionScheme of bool * reference or_by_notation * sort_expr
+ | CaseScheme of bool * reference or_by_notation * sort_expr
| EqualityScheme of reference or_by_notation
type vernac_expr =
diff --git a/toplevel/vernacinterp.ml b/toplevel/vernacinterp.ml
index 90d8d9dd..f3d2e7a5 100644
--- a/toplevel/vernacinterp.ml
+++ b/toplevel/vernacinterp.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id$ *)
+(* $Id: vernacinterp.ml 13323 2010-07-24 15:57:30Z herbelin $ *)
open Pp
open Util
diff --git a/toplevel/vernacinterp.mli b/toplevel/vernacinterp.mli
index 8bcbe5f3..ce64188c 100644
--- a/toplevel/vernacinterp.mli
+++ b/toplevel/vernacinterp.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: vernacinterp.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(*i*)
open Tacexpr
diff --git a/toplevel/whelp.ml4 b/toplevel/whelp.ml4
index 20928cbe..15caaddd 100644
--- a/toplevel/whelp.ml4
+++ b/toplevel/whelp.ml4
@@ -8,7 +8,7 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
-(* $Id$ *)
+(* $Id: whelp.ml4 13323 2010-07-24 15:57:30Z herbelin $ *)
open Flags
open Pp
diff --git a/toplevel/whelp.mli b/toplevel/whelp.mli
index d6beeca1..27c36239 100644
--- a/toplevel/whelp.mli
+++ b/toplevel/whelp.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id$ i*)
+(*i $Id: whelp.mli 13323 2010-07-24 15:57:30Z herbelin $ i*)
(* Coq interface to the Whelp query engine developed at
the University of Bologna *)