diff options
245 files changed, 2415 insertions, 3756 deletions
diff --git a/.gitattributes b/.gitattributes index 6af0a106b..00f78b449 100644 --- a/.gitattributes +++ b/.gitattributes @@ -1,5 +1,3 @@ -.dir-locals.el export-ignore .gitattributes export-ignore .gitignore export-ignore .mailmap export-ignore -TODO export-ignore diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index ae55302d1..d2e335d45 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -60,6 +60,7 @@ before_script: paths: - _install_ci - config/Makefile + - test-suite/misc/universes/all_stdlib.v expire_in: 1 week script: - set -e @@ -70,6 +71,7 @@ before_script: - echo 'start:coq.build' - make -j ${NJOBS} + - make test-suite/misc/universes/all_stdlib.v - echo 'end:coq:build' - echo 'start:coq.install' diff --git a/.travis.yml b/.travis.yml index b9ea455da..1a9f6964f 100644 --- a/.travis.yml +++ b/.travis.yml @@ -31,6 +31,7 @@ env: # system is == 4.02.3 - COMPILER="system" - CAMLP5_VER="6.14" + - FINDLIB_VER="1.4.1" - NATIVE_COMP="yes" - COQ_DEST="-local" # Main test suites @@ -62,9 +63,6 @@ env: matrix: - allow_failures: - - env: TEST_TARGET="ci-geocoq TIMED=1" - include: # Full Coq test-suite with two compilers - env: @@ -95,6 +93,7 @@ matrix: - env: - TEST_TARGET="test-suite" - COMPILER="4.05.0" + - FINDLIB_VER="1.7.3" - CAMLP5_VER="7.01" - EXTRA_CONF="-coqide opt -with-doc yes" - EXTRA_OPAM="lablgtk-extras hevea" @@ -125,6 +124,7 @@ matrix: - TEST_TARGET="coqocaml" - COMPILER="4.05.0" - CAMLP5_VER="7.01" + - FINDLIB_VER="1.7.3" - EXTRA_CONF="-coqide opt -warn-error" - EXTRA_OPAM="lablgtk-extras hevea" # dummy target @@ -140,14 +140,15 @@ matrix: env: - TEST_TARGET="test-suite" - COMPILER="4.02.3" - - CAMLP5_VER="6.17" + - CAMLP5_VER="6.17" - NATIVE_COMP="no" - COQ_DEST="-local" before_install: - brew update --debug --verbose - brew install opam gnu-time - - os: osx + - if: NOT type IS pull_request + os: osx osx_image: xcode8.3 env: - TEST_TARGET="" @@ -172,14 +173,6 @@ matrix: skip_cleanup: true on: all_branches: true - - provider: releases - api_key: - secure: "Z/ewvydCLXEhlBBtQGYm2nZ8o+2RP+MwA5uEDuu6mEpZttUZAYaoHivChxADLXz8LNKvUloIeBeIL/PrLk6QnhSur/s2iEYHssrnl99SkAPtoWggyfsdacuKLMkpLoZGOBIEYKPuXuEZyqvugSUO42rSya1zdjcnXc4l+E/bXMc=" - file: _build/*.dmg - skip_cleanup: true - on: - tags: true - repo: coq/coq before_install: - if [ "${TRAVIS_PULL_REQUEST}" != "false" ]; then echo "Tested commit (followed by parent commits):"; git log -1; for commit in `git log -1 --format="%P"`; do echo; git log -1 $commit; done; fi @@ -188,7 +181,7 @@ install: - opam init -j ${NJOBS} --compiler=${COMPILER} -n -y - eval $(opam config env) - opam config list -- opam install -j ${NJOBS} -y camlp5.${CAMLP5_VER} ocamlfind ${EXTRA_OPAM} +- opam install -j ${NJOBS} -y camlp5.${CAMLP5_VER} ocamlfind.${FINDLIB_VER} ${EXTRA_OPAM} - opam list script: diff --git a/API/API.ml b/API/API.ml index 68da858ba..46ad36d36 100644 --- a/API/API.ml +++ b/API/API.ml @@ -162,6 +162,7 @@ module Indrec = Indrec (* module Cases *) module Pretyping = Pretyping module Unification = Unification +module Univdecls = Univdecls (******************************************************************************) (* interp *) (******************************************************************************) diff --git a/API/API.mli b/API/API.mli index 901ed3528..3ed326ff0 100644 --- a/API/API.mli +++ b/API/API.mli @@ -1648,6 +1648,14 @@ sig type sort_info = Names.Name.t Loc.located list type glob_sort = sort_info glob_sort_gen + type ('a, 'b) gen_universe_decl = { + univdecl_instance : 'a; (* Declared universes *) + univdecl_extensible_instance : bool; (* Can new universes be added *) + univdecl_constraints : 'b; (* Declared constraints *) + univdecl_extensible_constraints : bool (* Can new constraints be added *) } + + type glob_constraint = glob_level * Univ.constraint_type * glob_level + type case_style = Term.case_style = | LetStyle | IfStyle @@ -2300,7 +2308,7 @@ sig val universe_context_set : evar_map -> Univ.ContextSet.t val evar_ident : evar -> evar_map -> Names.Id.t option val extract_all_conv_pbs : evar_map -> evar_map * evar_constraint list - val universe_context : ?names:(Names.Id.t Loc.located) list -> evar_map -> + val universe_context : names:(Names.Id.t Loc.located) list -> extensible:bool -> evar_map -> (Names.Id.t * Univ.Level.t) list * Univ.UContext.t val nf_constraints : evar_map -> evar_map val from_ctx : UState.t -> evar_map @@ -2461,7 +2469,6 @@ sig constr_expr list list * local_binder_expr list list - type typeclass_constraint = (Names.Name.t Loc.located * Names.Id.t Loc.located list option) * Decl_kinds.binding_kind * constr_expr type constr_pattern_expr = constr_expr end @@ -2744,15 +2751,15 @@ sig the whole identifier except for the {i subscript}. E.g. if we take [foo42], then [42] is the {i subscript}, and [foo] is the root. *) - val next_ident_away : Names.Id.t -> Names.Id.t list -> Names.Id.t + val next_ident_away : Names.Id.t -> Names.Id.Set.t -> Names.Id.t val hdchar : Environ.env -> Evd.evar_map -> EConstr.types -> string val id_of_name_using_hdchar : Environ.env -> Evd.evar_map -> EConstr.types -> Names.Name.t -> Names.Id.t - val next_ident_away_in_goal : Names.Id.t -> Names.Id.t list -> Names.Id.t + val next_ident_away_in_goal : Names.Id.t -> Names.Id.Set.t -> Names.Id.t val default_dependent_ident : Names.Id.t - val next_global_ident_away : Names.Id.t -> Names.Id.t list -> Names.Id.t + val next_global_ident_away : Names.Id.t -> Names.Id.Set.t -> Names.Id.t val rename_bound_vars_as_displayed : - Evd.evar_map -> Names.Id.t list -> Names.Name.t list -> EConstr.types -> EConstr.types + Evd.evar_map -> Names.Id.Set.t -> Names.Name.t list -> EConstr.types -> EConstr.types end module Termops : @@ -3663,7 +3670,7 @@ sig type lname = Names.Name.t Loc.located type lident = Names.Id.t Loc.located type opacity_flag = - | Opaque of lident list option + | Opaque | Transparent type locality_flag = bool type inductive_kind = @@ -3676,7 +3683,7 @@ sig | VtProofStep of proof_step | VtProofMode of string | VtQuery of vernac_part_of_script * Feedback.route_id - | VtStm of vernac_control * vernac_part_of_script + | VtBack of vernac_part_of_script * Stateid.t | VtUnknown and vernac_qed_type = | VtKeep @@ -3685,10 +3692,6 @@ sig and vernac_start = string * opacity_guarantee * Names.Id.t list and vernac_sideff_type = Names.Id.t list and vernac_part_of_script = bool - and vernac_control = - | VtWait - | VtJoinDocument - | VtBack of Stateid.t and opacity_guarantee = | GuaranteesOpacity | Doesn'tGuaranteeOpacity @@ -3708,6 +3711,10 @@ sig type obsolete_locality = bool + type universe_decl_expr = (lident list, Misctypes.glob_constraint list) gen_universe_decl + + type ident_decl = lident * universe_decl_expr option + type lstring type 'a with_coercion = coercion_flag * 'a type scope_name = string @@ -3725,9 +3732,7 @@ sig | Constructors of constructor_expr list | RecordDecl of lident option * local_decl_expr with_instance with_priority with_notation list - type plident = lident * lident list option - - type inductive_expr = plident with_coercion * Constrexpr.local_binder_expr list * Constrexpr.constr_expr option * inductive_kind * constructor_list_or_record_decl_expr + type inductive_expr = ident_decl with_coercion * Constrexpr.local_binder_expr list * Constrexpr.constr_expr option * inductive_kind * constructor_list_or_record_decl_expr type syntax_modifier = | SetItemLevel of string list * Extend.production_level @@ -3741,18 +3746,20 @@ sig type class_rawexpr = FunClass | SortClass | RefClass of reference or_by_notation + type typeclass_constraint = (Names.Name.t Loc.located * universe_decl_expr option) * Decl_kinds.binding_kind * constr_expr + type definition_expr = | ProveBody of local_binder_expr list * constr_expr | DefineBody of local_binder_expr list * Genredexpr.raw_red_expr option * constr_expr * constr_expr option type proof_expr = - plident option * (local_binder_expr list * constr_expr) + ident_decl option * (local_binder_expr list * constr_expr) type proof_end = | Admitted | Proved of opacity_flag * lident option - type fixpoint_expr = plident * (Names.Id.t Loc.located option * Constrexpr.recursion_order_expr) * Constrexpr.local_binder_expr list * Constrexpr.constr_expr * Constrexpr.constr_expr option + type fixpoint_expr = ident_decl * (Names.Id.t Loc.located option * Constrexpr.recursion_order_expr) * Constrexpr.local_binder_expr list * Constrexpr.constr_expr * Constrexpr.constr_expr option type cofixpoint_expr @@ -3770,7 +3777,6 @@ sig type option_value type showable type bullet - type stm_vernac type comment type register_kind type locatable @@ -3831,12 +3837,12 @@ sig scope_name option | VernacNotationAddFormat of string * string * string | VernacDefinition of - (Decl_kinds.locality option * Decl_kinds.definition_object_kind) * plident * definition_expr + (Decl_kinds.locality option * Decl_kinds.definition_object_kind) * ident_decl * definition_expr | VernacStartTheoremProof of Decl_kinds.theorem_kind * proof_expr list | VernacEndProof of proof_end | VernacExactProof of Constrexpr.constr_expr | VernacAssumption of (Decl_kinds.locality option * Decl_kinds.assumption_object_kind) * - inline * (plident list * Constrexpr.constr_expr) with_coercion list + inline * (ident_decl list * Constrexpr.constr_expr) with_coercion list | VernacInductive of cumulative_inductive_parsing_flag * Decl_kinds.private_flag * inductive_flag * (inductive_expr * decl_notation list) list | VernacFixpoint of Decl_kinds.locality option * (fixpoint_expr * decl_notation list) list @@ -3860,7 +3866,7 @@ sig | VernacInstance of bool * Constrexpr.local_binder_expr list * - Constrexpr.typeclass_constraint * + typeclass_constraint * (bool * Constrexpr.constr_expr) option * hint_info_expr | VernacContext of Constrexpr.local_binder_expr list @@ -3922,7 +3928,6 @@ sig | VernacLocate of locatable | VernacRegister of lident * register_kind | VernacComments of comment list - | VernacStm of stm_vernac | VernacGoal of Constrexpr.constr_expr | VernacAbort of lident option | VernacAbortAll @@ -3952,7 +3957,7 @@ sig | SelectAll and vernac_classification = vernac_type * vernac_when and one_inductive_expr = - plident * Constrexpr.local_binder_expr list * Constrexpr.constr_expr option * constructor_expr list + ident_decl * Constrexpr.local_binder_expr list * Constrexpr.constr_expr option * constructor_expr list end (* XXX: end manual intf move *) @@ -4006,7 +4011,7 @@ sig | Later : [ `thunk ] delay val print_universes : bool ref val print_evar_arguments : bool ref - val detype : 'a delay -> ?lax:bool -> bool -> Names.Id.t list -> Environ.env -> Evd.evar_map -> EConstr.constr -> 'a Glob_term.glob_constr_g + val detype : 'a delay -> ?lax:bool -> bool -> Names.Id.Set.t -> Environ.env -> Evd.evar_map -> EConstr.constr -> 'a Glob_term.glob_constr_g val subst_glob_constr : Mod_subst.substitution -> Glob_term.glob_constr -> Glob_term.glob_constr val set_detype_anonymous : (?loc:Loc.t -> int -> Names.Id.t) -> unit end @@ -4089,6 +4094,18 @@ sig Environ.env -> Evd.evar_map -> ?flags:unify_flags -> EConstr.constr * EConstr.constr -> Evd.evar_map * EConstr.constr end +module Univdecls : +sig + type universe_decl = + (Names.Id.t Loc.located list, Univ.Constraint.t) Misctypes.gen_universe_decl + + val interp_univ_decl : Environ.env -> Vernacexpr.universe_decl_expr -> + Evd.evar_map * universe_decl + val interp_univ_decl_opt : Environ.env -> Vernacexpr.universe_decl_expr option -> + Evd.evar_map * universe_decl + val default_univ_decl : universe_decl +end + (************************************************************************) (* End of modules from pretyping/ *) (************************************************************************) @@ -4487,12 +4504,11 @@ sig type proof_terminator type lemma_possible_guards - type universe_binders type closed_proof = proof_object * proof_terminator val make_terminator : (proof_ending -> unit) -> proof_terminator val start_dependent_proof : - Names.Id.t -> ?pl:universe_binders -> Decl_kinds.goal_kind -> + Names.Id.t -> ?pl:Univdecls.universe_decl -> Decl_kinds.goal_kind -> Proofview.telescope -> proof_terminator -> unit val with_current_proof : (unit Proofview.tactic -> Proof.proof -> Proof.proof * 'a) -> 'a @@ -4612,6 +4628,7 @@ sig val pf_env : 'a Proofview.Goal.t -> Environ.env val pf_ids_of_hyps : 'a Proofview.Goal.t -> Names.Id.t list + val pf_ids_set_of_hyps : 'a Proofview.Goal.t -> Names.Id.Set.t val pf_concl : 'a Proofview.Goal.t -> EConstr.types val pf_get_new_id : Names.Id.t -> 'a Proofview.Goal.t -> Names.Id.t val pf_get_hyp_typ : Names.Id.t -> 'a Proofview.Goal.t -> EConstr.types @@ -5124,7 +5141,7 @@ sig val convert_concl : ?check:bool -> EConstr.types -> Constr.cast_kind -> unit tactic val intro_using : Names.Id.t -> unit tactic val intro : unit tactic - val fresh_id_in_env : Names.Id.t list -> Names.Id.t -> Environ.env -> Names.Id.t + val fresh_id_in_env : Names.Id.Set.t -> Names.Id.t -> Environ.env -> Names.Id.t val is_quantified_hypothesis : Names.Id.t -> 'a Goal.t -> bool val tclABSTRACT : ?opaque:bool -> Names.Id.t option -> unit Proofview.tactic -> unit Proofview.tactic val intro_patterns : bool -> Tactypes.intro_patterns -> unit Proofview.tactic @@ -5224,7 +5241,7 @@ sig val eapply_with_bindings : EConstr.constr Misctypes.with_bindings -> unit Proofview.tactic val assert_by : Names.Name.t -> EConstr.types -> unit Proofview.tactic -> unit Proofview.tactic - val intro_avoiding : Names.Id.t list -> unit Proofview.tactic + val intro_avoiding : Names.Id.Set.t -> unit Proofview.tactic val pose_proof : Names.Name.t -> EConstr.constr -> unit Proofview.tactic val pattern_option : (Locus.occurrences * EConstr.constr) list -> Locus.goal_location -> unit Proofview.tactic val compute_elim_sig : Evd.evar_map -> ?elimc:EConstr.constr Misctypes.with_bindings -> EConstr.types -> elim_scheme @@ -5546,7 +5563,7 @@ sig val mk_hook : (Decl_kinds.locality -> Globnames.global_reference -> 'a) -> 'a declaration_hook - val start_proof : Names.Id.t -> ?pl:Proof_global.universe_binders -> Decl_kinds.goal_kind -> Evd.evar_map -> + val start_proof : Names.Id.t -> ?pl:Univdecls.universe_decl -> Decl_kinds.goal_kind -> Evd.evar_map -> ?terminator:(Proof_global.lemma_possible_guards -> unit declaration_hook -> Proof_global.proof_terminator) -> ?sign:Environ.named_context_val -> EConstr.types -> ?init_tac:unit Proofview.tactic -> ?compute_guard:Proof_global.lemma_possible_guards -> @@ -5622,7 +5639,7 @@ sig type structured_fixpoint_expr = { fix_name : Id.t; - fix_univs : lident list option; + fix_univs : universe_decl_expr option; fix_annot : Id.t Loc.located option; fix_binders : local_binder_expr list; fix_body : constr_expr option; @@ -5631,7 +5648,7 @@ sig type structured_one_inductive_expr = { ind_name : Id.t; - ind_univs : lident list option; + ind_univs : universe_decl_expr option; ind_arity : constr_expr; ind_lc : (Id.t * constr_expr) list } @@ -5647,7 +5664,7 @@ sig (Vernacexpr.one_inductive_expr * Vernacexpr.decl_notation list) list -> Decl_kinds.cumulative_inductive_flag -> Decl_kinds.polymorphic -> Decl_kinds.private_flag -> Decl_kinds.recursivity_kind -> unit - val do_definition : Names.Id.t -> Decl_kinds.definition_kind -> Vernacexpr.lident list option -> + val do_definition : Names.Id.t -> Decl_kinds.definition_kind -> Vernacexpr.universe_decl_expr option -> Constrexpr.local_binder_expr list -> Redexpr.red_expr option -> Constrexpr.constr_expr -> Constrexpr.constr_expr option -> unit Lemmas.declaration_hook -> unit @@ -5660,7 +5677,7 @@ sig val interp_fixpoint : structured_fixpoint_expr list -> Vernacexpr.decl_notation list -> - recursive_preentry * Vernacexpr.lident list option * UState.t * + recursive_preentry * Univdecls.universe_decl * UState.t * (EConstr.rel_context * Impargs.manual_implicits * int option) list val extract_mutual_inductive_declaration_components : @@ -5688,7 +5705,7 @@ sig ?refine:bool -> Decl_kinds.polymorphic -> Constrexpr.local_binder_expr list -> - Constrexpr.typeclass_constraint -> + Vernacexpr.typeclass_constraint -> (bool * Constrexpr.constr_expr) option -> ?generalize:bool -> ?tac:unit Proofview.tactic -> @@ -15,14 +15,22 @@ Tactics profiling, and "Set NativeCompute Profile Filename" customizes the profile filename. -Changes from 8.7+beta1 to 8.7.0 -=============================== +Changes from 8.7+beta1 to 8.7+beta2 +=================================== Tools - In CoqIDE, the "Compile Buffer" command takes account of flags in _CoqProject or other project file. +Improvements around some error messages. + +Many bug fixes including two important ones: + +- BZ#5730: CoqIDE becomes unresponsive on file open. +- coq_makefile: make sure compile flags for Coq and coq_makefile are in sync + (in particular, make sure the `-safe-string` option is used to compile plugins). + Changes from 8.6.1 to 8.7+beta1 =============================== @@ -135,6 +143,13 @@ Plugins - The mathematical proof language (also known as declarative mode) was removed. - A new command Extraction TestCompile has been introduced, not meant for the general user but instead for Coq's test-suite. +- The extraction plugin is no longer loaded by default. It must be + explicitly loaded with [Require Extraction], which is backwards + compatible. +- The functional induction plugin (which provides the [Function] + vernacular) is no longer loaded by default. It must be explicitly + loaded with [Require FunInd], which is backwards compatible. + Dependencies diff --git a/COMPATIBILITY b/COMPATIBILITY index 78dfabaa3..b5fed7f01 100644 --- a/COMPATIBILITY +++ b/COMPATIBILITY @@ -5,6 +5,10 @@ Potential sources of incompatibilities between Coq V8.6 and V8.7 error rather than a warning when the superfluous name is already in use. The easy fix is to remove the superfluous name. +- Proofs ending in "Qed exporting ident, .., ident" are not supported + anymore. Constants generated during `abstract` are kept private to the + local environment. + Potential sources of incompatibilities between Coq V8.5 and V8.6 ---------------------------------------------------------------- @@ -1,5 +1,5 @@ - INSTALLATION PROCEDURES FOR THE COQ V8.6 SYSTEM + INSTALLATION PROCEDURES FOR THE COQ V8.7 SYSTEM ----------------------------------------------- @@ -27,19 +27,16 @@ WHAT DO YOU NEED ? port install coq - To compile Coq V8.6 yourself, you need: + To compile Coq V8.7 yourself, you need: - - OCaml version 4.02.1 or later - (available at http://caml.inria.fr/) + - OCaml version 4.02.3 or later + (available at https://ocaml.org/) - OCaml version 4.02.0 is not supported because of a severe performance - issue increasing compilation time. + - Findlib (version >= 1.4.1) + (available at http://projects.camlcity.org/projects/findlib.html) - - Findlib (included in OCaml binary distribution under windows, - probably available in your distribution and for sure at - http://projects.camlcity.org/projects/findlib.html) - - - Camlp5 (version >= 6.02) + - Camlp5 (version >= 6.14) + (available at https://camlp5.github.io/) - GNU Make version 3.81 or later @@ -48,6 +45,12 @@ WHAT DO YOU NEED ? - for Coqide, the Lablgtk development files, and the GTK libraries incuding gtksourceview, see INSTALL.ide for more details + Opam (https://opam.ocaml.org/) is recommended to install ocaml and + the corresponding packages. + + $ opam install ocamlfind camlp5 lablgtk-extras + + should get you a reasonable OCaml environment to compile Coq. QUICK INSTALLATION PROCEDURE. ============================= diff --git a/Makefile.build b/Makefile.build index 26a40c6cc..ecaaccaaf 100644 --- a/Makefile.build +++ b/Makefile.build @@ -195,8 +195,8 @@ MLINCLUDES=$(LOCALINCLUDES) -I $(MYCAMLP4LIB) OCAMLC := $(OCAMLFIND) ocamlc $(CAMLFLAGS) OCAMLOPT := $(OCAMLFIND) opt $(CAMLFLAGS) -BYTEFLAGS=-thread $(CAMLDEBUG) $(USERFLAGS) -OPTFLAGS=-thread $(CAMLDEBUGOPT) $(CAMLTIMEPROF) $(USERFLAGS) +BYTEFLAGS=$(CAMLDEBUG) $(USERFLAGS) +OPTFLAGS=$(CAMLDEBUGOPT) $(CAMLTIMEPROF) $(USERFLAGS) DEPFLAGS=$(LOCALINCLUDES)$(if $(filter plugins/%,$<),, -I ide -I ide/utils) # On MacOS, the binaries are signed, except our private ones @@ -429,6 +429,7 @@ tools: $(TOOLS) $(OCAMLLIBDEP) $(COQDEPBOOT) # is being built. COQDEPBOOTSRC := lib/minisys.cmo \ + lib/segmenttree.cmo lib/unicodetable.cmo lib/unicode.cmo \ tools/coqdep_lexer.cmo tools/coqdep_common.cmo tools/coqdep_boot.cmo tools/coqdep_lexer.cmo : tools/coqdep_lexer.cmi @@ -449,6 +450,7 @@ $(OCAMLLIBDEP): $(call bestobj, tools/ocamllibdep.cmo) # The full coqdep (unused by this build, but distributed by make install) COQDEPCMO:=lib/clib.cma lib/cErrors.cmo lib/cWarnings.cmo lib/minisys.cmo \ + lib/segmenttree.cmo lib/unicodetable.cmo lib/unicode.cmo \ lib/system.cmo tools/coqdep_lexer.cmo tools/coqdep_common.cmo \ tools/coqdep.cmo diff --git a/Makefile.doc b/Makefile.doc index 0c3b70149..faa9c879c 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -61,7 +61,7 @@ REFMANCOQTEXFILES:=$(addprefix doc/refman/, \ REFMANTEXFILES:=$(addprefix doc/refman/, \ headers.sty Reference-Manual.tex \ RefMan-pre.tex RefMan-int.tex RefMan-com.tex \ - RefMan-uti.tex RefMan-ide.tex RefMan-add.tex RefMan-modr.tex \ + RefMan-uti.tex RefMan-ide.tex RefMan-modr.tex \ AsyncProofs.tex RefMan-ssr.tex) \ $(REFMANCOQTEXFILES) \ diff --git a/checker/checker.ml b/checker/checker.ml index 7a69700d2..247a98e63 100644 --- a/checker/checker.ml +++ b/checker/checker.ml @@ -10,7 +10,6 @@ open Pp open CErrors open Util open System -open Flags open Names open Check @@ -74,7 +73,7 @@ let add_path ~unix_path:dir ~coq_root:coq_dirpath = let convert_string d = try Id.of_string d with CErrors.UserError _ -> - if_verbose Feedback.msg_warning + Flags.if_verbose Feedback.msg_warning (str "Directory " ++ str d ++ str " cannot be used as a Coq identifier (skipped)"); raise Exit @@ -342,7 +341,7 @@ let parse_args argv = | ("-?"|"-h"|"-H"|"-help"|"--help") :: _ -> usage () | ("-v"|"--version") :: _ -> version () - | "-boot" :: rem -> boot := true; parse rem + | "-boot" :: rem -> Flags.boot := true; parse rem | ("-m" | "--memory") :: rem -> Check_stat.memory_stat := true; parse rem | ("-o" | "--output-context") :: rem -> Check_stat.output_context := true; parse rem @@ -366,15 +365,53 @@ let parse_args argv = (* To prevent from doing the initialization twice *) let initialized = ref false +(* XXX: At some point we need to either port the checker to use the + feedback system or to remove its use completely. *) +let init_feedback_listener () = + let open Format in + let pp_lvl fmt lvl = let open Feedback in match lvl with + | Error -> fprintf fmt "Error: " + | Info -> fprintf fmt "Info: " + | Debug -> fprintf fmt "Debug: " + | Warning -> fprintf fmt "Warning: " + | Notice -> fprintf fmt "" + in + let pp_loc fmt loc = let open Loc in match loc with + | None -> fprintf fmt "" + | Some loc -> + let where = + match loc.fname with InFile f -> f | ToplevelInput -> "Toplevel input" in + fprintf fmt "\"%s\", line %d, characters %d-%d:@\n" + where loc.line_nb (loc.bp-loc.bol_pos) (loc.ep-loc.bol_pos) in + let checker_feed (fb : Feedback.feedback) = let open Feedback in + match fb.contents with + | Processed -> () + | Incomplete -> () + | Complete -> () + | ProcessingIn _ -> () + | InProgress _ -> () + | WorkerStatus (_,_) -> () + | AddedAxiom -> () + | GlobRef (_,_,_,_,_) -> () + | GlobDef (_,_,_,_) -> () + | FileDependency (_,_) -> () + | FileLoaded (_,_) -> () + | Custom (_,_,_) -> () + (* Re-enable when we switch back to feedback-based error printing *) + | Message (lvl,loc,msg) -> + Format.eprintf "@[%a@]%a@[%a@]\n%!" pp_loc loc pp_lvl lvl Pp.pp_with msg + in ignore(Feedback.add_feeder checker_feed) + let init_with_argv argv = if not !initialized then begin initialized := true; Sys.catch_break false; (* Ctrl-C is fatal during the initialisation *) + init_feedback_listener (); try parse_args argv; if !Flags.debug then Printexc.record_backtrace true; Envars.set_coqlib ~fail:(fun x -> CErrors.user_err Pp.(str x)); - if_verbose print_header (); + Flags.if_verbose print_header (); init_load_path (); engage (); with e -> diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index 3c9e1cac5..63e28448f 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -25,7 +25,7 @@ let refresh_arity ar = | _ -> ar, Univ.ContextSet.empty let check_constant_declaration env kn cb = - Feedback.msg_notice (str " checking cst:" ++ prcon kn); + Flags.if_verbose Feedback.msg_notice (str " checking cst:" ++ prcon kn); (** [env'] contains De Bruijn universe variables *) let env' = match cb.const_universes with diff --git a/config/coq_config.mli b/config/coq_config.mli index b0f39e9d2..429d8811b 100644 --- a/config/coq_config.mli +++ b/config/coq_config.mli @@ -36,6 +36,7 @@ val camlp4compat : string (* compatibility argument to camlp4/5 *) val coqideincl : string (* arguments for building coqide (e.g. lablgtk) *) val cflags : string (* arguments passed to gcc *) +val caml_flags : string (* arguments passed to ocamlc (ie. CAMLFLAGS) *) val best : string (* byte/opt *) val arch : string (* architecture *) diff --git a/configure.ml b/configure.ml index b5e456779..fc2233f78 100644 --- a/configure.ml +++ b/configure.ml @@ -263,10 +263,6 @@ module Prefs = struct let debug = ref true let profile = ref false let annotate = ref false - (* Note, disabling this should be OK, but be careful with the - sharing invariants. - *) - let safe_string = ref true let nativecompiler = ref (not (os_type_win32 || os_type_cygwin)) let coqwebsite = ref "http://coq.inria.fr/" let force_caml_version = ref false @@ -376,8 +372,9 @@ let coq_annotate_flag = then if program_in_path "ocamlmerlin" then "-bin-annot" else "-annot" else "" -let coq_safe_string = - if !Prefs.safe_string then "-safe-string" else "" +(* This variable can be overriden only for debug purposes, use with + care. *) +let coq_safe_string = "-safe-string" let cflags = "-Wall -Wno-unused -g -O2" @@ -512,19 +509,22 @@ let camltag = match caml_version_list with 50: unexpected documentation comment: too common and annoying to avoid 56: unreachable match case: the [_ -> .] syntax doesn't exist in 4.02.3 *) -let coq_warn_flags = - let warnings = "-w +a-4-9-27-41-42-44-45-48-50" in - let errors = +let coq_warnings = "-w +a-4-9-27-41-42-44-45-48-50" +let coq_warn_error = if !Prefs.warn_error then "-warn-error +a" ^ (if caml_version_nums > [4;2;3] then "-56" else "") else "" - in - warnings ^ " " ^ errors +(* Flags used to compile Coq and plugins (via coq_makefile) *) +let caml_flags = + Printf.sprintf "-thread -rectypes %s %s %s" coq_warnings coq_annotate_flag coq_safe_string +(* Flags used to compile Coq but _not_ plugins (via coq_makefile) *) +let coq_caml_flags = + coq_warn_error (** * CamlpX configuration *) @@ -1050,6 +1050,7 @@ let write_configml f = pr_s "camlp4lib" camlpXlibdir; pr_s "camlp4compat" camlp4compat; pr_s "cflags" cflags; + pr_s "caml_flags" caml_flags; pr_s "best" best_compiler; pr_s "osdeplibs" osdeplibs; pr_s "version" coq_version; @@ -1156,7 +1157,7 @@ let write_makefile f = pr "CAMLHLIB=%S\n\n" camllib; pr "# Caml link command and Caml make top command\n"; pr "# Caml flags\n"; - pr "CAMLFLAGS=-rectypes %s %s %s\n" coq_warn_flags coq_annotate_flag coq_safe_string; + pr "CAMLFLAGS=%s %s\n" caml_flags coq_caml_flags; pr "# User compilation flag\n"; pr "USERFLAGS=\n\n"; pr "# Flags for GCC\n"; diff --git a/dev/Coq_Bugzilla_autolink.user.js b/dev/Coq_Bugzilla_autolink.user.js new file mode 100644 index 000000000..371c5adc0 --- /dev/null +++ b/dev/Coq_Bugzilla_autolink.user.js @@ -0,0 +1,34 @@ +// ==UserScript== +// @name Coq Bugzilla autolink +// @namespace SkySkimmer +// @include https://github.com/coq/coq/* +// @description Makes BZ#XXXX into links to bugzilla for GitHub +// @version 1 +// @grant none +// ==/UserScript== + +var regex = /BZ#(\d+)/g; +var substr = '<a href="https://coq.inria.fr/bugs/show_bug.cgi?id=$1">$&</a>'; + +function doNode(node) +{ + node.innerHTML = node.innerHTML.replace(regex,substr); +} + +var comments = document.getElementsByClassName("comment-body"); + +for(var i=0; i<comments.length; i++) +{ + var pars = comments[i].getElementsByTagName("p"); + for(var j=0; j<pars.length; j++) + { + doNode(pars[j]); + } +} + +// usually 1 or 0 titles... +var titles = document.getElementsByClassName("js-issue-title"); +for(var i=0; i<titles.length; i++) +{ + doNode(titles[i]); +} diff --git a/dev/build/windows/MakeCoq_MinGW.bat b/dev/build/windows/MakeCoq_MinGW.bat index a420b5d8b..f91b301b8 100644 --- a/dev/build/windows/MakeCoq_MinGW.bat +++ b/dev/build/windows/MakeCoq_MinGW.bat @@ -328,12 +328,6 @@ ECHO ========== INSTALL CYGWIN ========== REM Cygwin setup sets proper ACLs (permissions) for folders it CREATES. REM Otherwise chmod won't work and e.g. the ocaml build will fail. REM Cygwin setup does not touch the ACLs of existing folders. -REM => Create the setup log in a temporary location and move it later. - -REM Get Unique temporary file name -:logfileloop -SET LOGFILE=%TEMP%\CygwinSetUp%RANDOM%-%RANDOM%-%RANDOM%-%RANDOM%.log -if exist "%LOGFILE%" GOTO logfileloop REM Run Cygwin Setup @@ -348,6 +342,12 @@ IF "%COQREGTESTING%" == "Y" ( SET RUNSETUP=Y ) +SET "EXTRAPACKAGES= " + +IF NOT "%APPVEYOR%" == "True" ( + SET EXTRAPACKAGES="-P wget,curl,git,gcc-core,gcc-g++,automake1.5" +) + IF "%RUNSETUP%"=="Y" ( %SETUP% ^ --proxy "%PROXY%" ^ @@ -356,10 +356,9 @@ IF "%RUNSETUP%"=="Y" ( --local-package-dir "%CYGWIN_LOCAL_CACHE_WFMT%" ^ --no-shortcuts ^ %CYGWIN_OPT% ^ - -P wget,curl,git,make,unzip ^ - -P gcc-core,gcc-g++ ^ + -P make,unzip ^ -P gdb,liblzma5 ^ - -P patch,automake1.14,automake1.15 ^ + -P patch,automake1.14 ^ -P mingw64-%ARCH%-binutils,mingw64-%ARCH%-gcc-core,mingw64-%ARCH%-gcc-g++,mingw64-%ARCH%-pkg-config,mingw64-%ARCH%-windows_default_manifest ^ -P mingw64-%ARCH%-headers,mingw64-%ARCH%-runtime,mingw64-%ARCH%-pthreads,mingw64-%ARCH%-zlib ^ -P libiconv-devel,libunistring-devel,libncurses-devel ^ @@ -369,12 +368,11 @@ IF "%RUNSETUP%"=="Y" ( -P gtk-update-icon-cache ^ -P libtool,automake ^ -P intltool ^ - > "%LOGFILE%" ^ + %EXTRAPACKAGES% ^ || GOTO ErrorExit MKDIR "%CYGWIN_INSTALLDIR_WFMT%\build" MKDIR "%CYGWIN_INSTALLDIR_WFMT%\build\buildlogs" - MOVE "%LOGFILE%" "%CYGWIN_INSTALLDIR_WFMT%\build\buildlogs\cygwinsetup.log" || GOTO ErrorExit ) diff --git a/dev/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh index f3e4cec0b..f12cbe0a7 100644 --- a/dev/build/windows/makecoq_mingw.sh +++ b/dev/build/windows/makecoq_mingw.sh @@ -910,6 +910,10 @@ function make_camlp5 { log2 make install # For some reason gramlib.a is not copied, but it is required by Coq cp lib/gramlib.a "$PREFIXOCAML/libocaml/camlp5/" + # For some reason META is not copied, but it is required by coq_makefile + log2 make -C etc META + mkdir -p "$PREFIXOCAML/libocaml/site-lib/camlp5/" + cp etc/META "$PREFIXOCAML/libocaml/site-lib/camlp5/" log2 make clean build_post fi diff --git a/dev/ci/appveyor.bat b/dev/ci/appveyor.bat index ca6a5643c..e2fbf1f6d 100644 --- a/dev/ci/appveyor.bat +++ b/dev/ci/appveyor.bat @@ -23,13 +23,19 @@ if %USEOPAM% == false ( call %APPVEYOR_BUILD_FOLDER%\dev\build\windows\MakeCoq_MinGW.bat -threads=1 ^ -arch=%ARCH% -installer=Y -coqver=%APPVEYOR_BUILD_FOLDER_CFMT% ^ -destcyg=%CYGROOT% -destcoq=%DESTCOQ% -cygcache=%CYGCACHE% ^ - -setup %CYGROOT%\%SETUP% - copy "%CYGROOT%\build\coq-local\dev\nsis\*.exe" dev\nsis - 7z a coq-opensource-archive-%ARCHLONG%.zip %CYGROOT%\build\tarballs\* + -setup %CYGROOT%\%SETUP% || GOTO ErrorExit + copy "%CYGROOT%\build\coq-local\dev\nsis\*.exe" dev\nsis || GOTO ErrorExit + 7z a coq-opensource-archive-%ARCHLONG%.zip %CYGROOT%\build\tarballs\* || GOTO ErrorExit ) if %USEOPAM% == true ( %CYGROOT%\%SETUP% -qnNdO -R %CYGROOT% -l %CYGCACHE% -s %CYGMIRROR% ^ -P rsync -P patch -P diffutils -P make -P unzip -P m4 -P findutils -P time - %CYGROOT%/bin/bash -l %APPVEYOR_BUILD_FOLDER%/dev/ci/appveyor.sh + %CYGROOT%/bin/bash -l %APPVEYOR_BUILD_FOLDER%/dev/ci/appveyor.sh || GOTO ErrorExit ) + +GOTO :EOF + +:ErrorExit + ECHO ERROR MakeCoq_MinGW.bat failed + EXIT /b 1 diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index 8e7265969..43525dcd4 100644 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -127,5 +127,5 @@ ######################################################################## # Bignums ######################################################################## -: ${bignums_CI_BRANCH:=fix-thunk-printer} -: ${bignums_CI_GITURL:=https://github.com/ppedrot/bignums.git} +: ${bignums_CI_BRANCH:=master} +: ${bignums_CI_GITURL:=https://github.com/coq/bignums.git} diff --git a/dev/ci/ci-common.sh b/dev/ci/ci-common.sh index 358f527f9..1bfdf7dfb 100644 --- a/dev/ci/ci-common.sh +++ b/dev/ci/ci-common.sh @@ -5,6 +5,7 @@ set -xe if [ -n "${GITLAB_CI}" ]; then export COQBIN=`pwd`/_install_ci/bin + export TRAVIS_BRANCH="$CI_COMMIT_REF_NAME" else export COQBIN=`pwd`/bin fi diff --git a/dev/ci/ci-geocoq.sh b/dev/ci/ci-geocoq.sh index eadeb7c38..8e6448e76 100755 --- a/dev/ci/ci-geocoq.sh +++ b/dev/ci/ci-geocoq.sh @@ -8,9 +8,5 @@ GeoCoq_CI_DIR=${CI_BUILD_DIR}/GeoCoq git_checkout ${GeoCoq_CI_BRANCH} ${GeoCoq_CI_GITURL} ${GeoCoq_CI_DIR} ( cd ${GeoCoq_CI_DIR} && \ - ./configure.sh && \ - sed -i.bak '/Ch16_coordinates_with_functions\.v/d' Make && \ - sed -i.bak '/Elements\/Book_1\.v/d' Make && \ - sed -i.bak '/Elements\/Book_3\.v/d' Make && \ - coq_makefile -f Make -o Makefile && \ + ./configure-ci.sh && \ make ) diff --git a/dev/doc/changes.md b/dev/doc/changes.md index 5ed74917a..b5e19f33c 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -641,6 +641,12 @@ The main search functions now take a function iterating over the results. This allows for clients to use streaming or more economic printing. +### XML Protocol + +- In several places, flat text wrapped in `<string>` tags now appears as structured text inside `<richpp>` tags. + +- The "errormsg" feedback has been replaced by a "message" feedback which contains `<feedback\_content>` tag, with a message_level attribute of "error". + ## Changes between Coq 8.4 and Coq 8.5 ### Refactoring : more mli interfaces and simpler grammar.cma diff --git a/dev/doc/xml-protocol.md b/dev/doc/xml-protocol.md index 127b4a6d2..18f6288f6 100644 --- a/dev/doc/xml-protocol.md +++ b/dev/doc/xml-protocol.md @@ -1,4 +1,4 @@ -#Coq XML Protocol for Coq 8.6# +# Coq XML Protocol This document is based on documentation originally written by CJ Bell for his [vscoq](https://github.com/siegebell/vscoq/) project. @@ -12,11 +12,7 @@ A somewhat out-of-date description of the async state machine is [documented here](https://github.com/ejgallego/jscoq/blob/master/etc/notes/coq-notes.md). OCaml types for the protocol can be found in the [`ide/interface.mli` file](/ide/interface.mli). -# CHANGES -## Changes from 8.5: - * In several places, flat text wrapped in <string> tags now appears as structured text inside <richpp> tags - * The "errormsg" feedback has been replaced by a "message" feedback which contains - <feedback\_content> tag, with a message_level attribute of "error" +Changes to the XML protocol are documented as part of [`dev/doc/changes.txt`](/dev/doc/changes.txt). * [Commands](#commands) - [About](#command-about) @@ -291,7 +287,10 @@ Pseudocode for listing all of the goals in order: `rev (flat_map fst background) ### <a name="command-status">**Status(force: bool)**</a> -CoqIDE typically sets `force` to `false`. +Returns information about the current proofs. CoqIDE typically sends this +message with `force = false` after each sentence, and with `force = true` if +the user wants to force the checking of all proofs (wheels button). In terms of +the STM API, `force` triggers a `Join`. ```html <call val="Status"><bool val="${force}"/></call> ``` diff --git a/doc/common/styles/html/coqremote/cover.html b/doc/common/styles/html/coqremote/cover.html index 1c415eca6..5d151381f 100644 --- a/doc/common/styles/html/coqremote/cover.html +++ b/doc/common/styles/html/coqremote/cover.html @@ -52,20 +52,7 @@ <h2 style="text-align:center; font-size: 150%">The Coq Development Team</h2> <br /><br /><br /> -<div style="text-align: left; font-size: 80%; text-indent: 0pt"> -<ul style="list-style: none; margin-left: 0pt"> - <li>V7.x © INRIA 1999-2004</li> - <li>V8.0 © INRIA 2004-2008</li> - <li>V8.1 © INRIA 2006-2011</li> - <li>V8.2 © INRIA 2008-2011</li> - <li>V8.3 © INRIA 2010-2011</li> - <li>V8.4 © INRIA 2012-2014</li> - <li>V8.5 © INRIA 2015-2016</li> - <li>V8.6 © INRIA 2016</li> -</ul> - -<p style="text-indent:0pt">This research was partly supported by IST - working group ``Types''</p> +<p style="text-indent:0pt">Copyright © INRIA 1999-2017</p> <p style="text-indent:0pt">This material may be distributed only subject to the terms and conditions set forth in the Open Publication License, v1.0 or later (the latest version is presently available at <a href="http://www.opencontent.org/openpub">http://www.opencontent.org/openpub</a>). Options A and B are not elected.</p> diff --git a/doc/common/styles/html/simple/cover.html b/doc/common/styles/html/simple/cover.html index 25fb56320..605313104 100644 --- a/doc/common/styles/html/simple/cover.html +++ b/doc/common/styles/html/simple/cover.html @@ -30,20 +30,7 @@ <br /><br /><br /> -<div style="text-align: left; font-size: 80%; text-indent: 0pt"> -<ul style="list-style: none; margin-left: 0pt"> - <li>V7.x © INRIA 1999-2004</li> - <li>V8.0 © INRIA 2004-2008</li> - <li>V8.1 © INRIA 2006-2011</li> - <li>V8.2 © INRIA 2008-2011</li> - <li>V8.3 © INRIA 2010-2011</li> - <li>V8.4 © INRIA 2012-2014</li> - <li>V8.5 © INRIA 2015-2016</li> - <li>V8.6 © INRIA 2016</li> -</ul> - -<p style="text-indent:0pt">This research was partly supported by IST - working group ``Types''</p> +<p style="text-indent:0pt">Copyright © INRIA 1999-2017</p> <p style="text-indent: 0pt">This material may be distributed only subject to the terms and conditions set forth in the Open Publication License, v1.0 or later (the latest version is presently available at <a href="http://www.opencontent.org/openpub">http://www.opencontent.org/openpub</a>). Options A and B are not elected.</p> diff --git a/doc/refman/AddRefMan-pre.tex b/doc/refman/AddRefMan-pre.tex index eee41a679..856a823de 100644 --- a/doc/refman/AddRefMan-pre.tex +++ b/doc/refman/AddRefMan-pre.tex @@ -4,6 +4,7 @@ \setheaders{Presentation of the Addendum} %END LATEX \chapter*{Presentation of the Addendum} +%HEVEA\cutname{addendum.html} Here you will find several pieces of additional documentation for the \Coq\ Reference Manual. Each of this chapters is concentrated on a diff --git a/doc/refman/AsyncProofs.tex b/doc/refman/AsyncProofs.tex index 1609e4a04..30039d489 100644 --- a/doc/refman/AsyncProofs.tex +++ b/doc/refman/AsyncProofs.tex @@ -1,4 +1,5 @@ \achapter{Asynchronous and Parallel Proof Processing} +%HEVEA\cutname{async-proofs.html} \aauthor{Enrico Tassi} \label{pralitp} diff --git a/doc/refman/CanonicalStructures.tex b/doc/refman/CanonicalStructures.tex index 275e1c2d5..8961b0096 100644 --- a/doc/refman/CanonicalStructures.tex +++ b/doc/refman/CanonicalStructures.tex @@ -1,4 +1,5 @@ \achapter{Canonical Structures} +%HEVEA\cutname{canonical-structures.html} \aauthor{Assia Mahboubi and Enrico Tassi} \label{CS-full} diff --git a/doc/refman/Cases.tex b/doc/refman/Cases.tex index a95d8114f..7ad895f9d 100644 --- a/doc/refman/Cases.tex +++ b/doc/refman/Cases.tex @@ -1,4 +1,5 @@ \achapter{Extended pattern-matching} +%HEVEA\cutname{cases.html} %BEGIN LATEX \defaultheaders %END LATEX diff --git a/doc/refman/Classes.tex b/doc/refman/Classes.tex index 7e07868a3..22c75b4fc 100644 --- a/doc/refman/Classes.tex +++ b/doc/refman/Classes.tex @@ -6,6 +6,7 @@ \newcommand\tele[1]{\overrightarrow{#1}} \achapter{\protect{Type Classes}} +%HEVEA\cutname{type-classes.html} \aauthor{Matthieu Sozeau} \label{typeclasses} diff --git a/doc/refman/Coercion.tex b/doc/refman/Coercion.tex index 16006a6ad..ec46e1eb5 100644 --- a/doc/refman/Coercion.tex +++ b/doc/refman/Coercion.tex @@ -1,4 +1,5 @@ \achapter{Implicit Coercions} +%HEVEA\cutname{coercions.html} \aauthor{Amokrane Saïbi} \label{Coercions-full} diff --git a/doc/refman/Extraction.tex b/doc/refman/Extraction.tex index 499239b6f..83e866e9f 100644 --- a/doc/refman/Extraction.tex +++ b/doc/refman/Extraction.tex @@ -1,4 +1,5 @@ \achapter{Extraction of programs in Objective Caml and Haskell} +%HEVEA\cutname{extraction.html} \label{Extraction} \aauthor{Jean-Christophe Filliâtre and Pierre Letouzey} \index{Extraction} diff --git a/doc/refman/Micromega.tex b/doc/refman/Micromega.tex index 4daf98f87..2617142f5 100644 --- a/doc/refman/Micromega.tex +++ b/doc/refman/Micromega.tex @@ -1,4 +1,5 @@ \achapter{Micromega: tactics for solving arithmetic goals over ordered rings} +%HEVEA\cutname{micromega.html} \aauthor{Frédéric Besson and Evgeny Makarov} \newtheorem{theorem}{Theorem} diff --git a/doc/refman/Misc.tex b/doc/refman/Misc.tex index e953d2f70..ab00fbfe3 100644 --- a/doc/refman/Misc.tex +++ b/doc/refman/Misc.tex @@ -1,4 +1,5 @@ \achapter{\protect{Miscellaneous extensions}} +%HEVEA\cutname{miscellaneous.html} \asection{Program derivation} diff --git a/doc/refman/Nsatz.tex b/doc/refman/Nsatz.tex index 70e36a5ee..1401af10f 100644 --- a/doc/refman/Nsatz.tex +++ b/doc/refman/Nsatz.tex @@ -1,4 +1,5 @@ \achapter{Nsatz: tactics for proving equalities in integral domains} +%HEVEA\cutname{nsatz.html} \aauthor{Loïc Pottier} The tactic \texttt{nsatz} proves goals of the form diff --git a/doc/refman/Omega.tex b/doc/refman/Omega.tex index 1610305e7..8025fbe29 100644 --- a/doc/refman/Omega.tex +++ b/doc/refman/Omega.tex @@ -1,5 +1,6 @@ \achapter{Omega: a solver of quantifier-free problems in Presburger Arithmetic} +%HEVEA\cutname{omega.html} \aauthor{Pierre Crégut} \label{OmegaChapter} diff --git a/doc/refman/Polynom.tex b/doc/refman/Polynom.tex index 77d592834..d9b8b8c52 100644 --- a/doc/refman/Polynom.tex +++ b/doc/refman/Polynom.tex @@ -1,4 +1,5 @@ \achapter{The \texttt{ring} and \texttt{field} tactic families} +%HEVEA\cutname{ring.html} \aauthor{Bruno Barras, Benjamin Gr\'egoire, Assia Mahboubi, Laurent Th\'ery\footnote{based on previous work from Patrick Loiseleur and Samuel Boutin}} diff --git a/doc/refman/Program.tex b/doc/refman/Program.tex index f60908da6..1e204dc83 100644 --- a/doc/refman/Program.tex +++ b/doc/refman/Program.tex @@ -1,4 +1,5 @@ \achapter{\Program{}} +%HEVEA\cutname{program.html} \label{Program} \aauthor{Matthieu Sozeau} \index{Program} diff --git a/doc/refman/RefMan-add.tex b/doc/refman/RefMan-add.tex deleted file mode 100644 index 2094c9d2d..000000000 --- a/doc/refman/RefMan-add.tex +++ /dev/null @@ -1,58 +0,0 @@ -\chapter[List of additional documentation]{List of additional documentation\label{Addoc}} - -\section[Tutorials]{Tutorials\label{Tutorial}} -A companion volume to this reference manual, the \Coq\ Tutorial, is -aimed at gently introducing new users to developing proofs in \Coq\ -without assuming prior knowledge of type theory. In a second step, the -user can read also the tutorial on recursive types (document {\tt -RecTutorial.ps}). - -\section[The \Coq\ standard library]{The \Coq\ standard library\label{Addoc-library}} -A brief description of the \Coq\ standard library is given in the additional -document {\tt Library.dvi}. - -\section[Installation and un-installation procedures]{Installation and un-installation procedures\label{Addoc-install}} -A \verb!INSTALL! file in the distribution explains how to install -\Coq. - -\section[{\tt Extraction} of programs]{{\tt Extraction} of programs\label{Addoc-extract}} -{\tt Extraction} is a package offering some special facilities to -extract ML program files. It is described in the separate document -{\tt Extraction.dvi} -\index{Extraction of programs} - -\section[{\tt Program}]{A tool for {\tt Program}-ing\label{Addoc-program}} -{\tt Program} is a package offering some special facilities to -extract ML program files. It is described in the separate document -{\tt Program.dvi} -\index{Program-ing} - -\section[Proof printing in {\tt Natural} language]{Proof printing in {\tt Natural} language\label{Addoc-natural}} -{\tt Natural} is a tool to print proofs in natural language. -It is described in the separate document {\tt Natural.dvi}. -\index{Natural@{\tt Print Natural}} -\index{Printing in natural language} - -\section[The {\tt Omega} decision tactic]{The {\tt Omega} decision tactic\label{Addoc-omega}} -{\bf Omega} is a tactic to automatically solve arithmetical goals in -Presburger arithmetic (i.e. arithmetic without multiplication). -It is described in the separate document {\tt Omega.dvi}. -\index{Omega@{\tt Omega}} - -\section[Simplification on rings]{Simplification on rings\label{Addoc-polynom}} -A documentation of the package {\tt polynom} (simplification on rings) -can be found in the document {\tt Polynom.dvi} -\index{Polynom@{\tt Polynom}} -\index{Simplification on rings} - -%\section[Anomalies]{Anomalies\label{Addoc-anomalies}} -%The separate document {\tt Anomalies.*} gives a list of known -%anomalies and bugs of the system. Before communicating us an -%anomalous behavior, please check first whether it has been already -%reported in this document. - - -%%% Local Variables: -%%% mode: latex -%%% TeX-master: "Reference-Manual" -%%% End: diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index ad795d406..0dbfe05d4 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -2,6 +2,7 @@ \label{Cic} \index{Cic@\textsc{CIC}} \index{Calculus of Inductive Constructions}} +%HEVEA\cutname{cic.html} The underlying formal language of {\Coq} is a {\em Calculus of Inductive Constructions} (\CIC) whose inference rules are presented in diff --git a/doc/refman/RefMan-coi.tex b/doc/refman/RefMan-coi.tex deleted file mode 100644 index dac3c60bd..000000000 --- a/doc/refman/RefMan-coi.tex +++ /dev/null @@ -1,405 +0,0 @@ -%\documentstyle[11pt,../tools/coq-tex/coq]{article} -%\input{title} - -%\include{macros} -%\begin{document} - -%\coverpage{Co-inductive types in Coq}{Eduardo Gim\'enez} -\chapter[Co-inductive types in Coq]{Co-inductive types in Coq\label{Co-inductives}} - -%\begin{abstract} -{\it Co-inductive} types are types whose elements may not be well-founded. -A formal study of the Calculus of Constructions extended by -co-inductive types has been presented -in \cite{Gim94}. It is based on the notion of -{\it guarded definitions} introduced by Th. Coquand -in \cite{Coquand93}. The implementation is by E. Gim\'enez. -%\end{abstract} - -\section{A short introduction to co-inductive types} - -We assume that the reader is rather familiar with inductive types. -These types are characterized by their {\it constructors}, which can be -regarded as the basic methods from which the elements -of the type can be built up. It is implicit in the definition -of an inductive type that -its elements are the result of a {\it finite} number of -applications of its constructors. Co-inductive types arise from -relaxing this implicit condition and admitting that an element of -the type can also be introduced by a non-ending (but effective) process -of construction defined in terms of the basic methods which characterize the -type. So we could think in the wider notion of types defined by -constructors (let us call them {\it recursive types}) and classify -them into inductive and co-inductive ones, depending on whether or not -we consider non-ending methods as admissible for constructing elements -of the type. Note that in both cases we obtain a ``closed type'', all whose -elements are pre-determined in advance (by the constructors). When we -know that $a$ is an element of a recursive type (no matter if it is -inductive or co-inductive) what we know is that it is the result of applying -one of the basic forms of construction allowed for the type. -So the more primitive way of eliminating an element of a recursive type is -by case analysis, i.e. by considering through which constructor it could have -been introduced. In the case of inductive sets, the additional knowledge that -constructors can be applied only a finite number of times provide -us with a more powerful way of eliminating their elements, say, -the principle of -induction. This principle is obviously not valid for co-inductive types, -since it is just the expression of this extra knowledge attached to inductive -types. - - -An example of a co-inductive type is the type of infinite sequences formed with -elements of type $A$, or streams for shorter. In Coq, -it can be introduced using the \verb!CoInductive! command~: -\begin{coq_example} -CoInductive Stream (A:Set) : Set := - cons : A -> Stream A -> Stream A. -\end{coq_example} - -The syntax of this command is the same as the -command \verb!Inductive! (cf. section -\ref{gal_Inductive_Definitions}). -Definition of mutually co-inductive types are possible. - -As was already said, there are not principles of -induction for co-inductive sets, the only way of eliminating these -elements is by case analysis. -In the example of streams, this elimination principle can be -used for instance to define the well known -destructors on streams $\hd : (\Str\;A)\rightarrow A$ -and $\tl: (\Str\;A)\rightarrow (\Str\;A)$ : -\begin{coq_example} -Section Destructors. -Variable A : Set. -Definition hd (x:Stream A) := match x with - | cons a s => a - end. -Definition tl (x:Stream A) := match x with - | cons a s => s - end. -\end{coq_example} -\begin{coq_example*} -End Destructors. -\end{coq_example*} - -\subsection{Non-ending methods of construction} - -At this point the reader should have realized that we have left unexplained -what is a ``non-ending but effective process of -construction'' of a stream. In the widest sense, a -method is a non-ending process of construction if we can eliminate the -stream that it introduces, in other words, if we can reduce -any case analysis on it. In this sense, the following ways of -introducing a stream are not acceptable. -\begin{center} -$\zeros = (\cons\;\nat\;\nO\;(\tl\;\zeros))\;\;:\;\;(\Str\;\nat)$\\[12pt] -$\filter\;(\cons\;A\;a\;s) = \si\;\;(P\;a)\;\;\alors\;\;(\cons\;A\;a\;(\filter\;s))\;\;\sinon\;\;(\filter\;s) )\;\;:\;\;(\Str\;A)$ -\end{center} -\noindent The former it is not valid since the stream can not be eliminated -to obtain its tail. In the latter, a stream is naively defined as -the result of erasing from another (arbitrary) stream -all the elements which does not verify a certain property $P$. This -does not always makes sense, for example it does not when all the elements -of the stream verify $P$, in which case we can not eliminate it to -obtain its head\footnote{Note that there is no notion of ``the empty -stream'', a stream is always infinite and build by a \texttt{cons}.}. -On the contrary, the following definitions are acceptable methods for -constructing a stream~: -\begin{center} -$\zeros = (\cons\;\nat\;\nO\;\zeros)\;\;:\;\;(\Str\;\nat)\;\;\;(*)$\\[12pt] -$(\from\;n) = (\cons\;\nat\;n\;(\from\;(\nS\;n)))\;:\;(\Str\;\nat)$\\[12pt] -$\alter = (\cons\;\bool\;\true\;(\cons\;\bool\;\false\;\alter))\;:\;(\Str\;\bool)$. -\end{center} -\noindent The first one introduces a stream containing all the natural numbers -greater than a given one, and the second the stream which infinitely -alternates the booleans true and false. - -In general it is not evident to realise when a definition can -be accepted or not. However, there is a class of definitions that -can be easily recognised as being valid : those -where (1) all the recursive calls of the method are done -after having explicitly mentioned which is (at least) the first constructor -to start building the element, and (2) no other -functions apart from constructors are applied to recursive calls. -This class of definitions is usually -referred as {\it guarded-by-constructors} -definitions \cite{Coquand93,Gim94}. -The methods $\from$ -and $\alter$ are examples of definitions which are guarded by constructors. -The definition of function $\filter$ is not, because there is no -constructor to guard -the recursive call in the {\it else} branch. Neither is the one of -$\zeros$, since there is function applied to the recursive call -which is not a constructor. However, there is a difference between -the definition of $\zeros$ and $\filter$. The former may be seen as a -wrong way of characterising an object which makes sense, and it can -be reformulated in an admissible way using the equation (*). On the contrary, -the definition of -$\filter$ can not be patched, since is the idea itself -of traversing an infinite -construction searching for an element whose existence is not ensured -which does not make sense. - - - -Guarded definitions are exactly the kind of non-ending process of -construction which are allowed in Coq. The way of introducing -a guarded definition in Coq is using the special command -{\tt CoFixpoint}. This command verifies that the definition introduces an -element of a co-inductive type, and checks if it is guarded by constructors. -If we try to -introduce the definitions above, $\from$ and $\alter$ will be accepted, -while $\zeros$ and $\filter$ will be rejected giving some explanation -about why. -\begin{coq_example} -CoFixpoint zeros : Stream nat := cons nat 0%N (tl nat zeros). -CoFixpoint zeros : Stream nat := cons nat 0%N zeros. -CoFixpoint from (n:nat) : Stream nat := cons nat n (from (S n)). -\end{coq_example} - -As in the \verb!Fixpoint! command (see Section~\ref{Fixpoint}), it is possible -to introduce a block of mutually dependent methods. The general syntax -for this case is : - -{\tt CoFixpoint {\ident$_1$} :{\term$_1$} := {\term$_1'$}\\ - with\\ - \mbox{}\hspace{0.1cm} $\ldots$ \\ - with {\ident$_m$} : {\term$_m$} := {\term$_m'$}} - - -\subsection{Non-ending methods and reduction} - -The elimination of a stream introduced by a \verb!CoFixpoint! definition -is done lazily, i.e. its definition can be expanded only when it occurs -at the head of an application which is the argument of a case expression. -Isolately it is considered as a canonical expression which -is completely evaluated. We can test this using the command \verb!compute! -to calculate the normal forms of some terms~: -\begin{coq_example} -Eval compute in (from 0). -Eval compute in (hd nat (from 0)). -Eval compute in (tl nat (from 0)). -\end{coq_example} -\noindent Thus, the equality -$(\from\;n)\equiv(\cons\;\nat\;n\;(\from \; (\S\;n)))$ -does not hold as definitional one. Nevertheless, it can be proved -as a propositional equality, in the sense of Leibniz's equality. -The version {\it à la Leibniz} of the equality above follows from -a general lemma stating that eliminating and then re-introducing a stream -yields the same stream. -\begin{coq_example} -Lemma unfold_Stream : - forall x:Stream nat, x = match x with - | cons a s => cons nat a s - end. -\end{coq_example} - -\noindent The proof is immediate from the analysis of -the possible cases for $x$, which transforms -the equality in a trivial one. - -\begin{coq_example} -olddestruct x. -trivial. -\end{coq_example} -\begin{coq_eval} -Qed. -\end{coq_eval} -The application of this lemma to $(\from\;n)$ puts this -constant at the head of an application which is an argument -of a case analysis, forcing its expansion. -We can test the type of this application using Coq's command \verb!Check!, -which infers the type of a given term. -\begin{coq_example} -Check (fun n:nat => unfold_Stream (from n)). -\end{coq_example} - \noindent Actually, The elimination of $(\from\;n)$ has actually -no effect, because it is followed by a re-introduction, -so the type of this application is in fact -definitionally equal to the -desired proposition. We can test this computing -the normal form of the application above to see its type. -\begin{coq_example} -Transparent unfold_Stream. -Eval compute in (fun n:nat => unfold_Stream (from n)). -\end{coq_example} - - -\section{Reasoning about infinite objects} - -At a first sight, it might seem that -case analysis does not provide a very powerful way -of reasoning about infinite objects. In fact, what we can prove about -an infinite object using -only case analysis is just what we can prove unfolding its method -of construction a finite number of times, which is not always -enough. Consider for example the following method for appending -two streams~: -\begin{coq_example} -Variable A : Set. -CoFixpoint conc (s1 s2:Stream A) : Stream A := - cons A (hd A s1) (conc (tl A s1) s2). -\end{coq_example} - -Informally speaking, we expect that for all pair of streams $s_1$ and $s_2$, -$(\conc\;s_1\;s_2)$ -defines the ``the same'' stream as $s_1$, -in the sense that if we would be able to unfold the definition -``up to the infinite'', we would obtain definitionally equal normal forms. -However, no finite unfolding of the definitions gives definitionally -equal terms. Their equality can not be proved just using case analysis. - - -The weakness of the elimination principle proposed for infinite objects -contrast with the power provided by the inductive -elimination principles, but it is not actually surprising. It just means -that we can not expect to prove very interesting things about infinite -objects doing finite proofs. To take advantage of infinite objects we -have to consider infinite proofs as well. For example, -if we want to catch up the equality between $(\conc\;s_1\;s_2)$ and -$s_1$ we have to introduce first the type of the infinite proofs -of equality between streams. This is a -co-inductive type, whose elements are build up from a -unique constructor, requiring a proof of the equality of the -heads of the streams, and an (infinite) proof of the equality -of their tails. - -\begin{coq_example} -CoInductive EqSt : Stream A -> Stream A -> Prop := - eqst : - forall s1 s2:Stream A, - hd A s1 = hd A s2 -> EqSt (tl A s1) (tl A s2) -> EqSt s1 s2. -\end{coq_example} -\noindent Now the equality of both streams can be proved introducing -an infinite object of type - -\noindent $(\EqSt\;s_1\;(\conc\;s_1\;s_2))$ by a \verb!CoFixpoint! -definition. -\begin{coq_example} -CoFixpoint eqproof (s1 s2:Stream A) : EqSt s1 (conc s1 s2) := - eqst s1 (conc s1 s2) (eq_refl (hd A (conc s1 s2))) - (eqproof (tl A s1) s2). -\end{coq_example} -\begin{coq_eval} -Reset eqproof. -\end{coq_eval} -\noindent Instead of giving an explicit definition, -we can use the proof editor of Coq to help us in -the construction of the proof. -A tactic \verb!Cofix! allows placing a \verb!CoFixpoint! definition -inside a proof. -This tactic introduces a variable in the context which has -the same type as the current goal, and its application stands -for a recursive call in the construction of the proof. If no name is -specified for this variable, the name of the lemma is chosen by -default. -%\pagebreak - -\begin{coq_example} -Lemma eqproof : forall s1 s2:Stream A, EqSt s1 (conc s1 s2). -cofix. -\end{coq_example} - -\noindent An easy (and wrong!) way of finishing the proof is just to apply the -variable \verb!eqproof!, which has the same type as the goal. - -\begin{coq_example} -intros. -apply eqproof. -\end{coq_example} - -\noindent The ``proof'' constructed in this way -would correspond to the \verb!CoFixpoint! definition -\begin{coq_example*} -CoFixpoint eqproof : forall s1 s2:Stream A, EqSt s1 (conc s1 s2) := - eqproof. -\end{coq_example*} - -\noindent which is obviously non-guarded. This means that -we can use the proof editor to -define a method of construction which does not make sense. However, -the system will never accept to include it as part of the theory, -because the guard condition is always verified before saving the proof. - -\begin{coq_example} -Qed. -\end{coq_example} - -\noindent Thus, the user must be careful in the -construction of infinite proofs -with the tactic \verb!Cofix!. Remark that once it has been used -the application of tactics performing automatic proof search in -the environment (like for example \verb!Auto!) -could introduce unguarded recursive calls in the proof. -The command \verb!Guarded! verifies -that the guarded condition has been not violated -during the construction of the proof. This command can be -applied even if the proof term is not complete. - - - -\begin{coq_example} -Restart. -cofix. -auto. -Guarded. -Undo. -Guarded. -\end{coq_example} - -\noindent To finish with this example, let us restart from the -beginning and show how to construct an admissible proof~: - -\begin{coq_example} -Restart. - cofix. -\end{coq_example} - -%\pagebreak - -\begin{coq_example} -intros. -apply eqst. -trivial. -simpl. -apply eqproof. -Qed. -\end{coq_example} - - -\section{Experiments with co-inductive types} - -Some examples involving co-inductive types are available with -the distributed system, in the theories library and in the contributions -of the Lyon site. Here we present a short description of their contents~: -\begin{itemize} -\item Directory \verb!theories/LISTS! : - \begin{itemize} - \item File \verb!Streams.v! : The type of streams and the -extensional equality between streams. - \end{itemize} - -\item Directory \verb!contrib/Lyon/COINDUCTIVES! : - \begin{itemize} - \item Directory \verb!ARITH! : An arithmetic where $\infty$ -is an explicit constant of the language instead of a metatheoretical notion. - \item Directory \verb!STREAM! : - \begin{itemize} - \item File \verb!Examples! : -Several examples of guarded definitions, as well as -of frequent errors in the introduction of a stream. A different -way of defining the extensional equality of two streams, -and the proofs showing that it is equivalent to the one in \verb!theories!. - \item File \verb!Alter.v! : An example showing how -an infinite proof introduced by a guarded definition can be also described -using an operator of co-recursion \cite{Gimenez95b}. - \end{itemize} -\item Directory \verb!PROCESSES! : A proof of the alternating -bit protocol based on Pra\-sad's Calculus of Broadcasting Systems \cite{Prasad93}, -and the verification of an interpreter for this calculus. -See \cite{Gimenez95b} for a complete description about this development. - \end{itemize} -\end{itemize} - -%\end{document} - diff --git a/doc/refman/RefMan-com.tex b/doc/refman/RefMan-com.tex index 45230fb6e..892c9931b 100644 --- a/doc/refman/RefMan-com.tex +++ b/doc/refman/RefMan-com.tex @@ -2,6 +2,7 @@ \ttindex{coqtop} \ttindex{coqc} \ttindex{coqchk}} +%HEVEA\cutname{commands.html} There are three \Coq~commands: \begin{itemize} @@ -106,6 +107,15 @@ The following command-line options are recognized by the commands {\tt recursively available from {\Coq} using absolute names (extending the {\dirpath} prefix) (see Section~\ref{LongNames}). + Note that only those subdirectories and files which obey the lexical + conventions of what is an {\ident} (see Section~\ref{lexical}) + are taken into account. Conversely, the underlying file systems or + operating systems may be more restrictive than {\Coq}. While Linux's + ext4 file system supports any {\Coq} recursive layout + (within the limit of 255 bytes per file name), the default on NTFS + (Windows) or HFS+ (MacOS X) file systems is on the contrary to + disallow two files differing only in the case in the same directory. + \SeeAlso Section~\ref{Libraries}. \item[{\tt -R} {\em directory} {\dirpath}]\ % diff --git a/doc/refman/RefMan-ext.tex b/doc/refman/RefMan-ext.tex index 7af4e9313..b27a4dc94 100644 --- a/doc/refman/RefMan-ext.tex +++ b/doc/refman/RefMan-ext.tex @@ -1,4 +1,5 @@ \chapter[Extensions of \Gallina{}]{Extensions of \Gallina{}\label{Gallina-extension}\index{Gallina}} +%HEVEA\cutname{gallina-ext.html} {\gallina} is the kernel language of {\Coq}. We describe here extensions of the Gallina's syntax. diff --git a/doc/refman/RefMan-gal.tex b/doc/refman/RefMan-gal.tex index ef12fe416..df0cd2b82 100644 --- a/doc/refman/RefMan-gal.tex +++ b/doc/refman/RefMan-gal.tex @@ -1,5 +1,6 @@ \chapter{The \gallina{} specification language \label{Gallina}\index{Gallina}} +%HEVEA\cutname{gallina.html} \label{BNF-syntax} % Used referred to as a chapter label This chapter describes \gallina, the specification language of {\Coq}. diff --git a/doc/refman/RefMan-ide.tex b/doc/refman/RefMan-ide.tex index c6fbd1c53..75f3d18de 100644 --- a/doc/refman/RefMan-ide.tex +++ b/doc/refman/RefMan-ide.tex @@ -1,5 +1,6 @@ \chapter[\Coq{} Integrated Development Environment]{\Coq{} Integrated Development Environment\label{Addoc-coqide} \ttindex{coqide}} +%HEVEA\cutname{coqide.html} The \Coq{} Integrated Development Environment is a graphical tool, to be used as a user-friendly replacement to \texttt{coqtop}. Its main diff --git a/doc/refman/RefMan-int.tex b/doc/refman/RefMan-int.tex index 2b9e4e605..f802a3595 100644 --- a/doc/refman/RefMan-int.tex +++ b/doc/refman/RefMan-int.tex @@ -2,6 +2,7 @@ \setheaders{Introduction} %END LATEX \chapter*{Introduction} +%HEVEA\cutname{introduction.html} This document is the Reference Manual of version \coqversion{} of the \Coq\ proof assistant. A companion volume, the \Coq\ Tutorial, is provided diff --git a/doc/refman/RefMan-lib.tex b/doc/refman/RefMan-lib.tex index 4ebb484e7..c8e844302 100644 --- a/doc/refman/RefMan-lib.tex +++ b/doc/refman/RefMan-lib.tex @@ -1,4 +1,5 @@ \chapter[The {\Coq} library]{The {\Coq} library\index{Theories}\label{Theories}} +%HEVEA\cutname{stdlib.html} The \Coq\ library is structured into two parts: diff --git a/doc/refman/RefMan-ltac.tex b/doc/refman/RefMan-ltac.tex index 3ce1d4ecd..574591185 100644 --- a/doc/refman/RefMan-ltac.tex +++ b/doc/refman/RefMan-ltac.tex @@ -1,4 +1,5 @@ \chapter[The tactic language]{The tactic language\label{TacticLanguage}} +%HEVEA\cutname{ltac.html} %\geometry{a4paper,body={5in,8in}} @@ -1105,19 +1106,14 @@ Fail all:let n:= numgoals in guard n=2. Reset Initial. \end{coq_eval} -\subsubsection[Proving a subgoal as a separate lemma]{Proving a subgoal as a separate lemma\tacindex{abstract}\tacindex{transparent\_abstract}\comindex{Qed exporting} +\subsubsection[Proving a subgoal as a separate lemma]{Proving a subgoal as a separate lemma\tacindex{abstract}\tacindex{transparent\_abstract} \index{Tacticals!abstract@{\tt abstract}}\index{Tacticals!transparent\_abstract@{\tt transparent\_abstract}}} From the outside ``\texttt{abstract \tacexpr}'' is the same as {\tt solve \tacexpr}. Internally it saves an auxiliary lemma called {\ident}\texttt{\_subproof}\textit{n} where {\ident} is the name of the current goal and \textit{n} is chosen so that this is a fresh name. -Such auxiliary lemma is inlined in the final proof term -unless the proof is ended with ``\texttt{Qed exporting}''. In such -case the lemma is preserved. The syntax -``\texttt{Qed exporting }\ident$_1$\texttt{, ..., }\ident$_n$'' -is also supported. In such case the system checks that the names given by the -user actually exist when the proof is ended. +Such an auxiliary lemma is inlined in the final proof term. This tactical is useful with tactics such as \texttt{omega} or \texttt{discriminate} that generate huge proof terms. With that tool diff --git a/doc/refman/RefMan-modr.tex b/doc/refman/RefMan-modr.tex index 2019a529f..7c672cf42 100644 --- a/doc/refman/RefMan-modr.tex +++ b/doc/refman/RefMan-modr.tex @@ -1,4 +1,5 @@ \chapter[The Module System]{The Module System\label{chapter:Modules}} +%HEVEA\cutname{modules.html} The module system extends the Calculus of Inductive Constructions providing a convenient way to structure large developments as well as diff --git a/doc/refman/RefMan-oth.tex b/doc/refman/RefMan-oth.tex index 8f43ebcfb..60cd8b73a 100644 --- a/doc/refman/RefMan-oth.tex +++ b/doc/refman/RefMan-oth.tex @@ -1,5 +1,6 @@ \chapter[Vernacular commands]{Vernacular commands\label{Vernacular-commands} \label{Other-commands}} +%HEVEA\cutname{vernacular.html} \section{Displaying} diff --git a/doc/refman/RefMan-pre.tex b/doc/refman/RefMan-pre.tex index 0c2a18eb2..991c9745e 100644 --- a/doc/refman/RefMan-pre.tex +++ b/doc/refman/RefMan-pre.tex @@ -2,6 +2,7 @@ \setheaders{Credits} %END LATEX \chapter*{Credits} +%HEVEA\cutname{credits.html} %\addcontentsline{toc}{section}{Credits} \Coq{}~ is a proof assistant for higher-order logic, allowing the diff --git a/doc/refman/RefMan-pro.tex b/doc/refman/RefMan-pro.tex index eb59ca584..8f659ded3 100644 --- a/doc/refman/RefMan-pro.tex +++ b/doc/refman/RefMan-pro.tex @@ -1,5 +1,6 @@ \chapter[Proof handling]{Proof handling\index{Proof editing} \label{Proof-handling}} +%HEVEA\cutname{proof-handling.html} In \Coq's proof editing mode all top-level commands documented in Chapter~\ref{Vernacular-commands} remain available diff --git a/doc/refman/RefMan-sch.tex b/doc/refman/RefMan-sch.tex index 23a1c9b02..956f30851 100644 --- a/doc/refman/RefMan-sch.tex +++ b/doc/refman/RefMan-sch.tex @@ -1,4 +1,5 @@ \chapter{Proof schemes} +%HEVEA\cutname{schemes.html} \section{Generation of induction principles with {\tt Scheme}} \label{Scheme} diff --git a/doc/refman/RefMan-ssr.tex b/doc/refman/RefMan-ssr.tex index db794e5a6..be199e0b2 100644 --- a/doc/refman/RefMan-ssr.tex +++ b/doc/refman/RefMan-ssr.tex @@ -1,4 +1,5 @@ \achapter{The SSReflect proof language} +%HEVEA\cutname{ssreflect.html} \aauthor{Georges Gonthier, Assia Mahboubi, Enrico Tassi} \newcommand{\ssr}{{\sc SSReflect}} diff --git a/doc/refman/RefMan-syn.tex b/doc/refman/RefMan-syn.tex index d8a353300..eecb5ac7c 100644 --- a/doc/refman/RefMan-syn.tex +++ b/doc/refman/RefMan-syn.tex @@ -1,4 +1,5 @@ \chapter[Syntax extensions and interpretation scopes]{Syntax extensions and interpretation scopes\label{Addoc-syntax}} +%HEVEA\cutname{syntax-extensions.html} In this chapter, we introduce advanced commands to modify the way {\Coq} parses and prints objects, i.e. the translations between the diff --git a/doc/refman/RefMan-tac.tex b/doc/refman/RefMan-tac.tex index 8fbcfdf30..a2d45046b 100644 --- a/doc/refman/RefMan-tac.tex +++ b/doc/refman/RefMan-tac.tex @@ -3,6 +3,7 @@ \chapter{Tactics \index{Tactics} \label{Tactics}} +%HEVEA\cutname{tactics.html} A deduction rule is a link between some (unique) formula, that we call the {\em conclusion} and (several) formulas that we call the {\em diff --git a/doc/refman/RefMan-tacex.tex b/doc/refman/RefMan-tacex.tex index cb8f916f1..7cdb1a527 100644 --- a/doc/refman/RefMan-tacex.tex +++ b/doc/refman/RefMan-tacex.tex @@ -1,4 +1,5 @@ \chapter[Detailed examples of tactics]{Detailed examples of tactics\label{Tactics-examples}} +%HEVEA\cutname{tactic-examples.html} This chapter presents detailed examples of certain tactics, to illustrate their behavior. diff --git a/doc/refman/RefMan-tus.tex b/doc/refman/RefMan-tus.tex deleted file mode 100644 index 7e5bb81a9..000000000 --- a/doc/refman/RefMan-tus.tex +++ /dev/null @@ -1,2001 +0,0 @@ -%\documentclass[11pt]{article} -%\usepackage{fullpage,euler} -%\usepackage[latin1]{inputenc} -%\begin{document} -%\title{Writing ad-hoc Tactics in Coq} -%\author{} -%\date{} -%\maketitle -%\tableofcontents -%\clearpage - -\chapter[Writing ad-hoc Tactics in Coq]{Writing ad-hoc Tactics in Coq\label{WritingTactics}} - -\section{Introduction} - -\Coq\ is an open proof environment, in the sense that the collection of -proof strategies offered by the system can be extended by the user. -This feature has two important advantages. First, the user can develop -his/her own ad-hoc proof procedures, customizing the system for a -particular domain of application. Second, the repetitive and tedious -aspects of the proofs can be abstracted away implementing new tactics -for dealing with them. For example, this may be useful when a theorem -needs several lemmas which are all proven in a similar but not exactly -the same way. Let us illustrate this with an example. - -Consider the problem of deciding the equality of two booleans. The -theorem establishing that this is always possible is state by -the following theorem: - -\begin{coq_example*} -Theorem decideBool : (x,y:bool){x=y}+{~x=y}. -\end{coq_example*} - -The proof proceeds by case analysis on both $x$ and $y$. This yields -four cases to solve. The cases $x=y=\textsl{true}$ and -$x=y=\textsl{false}$ are immediate by the reflexivity of equality. - -The other two cases follow by discrimination. The following script -describes the proof: - -\begin{coq_example*} -Destruct x. - Destruct y. - Left ; Reflexivity. - Right; Discriminate. - Destruct y. - Right; Discriminate. - Left ; Reflexivity. -\end{coq_example*} -\begin{coq_eval} -Abort. -\end{coq_eval} - -Now, consider the theorem stating the same property but for the -following enumerated type: - -\begin{coq_example*} -Inductive Set Color := Blue:Color | White:Color | Red:Color. -Theorem decideColor : (c1,c2:Color){c1=c2}+{~c1=c2}. -\end{coq_example*} - -This theorem can be proven in a very similar way, reasoning by case -analysis on $c_1$ and $c_2$. Once more, each of the (now six) cases is -solved either by reflexivity or by discrimination: - -\begin{coq_example*} -Destruct c1. - Destruct c2. - Left ; Reflexivity. - Right ; Discriminate. - Right ; Discriminate. - Destruct c2. - Right ; Discriminate. - Left ; Reflexivity. - Right ; Discriminate. - Destruct c2. - Right ; Discriminate. - Right ; Discriminate. - Left ; Reflexivity. -\end{coq_example*} -\begin{coq_eval} -Abort. -\end{coq_eval} - -If we face the same theorem for an enumerated datatype corresponding -to the days of the week, it would still follow a similar pattern. In -general, the general pattern for proving the property -$(x,y:R)\{x=y\}+\{\neg x =y\}$ for an enumerated type $R$ proceeds as -follow: -\begin{enumerate} -\item Analyze the cases for $x$. -\item For each of the sub-goals generated by the first step, analyze -the cases for $y$. -\item The remaining subgoals follow either by reflexivity or -by discrimination. -\end{enumerate} - -Let us describe how this general proof procedure can be introduced in -\Coq. - -\section{Tactic Macros} - -The simplest way to introduce it is to define it as new a -\textsl{tactic macro}, as follows: - -\begin{coq_example*} -Tactic Definition DecideEq [$a $b] := - [<:tactic:<Destruct $a; - Destruct $b; - (Left;Reflexivity) Orelse (Right;Discriminate)>>]. -\end{coq_example*} - -The general pattern of the proof is abstracted away using the -tacticals ``\texttt{;}'' and \texttt{Orelse}, and introducing two -parameters for the names of the arguments to be analyzed. - -Once defined, this tactic can be called like any other tactic, just -supplying the list of terms corresponding to its real arguments. Let us -revisit the proof of the former theorems using the new tactic -\texttt{DecideEq}: - -\begin{coq_example*} -Theorem decideBool : (x,y:bool){x=y}+{~x=y}. -DecideEq x y. -Defined. -\end{coq_example*} -\begin{coq_example*} -Theorem decideColor : (c1,c2:Color){c1=c2}+{~c1=c2}. -DecideEq c1 c2. -Defined. -\end{coq_example*} - -In general, the command \texttt{Tactic Definition} associates a name -to a parameterized tactic expression, built up from the tactics and -tacticals that are already available. The general syntax rule for this -command is the following: - -\begin{tabbing} -\texttt{Tactic Definition} \textit{tactic-name} \= -\texttt{[}\$$id_1\ldots \$id_n$\texttt{]}\\ -\> := \texttt{[<:tactic:<} \textit{tactic-expression} \verb+>>]+ -\end{tabbing} - -This command provides a quick but also very primitive mechanism for -introducing new tactics. It does not support recursive definitions, -and the arguments of a tactic macro are restricted to term -expressions. Moreover, there is no static checking of the definition -other than the syntactical one. Any error in the definition of the -tactic ---for instance, a call to an undefined tactic--- will not be -noticed until the tactic is called. - -%This command provides a very primitive mechanism for introducing new -%tactics. The arguments of a tactic macro are restricted to term -%expressions. Hence, it is not possible to define higher order tactics -%with this command. Also, there is no static checking of the definition -%other than syntactical. If the tactic contain errors in its definition -%--for instance, a call to an undefined tactic-- this will be noticed -%during the tactic call. - -Let us illustrate the weakness of this way of introducing new tactics -trying to extend our proof procedure to work on a larger class of -inductive types. Consider for example the decidability of equality -for pairs of booleans and colors: - -\begin{coq_example*} -Theorem decideBoolXColor : (p1,p2:bool*Color){p1=p2}+{~p1=p2}. -\end{coq_example*} - -The proof still proceeds by a double case analysis, but now the -constructors of the type take two arguments. Therefore, the sub-goals -that can not be solved by discrimination need further considerations -about the equality of such arguments: - -\begin{coq_example} - Destruct p1; - Destruct p2; Try (Right;Discriminate);Intros. -\end{coq_example} - -The half of the disjunction to be chosen depends on whether or not -$b=b_0$ and $c=c_0$. These equalities can be decided automatically -using the previous lemmas about booleans and colors. If both -equalities are satisfied, then it is sufficient to rewrite $b$ into -$b_0$ and $c$ into $c_0$, so that the left half of the goal follows by -reflexivity. Otherwise, the right half follows by first contraposing -the disequality, and then applying the invectiveness of the pairing -constructor. - -As the cases associated to each argument of the pair are very similar, -a tactic macro can be introduced to abstract this part of the proof: - -\begin{coq_example*} -Hints Resolve decideBool decideColor. -Tactic Definition SolveArg [$t1 $t2] := - [<:tactic:< - ElimType {$t1=$t2}+{~$t1=$t2}; - [(Intro equality;Rewrite equality;Clear equality) | - (Intro diseq; Right; Red; Intro absurd; - Apply diseq;Injection absurd;Trivial) | - Auto]>>]. -\end{coq_example*} - -This tactic is applied to each corresponding pair of arguments of the -arguments, until the goal can be solved by reflexivity: - -\begin{coq_example*} -SolveArg b b0; - SolveArg c c0; - Left; Reflexivity. -Defined. -\end{coq_example*} - -Therefore, a more general strategy for deciding the property -$(x,y:R)\{x=y\}+\{\neg x =y\}$ on $R$ can be sketched as follows: -\begin{enumerate} -\item Eliminate $x$ and then $y$. -\item Try discrimination to solve those goals where $x$ and $y$ has -been introduced by different constructors. -\item If $x$ and $y$ have been introduced by the same constructor, -then iterate the tactic \textsl{SolveArg} for each pair of -arguments. -\item Finally, solve the left half of the goal by reflexivity. -\end{enumerate} - -The implementation of this stronger proof strategy needs to perform a -term decomposition, in order to extract the list of arguments of each -constructor. It also requires the introduction of recursively defined -tactics, so that the \textsl{SolveArg} can be iterated on the lists of -arguments. These features are not supported by the \texttt{Tactic -Definition} command. One possibility could be extended this command in -order to introduce recursion, general parameter passing, -pattern-matching, etc, but this would quickly lead us to introduce the -whole \ocaml{} into \Coq\footnote{This is historically true. In fact, -\ocaml{} is a direct descendent of ML, a functional programming language -conceived language for programming the tactics of the theorem prover -LCF.}. Instead of doing this, we prefer to give to the user the -possibility of writing his/her own tactics directly in \ocaml{}, and then -to link them dynamically with \Coq's code. This requires a minimal -knowledge about \Coq's implementation. The next section provides an -overview of \Coq's architecture. - -%It is important to point out that the introduction of a new tactic -%never endangers the correction of the theorems proven in the extended -%system. In order to understand why, let us introduce briefly the system -%architecture. - -\section{An Overview of \Coq's Architecture} - -The implementation of \Coq\ is based on eight \textsl{logical -modules}. By ``module'' we mean here a logical piece of code having a -conceptual unity, that may concern several \ocaml{} files. By the sake of -organization, all the \ocaml{} files concerning a logical module are -grouped altogether into the same sub-directory. The eight modules -are: - -\begin{tabular}{lll} -1. & The logical framework & (directory \texttt{src/generic})\\ -2. & The language of constructions & (directory \texttt{src/constr})\\ -3. & The type-checker & (directory \texttt{src/typing})\\ -4. & The proof engine & (directory \texttt{src/proofs})\\ -5. & The language of basic tactics & (directory \texttt{src/tactics})\\ -6. & The vernacular interpreter & (directory \texttt{src/env})\\ -7. & The parser and the pretty-printer & (directory \texttt{src/parsing})\\ -8. & The standard library & (directory \texttt{src/lib}) -\end{tabular} - -\vspace{1em} - -The following sections briefly present each of the modules above. -This presentation is not intended to be a complete description of \Coq's -implementation, but rather a guideline to be read before taking a look -at the sources. For each of the modules, we also present some of its -most important functions, which are sufficient to implement a large -class of tactics. - - -\subsection[The Logical Framework]{The Logical Framework\label{LogicalFramework}} - -At the very heart of \Coq there is a generic untyped language for -expressing abstractions, applications and global constants. This -language is used as a meta-language for expressing the terms of the -Calculus of Inductive Constructions. General operations on terms like -collecting the free variables of an expression, substituting a term for -a free variable, etc, are expressed in this language. - -The meta-language \texttt{'op term} of terms has seven main -constructors: -\begin{itemize} -\item $(\texttt{VAR}\;id)$, a reference to a global identifier called $id$; -\item $(\texttt{Rel}\;n)$, a bound variable, whose binder is the $nth$ - binder up in the term; -\item $\texttt{DLAM}\;(x,t)$, a de Bruijn's binder on the term $t$; -\item $\texttt{DLAMV}\;(x,vt)$, a de Bruijn's binder on all the terms of - the vector $vt$; -\item $(\texttt{DOP0}\;op)$, a unary operator $op$; -\item $\texttt{DOP2}\;(op,t_1,t_2)$, the application of a binary -operator $op$ to the terms $t_1$ and $t_2$; -\item $\texttt{DOPN} (op,vt)$, the application of an n-ary operator $op$ to the -vector of terms $vt$. -\end{itemize} - -In this meta-language, bound variables are represented using the -so-called de Bruijn's indexes. In this representation, an occurrence of -a bound variable is denoted by an integer, meaning the number of -binders that must be traversed to reach its own -binder\footnote{Actually, $(\texttt{Rel}\;n)$ means that $(n-1)$ binders -have to be traversed, since indexes are represented by strictly -positive integers.}. On the other hand, constants are referred by its -name, as usual. For example, if $A$ is a variable of the current -section, then the lambda abstraction $[x:A]x$ of the Calculus of -Constructions is represented in the meta-language by the term: - -\begin{displaymath} -(DOP2 (Lambda,(Var\;A),DLAM (x,(Rel\;1))) -\end{displaymath} - -In this term, $Lambda$ is a binary operator. Its first argument -correspond to the type $A$ of the bound variable, while the second is -a body of the abstraction, where $x$ is bound. The name $x$ is just kept -to pretty-print the occurrences of the bound variable. - -%Similarly, the product -%$(A:Prop)A$ of the Calculus of Constructions is represented by the -%term: -%\begin{displaumath} -%DOP2 (Prod, DOP0 (Sort (Prop Null)), DLAM (Name \#A, Rel 1)) -%\end{displaymath} - -The following functions perform some of the most frequent operations -on the terms of the meta-language: -\begin{description} -\fun{val Generic.subst1 : 'op term -> 'op term -> 'op term} - {$(\texttt{subst1}\;t_1\;t_2)$ substitutes $t_1$ for - $\texttt{(Rel}\;1)$ in $t_2$.} -\fun{val Generic.occur\_var : identifier -> 'op term -> bool} - {Returns true when the given identifier appears in the term, - and false otherwise.} -\fun{val Generic.eq\_term : 'op term -> 'op term -> bool} - {Implements $\alpha$-equality for terms.} -\fun{val Generic.dependent : 'op term -> 'op term -> bool} - {Returns true if the first term is a sub-term of the second.} -%\fun{val Generic.subst\_var : identifier -> 'op term -> 'op term} -% { $(\texttt{subst\_var}\;id\;t)$ substitutes the de Bruijn's index -% associated to $id$ to every occurrence of the term -% $(\texttt{VAR}\;id)$ in $t$.} -\end{description} - -\subsubsection{Identifiers, names and sections paths.} - -Three different kinds of names are used in the meta-language. They are -all defined in the \ocaml{} file \texttt{Names}. - -\paragraph{Identifiers.} The simplest kind of names are -\textsl{identifiers}. An identifier is a string possibly indexed by an -integer. They are used to represent names that are not unique, like -for example the name of a variable in the scope of a section. The -following operations can be used for handling identifiers: - -\begin{description} -\fun{val Names.make\_ident : string -> int -> identifier} - {The value $(\texttt{make\_ident}\;x\;i)$ creates the - identifier $x_i$. If $i=-1$, then the identifier has - is created with no index at all.} -\fun{val Names.repr\_ident : identifier -> string * int} - {The inverse operation of \texttt{make\_ident}: - it yields the string and the index of the identifier.} -\fun{val Names.lift\_ident : identifier -> identifier} - {Increases the index of the identifier by one.} -\fun{val Names.next\_ident\_away : \\ -\qquad identifier -> identifier list -> identifier} - {\\ Generates a new identifier with the same root string than the - given one, but with a new index, different from all the indexes of - a given list of identifiers.} -\fun{val Names.id\_of\_string : string -> - identifier} - {Creates an identifier from a string.} -\fun{val Names.string\_of\_id : identifier -> string} - {The inverse operation: transforms an identifier into a string} -\end{description} - -\paragraph{Names.} A \textsl{name} is either an identifier or the -special name \texttt{Anonymous}. Names are used as arguments of -binders, in order to pretty print bound variables. -The following operations can be used for handling names: - -\begin{description} -\fun{val Names.Name: identifier -> Name} - {Constructs a name from an identifier.} -\fun{val Names.Anonymous : Name} - {Constructs a special, anonymous identifier, like the variable abstracted - in the term $[\_:A]0$.} -\fun{val - Names.next\_name\_away\_with\_default : \\ \qquad - string->name->identifier list->identifier} -{\\ If the name is not anonymous, then this function generates a new - identifier different from all the ones in a given list. Otherwise, it - generates an identifier from the given string.} -\end{description} - -\paragraph[Section paths.]{Section paths.\label{SectionPaths}} -A \textsl{section-path} is a global name to refer to an object without -ambiguity. It can be seen as a sort of filename, where open sections -play the role of directories. Each section path is formed by three -components: a \textsl{directory} (the list of open sections); a -\textsl{basename} (the identifier for the object); and a \textsl{kind} -(either CCI for the terms of the Calculus of Constructions, FW for the -the terms of $F_\omega$, or OBJ for other objects). For example, the -name of the following constant: -\begin{verbatim} - Section A. - Section B. - Section C. - Definition zero := O. -\end{verbatim} - -is internally represented by the section path: - -$$\underbrace{\mathtt{\#A\#B\#C}}_{\mbox{dirpath}} -\underbrace{\mathtt{\tt \#zero}}_{\mbox{basename}} -\underbrace{\mathtt{\tt .cci}_{\;}}_{\mbox{kind}}$$ - -When one of the sections is closed, a new constant is created with an -updated section-path,a nd the old one is no longer reachable. In our -example, after closing the section \texttt{C}, the new section-path -for the constant {\tt zero} becomes: -\begin{center} -\texttt{ \#A\#B\#zero.cci} -\end{center} - -The following operations can be used to handle section paths: - -\begin{description} -\fun{val Names.string\_of\_path : section\_path -> string} - {Transforms the section path into a string.} -\fun{val Names.path\_of\_string : string -> section\_path} - {Parses a string an returns the corresponding section path.} -\fun{val Names.basename : section\_path -> identifier} - {Provides the basename of a section path} -\fun{val Names.dirpath : section\_path -> string list} - {Provides the directory of a section path} -\fun{val Names.kind\_of\_path : section\_path -> path\_kind} - {Provides the kind of a section path} -\end{description} - -\subsubsection{Signatures} - -A \textsl{signature} is a mapping associating different informations -to identifiers (for example, its type, its definition, etc). The -following operations could be useful for working with signatures: - -\begin{description} -\fun{val Names.ids\_of\_sign : 'a signature -> identifier list} - {Gets the list of identifiers of the signature.} -\fun{val Names.vals\_of\_sign : 'a signature -> 'a list} - {Gets the list of values associated to the identifiers of the signature.} -\fun{val Names.lookup\_glob1 : \\ \qquad -identifier -> 'a signature -> (identifier * - 'a)} - {\\ Gets the value associated to a given identifier of the signature.} -\end{description} - - -\subsection{The Terms of the Calculus of Constructions} - -The language of the Calculus of Inductive Constructions described in -Chapter \ref{Cic} is implemented on the top of the logical framework, -instantiating the parameter $op$ of the meta-language with a -particular set of operators. In the implementation this language is -called \texttt{constr}, the language of constructions. - -% The only difference -%with respect to the one described in Section \ref{} is that the terms -%of \texttt{constr} may contain \textsl{existential variables}. An -%existential variable is a place holder representing a part of the term -%that is still to be constructed. Such ``open terms'' are necessary -%when building proofs interactively. - -\subsubsection{Building Constructions} - -The user does not need to know the choices made to represent -\texttt{constr} in the meta-language. They are abstracted away by the -following constructor functions: - -\begin{description} -\fun{val Term.mkRel : int -> constr} - {$(\texttt{mkRel}\;n)$ represents de Bruijn's index $n$.} - -\fun{val Term.mkVar : identifier -> constr} - {$(\texttt{mkVar}\;id)$ - represents a global identifier named $id$, like a variable - inside the scope of a section, or a hypothesis in a proof}. - -\fun{val Term.mkExistential : constr} - {\texttt{mkExistential} represents an implicit sub-term, like the question - marks in the term \texttt{(pair ? ? O true)}.} - -%\fun{val Term.mkMeta : int -> constr} -% {$(\texttt{mkMeta}\;n)$ represents an existential variable, whose -% name is the integer $n$.} - -\fun{val Term.mkProp : constr} - {$\texttt{mkProp}$ represents the sort \textsl{Prop}.} - -\fun{val Term.mkSet : constr} - {$\texttt{mkSet}$ represents the sort \textsl{Set}.} - -\fun{val Term.mkType : Impuniv.universe -> constr} - {$(\texttt{mkType}\;u)$ represents the term - $\textsl{Type}(u)$. The universe $u$ is represented as a - section path indexed by an integer. } - -\fun{val Term.mkConst : section\_path -> constr array -> constr} - {$(\texttt{mkConst}\;c\;v)$ represents a constant whose name is - $c$. The body of the constant is stored in a global table, - accessible through the name of the constant. The array of terms - $v$ corresponds to the variables of the environment appearing in - the body of the constant when it was defined. For instance, a - constant defined in the section \textsl{Foo} containing the - variable $A$, and whose body is $[x:Prop\ra Prop](x\;A)$ is - represented inside the scope of the section by - $(\texttt{mkConst}\;\texttt{\#foo\#f.cci}\;[| \texttt{mkVAR}\;A - |])$. Once the section is closed, the constant is represented by - the term $(\texttt{mkConst}\;\#f.cci\;[| |])$, and its body - becomes $[A:Prop][x:Prop\ra Prop](x\;A)$}. - -\fun{val Term.mkMutInd : section\_path -> int -> constr array ->constr} - {$(\texttt{mkMutInd}\;c\;i)$ represents the $ith$ type - (starting from zero) of the block of mutually dependent - (co)inductive types, whose first type is $c$. Similarly to the - case of constants, the array of terms represents the current - environment of the (co)inductive type. The definition of the type - (its arity, its constructors, whether it is inductive or co-inductive, etc.) - is stored in a global hash table, accessible through the name of - the type.} - -\fun{val Term.mkMutConstruct : \\ \qquad section\_path -> int -> int -> constr array - ->constr} {\\ $(\texttt{mkMutConstruct}\;c\;i\;j)$ represents the - $jth$ constructor of the $ith$ type of the block of mutually - dependent (co)inductive types whose first type is $c$. The array - of terms represents the current environment of the (co)inductive - type.} - -\fun{val Term.mkCast : constr -> constr -> constr} - {$(\texttt{mkCast}\;t\;T)$ represents the annotated term $t::T$ in - \Coq's syntax.} - -\fun{val Term.mkProd : name ->constr ->constr -> constr} - {$(\texttt{mkProd}\;x\;A\;B)$ represents the product $(x:A)B$. - The free ocurrences of $x$ in $B$ are represented by de Bruijn's - indexes.} - -\fun{val Term.mkNamedProd : identifier -> constr -> constr -> constr} - {$(\texttt{produit}\;x\;A\;B)$ represents the product $(x:A)B$, - but the bound occurrences of $x$ in $B$ are denoted by - the identifier $(\texttt{mkVar}\;x)$. The function automatically - changes each occurrences of this identifier into the corresponding - de Bruijn's index.} - -\fun{val Term.mkArrow : constr -> constr -> constr} - {$(\texttt{arrow}\;A\;B)$ represents the type $(A\rightarrow B)$.} - -\fun{val Term.mkLambda : name -> constr -> constr -> constr} - {$(\texttt{mkLambda}\;x\;A\;b)$ represents the lambda abstraction - $[x:A]b$. The free ocurrences of $x$ in $B$ are represented by de Bruijn's - indexes.} - -\fun{val Term.mkNamedLambda : identifier -> constr -> constr -> constr} - {$(\texttt{lambda}\;x\;A\;b)$ represents the lambda abstraction - $[x:A]b$, but the bound occurrences of $x$ in $B$ are denoted by - the identifier $(\texttt{mkVar}\;x)$. } - -\fun{val Term.mkAppLA : constr array -> constr} - {$(\texttt{mkAppLA}\;t\;[|t_1\ldots t_n|])$ represents the application - $(t\;t_1\;\ldots t_n)$.} - -\fun{val Term.mkMutCaseA : \\ \qquad - case\_info -> constr ->constr - ->constr array -> constr} - {\\ $(\texttt{mkMutCaseA}\;r\;P\;m\;[|f_1\ldots f_n|])$ - represents the term \Case{P}{m}{f_1\ldots f_n}. The first argument - $r$ is either \texttt{None} or $\texttt{Some}\;(c,i)$, where the - pair $(c,i)$ refers to the inductive type that $m$ belongs to.} - -\fun{val Term.mkFix : \\ \qquad -int array->int->constr array->name - list->constr array->constr} - {\\ $(\texttt{mkFix}\;[|k_1\ldots k_n |]\;i\;[|A_1\ldots - A_n|]\;[|f_1\ldots f_n|]\;[|t_1\ldots t_n|])$ represents the term - $\Fix{f_i}{f_1/k_1:A_1:=t_1 \ldots f_n/k_n:A_n:=t_n}$} - -\fun{val Term.mkCoFix : \\ \qquad - int -> constr array -> name list -> - constr array -> constr} - {\\ $(\texttt{mkCoFix}\;i\;[|A_1\ldots - A_n|]\;[|f_1\ldots f_n|]\;[|t_1\ldots t_n|])$ represents the term - $\CoFix{f_i}{f_1:A_1:=t_1 \ldots f_n:A_n:=t_n}$. There are no - decreasing indexes in this case.} -\end{description} - -\subsubsection{Decomposing Constructions} - -Each of the construction functions above has its corresponding -(partial) destruction function, whose name is obtained changing the -prefix \texttt{mk} by \texttt{dest}. In addition to these functions, a -concrete datatype \texttt{kindOfTerm} can be used to do pattern -matching on terms without dealing with their internal representation -in the meta-language. This concrete datatype is described in the \ocaml{} -file \texttt{term.mli}. The following function transforms a construction -into an element of type \texttt{kindOfTerm}: - -\begin{description} -\fun{val Term.kind\_of\_term : constr -> kindOfTerm} - {Destructs a term of the language \texttt{constr}, -yielding the direct components of the term. Hence, in order to do -pattern matching on an object $c$ of \texttt{constr}, it is sufficient -to do pattern matching on the value $(\texttt{kind\_of\_term}\;c)$.} -\end{description} - -Part of the information associated to the constants is stored in -global tables. The following functions give access to such -information: - -\begin{description} -\fun{val Termenv.constant\_value : constr -> constr} - {If the term denotes a constant, projects the body of a constant} -\fun{Termenv.constant\_type : constr -> constr} - {If the term denotes a constant, projects the type of the constant} -\fun{val mind\_arity : constr -> constr} - {If the term denotes an inductive type, projects its arity (i.e., - the type of the inductive type).} -\fun{val Termenv.mis\_is\_finite : mind\_specif -> bool} - {Determines whether a recursive type is inductive or co-inductive.} -\fun{val Termenv.mind\_nparams : constr -> int} - {If the term denotes an inductive type, projects the number of - its general parameters.} -\fun{val Termenv.mind\_is\_recursive : constr -> bool} - {If the term denotes an inductive type, - determines if the type has at least one recursive constructor. } -\fun{val Termenv.mind\_recargs : constr -> recarg list array array} - {If the term denotes an inductive type, returns an array $v$ such - that the nth element of $v.(i).(j)$ is - \texttt{Mrec} if the $nth$ argument of the $jth$ constructor of - the $ith$ type is recursive, and \texttt{Norec} if it is not.}. -\end{description} - -\subsection[The Type Checker]{The Type Checker\label{TypeChecker}} - -The third logical module is the type checker. It concentrates two main -tasks concerning the language of constructions. - -On one hand, it contains the type inference and type-checking -functions. The type inference function takes a term -$a$ and a signature $\Gamma$, and yields a term $A$ such that -$\Gamma \vdash a:A$. The type-checking function takes two terms $a$ -and $A$ and a signature $\Gamma$, and determines whether or not -$\Gamma \vdash a:A$. - -On the other hand, this module is in charge of the compilation of -\Coq's abstract syntax trees into the language \texttt{constr} of -constructions. This compilation seeks to eliminate all the ambiguities -contained in \Coq's abstract syntax, restoring the information -necessary to type-check it. It concerns at least the following steps: -\begin{enumerate} -\item Compiling the pattern-matching expressions containing -constructor patterns, wild-cards, etc, into terms that only -use the primitive \textsl{Case} described in Chapter \ref{Cic} -\item Restoring type coercions and synthesizing the implicit arguments -(the one denoted by question marks in -{\Coq} syntax: see Section~\ref{Coercions}). -\item Transforming the named bound variables into de Bruijn's indexes. -\item Classifying the global names into the different classes of -constants (defined constants, constructors, inductive types, etc). -\end{enumerate} - -\subsection{The Proof Engine} - -The fourth stage of \Coq's implementation is the \textsl{proof engine}: -the interactive machine for constructing proofs. The aim of the proof -engine is to construct a top-down derivation or \textsl{proof tree}, -by the application of \textsl{tactics}. A proof tree has the following -general structure:\\ - -\begin{displaymath} -\frac{\Gamma \vdash ? = t(?_1,\ldots?_n) : G} - {\hspace{3ex}\frac{\displaystyle \Gamma_1 \vdash ?_1 = t_1(\ldots) : G_1} - {\stackrel{\vdots}{\displaystyle {\Gamma_{i_1} \vdash ?_{i_1} - : G_{i_1}}}}(tac_1) - \;\;\;\;\;\;\;\;\; - \frac{\displaystyle \Gamma_n \vdash ?_n = t_n(\ldots) : G_n} - {\displaystyle \stackrel{\vdots}{\displaystyle {\Gamma_{i_m} \vdash ?_{i_m} : - G_{i_m}}}}(tac_n)} (tac) -\end{displaymath} - - -\noindent Each node of the tree is called a \textsl{goal}. A goal -is a record type containing the following three fields: -\begin{enumerate} -\item the conclusion $G$ to be proven; -\item a typing signature $\Gamma$ for the free variables in $G$; -\item if the goal is an internal node of the proof tree, the -definition $t(?_1,\ldots?_n)$ of an \textsl{existential variable} -(i.e. a possible undefined constant) $?$ of type $G$ in terms of the -existential variables of the children sub-goals. If the node is a -leaf, the existential variable maybe still undefined. -\end{enumerate} - -Once all the existential variables have been defined the derivation is -completed, and a construction can be generated from the proof tree, -replacing each of the existential variables by its definition. This -is exactly what happens when one of the commands -\texttt{Qed} or \texttt{Defined} is invoked -(see Section~\ref{Qed}). The saved theorem becomes a defined constant, -whose body is the proof object generated. - -\paragraph{Important:} Before being added to the -context, the proof object is type-checked, in order to verify that it is -actually an object of the expected type $G$. Hence, the correctness -of the proof actually does not depend on the tactics applied to -generate it or the machinery of the proof engine, but only on the -type-checker. In other words, extending the system with a potentially -bugged new tactic never endangers the consistency of the system. - -\subsubsection[What is a Tactic?]{What is a Tactic?\label{WhatIsATactic}} -%Let us now explain what is a tactic, and how the user can introduce -%new ones. - -From an operational point of view, the current state of the proof -engine is given by the mapping $emap$ from existential variables into -goals, plus a pointer to one of the leaf goals $g$. Such a pointer -indicates where the proof tree will be refined by the application of a -\textsl{tactic}. A tactic is a function from the current state -$(g,emap)$ of the proof engine into a pair $(l,val)$. The first -component of this pair is the list of children sub-goals $g_1,\ldots -g_n$ of $g$ to be yielded by the tactic. The second one is a -\textsl{validation function}. Once the proof trees $\pi_1,\ldots -\pi_n$ for $g_1,\ldots g_n$ have been completed, this validation -function must yield a proof tree $(val\;\pi_1,\ldots \pi_n)$ deriving -$g$. - -Tactics can be classified into \textsl{primitive} ones and -\textsl{defined} ones. Primitive tactics correspond to the five basic -operations of the proof engine: - -\begin{enumerate} -\item Introducing a universally quantified variable into the local -context of the goal. -\item Defining an undefined existential variable -\item Changing the conclusion of the goal for another ---definitionally equal-- term. -\item Changing the type of a variable in the local context for another -definitionally equal term. -\item Erasing a variable from the local context. -\end{enumerate} - -\textsl{Defined} tactics are tactics constructed by combining these -primitive operations. Defined tactics are registered in a hash table, -so that they can be introduced dynamically. In order to define such a -tactic table, it is necessary to fix what a \textsl{possible argument} -of a tactic may be. The type \texttt{tactic\_arg} of the possible -arguments for tactics is a union type including: -\begin{itemize} -\item quoted strings; -\item integers; -\item identifiers; -\item lists of identifiers; -\item plain terms, represented by its abstract syntax tree; -\item well-typed terms, represented by a construction; -\item a substitution for bound variables, like the -substitution in the tactic \\$\texttt{Apply}\;t\;\texttt{with}\;x:=t_1\ldots -x_n:=t_n$, (see Section~\ref{apply}); -\item a reduction expression, denoting the reduction strategy to be -followed. -\end{itemize} -Therefore, for each function $tac:a \rightarrow tactic$ implementing a -defined tactic, an associated dynamic tactic $tacargs\_tac: -\texttt{tactic\_arg}\;list \rightarrow tactic$ calling $tac$ must be -written. The aim of the auxiliary function $tacargs\_tac$ is to inject -the arguments of the tactic $tac$ into the type of possible arguments -for a tactic. - -The following function can be used for registering and calling a -defined tactic: - -\begin{description} -\fun{val Tacmach.add\_tactic : \\ \qquad -string -> (tactic\_arg list ->tactic) -> unit} - {\\ Registers a dynamic tactic with the given string as access index.} -\fun{val Tacinterp.vernac\_tactic : string*tactic\_arg list -> tactic} - {Interprets a defined tactic given by its entry in the - tactics table with a particular list of possible arguments.} -\fun{val Tacinterp.vernac\_interp : CoqAst.t -> tactic} - {Interprets a tactic expression formed combining \Coq's tactics and - tacticals, and described by its abstract syntax tree.} -\end{description} - -When programming a new tactic that calls an already defined tactic -$tac$, we have the choice between using the \ocaml{} function -implementing $tac$, or calling the tactic interpreter with the name -and arguments for interpreting $tac$. In the first case, a tactic call -will left the trace of the whole implementation of $tac$ in the proof -tree. In the second, the implementation of $tac$ will be hidden, and -only an invocation of $tac$ will be recalled (cf. the example of -Section \ref{ACompleteExample}. The following combinators can be used -to hide the implementation of a tactic: - -\begin{verbatim} -type 'a hiding_combinator = string -> ('a -> tactic) -> ('a -> tactic) -val Tacmach.hide_atomic_tactic : string -> tactic -> tactic -val Tacmach.hide_constr_tactic : constr hiding_combinator -val Tacmach.hide_constrl_tactic : (constr list) hiding_combinator -val Tacmach.hide_numarg_tactic : int hiding_combinator -val Tacmach.hide_ident_tactic : identifier hiding_combinator -val Tacmach.hide_identl_tactic : identifier hiding_combinator -val Tacmach.hide_string_tactic : string hiding_combinator -val Tacmach.hide_bindl_tactic : substitution hiding_combinator -val Tacmach.hide_cbindl_tactic : - (constr * substitution) hiding_combinator -\end{verbatim} - -These functions first register the tactic by a side effect, and then -yield a function calling the interpreter with the registered name and -the right injection into the type of possible arguments. - -\subsection{Tactics and Tacticals Provided by \Coq} - -The fifth logical module is the library of tacticals and basic tactics -provided by \Coq. This library is distributed into the directories -\texttt{tactics} and \texttt{src/tactics}. The former contains those -basic tactics that make use of the types contained in the basic state -of \Coq. For example, inversion or rewriting tactics are in the -directory \texttt{tactics}, since they make use of the propositional -equality type. Those tactics which are independent from the context ---like for example \texttt{Cut}, \texttt{Intros}, etc-- are defined in -the directory \texttt{src/tactics}. This latter directory also -contains some useful tools for programming new tactics, referred in -Section \ref{SomeUsefulToolsforWrittingTactics}. - -In practice, it is very unusual that the list of sub-goals and the -validation function of the tactic must be explicitly constructed by -the user. In most of the cases, the implementation of a new tactic -consists in supplying the appropriate arguments to the basic tactics -and tacticals. - -\subsubsection{Basic Tactics} - -The file \texttt{Tactics} contain the implementation of the basic -tactics provided by \Coq. The following tactics are some of the most -used ones: - -\begin{verbatim} -val Tactics.intro : tactic -val Tactics.assumption : tactic -val Tactics.clear : identifier list -> tactic -val Tactics.apply : constr -> constr substitution -> tactic -val Tactics.one_constructor : int -> constr substitution -> tactic -val Tactics.simplest_elim : constr -> tactic -val Tactics.elimType : constr -> tactic -val Tactics.simplest_case : constr -> tactic -val Tactics.caseType : constr -> tactic -val Tactics.cut : constr -> tactic -val Tactics.reduce : redexpr -> tactic -val Tactics.exact : constr -> tactic -val Auto.auto : int option -> tactic -val Auto.trivial : tactic -\end{verbatim} - -The functions hiding the implementation of these tactics are defined -in the module \texttt{Hiddentac}. Their names are prefixed by ``h\_''. - -\subsubsection[Tacticals]{Tacticals\label{OcamlTacticals}} - -The following tacticals can be used to combine already existing -tactics: - -\begin{description} -\fun{val Tacticals.tclIDTAC : tactic} - {The identity tactic: it leaves the goal as it is.} - -\fun{val Tacticals.tclORELSE : tactic -> tactic -> tactic} - {Tries the first tactic and in case of failure applies the second one.} - -\fun{val Tacticals.tclTHEN : tactic -> tactic -> tactic} - {Applies the first tactic and then the second one to each generated subgoal.} - -\fun{val Tacticals.tclTHENS : tactic -> tactic list -> tactic} - {Applies a tactic, and then applies each tactic of the tactic list to the - corresponding generated subgoal.} - -\fun{val Tacticals.tclTHENL : tactic -> tactic -> tactic} - {Applies the first tactic, and then applies the second one to the last - generated subgoal.} - -\fun{val Tacticals.tclREPEAT : tactic -> tactic} - {If the given tactic succeeds in producing a subgoal, then it - is recursively applied to each generated subgoal, - and so on until it fails. } - -\fun{val Tacticals.tclFIRST : tactic list -> tactic} - {Tries the tactics of the given list one by one, until one of them - succeeds.} - -\fun{val Tacticals.tclTRY : tactic -> tactic} - {Tries the given tactic and in case of failure applies the {\tt - tclIDTAC} tactical to the original goal.} - -\fun{val Tacticals.tclDO : int -> tactic -> tactic} - {Applies the tactic a given number of times.} - -\fun{val Tacticals.tclFAIL : tactic} - {The always failing tactic: it raises a {\tt UserError} exception.} - -\fun{val Tacticals.tclPROGRESS : tactic -> tactic} - {Applies the given tactic to the current goal and fails if the - tactic leaves the goal unchanged} - -\fun{val Tacticals.tclNTH\_HYP : int -> (constr -> tactic) -> tactic} - {Applies a tactic to the nth hypothesis of the local context. - The last hypothesis introduced correspond to the integer 1.} - -\fun{val Tacticals.tclLAST\_HYP : (constr -> tactic) -> tactic} - {Applies a tactic to the last hypothesis introduced.} - -\fun{val Tacticals.tclCOMPLETE : tactic -> tactic} - {Applies a tactic and fails if the tactic did not solve completely the - goal} - -\fun{val Tacticals.tclMAP : ('a -> tactic) -> 'a list -> tactic} - {Applied to the function \texttt{f} and the list \texttt{[x\_1; - ... ; x\_n]}, this tactical applies the tactic - \texttt{tclTHEN (f x1) (tclTHEN (f x2) ... ))))}} - -\fun{val Tacicals.tclIF : (goal sigma -> bool) -> tactic -> tactic -> tactic} - {If the condition holds, apply the first tactic; otherwise, - apply the second one} - -\end{description} - - -\subsection{The Vernacular Interpreter} - -The sixth logical module of the implementation corresponds to the -interpreter of the vernacular phrases of \Coq. These phrases may be -expressions from the \gallina{} language (definitions), general -directives (setting commands) or tactics to be applied by the proof -engine. - -\subsection[The Parser and the Pretty-Printer]{The Parser and the Pretty-Printer\label{PrettyPrinter}} - -The last logical module is the parser and pretty printer of \Coq, -which is the interface between the vernacular interpreter and the -user. They translate the chains of characters entered at the input -into abstract syntax trees, and vice versa. Abstract syntax trees are -represented by labeled n-ary trees, and its type is called -\texttt{CoqAst.t}. For instance, the abstract syntax tree associated -to the term $[x:A]x$ is: - -\begin{displaymath} -\texttt{Node} - ((0,6), "LAMBDA", - [\texttt{Nvar}~((3, 4),"A");~\texttt{Slam}~((0,6),~Some~"x",~\texttt{Nvar}~((5,6),"x"))]) -\end{displaymath} - -The numbers correspond to \textsl{locations}, used to point to some -input line and character positions in the error messages. As it was -already explained in Section \ref{TypeChecker}, this term is then -translated into a construction term in order to be typed. - -The parser of \Coq\ is implemented using \camlpppp. The lexer and the data -used by \camlpppp\ to generate the parser lay in the directory -\texttt{src/parsing}. This directory also contains \Coq's -pretty-printer. The printing rules lay in the directory -\texttt{src/syntax}. The different entries of the grammar are -described in the module \texttt{Pcoq.Entry}. Let us present here two -important functions of this logical module: - -\begin{description} -\fun{val Pcoq.parse\_string : 'a Grammar.Entry.e -> string -> 'a} - {Parses a given string, trying to recognize a phrase - corresponding to some entry in the grammar. If it succeeds, - it yields a value associated to the grammar entry. For example, - applied to the entry \texttt{Pcoq.Command.command}, this function - parses a term of \Coq's language, and yields a value of type - \texttt{CoqAst.t}. When applied to the entry - \texttt{Pcoq.Vernac.vernac}, it parses a vernacular command and - returns the corresponding Ast.} -\fun{val gentermpr : \\ \qquad -path\_kind -> constr assumptions -> constr -> std\_ppcmds} - {\\ Pretty-prints a well-typed term of certain kind (cf. Section - \ref{SectionPaths}) under its context of typing assumption.} -\fun{val gentacpr : CoqAst.t -> std\_ppcmds} - {Pretty-prints a given abstract syntax tree representing a tactic - expression.} -\end{description} - -\subsection{The General Library} - -In addition to the ones laying in the standard library of \ocaml{}, -several useful modules about lists, arrays, sets, mappings, balanced -trees, and other frequently used data structures can be found in the -directory \texttt{lib}. Before writing a new one, check if it is not -already there! - -\subsubsection{The module \texttt{Std}} -This module in the directory \texttt{src/lib/util} is opened by almost -all modules of \Coq{}. Among other things, it contains a definition of -the different kinds of errors used in \Coq{} : - -\begin{description} -\fun{exception UserError of string * std\_ppcmds} - {This is the class of ``users exceptions''. Such errors arise when - the user attempts to do something illegal, for example \texttt{Intro} - when the current goal conclusion is not a product.} - -\fun{val Std.error : string -> 'a} - {For simple error messages} -\fun{val Std.user_err : ?loc:Loc.t -> string -> std\_ppcmds -> 'a} - {See Section~\ref{PrettyPrinter} : this can be used if the user - want to display a term or build a complex error message} - -\fun{exception Anomaly of string * std\_ppcmds} - {This for reporting bugs or things that should not - happen. The tacticals \texttt{tclTRY} and - \texttt{tclTRY} described in Section~\ref{OcamlTacticals} catch the - exceptions of type \texttt{UserError}, but they don't catch the - anomalies. So, in your code, don't raise any anomaly, unless you - know what you are doing. We also recommend to avoid constructs - such as \texttt{try ... with \_ -> ...} : such constructs can trap - an anomaly and make the debugging process harder.} - -\fun{val Std.anomaly : string -> 'a}{} -\fun{val Std.anomalylabstrm : string -> std\_ppcmds -> 'a}{} -\end{description} - -\section{The tactic writer mini-HOWTO} - -\subsection{How to add a vernacular command} - -The command to register a vernacular command can be found -in module \texttt{Vernacinterp}: - -\begin{verbatim} -val vinterp_add : string * (vernac_arg list -> unit -> unit) -> unit;; -\end{verbatim} - -The first argument is the name, the second argument is a function that -parses the arguments and returns a function of type -\texttt{unit}$\rightarrow$\texttt{unit} that do the job. - -In this section we will show how to add a vernacular command -\texttt{CheckCheck} that print a type of a term and the type of its -type. - -File \texttt{dcheck.ml}: - -\begin{verbatim} -open Vernacinterp;; -open Trad;; -let _ = - vinterp_add - ("DblCheck", - function [VARG_COMMAND com] -> - (fun () -> - let evmap = Evd.mt_evd () - and sign = Termenv.initial_sign () in - let {vAL=c;tYP=t;kIND=k} = - fconstruct_with_univ evmap sign com in - Pp.mSGNL [< Printer.prterm c; 'sTR ":"; - Printer.prterm t; 'sTR ":"; - Printer.prterm k >] ) - | _ -> bad_vernac_args "DblCheck") -;; -\end{verbatim} - -Like for a new tactic, a new syntax entry must be created. - -File \texttt{DCheck.v}: - -\begin{verbatim} -Declare ML Module "dcheck.ml". - -Grammar vernac vernac := - dblcheck [ "CheckCheck" comarg($c) ] -> [(DblCheck $c)]. -\end{verbatim} - -We are now able to test our new command: - -\begin{verbatim} -Coq < Require DCheck. -Coq < CheckCheck O. -O:nat:Set -\end{verbatim} - -Most Coq vernacular commands are registered in the module - \verb+src/env/vernacentries.ml+. One can see more examples here. - -\subsection{How to keep a hashtable synchronous with the reset mechanism} - -This is far more tricky. Some vernacular commands modify some -sort of state (for example by adding something in a hashtable). One -wants that \texttt{Reset} has the expected behavior with this -commands. - -\Coq{} provides a general mechanism to do that. \Coq{} environments -contains objects of three kinds: CCI, FW and OBJ. CCI and FW are for -constants of the calculus. OBJ is a dynamically extensible datatype -that contains sections, tactic definitions, hints for auto, and so -on. - -The simplest example of use of such a mechanism is in file -\verb+src/proofs/macros.ml+ (which implements the \texttt{Tactic - Definition} command). Tactic macros are stored in the imperative -hashtable \texttt{mactab}. There are two functions freeze and unfreeze -to make a copy of the table and to restore the state of table from the -copy. Then this table is declared using \texttt{Library.declare\_summary}. - -What does \Coq{} with that ? \Coq{} defines synchronization points. -At each synchronisation point, the declared tables are frozen (that -is, a copy of this tables is stored). - -When \texttt{Reset }$i$ is called, \Coq{} goes back to the first -synchronisation point that is above $i$ and ``replays'' all objects -between that point -and $i$. It will re-declare constants, re-open section, etc. - -So we need to declare a new type of objects, TACTIC-MACRO-DATA. To -``replay'' on object of that type is to add the corresponding tactic -macro to \texttt{mactab} - -So, now, we can say that \texttt{mactab} is synchronous with the Reset -mechanism$^{\mathrm{TM}}$. - -Notice that this works for hash tables but also for a single integer -(the Undo stack size, modified by the \texttt{Set Undo} command, for -example). - -\subsection{The right way to access to Coq constants from your ML code} - -With their long names, Coq constants are stored using: - -\begin{itemize} -\item a section path -\item an identifier -\end{itemize} - -The identifier is exactly the identifier that is used in \Coq{} to -denote the constant; the section path can be known using the -\texttt{Locate} command: - -\begin{coq_example} - Locate S. - Locate nat. - Locate eq. -\end{coq_example} - -Now it is easy to get a constant by its name and section path: - - -\begin{verbatim} -let constant sp id = - Machops.global_reference (Names.gLOB (Termenv.initial_sign ())) - (Names.path_of_string sp) (Names.id_of_string id);; -\end{verbatim} - - -The only issue is that if one cannot put: - - -\begin{verbatim} -let coq_S = constant "#Datatypes#nat.cci" "S";; -\end{verbatim} - - -in his tactic's code. That is because this sentence is evaluated -\emph{before} the module \texttt{Datatypes} is loaded. The solution is -to use the lazy evaluation of \ocaml{}: - - -\begin{verbatim} -let coq_S = lazy (constant "#Datatypes#nat.cci" "S");; - -... (Lazy.force coq_S) ... -\end{verbatim} - - -Be sure to call always Lazy.force behind a closure -- i.e. inside a -function body or behind the \texttt{lazy} keyword. - -One can see examples of that technique in the source code of \Coq{}, -for example -\verb+plugins/omega/coq_omega.ml+. - -\section[Some Useful Tools for Writing Tactics]{Some Useful Tools for Writing Tactics\label{SomeUsefulToolsforWrittingTactics}} -When the implementation of a tactic is not a straightforward -combination of tactics and tacticals, the module \texttt{Tacmach} -provides several useful functions for handling goals, calling the -type-checker, parsing terms, etc. This module is intended to be -the interface of the proof engine for the user. - -\begin{description} -\fun{val Tacmach.pf\_hyps : goal sigma -> constr signature} - {Projects the local typing context $\Gamma$ from a given goal $\Gamma\vdash ?:G$.} -\fun{val pf\_concl : goal sigma -> constr} - {Projects the conclusion $G$ from a given goal $\Gamma\vdash ?:G$.} -\fun{val Tacmach.pf\_nth\_hyp : goal sigma -> int -> identifier * - constr} - {Projects the $ith$ typing constraint $x_i:A_i$ from the local - context of the given goal.} -\fun{val Tacmach.pf\_fexecute : goal sigma -> constr -> judgement} - {Given a goal whose local context is $\Gamma$ and a term $a$, this - function infers a type $A$ and a kind $K$ such that the judgement - $a:A:K$ is valid under $\Gamma$, or raises an exception if there - is no such judgement. A judgement is just a record type containing - the three terms $a$, $A$ and $K$.} -\fun{val Tacmach.pf\_infexecute : \\ - \qquad -goal sigma -> constr -> judgement * information} - {\\ In addition to the typing judgement, this function also extracts - the $F_{\omega}$ program underlying the term.} -\fun{val Tacmach.pf\_type\_of : goal sigma -> constr -> constr} - {Infers a term $A$ such that $\Gamma\vdash a:A$ for a given term - $a$, where $\Gamma$ is the local typing context of the goal.} -\fun{val Tacmach.pf\_check\_type : goal sigma -> constr -> constr -> bool} - {This function yields a type $A$ if the two given terms $a$ and $A$ verify $\Gamma\vdash - a:A$ in the local typing context $\Gamma$ of the goal. Otherwise, - it raises an exception.} -\fun{val Tacmach.pf\_constr\_of\_com : goal sigma -> CoqAst.t -> constr} - {Transforms an abstract syntax tree into a well-typed term of the - language of constructions. Raises an exception if the term cannot - be typed.} -\fun{val Tacmach.pf\_constr\_of\_com\_sort : goal sigma -> CoqAst.t -> constr} - {Transforms an abstract syntax tree representing a type into - a well-typed term of the language of constructions. Raises an - exception if the term cannot be typed.} -\fun{val Tacmach.pf\_parse\_const : goal sigma -> string -> constr} - {Constructs the constant whose name is the given string.} -\fun{val -Tacmach.pf\_reduction\_of\_redexp : \\ - \qquad goal sigma -> red\_expr -> constr -> constr} - {\\ Applies a certain kind of reduction function, specified by an - element of the type red\_expr.} -\fun{val Tacmach.pf\_conv\_x : goal sigma -> constr -> constr -> bool} - {Test whether two given terms are definitionally equal.} -\end{description} - -\subsection[Patterns]{Patterns\label{Patterns}} - -The \ocaml{} file \texttt{Pattern} provides a quick way for describing a -term pattern and performing second-order, binding-preserving, matching -on it. Patterns are described using an extension of \Coq's concrete -syntax, where the second-order meta-variables of the pattern are -denoted by indexed question marks. - -Patterns may depend on constants, and therefore only to make have -sense when certain theories have been loaded. For this reason, they -are stored with a \textsl{module-marker}, telling us which modules -have to be open in order to use the pattern. The following functions -can be used to store and retrieve patterns form the pattern table: - -\begin{description} -\fun{val Pattern.make\_module\_marker : string list -> module\_mark} - {Constructs a module marker from a list of module names.} -\fun{val Pattern.put\_pat : module\_mark -> string -> marked\_term} - {Constructs a pattern from a parseable string containing holes - and a module marker.} -\fun{val Pattern.somatches : constr -> marked\_term-> bool} - {Tests if a term matches a pattern.} -\fun{val dest\_somatch : constr -> marked\_term -> constr list} - {If the term matches the pattern, yields the list of sub-terms - matching the occurrences of the pattern variables (ordered from - left to right). Raises a \texttt{UserError} exception if the term - does not match the pattern.} -\fun{val Pattern.soinstance : marked\_term -> constr list -> constr} - {Substitutes each hole in the pattern - by the corresponding term of the given the list.} -\end{description} - -\paragraph{Warning:} Sometimes, a \Coq\ term may have invisible -sub-terms that the matching functions are nevertheless sensible to. -For example, the \Coq\ term $(?_1,?_2)$ is actually a shorthand for -the expression $(\texttt{pair}\;?\;?\;?_1\;?_2)$. -Hence, matching this term pattern -with the term $(\texttt{true},\texttt{O})$ actually yields the list -$[?;?;\texttt{true};\texttt{O}]$ as result (and \textbf{not} -$[\texttt{true};\texttt{O}]$, as could be expected). - -\subsection{Patterns on Inductive Definitions} - -The module \texttt{Pattern} also includes some functions for testing -if the definition of an inductive type satisfies certain -properties. Such functions may be used to perform pattern matching -independently from the name given to the inductive type and the -universe it inhabits. They yield the value $(\texttt{Some}\;r::l)$ if -the input term reduces into an application of an inductive type $r$ to -a list of terms $l$, and the definition of $r$ satisfies certain -conditions. Otherwise, they yield the value \texttt{None}. - -\begin{description} -\fun{val Pattern.match\_with\_non\_recursive\_type : constr list option} - {Tests if the inductive type $r$ has no recursive constructors} -\fun{val Pattern.match\_with\_disjunction : constr list option} - {Tests if the inductive type $r$ is a non-recursive type - such that all its constructors have a single argument.} -\fun{val Pattern.match\_with\_conjunction : constr list option} - {Tests if the inductive type $r$ is a non-recursive type - with a unique constructor.} -\fun{val Pattern.match\_with\_empty\_type : constr list option} - {Tests if the inductive type $r$ has no constructors at all} -\fun{val Pattern.match\_with\_equation : constr list option} - {Tests if the inductive type $r$ has a single constructor - expressing the property of reflexivity for some type. For - example, the types $a=b$, $A\mbox{==}B$ and $A\mbox{===}B$ satisfy - this predicate.} -\end{description} - -\subsection{Elimination Tacticals} - -It is frequently the case that the subgoals generated by an -elimination can all be solved in a similar way, possibly parametrized -on some information about each case, like for example: -\begin{itemize} -\item the inductive type of the object being eliminated; -\item its arguments (if it is an inductive predicate); -\item the branch number; -\item the predicate to be proven; -\item the number of assumptions to be introduced by the case -\item the signature of the branch, i.e., for each argument of -the branch whether it is recursive or not. -\end{itemize} - -The following tacticals can be useful to deal with such situations. -They - -\begin{description} -\fun{val Elim.simple\_elimination\_then : \\ \qquad -(branch\_args -> tactic) -> constr -> tactic} - {\\ Performs the default elimination on the last argument, and then - tries to solve the generated subgoals using a given parametrized - tactic. The type branch\_args is a record type containing all - information mentioned above.} -\fun{val Elim.simple\_case\_then : \\ \qquad -(branch\_args -> tactic) -> constr -> tactic} - {\\ Similarly, but it performs case analysis instead of induction.} -\end{description} - -\section[A Complete Example]{A Complete Example\label{ACompleteExample}} - -In order to illustrate the implementation of a new tactic, let us come -back to the problem of deciding the equality of two elements of an -inductive type. - -\subsection{Preliminaries} - -Let us call \texttt{newtactic} the directory that will contain the -implementation of the new tactic. In this directory will lay two -files: a file \texttt{eqdecide.ml}, containing the \ocaml{} sources that -implements the tactic, and a \Coq\ file \texttt{Eqdecide.v}, containing -its associated grammar rules and the commands to generate a module -that can be loaded dynamically from \Coq's toplevel. - -To compile our project, we will create a \texttt{Makefile} with the -command \texttt{do\_Makefile} (see Section~\ref{Makefile}) : - -\begin{quotation} - \texttt{do\_Makefile eqdecide.ml EqDecide.v > Makefile}\\ - \texttt{touch .depend}\\ - \texttt{make depend} -\end{quotation} - -We must have kept the sources of \Coq{} somewhere and to set an -environment variable \texttt{COQTOP} that points to that directory. - -\subsection{Implementing the Tactic} - -The file \texttt{eqdecide.ml} contains the implementation of the -tactic in \ocaml{}. Let us recall the main steps of the proof strategy -for deciding the proposition $(x,y:R)\{x=y\}+\{\neg x=y\}$ on the -inductive type $R$: -\begin{enumerate} -\item Eliminate $x$ and then $y$. -\item Try discrimination to solve those goals where $x$ and $y$ has -been introduced by different constructors. -\item If $x$ and $y$ have been introduced by the same constructor, - then analyze one by one the corresponding pairs of arguments. - If they are equal, rewrite one into the other. If they are - not, derive a contradiction from the invectiveness of the - constructor. -\item Once all the arguments have been rewritten, solve the left half -of the goal by reflexivity. -\end{enumerate} - -In the sequel we implement these steps one by one. We start opening -the modules necessary for the implementation of the tactic: - -\begin{verbatim} -open Names -open Term -open Tactics -open Tacticals -open Hiddentac -open Equality -open Auto -open Pattern -open Names -open Termenv -open Std -open Proof_trees -open Tacmach -\end{verbatim} - -The first step of the procedure can be straightforwardly implemented as -follows: - -\begin{verbatim} -let clear_last = (tclLAST_HYP (fun c -> (clear_one (destVar c))));; -\end{verbatim} - -\begin{verbatim} -let mkBranches = - (tclTHEN intro - (tclTHEN (tclLAST_HYP h_simplest_elim) - (tclTHEN clear_last - (tclTHEN intros - (tclTHEN (tclLAST_HYP h_simplest_case) - (tclTHEN clear_last - intros))))));; -\end{verbatim} - -Notice the use of the tactical \texttt{tclLAST\_HYP}, which avoids to -give a (potentially clashing) name to the quantified variables of the -goal when they are introduced. - -The second step of the procedure is implemented by the following -tactic: - -\begin{verbatim} -let solveRightBranch = (tclTHEN simplest_right discrConcl);; -\end{verbatim} - -In order to illustrate how the implementation of a tactic can be -hidden, let us do it with the tactic above: - -\begin{verbatim} -let h_solveRightBranch = - hide_atomic_tactic "solveRightBranch" solveRightBranch -;; -\end{verbatim} - -As it was already mentioned in Section \ref{WhatIsATactic}, the -combinator \texttt{hide\_atomic\_tactic} first registers the tactic -\texttt{solveRightBranch} in the table, and returns a tactic which -calls the interpreter with the used to register it. Hence, when the -tactical \texttt{Info} is used, our tactic will just inform that -\texttt{solveRightBranch} was applied, omitting all the details -corresponding to \texttt{simplest\_right} and \texttt{discrConcl}. - - - -The third step requires some auxiliary functions for constructing the -type $\{c_1=c_2\}+\{\neg c_1=c_2\}$ for a given inductive type $R$ and -two constructions $c_1$ and $c_2$, and for generalizing this type over -$c_1$ and $c_2$: - -\begin{verbatim} -let mmk = make_module_marker ["#Logic.obj";"#Specif.obj"];; -let eqpat = put_pat mmk "eq";; -let sumboolpat = put_pat mmk "sumbool";; -let notpat = put_pat mmk "not";; -let eq = get_pat eqpat;; -let sumbool = get_pat sumboolpat;; -let not = get_pat notpat;; - -let mkDecideEqGoal rectype c1 c2 g = - let equality = mkAppL [eq;rectype;c1;c2] in - let disequality = mkAppL [not;equality] - in mkAppL [sumbool;equality;disequality] -;; -let mkGenDecideEqGoal rectype g = - let hypnames = ids_of_sign (pf_hyps g) in - let xname = next_ident_away (id_of_string "x") hypnames - and yname = next_ident_away (id_of_string "y") hypnames - in (mkNamedProd xname rectype - (mkNamedProd yname rectype - (mkDecideEqGoal rectype (mkVar xname) (mkVar yname) g))) -;; -\end{verbatim} - -The tactic will depend on the \Coq modules \texttt{Logic} and -\texttt{Specif}, since we use the constants corresponding to -propositional equality (\texttt{eq}), computational disjunction -(\texttt{sumbool}), and logical negation (\texttt{not}), defined in -that modules. This is specified creating the module maker -\texttt{mmk} (see Section~\ref{Patterns}). - -The third step of the procedure can be divided into three sub-steps. -Assume that both $x$ and $y$ have been introduced by the same -constructor. For each corresponding pair of arguments of that -constructor, we have to consider whether they are equal or not. If -they are equal, the following tactic is applied to rewrite one into -the other: - -\begin{verbatim} -let eqCase tac = - (tclTHEN intro - (tclTHEN (tclLAST_HYP h_rewriteLR) - (tclTHEN clear_last - tac))) -;; -\end{verbatim} - - -If they are not equal, then the goal is contraposed and a -contradiction is reached form the invectiveness of the constructor: - -\begin{verbatim} -let diseqCase = - let diseq = (id_of_string "diseq") in - let absurd = (id_of_string "absurd") - in (tclTHEN (intro_using diseq) - (tclTHEN h_simplest_right - (tclTHEN red_in_concl - (tclTHEN (intro_using absurd) - (tclTHEN (h_simplest_apply (mkVar diseq)) - (tclTHEN (h_injHyp absurd) - trivial )))))) -;; -\end{verbatim} - -In the tactic above we have chosen to name the hypotheses because -they have to be applied later on. This introduces a potential risk -of name clashing if the context already contains other hypotheses -also named ``diseq'' or ``absurd''. - -We are now ready to implement the tactic \textsl{SolveArg}. Given the -two arguments $a_1$ and $a_2$ of the constructor, this tactic cuts the -goal with the proposition $\{a_1=a_2\}+\{\neg a_1=a_2\}$, and then -applies the tactics above to each of the generated cases. If the -disjunction cannot be solved automatically, it remains as a sub-goal -to be proven. - -\begin{verbatim} -let solveArg a1 a2 tac g = - let rectype = pf_type_of g a1 in - let decide = mkDecideEqGoal rectype a1 a2 g - in (tclTHENS (h_elimType decide) - [(eqCase tac);diseqCase;default_auto]) g -;; -\end{verbatim} - -The following tactic implements the third and fourth steps of the -proof procedure: - -\begin{verbatim} -let conclpatt = put_pat mmk "{<?1>?2=?3}+{?4}" -;; -let solveLeftBranch rectype g = - let (_::(lhs::(rhs::_))) = - try (dest_somatch (pf_concl g) conclpatt) - with UserError ("somatch",_)-> error "Unexpected conclusion!" in - let nparams = mind_nparams rectype in - let getargs l = snd (chop_list nparams (snd (decomp_app l))) in - let rargs = getargs rhs - and largs = getargs lhs - in List.fold_right2 - solveArg largs rargs (tclTHEN h_simplest_left h_reflexivity) g -;; -\end{verbatim} - -Notice the use of a pattern to decompose the goal and obtain the -inductive type and the left and right hand sides of the equality. A -certain number of arguments correspond to the general parameters of -the type, and must be skipped over. Once the corresponding list of -arguments \texttt{rargs} and \texttt{largs} have been obtained, the -tactic \texttt{solveArg} is iterated on them, leaving a disjunction -whose left half can be solved by reflexivity. - -The following tactic joints together the three steps of the -proof procedure: - -\begin{verbatim} -let initialpatt = put_pat mmk "(x,y:?1){<?1>x=y}+{~(<?1>x=y)}" -;; -let decideGralEquality g = - let (typ::_) = try (dest_somatch (pf_concl g) initialpatt) - with UserError ("somatch",_) -> - error "The goal does not have the expected form" in - let headtyp = hd_app (pf_compute g typ) in - let rectype = match (kind_of_term headtyp) with - IsMutInd _ -> headtyp - | _ -> error ("This decision procedure only" - " works for inductive objects") - in (tclTHEN mkBranches - (tclORELSE h_solveRightBranch (solveLeftBranch rectype))) g -;; -;; -\end{verbatim} - -The tactic above can be specialized in two different ways: either to -decide a particular instance $\{c_1=c_2\}+\{\neg c_1=c_2\}$ of the -universal quantification; or to eliminate this property and obtain two -subgoals containing the hypotheses $c_1=c_2$ and $\neg c_1=c_2$ -respectively. - -\begin{verbatim} -let decideGralEquality = - (tclTHEN mkBranches (tclORELSE h_solveRightBranch solveLeftBranch)) -;; -let decideEquality c1 c2 g = - let rectype = pf_type_of g c1 in - let decide = mkGenDecideEqGoal rectype g - in (tclTHENS (cut decide) [default_auto;decideGralEquality]) g -;; -let compare c1 c2 g = - let rectype = pf_type_of g c1 in - let decide = mkDecideEqGoal rectype c1 c2 g - in (tclTHENS (cut decide) - [(tclTHEN intro - (tclTHEN (tclLAST_HYP simplest_case) - clear_last)); - decideEquality c1 c2]) g -;; -\end{verbatim} - -Next, for each of the tactics that will have an entry in the grammar -we construct the associated dynamic one to be registered in the table -of tactics. This function can be used to overload a tactic name with -several similar tactics. For example, the tactic proving the general -decidability property and the one proving a particular instance for -two terms can be grouped together with the following convention: if -the user provides two terms as arguments, then the specialized tactic -is used; if no argument is provided then the general tactic is invoked. - -\begin{verbatim} -let dyn_decideEquality args g = - match args with - [(COMMAND com1);(COMMAND com2)] -> - let c1 = pf_constr_of_com g com1 - and c2 = pf_constr_of_com g com2 - in decideEquality c1 c2 g - | [] -> decideGralEquality g - | _ -> error "Invalid arguments for dynamic tactic" -;; -add_tactic "DecideEquality" dyn_decideEquality -;; - -let dyn_compare args g = - match args with - [(COMMAND com1);(COMMAND com2)] -> - let c1 = pf_constr_of_com g com1 - and c2 = pf_constr_of_com g com2 - in compare c1 c2 g - | _ -> error "Invalid arguments for dynamic tactic" -;; -add_tactic "Compare" tacargs_compare -;; -\end{verbatim} - -This completes the implementation of the tactic. We turn now to the -\Coq file \texttt{Eqdecide.v}. - - -\subsection{The Grammar Rules} - -Associated to the implementation of the tactic there is a \Coq\ file -containing the grammar and pretty-printing rules for the new tactic, -and the commands to generate an object module that can be then loaded -dynamically during a \Coq\ session. In order to generate an ML module, -the \Coq\ file must contain a -\texttt{Declare ML module} command for all the \ocaml{} files concerning -the implementation of the tactic --in our case there is only one file, -the file \texttt{eqdecide.ml}: - -\begin{verbatim} -Declare ML Module "eqdecide". -\end{verbatim} - -The following grammar and pretty-printing rules are -self-explanatory. We refer the reader to the Section \ref{Grammar} for -the details: - -\begin{verbatim} -Grammar tactic simple_tactic := - EqDecideRuleG1 - [ "Decide" "Equality" comarg($com1) comarg($com2)] -> - [(DecideEquality $com1 $com2)] -| EqDecideRuleG2 - [ "Decide" "Equality" ] -> - [(DecideEquality)] -| CompareRule - [ "Compare" comarg($com1) comarg($com2)] -> - [(Compare $com1 $com2)]. - -Syntax tactic level 0: - EqDecideRulePP1 - [(DecideEquality)] -> - ["Decide" "Equality"] -| EqDecideRulePP2 - [(DecideEquality $com1 $com2)] -> - ["Decide" "Equality" $com1 $com2] -| ComparePP - [(Compare $com1 $com2)] -> - ["Compare" $com1 $com2]. -\end{verbatim} - - -\paragraph{Important:} The names used to label the abstract syntax tree -in the grammar rules ---in this case ``DecideEquality'' and -``Compare''--- must be the same as the name used to register the -tactic in the tactics table. This is what makes the links between the -input entered by the user and the tactic executed by the interpreter. - -\subsection{Loading the Tactic} - -Once the module \texttt{EqDecide.v} has been compiled, the tactic can -be dynamically loaded using the \texttt{Require} command. - -\begin{coq_example} -Require EqDecide. -Goal (x,y:nat){x=y}+{~x=y}. -Decide Equality. -\end{coq_example} - -The implementation of the tactic can be accessed through the -tactical \texttt{Info}: -\begin{coq_example} -Undo. -Info Decide Equality. -\end{coq_example} -\begin{coq_eval} -Abort. -\end{coq_eval} - -Remark that the task performed by the tactic \texttt{solveRightBranch} -is not displayed, since we have chosen to hide its implementation. - -\section[Testing and Debugging your Tactic]{Testing and Debugging your Tactic\label{test-and-debug}} - -When your tactic does not behave as expected, it is possible to trace -it dynamically from \Coq. In order to do this, you have first to leave -the toplevel of \Coq, and come back to the \ocaml{} interpreter. This can -be done using the command \texttt{Drop} (see Section~\ref{Drop}). Once -in the \ocaml{} toplevel, load the file \texttt{tactics/include.ml}. -This file installs several pretty printers for proof trees, goals, -terms, abstract syntax trees, names, etc. It also contains the -function \texttt{go:unit -> unit} that enables to go back to \Coq's -toplevel. - -The modules \texttt{Tacmach} and \texttt{Pfedit} contain some basic -functions for extracting information from the state of the proof -engine. Such functions can be used to debug your tactic if -necessary. Let us mention here some of them: - -\begin{description} -\fun{val get\_pftreestate : unit -> pftreestate} - {Projects the current state of the proof engine.} -\fun{val proof\_of\_pftreestate : pftreestate -> proof} - {Projects the current state of the proof tree. A pretty-printer - displays it in a readable form. } -\fun{val top\_goal\_of\_pftreestate : pftreestate -> goal sigma} - {Projects the goal and the existential variables mapping from - the current state of the proof engine.} -\fun{val nth\_goal\_of\_pftreestate : int -> pftreestate -> goal sigma} - {Projects the goal and mapping corresponding to the $nth$ subgoal - that remains to be proven} -\fun{val traverse : int -> pftreestate -> pftreestate} - {Yields the children of the node that the current state of the - proof engine points to.} -\fun{val solve\_nth\_pftreestate : \\ \qquad -int -> tactic -> pftreestate -> pftreestate} - {\\ Provides the new state of the proof engine obtained applying - a given tactic to some unproven sub-goal.} -\end{description} - -Finally, the traditional \ocaml{} debugging tools like the directives -\texttt{trace} and \texttt{untrace} can be used to follow the -execution of your functions. Frequently, a better solution is to use -the \ocaml{} debugger, see Chapter \ref{Utilities}. - -\section[Concrete syntax for ML tactic and vernacular command]{Concrete syntax for ML tactic and vernacular command\label{Notations-for-ML-command}} - -\subsection{The general case} - -The standard way to bind an ML-written tactic or vernacular command to -a concrete {\Coq} syntax is to use the -\verb=TACTIC EXTEND= and \verb=VERNAC COMMAND EXTEND= macros. - -These macros can be used in any {\ocaml} file defining a (new) ML tactic -or vernacular command. They are expanded into pure {\ocaml} code by -the {\camlpppp} preprocessor of {\ocaml}. Concretely, files that use -these macros need to be compiled by giving to {\tt ocamlc} the option - -\verb=-pp "camlp4o -I $(COQTOP)/parsing grammar.cma pa_extend.cmo"= - -\noindent which is the default for every file compiled by means of a Makefile -generated by {\tt coq\_makefile} (see Chapter~\ref{Addoc-coqc}). So, -just do \verb=make= in this latter case. - -The syntax of the macros is given on figure -\ref{EXTEND-syntax}. They can be used at any place of an {\ocaml} -files where an ML sentence (called \verb=str_item= in the {\tt ocamlc} -parser) is expected. For each rule, the left-hand-side describes the -grammar production and the right-hand-side its interpretation which -must be an {\ocaml} expression. Each grammar production starts with -the concrete name of the tactic or command in {\Coq} and is followed -by arguments, possibly separated by terminal symbols or words. -Here is an example: - -\begin{verbatim} -TACTIC EXTEND Replace - [ "replace" constr(c1) "with" constr(c2) ] -> [ replace c1 c2 ] -END -\end{verbatim} - -\newcommand{\grule}{\textrm{\textsl{rule}}} -\newcommand{\stritem}{\textrm{\textsl{ocaml\_str\_item}}} -\newcommand{\camlexpr}{\textrm{\textsl{ocaml\_expr}}} -\newcommand{\arginfo}{\textrm{\textsl{argument\_infos}}} -\newcommand{\lident}{\textrm{\textsl{lower\_ident}}} -\newcommand{\argument}{\textrm{\textsl{argument}}} -\newcommand{\entry}{\textrm{\textsl{entry}}} -\newcommand{\argtype}{\textrm{\textsl{argtype}}} - -\begin{figure} -\begin{tabular}{|lcll|} -\hline -{\stritem} - & ::= & -\multicolumn{2}{l|}{{\tt TACTIC EXTEND} {\ident} \nelist{\grule}{$|$} {\tt END}}\\ - & $|$ & \multicolumn{2}{l|}{{\tt VERNAC COMMAND EXTEND} {\ident} \nelist{\grule}{$|$} {\tt END}}\\ -&&\multicolumn{2}{l|}{}\\ -{\grule} & ::= & -\multicolumn{2}{l|}{{\tt [} {\str} \sequence{\argument}{} {\tt ] -> [} {\camlexpr} {\tt ]}}\\ -&&\multicolumn{2}{l|}{}\\ -{\argument} & ::= & {\str} &\mbox{(terminal)}\\ - & $|$ & {\entry} {\tt (} {\lident} {\tt )} &\mbox{(non-terminal)}\\ -&&\multicolumn{2}{l|}{}\\ -{\entry} - & ::= & {\tt string} & (a string)\\ - & $|$ & {\tt preident} & (an identifier typed as a {\tt string})\\ - & $|$ & {\tt ident} & (an identifier of type {\tt identifier})\\ - & $|$ & {\tt global} & (a qualified identifier)\\ - & $|$ & {\tt constr} & (a {\Coq} term)\\ - & $|$ & {\tt openconstr} & (a {\Coq} term with holes)\\ - & $|$ & {\tt sort} & (a {\Coq} sort)\\ - & $|$ & {\tt tactic} & (an ${\cal L}_{tac}$ expression)\\ - & $|$ & {\tt constr\_with\_bindings} & (a {\Coq} term with a list of bindings\footnote{as for the tactics {\tt apply} and {\tt elim}})\\ - & $|$ & {\tt int\_or\_var} & (an integer or an identifier denoting an integer)\\ - & $|$ & {\tt quantified\_hypothesis} & (a quantified hypothesis\footnote{as for the tactics {\tt intros until}})\\ - & $|$ & {\tt {\entry}\_opt} & (an optional {\entry} )\\ - & $|$ & {\tt ne\_{\entry}\_list} & (a non empty list of {\entry})\\ - & $|$ & {\tt {\entry}\_list} & (a list of {\entry})\\ - & $|$ & {\tt bool} & (a boolean: no grammar rule, just for typing)\\ - & $|$ & {\lident} & (a user-defined entry)\\ -\hline -\end{tabular} -\caption{Syntax of the macros binding {\ocaml} tactics or commands to a {\Coq} syntax} -\label{EXTEND-syntax} -\end{figure} - -There is a set of predefined non-terminal entries which are -automatically translated into an {\ocaml} object of a given type. The -type is not the same for tactics and for vernacular commands. It is -given in the following table: - -\begin{small} -\noindent \begin{tabular}{|l|l|l|} -\hline -{\entry} & {\it type for tactics} & {\it type for commands} \\ -{\tt string} & {\tt string} & {\tt string}\\ -{\tt preident} & {\tt string} & {\tt string}\\ -{\tt ident} & {\tt identifier} & {\tt identifier}\\ -{\tt global} & {\tt global\_reference} & {\tt qualid}\\ -{\tt constr} & {\tt constr} & {\tt constr\_expr}\\ -{\tt openconstr} & {\tt open\_constr} & {\tt constr\_expr}\\ -{\tt sort} & {\tt sorts} & {\tt rawsort}\\ -{\tt tactic} & {\tt glob\_tactic\_expr * tactic} & {\tt raw\_tactic\_expr}\\ -{\tt constr\_with\_bindings} & {\tt constr with\_bindings} & {\tt constr\_expr with\_bindings}\\\\ -{\tt int\_or\_var} & {\tt int or\_var} & {\tt int or\_var}\\ -{\tt quantified\_hypothesis} & {\tt quantified\_hypothesis} & {\tt quantified\_hypothesis}\\ -{\tt {\entry}\_opt} & {\it the type of entry} {\tt option} & {\it the type of entry} {\tt option}\\ -{\tt ne\_{\entry}\_list} & {\it the type of entry} {\tt list} & {\it the type of entry} {\tt list}\\ -{\tt {\entry}\_list} & {\it the type of entry} {\tt list} & {\it the type of entry} {\tt list}\\ -{\tt bool} & {\tt bool} & {\tt bool}\\ -{\lident} & {user-provided, cf next section} & {user-provided, cf next section}\\ -\hline -\end{tabular} -\end{small} - -\bigskip - -Notice that {\entry} consists in a single identifier and that the {\tt -\_opt}, {\tt \_list}, ... modifiers are part of the identifier. -Here is now another example of a tactic which takes either a non empty -list of identifiers and executes the {\ocaml} function {\tt subst} or -takes no arguments and executes the{\ocaml} function {\tt subst\_all}. - -\begin{verbatim} -TACTIC EXTEND Subst -| [ "subst" ne_ident_list(l) ] -> [ subst l ] -| [ "subst" ] -> [ subst_all ] -END -\end{verbatim} - -\subsection{Adding grammar entries for tactic or command arguments} - -In case parsing the arguments of the tactic or the vernacular command -involves grammar entries other than the predefined entries listed -above, you have to declare a new entry using the macros -\verb=ARGUMENT EXTEND= or \verb=VERNAC ARGUMENT EXTEND=. The syntax is -given on Figure~\ref{ARGUMENT-EXTEND-syntax}. Notice that arguments -declared by \verb=ARGUMENT EXTEND= can be used for arguments of both -tactics and vernacular commands while arguments declared by -\verb=VERNAC ARGUMENT EXTEND= can only be used by vernacular commands. - -For \verb=VERNAC ARGUMENT EXTEND=, the identifier is the name of the -entry and it must be a valid {\ocaml} identifier (especially it must -be lowercase). The grammar rules works as before except that they do -not have to start by a terminal symbol or word. As an example, here -is how the {\Coq} {\tt Extraction Language {\it language}} parses its -argument: - -\begin{verbatim} -VERNAC ARGUMENT EXTEND language -| [ "Ocaml" ] -> [ Ocaml ] -| [ "Haskell" ] -> [ Haskell ] -| [ "Scheme" ] -> [ Scheme ] -END -\end{verbatim} - -For tactic arguments, and especially for \verb=ARGUMENT EXTEND=, the -procedure is more subtle because tactics are objects of the {\Coq} -environment which can be printed and interpreted. Then the syntax -requires extra information providing a printer and a type telling how -the argument behaves. Here is an example of entry parsing a pair of -optional {\Coq} terms. - -\begin{verbatim} -let pp_minus_div_arg pr_constr pr_tactic (omin,odiv) = - if omin=None && odiv=None then mt() else - spc() ++ str "with" ++ - pr_opt (fun c -> str "minus := " ++ pr_constr c) omin ++ - pr_opt (fun c -> str "div := " ++ pr_constr c) odiv - -ARGUMENT EXTEND minus_div_arg - TYPED AS constr_opt * constr_opt - PRINTED BY pp_minus_div_arg -| [ "with" minusarg(m) divarg_opt(d) ] -> [ Some m, d ] -| [ "with" divarg(d) minusarg_opt(m) ] -> [ m, Some d ] -| [ ] -> [ None, None ] -END -\end{verbatim} - -Notice that the type {\tt constr\_opt * constr\_opt} tells that the -object behaves as a pair of optional {\Coq} terms, i.e. as an object -of {\ocaml} type {\tt constr option * constr option} if in a -\verb=TACTIC EXTEND= macro and of type {\tt constr\_expr option * -constr\_expr option} if in a \verb=VERNAC COMMAND EXTEND= macro. - -As for the printer, it must be a function expecting a printer for -terms, a printer for tactics and returning a printer for the created -argument. Especially, each sub-{\term} and each sub-{\tac} in the -argument must be typed by the corresponding printers. Otherwise, the -{\ocaml} code will not be well-typed. - -\Rem The entry {\tt bool} is bound to no syntax but it can be used to -give the type of an argument as in the following example: - -\begin{verbatim} -let pr_orient _prc _prt = function - | true -> mt () - | false -> str " <-" - -ARGUMENT EXTEND orient TYPED AS bool PRINTED BY pr_orient -| [ "->" ] -> [ true ] -| [ "<-" ] -> [ false ] -| [ ] -> [ true ] -END -\end{verbatim} - -\begin{figure} -\begin{tabular}{|lcl|} -\hline -{\stritem} & ::= & - {\tt ARGUMENT EXTEND} {\ident} {\arginfo} {\nelist{\grule}{$|$}} {\tt END}\\ -& $|$ & {\tt VERNAC ARGUMENT EXTEND} {\ident} {\nelist{\grule}{$|$}} {\tt END}\\ -\\ -{\arginfo} & ::= & {\tt TYPED AS} {\argtype} \\ -&& {\tt PRINTED BY} {\lident} \\ -%&& \zeroone{{\tt INTERPRETED BY} {\lident}}\\ -%&& \zeroone{{\tt GLOBALIZED BY} {\lident}}\\ -%&& \zeroone{{\tt SUBSTITUTED BY} {\lident}}\\ -%&& \zeroone{{\tt RAW\_TYPED AS} {\lident} {\tt RAW\_PRINTED BY} {\lident}}\\ -%&& \zeroone{{\tt GLOB\_TYPED AS} {\lident} {\tt GLOB\_PRINTED BY} {\lident}}\\ -\\ -{\argtype} & ::= & {\argtype} {\tt *} {\argtype} \\ -& $|$ & {\entry} \\ -\hline -\end{tabular} -\caption{Syntax of the macros binding {\ocaml} tactics or commands to a {\Coq} syntax} -\label{ARGUMENT-EXTEND-syntax} -\end{figure} - -%\end{document} diff --git a/doc/refman/RefMan-uti.tex b/doc/refman/RefMan-uti.tex index f6371f8e5..ed41e3216 100644 --- a/doc/refman/RefMan-uti.tex +++ b/doc/refman/RefMan-uti.tex @@ -1,4 +1,5 @@ \chapter[Utilities]{Utilities\label{Utilities}} +%HEVEA\cutname{tools.html} The distribution provides utilities to simplify some tedious works beside proof development, tactics writing or documentation. diff --git a/doc/refman/Setoid.tex b/doc/refman/Setoid.tex index 0c8cd408f..b7b343112 100644 --- a/doc/refman/Setoid.tex +++ b/doc/refman/Setoid.tex @@ -1,6 +1,7 @@ \newtheorem{cscexample}{Example} \achapter{\protect{Generalized rewriting}} +%HEVEA\cutname{setoid.html} \aauthor{Matthieu Sozeau} \label{setoids} diff --git a/doc/refman/Universes.tex b/doc/refman/Universes.tex index 6ea253739..75fac9454 100644 --- a/doc/refman/Universes.tex +++ b/doc/refman/Universes.tex @@ -1,4 +1,5 @@ \achapter{Polymorphic Universes} +%HEVEA\cutname{universes.html} \aauthor{Matthieu Sozeau} \label{Universes-full} diff --git a/engine/evarutil.ml b/engine/evarutil.ml index 339c6a248..eabfb7b39 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -478,8 +478,6 @@ type clear_dependency_error = exception ClearDependencyError of Id.t * clear_dependency_error -let cleared = Store.field () - exception Depends of Id.t let rec check_and_clear_in_constr env evdref err ids global c = @@ -552,13 +550,6 @@ let rec check_and_clear_in_constr env evdref err ids global c = let evd = !evdref in let (evd,_) = restrict_evar evd evk filter None in evdref := evd; - (* spiwack: hacking session to mark the old [evk] as having been "cleared" *) - let evi = Evd.find !evdref evk in - let extra = evi.evar_extra in - let extra' = Store.set extra cleared true in - let evi' = { evi with evar_extra = extra' } in - evdref := Evd.add !evdref evk evi' ; - (* spiwack: /hacking session *) Evd.existential_value !evdref ev | _ -> map_constr (check_and_clear_in_constr env evdref err ids global) c @@ -665,11 +656,9 @@ let rec advance sigma evk = match evi.evar_body with | Evar_empty -> Some evk | Evar_defined v -> - if Option.default false (Store.get evi.evar_extra cleared) then - let (evk,_) = Term.destEvar v in - advance sigma evk - else - None + match is_restricted_evar evi with + | Some evk -> advance sigma evk + | None -> None (** The following functions return the set of undefined evars contained in the object, the defined evars being traversed. diff --git a/engine/evarutil.mli b/engine/evarutil.mli index 14173e774..ee0fae3d4 100644 --- a/engine/evarutil.mli +++ b/engine/evarutil.mli @@ -204,10 +204,6 @@ type clear_dependency_error = exception ClearDependencyError of Id.t * clear_dependency_error -(* spiwack: marks an evar that has been "defined" by clear. - used by [Goal] and (indirectly) [Proofview] to handle the clear tactic gracefully*) -val cleared : bool Store.field - val clear_hyps_in_evi : env -> evar_map ref -> named_context_val -> types -> Id.Set.t -> named_context_val * types diff --git a/engine/evd.ml b/engine/evd.ml index cfc9aa635..324f883e8 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -630,7 +630,9 @@ let evar_source evk d = (find d evk).evar_source let evar_ident evk evd = EvNames.ident evk evd.evar_names let evar_key id evd = EvNames.key id evd.evar_names -let define_aux def undef evk body = +let restricted = Store.field () + +let define_aux ?dorestrict def undef evk body = let oldinfo = try EvMap.find evk undef with Not_found -> @@ -640,7 +642,10 @@ let define_aux def undef evk body = anomaly ~label:"Evd.define" (Pp.str "cannot define undeclared evar.") in let () = assert (oldinfo.evar_body == Evar_empty) in - let newinfo = { oldinfo with evar_body = Evar_defined body } in + let evar_extra = match dorestrict with + | Some evk' -> Store.set oldinfo.evar_extra restricted evk' + | None -> oldinfo.evar_extra in + let newinfo = { oldinfo with evar_body = Evar_defined body; evar_extra } in EvMap.add evk newinfo def, EvMap.remove evk undef (* define the existential of section path sp as the constr body *) @@ -653,6 +658,9 @@ let define evk body evd = let evar_names = EvNames.remove_name_defined evk evd.evar_names in { evd with defn_evars; undf_evars; last_mods; evar_names } +let is_restricted_evar evi = + Store.get evi.evar_extra restricted + let restrict evk filter ?candidates ?src evd = let evk' = new_untyped_evar () in let evar_info = EvMap.find evk evd.undf_evars in @@ -667,7 +675,7 @@ let restrict evk filter ?candidates ?src evd = let ctxt = Filter.filter_list filter (evar_context evar_info) in let id_inst = Array.map_of_list (NamedDecl.get_id %> mkVar) ctxt in let body = mkEvar(evk',id_inst) in - let (defn_evars, undf_evars) = define_aux evd.defn_evars evd.undf_evars evk body in + let (defn_evars, undf_evars) = define_aux ~dorestrict:evk' evd.defn_evars evd.undf_evars evk body in { evd with undf_evars = EvMap.add evk' evar_info' undf_evars; defn_evars; last_mods; evar_names }, evk' @@ -748,7 +756,10 @@ let evar_universe_context d = d.universes let universe_context_set d = UState.context_set d.universes -let universe_context ?names evd = UState.universe_context ?names evd.universes +let universe_context ~names ~extensible evd = + UState.universe_context ~names ~extensible evd.universes + +let check_univ_decl evd decl = UState.check_univ_decl evd.universes decl let restrict_universe_context evd vars = { evd with universes = UState.restrict evd.universes vars } diff --git a/engine/evd.mli b/engine/evd.mli index 3f00a3b0b..9055dcc86 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -244,6 +244,9 @@ val restrict : evar -> Filter.t -> ?candidates:constr list -> (** Restrict an undefined evar into a new evar by filtering context and possibly limiting the instances to a set of candidates *) +val is_restricted_evar : evar_info -> evar option +(** Tell if an evar comes from restriction of another evar, and if yes, which *) + val downcast : evar -> types -> evar_map -> evar_map (** Change the type of an undefined evar to a new type assumed to be a subtype of its current type; subtyping must be ensured by caller *) @@ -493,7 +496,7 @@ val empty_evar_universe_context : evar_universe_context val union_evar_universe_context : evar_universe_context -> evar_universe_context -> evar_universe_context val evar_universe_context_subst : evar_universe_context -> Universes.universe_opt_subst -val constrain_variables : Univ.LSet.t -> evar_universe_context -> Univ.constraints +val constrain_variables : Univ.LSet.t -> evar_universe_context -> evar_universe_context val evar_universe_context_of_binders : @@ -547,11 +550,13 @@ val check_leq : evar_map -> Univ.universe -> Univ.universe -> bool val evar_universe_context : evar_map -> evar_universe_context val universe_context_set : evar_map -> Univ.universe_context_set -val universe_context : ?names:(Id.t located) list -> evar_map -> +val universe_context : names:(Id.t located) list -> extensible:bool -> evar_map -> (Id.t * Univ.Level.t) list * Univ.universe_context val universe_subst : evar_map -> Universes.universe_opt_subst val universes : evar_map -> UGraph.t +val check_univ_decl : evar_map -> UState.universe_decl -> + Universes.universe_binders * Univ.universe_context val merge_universe_context : evar_map -> evar_universe_context -> evar_map val set_universe_context : evar_map -> evar_universe_context -> evar_map diff --git a/engine/namegen.ml b/engine/namegen.ml index a75fe721f..2e62b8901 100644 --- a/engine/namegen.ml +++ b/engine/namegen.ml @@ -43,6 +43,8 @@ let default_non_dependent_ident = Id.of_string default_non_dependent_string let default_dependent_ident = Id.of_string "x" +let default_generated_non_letter_string = "x" + (**********************************************************************) (* Globality of identifiers *) @@ -107,7 +109,17 @@ let head_name sigma c = (* Find the head constant of a constr if any *) hdrec c let lowercase_first_char id = (* First character of a constr *) - Unicode.lowercase_first_char (Id.to_string id) + let s = Id.to_string id in + match Unicode.split_at_first_letter s with + | None -> + (* General case: nat -> n *) + Unicode.lowercase_first_char s + | Some (s,s') -> + if String.length s' = 0 then + (* No letter, e.g. __, or __'_, etc. *) + default_generated_non_letter_string + else + s ^ Unicode.lowercase_first_char s' let sort_hdchar = function | Prop(_) -> "P" @@ -239,7 +251,7 @@ let visible_ids sigma (nenv, c) = let next_name_away_in_cases_pattern sigma env_t na avoid = let id = match na with Name id -> id | Anonymous -> default_dependent_ident in let visible = visible_ids sigma env_t in - let bad id = Id.List.mem id avoid || is_constructor id + let bad id = Id.Set.mem id avoid || is_constructor id || Id.Set.mem id visible in next_ident_away_from id bad @@ -253,8 +265,8 @@ let next_name_away_in_cases_pattern sigma env_t na avoid = name is taken by finding a free subscript starting from 0 *) let next_ident_away_in_goal id avoid = - let id = if Id.List.mem id avoid then restart_subscript id else id in - let bad id = Id.List.mem id avoid || (is_global id && not (is_section_variable id)) in + let id = if Id.Set.mem id avoid then restart_subscript id else id in + let bad id = Id.Set.mem id avoid || (is_global id && not (is_section_variable id)) in next_ident_away_from id bad let next_name_away_in_goal na avoid = @@ -271,16 +283,16 @@ let next_name_away_in_goal na avoid = beyond the current subscript *) let next_global_ident_away id avoid = - let id = if Id.List.mem id avoid then restart_subscript id else id in - let bad id = Id.List.mem id avoid || is_global id in + let id = if Id.Set.mem id avoid then restart_subscript id else id in + let bad id = Id.Set.mem id avoid || is_global id in next_ident_away_from id bad (* 4- Looks for next fresh name outside a list; if name already used, looks for same name with lower available subscript *) let next_ident_away id avoid = - if Id.List.mem id avoid then - next_ident_away_from (restart_subscript id) (fun id -> Id.List.mem id avoid) + if Id.Set.mem id avoid then + next_ident_away_from (restart_subscript id) (fun id -> Id.Set.mem id avoid) else id let next_name_away_with_default default na avoid = @@ -302,7 +314,7 @@ let next_name_away = next_name_away_with_default default_non_dependent_string let make_all_name_different env sigma = (** FIXME: this is inefficient, but only used in printing *) - let avoid = ref (Id.Set.elements (Context.Named.to_vars (named_context env))) in + let avoid = ref (ids_of_named_context_val (named_context_val env)) in let sign = named_context_val env in let rels = rel_context env in let env0 = reset_with_named_context sign env in @@ -310,7 +322,7 @@ let make_all_name_different env sigma = (fun decl newenv -> let na = named_hd newenv sigma (RelDecl.get_type decl) (RelDecl.get_name decl) in let id = next_name_away na !avoid in - avoid := id::!avoid; + avoid := Id.Set.add id !avoid; push_rel (RelDecl.set_name (Name id) decl) newenv) rels ~init:env0 @@ -321,7 +333,7 @@ let make_all_name_different env sigma = let next_ident_away_for_default_printing sigma env_t id avoid = let visible = visible_ids sigma env_t in - let bad id = Id.List.mem id avoid || Id.Set.mem id visible in + let bad id = Id.Set.mem id avoid || Id.Set.mem id visible in next_ident_away_from id bad let next_name_away_for_default_printing sigma env_t na avoid = @@ -371,7 +383,7 @@ let compute_displayed_name_in sigma flags avoid na c = | _ -> let fresh_id = next_name_for_display sigma flags na avoid in let idopt = if noccurn sigma 1 c then Anonymous else Name fresh_id in - (idopt, fresh_id::avoid) + (idopt, Id.Set.add fresh_id avoid) let compute_and_force_displayed_name_in sigma flags avoid na c = match na with @@ -379,11 +391,11 @@ let compute_and_force_displayed_name_in sigma flags avoid na c = (Anonymous,avoid) | _ -> let fresh_id = next_name_for_display sigma flags na avoid in - (Name fresh_id, fresh_id::avoid) + (Name fresh_id, Id.Set.add fresh_id avoid) let compute_displayed_let_name_in sigma flags avoid na c = let fresh_id = next_name_for_display sigma flags na avoid in - (Name fresh_id, fresh_id::avoid) + (Name fresh_id, Id.Set.add fresh_id avoid) let rename_bound_vars_as_displayed sigma avoid env c = let rec rename avoid env c = diff --git a/engine/namegen.mli b/engine/namegen.mli index 14846a918..6fde90a39 100644 --- a/engine/namegen.mli +++ b/engine/namegen.mli @@ -72,23 +72,22 @@ val next_ident_away_from : Id.t -> (Id.t -> bool) -> Id.t the whole identifier except for the {i subscript}. E.g. if we take [foo42], then [42] is the {i subscript}, and [foo] is the root. *) -val next_ident_away : Id.t -> Id.t list -> Id.t +val next_ident_away : Id.t -> Id.Set.t -> Id.t (** Avoid clashing with a name already used in current module *) -val next_ident_away_in_goal : Id.t -> Id.t list -> Id.t +val next_ident_away_in_goal : Id.t -> Id.Set.t -> Id.t (** Avoid clashing with a name already used in current module but tolerate overwriting section variables, as in goals *) -val next_global_ident_away : Id.t -> Id.t list -> Id.t +val next_global_ident_away : Id.t -> Id.Set.t -> Id.t (** Default is [default_non_dependent_ident] *) -val next_name_away : Name.t -> Id.t list -> Id.t +val next_name_away : Name.t -> Id.Set.t -> Id.t -val next_name_away_with_default : string -> Name.t -> Id.t list -> - Id.t +val next_name_away_with_default : string -> Name.t -> Id.Set.t -> Id.t val next_name_away_with_default_using_types : string -> Name.t -> - Id.t list -> types -> Id.t + Id.Set.t -> types -> Id.t val set_reserved_typed_name : (types -> Name.t) -> unit @@ -103,13 +102,13 @@ type renaming_flags = val make_all_name_different : env -> evar_map -> env val compute_displayed_name_in : - evar_map -> renaming_flags -> Id.t list -> Name.t -> constr -> Name.t * Id.t list + evar_map -> renaming_flags -> Id.Set.t -> Name.t -> constr -> Name.t * Id.Set.t val compute_and_force_displayed_name_in : - evar_map -> renaming_flags -> Id.t list -> Name.t -> constr -> Name.t * Id.t list + evar_map -> renaming_flags -> Id.Set.t -> Name.t -> constr -> Name.t * Id.Set.t val compute_displayed_let_name_in : - evar_map -> renaming_flags -> Id.t list -> Name.t -> constr -> Name.t * Id.t list + evar_map -> renaming_flags -> Id.Set.t -> Name.t -> constr -> Name.t * Id.Set.t val rename_bound_vars_as_displayed : - evar_map -> Id.t list -> Name.t list -> types -> types + evar_map -> Id.Set.t -> Name.t list -> types -> types (**********************************************************************) (* Naming strategy for arguments in Prop when eliminating inductive types *) diff --git a/engine/proofview.ml b/engine/proofview.ml index eef2b83f4..598358c47 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -153,8 +153,12 @@ let focus i j sp = ( { sp with comb = new_comb } , context ) (** [undefined defs l] is the list of goals in [l] which are still - unsolved (after advancing cleared goals). *) -let undefined defs l = CList.map_filter (Evarutil.advance defs) l + unsolved (after advancing cleared goals). Note that order matters. *) +let undefined defs l = + List.fold_right (fun evk l -> + match Evarutil.advance defs evk with + | Some evk -> List.add_set Evar.equal evk l + | None -> l) l [] (** Unfocuses a proofview with respect to a context. *) let unfocus c sp = diff --git a/engine/termops.ml b/engine/termops.ml index e2bdf7238..b7fa2dc4a 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -1071,9 +1071,9 @@ let replace_term_gen sigma eq_fun c by_c in_t = let replace_term sigma c byc t = replace_term_gen sigma EConstr.eq_constr c byc t let vars_of_env env = - let s = - Context.Named.fold_outside (fun decl s -> Id.Set.add (NamedDecl.get_id decl) s) - (named_context env) ~init:Id.Set.empty in + let s = Environ.ids_of_named_context_val (Environ.named_context_val env) in + if List.is_empty (Environ.rel_context env) then s + else Context.Rel.fold_outside (fun decl s -> match RelDecl.get_name decl with Name id -> Id.Set.add id s | _ -> s) (rel_context env) ~init:s diff --git a/engine/uState.ml b/engine/uState.ml index 63bd247d5..13a9bb373 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -97,17 +97,9 @@ let subst ctx = ctx.uctx_univ_variables let ugraph ctx = ctx.uctx_universes -let algebraics ctx = ctx.uctx_univ_algebraic +let initial_graph ctx = ctx.uctx_initial_universes -let constrain_variables diff ctx = - Univ.LSet.fold - (fun l cstrs -> - try - match Univ.LMap.find l ctx.uctx_univ_variables with - | Some u -> Univ.Constraint.add (l, Univ.Eq, Option.get (Univ.Universe.level u)) cstrs - | None -> cstrs - with Not_found | Option.IsNone -> cstrs) - diff Univ.Constraint.empty +let algebraics ctx = ctx.uctx_univ_algebraic let add_uctx_names ?loc s l (names, names_rev) = (UNameMap.add s l names, Univ.LMap.add l { uname = Some s; uloc = loc } names_rev) @@ -240,6 +232,24 @@ let add_universe_constraints ctx cstrs = uctx_univ_variables = vars; uctx_universes = UGraph.merge_constraints local' ctx.uctx_universes } +let constrain_variables diff ctx = + let univs, local = ctx.uctx_local in + let univs, vars, local = + Univ.LSet.fold + (fun l (univs, vars, cstrs) -> + try + match Univ.LMap.find l vars with + | Some u -> + (Univ.LSet.add l univs, + Univ.LMap.remove l vars, + Univ.Constraint.add (l, Univ.Eq, Option.get (Univ.Universe.level u)) cstrs) + | None -> (univs, vars, cstrs) + with Not_found | Option.IsNone -> (univs, vars, cstrs)) + diff (univs, ctx.uctx_univ_variables, local) + in + { ctx with uctx_local = (univs, local); uctx_univ_variables = vars } + + let pr_uctx_level uctx = let map, map_rev = uctx.uctx_names in fun l -> @@ -247,41 +257,63 @@ let pr_uctx_level uctx = with Not_found | Option.IsNone -> Universes.pr_with_global_universes l -let universe_context ?names ctx = - match names with - | None -> [], Univ.ContextSet.to_context ctx.uctx_local - | Some pl -> - let levels = Univ.ContextSet.levels ctx.uctx_local in - let newinst, map, left = - List.fold_right - (fun (loc,id) (newinst, map, acc) -> - let l = - try UNameMap.find (Id.to_string id) (fst ctx.uctx_names) - with Not_found -> - user_err ?loc ~hdr:"universe_context" - (str"Universe " ++ Nameops.pr_id id ++ str" is not bound anymore.") - in (l :: newinst, (id, l) :: map, Univ.LSet.remove l acc)) - pl ([], [], levels) - in - if not (Univ.LSet.is_empty left) then - let n = Univ.LSet.cardinal left in - let loc = - try - let info = - Univ.LMap.find (Univ.LSet.choose left) (snd ctx.uctx_names) in - info.uloc - with Not_found -> None - in - user_err ?loc ~hdr:"universe_context" - ((str(CString.plural n "Universe") ++ spc () ++ - Univ.LSet.pr (pr_uctx_level ctx) left ++ - spc () ++ str (CString.conjugate_verb_to_be n) ++ - str" unbound.")) - else - let inst = Univ.Instance.of_array (Array.of_list newinst) in - let ctx = Univ.UContext.make (inst, - Univ.ContextSet.constraints ctx.uctx_local) - in map, ctx +type universe_decl = + (Names.Id.t Loc.located list, Univ.Constraint.t) Misctypes.gen_universe_decl + +let universe_context ~names ~extensible ctx = + let levels = Univ.ContextSet.levels ctx.uctx_local in + let newinst, left = + List.fold_right + (fun (loc,id) (newinst, acc) -> + let l = + try UNameMap.find (Id.to_string id) (fst ctx.uctx_names) + with Not_found -> + user_err ?loc ~hdr:"universe_context" + (str"Universe " ++ Nameops.pr_id id ++ str" is not bound anymore.") + in (l :: newinst, Univ.LSet.remove l acc)) + names ([], levels) + in + if not extensible && not (Univ.LSet.is_empty left) then + let n = Univ.LSet.cardinal left in + let loc = + try + let info = + Univ.LMap.find (Univ.LSet.choose left) (snd ctx.uctx_names) in + info.uloc + with Not_found -> None + in + user_err ?loc ~hdr:"universe_context" + ((str(CString.plural n "Universe") ++ spc () ++ + Univ.LSet.pr (pr_uctx_level ctx) left ++ + spc () ++ str (CString.conjugate_verb_to_be n) ++ + str" unbound.")) + else + let left = Univ.ContextSet.sort_levels (Array.of_list (Univ.LSet.elements left)) in + let inst = Array.append (Array.of_list newinst) left in + let inst = Univ.Instance.of_array inst in + let map = List.map (fun (s,l) -> Id.of_string s, l) (UNameMap.bindings (fst ctx.uctx_names)) in + let ctx = Univ.UContext.make (inst, + Univ.ContextSet.constraints ctx.uctx_local) in + map, ctx + +let check_implication uctx cstrs ctx = + let gr = initial_graph uctx in + let grext = UGraph.merge_constraints cstrs gr in + let cstrs' = Univ.UContext.constraints ctx in + if UGraph.check_constraints cstrs' grext then () + else CErrors.user_err ~hdr:"check_univ_decl" + (str "Universe constraints are not implied by the ones declared.") + +let check_univ_decl uctx decl = + let open Misctypes in + let pl, ctx = universe_context + ~names:decl.univdecl_instance + ~extensible:decl.univdecl_extensible_instance + uctx + in + if not decl.univdecl_extensible_constraints then + check_implication uctx decl.univdecl_constraints ctx; + pl, ctx let restrict ctx vars = let uctx' = Univops.restrict_universe_context ctx.uctx_local vars in diff --git a/engine/uState.mli b/engine/uState.mli index d198fbfbe..c44f2c1d7 100644 --- a/engine/uState.mli +++ b/engine/uState.mli @@ -44,6 +44,9 @@ val subst : t -> Universes.universe_opt_subst val ugraph : t -> UGraph.t (** The current graph extended with the local constraints *) +val initial_graph : t -> UGraph.t +(** The initial graph with just the declarations of new universes. *) + val algebraics : t -> Univ.LSet.t (** The subset of unification variables that can be instantiated with algebraic universes as they appear in inferred types only. *) @@ -105,7 +108,7 @@ val is_sort_variable : t -> Sorts.t -> Univ.Level.t option val normalize_variables : t -> Univ.universe_subst * t -val constrain_variables : Univ.LSet.t -> t -> Univ.constraints +val constrain_variables : Univ.LSet.t -> t -> t val abstract_undefined_variables : t -> t @@ -115,9 +118,26 @@ val refresh_undefined_univ_variables : t -> t * Univ.universe_level_subst val normalize : t -> t -(** {5 TODO: Document me} *) +(** [universe_context names extensible ctx] + + Return a universe context containing the local universes of [ctx] + and their constraints. The universes corresponding to [names] come + first in the order defined by that list. + + If [extensible] is false, check that the universes of [names] are + the only local universes. -val universe_context : ?names:(Id.t Loc.located) list -> t -> (Id.t * Univ.Level.t) list * Univ.universe_context + Also return the association list of universe names and universes + (including those not in [names]). *) +val universe_context : names:(Id.t Loc.located) list -> extensible:bool -> t -> + (Id.t * Univ.Level.t) list * Univ.universe_context + +type universe_decl = + (Names.Id.t Loc.located list, Univ.Constraint.t) Misctypes.gen_universe_decl + +val check_univ_decl : t -> universe_decl -> Universes.universe_binders * Univ.universe_context + +(** {5 TODO: Document me} *) val update_sigma_env : t -> Environ.env -> t diff --git a/engine/universes.ml b/engine/universes.ml index 686411e7d..7f5bf24b7 100644 --- a/engine/universes.ml +++ b/engine/universes.ml @@ -14,7 +14,7 @@ open Environ open Univ open Globnames -let pr_with_global_universes l = +let pr_with_global_universes l = try Nameops.pr_id (LMap.find l (snd (Global.global_universe_names ()))) with Not_found -> Level.pr l @@ -31,7 +31,7 @@ let universe_binders_of_global ref = let register_universe_binders ref l = universe_binders_table := Refmap.add ref l !universe_binders_table - + (* To disallow minimization to Set *) let set_minimization = ref true diff --git a/ide/coqOps.ml b/ide/coqOps.ml index 9be70e6d3..0dd08293c 100644 --- a/ide/coqOps.ml +++ b/ide/coqOps.ml @@ -480,8 +480,11 @@ object(self) | Message(lvl, loc, msg), Some (id,sentence) -> log_pp ?id Pp.(str "Msg " ++ msg); messages#push lvl msg + (* We do nothing here as for BZ#5583 *) + | Message(Error, loc, msg), None -> + log_pp Pp.(str "Error Msg without a sentence" ++ msg) | Message(lvl, loc, msg), None -> - log_pp Pp.(str "Msg " ++ msg); + log_pp Pp.(str "Msg without a sentence " ++ msg); messages#push lvl msg | InProgress n, _ -> if n < 0 then processed <- processed + abs n @@ -655,7 +658,7 @@ object(self) with Doc.Empty -> initial_state | Invalid_argument _ -> assert false in loop tip [] in Coq.bind fill_queue process_queue - + method join_document = let next = function | Good _ -> diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml index b11a11606..f00b1e142 100644 --- a/ide/ide_slave.ml +++ b/ide/ide_slave.ml @@ -413,6 +413,7 @@ let eval_call c = Interface.quit = (fun () -> quit := true); Interface.init = interruptible init; Interface.about = interruptible about; + Interface.wait = interruptible Stm.wait; Interface.interp = interruptible interp; Interface.handle_exn = handle_exn; Interface.stop_worker = Stm.stop_worker; diff --git a/ide/interface.mli b/ide/interface.mli index 1939a8427..a5d98946f 100644 --- a/ide/interface.mli +++ b/ide/interface.mli @@ -229,6 +229,9 @@ type print_ast_rty = Xml_datatype.xml type annotate_sty = string type annotate_rty = Xml_datatype.xml +type wait_sty = unit +type wait_rty = unit + type handler = { add : add_sty -> add_rty; edit_at : edit_at_sty -> edit_at_rty; @@ -248,6 +251,8 @@ type handler = { handle_exn : handle_exn_sty -> handle_exn_rty; init : init_sty -> init_rty; quit : quit_sty -> quit_rty; + (* for internal use (fake_id) only, do not use *) + wait : wait_sty -> wait_rty; (* Retrocompatibility stuff *) interp : interp_sty -> interp_rty; } diff --git a/ide/xmlprotocol.ml b/ide/xmlprotocol.ml index 4b521a968..b452b0a13 100644 --- a/ide/xmlprotocol.ml +++ b/ide/xmlprotocol.ml @@ -531,6 +531,7 @@ let set_options_sty_t : set_options_sty val_t = list_t (pair_t (list_t string_t) option_value_t) let mkcases_sty_t : mkcases_sty val_t = string_t let quit_sty_t : quit_sty val_t = unit_t +let wait_sty_t : wait_sty val_t = unit_t let about_sty_t : about_sty val_t = unit_t let init_sty_t : init_sty val_t = option_t string_t let interp_sty_t : interp_sty val_t = pair_t (pair_t bool_t bool_t) string_t @@ -555,6 +556,7 @@ let get_options_rty_t : get_options_rty val_t = let set_options_rty_t : set_options_rty val_t = unit_t let mkcases_rty_t : mkcases_rty val_t = list_t (list_t string_t) let quit_rty_t : quit_rty val_t = unit_t +let wait_rty_t : wait_rty val_t = unit_t let about_rty_t : about_rty val_t = coq_info_t let init_rty_t : init_rty val_t = state_id_t let interp_rty_t : interp_rty val_t = pair_t state_id_t (union_t string_t string_t) @@ -576,6 +578,7 @@ let calls = [| "SetOptions", ($)set_options_sty_t, ($)set_options_rty_t; "MkCases", ($)mkcases_sty_t, ($)mkcases_rty_t; "Quit", ($)quit_sty_t, ($)quit_rty_t; + "Wait", ($)wait_sty_t, ($)wait_rty_t; "About", ($)about_sty_t, ($)about_rty_t; "Init", ($)init_sty_t, ($)init_rty_t; "Interp", ($)interp_sty_t, ($)interp_rty_t; @@ -600,6 +603,8 @@ type 'a call = | About : about_sty -> about_rty call | Init : init_sty -> init_rty call | StopWorker : stop_worker_sty -> stop_worker_rty call + (* internal use (fake_ide) only, do not use *) + | Wait : wait_sty -> wait_rty call (* retrocompatibility *) | Interp : interp_sty -> interp_rty call | PrintAst : print_ast_sty -> print_ast_rty call @@ -618,12 +623,13 @@ let id_of_call : type a. a call -> int = function | SetOptions _ -> 9 | MkCases _ -> 10 | Quit _ -> 11 - | About _ -> 12 - | Init _ -> 13 - | Interp _ -> 14 - | StopWorker _ -> 15 - | PrintAst _ -> 16 - | Annotate _ -> 17 + | Wait _ -> 12 + | About _ -> 13 + | Init _ -> 14 + | Interp _ -> 15 + | StopWorker _ -> 16 + | PrintAst _ -> 17 + | Annotate _ -> 18 let str_of_call c = pi1 calls.(id_of_call c) @@ -643,6 +649,7 @@ let mkcases x : mkcases_rty call = MkCases x let search x : search_rty call = Search x let quit x : quit_rty call = Quit x let init x : init_rty call = Init x +let wait x : wait_rty call = Wait x let interp x : interp_rty call = Interp x let stop_worker x : stop_worker_rty call = StopWorker x let print_ast x : print_ast_rty call = PrintAst x @@ -664,6 +671,7 @@ let abstract_eval_call : type a. _ -> a call -> a value = fun handler c -> | SetOptions x -> mkGood (handler.set_options x) | MkCases x -> mkGood (handler.mkcases x) | Quit x -> mkGood (handler.quit x) + | Wait x -> mkGood (handler.wait x) | About x -> mkGood (handler.about x) | Init x -> mkGood (handler.init x) | Interp x -> mkGood (handler.interp x) @@ -688,6 +696,7 @@ let of_answer : type a. a call -> a value -> xml = function | SetOptions _ -> of_value (of_value_type set_options_rty_t) | MkCases _ -> of_value (of_value_type mkcases_rty_t ) | Quit _ -> of_value (of_value_type quit_rty_t ) + | Wait _ -> of_value (of_value_type wait_rty_t ) | About _ -> of_value (of_value_type about_rty_t ) | Init _ -> of_value (of_value_type init_rty_t ) | Interp _ -> of_value (of_value_type interp_rty_t ) @@ -711,6 +720,7 @@ let to_answer : type a. a call -> xml -> a value = function | SetOptions _ -> to_value (to_value_type set_options_rty_t) | MkCases _ -> to_value (to_value_type mkcases_rty_t ) | Quit _ -> to_value (to_value_type quit_rty_t ) + | Wait _ -> to_value (to_value_type wait_rty_t ) | About _ -> to_value (to_value_type about_rty_t ) | Init _ -> to_value (to_value_type init_rty_t ) | Interp _ -> to_value (to_value_type interp_rty_t ) @@ -733,6 +743,7 @@ let of_call : type a. a call -> xml = fun q -> | SetOptions x -> mkCall (of_value_type set_options_sty_t x) | MkCases x -> mkCall (of_value_type mkcases_sty_t x) | Quit x -> mkCall (of_value_type quit_sty_t x) + | Wait x -> mkCall (of_value_type wait_sty_t x) | About x -> mkCall (of_value_type about_sty_t x) | Init x -> mkCall (of_value_type init_sty_t x) | Interp x -> mkCall (of_value_type interp_sty_t x) @@ -756,6 +767,7 @@ let to_call : xml -> unknown_call = | "SetOptions" -> Unknown (SetOptions (mkCallArg set_options_sty_t a)) | "MkCases" -> Unknown (MkCases (mkCallArg mkcases_sty_t a)) | "Quit" -> Unknown (Quit (mkCallArg quit_sty_t a)) + | "Wait" -> Unknown (Wait (mkCallArg wait_sty_t a)) | "About" -> Unknown (About (mkCallArg about_sty_t a)) | "Init" -> Unknown (Init (mkCallArg init_sty_t a)) | "Interp" -> Unknown (Interp (mkCallArg interp_sty_t a)) @@ -786,6 +798,7 @@ let pr_full_value : type a. a call -> a value -> string = fun call value -> matc | SetOptions _ -> pr_value_gen (print set_options_rty_t) value | MkCases _ -> pr_value_gen (print mkcases_rty_t ) value | Quit _ -> pr_value_gen (print quit_rty_t ) value + | Wait _ -> pr_value_gen (print wait_rty_t ) value | About _ -> pr_value_gen (print about_rty_t ) value | Init _ -> pr_value_gen (print init_rty_t ) value | Interp _ -> pr_value_gen (print interp_rty_t ) value @@ -807,6 +820,7 @@ let pr_call : type a. a call -> string = fun call -> | SetOptions x -> return set_options_sty_t x | MkCases x -> return mkcases_sty_t x | Quit x -> return quit_sty_t x + | Wait x -> return wait_sty_t x | About x -> return about_sty_t x | Init x -> return init_sty_t x | Interp x -> return interp_sty_t x diff --git a/ide/xmlprotocol.mli b/ide/xmlprotocol.mli index d1c678b90..22117e35c 100644 --- a/ide/xmlprotocol.mli +++ b/ide/xmlprotocol.mli @@ -29,6 +29,8 @@ val set_options : set_options_sty -> set_options_rty call val quit : quit_sty -> quit_rty call val init : init_sty -> init_rty call val stop_worker : stop_worker_sty -> stop_worker_rty call +(* internal use (fake_ide) only, do not use *) +val wait : wait_sty -> wait_rty call (* retrocompatibility *) val interp : interp_sty -> interp_rty call val print_ast : print_ast_sty -> print_ast_rty call diff --git a/interp/constrextern.ml b/interp/constrextern.ml index f5eff693f..f1bee65ef 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -1087,7 +1087,7 @@ let extern_constr_gen lax goal_concl_style scopt env sigma t = (* Not "goal_concl_style" means do alpha-conversion avoiding only *) (* those goal/section/rel variables that occurs in the subterm under *) (* consideration; see namegen.ml for further details *) - let avoid = if goal_concl_style then ids_of_context env else [] in + let avoid = if goal_concl_style then vars_of_env env else Id.Set.empty in let r = Detyping.detype Detyping.Later ~lax:lax goal_concl_style avoid env sigma t in let vars = vars_of_env env in extern false (scopt,[]) vars r @@ -1099,14 +1099,14 @@ let extern_constr ?(lax=false) goal_concl_style env sigma t = extern_constr_gen lax goal_concl_style None env sigma t let extern_type goal_concl_style env sigma t = - let avoid = if goal_concl_style then ids_of_context env else [] in + let avoid = if goal_concl_style then vars_of_env env else Id.Set.empty in let r = Detyping.detype Detyping.Later goal_concl_style avoid env sigma t in extern_glob_type (vars_of_env env) r let extern_sort sigma s = extern_glob_sort (detype_sort sigma s) let extern_closed_glob ?lax goal_concl_style env sigma t = - let avoid = if goal_concl_style then ids_of_context env else [] in + let avoid = if goal_concl_style then vars_of_env env else Id.Set.empty in let r = Detyping.detype_closed_glob ?lax goal_concl_style avoid env sigma t in @@ -1177,15 +1177,15 @@ let rec glob_of_pat env sigma pat = DAst.make @@ match pat with | _ -> anomaly (Pp.str "PCase with non-trivial predicate but unknown inductive.") in GCases (RegularStyle,rtn,[glob_of_pat env sigma tm,indnames],mat) - | PFix f -> DAst.get (Detyping.detype_names false [] env (Global.env()) sigma (EConstr.of_constr (mkFix f))) (** FIXME bad env *) - | PCoFix c -> DAst.get (Detyping.detype_names false [] env (Global.env()) sigma (EConstr.of_constr (mkCoFix c))) + | PFix f -> DAst.get (Detyping.detype_names false Id.Set.empty env (Global.env()) sigma (EConstr.of_constr (mkFix f))) (** FIXME bad env *) + | PCoFix c -> DAst.get (Detyping.detype_names false Id.Set.empty env (Global.env()) sigma (EConstr.of_constr (mkCoFix c))) | PSort s -> GSort s let extern_constr_pattern env sigma pat = extern true (None,[]) Id.Set.empty (glob_of_pat env sigma pat) let extern_rel_context where env sigma sign = - let a = detype_rel_context Detyping.Later where [] (names_of_rel_context env,env) sigma sign in + let a = detype_rel_context Detyping.Later where Id.Set.empty (names_of_rel_context env,env) sigma sign in let vars = vars_of_env env in let a = List.map (extended_glob_local_binder_of_decl) a in pi3 (extern_local_binder (None,[]) vars a) diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 6f7c6c827..1cea307d7 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -469,8 +469,7 @@ let intern_local_binder_aux ?(global_level=false) intern lvar (env,bl) = functio | _ -> assert false in let env = {env with ids = List.fold_right Id.Set.add il env.ids} in - let ienv = Id.Set.elements env.ids in - let id = Namegen.next_ident_away (Id.of_string "pat") ienv in + let id = Namegen.next_ident_away (Id.of_string "pat") env.ids in let na = (loc, Name id) in let bk = Default Explicit in let _, bl' = intern_assumption intern lvar env [na] bk tyc in @@ -1939,13 +1938,13 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = | _ -> let fresh = Namegen.next_name_away_with_default_using_types "iV" cano_name forbidden_names (EConstr.of_constr ty) in - canonize_args t tt (fresh::forbidden_names) + canonize_args t tt (Id.Set.add fresh forbidden_names) ((fresh,c)::match_acc) ((cases_pattern_loc c,Name fresh)::var_acc) end | _ -> assert false in let _,args_rel = List.chop nparams (List.rev mip.Declarations.mind_arity_ctxt) in - canonize_args args_rel l (Id.Set.elements forbidden_names_for_gen) [] [] in + canonize_args args_rel l forbidden_names_for_gen [] [] in match_to_do, Some (cases_pattern_expr_loc t,(ind,List.rev_map snd nal)) | None -> [], None in diff --git a/interp/dumpglob.mli b/interp/dumpglob.mli index 054e43e7c..afcd7a2ed 100644 --- a/interp/dumpglob.mli +++ b/interp/dumpglob.mli @@ -37,7 +37,7 @@ val dump_notation : (Constrexpr.notation * Notation.notation_location) Loc.located -> Notation_term.scope_name option -> bool -> unit val dump_constraint : - Constrexpr.typeclass_constraint -> bool -> string -> unit + Vernacexpr.typeclass_constraint -> bool -> string -> unit val dump_string : string -> unit diff --git a/interp/impargs.ml b/interp/impargs.ml index d8241c044..09a0ba83c 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -255,7 +255,7 @@ let compute_implicits_gen strict strongly_strict revpat contextual all env t = in match kind_of_term (whd_all env t) with | Prod (na,a,b) -> - let na',avoid = find_displayed_name_in all [] na ([],b) in + let na',avoid = find_displayed_name_in all Id.Set.empty na ([],b) in let v = aux (push_rel (LocalAssum (na',a)) env) avoid 1 [na'] b in !rigid, Array.to_list v | _ -> true, [] diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index 3d48114ec..0967d21f0 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -577,7 +577,7 @@ let rec subst_notation_constr subst bound raw = if r1' == r1 && k' == k then raw else NCast(r1',k') let subst_interpretation subst (metas,pat) = - let bound = List.map fst metas in + let bound = List.fold_left (fun accu (id, _) -> Id.Set.add id accu) Id.Set.empty metas in (metas,subst_notation_constr subst bound pat) (**********************************************************************) @@ -1143,7 +1143,7 @@ let rec match_ inner u alp metas sigma a1 a2 = to print "{x:_ & P x}" knowing that notation "{x & P x}" is not defined. *) | _b1, NLambda (Name id as na,(NHole _ | NVar _ as t2),b2) when inner -> let avoid = - free_glob_vars a1 @ (* as in Namegen: *) glob_visible_short_qualid a1 in + Id.Set.union (free_glob_vars a1) (* as in Namegen: *) (glob_visible_short_qualid a1) in let id' = Namegen.next_ident_away id avoid in let t1 = DAst.make @@ GHole(Evar_kinds.BinderType (Name id'),Misctypes.IntroAnonymous,None) in let sigma = match t2 with diff --git a/interp/ppextend.ml b/interp/ppextend.ml index 3ebc9b71d..ce19dd8a9 100644 --- a/interp/ppextend.ml +++ b/interp/ppextend.ml @@ -36,5 +36,5 @@ type unparsing = | UnpListMetaVar of int * parenRelation * unparsing list | UnpBinderListMetaVar of int * bool * unparsing list | UnpTerminal of string - | UnpBox of ppbox * unparsing list + | UnpBox of ppbox * unparsing Loc.located list | UnpCut of ppcut diff --git a/interp/ppextend.mli b/interp/ppextend.mli index 6ff5a4272..7b62a2074 100644 --- a/interp/ppextend.mli +++ b/interp/ppextend.mli @@ -29,5 +29,5 @@ type unparsing = | UnpListMetaVar of int * parenRelation * unparsing list | UnpBinderListMetaVar of int * bool * unparsing list | UnpTerminal of string - | UnpBox of ppbox * unparsing list + | UnpBox of ppbox * unparsing Loc.located list | UnpCut of ppcut diff --git a/interp/reserve.ml b/interp/reserve.ml index a1e5bd0ea..dc0f60dcf 100644 --- a/interp/reserve.ml +++ b/interp/reserve.ml @@ -110,7 +110,7 @@ let revert_reserved_type t = let t = EConstr.Unsafe.to_constr t in let reserved = KeyMap.find (constr_key t) !reserve_revtable in let t = EConstr.of_constr t in - let t = Detyping.detype Detyping.Now false [] (Global.env()) Evd.empty t in + let t = Detyping.detype Detyping.Now false Id.Set.empty (Global.env()) Evd.empty t in (* pedrot: if [Notation_ops.match_notation_constr] may raise [Failure _] then I've introduced a bug... *) let filter _ pat = diff --git a/intf/constrexpr.ml b/intf/constrexpr.ml index 413cd9704..8eadafe66 100644 --- a/intf/constrexpr.ml +++ b/intf/constrexpr.ml @@ -132,10 +132,6 @@ and constr_notation_substitution = constr_expr list list * (** for recursive notations *) local_binder_expr list list (** for binders subexpressions *) -type typeclass_constraint = (Name.t Loc.located * Id.t Loc.located list option) * binding_kind * constr_expr - -and typeclass_context = typeclass_constraint list - type constr_pattern_expr = constr_expr (** Concrete syntax for modules and module types *) diff --git a/intf/misctypes.ml b/intf/misctypes.ml index 807882b42..8b7073143 100644 --- a/intf/misctypes.ml +++ b/intf/misctypes.ml @@ -53,6 +53,7 @@ type level_info = Name.t Loc.located option type glob_sort = sort_info glob_sort_gen type glob_level = level_info glob_sort_gen +type glob_constraint = glob_level * Univ.constraint_type * glob_level (** A synonym of [Evar.t], also defined in Term *) @@ -136,3 +137,9 @@ type inversion_kind = | SimpleInversion | FullInversion | FullInversionClear + +type ('a, 'b) gen_universe_decl = { + univdecl_instance : 'a; (* Declared universes *) + univdecl_extensible_instance : bool; (* Can new universes be added *) + univdecl_constraints : 'b; (* Declared constraints *) + univdecl_extensible_constraints : bool (* Can new constraints be added *) } diff --git a/intf/vernacexpr.ml b/intf/vernacexpr.ml index 94e166f92..03e8ea43d 100644 --- a/intf/vernacexpr.ml +++ b/intf/vernacexpr.ml @@ -139,8 +139,7 @@ type search_restriction = type rec_flag = bool (* true = Rec; false = NoRec *) type verbose_flag = bool (* true = Verbose; false = Silent *) - (* list of idents for qed exporting *) -type opacity_flag = Opaque of lident list option | Transparent +type opacity_flag = Opaque | Transparent type coercion_flag = bool (* true = AddCoercion false = NoCoercion *) type instance_flag = bool option (* Some true = Backward instance; Some false = Forward instance, None = NoInstance *) @@ -166,8 +165,11 @@ type option_ref_value = | StringRefValue of string | QualidRefValue of reference -(** Identifier and optional list of bound universes. *) -type plident = lident * lident list option +(** Identifier and optional list of bound universes and constraints. *) + +type universe_decl_expr = (Id.t Loc.located list, glob_constraint list) gen_universe_decl + +type ident_decl = lident * universe_decl_expr option type sort_expr = Sorts.family @@ -177,10 +179,10 @@ type definition_expr = * constr_expr option type fixpoint_expr = - plident * (Id.t located option * recursion_order_expr) * local_binder_expr list * constr_expr * constr_expr option + ident_decl * (Id.t located option * recursion_order_expr) * local_binder_expr list * constr_expr * constr_expr option type cofixpoint_expr = - plident * local_binder_expr list * constr_expr * constr_expr option + ident_decl * local_binder_expr list * constr_expr * constr_expr option type local_decl_expr = | AssumExpr of lname * constr_expr @@ -199,14 +201,18 @@ type constructor_list_or_record_decl_expr = | Constructors of constructor_expr list | RecordDecl of lident option * local_decl_expr with_instance with_priority with_notation list type inductive_expr = - plident with_coercion * local_binder_expr list * constr_expr option * inductive_kind * + ident_decl with_coercion * local_binder_expr list * constr_expr option * inductive_kind * constructor_list_or_record_decl_expr type one_inductive_expr = - plident * local_binder_expr list * constr_expr option * constructor_expr list + ident_decl * local_binder_expr list * constr_expr option * constructor_expr list + +type typeclass_constraint = (Name.t Loc.located * universe_decl_expr option) * binding_kind * constr_expr + +and typeclass_context = typeclass_constraint list type proof_expr = - plident option * (local_binder_expr list * constr_expr) + ident_decl option * (local_binder_expr list * constr_expr) type syntax_modifier = | SetItemLevel of string list * Extend.production_level @@ -280,11 +286,6 @@ type bullet = | Star of int | Plus of int -(** {6 Types concerning Stm} *) -type stm_vernac = - | JoinDocument - | Wait - (** {6 Types concerning the module layer} *) (** Rigid / flexible module signature *) @@ -338,12 +339,12 @@ type vernac_expr = (* Gallina *) | VernacDefinition of - (locality option * definition_object_kind) * plident * definition_expr + (locality option * definition_object_kind) * ident_decl * definition_expr | VernacStartTheoremProof of theorem_kind * proof_expr list | VernacEndProof of proof_end | VernacExactProof of constr_expr | VernacAssumption of (locality option * assumption_object_kind) * - inline * (plident list * constr_expr) with_coercion list + inline * (ident_decl list * constr_expr) with_coercion list | VernacInductive of cumulative_inductive_parsing_flag * private_flag * inductive_flag * (inductive_expr * decl_notation list) list | VernacFixpoint of locality option * (fixpoint_expr * decl_notation list) list @@ -352,7 +353,7 @@ type vernac_expr = | VernacScheme of (lident option * scheme) list | VernacCombinedScheme of lident * lident list | VernacUniverse of lident list - | VernacConstraint of (glob_level * Univ.constraint_type * glob_level) list + | VernacConstraint of glob_constraint list (* Gallina extensions *) | VernacBeginSection of lident @@ -450,10 +451,6 @@ type vernac_expr = | VernacRegister of lident * register_kind | VernacComments of comment list - (* Stm backdoor: used in fake_id, will be removed when fake_ide - becomes aware of feedback about completed jobs. *) - | VernacStm of stm_vernac - (* Proof management *) | VernacGoal of constr_expr | VernacAbort of lident option @@ -504,16 +501,12 @@ type vernac_type = | VtProofStep of proof_step | VtProofMode of string | VtQuery of vernac_part_of_script * Feedback.route_id - | VtStm of vernac_control * vernac_part_of_script + | VtBack of vernac_part_of_script * Stateid.t | VtUnknown and vernac_qed_type = VtKeep | VtKeepAsAxiom | VtDrop (* Qed/Admitted, Abort *) and vernac_start = string * opacity_guarantee * Id.t list and vernac_sideff_type = Id.t list and vernac_part_of_script = bool -and vernac_control = - | VtWait - | VtJoinDocument - | VtBack of Stateid.t and opacity_guarantee = | GuaranteesOpacity (** Only generates opaque terms at [Qed] *) | Doesn'tGuaranteeOpacity (** May generate transparent terms even with [Qed].*) diff --git a/kernel/environ.ml b/kernel/environ.ml index 621a9931d..c3fd8962e 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -101,6 +101,8 @@ let fold_rel_context f env ~init = let named_context_of_val c = c.env_named_ctx +let ids_of_named_context_val c = Id.Map.domain c.env_named_map + (* [map_named_val f ctxt] apply [f] to the body and the type of each declarations. *** /!\ *** [f t] should be convertible with t *) diff --git a/kernel/environ.mli b/kernel/environ.mli index 377c61de2..2667ad7ca 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -80,6 +80,7 @@ val fold_rel_context : val named_context_of_val : named_context_val -> Context.Named.t val val_of_named_context : Context.Named.t -> named_context_val val empty_named_context_val : named_context_val +val ids_of_named_context_val : named_context_val -> Id.Set.t (** [map_named_val f ctxt] apply [f] to the body and the type of diff --git a/kernel/univ.mli b/kernel/univ.mli index a4f2e26b6..94116e473 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -411,6 +411,7 @@ sig val add_instance : Instance.t -> t -> t (** Arbitrary choice of linear order of the variables *) + val sort_levels : Level.t array -> Level.t array val to_context : t -> universe_context val of_context : universe_context -> t diff --git a/lib/cWarnings.ml b/lib/cWarnings.ml index ff7145267..3699b1c61 100644 --- a/lib/cWarnings.ml +++ b/lib/cWarnings.ml @@ -93,8 +93,12 @@ let split_flags s = "all" flag, and reverses the list. *) let rec cut_before_all_rev acc = function | [] -> acc - | (_status,name as w) :: warnings -> - cut_before_all_rev (w :: if is_all_keyword name then [] else acc) warnings + | (status,name as w) :: warnings -> + let acc = + if is_all_keyword name then [w] + else if is_none_keyword name then [(Disabled,"all")] + else w :: acc in + cut_before_all_rev acc warnings let cut_before_all_rev warnings = cut_before_all_rev [] warnings diff --git a/lib/coqProject_file.ml4 b/lib/coqProject_file.ml4 index 13de731f5..970666638 100644 --- a/lib/coqProject_file.ml4 +++ b/lib/coqProject_file.ml4 @@ -206,7 +206,7 @@ let rec find_project_file ~from ~projfile_name = if Sys.file_exists fname then Some fname else let newdir = Filename.dirname from in - if newdir = "" || newdir = "/" then None + if newdir = from then None else find_project_file ~from:newdir ~projfile_name ;; diff --git a/lib/envars.ml b/lib/envars.ml index 68604ae6c..206d75033 100644 --- a/lib/envars.ml +++ b/lib/envars.ml @@ -213,6 +213,7 @@ let print_config ?(prefix_var_name="") f coq_src_subdirs = fprintf f "%sCAMLP4BIN=%s/\n" prefix_var_name (camlp4bin ()); fprintf f "%sCAMLP4LIB=%s\n" prefix_var_name (camlp4lib ()); fprintf f "%sCAMLP4OPTIONS=%s\n" prefix_var_name Coq_config.camlp4compat; + fprintf f "%sCAMLFLAGS=%s\n" prefix_var_name Coq_config.caml_flags; fprintf f "%sHASNATDYNLINK=%s\n" prefix_var_name (if Coq_config.has_natdynlink then "true" else "false"); fprintf f "%sCOQ_SRC_SUBDIRS=%s\n" prefix_var_name (String.concat " " coq_src_subdirs) diff --git a/lib/loc.ml b/lib/loc.ml index 06da13d44..4a935a9d9 100644 --- a/lib/loc.ml +++ b/lib/loc.ml @@ -62,6 +62,8 @@ let merge_opt l1 l2 = match l1, l2 with let unloc loc = (loc.bp, loc.ep) +let shift_loc kb kp loc = { loc with bp = loc.bp + kb ; ep = loc.ep + kp } + (** Located type *) type 'a located = t option * 'a diff --git a/lib/loc.mli b/lib/loc.mli index d4061e044..fde490cc8 100644 --- a/lib/loc.mli +++ b/lib/loc.mli @@ -40,6 +40,11 @@ val merge : t -> t -> t val merge_opt : t option -> t option -> t option (** Merge locations, usually generating the largest possible span *) +val shift_loc : int -> int -> t -> t +(** [shift_loc loc n p] shifts the beginning of location by [n] and + the end by [p]; it is assumed that the shifts do not change the + lines at which the location starts and ends *) + (** {5 Located exceptions} *) val add_loc : Exninfo.info -> t -> Exninfo.info @@ -82,10 +82,21 @@ let utf8_length s = done ; !cnt -let app s1 s2 = match s1, s2 with - | Ppcmd_empty, s - | s, Ppcmd_empty -> s - | s1, s2 -> Ppcmd_glue [s1; s2] +let rec app d1 d2 = match d1, d2 with + | Ppcmd_empty, d + | d, Ppcmd_empty -> d + + (* Optimizations *) + | Ppcmd_glue [l1;l2], Ppcmd_glue l3 -> Ppcmd_glue (l1 :: l2 :: l3) + | Ppcmd_glue [l1;l2], d2 -> Ppcmd_glue [l1 ; l2 ; d2] + | d1, Ppcmd_glue l2 -> Ppcmd_glue (d1 :: l2) + + | Ppcmd_tag(t1,d1), Ppcmd_tag(t2,d2) + when t1 = t2 -> Ppcmd_tag(t1,app d1 d2) + | d1, d2 -> Ppcmd_glue [d1; d2] + (* Optimizations deemed too costly *) + (* | Ppcmd_glue l1, Ppcmd_glue l2 -> Ppcmd_glue (l1 @ l2) *) + (* | Ppcmd_string s1, Ppcmd_string s2 -> Ppcmd_string (s1 ^ s2) *) let seq s = Ppcmd_glue s diff --git a/lib/system.ml b/lib/system.ml index 12eacf2ea..0b64b237d 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -52,7 +52,7 @@ let dirmap = ref StrMap.empty let make_dir_table dir = let filter_dotfiles s f = if f.[0] = '.' then s else StrSet.add f s in - Array.fold_left filter_dotfiles StrSet.empty (readdir dir) + Array.fold_left filter_dotfiles StrSet.empty (Sys.readdir dir) let exists_in_dir_respecting_case dir bf = let cache_dir dir = diff --git a/lib/unicode.ml b/lib/unicode.ml index 959ccaf73..f193c4e0f 100644 --- a/lib/unicode.ml +++ b/lib/unicode.ml @@ -8,13 +8,14 @@ (** Unicode utilities *) -type status = Letter | IdentPart | Symbol | Unknown +type status = Letter | IdentPart | Symbol | IdentSep | Unknown (* The following table stores classes of Unicode characters that - are used by the lexer. There are 3 different classes so 2 bits are - allocated for each character. We only use 16 bits over the 31 bits - to simplify the masking process. (This choice seems to be a good - trade-off between speed and space after some benchmarks.) *) + are used by the lexer. There are 5 different classes so 3 bits + are allocated for each character. We encode the masks of 8 + characters per word, thus using 24 bits over the 31 available + bits. (This choice seems to be a good trade-off between speed + and space after some benchmarks.) *) (* A 256 KiB table, initially filled with zeros. *) let table = Array.make (1 lsl 17) 0 @@ -24,14 +25,15 @@ let table = Array.make (1 lsl 17) 0 define the position of the pattern in the word. Notice that pattern "00" means "undefined". *) let mask i = function - | Letter -> 1 lsl ((i land 7) lsl 1) (* 01 *) - | IdentPart -> 2 lsl ((i land 7) lsl 1) (* 10 *) - | Symbol -> 3 lsl ((i land 7) lsl 1) (* 11 *) - | Unknown -> 0 lsl ((i land 7) lsl 1) (* 00 *) + | Letter -> 1 lsl ((i land 7) * 3) (* 001 *) + | IdentPart -> 2 lsl ((i land 7) * 3) (* 010 *) + | Symbol -> 3 lsl ((i land 7) * 3) (* 011 *) + | IdentSep -> 4 lsl ((i land 7) * 3) (* 100 *) + | Unknown -> 0 lsl ((i land 7) * 3) (* 000 *) -(* Helper to reset 2 bits in a word. *) +(* Helper to reset 3 bits in a word. *) let reset_mask i = - lnot (3 lsl ((i land 7) lsl 1)) + lnot (7 lsl ((i land 7) * 3)) (* Initialize the lookup table from a list of segments, assigning a status to every character of each segment. The order of these @@ -50,13 +52,14 @@ let mk_lookup_table_from_unicode_tables_for status tables = (* Look up into the table and interpret the found pattern. *) let lookup x = - let v = (table.(x lsr 3) lsr ((x land 7) lsl 1)) land 3 in + let v = (table.(x lsr 3) lsr ((x land 7) * 3)) land 7 in if v = 1 then Letter else if v = 2 then IdentPart else if v = 3 then Symbol + else if v = 4 then IdentSep else Unknown -(* [classify] discriminates between 3 different kinds of +(* [classify] discriminates between 5 different kinds of symbols based on the standard unicode classification (extracted from Camomile). *) let classify = @@ -67,13 +70,13 @@ let classify = Unicodetable.sm; (* Symbol, maths. *) Unicodetable.sc; (* Symbol, currency. *) Unicodetable.so; (* Symbol, modifier. *) - Unicodetable.pd; (* Punctation, dash. *) - Unicodetable.pc; (* Punctation, connector. *) - Unicodetable.pe; (* Punctation, open. *) - Unicodetable.ps; (* Punctation, close. *) - Unicodetable.pi; (* Punctation, initial quote. *) - Unicodetable.pf; (* Punctation, final quote. *) - Unicodetable.po; (* Punctation, other. *) + Unicodetable.pd; (* Punctuation, dash. *) + Unicodetable.pc; (* Punctuation, connector. *) + Unicodetable.pe; (* Punctuation, open. *) + Unicodetable.ps; (* Punctution, close. *) + Unicodetable.pi; (* Punctuation, initial quote. *) + Unicodetable.pf; (* Punctuation, final quote. *) + Unicodetable.po; (* Punctuation, other. *) ]; mk_lookup_table_from_unicode_tables_for Letter [ @@ -107,14 +110,14 @@ let classify = [(0x02074, 0x02079)]; (* Superscript 4-9. *) single 0x0002E; (* Dot. *) ]; - mk_lookup_table_from_unicode_tables_for Letter + mk_lookup_table_from_unicode_tables_for IdentSep [ single 0x005F; (* Underscore. *) single 0x00A0; (* Non breaking space. *) ]; mk_lookup_table_from_unicode_tables_for IdentPart [ - single 0x0027; (* Special space. *) + single 0x0027; (* Single quote. *) ]; (* Lookup *) lookup @@ -163,24 +166,75 @@ let is_utf8 s = in try check 0 with End_of_input -> true | Invalid_argument _ -> false +(* Escape string if it contains non-utf8 characters *) + +let escaped_non_utf8 s = + let mk_escape x = Printf.sprintf "%%%X" x in + let buff = Buffer.create (String.length s * 3) in + let rec process_trailing_aux i j = + if i = j then i else + match String.unsafe_get s i with + | '\128'..'\191' -> process_trailing_aux (i+1) j + | _ -> i in + let process_trailing i n = + let j = if i+n-1 >= String.length s then i+1 else process_trailing_aux (i+1) (i+n) in + (if j = i+n then + Buffer.add_string buff (String.sub s i n) + else + let v = Array.init (j-i) (fun k -> mk_escape (Char.code s.[i+k])) in + Buffer.add_string buff (String.concat "" (Array.to_list v))); + j in + let rec process i = + if i >= String.length s then Buffer.contents buff else + let c = String.unsafe_get s i in + match c with + | '\000'..'\127' -> Buffer.add_char buff c; process (i+1) + | '\128'..'\191' | '\248'..'\255' -> Buffer.add_string buff (mk_escape (Char.code c)); process (i+1) + | '\192'..'\223' -> process (process_trailing i 2) + | '\224'..'\239' -> process (process_trailing i 3) + | '\240'..'\247' -> process (process_trailing i 4) + in + process 0 + +let escaped_if_non_utf8 s = + if is_utf8 s then s else escaped_non_utf8 s + (* Check the well-formedness of an identifier *) +let is_valid_ident_initial = function + | Letter | IdentSep -> true + | IdentPart | Symbol | Unknown -> false + let initial_refutation j n s = - match classify n with - | Letter -> None - | _ -> + if is_valid_ident_initial (classify n) then None + else let c = String.sub s 0 j in Some (false, "Invalid character '"^c^"' at beginning of identifier \""^s^"\".") +let is_valid_ident_trailing = function + | Letter | IdentSep | IdentPart -> true + | Symbol | Unknown -> false + let trailing_refutation i j n s = - match classify n with - | Letter | IdentPart -> None - | _ -> + if is_valid_ident_trailing (classify n) then None + else let c = String.sub s i j in Some (false, "Invalid character '"^c^"' in identifier \""^s^"\".") +let is_unknown = function + | Unknown -> true + | Letter | IdentSep | IdentPart | Symbol -> false + +let is_ident_part = function + | IdentPart -> true + | Letter | IdentSep | Symbol | Unknown -> false + +let is_ident_sep = function + | IdentSep -> true + | Letter | IdentPart | Symbol | Unknown -> false + let ident_refutation s = if s = ".." then None else try let j, n = next_utf8 s 0 in @@ -198,7 +252,7 @@ let ident_refutation s = |x -> x with | End_of_input -> Some (true,"The empty string is not an identifier.") - | Invalid_argument _ -> Some (true,s^": invalid utf8 sequence.") + | Invalid_argument _ -> Some (true,escaped_non_utf8 s^": invalid utf8 sequence.") let lowercase_unicode = let tree = Segmenttree.make Unicodetable.to_lower in @@ -214,6 +268,26 @@ let lowercase_first_char s = let j, n = next_utf8 s 0 in utf8_of_unicode (lowercase_unicode n) +let split_at_first_letter s = + let n, v = next_utf8 s 0 in + if ((* optim *) n = 1 && s.[0] != '_') || not (is_ident_sep (classify v)) then None + else begin + let n = ref n in + let p = ref 0 in + while !n < String.length s && + let n', v = next_utf8 s !n in + p := n'; + (* Test if not letter *) + ((* optim *) n' = 1 && (s.[!n] = '_' || s.[!n] = '\'')) + || let st = classify v in + is_ident_sep st || is_ident_part st + do n := !n + !p + done; + let s1 = String.sub s 0 !n in + let s2 = String.sub s !n (String.length s - !n) in + Some (s1,s2) + end + (** For extraction, we need to encode unicode character into ascii ones *) let is_basic_ascii s = @@ -268,9 +342,7 @@ let utf8_length s = | '\192'..'\223' -> nc := 1 (* expect 1 continuation byte *) | '\224'..'\239' -> nc := 2 (* expect 2 continuation bytes *) | '\240'..'\247' -> nc := 3 (* expect 3 continuation bytes *) - | '\248'..'\251' -> nc := 4 (* expect 4 continuation bytes *) - | '\252'..'\253' -> nc := 5 (* expect 5 continuation bytes *) - | '\254'..'\255' -> nc := 0 (* invalid byte *) + | '\248'..'\255' -> nc := 0 (* invalid byte *) end ; incr p ; while !p < len && !nc > 0 do @@ -299,9 +371,7 @@ let utf8_sub s start_u len_u = | '\192'..'\223' -> nc := 1 (* expect 1 continuation byte *) | '\224'..'\239' -> nc := 2 (* expect 2 continuation bytes *) | '\240'..'\247' -> nc := 3 (* expect 3 continuation bytes *) - | '\248'..'\251' -> nc := 4 (* expect 4 continuation bytes *) - | '\252'..'\253' -> nc := 5 (* expect 5 continuation bytes *) - | '\254'..'\255' -> nc := 0 (* invalid byte *) + | '\248'..'\255' -> nc := 0 (* invalid byte *) end ; incr p ; while !p < len_b && !nc > 0 do diff --git a/lib/unicode.mli b/lib/unicode.mli index c7d742480..32ffbb8e9 100644 --- a/lib/unicode.mli +++ b/lib/unicode.mli @@ -8,7 +8,7 @@ (** Unicode utilities *) -type status = Letter | IdentPart | Symbol | Unknown +type status (** Classify a unicode char into 3 classes or unknown. *) val classify : int -> status @@ -17,10 +17,23 @@ val classify : int -> status Return [Some (b,s)] otherwise, where [s] is an explanation and [b] is severity. *) val ident_refutation : string -> (bool * string) option +(** Tells if a valid initial character for an identifier *) +val is_valid_ident_initial : status -> bool + +(** Tells if a valid non-initial character for an identifier *) +val is_valid_ident_trailing : status -> bool + +(** Tells if a character is unclassified *) +val is_unknown : status -> bool + (** First char of a string, converted to lowercase @raise Assert_failure if the input string is empty. *) val lowercase_first_char : string -> string +(** Split a string supposed to be an ident at the first letter; + as an optimization, return None if the first character is a letter *) +val split_at_first_letter : string -> (string * string) option + (** Return [true] if all UTF-8 characters in the input string are just plain ASCII characters. Returns [false] otherwise. *) val is_basic_ascii : string -> bool @@ -40,3 +53,6 @@ val utf8_length : string -> int (** Variant of {!String.sub} for UTF-8 strings. *) val utf8_sub : string -> int -> int -> string + +(** Return a "%XX"-escaped string if it contains non UTF-8 characters. *) +val escaped_if_non_utf8 : string -> string diff --git a/lib/util.ml b/lib/util.ml index 36282b2da..6de012da0 100644 --- a/lib/util.ml +++ b/lib/util.ml @@ -171,3 +171,12 @@ let open_utf8_file_in fname = let s = Bytes.make 3 ' ' in if input in_chan s 0 3 < 3 || not (is_bom s) then seek_in in_chan 0; in_chan + +(** A trick which can typically be used to store on the fly the + computation of values in the "when" clause of a "match" then + retrieve the evaluated result in the r.h.s of the clause *) + +let set_temporary_memory () = + let a = ref None in + (fun x -> assert (!a = None); a := Some x; x), + (fun () -> match !a with Some x -> x | None -> assert false) diff --git a/lib/util.mli b/lib/util.mli index d910e7e28..c54f5825c 100644 --- a/lib/util.mli +++ b/lib/util.mli @@ -137,3 +137,8 @@ val sym : ('a, 'b) eq -> ('b, 'a) eq val open_utf8_file_in : string -> in_channel (** Open an utf-8 encoded file and skip the byte-order mark if any. *) + +val set_temporary_memory : unit -> ('a -> 'a) * (unit -> 'a) +(** A trick which can typically be used to store on the fly the + computation of values in the "when" clause of a "match" then + retrieve the evaluated result in the r.h.s of the clause *) diff --git a/library/library.ml b/library/library.ml index 28afa054e..1da2c591d 100644 --- a/library/library.ml +++ b/library/library.ml @@ -620,25 +620,6 @@ let check_coq_overwriting p id = (str "Cannot build module " ++ pr_dirpath p ++ str "." ++ pr_id id ++ str "." ++ spc () ++ str "it starts with prefix \"Coq\" which is reserved for the Coq library.") -(* Verifies that a string starts by a letter and do not contain - others caracters than letters, digits, or `_` *) - -let check_module_name s = - let msg c = - strbrk "Invalid module name: " ++ str s ++ strbrk " character " ++ - (if c = '\'' then str "\"'\"" else (str "'" ++ str (String.make 1 c) ++ str "'")) ++ - strbrk " is not allowed in module names\n" - in - let err c = user_err (msg c) in - match String.get s 0 with - | 'a' .. 'z' | 'A' .. 'Z' -> - for i = 1 to (String.length s)-1 do - match String.get s i with - | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' -> () - | c -> err c - done - | c -> err c - let start_library fo = let ldir0 = try @@ -648,7 +629,6 @@ let start_library fo = in let file = Filename.chop_extension (Filename.basename fo) in let id = Id.of_string file in - check_module_name file; check_coq_overwriting ldir0 id; let ldir = add_dirpath_suffix ldir0 id in Declaremods.start_library ldir; diff --git a/parsing/cLexer.ml4 b/parsing/cLexer.ml4 index 9c9189ffe..f26398fa9 100644 --- a/parsing/cLexer.ml4 +++ b/parsing/cLexer.ml4 @@ -245,8 +245,8 @@ let check_ident str = loop_id true s | [< s >] -> match unlocated lookup_utf8 Ploc.dummy s with - | Utf8Token (Unicode.Letter, n) -> njunk n s; loop_id true s - | Utf8Token (Unicode.IdentPart, n) when intail -> + | Utf8Token (st, n) when not intail && Unicode.is_valid_ident_initial st -> njunk n s; loop_id true s + | Utf8Token (st, n) when intail && Unicode.is_valid_ident_trailing st -> njunk n s; loop_id true s | EmptyStream -> () @@ -311,9 +311,9 @@ let rec ident_tail loc len = parser ident_tail loc (store len c) s | [< s >] -> match lookup_utf8 loc s with - | Utf8Token ((Unicode.IdentPart | Unicode.Letter), n) -> + | Utf8Token (st, n) when Unicode.is_valid_ident_trailing st -> ident_tail loc (nstore n len s) s - | Utf8Token (Unicode.Unknown, n) -> + | Utf8Token (st, n) when Unicode.is_unknown st -> let id = get_buff len in let u = String.concat "" (List.map (String.make 1) (Stream.npeek n s)) in warn_unrecognized_unicode ~loc:!@loc (u,id); len @@ -539,7 +539,7 @@ let parse_after_dot loc c bp = (try find_keyword loc ("."^field) s with Not_found -> FIELD field) | [< s >] -> match lookup_utf8 loc s with - | Utf8Token (Unicode.Letter, n) -> + | Utf8Token (st, n) when Unicode.is_valid_ident_initial st -> let len = ident_tail loc (nstore n 0 s) s in let field = get_buff len in (try find_keyword loc ("."^field) s with Not_found -> FIELD field) @@ -553,7 +553,7 @@ let parse_after_qmark loc bp s = | None -> KEYWORD "?" | _ -> match lookup_utf8 loc s with - | Utf8Token (Unicode.Letter, _) -> LEFTQMARK + | Utf8Token (st, _) when Unicode.is_valid_ident_initial st -> LEFTQMARK | AsciiChar | Utf8Token _ | EmptyStream -> fst (process_chars loc bp '?' s) @@ -618,13 +618,13 @@ let rec next_token loc = parser bp comment_stop bp; between_commands := new_between_commands; t | [< s >] -> match lookup_utf8 loc s with - | Utf8Token (Unicode.Letter, n) -> + | Utf8Token (st, n) when Unicode.is_valid_ident_initial st -> let len = ident_tail loc (nstore n 0 s) s in let id = get_buff len in let ep = Stream.count s in comment_stop bp; (try find_keyword loc id s with Not_found -> IDENT id), set_loc_pos loc bp ep - | AsciiChar | Utf8Token ((Unicode.Symbol | Unicode.IdentPart | Unicode.Unknown), _) -> + | AsciiChar | Utf8Token _ -> let t = process_chars loc bp (Stream.next s) s in comment_stop bp; t | EmptyStream -> diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml index 870137ca1..d51b8b54e 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -34,6 +34,7 @@ let default_levels = [200,Extend.RightA,false; 100,Extend.RightA,false; 99,Extend.RightA,true; + 90,Extend.RightA,true; 10,Extend.RightA,false; 9,Extend.RightA,false; 8,Extend.RightA,true; @@ -44,6 +45,7 @@ let default_pattern_levels = [200,Extend.RightA,true; 100,Extend.RightA,false; 99,Extend.RightA,true; + 90,Extend.RightA,true; 11,Extend.LeftA,false; 10,Extend.RightA,false; 1,Extend.LeftA,false; diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index 7d0728458..844c040fd 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -301,7 +301,7 @@ GEXTEND Gram | -> [] ] ] ; instance: - [ [ "@{"; l = LIST1 universe_level; "}" -> Some l + [ [ "@{"; l = LIST0 universe_level; "}" -> Some l | -> None ] ] ; universe_level: @@ -376,6 +376,7 @@ GEXTEND Gram | "100" RIGHTA [ p = pattern; "|"; pl = LIST1 pattern SEP "|" -> CAst.make ~loc:!@loc @@ CPatOr (p::pl) ] | "99" RIGHTA [ ] + | "90" RIGHTA [ ] | "11" LEFTA [ p = pattern; "as"; id = ident -> CAst.make ~loc:!@loc @@ CPatAlias (p, id) ] diff --git a/parsing/g_proofs.ml4 b/parsing/g_proofs.ml4 index 42b5bfa93..e2c87bbbf 100644 --- a/parsing/g_proofs.ml4 +++ b/parsing/g_proofs.ml4 @@ -45,11 +45,9 @@ GEXTEND Gram | IDENT "Existential"; n = natural; c = constr_body -> VernacSolveExistential (n,c) | IDENT "Admitted" -> VernacEndProof Admitted - | IDENT "Qed" -> VernacEndProof (Proved (Opaque None,None)) - | IDENT "Qed"; IDENT "exporting"; l = LIST0 identref SEP "," -> - VernacEndProof (Proved (Opaque (Some l),None)) + | IDENT "Qed" -> VernacEndProof (Proved (Opaque,None)) | IDENT "Save"; id = identref -> - VernacEndProof (Proved (Opaque None, Some id)) + VernacEndProof (Proved (Opaque, Some id)) | IDENT "Defined" -> VernacEndProof (Proved (Transparent,None)) | IDENT "Defined"; id=identref -> VernacEndProof (Proved (Transparent,Some id)) diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index de98415cd..819d236cd 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -75,10 +75,6 @@ GEXTEND Gram | IDENT "Local"; v = vernac_poly -> VernacLocal (true, v) | IDENT "Global"; v = vernac_poly -> VernacLocal (false, v) - (* Stm backdoor *) - | IDENT "Stm"; IDENT "JoinDocument"; "." -> VernacStm JoinDocument - | IDENT "Stm"; IDENT "Wait"; "." -> VernacStm Wait - | v = vernac_poly -> v ] ] ; @@ -135,20 +131,20 @@ let test_plural_form_types loc kwd = function let fresh_var env c = Namegen.next_ident_away (Id.of_string "pat") - (env @ Id.Set.elements (Topconstr.free_vars_of_constr_expr c)) + (List.fold_left (fun accu id -> Id.Set.add id accu) (Topconstr.free_vars_of_constr_expr c) env) let _ = Hook.set Constrexpr_ops.fresh_var_hook fresh_var (* Gallina declarations *) GEXTEND Gram GLOBAL: gallina gallina_ext thm_token def_body of_type_with_opt_coercion - record_field decl_notation rec_definition pidentref; + record_field decl_notation rec_definition pidentref ident_decl; gallina: (* Definition, Theorem, Variable, Axiom, ... *) - [ [ thm = thm_token; id = pidentref; bl = binders; ":"; c = lconstr; + [ [ thm = thm_token; id = ident_decl; bl = binders; ":"; c = lconstr; l = LIST0 - [ "with"; id = pidentref; bl = binders; ":"; c = lconstr -> + [ "with"; id = ident_decl; bl = binders; ":"; c = lconstr -> (Some id,(bl,c)) ] -> VernacStartTheoremProof (thm, (Some id,(bl,c))::l) | stre = assumption_token; nl = inline; bl = assum_list -> @@ -156,7 +152,7 @@ GEXTEND Gram | (kwd,stre) = assumptions_token; nl = inline; bl = assum_list -> test_plural_form loc kwd bl; VernacAssumption (stre, nl, bl) - | d = def_token; id = pidentref; b = def_body -> + | d = def_token; id = ident_decl; b = def_body -> VernacDefinition (d, id, b) | IDENT "Let"; id = identref; b = def_body -> VernacDefinition ((Some Discharge, Definition), (id, None), b) @@ -228,13 +224,29 @@ GEXTEND Gram | IDENT "Inline" -> DefaultInline | -> NoInline] ] ; - pidentref: - [ [ i = identref; l = OPT [ "@{" ; l = LIST0 identref; "}" -> l ] -> (i,l) ] ] - ; univ_constraint: [ [ l = universe_level; ord = [ "<" -> Univ.Lt | "=" -> Univ.Eq | "<=" -> Univ.Le ]; r = universe_level -> (l, ord, r) ] ] ; + pidentref: + [ [ i = identref; l = OPT [ "@{" ; l = LIST0 identref; "}" -> l ] -> (i,l) ] ] + ; + univ_decl : + [ [ "@{" ; l = LIST0 identref; ext = [ "+" -> true | -> false ]; + cs = [ "|"; l' = LIST0 univ_constraint SEP ","; + ext = [ "+" -> true | -> false ]; "}" -> (l',ext) + | ext = [ "}" -> true | "|}" -> false ] -> ([], ext) ] + -> + { univdecl_instance = l; + univdecl_extensible_instance = ext; + univdecl_constraints = fst cs; + univdecl_extensible_constraints = snd cs } + ] ] + ; + ident_decl: + [ [ i = identref; l = OPT univ_decl -> (i, l) + ] ] + ; finite_token: [ [ IDENT "Inductive" -> (Inductive_kw,Finite) | IDENT "CoInductive" -> (CoInductive,CoFinite) @@ -292,7 +304,7 @@ GEXTEND Gram | -> RecordDecl (None, []) ] ] ; inductive_definition: - [ [ oc = opt_coercion; id = pidentref; indpar = binders; + [ [ oc = opt_coercion; id = ident_decl; indpar = binders; c = OPT [ ":"; c = lconstr -> c ]; lc=opt_constructors_or_fields; ntn = decl_notation -> (((oc,id),indpar,c,lc),ntn) ] ] @@ -318,14 +330,14 @@ GEXTEND Gram ; (* (co)-fixpoints *) rec_definition: - [ [ id = pidentref; + [ [ id = ident_decl; 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 = pidentref; bl = binders; ty = type_cstr; + [ [ id = ident_decl; bl = binders; ty = type_cstr; def = OPT [":="; def = lconstr -> def]; ntn = decl_notation -> ((id,bl,ty,def),ntn) ] ] ; @@ -397,7 +409,7 @@ GEXTEND Gram [ [ "("; a = simple_assum_coe; ")" -> a ] ] ; simple_assum_coe: - [ [ idl = LIST1 pidentref; oc = of_type_with_opt_coercion; c = lconstr -> + [ [ idl = LIST1 ident_decl; oc = of_type_with_opt_coercion; c = lconstr -> (not (Option.is_empty oc),(idl,c)) ] ] ; @@ -800,7 +812,7 @@ GEXTEND Gram | IDENT "transparent" -> Conv_oracle.transparent ] ] ; instance_name: - [ [ name = pidentref; sup = OPT binders -> + [ [ name = ident_decl; sup = OPT binders -> (let ((loc,id),l) = name in ((loc, Name id),l)), (Option.default [] sup) | -> ((Loc.tag ~loc:!@loc Anonymous), None), [] ] ] diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 40c5da7a5..3d00b220b 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -445,6 +445,7 @@ module Prim = let name = Gram.entry_create "Prim.name" let identref = Gram.entry_create "Prim.identref" let pidentref = Gram.entry_create "Prim.pidentref" + let ident_decl = Gram.entry_create "Prim.ident_decl" let pattern_ident = Gram.entry_create "pattern_ident" let pattern_identref = Gram.entry_create "pattern_identref" diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 4e6bff20a..2f0375419 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -195,6 +195,7 @@ module Prim : val name : Name.t located Gram.entry val identref : Id.t located Gram.entry val pidentref : (Id.t located * (Id.t located list) option) Gram.entry + val ident_decl : ident_decl Gram.entry val pattern_ident : Id.t Gram.entry val pattern_identref : Id.t located Gram.entry val base_ident : Id.t Gram.entry diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index fca7d9851..150319f6b 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -444,7 +444,7 @@ let cc_tactic depth additionnal_terms = let terms_to_complete = List.map (build_term_to_complete uf) (epsilons uf) in let hole = DAst.make @@ GHole (Evar_kinds.InternalHole, Misctypes.IntroAnonymous, None) in let pr_missing (c, missing) = - let c = Detyping.detype Detyping.Now ~lax:true false [] env sigma c in + let c = Detyping.detype Detyping.Now ~lax:true false Id.Set.empty env sigma c in let holes = List.init missing (fun _ -> hole) in Printer.pr_glob_constr_env env (DAst.make @@ GApp (c, holes)) in diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml index 9772ebd64..9aec190d0 100644 --- a/plugins/extraction/common.ml +++ b/plugins/extraction/common.ml @@ -405,7 +405,7 @@ let ref_renaming_fun (k,r) = let idg = safe_basename_of_global r in match l with | [""] -> (* this happens only at toplevel of the monolithic case *) - let globs = Id.Set.elements (get_global_ids ()) in + let globs = get_global_ids () in let id = next_ident_away (kindcase_id k idg) globs in Id.to_string id | _ -> modular_rename k idg diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index f503c572d..3c46d5c43 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -342,7 +342,7 @@ let rec extract_structure env mp reso ~all = function and extract_mexpr env mp = function | MEwith _ -> assert false (* no 'with' syntax for modules *) - | me when lang () != Ocaml -> + | me when lang () != Ocaml || Table.is_extrcompute () -> (* In Haskell/Scheme, we expand everything. For now, we also extract everything, dead code will be removed later (see [Modutil.optimize_struct]. *) @@ -570,11 +570,12 @@ let print_structure_to_file (fn,si,mo) dry struc = let reset () = Visit.reset (); reset_tables (); reset_renaming_tables Everything -let init modular library = +let init ?(compute=false) modular library = check_inside_section (); check_inside_module (); set_keywords (descr ()).keywords; set_modular modular; set_library library; + set_extrcompute compute; reset (); if modular && lang () == Scheme then error_scheme () @@ -684,8 +685,22 @@ let extraction_library is_rec m = List.iter print struc; reset () +(** For extraction compute, we flatten all the module structure, + getting rid of module types or unapplied functors *) + +let flatten_structure struc = + let rec flatten_elem (lab,elem) = match elem with + |SEdecl d -> [d] + |SEmodtype _ -> [] + |SEmodule m -> match m.ml_mod_expr with + |MEfunctor _ -> [] + |MEident _ | MEapply _ -> assert false (* should be expanded *) + |MEstruct (_,elems) -> flatten_elems elems + and flatten_elems l = List.flatten (List.map flatten_elem l) + in flatten_elems (List.flatten (List.map snd struc)) + let structure_for_compute c = - init false false; + init false false ~compute:true; let env = Global.env () in let ast, mlt = Extraction.extract_constr env c in let ast = Mlutil.normalize ast in @@ -694,8 +709,7 @@ let structure_for_compute c = let () = ast_iter_references add_ref add_ref add_ref ast in let refs = Refset.elements !refs in let struc = optimize_struct (refs,[]) (mono_environment refs []) in - let flatstruc = List.map snd (List.flatten (List.map snd struc)) in - flatstruc, ast, mlt + (flatten_structure struc), ast, mlt (* For the test-suite : extraction to a temporary file + run ocamlc on it *) diff --git a/plugins/extraction/extract_env.mli b/plugins/extraction/extract_env.mli index 5769ff117..7bbb825b1 100644 --- a/plugins/extraction/extract_env.mli +++ b/plugins/extraction/extract_env.mli @@ -34,5 +34,4 @@ val print_one_decl : (* Used by Extraction Compute *) val structure_for_compute : - Term.constr -> - Miniml.ml_flat_structure * Miniml.ml_ast * Miniml.ml_type + Term.constr -> (Miniml.ml_decl list) * Miniml.ml_ast * Miniml.ml_type diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 7644b49ce..a227478d0 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -141,6 +141,7 @@ let make_typvar n vl = if not (String.contains s '\'') && Unicode.is_basic_ascii s then id else id_of_name Anonymous in + let vl = Id.Set.of_list vl in next_ident_away id' vl let rec type_sign_vl env c = diff --git a/plugins/extraction/miniml.mli b/plugins/extraction/miniml.mli index edebba49d..5e967ef37 100644 --- a/plugins/extraction/miniml.mli +++ b/plugins/extraction/miniml.mli @@ -187,8 +187,6 @@ type ml_structure = (ModPath.t * ml_module_structure) list type ml_signature = (ModPath.t * ml_module_sig) list -type ml_flat_structure = ml_structure_elem list - type unsafe_needs = { mldummy : bool; tdummy : bool; diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index a4c2bcd88..b01b0198d 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -127,11 +127,15 @@ let rec mgu = function | Taxiom, Taxiom -> () | _ -> raise Impossible -let needs_magic p = try mgu p; false with Impossible -> true +let skip_typing () = lang () == Scheme || is_extrcompute () -let put_magic_if b a = if b && lang () != Scheme then MLmagic a else a +let needs_magic p = + if skip_typing () then false + else try mgu p; false with Impossible -> true -let put_magic p a = if needs_magic p && lang () != Scheme then MLmagic a else a +let put_magic_if b a = if b then MLmagic a else a + +let put_magic p a = if needs_magic p then MLmagic a else a let generalizable a = lang () != Ocaml || @@ -769,6 +773,20 @@ let eta_red e = else e | _ -> e +(* Performs an eta-reduction when the core is atomic, + or otherwise returns None *) + +let atomic_eta_red e = + let ids,t = collect_lams e in + let n = List.length ids in + match t with + | MLapp (f,a) when test_eta_args_lift 0 n a -> + (match f with + | MLrel k when k>n -> Some (MLrel (k-n)) + | MLglob _ | MLexn _ | MLdummy _ -> Some f + | _ -> None) + | _ -> None + (*s Computes all head linear beta-reductions possible in [(t a)]. Non-linear head beta-redex become let-in. *) @@ -1053,6 +1071,10 @@ let rec simpl o = function simpl o (MLcase(typ,e,br')) | MLmagic(MLdummy _ as e) when lang () == Haskell -> e | MLmagic(MLexn _ as e) -> e + | MLlam _ as e -> + (match atomic_eta_red e with + | Some e' -> e' + | None -> ast_map (simpl o) e) | a -> ast_map (simpl o) a (* invariant : list [a] of arguments is non-empty *) diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index ca98f07e8..995d5fd19 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -250,6 +250,11 @@ let modular () = !modular_ref let set_library b = library_ref := b let library () = !library_ref +let extrcompute = ref false + +let set_extrcompute b = extrcompute := b +let is_extrcompute () = !extrcompute + (*s Printing. *) (* The following functions work even on objects not in [Global.env ()]. @@ -750,11 +755,11 @@ let extraction_implicit r l = let blacklist_table = Summary.ref Id.Set.empty ~name:"ExtrBlacklist" -let modfile_ids = ref [] +let modfile_ids = ref Id.Set.empty let modfile_mps = ref MPmap.empty let reset_modfile () = - modfile_ids := Id.Set.elements !blacklist_table; + modfile_ids := !blacklist_table; modfile_mps := MPmap.empty let string_of_modfile mp = @@ -763,7 +768,7 @@ let string_of_modfile mp = let id = Id.of_string (raw_string_of_modfile mp) in let id' = next_ident_away id !modfile_ids in let s' = Id.to_string id' in - modfile_ids := id' :: !modfile_ids; + modfile_ids := Id.Set.add id' !modfile_ids; modfile_mps := MPmap.add mp s' !modfile_mps; s' diff --git a/plugins/extraction/table.mli b/plugins/extraction/table.mli index 7e47d0bc8..cc93f294b 100644 --- a/plugins/extraction/table.mli +++ b/plugins/extraction/table.mli @@ -165,6 +165,9 @@ val modular : unit -> bool val set_library : bool -> unit val library : unit -> bool +val set_extrcompute : bool -> unit +val is_extrcompute : unit -> bool + (*s Table for custom inlining *) val to_inline : global_reference -> bool diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index 169073630..c2606dbe8 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -115,8 +115,8 @@ let mk_open_instance env evmap id idc m t = let nid=(fresh_id_in_env avoid var_id env) in let (evmap, (c, _)) = Evarutil.new_type_evar env evmap Evd.univ_flexible in let decl = LocalAssum (Name nid, c) in - aux (n-1) (nid::avoid) (EConstr.push_rel decl env) evmap (decl::decls) in - let evmap, decls = aux m [] env evmap [] in + aux (n-1) (Id.Set.add nid avoid) (EConstr.push_rel decl env) evmap (decl::decls) in + let evmap, decls = aux m Id.Set.empty env evmap [] in (evmap, decls, revt) (* tactics *) diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 5f6d78359..bd5fb1d92 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -587,7 +587,7 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = tclTHENLIST [ (* We first introduce the variables *) - tclDO nb_first_intro (Proofview.V82.of_tactic (intro_avoiding dyn_infos.rec_hyps)); + tclDO nb_first_intro (Proofview.V82.of_tactic (intro_avoiding (Id.Set.of_list dyn_infos.rec_hyps))); (* Then the equation itself *) Proofview.V82.of_tactic (intro_using heq_id); onLastHypId (fun heq_id -> tclTHENLIST [ @@ -1614,7 +1614,7 @@ let prove_principle_for_gen let hid = next_ident_away_in_goal (Id.of_string "prov") - hyps + (Id.Set.of_list hyps) in tclTHENLIST [ diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index ef1654fdf..018b51517 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -39,7 +39,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = | decl :: predicates -> (match Context.Rel.Declaration.get_name decl with | Name x -> - let id = Namegen.next_ident_away x avoid in + let id = Namegen.next_ident_away x (Id.Set.of_list avoid) in Hashtbl.add tbl id x; RelDecl.set_name (Name id) decl :: change_predicates_names (id::avoid) predicates | Anonymous -> anomaly (Pp.str "Anonymous property binder.")) @@ -285,7 +285,7 @@ let build_functional_principle (evd:Evd.evar_map ref) interactive_proof old_prin (* let time2 = System.get_time () in *) (* Pp.msgnl (str "computing principle type := " ++ System.fmt_time_difference time1 time2); *) let new_princ_name = - next_ident_away_in_goal (Id.of_string "___________princ_________") [] + next_ident_away_in_goal (Id.of_string "___________princ_________") Id.Set.empty in let _ = Typing.e_type_of ~refresh:true (Global.env ()) evd (EConstr.of_constr new_principle_type) in let hook = Lemmas.mk_hook (hook new_principle_type) in @@ -338,13 +338,14 @@ let generate_functional_principle (evd: Evd.evar_map ref) then (* let id_of_f = Label.to_id (con_label f) in *) let register_with_sort fam_sort = - let evd' = Evd.from_env (Global.env ()) in - let evd',s = Evd.fresh_sort_in_family env evd' fam_sort in - let name = Indrec.make_elimination_ident base_new_princ_name fam_sort in - let evd',value = change_property_sort evd' s new_principle_type new_princ_name in - let evd' = fst (Typing.type_of ~refresh:true (Global.env ()) evd' (EConstr.of_constr value)) in - (* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *) - let ce = Declare.definition_entry ~poly:(Flags.is_universe_polymorphism ()) ~univs:(snd (Evd.universe_context evd')) value in + let evd' = Evd.from_env (Global.env ()) in + let evd',s = Evd.fresh_sort_in_family env evd' fam_sort in + let name = Indrec.make_elimination_ident base_new_princ_name fam_sort in + let evd',value = change_property_sort evd' s new_principle_type new_princ_name in + let evd' = fst (Typing.type_of ~refresh:true (Global.env ()) evd' (EConstr.of_constr value)) in + (* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *) + let univs = (snd (Evd.universe_context ~names:[] ~extensible:true evd')) in + let ce = Declare.definition_entry ~poly:(Flags.is_universe_polymorphism ()) ~univs value in ignore( Declare.declare_constant name diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 7087a195e..e8e5bfccc 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -120,13 +120,13 @@ let combine_args arg args = let ids_of_binder = function - | LetIn Anonymous | Prod Anonymous | Lambda Anonymous -> [] - | LetIn (Name id) | Prod (Name id) | Lambda (Name id) -> [id] + | LetIn Anonymous | Prod Anonymous | Lambda Anonymous -> Id.Set.empty + | LetIn (Name id) | Prod (Name id) | Lambda (Name id) -> Id.Set.singleton id let rec change_vars_in_binder mapping = function [] -> [] | (bt,t)::l -> - let new_mapping = List.fold_right Id.Map.remove (ids_of_binder bt) mapping in + let new_mapping = Id.Set.fold Id.Map.remove (ids_of_binder bt) mapping in (bt,change_vars mapping t):: (if Id.Map.is_empty new_mapping then l @@ -137,27 +137,27 @@ let rec replace_var_by_term_in_binder x_id term = function | [] -> [] | (bt,t)::l -> (bt,replace_var_by_term x_id term t):: - if Id.List.mem x_id (ids_of_binder bt) + if Id.Set.mem x_id (ids_of_binder bt) then l else replace_var_by_term_in_binder x_id term l -let add_bt_names bt = List.append (ids_of_binder bt) +let add_bt_names bt = Id.Set.union (ids_of_binder bt) let apply_args ctxt body args = let need_convert_id avoid id = - List.exists (is_free_in id) args || Id.List.mem id avoid + List.exists (is_free_in id) args || Id.Set.mem id avoid in let need_convert avoid bt = - List.exists (need_convert_id avoid) (ids_of_binder bt) + Id.Set.exists (need_convert_id avoid) (ids_of_binder bt) in - let next_name_away (na:Name.t) (mapping: Id.t Id.Map.t) (avoid: Id.t list) = + let next_name_away (na:Name.t) (mapping: Id.t Id.Map.t) (avoid: Id.Set.t) = match na with - | Name id when Id.List.mem id avoid -> + | Name id when Id.Set.mem id avoid -> let new_id = Namegen.next_ident_away id avoid in - Name new_id,Id.Map.add id new_id mapping,new_id::avoid + Name new_id,Id.Map.add id new_id mapping,Id.Set.add new_id avoid | _ -> na,mapping,avoid in - let next_bt_away bt (avoid:Id.t list) = + let next_bt_away bt (avoid:Id.Set.t) = match bt with | LetIn na -> let new_na,mapping,new_avoid = next_name_away na Id.Map.empty avoid in @@ -182,15 +182,15 @@ let apply_args ctxt body args = let new_avoid,new_ctxt',new_body,new_id = if need_convert_id avoid id then - let new_avoid = id::avoid in + let new_avoid = Id.Set.add id avoid in let new_id = Namegen.next_ident_away id new_avoid in - let new_avoid' = new_id :: new_avoid in + let new_avoid' = Id.Set.add new_id new_avoid in let mapping = Id.Map.add id new_id Id.Map.empty in let new_ctxt' = change_vars_in_binder mapping ctxt' in let new_body = change_vars mapping body in new_avoid',new_ctxt',new_body,new_id else - id::avoid,ctxt',body,id + Id.Set.add id avoid,ctxt',body,id in let new_body = replace_var_by_term new_id arg new_body in let new_ctxt' = replace_var_by_term_in_binder new_id arg new_ctxt' in @@ -214,7 +214,7 @@ let apply_args ctxt body args = in (new_bt,t)::new_ctxt',new_body in - do_apply [] ctxt body args + do_apply Id.Set.empty ctxt body args let combine_app f args = @@ -434,7 +434,7 @@ let rec pattern_to_term_and_type env typ = DAst.with_val (function Array.to_list (Array.init (cst_narg - List.length patternl) - (fun i -> Detyping.detype Detyping.Now false [] env (Evd.from_env env) (EConstr.of_constr csta.(i))) + (fun i -> Detyping.detype Detyping.Now false Id.Set.empty env (Evd.from_env env) (EConstr.of_constr csta.(i))) ) in let patl_as_term = @@ -519,7 +519,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = *) let rt_as_constr,ctx = Pretyping.understand env (Evd.from_env env) rt in let rt_typ = Typing.unsafe_type_of env (Evd.from_env env) (EConstr.of_constr rt_as_constr) in - let res_raw_type = Detyping.detype Detyping.Now false [] env (Evd.from_env env) rt_typ in + let res_raw_type = Detyping.detype Detyping.Now false Id.Set.empty env (Evd.from_env env) rt_typ in let res = fresh_id args_res.to_avoid "_res" in let new_avoid = res::args_res.to_avoid in let res_rt = mkGVar res in @@ -559,7 +559,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = match n with | Name id when List.exists (is_free_in id) args -> (* need to alpha-convert the name *) - let new_id = Namegen.next_ident_away id avoid in + let new_id = Namegen.next_ident_away id (Id.Set.of_list avoid) in let new_avoid = id:: avoid in let new_b = replace_var_by_term @@ -773,7 +773,7 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve Typing.unsafe_type_of env_with_pat_ids (Evd.from_env env) (EConstr.mkVar id) in let raw_typ_of_id = - Detyping.detype Detyping.Now false [] + Detyping.detype Detyping.Now false Id.Set.empty env_with_pat_ids (Evd.from_env env) typ_of_id in mkGProd (Name id,raw_typ_of_id,acc)) @@ -819,7 +819,7 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve (fun pat e typ_as_constr -> let this_pat_ids = ids_of_pat pat in let typ_as_constr = EConstr.of_constr typ_as_constr in - let typ = Detyping.detype Detyping.Now false [] new_env (Evd.from_env env) typ_as_constr in + let typ = Detyping.detype Detyping.Now false Id.Set.empty new_env (Evd.from_env env) typ_as_constr in let pat_as_term = pattern_to_term pat in (* removing trivial holes *) let pat_as_term = solve_trivial_holes pat_as_term e in @@ -833,7 +833,7 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve then (Prod (Name id), let typ_of_id = Typing.unsafe_type_of new_env (Evd.from_env env) (EConstr.mkVar id) in let raw_typ_of_id = - Detyping.detype Detyping.Now false [] new_env (Evd.from_env env) typ_of_id + Detyping.detype Detyping.Now false Id.Set.empty new_env (Evd.from_env env) typ_of_id in raw_typ_of_id )::acc @@ -1001,7 +1001,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let rt_typ = DAst.make @@ GApp(DAst.make @@ GRef (Globnames.IndRef (fst ind),None), (List.map - (fun p -> Detyping.detype Detyping.Now false [] + (fun p -> Detyping.detype Detyping.Now false Id.Set.empty env (Evd.from_env env) (EConstr.of_constr p)) params)@(Array.to_list (Array.make @@ -1028,12 +1028,12 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = match na with | Anonymous -> acc | Name id' -> - (id',Detyping.detype Detyping.Now false [] + (id',Detyping.detype Detyping.Now false Id.Set.empty env (Evd.from_env env) arg)::acc else if isVar var_as_constr - then (destVar var_as_constr,Detyping.detype Detyping.Now false [] + then (destVar var_as_constr,Detyping.detype Detyping.Now false Id.Set.empty env (Evd.from_env env) arg)::acc diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index 02ee56ac5..0666ab4f1 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -198,7 +198,7 @@ let rec alpha_pat excluded pat = | PatVar(Name id) -> if Id.List.mem id excluded then - let new_id = Namegen.next_ident_away id excluded in + let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in (DAst.make ?loc @@ PatVar(Name new_id)),(new_id::excluded), (Id.Map.add id new_id Id.Map.empty) else pat, excluded,Id.Map.empty @@ -206,7 +206,7 @@ let rec alpha_pat excluded pat = let new_na,new_excluded,map = match na with | Name id when Id.List.mem id excluded -> - let new_id = Namegen.next_ident_away id excluded in + let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in Name new_id,new_id::excluded, Id.Map.add id new_id Id.Map.empty | _ -> na,excluded,Id.Map.empty in @@ -261,7 +261,7 @@ let rec alpha_rt excluded rt = match DAst.get rt with | GRef _ | GVar _ | GEvar _ | GPatVar _ as rt -> rt | GLambda(Anonymous,k,t,b) -> - let new_id = Namegen.next_ident_away (Id.of_string "_x") excluded in + let new_id = Namegen.next_ident_away (Id.of_string "_x") (Id.Set.of_list excluded) in let new_excluded = new_id :: excluded in let new_t = alpha_rt new_excluded t in let new_b = alpha_rt new_excluded b in @@ -276,7 +276,7 @@ let rec alpha_rt excluded rt = let new_c = alpha_rt excluded c in GLetIn(Anonymous,new_b,new_t,new_c) | GLambda(Name id,k,t,b) -> - let new_id = Namegen.next_ident_away id excluded in + let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in let t,b = if Id.equal new_id id then t, b @@ -289,7 +289,7 @@ let rec alpha_rt excluded rt = let new_b = alpha_rt new_excluded b in GLambda(Name new_id,k,new_t,new_b) | GProd(Name id,k,t,b) -> - let new_id = Namegen.next_ident_away id excluded in + let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in let new_excluded = new_id::excluded in let t,b = if Id.equal new_id id @@ -302,7 +302,7 @@ let rec alpha_rt excluded rt = let new_b = alpha_rt new_excluded b in GProd(Name new_id,k,new_t,new_b) | GLetIn(Name id,b,t,c) -> - let new_id = Namegen.next_ident_away id excluded in + let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in let c = if Id.equal new_id id then c else change_vars (Id.Map.add id new_id Id.Map.empty) c @@ -320,7 +320,7 @@ let rec alpha_rt excluded rt = match na with | Anonymous -> (na::nal,excluded,mapping) | Name id -> - let new_id = Namegen.next_ident_away id excluded in + let new_id = Namegen.next_ident_away id (Id.Set.of_list excluded) in if Id.equal new_id id then na::nal,id::excluded,mapping @@ -741,7 +741,7 @@ If someone knows how to prevent solved existantial removal in understand, pleas match evi.evar_body with | Evar_defined c -> (* we just have to lift the solution in glob_term *) - Detyping.detype Detyping.Now false [] env ctx (EConstr.of_constr (f c)) + Detyping.detype Detyping.Now false Id.Set.empty env ctx (EConstr.of_constr (f c)) | Evar_empty -> rt (* the hole was not solved : we do nothing *) ) | (GHole(BinderType na,_,_)) -> (* we only want to deal with implicit arguments *) @@ -763,7 +763,7 @@ If someone knows how to prevent solved existantial removal in understand, pleas match evi.evar_body with | Evar_defined c -> (* we just have to lift the solution in glob_term *) - Detyping.detype Detyping.Now false [] env ctx (EConstr.of_constr (f c)) + Detyping.detype Detyping.Now false Id.Set.empty env ctx (EConstr.of_constr (f c)) | Evar_empty -> rt (* the hole was not solved : we d when falseo nothing *) in res diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index 5f4d514f3..1e8854249 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -12,7 +12,7 @@ let mk_equation_id id = Nameops.add_suffix id "_equation" let msgnl m = () -let fresh_id avoid s = Namegen.next_ident_away_in_goal (Id.of_string s) avoid +let fresh_id avoid s = Namegen.next_ident_away_in_goal (Id.of_string s) (Id.Set.of_list avoid) let fresh_name avoid s = Name (fresh_id avoid s) diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 5f8d50da1..299753766 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -131,9 +131,9 @@ let generate_type evd g_to_f f graph i = | Name id -> Some id | Anonymous -> None in - let named_ctxt = List.map_filter filter fun_ctxt in + let named_ctxt = Id.Set.of_list (List.map_filter filter fun_ctxt) in let res_id = Namegen.next_ident_away_in_goal (Id.of_string "_res") named_ctxt in - let fv_id = Namegen.next_ident_away_in_goal (Id.of_string "fv") (res_id :: named_ctxt) in + let fv_id = Namegen.next_ident_away_in_goal (Id.of_string "fv") (Id.Set.add res_id named_ctxt) in (*i we can then type the argument to be applied to the function [f] i*) let args_as_rels = Array.of_list (args_from_decl 1 [] fun_ctxt) in (*i @@ -189,7 +189,7 @@ let rec generate_fresh_id x avoid i = if i == 0 then [] else - let id = Namegen.next_ident_away_in_goal x avoid in + let id = Namegen.next_ident_away_in_goal x (Id.Set.of_list avoid) in id::(generate_fresh_id x (id::avoid) (pred i)) @@ -239,7 +239,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes environment and due to the bug #1174, we will need to pose the principle using a name *) - let principle_id = Namegen.next_ident_away_in_goal (Id.of_string "princ") ids in + let principle_id = Namegen.next_ident_away_in_goal (Id.of_string "princ") (Id.Set.of_list ids) in let ids = principle_id :: ids in (* We get the branches of the principle *) let branches = List.rev princ_infos.branches in @@ -396,7 +396,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes let params_bindings,avoid = List.fold_left2 (fun (bindings,avoid) decl p -> - let id = Namegen.next_ident_away (Nameops.Name.get_id (RelDecl.get_name decl)) avoid in + let id = Namegen.next_ident_away (Nameops.Name.get_id (RelDecl.get_name decl)) (Id.Set.of_list avoid) in p::bindings,id::avoid ) ([],pf_ids_of_hyps g) @@ -406,7 +406,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes let lemmas_bindings = List.rev (fst (List.fold_left2 (fun (bindings,avoid) decl p -> - let id = Namegen.next_ident_away (Nameops.Name.get_id (RelDecl.get_name decl)) avoid in + let id = Namegen.next_ident_away (Nameops.Name.get_id (RelDecl.get_name decl)) (Id.Set.of_list avoid) in (nf_zeta p)::bindings,id::avoid) ([],avoid) princ_infos.predicates diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml index 96200a98a..77c26f8ce 100644 --- a/plugins/funind/merge.ml +++ b/plugins/funind/merge.ml @@ -767,7 +767,7 @@ let merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body) (* first replace rel 1 by a varname *) let substindtyp = substitterm 0 (mkRel 1) (mkVar nme) typ in let substindtyp = EConstr.of_constr substindtyp in - Detyping.detype Detyping.Now false (Id.Set.elements avoid) (Global.env()) Evd.empty substindtyp in + Detyping.detype Detyping.Now false avoid (Global.env()) Evd.empty substindtyp in let lcstr1: glob_constr list = Array.to_list (Array.map (mkrawcor ind1name avoid) oib1.mind_user_lc) in (* add to avoid all indentifiers of lcstr1 *) @@ -851,7 +851,7 @@ let mkProd_reldecl (rdecl:Context.Rel.Declaration.t) (t2:glob_constr) = match rdecl with | LocalAssum (nme,t) -> let t = EConstr.of_constr t in - let traw = Detyping.detype Detyping.Now false [] (Global.env()) Evd.empty t in + let traw = Detyping.detype Detyping.Now false Id.Set.empty (Global.env()) Evd.empty t in DAst.make @@ GProd (nme,Explicit,traw,t2) | LocalDef _ -> assert false diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 41a10cba3..74c454334 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -115,13 +115,17 @@ let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta (* Generic values *) let pf_get_new_ids idl g = let ids = pf_ids_of_hyps g in + let ids = Id.Set.of_list ids in List.fold_right - (fun id acc -> next_global_ident_away id (acc@ids)::acc) + (fun id acc -> next_global_ident_away id (Id.Set.union (Id.Set.of_list acc) ids)::acc) idl [] +let next_ident_away_in_goal ids avoid = + next_ident_away_in_goal ids (Id.Set.of_list avoid) + let compute_renamed_type gls c = - rename_bound_vars_as_displayed (project gls) (*no avoid*) [] (*no rels*) [] + rename_bound_vars_as_displayed (project gls) (*no avoid*) Id.Set.empty (*no rels*) [] (pf_unsafe_type_of gls c) let h'_id = Id.of_string "h'" let teq_id = Id.of_string "teq" @@ -1288,8 +1292,8 @@ let build_new_goal_type () = let is_opaque_constant c = let cb = Global.lookup_constant c in match cb.Declarations.const_body with - | Declarations.OpaqueDef _ -> Vernacexpr.Opaque None - | Declarations.Undef _ -> Vernacexpr.Opaque None + | Declarations.OpaqueDef _ -> Vernacexpr.Opaque + | Declarations.Undef _ -> Vernacexpr.Opaque | Declarations.Def _ -> Vernacexpr.Transparent let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal) = @@ -1302,7 +1306,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp with e when CErrors.noncritical e -> anomaly (Pp.str "open_new_goal with an unamed theorem.") in - let na = next_global_ident_away name [] in + let na = next_global_ident_away name Id.Set.empty in if Termops.occur_existential sigma gls_type then CErrors.user_err Pp.(str "\"abstract\" cannot handle existentials"); let hook _ _ = @@ -1543,7 +1547,10 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let equation_id = add_suffix function_name "_equation" in let functional_id = add_suffix function_name "_F" in let term_id = add_suffix function_name "_terminate" in - let functional_ref = declare_fun functional_id (IsDefinition Decl_kinds.Definition) ~ctx:(snd (Evd.universe_context evm)) res in + let functional_ref = + let ctx = (snd (Evd.universe_context ~names:[] ~extensible:true evm)) in + declare_fun functional_id (IsDefinition Decl_kinds.Definition) ~ctx res + in (* Refresh the global universes, now including those of _F *) let evm = Evd.from_env (Global.env ()) in let env_with_pre_rec_args = push_rel_context(List.map (function (x,t) -> LocalAssum (x,t)) pre_rec_args) env in diff --git a/plugins/ltac/evar_tactics.ml b/plugins/ltac/evar_tactics.ml index 4cab6ef33..d9150a7bb 100644 --- a/plugins/ltac/evar_tactics.ml +++ b/plugins/ltac/evar_tactics.ml @@ -88,7 +88,7 @@ let let_evar name typ = let id = match name with | Name.Anonymous -> let id = Namegen.id_of_name_using_hdchar env sigma typ name in - Namegen.next_ident_away_in_goal id (Termops.ids_of_named_context (Environ.named_context env)) + Namegen.next_ident_away_in_goal id (Termops.vars_of_env env) | Name.Name id -> id in let (sigma, evar) = Evarutil.new_evar env sigma ~src ~naming:(Misctypes.IntroFresh id) typ in diff --git a/plugins/ltac/extratactics.ml4 b/plugins/ltac/extratactics.ml4 index b4c6f9c90..a7aebf9e1 100644 --- a/plugins/ltac/extratactics.ml4 +++ b/plugins/ltac/extratactics.ml4 @@ -665,7 +665,7 @@ let hResolve id c occ t = let sigma = Proofview.Goal.sigma gl in let env = Termops.clear_named_body id (Proofview.Goal.env gl) in let concl = Proofview.Goal.concl gl in - let env_ids = Termops.ids_of_context env in + let env_ids = Termops.vars_of_env env in let c_raw = Detyping.detype Detyping.Now true env_ids env sigma c in let t_raw = Detyping.detype Detyping.Now true env_ids env sigma t in let rec resolve_hole t_hole = @@ -764,7 +764,7 @@ let case_eq_intros_rewrite x = mkCaseEq x; Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in - let hyps = Tacmach.New.pf_ids_of_hyps gl in + let hyps = Tacmach.New.pf_ids_set_of_hyps gl in let n' = nb_prod (Tacmach.New.project gl) concl in let h = fresh_id_in_env hyps (Id.of_string "heq") (Proofview.Goal.env gl) in Tacticals.New.tclTHENLIST [ diff --git a/plugins/ltac/g_ltac.ml4 b/plugins/ltac/g_ltac.ml4 index 2ea0f60eb..86c983bdd 100644 --- a/plugins/ltac/g_ltac.ml4 +++ b/plugins/ltac/g_ltac.ml4 @@ -388,16 +388,7 @@ let vernac_solve n info tcom b = p,status) in if not status then Feedback.feedback Feedback.AddedAxiom -let pr_range_selector (i, j) = - if Int.equal i j then int i - else int i ++ str "-" ++ int j - -let pr_ltac_selector = function -| SelectNth i -> int i ++ str ":" -| SelectList l -> str "[" ++ prlist_with_sep (fun () -> str ", ") pr_range_selector l ++ - str "]" ++ str ":" -| SelectId id -> str "[" ++ Id.print id ++ str "]" ++ str ":" -| SelectAll -> str "all" ++ str ":" +let pr_ltac_selector s = Pptactic.pr_goal_selector ~toplevel:true s VERNAC ARGUMENT EXTEND ltac_selector PRINTED BY pr_ltac_selector | [ toplevel_selector(s) ] -> [ s ] diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index f4e3ba633..d8bd16620 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -477,12 +477,14 @@ type 'a extra_genarg_printer = if Int.equal i j then int i else int i ++ str "-" ++ int j - let pr_goal_selector = function - | SelectNth i -> int i ++ str ":" - | SelectList l -> str "[" ++ prlist_with_sep (fun () -> str ", ") pr_range_selector l ++ - str "]" ++ str ":" - | SelectId id -> str "[" ++ Id.print id ++ str "]" ++ str ":" - | SelectAll -> str "all" ++ str ":" +let pr_goal_selector toplevel = function + | SelectNth i -> int i ++ str ":" + | SelectList l -> prlist_with_sep (fun () -> str ", ") pr_range_selector l ++ str ":" + | SelectId id -> str "[" ++ Id.print id ++ str "]:" + | SelectAll -> assert toplevel; str "all:" + +let pr_goal_selector ~toplevel s = + (if toplevel then mt () else str "only ") ++ pr_goal_selector toplevel s let pr_lazy = function | General -> keyword "multi" @@ -662,14 +664,14 @@ type 'a extra_genarg_printer = let names = List.fold_left (fun ln (nal,_) -> List.fold_left - (fun ln na -> match na with (_,Name id) -> id::ln | _ -> ln) + (fun ln na -> match na with (_,Name id) -> Id.Set.add id ln | _ -> ln) ln nal) - [] bll in + Id.Set.empty bll in let idarg,bll = set_nth_name names n bll in - let annot = match names with - | [_] -> + let annot = + if Int.equal (Id.Set.cardinal names) 1 then mt () - | _ -> + else spc() ++ str"{" ++ keyword "struct" ++ spc () ++ pr_id idarg ++ str"}" @@ -988,7 +990,7 @@ type 'a extra_genarg_printer = keyword "solve" ++ spc () ++ pr_seq_body (pr_tac ltop) tl, llet | TacComplete t -> pr_tac (lcomplete,E) t, lcomplete - | TacSelect (s, tac) -> pr_goal_selector s ++ spc () ++ pr_tac ltop tac, latom + | TacSelect (s, tac) -> pr_goal_selector ~toplevel:false s ++ spc () ++ pr_tac ltop tac, latom | TacId l -> keyword "idtac" ++ prlist (pr_arg (pr_message_token pr.pr_name)) l, latom | TacAtom (loc,t) -> diff --git a/plugins/ltac/pptactic.mli b/plugins/ltac/pptactic.mli index 1f6ebaf44..c79d5b389 100644 --- a/plugins/ltac/pptactic.mli +++ b/plugins/ltac/pptactic.mli @@ -53,6 +53,8 @@ type pp_tactic = { pptac_prods : grammar_terminals; } +val pr_goal_selector : toplevel:bool -> goal_selector -> Pp.t + val declare_notation_tactic_pprule : KerName.t -> pp_tactic -> unit val pr_with_occurrences : diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 75b665aad..fd791a910 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -664,7 +664,7 @@ type rewrite_result = type 'a strategy_input = { state : 'a ; (* a parameter: for instance, a state *) env : Environ.env ; - unfresh : Id.t list ; (* Unfresh names *) + unfresh : Id.Set.t; (* Unfresh names *) term1 : constr ; ty1 : types ; (* first term and its type (convertible to rew_from) *) cstr : (bool (* prop *) * constr option) ; @@ -1614,7 +1614,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = in try let res = - cl_rewrite_clause_aux ?abs strat env [] sigma ty clause + cl_rewrite_clause_aux ?abs strat env Id.Set.empty sigma ty clause in let sigma = match origsigma with None -> sigma | Some sigma -> sigma in treat sigma res <*> @@ -1884,7 +1884,7 @@ let declare_projection n instance_id r = in it_mkProd_or_LetIn ccl ctx in let typ = it_mkProd_or_LetIn typ ctx in - let pl, ctx = Evd.universe_context sigma in + let pl, ctx = Evd.universe_context ~names:[] ~extensible:true sigma in let typ = EConstr.to_constr sigma typ in let term = EConstr.to_constr sigma term in let cst = diff --git a/plugins/ltac/rewrite.mli b/plugins/ltac/rewrite.mli index 23767c12f..63e891b45 100644 --- a/plugins/ltac/rewrite.mli +++ b/plugins/ltac/rewrite.mli @@ -110,7 +110,7 @@ val setoid_transitivity : constr option -> unit Proofview.tactic val apply_strategy : strategy -> Environ.env -> - Names.Id.t list -> + Names.Id.Set.t -> constr -> bool * constr -> evars -> rewrite_result diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index cf676f598..a8d518fbd 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -216,7 +216,6 @@ let interp_prod_item = function assert (String.equal s "tactic"); begin match Tacarg.wit_tactic with | ExtraArg tag -> ArgT.Any tag - | _ -> assert false end in let symbol = interp_entry_name interp symbol in diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 8fa95ffb0..20f117ff4 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -139,7 +139,7 @@ let name_vfun appl vle = module TacStore = Geninterp.TacStore -let f_avoid_ids : Id.t list TacStore.field = TacStore.field () +let f_avoid_ids : Id.Set.t TacStore.field = TacStore.field () (* ids inherited from the call context (needed to get fresh ids) *) let f_debug : debug_info TacStore.field = TacStore.field () let f_trace : ltac_trace TacStore.field = TacStore.field () @@ -501,29 +501,29 @@ let extract_ltac_constr_values ist env = could barely be defined as a feature... *) (* Extract the identifier list from lfun: join all branches (what to do else?)*) -let rec intropattern_ids (loc,pat) = match pat with - | IntroNaming (IntroIdentifier id) -> [id] +let rec intropattern_ids accu (loc,pat) = match pat with + | IntroNaming (IntroIdentifier id) -> Id.Set.add id accu | IntroAction (IntroOrAndPattern (IntroAndPattern l)) -> - List.flatten (List.map intropattern_ids l) + List.fold_left intropattern_ids accu l | IntroAction (IntroOrAndPattern (IntroOrPattern ll)) -> - List.flatten (List.map intropattern_ids (List.flatten ll)) + List.fold_left intropattern_ids accu (List.flatten ll) | IntroAction (IntroInjection l) -> - List.flatten (List.map intropattern_ids l) - | IntroAction (IntroApplyOn ((_,c),pat)) -> intropattern_ids pat + List.fold_left intropattern_ids accu l + | IntroAction (IntroApplyOn ((_,c),pat)) -> intropattern_ids accu pat | IntroNaming (IntroAnonymous | IntroFresh _) | IntroAction (IntroWildcard | IntroRewrite _) - | IntroForthcoming _ -> [] + | IntroForthcoming _ -> accu -let extract_ids ids lfun = +let extract_ids ids lfun accu = let fold id v accu = let v = Value.normalize v in if has_type v (topwit wit_intro_pattern) then let (_, ipat) = out_gen (topwit wit_intro_pattern) v in if Id.List.mem id ids then accu - else accu @ intropattern_ids (Loc.tag ipat) + else intropattern_ids accu (Loc.tag ipat) else accu in - Id.Map.fold fold lfun [] + Id.Map.fold fold lfun accu let default_fresh_id = Id.of_string "H" @@ -534,10 +534,10 @@ let interp_fresh_id ist env sigma l = with Not_found -> id in let ids = List.map_filter (function ArgVar (_, id) -> Some id | _ -> None) l in let avoid = match TacStore.get ist.extra f_avoid_ids with - | None -> [] + | None -> Id.Set.empty | Some l -> l in - let avoid = (extract_ids ids ist.lfun) @ avoid in + let avoid = extract_ids ids ist.lfun avoid in let id = if List.is_empty l then default_fresh_id else @@ -1303,7 +1303,7 @@ and interp_ltac_reference ?loc' mustbetac ist r : Val.t Ftactic.t = if mustbetac then Ftactic.return (coerce_to_tactic loc id v) else Ftactic.return v end | ArgArg (loc,r) -> - let ids = extract_ids [] ist.lfun in + let ids = extract_ids [] ist.lfun Id.Set.empty in let loc_info = (Option.default loc loc',LtacNameCall r) in let extra = TacStore.set ist.extra f_avoid_ids ids in push_trace loc_info ist >>= fun trace -> @@ -1394,7 +1394,13 @@ and interp_app loc ist fv largs : Val.t Ftactic.t = if List.is_empty lval then Ftactic.return v else interp_app loc ist v lval else Ftactic.return (of_tacvalue (VFun(push_appl appl largs,trace,newlfun,lvar,body))) - | _ -> fail + | (VFun(appl,trace,olfun,[],body)) -> + let extra_args = List.length largs in + Tacticals.New.tclZEROMSG (str "Illegal tactic application: got " ++ + str (string_of_int extra_args) ++ + str " extra " ++ str (String.plural extra_args "argument") ++ + str ".") + | VRec(_,_) -> fail else fail (* Gives the tactic corresponding to the tactic value *) @@ -1956,7 +1962,7 @@ let interp_tac_gen lfun avoid_ids debug t = (intern_pure_tactic { (Genintern.empty_glob_sign env) with ltacvars } t) end -let interp t = interp_tac_gen Id.Map.empty [] (get_debug()) t +let interp t = interp_tac_gen Id.Map.empty Id.Set.empty (get_debug()) t (* Used to hide interpretation for pretty-print, now just launch tactics *) (* [global] means that [t] should be internalized outside of goals. *) diff --git a/plugins/ltac/tacinterp.mli b/plugins/ltac/tacinterp.mli index c1ab2b4c4..d0a0a81d4 100644 --- a/plugins/ltac/tacinterp.mli +++ b/plugins/ltac/tacinterp.mli @@ -40,7 +40,7 @@ type interp_sign = Geninterp.interp_sign = { lfun : value Id.Map.t; extra : TacStore.t } -val f_avoid_ids : Id.t list TacStore.field +val f_avoid_ids : Id.Set.t TacStore.field val f_debug : debug_info TacStore.field val extract_ltac_constr_values : interp_sign -> Environ.env -> @@ -113,7 +113,7 @@ val tactic_of_value : interp_sign -> Value.t -> unit Proofview.tactic (** Globalization + interpretation *) -val interp_tac_gen : value Id.Map.t -> Id.t list -> +val interp_tac_gen : value Id.Map.t -> Id.Set.t -> debug_info -> raw_tactic_expr -> unit Proofview.tactic val interp : raw_tactic_expr -> unit Proofview.tactic diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index a4103634e..fc6781b06 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -1986,7 +1986,7 @@ let micromega_gen let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in let intro_props = Tacticals.New.tclTHENLIST (List.map intro props) in let ipat_of_name id = Some (Loc.tag @@ Misctypes.IntroNaming (Misctypes.IntroIdentifier id)) in - let goal_name = fresh_id [] (Names.Id.of_string "__arith") gl in + let goal_name = fresh_id Id.Set.empty (Names.Id.of_string "__arith") gl in let env' = List.map (fun (id,i) -> EConstr.mkVar id,i) vars in let tac_arith = Tacticals.New.tclTHENLIST [ intro_props ; intro_vars ; @@ -2101,7 +2101,7 @@ let micromega_genr prover tac = let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in let intro_props = Tacticals.New.tclTHENLIST (List.map intro props) in let ipat_of_name id = Some (Loc.tag @@ Misctypes.IntroNaming (Misctypes.IntroIdentifier id)) in - let goal_name = fresh_id [] (Names.Id.of_string "__arith") gl in + let goal_name = fresh_id Id.Set.empty (Names.Id.of_string "__arith") gl in let env' = List.map (fun (id,i) -> EConstr.mkVar id,i) vars in let tac_arith = Tacticals.New.tclTHENLIST [ intro_props ; intro_vars ; diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 99493d698..ae1a563be 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -1760,7 +1760,7 @@ let onClearedName id tac = tclTHEN (tclTRY (clear [id])) (Proofview.Goal.nf_enter begin fun gl -> - let id = fresh_id [] id gl in + let id = fresh_id Id.Set.empty id gl in tclTHEN (introduction id) (tac id) end) @@ -1768,8 +1768,8 @@ let onClearedName2 id tac = tclTHEN (tclTRY (clear [id])) (Proofview.Goal.nf_enter begin fun gl -> - let id1 = fresh_id [] (add_suffix id "_left") gl in - let id2 = fresh_id [] (add_suffix id "_right") gl in + let id1 = fresh_id Id.Set.empty (add_suffix id "_left") gl in + let id2 = fresh_id Id.Set.empty (add_suffix id "_right") gl in tclTHENLIST [ introduction id1; introduction id2; tac id1 id2 ] end) diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index d0fe1f957..b8fae2494 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -220,7 +220,7 @@ let exec_tactic env evd n f args = let gls = Proofview.V82.of_tactic (Tacinterp.eval_tactic_ist ist (ltac_call f (args@[getter]))) gl in let evd, nf = Evarutil.nf_evars_and_universes (Refiner.project gls) in let nf c = nf (constr_of c) in - Array.map nf !tactic_res, snd (Evd.universe_context evd) + Array.map nf !tactic_res, snd (Evd.universe_context ~names:[] ~extensible:true evd) let stdlib_modules = [["Coq";"Setoids";"Setoid"]; diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index 8b69c3435..95ca6f49a 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -129,7 +129,7 @@ let newssrcongrtac arg ist gl = let eq, gl = pf_fresh_global (Coqlib.build_coq_eq ()) gl in pf_saturate gl (EConstr.of_constr eq) 3 in tclMATCH_GOAL (equality, gl') (fun gl' -> fs gl' (List.assoc 0 eq_args)) - (fun ty -> congrtac (arg, Detyping.detype Detyping.Now false [] (pf_env gl) (project gl) ty) ist) + (fun ty -> congrtac (arg, Detyping.detype Detyping.Now false Id.Set.empty (pf_env gl) (project gl) ty) ist) (fun () -> let lhs, gl' = mk_evar gl EConstr.mkProp in let rhs, gl' = mk_evar gl' EConstr.mkProp in let arrow = EConstr.mkArrow lhs (EConstr.Vars.lift 1 rhs) in diff --git a/plugins/ssr/ssrparser.ml4 b/plugins/ssr/ssrparser.ml4 index 060225dab..1e1a986da 100644 --- a/plugins/ssr/ssrparser.ml4 +++ b/plugins/ssr/ssrparser.ml4 @@ -342,7 +342,7 @@ let interp_index ist gl idx = | None -> begin match Tacinterp.Value.to_constr v with | Some c -> - let rc = Detyping.detype Detyping.Now false [] (pf_env gl) (project gl) c in + let rc = Detyping.detype Detyping.Now false Id.Set.empty (pf_env gl) (project gl) c in begin match Notation.uninterp_prim_token rc with | _, Constrexpr.Numeral (s,b) -> let n = int_of_string s in if b then n else -n diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4 index 2e5522b83..e3e34616b 100644 --- a/plugins/ssrmatching/ssrmatching.ml4 +++ b/plugins/ssrmatching/ssrmatching.ml4 @@ -502,16 +502,16 @@ let ungen_upat lhs (sigma, uc, t) u = let nb_cs_proj_args pc f u = let na k = List.length (snd (lookup_canonical_conversion (ConstRef pc, k))).o_TCOMPS in - try match kind_of_term f with - | Prod _ -> na Prod_cs - | Sort s -> na (Sort_cs (family_of_sort s)) - | Const (c',_) when Constant.equal c' pc -> - begin match kind_of_term u.up_f with + let nargs_of_proj t = match kind_of_term t with | App(_,args) -> Array.length args | Proj _ -> 0 (* if splay_app calls expand_projection, this has to be the number of arguments including the projected *) - | _ -> assert false - end + | _ -> assert false in + try match kind_of_term f with + | Prod _ -> na Prod_cs + | Sort s -> na (Sort_cs (family_of_sort s)) + | Const (c',_) when Constant.equal c' pc -> nargs_of_proj u.up_f + | Proj (c',_) when Constant.equal (Projection.constant c') pc -> nargs_of_proj u.up_f | Var _ | Ind _ | Construct _ | Const _ -> na (Const_cs (global_of_constr f)) | _ -> -1 with Not_found -> -1 diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 7455587c0..08ce72932 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -113,8 +113,8 @@ let rec relocate_index sigma n1 n2 k t = type 'a rhs = { rhs_env : env; - rhs_vars : Id.t list; - avoid_ids : Id.t list; + rhs_vars : Id.Set.t; + avoid_ids : Id.Set.t; it : 'a option} type 'a equation = @@ -553,7 +553,7 @@ let extract_rhs pb = let occur_in_rhs na rhs = match na with | Anonymous -> false - | Name id -> Id.List.mem id rhs.rhs_vars + | Name id -> Id.Set.mem id rhs.rhs_vars let is_dep_patt_in eqn pat = match DAst.get pat with | PatVar name -> Flags.is_program_mode () || occur_in_rhs name eqn.rhs @@ -747,8 +747,8 @@ let get_names env sigma sign eqns = (* Otherwise, we take names from the parameters of the constructor but avoiding conflicts with user ids *) let allvars = - List.fold_left (fun l (_,_,eqn) -> List.union Id.equal l eqn.rhs.avoid_ids) - [] eqns in + List.fold_left (fun l (_,_,eqn) -> Id.Set.union l eqn.rhs.avoid_ids) + Id.Set.empty eqns in let names3,_ = List.fold_left2 (fun (l,avoid) d na -> @@ -757,7 +757,7 @@ let get_names env sigma sign eqns = (fun (LocalAssum (na,t) | LocalDef (na,_,t)) -> Name (next_name_away (named_hd env sigma t na) avoid)) d na in - (na::l,(Name.get_id na)::avoid)) + (na::l,Id.Set.add (Name.get_id na) avoid)) ([],allvars) (List.rev sign) names2 in names3,aliasname @@ -999,8 +999,8 @@ let add_assert_false_case pb tomatch = in [ { patterns = pats; rhs = { rhs_env = pb.env; - rhs_vars = []; - avoid_ids = []; + rhs_vars = Id.Set.empty; + avoid_ids = Id.Set.empty; it = None }; alias_stack = Anonymous::aliasnames; eqn_loc = None; @@ -1570,10 +1570,12 @@ let matx_of_eqns env eqns = let build_eqn (loc,(ids,lpat,rhs)) = let initial_lpat,initial_rhs = lpat,rhs in let initial_rhs = rhs in + let avoid = ids_of_named_context_val (named_context_val env) in + let avoid = List.fold_left (fun accu id -> Id.Set.add id accu) avoid ids in let rhs = { rhs_env = env; rhs_vars = free_glob_vars initial_rhs; - avoid_ids = ids@(ids_of_named_context (named_context env)); + avoid_ids = avoid; it = Some initial_rhs } in { patterns = initial_lpat; alias_stack = []; @@ -1751,7 +1753,7 @@ let build_tycon ?loc env tycon_env s subst tycon extenv evdref t = let build_inversion_problem loc env sigma tms t = let make_patvar t (subst,avoid) = let id = next_name_away (named_hd env sigma t Anonymous) avoid in - DAst.make @@ PatVar (Name id), ((id,t)::subst, id::avoid) in + DAst.make @@ PatVar (Name id), ((id,t)::subst, Id.Set.add id avoid) in let rec reveal_pattern t (subst,avoid as acc) = match EConstr.kind sigma (whd_all env sigma t) with | Construct (cstr,u) -> DAst.make (PatCstr (cstr,[],Anonymous)), acc @@ -1781,7 +1783,7 @@ let build_inversion_problem loc env sigma tms t = let d = LocalAssum (alias_of_pat pat,typ) in let patl,acc_sign,acc = aux (n+1) (push_rel d env) (d::acc_sign) tms acc in pat::patl,acc_sign,acc in - let avoid0 = ids_of_context env in + let avoid0 = vars_of_env env in (* [patl] is a list of patterns revealing the substructure of constructors present in the constraints on the type of the multiple terms t1..tn that are matched in the original problem; @@ -1823,7 +1825,7 @@ let build_inversion_problem loc env sigma tms t = rhs = { rhs_env = pb_env; (* we assume all vars are used; in practice we discard dependent vars so that the field rhs_vars is normally not used *) - rhs_vars = List.map fst subst; + rhs_vars = List.fold_left (fun accu (id, _) -> Id.Set.add id accu) Id.Set.empty subst; avoid_ids = avoid; it = Some (lift n t) } } in (* [catch_all] is a catch-all default clause of the auxiliary @@ -1841,7 +1843,7 @@ let build_inversion_problem loc env sigma tms t = eqn_loc = None; used = ref false; rhs = { rhs_env = pb_env; - rhs_vars = []; + rhs_vars = Id.Set.empty; avoid_ids = avoid0; it = None } } ] in (* [pb] is the auxiliary pattern-matching serving as skeleton for the @@ -2085,7 +2087,7 @@ let prime avoid name = let make_prime avoid prevname = let previd, id = prime !avoid prevname in - avoid := id :: !avoid; + avoid := Id.Set.add id !avoid; previd, id let eq_id avoid id = @@ -2113,7 +2115,7 @@ let constr_of_pat env evdref arsign pat avoid = Name n -> name, avoid | Anonymous -> let previd, id = prime avoid (Name (Id.of_string "wildcard")) in - Name id, id :: avoid + Name id, Id.Set.add id avoid in ((DAst.make ?loc @@ PatVar name), [LocalAssum (name, ty)] @ realargs, mkRel 1, ty, (List.map (fun x -> mkRel 1) realargs), 1, avoid) @@ -2157,7 +2159,7 @@ let constr_of_pat env evdref arsign pat avoid = pat', sign, app, apptype, realargs, n, avoid | Name id -> let sign = LocalAssum (alias, lift m ty) :: sign in - let avoid = id :: avoid in + let avoid = Id.Set.add id avoid in let sign, i, avoid = try let env = push_rel_context sign env in @@ -2168,7 +2170,7 @@ let constr_of_pat env evdref arsign pat avoid = (lift 1 app) (* aliased term *) in let neq = eq_id avoid id in - LocalDef (Name neq, mkRel 0, eq_t) :: sign, 2, neq :: avoid + LocalDef (Name neq, mkRel 0, eq_t) :: sign, 2, Id.Set.add neq avoid with Reduction.NotConvertible -> sign, 1, avoid in (* Mark the equality as a hole *) @@ -2182,7 +2184,7 @@ let constr_of_pat env evdref arsign pat avoid = let eq_id avoid id = let hid = Id.of_string ("Heq_" ^ Id.to_string id) in let hid' = next_ident_away hid !avoid in - avoid := hid' :: !avoid; + avoid := Id.Set.add hid' !avoid; hid' let is_topvar sigma t = @@ -2278,7 +2280,7 @@ let constrs_of_pats typing_fun env evdref eqns tomatchs sign neqs arity = (fun (idents, newpatterns, pats) pat arsign -> let pat', cpat, idents = constr_of_pat env evdref arsign pat idents in (idents, pat' :: newpatterns, cpat :: pats)) - ([], [], []) eqn.patterns sign + (Id.Set.empty, [], []) eqn.patterns sign in let newpatterns = List.rev newpatterns and opats = List.rev pats in let rhs_rels, pats, signlen = @@ -2379,8 +2381,8 @@ let abstract_tomatch env sigma tomatchs tycon = let name = next_ident_away (Id.of_string "filtered_var") names in (mkRel 1, lift_tomatch_type (succ lenctx) t) :: lift_ctx 1 prev, LocalDef (Name name, lift lenctx c, lift lenctx $ type_of_tomatch t) :: ctx, - name :: names, tycon) - ([], [], [], tycon) tomatchs + Id.Set.add name names, tycon) + ([], [], Id.Set.empty, tycon) tomatchs in List.rev prev, ctx, tycon let build_dependent_signature env evdref avoid tomatchs arsign = @@ -2502,7 +2504,7 @@ let compile_program_cases ?loc style (typing_function, evdref) tycon env lvar let arsign = List.map fst arsign in (* Because no difference between the arity for typing and the arity for building *) (* Build the dependent arity signature, the equalities which makes the first part of the predicate and their instantiations. *) - let avoid = [] in + let avoid = Id.Set.empty in build_dependent_signature env evdref avoid tomatchs arsign in diff --git a/pretyping/cases.mli b/pretyping/cases.mli index 428f64b99..7bdc604b8 100644 --- a/pretyping/cases.mli +++ b/pretyping/cases.mli @@ -49,16 +49,16 @@ val constr_of_pat : Evd.evar_map ref -> rel_context -> Glob_term.cases_pattern -> - Names.Id.t list -> + Names.Id.Set.t -> Glob_term.cases_pattern * (rel_context * constr * (types * constr list) * Glob_term.cases_pattern) * - Names.Id.t list + Names.Id.Set.t type 'a rhs = { rhs_env : env; - rhs_vars : Id.t list; - avoid_ids : Id.t list; + rhs_vars : Id.Set.t; + avoid_ids : Id.Set.t; it : 'a option} type 'a equation = diff --git a/pretyping/classops.ml b/pretyping/classops.ml index 1cc072a2a..260cd0444 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -9,7 +9,6 @@ open CErrors open Util open Pp -open Flags open Names open Libnames open Globnames @@ -387,7 +386,7 @@ let add_coercion_in_graph (ic,source,target) = old_inheritance_graph end; let is_ambig = match !ambig_paths with [] -> false | _ -> true in - if is_ambig && not !quiet then + if is_ambig && not !Flags.quiet then Feedback.msg_info (message_ambig !ambig_paths) type coercion = { diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index fc0a650bc..7cfd2e27d 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -205,7 +205,7 @@ and coerce ?loc env evdref (x : EConstr.constr) (y : EConstr.constr) | _ -> subco ()) | Prod (name, a, b), Prod (name', a', b') -> let name' = - Name (Namegen.next_ident_away Namegen.default_dependent_ident (Termops.ids_of_context env)) + Name (Namegen.next_ident_away Namegen.default_dependent_ident (Termops.vars_of_env env)) in let env' = push_rel (LocalAssum (name', a')) env in let c1 = coerce_unify env' (lift 1 a') (lift 1 a) in diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index ca7f633dc..0973d73ee 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -178,7 +178,7 @@ let push_binder na1 na2 t ctx = let id2 = match na2 with | Name id2 -> id2 | Anonymous -> - let avoid = List.map pi2 ctx in + let avoid = Id.Set.of_list (List.map pi2 ctx) in Namegen.next_ident_away Namegen.default_non_dependent_ident avoid in (na1, id2, t) :: ctx diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 1eb22cdb8..f3e8e72bb 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -221,12 +221,12 @@ let lookup_name_as_displayed env sigma t s = | (Anonymous,avoid') -> lookup avoid' (n+1) (pop c')) | Cast (c,_,_) -> lookup avoid n c | _ -> None - in lookup (ids_of_named_context (named_context env)) 1 t + in lookup (Environ.ids_of_named_context_val (Environ.named_context_val env)) 1 t let lookup_index_as_renamed env sigma t n = let rec lookup n d c = match EConstr.kind sigma c with | Prod (name,_,c') -> - (match compute_displayed_name_in sigma RenamingForGoal [] name c' with + (match compute_displayed_name_in sigma RenamingForGoal Id.Set.empty name c' with (Name _,_) -> lookup n (d+1) c' | (Anonymous,_) -> if Int.equal n 0 then @@ -236,7 +236,7 @@ let lookup_index_as_renamed env sigma t n = else lookup (n-1) (d+1) c') | LetIn (name,_,_,c') -> - (match compute_displayed_name_in sigma RenamingForGoal [] name c' with + (match compute_displayed_name_in sigma RenamingForGoal Id.Set.empty name c' with | (Name _,_) -> lookup n (d+1) c' | (Anonymous,_) -> if Int.equal n 0 then @@ -460,8 +460,11 @@ and detype_r d flags avoid env sigma t = in GVar (Id.of_string s)) | Meta n -> (* Meta in constr are not user-parsable and are mapped to Evar *) - (* using numbers to be unparsable *) - GEvar (Id.of_string ("M" ^ string_of_int n), []) + if n = Constr_matching.special_meta then + (* Using a dash to be unparsable *) + GEvar (Id.of_string_soft "CONTEXT-HOLE", []) + else + GEvar (Id.of_string_soft ("M" ^ string_of_int n), []) | Var id -> (try let _ = Global.lookup_named id in GRef (VarRef id, None) with Not_found -> GVar id) @@ -575,7 +578,7 @@ and detype_fix d flags avoid env sigma (vn,_ as nvn) (names,tys,bodies) = Array.fold_left2 (fun (avoid, env, l) na ty -> let id = next_name_away na avoid in - (id::avoid, add_name (Name id) None ty env, id::l)) + (Id.Set.add id avoid, add_name (Name id) None ty env, id::l)) (avoid, env, []) names tys in let n = Array.length tys in let v = Array.map3 @@ -591,7 +594,7 @@ and detype_cofix d flags avoid env sigma n (names,tys,bodies) = Array.fold_left2 (fun (avoid, env, l) na ty -> let id = next_name_away na avoid in - (id::avoid, add_name (Name id) None ty env, id::l)) + (Id.Set.add id avoid, add_name (Name id) None ty env, id::l)) (avoid, env, []) names tys in let ntys = Array.length tys in let v = Array.map2 @@ -612,14 +615,14 @@ and share_names d flags n l avoid env sigma c t = | _ -> na in let t' = detype d flags avoid env sigma t in let id = next_name_away na avoid in - let avoid = id::avoid and env = add_name (Name id) None t env in + let avoid = Id.Set.add id avoid and env = add_name (Name id) None t env in share_names d flags (n-1) ((Name id,Explicit,None,t')::l) avoid env sigma c c' (* May occur for fix built interactively *) | LetIn (na,b,t',c), _ when n > 0 -> let t'' = detype d flags avoid env sigma t' in let b' = detype d flags avoid env sigma b in let id = next_name_away na avoid in - let avoid = id::avoid and env = add_name (Name id) (Some b) t' env in + let avoid = Id.Set. add id avoid and env = add_name (Name id) (Some b) t' env in share_names d flags n ((Name id,Explicit,Some b',t'')::l) avoid env sigma c (lift 1 t) (* Only if built with the f/n notation or w/o let-expansion in types *) | _, LetIn (_,b,_,t) when n > 0 -> @@ -628,7 +631,7 @@ and share_names d flags n l avoid env sigma c t = | _, Prod (na',t',c') when n > 0 -> let t'' = detype d flags avoid env sigma t' in let id = next_name_away na' avoid in - let avoid = id::avoid and env = add_name (Name id) None t' env in + let avoid = Id.Set.add id avoid and env = add_name (Name id) None t' env in let appc = mkApp (lift 1 c,[|mkRel 1|]) in share_names d flags (n-1) ((Name id,Explicit,None,t'')::l) avoid env sigma appc c' (* If built with the f/n notation: we renounce to share names *) @@ -819,7 +822,7 @@ let rec subst_glob_constr subst = DAst.map (function | GRef (ref,u) as raw -> let ref',t = subst_global subst ref in if ref' == ref then raw else - DAst.get (detype Now false [] (Global.env()) Evd.empty (EConstr.of_constr t)) + DAst.get (detype Now false Id.Set.empty (Global.env()) Evd.empty (EConstr.of_constr t)) | GSort _ | GVar _ diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli index 67c852af3..b70bfd83c 100644 --- a/pretyping/detyping.mli +++ b/pretyping/detyping.mli @@ -35,16 +35,16 @@ val subst_glob_constr : substitution -> glob_constr -> glob_constr [isgoal] tells if naming must avoid global-level synonyms as intro does [ctx] gives the names of the free variables *) -val detype_names : bool -> Id.t list -> names_context -> env -> evar_map -> constr -> glob_constr +val detype_names : bool -> Id.Set.t -> names_context -> env -> evar_map -> constr -> glob_constr -val detype : 'a delay -> ?lax:bool -> bool -> Id.t list -> env -> evar_map -> constr -> 'a glob_constr_g +val detype : 'a delay -> ?lax:bool -> bool -> Id.Set.t -> env -> evar_map -> constr -> 'a glob_constr_g val detype_sort : evar_map -> sorts -> glob_sort -val detype_rel_context : 'a delay -> ?lax:bool -> constr option -> Id.t list -> (names_context * env) -> +val detype_rel_context : 'a delay -> ?lax:bool -> constr option -> Id.Set.t -> (names_context * env) -> evar_map -> rel_context -> 'a glob_decl_g list -val detype_closed_glob : ?lax:bool -> bool -> Id.t list -> env -> evar_map -> closed_glob_constr -> glob_constr +val detype_closed_glob : ?lax:bool -> bool -> Id.Set.t -> env -> evar_map -> closed_glob_constr -> glob_constr (** look for the index of a named var or a nondep var as it is renamed *) val lookup_name_as_displayed : env -> evar_map -> constr -> Id.t -> int option diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml index 7f5a780f9..5f12f360b 100644 --- a/pretyping/evardefine.ml +++ b/pretyping/evardefine.ml @@ -72,7 +72,7 @@ let define_pure_evar_as_product evd evk = let open Context.Named.Declaration in let evi = Evd.find_undefined evd evk in let evenv = evar_env evi in - let id = next_ident_away idx (ids_of_named_context (evar_context evi)) in + let id = next_ident_away idx (Environ.ids_of_named_context_val evi.evar_hyps) in let concl = Reductionops.whd_all evenv evd (EConstr.of_constr evi.evar_concl) in let s = destSort evd concl in let evd1,(dom,u1) = @@ -127,7 +127,7 @@ let define_pure_evar_as_lambda env evd evk = | Prod (na,dom,rng) -> (evd,(na,dom,rng)) | Evar ev' -> let evd,typ = define_evar_as_product evd ev' in evd,destProd evd typ | _ -> error_not_product env evd typ in - let avoid = ids_of_named_context (evar_context evi) in + let avoid = Environ.ids_of_named_context_val evi.evar_hyps in let id = next_name_away_with_default_using_types "x" na avoid (Reductionops.whd_evar evd dom) in let newenv = push_named (LocalAssum (id, dom)) evenv in diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index ef0fb8ea6..ad1409f5b 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -679,6 +679,7 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = let filter1 = evar_filter evi1 in let src = subterm_source evk1 evi1.evar_source in let ids1 = List.map get_id (named_context_of_val sign1) in + let avoid = Environ.ids_of_named_context_val sign1 in let inst_in_sign = List.map mkVar (Filter.filter_list filter1 ids1) in let open Context.Rel.Declaration in let (sign2,filter2,inst2_in_env,inst2_in_sign,_,evd,_) = @@ -700,9 +701,9 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = (push_named_context_val d' sign, Filter.extend 1 filter, (mkRel 1)::(List.map (lift 1) inst_in_env), (mkRel 1)::(List.map (lift 1) inst_in_sign), - push_rel d env,evd,id::avoid)) + push_rel d env,evd,Id.Set.add id avoid)) rel_sign - (sign1,filter1,Array.to_list args1,inst_in_sign,env1,evd,ids1) + (sign1,filter1,Array.to_list args1,inst_in_sign,env1,evd,avoid) in let evd,ev2ty_in_sign = let s = Retyping.get_sort_of env evd ty_in_env in diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index c40a24e3b..7804cc679 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -234,7 +234,8 @@ let fold_glob_constr_with_binders g f v acc = DAst.(with_val (function let acc = Option.fold_left (f v') acc rtntypopt in List.fold_left fold_pattern acc pl | GLetTuple (nal,rtntyp,b,c) -> - f v (f v (fold_return_type_with_binders f g v acc rtntyp) b) c + f (List.fold_right (Name.fold_right g) nal v) + (f v (fold_return_type_with_binders f g v acc rtntyp) b) c | GIf (c,rtntyp,b1,b2) -> f v (f v (f v (fold_return_type_with_binders f g v acc rtntyp) c) b1) b2 | GRec (_,idl,bll,tyl,bv) -> @@ -272,17 +273,17 @@ let free_glob_vars = | _ -> fold_glob_constr_with_binders Id.Set.add vars bound vs c in fun rt -> let vs = vars Id.Set.empty Id.Set.empty rt in - Id.Set.elements vs + vs let glob_visible_short_qualid c = let rec aux acc c = match DAst.get c with | GRef (c,_) -> let qualid = Nametab.shortest_qualid_of_global Id.Set.empty c in let dir,id = Libnames.repr_qualid qualid in - if DirPath.is_empty dir then id :: acc else acc + if DirPath.is_empty dir then Id.Set.add id acc else acc | _ -> fold_glob_constr aux acc c - in aux [] c + in aux Id.Set.empty c let warn_variable_collision = let open Pp in diff --git a/pretyping/glob_ops.mli b/pretyping/glob_ops.mli index bacc8fbe4..49ea9727c 100644 --- a/pretyping/glob_ops.mli +++ b/pretyping/glob_ops.mli @@ -43,11 +43,11 @@ val fold_glob_constr : ('a -> glob_constr -> 'a) -> 'a -> glob_constr -> 'a val fold_glob_constr_with_binders : (Id.t -> 'a -> 'a) -> ('a -> 'b -> glob_constr -> 'b) -> 'a -> 'b -> glob_constr -> 'b val iter_glob_constr : (glob_constr -> unit) -> glob_constr -> unit val occur_glob_constr : Id.t -> 'a glob_constr_g -> bool -val free_glob_vars : 'a glob_constr_g -> Id.t list +val free_glob_vars : 'a glob_constr_g -> Id.Set.t val bound_glob_vars : glob_constr -> Id.Set.t (* Obsolete *) val loc_of_glob_constr : 'a glob_constr_g -> Loc.t option -val glob_visible_short_qualid : 'a glob_constr_g -> Id.t list +val glob_visible_short_qualid : 'a glob_constr_g -> Id.Set.t (* Renaming free variables using a renaming map; fails with [UnsoundRenaming] if applying the renaming would introduce diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 88ca9b5ca..b31ee03d8 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -397,8 +397,8 @@ let get_arity env ((ind,u),params) = mib.mind_params_ctxt else begin assert (Int.equal nparams mib.mind_nparams_rec); - let nnonrecparamdecls = List.length mib.mind_params_ctxt - mib.mind_nparams_rec in - snd (List.chop nnonrecparamdecls mib.mind_params_ctxt) + let nnonrecparamdecls = mib.mind_nparams - mib.mind_nparams_rec in + snd (Termops.context_chop nnonrecparamdecls mib.mind_params_ctxt) end in let parsign = Vars.subst_instance_context u parsign in let arproperlength = List.length mip.mind_arity_ctxt - List.length parsign in diff --git a/pretyping/pretyping.mllib b/pretyping/pretyping.mllib index c8b3307d7..d04dcb8e3 100644 --- a/pretyping/pretyping.mllib +++ b/pretyping/pretyping.mllib @@ -29,3 +29,4 @@ Indrec Cases Pretyping Unification +Univdecls diff --git a/pretyping/unification.ml b/pretyping/unification.ml index f090921e5..d52c3932d 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -1616,7 +1616,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = let id = let t = match ty with Some t -> t | None -> get_type_of env sigma c in let x = id_of_name_using_hdchar (Global.env()) sigma t name in - let ids = ids_of_named_context (named_context env) in + let ids = Environ.ids_of_named_context_val (named_context_val env) in if name == Anonymous then next_ident_away_in_goal x ids else if mem_named_context_val x (named_context_val env) then user_err ~hdr:"Unification.make_abstraction_core" diff --git a/pretyping/univdecls.ml b/pretyping/univdecls.ml new file mode 100644 index 000000000..d7c42d03a --- /dev/null +++ b/pretyping/univdecls.ml @@ -0,0 +1,64 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Names +open Nameops +open CErrors +open Pp + +(** Local universes and constraints declarations *) +type universe_decl = + (Id.t Loc.located list, Univ.Constraint.t) Misctypes.gen_universe_decl + +let default_univ_decl = + let open Misctypes in + { univdecl_instance = []; + univdecl_extensible_instance = true; + univdecl_constraints = Univ.Constraint.empty; + univdecl_extensible_constraints = true } + +let interp_univ_constraints env evd cstrs = + let open Misctypes in + let u_of_id x = + match x with + | Misctypes.GProp -> Loc.tag Univ.Level.prop + | GSet -> Loc.tag Univ.Level.set + | GType None | GType (Some (_, Anonymous)) -> + user_err ~hdr:"interp_constraint" + (str "Cannot declare constraints on anonymous universes") + | GType (Some (loc, Name id)) -> + try loc, Evd.universe_of_name evd (Id.to_string id) + with Not_found -> + user_err ?loc ~hdr:"interp_constraint" (str "Undeclared universe " ++ pr_id id) + in + let interp (evd,cstrs) (u, d, u') = + let lloc, ul = u_of_id u and rloc, u'l = u_of_id u' in + let cstr = (ul,d,u'l) in + let cstrs' = Univ.Constraint.add cstr cstrs in + try let evd = Evd.add_constraints evd (Univ.Constraint.singleton cstr) in + evd, cstrs' + with Univ.UniverseInconsistency e -> + user_err ~hdr:"interp_constraint" (str "Universe inconsistency" (* TODO *)) + in + List.fold_left interp (evd,Univ.Constraint.empty) cstrs + +let interp_univ_decl env decl = + let open Misctypes in + let pl = decl.univdecl_instance in + let evd = Evd.from_ctx (Evd.make_evar_universe_context env (Some pl)) in + let evd, cstrs = interp_univ_constraints env evd decl.univdecl_constraints in + let decl = { univdecl_instance = pl; + univdecl_extensible_instance = decl.univdecl_extensible_instance; + univdecl_constraints = cstrs; + univdecl_extensible_constraints = decl.univdecl_extensible_constraints } + in evd, decl + +let interp_univ_decl_opt env l = + match l with + | None -> Evd.from_env env, default_univ_decl + | Some decl -> interp_univ_decl env decl diff --git a/pretyping/univdecls.mli b/pretyping/univdecls.mli new file mode 100644 index 000000000..0c3b749cb --- /dev/null +++ b/pretyping/univdecls.mli @@ -0,0 +1,19 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Local universe and constraint declarations. *) +type universe_decl = + (Names.Id.t Loc.located list, Univ.Constraint.t) Misctypes.gen_universe_decl + +val default_univ_decl : universe_decl + +val interp_univ_decl : Environ.env -> Vernacexpr.universe_decl_expr -> + Evd.evar_map * universe_decl + +val interp_univ_decl_opt : Environ.env -> Vernacexpr.universe_decl_expr option -> + Evd.evar_map * universe_decl diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index 37204c213..102c6ef6d 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -117,7 +117,7 @@ let tag_var = tag Tag.variable let pp1 = str s in return unp pp1 pp2 | UnpBox (b,sub) as unp :: l -> - let pp1 = ppcmd_of_box b (aux sub) in + let pp1 = ppcmd_of_box b (aux (List.map snd sub)) in let pp2 = aux l in return unp pp1 pp2 | UnpCut cut as unp :: l -> diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index 5e57f5de0..10dd42ea9 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -37,11 +37,29 @@ open Decl_kinds | Some loc -> let (b,_) = Loc.unloc loc in pr_located pr_id @@ Loc.tag ~loc:(Loc.make_loc (b,b + String.length (Id.to_string id))) id - let pr_plident (lid, l) = - pr_lident lid ++ - (match l with - | Some l -> prlist_with_sep spc pr_lident l - | None -> mt()) + let pr_uconstraint (l, d, r) = + pr_glob_level l ++ spc () ++ Univ.pr_constraint_type d ++ spc () ++ + pr_glob_level r + + let pr_univdecl_instance l extensible = + prlist_with_sep spc pr_lident l ++ + (if extensible then str"+" else mt ()) + + let pr_univdecl_constraints l extensible = + if List.is_empty l && extensible then mt () + else str"|" ++ spc () ++ prlist_with_sep (fun () -> str",") pr_uconstraint l ++ + (if extensible then str"+" else mt()) + + let pr_universe_decl l = + let open Misctypes in + match l with + | None -> mt () + | Some l -> + str"@{" ++ pr_univdecl_instance l.univdecl_instance l.univdecl_extensible_instance ++ + pr_univdecl_constraints l.univdecl_constraints l.univdecl_extensible_constraints ++ str "}" + + let pr_ident_decl (lid, l) = + pr_lident lid ++ pr_universe_decl l let string_of_fqid fqid = String.concat "." (List.map Id.to_string fqid) @@ -371,24 +389,19 @@ open Decl_kinds | l -> spc() ++ hov 1 (str"(" ++ prlist_with_sep sep_v2 pr_syntax_modifier l ++ str")") - let pr_univs pl = - match pl with - | None -> mt () - | Some pl -> str"@{" ++ prlist_with_sep spc pr_lident pl ++ str"}" - - let pr_rec_definition ((((loc,id),pl),ro,bl,type_,def),ntn) = + let pr_rec_definition ((iddecl,ro,bl,type_,def),ntn) = let pr_pure_lconstr c = Flags.without_option Flags.beautify pr_lconstr c in let annot = pr_guard_annot pr_lconstr_expr bl ro in - pr_id id ++ pr_univs pl ++ pr_binders_arg bl ++ annot + pr_ident_decl iddecl ++ pr_binders_arg bl ++ annot ++ pr_type_option (fun c -> spc() ++ pr_lconstr_expr c) type_ ++ pr_opt (fun def -> str":=" ++ brk(1,2) ++ pr_pure_lconstr def) def ++ prlist (pr_decl_notation pr_constr) ntn let pr_statement head (idpl,(bl,c)) = assert (not (Option.is_empty idpl)); - let id, pl = Option.get idpl in + let idpl = Option.get idpl in hov 2 - (head ++ spc() ++ pr_lident id ++ pr_univs pl ++ spc() ++ + (head ++ spc() ++ pr_ident_decl idpl ++ spc() ++ (match bl with [] -> mt() | _ -> pr_binders bl ++ spc()) ++ str":" ++ pr_spc_lconstr c) @@ -524,12 +537,6 @@ open Decl_kinds | VernacLocal (local, v) -> return (pr_locality local ++ spc() ++ pr_vernac_body v) - (* Stm *) - | VernacStm JoinDocument -> - return (keyword "Stm JoinDocument") - | VernacStm Wait -> - return (keyword "Stm Wait") - (* Proof management *) | VernacAbortAll -> return (keyword "Abort All") @@ -692,7 +699,7 @@ open Decl_kinds return ( hov 2 ( pr_def_token d ++ spc() - ++ pr_plident id ++ binds ++ typ + ++ pr_ident_decl id ++ binds ++ typ ++ (match c with | None -> mt() | Some cc -> str" :=" ++ spc() ++ cc)) @@ -711,10 +718,7 @@ open Decl_kinds match o with | None -> (match opac with | Transparent -> keyword "Defined" - | Opaque None -> keyword "Qed" - | Opaque (Some l) -> - keyword "Qed" ++ spc() ++ str"export" ++ - prlist_with_sep (fun () -> str", ") pr_lident l) + | Opaque -> keyword "Qed") | Some id -> (if opac <> Transparent then keyword "Save" else keyword "Defined") ++ spc() ++ pr_lident id ) | VernacExactProof c -> @@ -722,7 +726,7 @@ open Decl_kinds | VernacAssumption (stre,t,l) -> let n = List.length (List.flatten (List.map fst (List.map snd l))) in let pr_params (c, (xl, t)) = - hov 2 (prlist_with_sep sep pr_plident xl ++ spc() ++ + hov 2 (prlist_with_sep sep pr_ident_decl xl ++ spc() ++ (if c then str":>" else str":" ++ spc() ++ pr_lconstr_expr t)) in let assumptions = prlist_with_sep spc (fun p -> hov 1 (str "(" ++ pr_params p ++ str ")")) l in return (hov 2 (pr_assumption_token (n > 1) stre ++ @@ -743,10 +747,10 @@ open Decl_kinds | RecordDecl (c,fs) -> pr_record_decl b c fs in - let pr_oneind key (((coe,(id,pl)),indpar,s,k,lc),ntn) = + let pr_oneind key (((coe,iddecl),indpar,s,k,lc),ntn) = hov 0 ( str key ++ spc() ++ - (if coe then str"> " else str"") ++ pr_lident id ++ pr_univs pl ++ + (if coe then str"> " else str"") ++ pr_ident_decl iddecl ++ pr_and_type_binders_arg indpar ++ pr_opt (fun s -> str":" ++ spc() ++ pr_lconstr_expr s) s ++ str" :=") ++ pr_constructor_list k lc ++ @@ -791,8 +795,8 @@ open Decl_kinds | Some Local -> keyword "Local" ++ spc () | None | Some Global -> str "" in - let pr_onecorec ((((loc,id),pl),bl,c,def),ntn) = - pr_id id ++ pr_univs pl ++ spc() ++ pr_binders bl ++ spc() ++ str":" ++ + let pr_onecorec ((iddecl,bl,c,def),ntn) = + pr_ident_decl iddecl ++ spc() ++ pr_binders bl ++ spc() ++ str":" ++ spc() ++ pr_lconstr_expr c ++ pr_opt (fun def -> str":=" ++ brk(1,2) ++ pr_lconstr def) def ++ prlist (pr_decl_notation pr_constr) ntn @@ -818,10 +822,6 @@ open Decl_kinds prlist_with_sep (fun _ -> str",") pr_lident v) ) | VernacConstraint v -> - let pr_uconstraint (l, d, r) = - pr_glob_level l ++ spc () ++ Univ.pr_constraint_type d ++ spc () ++ - pr_glob_level r - in return ( hov 2 (keyword "Constraint" ++ spc () ++ prlist_with_sep (fun _ -> str",") pr_uconstraint v) @@ -875,7 +875,7 @@ open Decl_kinds (if abst then keyword "Declare" ++ spc () else mt ()) ++ keyword "Instance" ++ (match instid with - | (loc, Name id), l -> spc () ++ pr_plident ((loc, id),l) ++ spc () + | (loc, Name id), l -> spc () ++ pr_ident_decl ((loc, id),l) ++ spc () | (_, Anonymous), _ -> mt ()) ++ pr_and_type_binders_arg sup ++ str":" ++ spc () ++ diff --git a/printing/printmod.ml b/printing/printmod.ml index 219eafda4..755e905a7 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -64,9 +64,10 @@ let get_new_id locals id = if not (Nametab.exists_module dir) then id else - get_id (id::l) (Namegen.next_ident_away id l) + get_id (Id.Set.add id l) (Namegen.next_ident_away id l) in - get_id (List.map snd locals) id + let avoid = List.fold_left (fun accu (_, id) -> Id.Set.add id accu) Id.Set.empty locals in + get_id avoid id (** Inductive declarations *) diff --git a/proofs/clenv.ml b/proofs/clenv.ml index ea60be31f..5ef7fac81 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -557,7 +557,7 @@ let make_clenv_binding_gen hyps_only n env sigma (c,t) = function let clause = mk_clenv_from_env env sigma n (c,t) in clenv_constrain_dep_args hyps_only largs clause | ExplicitBindings lbind -> - let t = rename_bound_vars_as_displayed sigma [] [] t in + let t = rename_bound_vars_as_displayed sigma Id.Set.empty [] t in let clause = mk_clenv_from_env env sigma n (c, t) in clenv_match_args lbind clause @@ -605,7 +605,7 @@ let make_evar_clause env sigma ?len t = | Some n -> assert (0 <= n); n in (** FIXME: do the renaming online *) - let t = rename_bound_vars_as_displayed sigma [] [] t in + let t = rename_bound_vars_as_displayed sigma Id.Set.empty [] t in let rec clrec (sigma, holes) n t = if n = 0 then (sigma, holes, t) else match EConstr.kind sigma t with diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 193788558..23f96b5a3 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -239,7 +239,6 @@ let get_current_proof_name = Proof_global.get_current_proof_name let get_all_proof_names = Proof_global.get_all_proof_names type lemma_possible_guards = Proof_global.lemma_possible_guards -type universe_binders = Proof_global.universe_binders let delete_proof = Proof_global.discard let delete_current_proof = Proof_global.discard_current @@ -257,6 +256,5 @@ let set_used_variables l = let get_used_variables () = Proof_global.get_used_variables () -let get_universe_binders () = - Proof_global.get_universe_binders () - +let get_universe_decl () = + Proof_global.get_universe_decl () diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index 745ee8f36..6e4ecd13b 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -23,7 +23,7 @@ open Decl_kinds proof of mutually dependent theorems) *) val start_proof : - Id.t -> ?pl:Proof_global.universe_binders -> goal_kind -> Evd.evar_map -> named_context_val -> EConstr.constr -> + Id.t -> ?pl:Univdecls.universe_decl -> goal_kind -> Evd.evar_map -> named_context_val -> EConstr.constr -> ?init_tac:unit Proofview.tactic -> Proof_global.proof_terminator -> unit @@ -67,6 +67,7 @@ val current_proof_statement : unit -> Id.t * goal_kind * EConstr.types (** {6 ... } *) + (** [solve (SelectNth n) tac] applies tactic [tac] to the [n]th subgoal of the current focused proof or raises a [UserError] if no proof is focused or if there is no [n]th subgoal. [solve SelectAll @@ -185,8 +186,8 @@ val get_used_variables : unit -> Context.Named.t option [@@ocaml.deprecated "use Proof_global.get_used_variables"] (** {6 Universe binders } *) -val get_universe_binders : unit -> Proof_global.universe_binders option -[@@ocaml.deprecated "use Proof_global.get_universe_binders"] +val get_universe_decl : unit -> Univdecls.universe_decl +[@@ocaml.deprecated "use Proof_global.get_universe_decl"] (** {6 ... } *) (** [get_current_proof_name ()] return the name of the current focused @@ -202,7 +203,3 @@ val get_all_proof_names : unit -> Id.t list type lemma_possible_guards = Proof_global.lemma_possible_guards [@@ocaml.deprecated "use Proof_global.lemma_possible_guards"] - -type universe_binders = Proof_global.universe_binders -[@@ocaml.deprecated "use Proof_global.universe_binders"] - diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 2ade797f6..cd4d1dcf6 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -69,7 +69,6 @@ let _ = (* Extra info on proofs. *) type lemma_possible_guards = int list list type proof_universes = Evd.evar_universe_context * Universes.universe_binders option -type universe_binders = Id.t Loc.located list type proof_object = { id : Names.Id.t; @@ -94,7 +93,7 @@ type pstate = { proof : Proof.proof; strength : Decl_kinds.goal_kind; mode : proof_mode CEphemeron.key; - universe_binders: universe_binders option; + universe_decl: Univdecls.universe_decl; } let make_terminator f = f @@ -230,15 +229,22 @@ let activate_proof_mode mode = let disactivate_current_proof_mode () = CEphemeron.iter_opt !current_proof_mode (fun x -> x.reset ()) -(** [start_proof sigma id str goals terminator] starts a proof of name +let default_universe_decl = + let open Misctypes in + { univdecl_instance = []; + univdecl_extensible_instance = true; + univdecl_constraints = Univ.Constraint.empty; + univdecl_extensible_constraints = true } + +(** [start_proof sigma id pl str goals terminator] starts a proof of name [id] with goals [goals] (a list of pairs of environment and conclusion); [str] describes what kind of theorem/definition this is (spiwack: for potential printing, I believe is used only by closing commands and the xml plugin); [terminator] is used at the end of the proof to close the proof. The proof is started in the evar map [sigma] (which can typically contain universe - constraints). *) -let start_proof sigma id ?pl str goals terminator = + constraints), and with universe bindings pl. *) +let start_proof sigma id ?(pl=default_universe_decl) str goals terminator = let initial_state = { pid = id; terminator = CEphemeron.create terminator; @@ -247,10 +253,10 @@ let start_proof sigma id ?pl str goals terminator = section_vars = None; strength = str; mode = find_proof_mode "No"; - universe_binders = pl } in + universe_decl = pl } in push initial_state pstates -let start_dependent_proof id ?pl str goals terminator = +let start_dependent_proof id ?(pl=default_universe_decl) str goals terminator = let initial_state = { pid = id; terminator = CEphemeron.create terminator; @@ -259,11 +265,11 @@ let start_dependent_proof id ?pl str goals terminator = section_vars = None; strength = str; mode = find_proof_mode "No"; - universe_binders = pl } in + universe_decl = pl } in push initial_state pstates let get_used_variables () = (cur_pstate ()).section_vars -let get_universe_binders () = (cur_pstate ()).universe_binders +let get_universe_decl () = (cur_pstate ()).universe_decl let proof_using_auto_clear = ref false let _ = Goptions.declare_bool_option @@ -312,20 +318,21 @@ let get_open_goals () = let constrain_variables init uctx = let levels = Univ.Instance.levels (Univ.UContext.instance init) in - let cstrs = UState.constrain_variables levels uctx in - Univ.ContextSet.add_constraints cstrs (UState.context_set uctx) + UState.constrain_variables levels uctx type closed_proof_output = (Term.constr * Safe_typing.private_constants) list * Evd.evar_universe_context let close_proof ~keep_body_ucst_separate ?feedback_id ~now (fpl : closed_proof_output Future.computation) = - let { pid; section_vars; strength; proof; terminator; universe_binders } = + let { pid; section_vars; strength; proof; terminator; universe_decl } = cur_pstate () in let poly = pi2 strength (* Polymorphic *) in let initial_goals = Proof.initial_goals proof in let initial_euctx = Proof.initial_euctx proof in let fpl, univs = Future.split2 fpl in let universes = if poly || now then Future.force univs else initial_euctx in + let binders, univctx = Evd.check_univ_decl (Evd.from_ctx universes) universe_decl in + let binders = if poly then Some binders else None in (* Because of dependent subgoals at the beginning of proofs, we could have existential variables in the initial types of goals, we need to normalise them for the kernel. *) @@ -349,53 +356,54 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now let initunivs = Evd.evar_context_universe_context initial_euctx in let ctx = constrain_variables initunivs universes in (* For vi2vo compilation proofs are computed now but we need to - * complement the univ constraints of the typ with the ones of - * the body. So we keep the two sets distinct. *) + complement the univ constraints of the typ with the ones of + the body. So we keep the two sets distinct. *) let used_univs = Univ.LSet.union used_univs_body used_univs_typ in - let ctx_body = Univops.restrict_universe_context ctx used_univs in - (initunivs, typ), ((body, ctx_body), eff) + let ctx_body = UState.restrict ctx used_univs in + let _, univs = Evd.check_univ_decl (Evd.from_ctx ctx_body) universe_decl in + (initunivs, typ), ((body, Univ.ContextSet.of_context univs), eff) else - let initunivs = Univ.UContext.empty in - let ctx = constrain_variables initunivs universes in (* Since the proof is computed now, we can simply have 1 set of - * constraints in which we merge the ones for the body and the ones - * for the typ *) + constraints in which we merge the ones for the body and the ones + for the typ. We recheck the declaration after restricting with + the actually used universes. + TODO: check if restrict is really necessary now. *) let used_univs = Univ.LSet.union used_univs_body used_univs_typ in - let ctx = Univops.restrict_universe_context ctx used_univs in - let univs = Univ.ContextSet.to_context ctx in + let ctx = UState.restrict universes used_univs in + let _, univs = Evd.check_univ_decl (Evd.from_ctx ctx) universe_decl in (univs, typ), ((body, Univ.ContextSet.empty), eff) in fun t p -> Future.split2 (Future.chain ~pure:true p (make_body t)) else fun t p -> - let initunivs = Evd.evar_context_universe_context initial_euctx in - Future.from_val (initunivs, nf t), + Future.from_val (univctx, nf t), Future.chain ~pure:true p (fun (pt,eff) -> - (pt,constrain_variables initunivs (Future.force univs)),eff) + (* Deferred proof, we already checked the universe declaration with + the initial universes, ensure that the final universes respect + the declaration as well. If the declaration is non-extensible, + this will prevent the body from adding universes and constraints. *) + let bodyunivs = constrain_variables univctx (Future.force univs) in + let _, univs = Evd.check_univ_decl (Evd.from_ctx bodyunivs) universe_decl in + (pt,Univ.ContextSet.of_context univs),eff) in - let entries = - Future.map2 (fun p (_, t) -> - let t = EConstr.Unsafe.to_constr t in - let univstyp, body = make_body t p in - let univs, typ = Future.force univstyp in - let univs = - if poly then Entries.Polymorphic_const_entry univs - else Entries.Monomorphic_const_entry univs - in - { Entries. - const_entry_body = body; - const_entry_secctx = section_vars; - const_entry_feedback = feedback_id; - const_entry_type = Some typ; - const_entry_inline_code = false; - const_entry_opaque = true; - const_entry_universes = univs; - }) - fpl initial_goals in - let binders = - Option.map (fun names -> fst (Evd.universe_context ~names (Evd.from_ctx universes))) - universe_binders + let entry_fn p (_, t) = + let t = EConstr.Unsafe.to_constr t in + let univstyp, body = make_body t p in + let univs, typ = Future.force univstyp in + let univs = + if poly then Entries.Polymorphic_const_entry univs + else Entries.Monomorphic_const_entry univs + in + {Entries. + const_entry_body = body; + const_entry_secctx = section_vars; + const_entry_feedback = feedback_id; + const_entry_type = Some typ; + const_entry_inline_code = false; + const_entry_opaque = true; + const_entry_universes = univs; } in + let entries = Future.map2 entry_fn fpl initial_goals in { id = pid; entries = entries; persistence = strength; universes = (universes, binders) }, fun pr_ending -> CEphemeron.get terminator pr_ending diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index 52f5f7404..8c0f6ad85 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -34,7 +34,7 @@ val compact_the_proof : unit -> unit values. *) type lemma_possible_guards = int list list type proof_universes = Evd.evar_universe_context * Universes.universe_binders option -type universe_binders = Names.Id.t Loc.located list + type proof_object = { id : Names.Id.t; entries : Safe_typing.private_constants Entries.definition_entry list; @@ -54,21 +54,23 @@ type closed_proof = proof_object * proof_terminator val make_terminator : (proof_ending -> unit) -> proof_terminator val apply_terminator : proof_terminator -> proof_ending -> unit -(** [start_proof id str goals terminator] starts a proof of name [id] +(** [start_proof id str pl goals terminator] starts a proof of name [id] with goals [goals] (a list of pairs of environment and conclusion); [str] describes what kind of theorem/definition this is (spiwack: for potential printing, I believe is used only by closing commands and the xml plugin); [terminator] is used at the - end of the proof to close the proof. *) + end of the proof to close the proof. The proof is started in the + evar map [sigma] (which can typically contain universe + constraints), and with universe bindings pl. *) val start_proof : - Evd.evar_map -> Names.Id.t -> ?pl:universe_binders -> + Evd.evar_map -> Names.Id.t -> ?pl:Univdecls.universe_decl -> Decl_kinds.goal_kind -> (Environ.env * EConstr.types) list -> proof_terminator -> unit (** Like [start_proof] except that there may be dependencies between initial goals. *) val start_dependent_proof : - Names.Id.t -> ?pl:universe_binders -> Decl_kinds.goal_kind -> + Names.Id.t -> ?pl:Univdecls.universe_decl -> Decl_kinds.goal_kind -> Proofview.telescope -> proof_terminator -> unit (** Update the proofs global environment after a side-effecting command @@ -119,7 +121,8 @@ val set_used_variables : Names.Id.t list -> Context.Named.t * Names.Id.t Loc.located list val get_used_variables : unit -> Context.Named.t option -val get_universe_binders : unit -> universe_binders option +(** Get the universe declaration associated to the current proof. *) +val get_universe_decl : unit -> Univdecls.universe_decl module V82 : sig val get_current_initial_conclusions : unit -> Names.Id.t *(EConstr.types list * diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index a4d662e0a..a8ec4d8ca 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -64,15 +64,11 @@ let pf_get_hyp_typ gls id = id |> pf_get_hyp gls |> NamedDecl.get_type let pf_ids_of_hyps gls = ids_of_named_context (pf_hyps gls) +let pf_ids_set_of_hyps gls = + Environ.ids_of_named_context_val (Environ.named_context_val (pf_env gls)) let pf_get_new_id id gls = - next_ident_away id (pf_ids_of_hyps gls) - -let pf_get_new_ids ids gls = - let avoid = pf_ids_of_hyps gls in - List.fold_right - (fun id acc -> (next_ident_away id (acc@avoid))::acc) - ids [] + next_ident_away id (pf_ids_set_of_hyps gls) let pf_global gls id = EConstr.of_constr (Universes.constr_of_global (Constrintern.construct_reference (pf_hyps gls) id)) @@ -177,8 +173,14 @@ module New = struct let hyps = Proofview.Goal.hyps gl in ids_of_named_context hyps + let pf_ids_set_of_hyps gl = + (** We only get the identifiers in [hyps] *) + let gl = Proofview.Goal.assume gl in + let env = Proofview.Goal.env gl in + Environ.ids_of_named_context_val (Environ.named_context_val env) + let pf_get_new_id id gl = - let ids = pf_ids_of_hyps gl in + let ids = pf_ids_set_of_hyps gl in next_ident_away id ids let pf_get_hyp id gl = diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index 93bf428fd..7e6d83b10 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -48,7 +48,6 @@ val pf_get_hyp : goal sigma -> Id.t -> named_declaration val pf_get_hyp_typ : goal sigma -> Id.t -> types val pf_get_new_id : Id.t -> goal sigma -> Id.t -val pf_get_new_ids : Id.t list -> goal sigma -> Id.t list val pf_reduction_of_red_expr : goal sigma -> red_expr -> constr -> evar_map * constr @@ -120,6 +119,7 @@ module New : sig val pf_get_new_id : identifier -> 'a Proofview.Goal.t -> identifier val pf_ids_of_hyps : 'a Proofview.Goal.t -> identifier list + val pf_ids_set_of_hyps : 'a Proofview.Goal.t -> Id.Set.t val pf_hyps_types : 'a Proofview.Goal.t -> (identifier * types) list val pf_get_hyp : identifier -> 'a Proofview.Goal.t -> named_declaration diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index 31ede2d8b..5d9b595d3 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -237,7 +237,7 @@ module Make(T : Task) = struct type queue = { active : Pool.pool; queue : (T.task * expiration) TQueue.t; - cleaner : Thread.t; + cleaner : Thread.t option; } let create size = @@ -250,7 +250,7 @@ module Make(T : Task) = struct { active = Pool.create queue ~size; queue; - cleaner = Thread.create cleaner queue; + cleaner = if size > 0 then Some (Thread.create cleaner queue) else None; } let destroy { active; queue } = diff --git a/stm/stm.ml b/stm/stm.ml index 3386044f2..984a87429 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -1044,12 +1044,22 @@ end = struct (* {{{ *) match f acc (id, vcs, ids, tactic, undo) with | `Stop x -> x | `Cont acc -> next acc - + + let undo_costly_in_batch_mode = + CWarnings.create ~name:"undo-batch-mode" ~category:"non-interactive" Pp.(fun v -> + str "Command " ++ Ppvernac.pr_vernac v ++ + str (" is not recommended in batch mode. In particular, going back in the document" ^ + " is not efficient in batch mode due to Coq not caching previous states for memory optimization reasons." ^ + " If your use is intentional, you may want to disable this warning and pass" ^ + " the \"-async-proofs-cache force\" option to Coq.")) + let undo_vernac_classifier v = + if !Flags.batch_mode && !Flags.async_proofs_cache <> Some Flags.Force + then undo_costly_in_batch_mode v; try match v with | VernacResetInitial -> - VtStm (VtBack Stateid.initial, true), VtNow + VtBack (true, Stateid.initial), VtNow | VernacResetName (_,name) -> let id = VCS.get_branch_pos (VCS.current_branch ()) in (try @@ -1057,20 +1067,20 @@ end = struct (* {{{ *) fold_until (fun b (id,_,label,_,_) -> if b then `Stop id else `Cont (List.mem name label)) false id in - VtStm (VtBack oid, true), VtNow + VtBack (true, oid), VtNow with Not_found -> - VtStm (VtBack id, true), VtNow) + VtBack (true, id), VtNow) | VernacBack n -> let id = VCS.get_branch_pos (VCS.current_branch ()) in let oid = fold_until (fun n (id,_,_,_,_) -> if Int.equal n 0 then `Stop id else `Cont (n-1)) n id in - VtStm (VtBack oid, true), VtNow + VtBack (true, oid), VtNow | VernacUndo n -> let id = VCS.get_branch_pos (VCS.current_branch ()) in let oid = fold_until (fun n (id,_,_,tactic,undo) -> let value = (if tactic then 1 else 0) - undo in if Int.equal n 0 then `Stop id else `Cont (n-value)) n id in - VtStm (VtBack oid, true), VtLater + VtBack (true, oid), VtLater | VernacUndoTo _ | VernacRestart as e -> let m = match e with VernacUndoTo m -> m | _ -> 0 in @@ -1087,16 +1097,16 @@ end = struct (* {{{ *) 0 id in let oid = fold_until (fun n (id,_,_,_,_) -> if Int.equal n 0 then `Stop id else `Cont (n-1)) (n-m-1) id in - VtStm (VtBack oid, true), VtLater + VtBack (true, oid), VtLater | VernacAbortAll -> let id = VCS.get_branch_pos (VCS.current_branch ()) in let oid = fold_until (fun () (id,vcs,_,_,_) -> match Vcs_.branches vcs with [_] -> `Stop id | _ -> `Cont ()) () id in - VtStm (VtBack oid, true), VtLater + VtBack (true, oid), VtLater | VernacBacktrack (id,_,_) | VernacBackTo id -> - VtStm (VtBack (Stateid.of_int id), not !Flags.batch_mode), VtNow + VtBack (not !Flags.batch_mode, Stateid.of_int id), VtNow | _ -> VtUnknown, VtNow with | Not_found -> @@ -1385,7 +1395,7 @@ end = struct (* {{{ *) stm_vernac_interp stop ~proof:(pobject, terminator) { verbose = false; loc; indentation = 0; strlen = 0; - expr = (VernacEndProof (Proved (Opaque None,None))) }) in + expr = (VernacEndProof (Proved (Opaque,None))) }) in ignore(Future.join checked_proof); end; RespBuiltProof(proof,time) @@ -1525,7 +1535,7 @@ end = struct (* {{{ *) Reach.known_state ~cache:`No start; stm_vernac_interp stop ~proof { verbose = false; loc; indentation = 0; strlen = 0; - expr = (VernacEndProof (Proved (Opaque None,None))) }; + expr = (VernacEndProof (Proved (Opaque,None))) }; `OK proof end with e -> @@ -1976,7 +1986,6 @@ let collect_proof keep cur hd brkind id = | id :: _ -> Names.Id.to_string id in let loc = (snd cur).loc in let rec is_defined_expr = function - | VernacEndProof (Proved ((Transparent|Opaque (Some _)),_)) -> true | VernacTime (_, e) -> is_defined_expr e | VernacRedirect (_, (_, e)) -> is_defined_expr e | VernacTimeout (_, e) -> is_defined_expr e @@ -2001,24 +2010,24 @@ let collect_proof keep cur hd brkind id = | { expr = (VernacRequire _ | VernacImport _) } -> true | ast -> may_pierce_opaque ast in let parent = function Some (p, _) -> p | None -> assert false in - let is_empty = function `Async(_,_,[],_,_) | `MaybeASync(_,_,[],_,_) -> true | _ -> false in + let is_empty = function `Async(_,[],_,_) | `MaybeASync(_,[],_,_) -> true | _ -> false in let rec collect last accn id = let view = VCS.visit id in match view.step with | (`Sideff (ReplayCommand x,_) | `Cmd { cast = x }) - when too_complex_to_delegate x -> `Sync(no_name,None,`Print) + when too_complex_to_delegate x -> `Sync(no_name,`Print) | `Cmd { cast = x } -> collect (Some (id,x)) (id::accn) view.next | `Sideff (ReplayCommand x,_) -> collect (Some (id,x)) (id::accn) view.next (* An Alias could jump everywhere... we hope we can ignore it*) - | `Alias _ -> `Sync (no_name,None,`Alias) + | `Alias _ -> `Sync (no_name,`Alias) | `Fork((_,_,_,_::_::_), _) -> - `Sync (no_name,proof_using_ast last,`MutualProofs) + `Sync (no_name,`MutualProofs) | `Fork((_,_,Doesn'tGuaranteeOpacity,_), _) -> - `Sync (no_name,proof_using_ast last,`Doesn'tGuaranteeOpacity) + `Sync (no_name,`Doesn'tGuaranteeOpacity) | `Fork((_,hd',GuaranteesOpacity,ids), _) when has_proof_using last -> assert (VCS.Branch.equal hd hd' || VCS.Branch.equal hd VCS.edit_branch); let name = name ids in - `ASync (parent last,proof_using_ast last,accn,name,delegate name) + `ASync (parent last,accn,name,delegate name) | `Fork((_, hd', GuaranteesOpacity, ids), _) when has_proof_no_using last && not (State.is_cached_and_valid (parent last)) && !Flags.compilation_mode = Flags.BuildVio -> @@ -2027,31 +2036,32 @@ let collect_proof keep cur hd brkind id = let name, hint = name ids, get_hint_ctx loc in let t, v = proof_no_using last in v.expr <- VernacProof(t, Some hint); - `ASync (parent last,proof_using_ast last,accn,name,delegate name) + `ASync (parent last,accn,name,delegate name) with Not_found -> let name = name ids in - `MaybeASync (parent last, None, accn, name, delegate name)) + `MaybeASync (parent last, accn, name, delegate name)) | `Fork((_, hd', GuaranteesOpacity, ids), _) -> assert (VCS.Branch.equal hd hd' || VCS.Branch.equal hd VCS.edit_branch); let name = name ids in - `MaybeASync (parent last, None, accn, name, delegate name) + `MaybeASync (parent last, accn, name, delegate name) | `Sideff _ -> warn_deprecated_nested_proofs (); - `Sync (no_name,None,`NestedProof) - | _ -> `Sync (no_name,None,`Unknown) in + `Sync (no_name,`NestedProof) + | _ -> `Sync (no_name,`Unknown) in let make_sync why = function - | `Sync(name,pua,_) -> `Sync (name,pua,why) - | `MaybeASync(_,pua,_,name,_) -> `Sync (name,pua,why) - | `ASync(_,pua,_,name,_) -> `Sync (name,pua,why) in + | `Sync(name,_) -> `Sync (name,why) + | `MaybeASync(_,_,name,_) -> `Sync (name,why) + | `ASync(_,_,name,_) -> `Sync (name,why) in + let check_policy rc = if async_policy () then rc else make_sync `Policy rc in match cur, (VCS.visit id).step, brkind with | (parent, { expr = VernacExactProof _ }), `Fork _, _ | (parent, { expr = VernacTime (_, VernacExactProof _) }), `Fork _, _ -> - `Sync (no_name,None,`Immediate) + `Sync (no_name,`Immediate) | _, _, { VCS.kind = `Edit _ } -> check_policy (collect (Some cur) [] id) | _ -> - if is_defined cur then `Sync (no_name,None,`Transparent) - else if keep == VtDrop then `Sync (no_name,None,`Aborted) + if is_defined cur then `Sync (no_name,`Transparent) + else if keep == VtDrop then `Sync (no_name,`Aborted) else let rc = collect (Some cur) [] id in if is_empty rc then make_sync `AlreadyEvaluated rc @@ -2223,7 +2233,7 @@ let known_state ?(redefine_qed=false) ~cache id = ), `Yes, true | `Qed ({ qast = x; keep; brinfo; brname } as qed, eop) -> let rec aux = function - | `ASync (block_start, pua, nodes, name, delegate) -> (fun () -> + | `ASync (block_start, nodes, name, delegate) -> (fun () -> assert(keep == VtKeep || keep == VtKeepAsAxiom); let drop_pt = keep == VtKeepAsAxiom in let block_stop, exn_info, loc = eop, (id, eop), x.loc in @@ -2270,10 +2280,10 @@ let known_state ?(redefine_qed=false) ~cache id = end; Proof_global.discard_all () ), (if redefine_qed then `No else `Yes), true - | `Sync (name, _, `Immediate) -> (fun () -> + | `Sync (name, `Immediate) -> (fun () -> reach eop; stm_vernac_interp id x; Proof_global.discard_all () ), `Yes, true - | `Sync (name, pua, reason) -> (fun () -> + | `Sync (name, reason) -> (fun () -> log_processing_sync id name reason; reach eop; let wall_clock = Unix.gettimeofday () in @@ -2298,12 +2308,12 @@ let known_state ?(redefine_qed=false) ~cache id = (Printf.sprintf "%.3f" (wall_clock3 -. wall_clock2)); Proof_global.discard_all () ), `Yes, true - | `MaybeASync (start, pua, nodes, name, delegate) -> (fun () -> + | `MaybeASync (start, nodes, name, delegate) -> (fun () -> reach ~cache:`Shallow start; (* no sections *) if CList.is_empty (Environ.named_context (Global.env ())) - then Util.pi1 (aux (`ASync (start, pua, nodes, name, delegate))) () - else Util.pi1 (aux (`Sync (name, pua, `NoPU_NoHint_NoES))) () + then Util.pi1 (aux (`ASync (start, nodes, name, delegate))) () + else Util.pi1 (aux (`Sync (name, `NoPU_NoHint_NoES))) () ), (if redefine_qed then `No else `Yes), true in aux (collect_proof keep (view.next, x) brname brinfo eop) @@ -2373,6 +2383,7 @@ let finish () = | _ -> () let wait () = + finish (); Slaves.wait_all_done (); VCS.print () @@ -2386,7 +2397,6 @@ let rec join_admitted_proofs id = | _ -> join_admitted_proofs view.next let join () = - finish (); wait (); stm_prerr_endline (fun () -> "Joining the environment"); Global.join_safe_environment (); @@ -2484,14 +2494,8 @@ let process_transaction ?(newtip=Stateid.fresh ()) stm_prerr_endline (fun () -> " classified as: " ^ string_of_vernac_classification c); match c with - (* Joining various parts of the document *) - | VtStm (VtJoinDocument, b), VtNow -> join (); `Ok - | VtStm (VtWait, b), VtNow -> finish (); wait (); `Ok - | VtStm ((VtJoinDocument|VtWait),_), VtLater -> - anomaly(str"classifier: join actions cannot be classified as VtLater.") - (* Back *) - | VtStm (VtBack oid, true), w -> + | VtBack (true, oid), w -> let id = VCS.new_node ~id:newtip () in let { mine; others } = Backtrack.branches_of oid in let valid = VCS.get_branch_pos head in @@ -2510,12 +2514,12 @@ let process_transaction ?(newtip=Stateid.fresh ()) VCS.checkout_shallowest_proof_branch (); VCS.commit id (Alias (oid,x)); Backtrack.record (); if w == VtNow then finish (); `Ok - | VtStm (VtBack id, false), VtNow -> + | VtBack (false, id), VtNow -> stm_prerr_endline (fun () -> "undo to state " ^ Stateid.to_string id); Backtrack.backto id; VCS.checkout_shallowest_proof_branch (); Reach.known_state ~cache:(interactive ()) id; `Ok - | VtStm (VtBack id, false), VtLater -> + | VtBack (false, id), VtLater -> anomaly(str"classifier: VtBack + VtLater must imply part_of_script.") (* Query *) @@ -2779,8 +2783,8 @@ let query ~at ~route s = let clas = classify_vernac ast in let aast = { verbose = true; indentation; strlen; loc; expr = ast } in match clas with - | VtStm (w,_), _ -> - ignore(process_transaction aast (VtStm (w,false), VtNow)) + | VtBack (_,id), _ -> (* TODO: can this still happen ? *) + ignore(process_transaction aast (VtBack (false,id), VtNow)) | _ -> ignore(process_transaction aast (VtQuery (false, route), VtNow))) s diff --git a/stm/stm.mli b/stm/stm.mli index 188b176ba..3f01fca01 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -51,6 +51,9 @@ val edit_at : Stateid.t -> [ `NewTip | `Focus of focus ] (* Evaluates the tip of the current branch *) val finish : unit -> unit +(* Internal use (fake_ide) only, do not use *) +val wait : unit -> unit + val observe : Stateid.t -> unit val stop_worker : string -> unit diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index c2ebea961..158ad9084 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -31,8 +31,7 @@ let string_of_vernac_type = function Option.default "" proof_block_detection | VtProofMode s -> "ProofMode " ^ s | VtQuery (b, route) -> "Query " ^ string_of_in_script b ^ " route " ^ string_of_int route - | VtStm ((VtJoinDocument|VtWait), b) -> "Stm " ^ string_of_in_script b - | VtStm (VtBack _, b) -> "Stm Back " ^ string_of_in_script b + | VtBack (b, _) -> "Stm Back " ^ string_of_in_script b let string_of_vernac_when = function | VtLater -> "Later" @@ -64,9 +63,6 @@ let rec classify_vernac e = * look at the entire dag to detect this option. *) | VernacSetOption (["Universe"; "Polymorphism"],_) | VernacUnsetOption (["Universe"; "Polymorphism"]) -> VtSideff [], VtNow - (* Stm *) - | VernacStm Wait -> VtStm (VtWait, true), VtNow - | VernacStm JoinDocument -> VtStm (VtJoinDocument, true), VtNow (* Nested vernac exprs *) | VernacProgram e -> classify_vernac e | VernacLocal (_,e) -> classify_vernac e @@ -79,7 +75,7 @@ let rec classify_vernac e = | VernacFail e -> (* Fail Qed or Fail Lemma must not join/fork the DAG *) (match classify_vernac e with | ( VtQuery _ | VtProofStep _ | VtSideff _ - | VtStm _ | VtProofMode _ ), _ as x -> x + | VtBack _ | VtProofMode _ ), _ as x -> x | VtQed _, _ -> VtProofStep { parallel = `No; proof_block_detection = None }, VtNow diff --git a/tactics/auto.ml b/tactics/auto.ml index 7aa5114a4..d0424eb89 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -187,35 +187,34 @@ let _ = add_option ["Info";"Trivial"] global_info_trivial; add_option ["Info";"Auto"] global_info_auto -let no_dbg () = (Off,0,ref []) +type debug_kind = ReportForTrivial | ReportForAuto + +let no_dbg (_,whatfor,_,_) = (Off,whatfor,0,ref []) let mk_trivial_dbg debug = let d = if debug == Debug || !global_debug_trivial then Debug else if debug == Info || !global_info_trivial then Info else Off - in (d,0,ref []) - -(** Note : we start the debug depth of auto at 1 to distinguish it - for trivial (whose depth is 0). *) + in (d,ReportForTrivial,0,ref []) let mk_auto_dbg debug = let d = if debug == Debug || !global_debug_auto then Debug else if debug == Info || !global_info_auto then Info else Off - in (d,1,ref []) + in (d,ReportForAuto,0,ref []) -let incr_dbg = function (dbg,depth,trace) -> (dbg,depth+1,trace) +let incr_dbg = function (dbg,whatfor,depth,trace) -> (dbg,whatfor,depth+1,trace) (** A tracing tactic for debug/info trivial/auto *) -let tclLOG (dbg,depth,trace) pp tac = +let tclLOG (dbg,_,depth,trace) pp tac = match dbg with | Off -> tac | Debug -> (* For "debug (trivial/auto)", we directly output messages *) - let s = String.make depth '*' in + let s = String.make (depth+1) '*' in Proofview.V82.tactic begin fun gl -> try let out = Proofview.V82.of_tactic tac gl in @@ -256,23 +255,23 @@ and erase_subtree depth = function | (d,_) :: l -> if Int.equal d depth then l else erase_subtree depth l let pr_info_atom (d,pp) = - str (String.make (d-1) ' ') ++ pp () ++ str "." + str (String.make d ' ') ++ pp () ++ str "." let pr_info_trace = function - | (Info,_,{contents=(d,Some pp)::l}) -> + | (Info,_,_,{contents=(d,Some pp)::l}) -> Feedback.msg_info (prlist_with_sep fnl pr_info_atom (cleanup_info_trace d [(d,pp)] l)) | _ -> () let pr_info_nop = function - | (Info,_,_) -> Feedback.msg_info (str "idtac.") + | (Info,_,_,_) -> Feedback.msg_info (str "idtac.") | _ -> () let pr_dbg_header = function - | (Off,_,_) -> () - | (Debug,0,_) -> Feedback.msg_debug (str "(* debug trivial: *)") - | (Debug,_,_) -> Feedback.msg_debug (str "(* debug auto: *)") - | (Info,0,_) -> Feedback.msg_info (str "(* info trivial: *)") - | (Info,_,_) -> Feedback.msg_info (str "(* info auto: *)") + | (Off,_,_,_) -> () + | (Debug,ReportForTrivial,_,_) -> Feedback.msg_debug (str "(* debug trivial: *)") + | (Debug,ReportForAuto,_,_) -> Feedback.msg_debug (str "(* debug auto: *)") + | (Info,ReportForTrivial,_,_) -> Feedback.msg_info (str "(* info trivial: *)") + | (Info,ReportForAuto,_,_) -> Feedback.msg_info (str "(* info auto: *)") let tclTRY_dbg d tac = let delay f = Proofview.tclUNIT () >>= fun () -> f () in @@ -382,7 +381,7 @@ and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly;db= (unify_resolve_gen poly flags (c,cl)) (* With "(debug) trivial", we shouldn't end here, and with "debug auto" we don't display the details of inner trivial *) - (trivial_fail_db (no_dbg ()) (not (Option.is_empty flags)) db_list local_db) + (trivial_fail_db (no_dbg dbg) (not (Option.is_empty flags)) db_list local_db) | Unfold_nth c -> Proofview.Goal.enter begin fun gl -> if exists_evaluable_reference (Tacmach.New.pf_env gl) c then diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml index e16fcec7c..d912decff 100644 --- a/tactics/eqdecide.ml +++ b/tactics/eqdecide.ml @@ -73,7 +73,7 @@ let generalize_right mk typ c1 c2 = let env = Proofview.Goal.env gl in let store = Proofview.Goal.extra gl in Refine.refine ~typecheck:false begin fun sigma -> - let na = Name (next_name_away_with_default "x" Anonymous (Termops.ids_of_context env)) in + let na = Name (next_name_away_with_default "x" Anonymous (Termops.vars_of_env env)) in let newconcl = mkProd (na, typ, mk typ c1 (mkRel 1)) in let (sigma, x) = Evarutil.new_evar env sigma ~principal:true ~store newconcl in (sigma, mkApp (x, [|c2|])) @@ -114,7 +114,7 @@ let idx = Id.of_string "x" let idy = Id.of_string "y" let mkGenDecideEqGoal rectype ops g = - let hypnames = pf_ids_of_hyps g in + let hypnames = pf_ids_set_of_hyps g in let xname = next_ident_away idx hypnames and yname = next_ident_away idy hypnames in (mkNamedProd xname rectype diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index ce57682c6..bfbac7787 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -64,7 +64,7 @@ module RelDecl = Context.Rel.Declaration let hid = Id.of_string "H" let xid = Id.of_string "X" let default_id_of_sort = function InProp | InSet -> hid | InType -> xid -let fresh env id = next_global_ident_away id [] +let fresh env id = next_global_ident_away id Id.Set.empty let with_context_set ctx (b, ctx') = (b, Univ.ContextSet.union ctx ctx') diff --git a/tactics/equality.ml b/tactics/equality.ml index 3ea9538f3..e33dd2e5e 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -1003,7 +1003,7 @@ let apply_on_clause (f,t) clause = let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn = build_coq_True () >>= fun true_0 -> build_coq_False () >>= fun false_0 -> - let e = next_ident_away eq_baseid (ids_of_context env) in + let e = next_ident_away eq_baseid (vars_of_env env) in let e_env = push_named (Context.Named.Declaration.LocalAssum (e,t)) env in let discriminator = try @@ -1371,7 +1371,7 @@ let simplify_args env sigma t = | _ -> t let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac = - let e = next_ident_away eq_baseid (ids_of_context env) in + let e = next_ident_away eq_baseid (vars_of_env env) in let e_env = push_named (LocalAssum (e,t)) env in let evdref = ref sigma in let filter (cpath, t1', t2') = diff --git a/tactics/inv.ml b/tactics/inv.ml index 9495ca9c5..f391382bf 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -387,7 +387,7 @@ let rewrite_equations as_mode othin neqns names ba = Proofview.Goal.enter begin fun gl -> let (depids,nodepids) = split_dep_and_nodep ba.Tacticals.assums gl in let first_eq = ref MoveLast in - let avoid = if as_mode then List.map NamedDecl.get_id nodepids else [] in + let avoid = if as_mode then Id.Set.of_list (List.map NamedDecl.get_id nodepids) else Id.Set.empty in match othin with | Some thin -> tclTHENLIST diff --git a/tactics/leminv.ml b/tactics/leminv.ml index 967ec2a71..cc9d98f6f 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -142,7 +142,7 @@ let rec add_prods_sign env sigma t = let compute_first_inversion_scheme env sigma ind sort dep_option = let indf,realargs = dest_ind_type ind in - let allvars = ids_of_context env in + let allvars = vars_of_env env in let p = next_ident_away (Id.of_string "P") allvars in let pty,goal = if dep_option then @@ -214,7 +214,7 @@ let inversion_scheme env sigma t sort dep_option inv_op = else Context.Named.add d sign) invEnv ~init:Context.Named.empty end in - let avoid = ref [] in + let avoid = ref Id.Set.empty in let { sigma=sigma } = Proof.V82.subgoals pf in let sigma = Evd.nf_constraints sigma in let rec fill_holes c = @@ -222,7 +222,7 @@ let inversion_scheme env sigma t sort dep_option inv_op = | Evar (e,args) -> let h = next_ident_away (Id.of_string "H") !avoid in let ty,inst = Evarutil.generalize_evar_over_rels sigma (e,args) in - avoid := h::!avoid; + avoid := Id.Set.add h !avoid; ownSign := Context.Named.add (LocalAssum (h,ty)) !ownSign; applist (mkVar h, inst) | _ -> EConstr.map sigma fill_holes c @@ -232,7 +232,7 @@ let inversion_scheme env sigma t sort dep_option inv_op = let invProof = it_mkNamedLambda_or_LetIn c !ownSign in let invProof = EConstr.Unsafe.to_constr invProof in let p = Evarutil.nf_evars_universes sigma invProof in - p, Evd.universe_context sigma + p, Evd.universe_context ~names:[] ~extensible:true sigma let add_inversion_lemma name env sigma t sort dep inv_op = let invProof, ctx = inversion_scheme env sigma t sort dep inv_op in diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 5698312ae..d6c24e9cc 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -74,7 +74,7 @@ let _ = let _ = declare_bool_option - { optdepr = false; + { optdepr = true; (* remove in 8.8 *) optname = "trigger bugged context matching compatibility"; optkey = ["Tactic";"Compat";"Context"]; optread = (fun () -> !Flags.tactic_context_compat) ; @@ -384,7 +384,9 @@ let rename_hyp repl = (**************************************************************) let fresh_id_in_env avoid id env = - next_ident_away_in_goal id (avoid@ids_of_named_context (named_context env)) + let avoid' = ids_of_named_context_val (named_context_val env) in + let avoid = if Id.Set.is_empty avoid then avoid' else Id.Set.union avoid' avoid in + next_ident_away_in_goal id avoid let fresh_id avoid id gl = fresh_id_in_env avoid id (pf_env gl) @@ -412,12 +414,12 @@ let default_id env sigma decl = possibly a move to do after the introduction *) type name_flag = - | NamingAvoid of Id.t list - | NamingBasedOn of Id.t * Id.t list + | NamingAvoid of Id.Set.t + | NamingBasedOn of Id.t * Id.Set.t | NamingMustBe of Id.t Loc.located let naming_of_name = function - | Anonymous -> NamingAvoid [] + | Anonymous -> NamingAvoid Id.Set.empty | Name id -> NamingMustBe (Loc.tag id) let find_name mayrepl decl naming gl = match naming with @@ -429,7 +431,7 @@ let find_name mayrepl decl naming gl = match naming with | NamingBasedOn (id,idl) -> new_fresh_id idl id gl | NamingMustBe (loc,id) -> (* When name is given, we allow to hide a global name *) - let ids_of_hyps = Tacmach.New.pf_ids_of_hyps gl in + let ids_of_hyps = Tacmach.New.pf_ids_set_of_hyps gl in let id' = next_ident_away id ids_of_hyps in if not mayrepl && not (Id.equal id' id) then user_err ?loc (pr_id id ++ str" is already used."); @@ -603,7 +605,7 @@ let fix ido n = match ido with | None -> Proofview.Goal.enter begin fun gl -> let name = Proof_global.get_current_proof_name () in - let id = new_fresh_id [] name gl in + let id = new_fresh_id Id.Set.empty name gl in mutual_fix id n [] 0 end | Some id -> @@ -654,7 +656,7 @@ let cofix ido = match ido with | None -> Proofview.Goal.enter begin fun gl -> let name = Proof_global.get_current_proof_name () in - let id = new_fresh_id [] name gl in + let id = new_fresh_id Id.Set.empty name gl in mutual_cofix id [] 0 end | Some id -> @@ -975,13 +977,13 @@ let unfold_constr = function the type to build hyp names, we maintain an environment to be able to type dependent hyps. *) let find_intro_names ctxt gl = - let _, res = List.fold_right + let _, res, _ = List.fold_right (fun decl acc -> - let env,idl = acc in - let name = fresh_id idl (default_id env gl.sigma decl) gl in + let env,idl,avoid = acc in + let name = fresh_id avoid (default_id env gl.sigma decl) gl in let newenv = push_rel decl env in - (newenv,(name::idl))) - ctxt (pf_env gl , []) in + (newenv, name :: idl, Id.Set.add name avoid)) + ctxt (pf_env gl, [], Id.Set.empty) in List.rev res let build_intro_tac id dest tac = match dest with @@ -1021,18 +1023,18 @@ let rec intro_then_gen name_flag move_flag force_flag dep_flag tac = let intro_gen n m f d = intro_then_gen n m f d (fun _ -> Proofview.tclUNIT ()) let intro_mustbe_force id = intro_gen (NamingMustBe (Loc.tag id)) MoveLast true false -let intro_using id = intro_gen (NamingBasedOn (id,[])) MoveLast false false +let intro_using id = intro_gen (NamingBasedOn (id, Id.Set.empty)) MoveLast false false -let intro_then = intro_then_gen (NamingAvoid []) MoveLast false false -let intro = intro_gen (NamingAvoid []) MoveLast false false -let introf = intro_gen (NamingAvoid []) MoveLast true false +let intro_then = intro_then_gen (NamingAvoid Id.Set.empty) MoveLast false false +let intro = intro_gen (NamingAvoid Id.Set.empty) MoveLast false false +let introf = intro_gen (NamingAvoid Id.Set.empty) MoveLast true false let intro_avoiding l = intro_gen (NamingAvoid l) MoveLast false false let intro_move_avoid idopt avoid hto = match idopt with | None -> intro_gen (NamingAvoid avoid) hto true false | Some id -> intro_gen (NamingMustBe (Loc.tag id)) hto true false -let intro_move idopt hto = intro_move_avoid idopt [] hto +let intro_move idopt hto = intro_move_avoid idopt Id.Set.empty hto (**** Multiple introduction tactics ****) @@ -1264,7 +1266,7 @@ let cut c = with e when Pretype_errors.precatchable_exception e -> false in if is_sort then - let id = next_name_away_with_default "H" Anonymous (Tacmach.New.pf_ids_of_hyps gl) in + let id = next_name_away_with_default "H" Anonymous (Tacmach.New.pf_ids_set_of_hyps gl) in (** Backward compat: normalize [c]. *) let c = if normalize_cut then local_strong whd_betaiota sigma c else c in Refine.refine ~typecheck:false begin fun h -> @@ -1763,7 +1765,7 @@ let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind : let info = Option.cata (fun loc -> Loc.add_loc info loc) info loc in let tac = if with_destruct then - descend_in_conjunctions [] + descend_in_conjunctions Id.Set.empty (fun b id -> Tacticals.New.tclTHEN (try_main_apply b (mkVar id)) @@ -1912,7 +1914,7 @@ let apply_in_once sidecond_first with_delta with_destruct with_evars naming ]) with e when with_destruct && CErrors.noncritical e -> let (e, info) = CErrors.push e in - (descend_in_conjunctions [targetid] + (descend_in_conjunctions (Id.Set.singleton targetid) (fun b id -> aux (id::idstoclear) b (mkVar id)) (e, info) c) end @@ -2219,27 +2221,27 @@ let check_number_of_constructors expctdnumopt i nconstr = end; if i > nconstr then error "Not enough constructors." -let constructor_tac with_evars expctdnumopt i lbind = +let constructor_core with_evars cstr lbind = Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in + let env = Proofview.Goal.env gl in + let (sigma, (cons, u)) = Evd.fresh_constructor_instance env sigma cstr in + let cons = mkConstructU (cons, EInstance.make u) in + let apply_tac = general_apply true false with_evars None (Loc.tag (cons,lbind)) in + Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) apply_tac + end + +let constructor_tac with_evars expctdnumopt i lbind = + Proofview.Goal.enter begin fun gl -> let cl = Tacmach.New.pf_concl gl in - let reduce_to_quantified_ind = - Tacmach.New.pf_apply Tacred.reduce_to_quantified_ind gl - in - let (mind,redcl) = reduce_to_quantified_ind cl in - let nconstr = - Array.length (snd (Global.lookup_inductive (fst mind))).mind_consnames in - check_number_of_constructors expctdnumopt i nconstr; - - let (sigma, (cons, u)) = Evd.fresh_constructor_instance - (Proofview.Goal.env gl) sigma (fst mind, i) in - let cons = mkConstructU (cons, EInstance.make u) in - - let apply_tac = general_apply true false with_evars None (Loc.tag (cons,lbind)) in - Tacticals.New.tclTHENLIST - [ Proofview.Unsafe.tclEVARS sigma; - convert_concl_no_check redcl DEFAULTcast; - intros; apply_tac] + let ((ind,_),redcl) = Tacmach.New.pf_apply Tacred.reduce_to_quantified_ind gl cl in + let nconstr = Array.length (snd (Global.lookup_inductive ind)).mind_consnames in + check_number_of_constructors expctdnumopt i nconstr; + Tacticals.New.tclTHENLIST [ + convert_concl_no_check redcl DEFAULTcast; + intros; + constructor_core with_evars (ind, i) lbind + ] end let one_constructor i lbind = constructor_tac false None i lbind @@ -2251,23 +2253,24 @@ let one_constructor i lbind = constructor_tac false None i lbind let any_constructor with_evars tacopt = let one_constr = - let tac i = constructor_tac with_evars None i NoBindings in + let tac cstr = constructor_core with_evars cstr NoBindings in match tacopt with | None -> tac - | Some t -> fun i -> Tacticals.New.tclTHEN (tac i) t in - let rec any_constr n i () = - if Int.equal i n then one_constr i - else Tacticals.New.tclORD (one_constr i) (any_constr n (i + 1)) in + | Some t -> fun cstr -> Tacticals.New.tclTHEN (tac cstr) t in + let rec any_constr ind n i () = + if Int.equal i n then one_constr (ind,i) + else Tacticals.New.tclORD (one_constr (ind,i)) (any_constr ind n (i + 1)) in Proofview.Goal.enter begin fun gl -> let cl = Tacmach.New.pf_concl gl in - let reduce_to_quantified_ind = - Tacmach.New.pf_apply Tacred.reduce_to_quantified_ind gl - in - let mind = fst (reduce_to_quantified_ind cl) in + let (ind,_),redcl = Tacmach.New.pf_apply Tacred.reduce_to_quantified_ind gl cl in let nconstr = - Array.length (snd (Global.lookup_inductive (fst mind))).mind_consnames in + Array.length (snd (Global.lookup_inductive ind)).mind_consnames in if Int.equal nconstr 0 then error "The type has no constructors."; - any_constr nconstr 1 () + Tacticals.New.tclTHENLIST [ + convert_concl_no_check redcl DEFAULTcast; + intros; + any_constr ind nconstr 1 () + ] end let left_with_bindings with_evars = constructor_tac with_evars (Some 2) 1 @@ -2391,15 +2394,16 @@ let rewrite_hyp_then assert_style with_evars thin l2r id tac = let prepare_naming ?loc = function | IntroIdentifier id -> NamingMustBe (Loc.tag ?loc id) - | IntroAnonymous -> NamingAvoid [] - | IntroFresh id -> NamingBasedOn (id,[]) + | IntroAnonymous -> NamingAvoid Id.Set.empty + | IntroFresh id -> NamingBasedOn (id, Id.Set.empty) let rec explicit_intro_names = function | (_, IntroForthcoming _) :: l -> explicit_intro_names l -| (_, IntroNaming (IntroIdentifier id)) :: l -> id :: explicit_intro_names l +| (_, IntroNaming (IntroIdentifier id)) :: l -> Id.Set.add id (explicit_intro_names l) | (_, IntroAction (IntroOrAndPattern l)) :: l' -> let ll = match l with IntroAndPattern l -> [l] | IntroOrPattern ll -> ll in - List.flatten (List.map (fun l -> explicit_intro_names (l@l')) ll) + let fold accu l = Id.Set.union accu (explicit_intro_names (l@l')) in + List.fold_left fold Id.Set.empty ll | (_, IntroAction (IntroInjection l)) :: l' -> explicit_intro_names (l@l') | (_, IntroAction (IntroApplyOn (c,pat))) :: l' -> @@ -2407,7 +2411,7 @@ let rec explicit_intro_names = function | (_, (IntroNaming (IntroAnonymous | IntroFresh _) | IntroAction (IntroWildcard | IntroRewrite _))) :: l -> explicit_intro_names l -| [] -> [] +| [] -> Id.Set.empty let rec check_name_unicity env ok seen = function | (_, IntroForthcoming _) :: l -> check_name_unicity env ok seen l @@ -2454,8 +2458,8 @@ let make_tmp_naming avoid l = function IntroAnonymous, but at the cost of a "renaming"; Note that in the case of IntroFresh, we should use check_thin_clash_then anyway to prevent the case of an IntroFresh precisely using the wild_id *) - | IntroWildcard -> NamingBasedOn (wild_id,avoid@explicit_intro_names l) - | pat -> NamingAvoid(avoid@explicit_intro_names ((Loc.tag @@ IntroAction pat)::l)) + | IntroWildcard -> NamingBasedOn (wild_id, Id.Set.union avoid (explicit_intro_names l)) + | pat -> NamingAvoid(Id.Set.union avoid (explicit_intro_names ((Loc.tag @@ IntroAction pat)::l))) let fit_bound n = function | None -> true @@ -2496,7 +2500,7 @@ let rec intro_patterns_core with_evars b avoid ids thin destopt bound n tac = if exceed_bound n bound then error_unexpected_extra_pattern loc bound pat else match pat with | IntroForthcoming onlydeps -> - intro_forthcoming_then_gen (NamingAvoid (avoid@explicit_intro_names l)) + intro_forthcoming_then_gen (NamingAvoid (Id.Set.union avoid (explicit_intro_names l))) destopt onlydeps n bound (fun ids -> intro_patterns_core with_evars b avoid ids thin destopt bound (n+List.length ids) tac l) @@ -2519,12 +2523,12 @@ and intro_pattern_naming loc with_evars b avoid ids pat thin destopt bound n tac intro_then_gen (NamingMustBe (loc,id)) destopt true false (fun id -> intro_patterns_core with_evars b avoid (id::ids) thin destopt bound n tac l)) | IntroAnonymous -> - intro_then_gen (NamingAvoid (avoid@explicit_intro_names l)) + intro_then_gen (NamingAvoid (Id.Set.union avoid (explicit_intro_names l))) destopt true false (fun id -> intro_patterns_core with_evars b avoid (id::ids) thin destopt bound n tac l) | IntroFresh id -> (* todo: avoid thinned names to interfere with generation of fresh name *) - intro_then_gen (NamingBasedOn (id, avoid@explicit_intro_names l)) + intro_then_gen (NamingBasedOn (id, Id.Set.union avoid (explicit_intro_names l))) destopt true false (fun id -> intro_patterns_core with_evars b avoid (id::ids) thin destopt bound n tac l) @@ -2558,7 +2562,7 @@ and prepare_intros ?loc with_evars dft destopt = function | IntroAction ipat -> prepare_naming ?loc dft, (let tac thin bound = - intro_patterns_core with_evars true [] [] thin destopt bound 0 + intro_patterns_core with_evars true Id.Set.empty [] thin destopt bound 0 (fun _ l -> clear_wildcards l) in fun id -> intro_pattern_action ?loc with_evars true true ipat [] destopt tac id) @@ -2569,7 +2573,7 @@ let intro_patterns_head_core with_evars b destopt bound pat = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in check_name_unicity env [] [] pat; - intro_patterns_core with_evars b [] [] [] destopt + intro_patterns_core with_evars b Id.Set.empty [] [] destopt bound 0 (fun _ l -> clear_wildcards l) pat end @@ -2681,8 +2685,8 @@ let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = let (sigma, (newcl, eq_tac)) = match with_eq with | Some (lr,(loc,ido)) -> let heq = match ido with - | IntroAnonymous -> new_fresh_id [id] (add_prefix "Heq" id) gl - | IntroFresh heq_base -> new_fresh_id [id] heq_base gl + | IntroAnonymous -> new_fresh_id (Id.Set.singleton id) (add_prefix "Heq" id) gl + | IntroFresh heq_base -> new_fresh_id (Id.Set.singleton id) heq_base gl | IntroIdentifier id -> id in let eqdata = build_coq_eq_data () in let args = if lr then [t;mkVar id;c] else [t;c;mkVar id]in @@ -2734,8 +2738,8 @@ let mkletin_goal env sigma store with_eq dep (id,lastlhyp,ccl,c) ty = match with_eq with | Some (lr,(loc,ido)) -> let heq = match ido with - | IntroAnonymous -> fresh_id_in_env [id] (add_prefix "Heq" id) env - | IntroFresh heq_base -> fresh_id_in_env [id] heq_base env + | IntroAnonymous -> fresh_id_in_env (Id.Set.singleton id) (add_prefix "Heq" id) env + | IntroFresh heq_base -> fresh_id_in_env (Id.Set.singleton id) heq_base env | IntroIdentifier id -> if List.mem id (ids_of_named_context (named_context env)) then user_err ?loc (pr_id id ++ str" is already used."); @@ -3142,13 +3146,13 @@ let rec consume_pattern avoid na isdep gl = function | (loc,IntroForthcoming true)::names when not isdep -> consume_pattern avoid na isdep gl names | (loc,IntroForthcoming _)::names as fullpat -> - let avoid = avoid@explicit_intro_names names in + let avoid = Id.Set.union avoid (explicit_intro_names names) in ((loc,intropattern_of_name gl avoid na), fullpat) | (loc,IntroNaming IntroAnonymous)::names -> - let avoid = avoid@explicit_intro_names names in + let avoid = Id.Set.union avoid (explicit_intro_names names) in ((loc,intropattern_of_name gl avoid na), names) | (loc,IntroNaming (IntroFresh id'))::names -> - let avoid = avoid@explicit_intro_names names in + let avoid = Id.Set.union avoid (explicit_intro_names names) in ((loc,IntroNaming (IntroIdentifier (new_fresh_id avoid id' gl))), names) | pat::names -> (pat,names) @@ -3206,7 +3210,7 @@ let get_recarg_dest (recargdests,tophyp) = *) let induct_discharge with_evars dests avoid' tac (avoid,ra) names = - let avoid = avoid @ avoid' in + let avoid = Id.Set.union avoid avoid' in let rec peel_tac ra dests names thin = match ra with | (RecArg,_,deprec,recvarname) :: @@ -3302,7 +3306,7 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = (* Based on the knowledge given by the user, all constraints on the variable are generalizable in the current environment so that it is clearable after destruction *) - atomize_one (i-1) (c::args) (c::args') (id::avoid) + atomize_one (i-1) (c::args) (c::args') (Id.Set.add id avoid) | _ -> let c' = expand_projections env' sigma c in let dependent t = dependent sigma c t in @@ -3327,9 +3331,9 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = let x = fresh_id_in_env avoid id env in Tacticals.New.tclTHEN (letin_tac None (Name x) c None allHypsAndConcl) - (atomize_one (i-1) (mkVar x::args) (mkVar x::args') (x::avoid)) + (atomize_one (i-1) (mkVar x::args) (mkVar x::args') (Id.Set.add x avoid)) in - atomize_one (List.length argl) [] [] [] + atomize_one (List.length argl) [] [] Id.Set.empty end (* [cook_sign] builds the lists [beforetoclear] (preceding the @@ -3401,7 +3405,7 @@ let cook_sign hyp0_opt inhyps indvars env sigma = (* First phase from L to R: get [toclear], [decldep] and [statuslist] for the hypotheses before (= more ancient than) hyp0 (see above) *) let toclear = ref [] in - let avoid = ref [] in + let avoid = ref Id.Set.empty in let decldeps = ref [] in let ldeps = ref [] in let rstatus = ref [] in @@ -3418,7 +3422,7 @@ let cook_sign hyp0_opt inhyps indvars env sigma = is one of indvars too *) toclear := hyp::!toclear; MoveFirst (* fake value *) - end else if Id.List.mem hyp indvars then begin + end else if Id.Set.mem hyp indvars then begin (* The variables in indvars are such that they don't occur any more after generalization, so declare them to clear. *) toclear := hyp::!toclear; @@ -3428,14 +3432,14 @@ let cook_sign hyp0_opt inhyps indvars env sigma = (Option.cata (fun id -> occur_var_in_decl env sigma id decl) false hyp0_opt) in let depother = List.is_empty inhyps && - (List.exists (fun id -> occur_var_in_decl env sigma id decl) indvars || + (Id.Set.exists (fun id -> occur_var_in_decl env sigma id decl) indvars || List.exists (fun decl' -> occur_var_in_decl env sigma (NamedDecl.get_id decl') decl) !decldeps) in if not (List.is_empty inhyps) && Id.List.mem hyp inhyps || dephyp0 || depother then begin decldeps := decl::!decldeps; - avoid := hyp::!avoid; + avoid := Id.Set.add hyp !avoid; maindep := dephyp0 || !maindep; if !before then begin toclear := hyp::!toclear; @@ -3559,15 +3563,15 @@ let make_up_names n ind_opt cname = else add_prefix ind_prefix cname in let hyprecname = make_base n base_ind in let avoid = - if Int.equal n 1 (* Only one recursive argument *) || Int.equal n 0 then [] + if Int.equal n 1 (* Only one recursive argument *) || Int.equal n 0 then Id.Set.empty else (* Forbid to use cname, cname0, hyprecname and hyprecname0 *) (* in order to get names such as f1, f2, ... *) let avoid = - (make_ident (Id.to_string hyprecname) None) :: - (make_ident (Id.to_string hyprecname) (Some 0)) :: [] in + Id.Set.add (make_ident (Id.to_string hyprecname) None) + (Id.Set.singleton (make_ident (Id.to_string hyprecname) (Some 0))) in if not (String.equal (atompart_of_id cname) "H") then - (make_ident base (Some 0)) :: (make_ident base None) :: avoid + Id.Set.add (make_ident base (Some 0)) (Id.Set.add (make_ident base None) avoid) else avoid in Id.of_string base, hyprecname, avoid @@ -3726,10 +3730,10 @@ let abstract_args gl generalize_vars dep id defined f args = let env = Tacmach.New.pf_env gl in let concl = Tacmach.New.pf_concl gl in let dep = dep || local_occur_var !sigma id concl in - let avoid = ref [] in + let avoid = ref Id.Set.empty in let get_id name = let id = new_fresh_id !avoid (match name with Name n -> n | Anonymous -> Id.of_string "gen_x") gl in - avoid := id :: !avoid; id + avoid := Id.Set.add id !avoid; id in (* Build application generalized w.r.t. the argument plus the necessary eqs. From env |- c : forall G, T and args : G we build @@ -4153,7 +4157,7 @@ let given_elim hyp0 (elimc,lbind as e) gl = Tacmach.New.project gl, (e, elimt), ind_type_guess type scheme_signature = - (Id.t list * (elim_arg_kind * bool * bool * Id.t) list) array + (Id.Set.t * (elim_arg_kind * bool * bool * Id.t) list) array type eliminator_source = | ElimUsing of (eliminator * EConstr.types) * scheme_signature @@ -4344,7 +4348,7 @@ let induction_without_atomization isrec with_evars elim names lid = gt_wf_rec was taken as a functional scheme with no parameters, but by chance, because of the addition of at least hyp0 for cook_sign, it behaved as if there was a real induction arg. *) - if indvars = [] then [List.hd lid_params] else indvars in + if List.is_empty indvars then Id.Set.singleton (List.hd lid_params) else Id.Set.of_list indvars in let induct_tac elim = Tacticals.New.tclTHENLIST [ (* pattern to make the predicate appear. *) reduce (Pattern (List.map inj_with_occurrences lidcstr)) onConcl; @@ -4540,7 +4544,7 @@ let induction_gen clear_flag isrec with_evars elim let id = (* Type not the right one if partially applied but anyway for internal use*) let x = id_of_name_using_hdchar env evd t Anonymous in - new_fresh_id [] x gl in + new_fresh_id Id.Set.empty x gl in let info_arg = (is_arg_pure_hyp, not enough_applied) in pose_induction_arg_then isrec with_evars info_arg elim id arg t inhyps cls @@ -4579,7 +4583,7 @@ let induction_gen_l isrec with_evars elim names lc = let x = id_of_name_using_hdchar env sigma (type_of c) Anonymous in - let id = new_fresh_id [] x gl in + let id = new_fresh_id Id.Set.empty x gl in let newl' = List.map (fun r -> replace_term sigma c (mkVar id) r) l' in let _ = newlc:=id::!newlc in Tacticals.New.tclTHEN @@ -5016,7 +5020,7 @@ let cache_term_by_tactic_then ~opaque ?(goal_type=None) id gk tac tacK = then (s1,push_named_context_val d s2) else (Context.Named.add d s1,s2)) global_sign (Context.Named.empty, empty_named_context_val) in - let id = next_global_ident_away id (pf_ids_of_hyps gl) in + let id = next_global_ident_away id (pf_ids_set_of_hyps gl) in let concl = match goal_type with | None -> Proofview.Goal.concl gl | Some ty -> ty in diff --git a/tactics/tactics.mli b/tactics/tactics.mli index bca0c4c50..e07d514cd 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -49,18 +49,18 @@ val convert_leq : constr -> constr -> unit Proofview.tactic (** {6 Introduction tactics. } *) -val fresh_id_in_env : Id.t list -> Id.t -> env -> Id.t -val fresh_id : Id.t list -> Id.t -> goal sigma -> Id.t +val fresh_id_in_env : Id.Set.t -> Id.t -> env -> Id.t +val fresh_id : Id.Set.t -> Id.t -> goal sigma -> Id.t val find_intro_names : rel_context -> goal sigma -> Id.t list val intro : unit Proofview.tactic val introf : unit Proofview.tactic val intro_move : Id.t option -> Id.t move_location -> unit Proofview.tactic -val intro_move_avoid : Id.t option -> Id.t list -> Id.t move_location -> unit Proofview.tactic +val intro_move_avoid : Id.t option -> Id.Set.t -> Id.t move_location -> unit Proofview.tactic (** [intro_avoiding idl] acts as intro but prevents the new Id.t to belong to [idl] *) -val intro_avoiding : Id.t list -> unit Proofview.tactic +val intro_avoiding : Id.Set.t -> unit Proofview.tactic val intro_replacing : Id.t -> unit Proofview.tactic val intro_using : Id.t -> unit Proofview.tactic diff --git a/test-suite/Makefile b/test-suite/Makefile index ae426f0da..61e75fa5d 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -92,7 +92,7 @@ VSUBSYSTEMS := prerequisite success failure $(BUGS) output \ coqdoc # All subsystems -SUBSYSTEMS := $(VSUBSYSTEMS) misc bugs ide vio coqchk coq-makefile +SUBSYSTEMS := $(VSUBSYSTEMS) misc bugs ide vio coqchk coqwc coq-makefile PREREQUISITELOG = prerequisite/admit.v.log \ prerequisite/make_local.v.log prerequisite/make_notation.v.log @@ -156,6 +156,7 @@ summary: $(call summary_dir, "IDE tests", ide); \ $(call summary_dir, "VI tests", vio); \ $(call summary_dir, "Coqchk tests", coqchk); \ + $(call summary_dir, "Coqwc tests", coqwc); \ $(call summary_dir, "Coq makefile", coq-makefile); \ $(call summary_dir, "Coqdoc tests", coqdoc); \ nb_success=`find . -name '*.log' -exec tail -n2 '{}' \; | grep -e $(log_success) | wc -l`; \ @@ -498,6 +499,26 @@ coqchk: $(patsubst %.v,%.chk.log,$(wildcard coqchk/*.v)) fi; \ } > "$@" +# coqwc : test output + +coqwc : $(patsubst %.v,%.v.log,$(wildcard coqwc/*.v)) + +coqwc/%.v.log : coqwc/%.v + $(HIDE){ \ + echo $(call log_intro,$<); \ + tmpoutput=`mktemp /tmp/coqwc.XXXXXX`; \ + $(BIN)coqwc $< 2>&1 > $$tmpoutput; \ + diff -u --strip-trailing-cr coqwc/$*.out $$tmpoutput 2>&1; R=$$?; times; \ + if [ $$R = 0 ]; then \ + echo $(log_success); \ + echo " $<...Ok"; \ + else \ + echo $(log_failure); \ + echo " $<...Error! (unexpected output)"; \ + fi; \ + rm $$tmpoutput; \ + } > "$@" + # coq_makefile coq-makefile: $(patsubst %/run.sh,%.log,$(wildcard coq-makefile/*/run.sh)) diff --git a/test-suite/bugs/closed/4852.v b/test-suite/bugs/closed/4852.v new file mode 100644 index 000000000..5068ed9b9 --- /dev/null +++ b/test-suite/bugs/closed/4852.v @@ -0,0 +1,54 @@ +(** BZ 4852 : unsatisfactory Extraction Implicit for a fixpoint defined via wf *) + +Require Import Coq.Lists.List. +Import ListNotations. +Require Import Omega. + +Definition wfi_lt := well_founded_induction_type Wf_nat.lt_wf. + +Tactic Notation "wfinduction" constr(term) "on" ne_hyp_list(Hs) "as" ident(H) := + let R := fresh in + let E := fresh in + remember term as R eqn:E; + revert E; revert Hs; + induction R as [R H] using wfi_lt; + intros; subst R. + +Hint Rewrite @app_comm_cons @app_assoc @app_length : app_rws. + +Ltac solve_nat := autorewrite with app_rws in *; cbn in *; omega. + +Notation "| x |" := (length x) (at level 11, no associativity, format "'|' x '|'"). + +Definition split_acc (ls : list nat) : forall acc1 acc2, + (|acc1| = |acc2| \/ |acc1| = S (|acc2|)) -> + { lss : list nat * list nat | + let '(ls1, ls2) := lss in |ls1++ls2| = |ls++acc1++acc2| /\ (|ls1| = |ls2| \/ |ls1| = S (|ls2|))}. +Proof. + induction ls as [|a ls IHls]. all:intros acc1 acc2 H. + { exists (acc1, acc2). cbn. intuition reflexivity. } + destruct (IHls (a::acc2) acc1) as [[ls1 ls2] (H1 & H2)]. 1:solve_nat. + exists (ls1, ls2). cbn. intuition solve_nat. +Defined. + +Definition join(ls : list nat) : { rls : list nat | |rls| = |ls| }. +Proof. + wfinduction (|ls|) on ls as IH. + case (split_acc ls [] []). 1:solve_nat. + intros (ls1 & ls2) (H1 & H2). + destruct ls2 as [|a ls2]. + - exists ls1. solve_nat. + - unshelve eelim (IH _ _ ls1 eq_refl). 1:solve_nat. intros rls1 H3. + unshelve eelim (IH _ _ ls2 eq_refl). 1:solve_nat. intros rls2 H4. + exists (a :: rls1 ++ rls2). solve_nat. +Defined. + +Require Import ExtrOcamlNatInt. +Extract Inlined Constant length => "List.length". +Extract Inlined Constant app => "List.append". + +Extraction Inline wfi_lt. +Extraction Implicit wfi_lt [1 3]. +Recursive Extraction join. (* was: Error: An implicit occurs after extraction *) +Extraction TestCompile join. + diff --git a/test-suite/bugs/closed/5692.v b/test-suite/bugs/closed/5692.v new file mode 100644 index 000000000..55ef7abe4 --- /dev/null +++ b/test-suite/bugs/closed/5692.v @@ -0,0 +1,38 @@ +Set Primitive Projections. +Require Import ZArith ssreflect. + +Module Test3. + +Set Primitive Projections. + +Structure semigroup := SemiGroup { + sg_car :> Type; + sg_op : sg_car -> sg_car -> sg_car; +}. + +Structure group := Something { + group_car :> Type; + group_op : group_car -> group_car -> group_car; + group_neg : group_car -> group_car; + group_neg_op' x y : group_neg (group_op x y) = group_op (group_neg x) (group_neg y) +}. + +Coercion group_sg (X : group) : semigroup := + SemiGroup (group_car X) (group_op X). +Canonical Structure group_sg. + +Axiom group_neg_op : forall (X : group) (x y : X), + group_neg X (sg_op (group_sg X) x y) = sg_op (group_sg X) (group_neg X x) (group_neg X y). + +Canonical Structure Z_sg := SemiGroup Z Z.add . +Canonical Structure Z_group := Something Z Z.add Z.opp Z.opp_add_distr. + +Lemma foo (x y : Z) : + sg_op Z_sg (group_neg Z_group x) (group_neg Z_group y) = + group_neg Z_group (sg_op Z_sg x y). +Proof. + rewrite -group_neg_op. + reflexivity. +Qed. + +End Test3. diff --git a/test-suite/bugs/closed/5741.v b/test-suite/bugs/closed/5741.v new file mode 100644 index 000000000..f6598f192 --- /dev/null +++ b/test-suite/bugs/closed/5741.v @@ -0,0 +1,4 @@ +(* Check no anomaly in info_trivial *) + +Goal True. +info_trivial. diff --git a/test-suite/bugs/closed/5749.v b/test-suite/bugs/closed/5749.v new file mode 100644 index 000000000..81bfe351c --- /dev/null +++ b/test-suite/bugs/closed/5749.v @@ -0,0 +1,18 @@ +(* Checking computation of free vars of a term for generalization *) + +Definition Decision := fun P : Prop => {P} + {~ P}. +Class SetUnfold (P Q : Prop) : Prop := Build_SetUnfold { set_unfold : P <-> Q +}. + +Section Filter_Help. + + Context {A: Type}. + Context (fold_right : forall A B : Type, (B -> A -> A) -> A -> list B -> A). + Definition lType2 := (sigT (fun (P : A -> Prop) => forall a, Decision (P +a))). + Definition test (X: lType2) := let (x, _) := X in x. + + Global Instance foo `{fhl1 : list lType2} m Q: + SetUnfold (Q) + (fold_right _ _ (fun (s : lType2) => let (P, _) := s in and (P +m)) (Q) (fhl1)). diff --git a/test-suite/bugs/closed/5750.v b/test-suite/bugs/closed/5750.v new file mode 100644 index 000000000..6d0e21f5d --- /dev/null +++ b/test-suite/bugs/closed/5750.v @@ -0,0 +1,3 @@ +(* Check printability of the hole of the context *) +Goal 0 = 0. +match goal with |- context c [0] => idtac c end. diff --git a/test-suite/bugs/closed/5755.v b/test-suite/bugs/closed/5755.v new file mode 100644 index 000000000..e07fdcf83 --- /dev/null +++ b/test-suite/bugs/closed/5755.v @@ -0,0 +1,16 @@ +(* Sections taking care of let-ins for inductive types *) + +Section Foo. + +Inductive foo (A : Type) (x : A) (y := x) (y : A) := Foo. + +End Foo. + +Section Foo2. + +Variable B : Type. +Variable b : B. +Let c := b. +Inductive foo2 (A : Type) (x : A) (y := x) (y : A) := Foo2 : c=c -> foo2 A x y. + +End Foo2. diff --git a/test-suite/bugs/closed/5757.v b/test-suite/bugs/closed/5757.v new file mode 100644 index 000000000..0d0f2eed4 --- /dev/null +++ b/test-suite/bugs/closed/5757.v @@ -0,0 +1,76 @@ +(* Check that resolved status of evars follows "restrict" *) + +Axiom H : forall (v : nat), Some 0 = Some v -> True. +Lemma L : True. +eapply H with _; +match goal with + | |- Some 0 = Some ?v => change (Some (0+0) = Some v) +end. +Abort. + +(* The original example *) + +Set Default Proof Using "Type". + +Module heap_lang. + +Inductive expr := + | InjR (e : expr). + +Inductive val := + | InjRV (v : val). + +Bind Scope val_scope with val. + +Fixpoint of_val (v : val) : expr := + match v with + | InjRV v => InjR (of_val v) + end. + +Fixpoint to_val (e : expr) : option val := None. + +End heap_lang. +Export heap_lang. + +Module W. +Inductive expr := + | Val (v : val) + (* Sums *) + | InjR (e : expr). + +Fixpoint to_expr (e : expr) : heap_lang.expr := + match e with + | Val v => of_val v + | InjR e => heap_lang.InjR (to_expr e) + end. + +End W. + + + +Section Tests. + + Context (iProp: Type). + Context (WPre: expr -> Prop). + + Context (tac_wp_alloc : + forall (e : expr) (v : val), + to_val e = Some v -> WPre e). + + Lemma push_atomic_spec (x: val) : + WPre (InjR (of_val x)). + Proof. +(* This works. *) +eapply tac_wp_alloc with _. +match goal with + | |- to_val ?e = Some ?v => + change (to_val (W.to_expr (W.InjR (W.Val x))) = Some v) +end. +Undo. Undo. +(* This is fixed *) +eapply tac_wp_alloc with _; +match goal with + | |- to_val ?e = Some ?v => + change (to_val (W.to_expr (W.InjR (W.Val x))) = Some v) +end. +Abort. diff --git a/test-suite/bugs/closed/5765.v b/test-suite/bugs/closed/5765.v new file mode 100644 index 000000000..343ab4935 --- /dev/null +++ b/test-suite/bugs/closed/5765.v @@ -0,0 +1,3 @@ +(* 'pat binder not (yet?) allowed in parameters of inductive types *) + +Fail Inductive X '(a,b) := x. diff --git a/test-suite/bugs/closed/5769.v b/test-suite/bugs/closed/5769.v new file mode 100644 index 000000000..42573aad8 --- /dev/null +++ b/test-suite/bugs/closed/5769.v @@ -0,0 +1,20 @@ +(* Check a few naming heuristics based on types *) +(* was buggy for types names _something *) + +Inductive _foo :=. +Lemma bob : (sigT (fun x : nat => _foo)) -> _foo. +destruct 1. +exact _f. +Abort. + +Inductive _'Foo :=. +Lemma bob : (sigT (fun x : nat => _'Foo)) -> _'Foo. +destruct 1. +exact _'f. +Abort. + +Inductive ____ :=. +Lemma bob : (sigT (fun x : nat => ____)) -> ____. +destruct 1. +exact x0. +Abort. diff --git a/test-suite/complexity/constructor.v b/test-suite/complexity/constructor.v new file mode 100644 index 000000000..c5e195382 --- /dev/null +++ b/test-suite/complexity/constructor.v @@ -0,0 +1,216 @@ +(* Checks that constructor does not repeat the reduction of the conclusion *) +(* Expected time < 3.00s *) + +(* Note: on i7 2.2GZ, time decreases from 85s to 0.1s *) + +Inductive T : bool -> Prop := +| C000 : T true | C001 : T true | C002 : T true | C003 : T true | C004 : T true +| C005 : T true | C006 : T true | C007 : T true | C008 : T true | C009 : T true +| C010 : T true | C011 : T true | C012 : T true | C013 : T true | C014 : T true +| C015 : T true | C016 : T true | C017 : T true | C018 : T true | C019 : T true +| C020 : T true | C021 : T true | C022 : T true | C023 : T true | C024 : T true +| C025 : T true | C026 : T true | C027 : T true | C028 : T true | C029 : T true +| C030 : T true | C031 : T true | C032 : T true | C033 : T true | C034 : T true +| C035 : T true | C036 : T true | C037 : T true | C038 : T true | C039 : T true +| C040 : T true | C041 : T true | C042 : T true | C043 : T true | C044 : T true +| C045 : T true | C046 : T true | C047 : T true | C048 : T true | C049 : T true +| C050 : T true | C051 : T true | C052 : T true | C053 : T true | C054 : T true +| C055 : T true | C056 : T true | C057 : T true | C058 : T true | C059 : T true +| C060 : T true | C061 : T true | C062 : T true | C063 : T true | C064 : T true +| C065 : T true | C066 : T true | C067 : T true | C068 : T true | C069 : T true +| C070 : T true | C071 : T true | C072 : T true | C073 : T true | C074 : T true +| C075 : T true | C076 : T true | C077 : T true | C078 : T true | C079 : T true +| C080 : T true | C081 : T true | C082 : T true | C083 : T true | C084 : T true +| C085 : T true | C086 : T true | C087 : T true | C088 : T true | C089 : T true +| C090 : T true | C091 : T true | C092 : T true | C093 : T true | C094 : T true +| C095 : T true | C096 : T true | C097 : T true | C098 : T true | C099 : T true +| C100 : T true | C101 : T true | C102 : T true | C103 : T true | C104 : T true +| C105 : T true | C106 : T true | C107 : T true | C108 : T true | C109 : T true +| C110 : T true | C111 : T true | C112 : T true | C113 : T true | C114 : T true +| C115 : T true | C116 : T true | C117 : T true | C118 : T true | C119 : T true +| C120 : T true | C121 : T true | C122 : T true | C123 : T true | C124 : T true +| C125 : T true | C126 : T true | C127 : T true | C128 : T true | C129 : T true +| C130 : T true | C131 : T true | C132 : T true | C133 : T true | C134 : T true +| C135 : T true | C136 : T true | C137 : T true | C138 : T true | C139 : T true +| C140 : T true | C141 : T true | C142 : T true | C143 : T true | C144 : T true +| C145 : T true | C146 : T true | C147 : T true | C148 : T true | C149 : T true +| C150 : T true | C151 : T true | C152 : T true | C153 : T true | C154 : T true +| C155 : T true | C156 : T true | C157 : T true | C158 : T true | C159 : T true +| C160 : T true | C161 : T true | C162 : T true | C163 : T true | C164 : T true +| C165 : T true | C166 : T true | C167 : T true | C168 : T true | C169 : T true +| C170 : T true | C171 : T true | C172 : T true | C173 : T true | C174 : T true +| C175 : T true | C176 : T true | C177 : T true | C178 : T true | C179 : T true +| C180 : T true | C181 : T true | C182 : T true | C183 : T true | C184 : T true +| C185 : T true | C186 : T true | C187 : T true | C188 : T true | C189 : T true +| C190 : T true | C191 : T true | C192 : T true | C193 : T true | C194 : T true +| C195 : T true | C196 : T true | C197 : T true | C198 : T true | C199 : T true +| C200 : T true | C201 : T true | C202 : T true | C203 : T true | C204 : T true +| C205 : T true | C206 : T true | C207 : T true | C208 : T true | C209 : T true +| C210 : T true | C211 : T true | C212 : T true | C213 : T true | C214 : T true +| C215 : T true | C216 : T true | C217 : T true | C218 : T true | C219 : T true +| C220 : T true | C221 : T true | C222 : T true | C223 : T true | C224 : T true +| C225 : T true | C226 : T true | C227 : T true | C228 : T true | C229 : T true +| C230 : T true | C231 : T true | C232 : T true | C233 : T true | C234 : T true +| C235 : T true | C236 : T true | C237 : T true | C238 : T true | C239 : T true +| C240 : T true | C241 : T true | C242 : T true | C243 : T true | C244 : T true +| C245 : T true | C246 : T true | C247 : T true | C248 : T true | C249 : T true +| C250 : T true | C251 : T true | C252 : T true | C253 : T true | C254 : T true +| C255 : T true | C256 : T true | C257 : T true | C258 : T true | C259 : T true +| C260 : T true | C261 : T true | C262 : T true | C263 : T true | C264 : T true +| C265 : T true | C266 : T true | C267 : T true | C268 : T true | C269 : T true +| C270 : T true | C271 : T true | C272 : T true | C273 : T true | C274 : T true +| C275 : T true | C276 : T true | C277 : T true | C278 : T true | C279 : T true +| C280 : T true | C281 : T true | C282 : T true | C283 : T true | C284 : T true +| C285 : T true | C286 : T true | C287 : T true | C288 : T true | C289 : T true +| C290 : T true | C291 : T true | C292 : T true | C293 : T true | C294 : T true +| C295 : T true | C296 : T true | C297 : T true | C298 : T true | C299 : T true +| C300 : T true | C301 : T true | C302 : T true | C303 : T true | C304 : T true +| C305 : T true | C306 : T true | C307 : T true | C308 : T true | C309 : T true +| C310 : T true | C311 : T true | C312 : T true | C313 : T true | C314 : T true +| C315 : T true | C316 : T true | C317 : T true | C318 : T true | C319 : T true +| C320 : T true | C321 : T true | C322 : T true | C323 : T true | C324 : T true +| C325 : T true | C326 : T true | C327 : T true | C328 : T true | C329 : T true +| C330 : T true | C331 : T true | C332 : T true | C333 : T true | C334 : T true +| C335 : T true | C336 : T true | C337 : T true | C338 : T true | C339 : T true +| C340 : T true | C341 : T true | C342 : T true | C343 : T true | C344 : T true +| C345 : T true | C346 : T true | C347 : T true | C348 : T true | C349 : T true +| C350 : T true | C351 : T true | C352 : T true | C353 : T true | C354 : T true +| C355 : T true | C356 : T true | C357 : T true | C358 : T true | C359 : T true +| C360 : T true | C361 : T true | C362 : T true | C363 : T true | C364 : T true +| C365 : T true | C366 : T true | C367 : T true | C368 : T true | C369 : T true +| C370 : T true | C371 : T true | C372 : T true | C373 : T true | C374 : T true +| C375 : T true | C376 : T true | C377 : T true | C378 : T true | C379 : T true +| C380 : T true | C381 : T true | C382 : T true | C383 : T true | C384 : T true +| C385 : T true | C386 : T true | C387 : T true | C388 : T true | C389 : T true +| C390 : T true | C391 : T true | C392 : T true | C393 : T true | C394 : T true +| C395 : T true | C396 : T true | C397 : T true | C398 : T true | C399 : T true +| C400 : T true | C401 : T true | C402 : T true | C403 : T true | C404 : T true +| C405 : T true | C406 : T true | C407 : T true | C408 : T true | C409 : T true +| C410 : T true | C411 : T true | C412 : T true | C413 : T true | C414 : T true +| C415 : T true | C416 : T true | C417 : T true | C418 : T true | C419 : T true +| C420 : T true | C421 : T true | C422 : T true | C423 : T true | C424 : T true +| C425 : T true | C426 : T true | C427 : T true | C428 : T true | C429 : T true +| C430 : T true | C431 : T true | C432 : T true | C433 : T true | C434 : T true +| C435 : T true | C436 : T true | C437 : T true | C438 : T true | C439 : T true +| C440 : T true | C441 : T true | C442 : T true | C443 : T true | C444 : T true +| C445 : T true | C446 : T true | C447 : T true | C448 : T true | C449 : T true +| C450 : T true | C451 : T true | C452 : T true | C453 : T true | C454 : T true +| C455 : T true | C456 : T true | C457 : T true | C458 : T true | C459 : T true +| C460 : T true | C461 : T true | C462 : T true | C463 : T true | C464 : T true +| C465 : T true | C466 : T true | C467 : T true | C468 : T true | C469 : T true +| C470 : T true | C471 : T true | C472 : T true | C473 : T true | C474 : T true +| C475 : T true | C476 : T true | C477 : T true | C478 : T true | C479 : T true +| C480 : T true | C481 : T true | C482 : T true | C483 : T true | C484 : T true +| C485 : T true | C486 : T true | C487 : T true | C488 : T true | C489 : T true +| C490 : T true | C491 : T true | C492 : T true | C493 : T true | C494 : T true +| C495 : T true | C496 : T true | C497 : T true | C498 : T true | C499 : T true +| C500 : T true | C501 : T true | C502 : T true | C503 : T true | C504 : T true +| C505 : T true | C506 : T true | C507 : T true | C508 : T true | C509 : T true +| C510 : T true | C511 : T true | C512 : T true | C513 : T true | C514 : T true +| C515 : T true | C516 : T true | C517 : T true | C518 : T true | C519 : T true +| C520 : T true | C521 : T true | C522 : T true | C523 : T true | C524 : T true +| C525 : T true | C526 : T true | C527 : T true | C528 : T true | C529 : T true +| C530 : T true | C531 : T true | C532 : T true | C533 : T true | C534 : T true +| C535 : T true | C536 : T true | C537 : T true | C538 : T true | C539 : T true +| C540 : T true | C541 : T true | C542 : T true | C543 : T true | C544 : T true +| C545 : T true | C546 : T true | C547 : T true | C548 : T true | C549 : T true +| C550 : T true | C551 : T true | C552 : T true | C553 : T true | C554 : T true +| C555 : T true | C556 : T true | C557 : T true | C558 : T true | C559 : T true +| C560 : T true | C561 : T true | C562 : T true | C563 : T true | C564 : T true +| C565 : T true | C566 : T true | C567 : T true | C568 : T true | C569 : T true +| C570 : T true | C571 : T true | C572 : T true | C573 : T true | C574 : T true +| C575 : T true | C576 : T true | C577 : T true | C578 : T true | C579 : T true +| C580 : T true | C581 : T true | C582 : T true | C583 : T true | C584 : T true +| C585 : T true | C586 : T true | C587 : T true | C588 : T true | C589 : T true +| C590 : T true | C591 : T true | C592 : T true | C593 : T true | C594 : T true +| C595 : T true | C596 : T true | C597 : T true | C598 : T true | C599 : T true +| C600 : T true | C601 : T true | C602 : T true | C603 : T true | C604 : T true +| C605 : T true | C606 : T true | C607 : T true | C608 : T true | C609 : T true +| C610 : T true | C611 : T true | C612 : T true | C613 : T true | C614 : T true +| C615 : T true | C616 : T true | C617 : T true | C618 : T true | C619 : T true +| C620 : T true | C621 : T true | C622 : T true | C623 : T true | C624 : T true +| C625 : T true | C626 : T true | C627 : T true | C628 : T true | C629 : T true +| C630 : T true | C631 : T true | C632 : T true | C633 : T true | C634 : T true +| C635 : T true | C636 : T true | C637 : T true | C638 : T true | C639 : T true +| C640 : T true | C641 : T true | C642 : T true | C643 : T true | C644 : T true +| C645 : T true | C646 : T true | C647 : T true | C648 : T true | C649 : T true +| C650 : T true | C651 : T true | C652 : T true | C653 : T true | C654 : T true +| C655 : T true | C656 : T true | C657 : T true | C658 : T true | C659 : T true +| C660 : T true | C661 : T true | C662 : T true | C663 : T true | C664 : T true +| C665 : T true | C666 : T true | C667 : T true | C668 : T true | C669 : T true +| C670 : T true | C671 : T true | C672 : T true | C673 : T true | C674 : T true +| C675 : T true | C676 : T true | C677 : T true | C678 : T true | C679 : T true +| C680 : T true | C681 : T true | C682 : T true | C683 : T true | C684 : T true +| C685 : T true | C686 : T true | C687 : T true | C688 : T true | C689 : T true +| C690 : T true | C691 : T true | C692 : T true | C693 : T true | C694 : T true +| C695 : T true | C696 : T true | C697 : T true | C698 : T true | C699 : T true +| C700 : T true | C701 : T true | C702 : T true | C703 : T true | C704 : T true +| C705 : T true | C706 : T true | C707 : T true | C708 : T true | C709 : T true +| C710 : T true | C711 : T true | C712 : T true | C713 : T true | C714 : T true +| C715 : T true | C716 : T true | C717 : T true | C718 : T true | C719 : T true +| C720 : T true | C721 : T true | C722 : T true | C723 : T true | C724 : T true +| C725 : T true | C726 : T true | C727 : T true | C728 : T true | C729 : T true +| C730 : T true | C731 : T true | C732 : T true | C733 : T true | C734 : T true +| C735 : T true | C736 : T true | C737 : T true | C738 : T true | C739 : T true +| C740 : T true | C741 : T true | C742 : T true | C743 : T true | C744 : T true +| C745 : T true | C746 : T true | C747 : T true | C748 : T true | C749 : T true +| C750 : T true | C751 : T true | C752 : T true | C753 : T true | C754 : T true +| C755 : T true | C756 : T true | C757 : T true | C758 : T true | C759 : T true +| C760 : T true | C761 : T true | C762 : T true | C763 : T true | C764 : T true +| C765 : T true | C766 : T true | C767 : T true | C768 : T true | C769 : T true +| C770 : T true | C771 : T true | C772 : T true | C773 : T true | C774 : T true +| C775 : T true | C776 : T true | C777 : T true | C778 : T true | C779 : T true +| C780 : T true | C781 : T true | C782 : T true | C783 : T true | C784 : T true +| C785 : T true | C786 : T true | C787 : T true | C788 : T true | C789 : T true +| C790 : T true | C791 : T true | C792 : T true | C793 : T true | C794 : T true +| C795 : T true | C796 : T true | C797 : T true | C798 : T true | C799 : T true +| C800 : T true | C801 : T true | C802 : T true | C803 : T true | C804 : T true +| C805 : T true | C806 : T true | C807 : T true | C808 : T true | C809 : T true +| C810 : T true | C811 : T true | C812 : T true | C813 : T true | C814 : T true +| C815 : T true | C816 : T true | C817 : T true | C818 : T true | C819 : T true +| C820 : T true | C821 : T true | C822 : T true | C823 : T true | C824 : T true +| C825 : T true | C826 : T true | C827 : T true | C828 : T true | C829 : T true +| C830 : T true | C831 : T true | C832 : T true | C833 : T true | C834 : T true +| C835 : T true | C836 : T true | C837 : T true | C838 : T true | C839 : T true +| C840 : T true | C841 : T true | C842 : T true | C843 : T true | C844 : T true +| C845 : T true | C846 : T true | C847 : T true | C848 : T true | C849 : T true +| C850 : T true | C851 : T true | C852 : T true | C853 : T true | C854 : T true +| C855 : T true | C856 : T true | C857 : T true | C858 : T true | C859 : T true +| C860 : T true | C861 : T true | C862 : T true | C863 : T true | C864 : T true +| C865 : T true | C866 : T true | C867 : T true | C868 : T true | C869 : T true +| C870 : T true | C871 : T true | C872 : T true | C873 : T true | C874 : T true +| C875 : T true | C876 : T true | C877 : T true | C878 : T true | C879 : T true +| C880 : T true | C881 : T true | C882 : T true | C883 : T true | C884 : T true +| C885 : T true | C886 : T true | C887 : T true | C888 : T true | C889 : T true +| C890 : T true | C891 : T true | C892 : T true | C893 : T true | C894 : T true +| C895 : T true | C896 : T true | C897 : T true | C898 : T true | C899 : T true +| C900 : T true | C901 : T true | C902 : T true | C903 : T true | C904 : T true +| C905 : T true | C906 : T true | C907 : T true | C908 : T true | C909 : T true +| C910 : T true | C911 : T true | C912 : T true | C913 : T true | C914 : T true +| C915 : T true | C916 : T true | C917 : T true | C918 : T true | C919 : T true +| C920 : T true | C921 : T true | C922 : T true | C923 : T true | C924 : T true +| C925 : T true | C926 : T true | C927 : T true | C928 : T true | C929 : T true +| C930 : T true | C931 : T true | C932 : T true | C933 : T true | C934 : T true +| C935 : T true | C936 : T true | C937 : T true | C938 : T true | C939 : T true +| C940 : T true | C941 : T true | C942 : T true | C943 : T true | C944 : T true +| C945 : T true | C946 : T true | C947 : T true | C948 : T true | C949 : T true +| C950 : T true | C951 : T true | C952 : T true | C953 : T true | C954 : T true +| C955 : T true | C956 : T true | C957 : T true | C958 : T true | C959 : T true +| C960 : T true | C961 : T true | C962 : T true | C963 : T true | C964 : T true +| C965 : T true | C966 : T true | C967 : T true | C968 : T true | C969 : T true +| C970 : T true | C971 : T true | C972 : T true | C973 : T true | C974 : T true +| C975 : T true | C976 : T true | C977 : T true | C978 : T true | C979 : T true +| C980 : T true | C981 : T true | C982 : T true | C983 : T true | C984 : T true +| C985 : T true | C986 : T true | C987 : T true | C988 : T true | C989 : T true +| C990 : T true | C991 : T true | C992 : T true | C993 : T true | C994 : T true +| C995 : T true | C996 : T true | C997 : T true | C998 : T true | C999 : T true +| C1000 : T false. + +Fixpoint expand (n : nat) : Prop := + match n with + | O => T false + | S n => expand n + end. + +Example Expand : expand 2500. +Time constructor. (* ~0.45 secs *) diff --git a/test-suite/coq-makefile/template/init.sh b/test-suite/coq-makefile/template/init.sh index 803fe8029..c4bd11c57 100755 --- a/test-suite/coq-makefile/template/init.sh +++ b/test-suite/coq-makefile/template/init.sh @@ -2,6 +2,7 @@ set -e set -o pipefail export PATH=$COQBIN:$PATH +export LC_ALL=C rm -rf theories src Makefile Makefile.conf tmp git clean -dfx || true diff --git a/test-suite/coqwc/BZ5637.out b/test-suite/coqwc/BZ5637.out new file mode 100644 index 000000000..f0b5e4f7e --- /dev/null +++ b/test-suite/coqwc/BZ5637.out @@ -0,0 +1,2 @@ + spec proof comments + 5 0 0 coqwc/BZ5637.v diff --git a/test-suite/coqwc/BZ5637.v b/test-suite/coqwc/BZ5637.v new file mode 100644 index 000000000..6428b10ff --- /dev/null +++ b/test-suite/coqwc/BZ5637.v @@ -0,0 +1,5 @@ +Local Obligation Tactic := idtac. +Definition a := 1. +Definition b := 1. +Definition c := 1. +Definition d := 1. diff --git a/test-suite/coqwc/BZ5756.out b/test-suite/coqwc/BZ5756.out new file mode 100644 index 000000000..039d1e500 --- /dev/null +++ b/test-suite/coqwc/BZ5756.out @@ -0,0 +1,2 @@ + spec proof comments + 3 0 2 coqwc/BZ5756.v diff --git a/test-suite/coqwc/BZ5756.v b/test-suite/coqwc/BZ5756.v new file mode 100644 index 000000000..ccb12076a --- /dev/null +++ b/test-suite/coqwc/BZ5756.v @@ -0,0 +1,3 @@ +Definition myNextValue := 0. (* OK *) +Definition x := myNextValue. (* not OK *) +Definition y := 0. diff --git a/test-suite/coqwc/false.out b/test-suite/coqwc/false.out new file mode 100644 index 000000000..14c5713f6 --- /dev/null +++ b/test-suite/coqwc/false.out @@ -0,0 +1,2 @@ + spec proof comments + 3 3 1 coqwc/false.v diff --git a/test-suite/coqwc/false.v b/test-suite/coqwc/false.v new file mode 100644 index 000000000..640f9ea7f --- /dev/null +++ b/test-suite/coqwc/false.v @@ -0,0 +1,8 @@ +Axiom x : nat. + +Definition foo (x : nat) := x + 1. + +Lemma bar : False. + idtac. + idtac. (* truth is overrated *) +Admitted. diff --git a/test-suite/coqwc/next-obligation.out b/test-suite/coqwc/next-obligation.out new file mode 100644 index 000000000..7a0fd777c --- /dev/null +++ b/test-suite/coqwc/next-obligation.out @@ -0,0 +1,2 @@ + spec proof comments + 1 7 0 coqwc/next-obligation.v diff --git a/test-suite/coqwc/next-obligation.v b/test-suite/coqwc/next-obligation.v new file mode 100644 index 000000000..786df9891 --- /dev/null +++ b/test-suite/coqwc/next-obligation.v @@ -0,0 +1,10 @@ +(* make sure all proof lines are counted *) + +Goal True. + Next Obligation. + idtac. + Next Obligation. + idtac. + Next Obligation. + idtac. +Qed. diff --git a/test-suite/coqwc/theorem.out b/test-suite/coqwc/theorem.out new file mode 100644 index 000000000..d01507bf7 --- /dev/null +++ b/test-suite/coqwc/theorem.out @@ -0,0 +1,2 @@ + spec proof comments + 1 9 2 coqwc/theorem.v diff --git a/test-suite/coqwc/theorem.v b/test-suite/coqwc/theorem.v new file mode 100644 index 000000000..901c9074f --- /dev/null +++ b/test-suite/coqwc/theorem.v @@ -0,0 +1,10 @@ +Theorem foo : True. +Proof. + idtac. (* comment *) + idtac. + idtac. + idtac. (* comment *) + idtac. + idtac. + auto. +Qed. diff --git a/test-suite/misc/deps-utf8.sh b/test-suite/misc/deps-utf8.sh new file mode 100755 index 000000000..13e264c09 --- /dev/null +++ b/test-suite/misc/deps-utf8.sh @@ -0,0 +1,17 @@ +# Check reading directories matching non pure ascii idents +# See bug #5715 (utf-8 working on macos X and linux) +# Windows is still not compliant +a=`uname` +if [ "$a" = "Darwin" -o "$a" = "Linux" ]; then +rm -f misc/deps/théorèmes/*.v +tmpoutput=`mktemp /tmp/coqcheck.XXXXXX` +$coqc -R misc/deps AlphaBêta misc/deps/αβ/γδ.v +R=$? +$coqtop -R misc/deps AlphaBêta -load-vernac-source misc/deps/αβ/εζ.v +S=$? +if [ $R = 0 -a $S = 0 ]; then + exit 0 +else + exit 1 +fi +fi diff --git a/test-suite/misc/deps/αβ/γδ.v b/test-suite/misc/deps/αβ/γδ.v new file mode 100644 index 000000000..f43a2d657 --- /dev/null +++ b/test-suite/misc/deps/αβ/γδ.v @@ -0,0 +1,4 @@ +Theorem simple : forall A, A -> A. +Proof. +auto. +Qed. diff --git a/test-suite/misc/deps/αβ/εζ.v b/test-suite/misc/deps/αβ/εζ.v new file mode 100644 index 000000000..e7fd25c0d --- /dev/null +++ b/test-suite/misc/deps/αβ/εζ.v @@ -0,0 +1 @@ +Require Import γδ. diff --git a/test-suite/output/UnivBinders.out b/test-suite/output/UnivBinders.out index 128bc7767..904ff68aa 100644 --- a/test-suite/output/UnivBinders.out +++ b/test-suite/output/UnivBinders.out @@ -4,3 +4,9 @@ bar@{u} = nat *) bar is universe polymorphic +foo@{u Top.8 v} = +Type@{Top.8} -> Type@{v} -> Type@{u} + : Type@{max(u+1, Top.8+1, v+1)} +(* u Top.8 v |= *) + +foo is universe polymorphic diff --git a/test-suite/output/UnivBinders.v b/test-suite/output/UnivBinders.v index d9e89e43c..8656ff1a3 100644 --- a/test-suite/output/UnivBinders.v +++ b/test-suite/output/UnivBinders.v @@ -1,7 +1,13 @@ Set Universe Polymorphism. Set Printing Universes. +Unset Strict Universe Declaration. Class Wrap A := wrap : A. Instance bar@{u} : Wrap@{u} Set. Proof nat. Print bar. + +(* The universes in the binder come first, then the extra universes in + order of appearance. *) +Definition foo@{u +} := Type -> Type@{v} -> Type@{u}. +Print foo. diff --git a/test-suite/output/auto.out b/test-suite/output/auto.out index a5b55a999..2761b87b0 100644 --- a/test-suite/output/auto.out +++ b/test-suite/output/auto.out @@ -18,3 +18,5 @@ Debug: 1 depth=5 Debug: 1.1 depth=4 simple apply or_intror Debug: 1.1.1 depth=4 intro Debug: 1.1.1.1 depth=4 exact H +(* info trivial: *) +exact I (in core). diff --git a/test-suite/output/auto.v b/test-suite/output/auto.v index a77b7b82e..92917cdfc 100644 --- a/test-suite/output/auto.v +++ b/test-suite/output/auto.v @@ -9,3 +9,7 @@ info_eauto. Undo. debug eauto. Qed. + +Goal True. +info_trivial. +Qed. diff --git a/test-suite/output/ltac_extra_args.out b/test-suite/output/ltac_extra_args.out new file mode 100644 index 000000000..77e799d35 --- /dev/null +++ b/test-suite/output/ltac_extra_args.out @@ -0,0 +1,8 @@ +The command has indeed failed with message: +Illegal tactic application: got 1 extra argument. +The command has indeed failed with message: +Illegal tactic application: got 2 extra arguments. +The command has indeed failed with message: +Illegal tactic application: got 1 extra argument. +The command has indeed failed with message: +Illegal tactic application: got 2 extra arguments. diff --git a/test-suite/output/ltac_extra_args.v b/test-suite/output/ltac_extra_args.v new file mode 100644 index 000000000..4caf619fe --- /dev/null +++ b/test-suite/output/ltac_extra_args.v @@ -0,0 +1,10 @@ +Ltac foo := idtac. +Ltac bar H := idtac. + +Goal True. +Proof. + Fail foo H. + Fail foo H H'. + Fail bar H H'. + Fail bar H H' H''. +Abort. diff --git a/test-suite/success/Inductive.v b/test-suite/success/Inductive.v index f746def5c..06f807f29 100644 --- a/test-suite/success/Inductive.v +++ b/test-suite/success/Inductive.v @@ -183,3 +183,20 @@ Module PolyNoLowerProp. Fail Check Foo True : Prop. End PolyNoLowerProp. + +(* Test building of elimination scheme with noth let-ins and + non-recursively uniform parameters *) + +Module NonRecLetIn. + + Unset Implicit Arguments. + + Inductive Ind (b:=2) (a:nat) (c:=1) : Type := + | Base : Ind a + | Rec : Ind (S a) -> Ind a. + + Check Ind_rect (fun n (b:Ind n) => b = b) + (fun n => eq_refl) + (fun n b c => f_equal (Rec n) eq_refl) 0 (Rec 0 (Base 1)). + +End NonRecLetIn. diff --git a/test-suite/success/polymorphism.v b/test-suite/success/polymorphism.v index ecc988507..7eaafc354 100644 --- a/test-suite/success/polymorphism.v +++ b/test-suite/success/polymorphism.v @@ -156,6 +156,52 @@ Polymorphic Definition twoprojs (d : dyn) := dyn_proof d = dyn_proof d. End structures. + +Module binders. + + Definition mynat@{|} := nat. + + Definition foo@{i j | i < j, i < j} (A : Type@{i}) : Type@{j}. + exact A. + Defined. + + Definition nomoreu@{i j | i < j +} (A : Type@{i}) : Type@{j}. + pose(foo:=Type). + exact A. + Fail Defined. + Abort. + + Polymorphic Definition moreu@{i j +} (A : Type@{i}) : Type@{j}. + pose(foo:=Type). + exact A. + Defined. + + Check moreu@{_ _ _ _}. + + Fail Definition morec@{i j|} (A : Type@{i}) : Type@{j} := A. + + (* By default constraints are extensible *) + Polymorphic Definition morec@{i j} (A : Type@{i}) : Type@{j} := A. + Check morec@{_ _}. + + (* Handled in proofs as well *) + Lemma bar@{i j | } : Type@{i}. + exact Type@{j}. + Fail Defined. + Abort. + + Lemma bar@{i j| i < j} : Type@{j}. + Proof. + exact Type@{i}. + Qed. + + Lemma barext@{i j|+} : Type@{j}. + Proof. + exact Type@{i}. + Qed. + +End binders. + Section cats. Local Set Universe Polymorphism. Require Import Utf8. diff --git a/test-suite/success/qed_export.v b/test-suite/success/qed_export.v deleted file mode 100644 index b3e41ab1f..000000000 --- a/test-suite/success/qed_export.v +++ /dev/null @@ -1,18 +0,0 @@ -Lemma a : True. -Proof. -assert True as H. - abstract (trivial) using exported_seff. -exact H. -Fail Qed exporting a_subproof. -Qed exporting exported_seff. -Check ( exported_seff : True ). - -Lemma b : True. -Proof. -assert True as H. - abstract (trivial) using exported_seff2. -exact H. -Qed. - -Fail Check ( exported_seff2 : True ). - diff --git a/test-suite/success/unshelve.v b/test-suite/success/unshelve.v index 672222bdd..a4fa544cd 100644 --- a/test-suite/success/unshelve.v +++ b/test-suite/success/unshelve.v @@ -9,3 +9,11 @@ unshelve (refine (F _ _ _ _)). + exact (@eq_refl bool true). + exact (@eq_refl unit tt). Qed. + +(* This was failing in 8.6, because of ?a:nat being wrongly duplicated *) + +Goal (forall a : nat, a = 0 -> True) -> True. +intros F. +unshelve (eapply (F _);clear F). +2:reflexivity. +Qed. diff --git a/tools/CoqMakefile.in b/tools/CoqMakefile.in index 56e12a1e0..cfa552602 100644 --- a/tools/CoqMakefile.in +++ b/tools/CoqMakefile.in @@ -39,6 +39,7 @@ CAMLP4O := $(COQMF_CAMLP4O) CAMLP4BIN := $(COQMF_CAMLP4BIN) CAMLP4LIB := $(COQMF_CAMLP4LIB) CAMLP4OPTIONS := $(COQMF_CAMLP4OPTIONS) +CAMLFLAGS := $(COQMF_CAMLFLAGS) HASNATDYNLINK := $(COQMF_HASNATDYNLINK) @CONF_FILE@: @PROJECT_FILE@ @@ -100,11 +101,11 @@ AFTER ?= CAMLDONTLINK=camlp5.gramlib,unix,str # OCaml binaries -CAMLC ?= "$(OCAMLFIND)" ocamlc -c -rectypes -thread -CAMLOPTC ?= "$(OCAMLFIND)" opt -c -rectypes -thread -CAMLLINK ?= "$(OCAMLFIND)" ocamlc -rectypes -thread -linkpkg -dontlink $(CAMLDONTLINK) -CAMLOPTLINK ?= "$(OCAMLFIND)" opt -rectypes -thread -linkpkg -dontlink $(CAMLDONTLINK) -CAMLDOC ?= "$(OCAMLFIND)" ocamldoc -rectypes +CAMLC ?= "$(OCAMLFIND)" ocamlc -c +CAMLOPTC ?= "$(OCAMLFIND)" opt -c +CAMLLINK ?= "$(OCAMLFIND)" ocamlc -linkpkg -dontlink $(CAMLDONTLINK) +CAMLOPTLINK ?= "$(OCAMLFIND)" opt -linkpkg -dontlink $(CAMLDONTLINK) +CAMLDOC ?= "$(OCAMLFIND)" ocamldoc CAMLDEP ?= "$(OCAMLFIND)" ocamldep -slash -ml-synonym .ml4 -ml-synonym .mlpack # DESTDIR is prepended to all installation paths @@ -114,8 +115,6 @@ DESTDIR ?= CAMLDEBUG ?= COQDEBUG ?= -# Extra flags to the OCaml compiler -CAMLFLAGS ?= # Extra packages to be linked in (as in findlib -package) CAMLPKGS ?= @@ -500,7 +499,7 @@ uninstall:: instf="$(COQLIBINSTALL)/$$df/`basename $$f`" &&\ rm -f "$$instf" &&\ echo RM "$$instf" &&\ - (rmdir "$(call concat_path,,$(COQLIBINSTALL)/$$df/)" || true); \ + (rmdir "$(call concat_path,,$(COQLIBINSTALL)/$$df/)" 2>/dev/null || true); \ done .PHONY: uninstall @@ -749,7 +748,7 @@ printenv:: # file you can extend the merlin-hook target in @LOCAL_FILE@ .merlin: $(SHOW)'FILL .merlin' - $(HIDE)echo 'FLG -rectypes -thread' > .merlin + $(HIDE)echo 'FLG $(COQMF_CAMLFLAGS)' > .merlin $(HIDE)echo 'B $(COQLIB)' >> .merlin $(HIDE)echo 'S $(COQLIB)' >> .merlin $(HIDE)$(foreach d,$(COQ_SRC_SUBDIRS), \ diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml index de76bf98b..4a9d871fd 100644 --- a/tools/coq_makefile.ml +++ b/tools/coq_makefile.ml @@ -274,7 +274,7 @@ let generate_conf oc project args = ;; let ensure_root_dir - ({ ml_includes; r_includes; + ({ ml_includes; r_includes; q_includes; v_files; ml_files; mli_files; ml4_files; mllib_files; mlpack_files } as project) = @@ -283,6 +283,7 @@ let ensure_root_dir let not_tops = List.for_all (fun s -> s <> Filename.basename s) in if exists (fun { canonical_path = x } -> x = here) ml_includes || exists (fun ({ canonical_path = x },_) -> is_prefix x here) r_includes + || exists (fun ({ canonical_path = x },_) -> is_prefix x here) q_includes || (not_tops v_files && not_tops mli_files && not_tops ml4_files && not_tops ml_files && not_tops mllib_files && not_tops mlpack_files) diff --git a/tools/coqc.ml b/tools/coqc.ml index 862225d3d..b381c5ba4 100644 --- a/tools/coqc.ml +++ b/tools/coqc.ml @@ -93,7 +93,7 @@ let parse_args () = | ("-bt"|"-debug"|"-nolib"|"-boot"|"-time"|"-profile-ltac" |"-batch"|"-noinit"|"-nois"|"-noglob"|"-no-glob" - |"-q"|"-profile"|"-just-parsing"|"-echo" |"-quiet" + |"-q"|"-profile"|"-echo" |"-quiet" |"-silent"|"-m"|"-beautify"|"-strict-implicit" |"-impredicative-set"|"-vm"|"-native-compiler" |"-indices-matter"|"-quick"|"-type-in-type" diff --git a/tools/coqdep_lexer.mll b/tools/coqdep_lexer.mll index 8eeb59898..564e20d0e 100644 --- a/tools/coqdep_lexer.mll +++ b/tools/coqdep_lexer.mll @@ -25,8 +25,6 @@ exception Fin_fichier exception Syntax_error of int*int - let field_name s = String.sub s 1 (String.length s - 1) - let unquote_string s = String.sub s 1 (String.length s - 2) @@ -40,6 +38,18 @@ let syntax_error lexbuf = raise (Syntax_error (Lexing.lexeme_start lexbuf, Lexing.lexeme_end lexbuf)) + let check_valid lexbuf s = + match Unicode.ident_refutation s with + | None -> s + | Some _ -> syntax_error lexbuf + + let get_ident lexbuf = + let s = Lexing.lexeme lexbuf in check_valid lexbuf s + + let get_field_name lexbuf = + let s = Lexing.lexeme lexbuf in + check_valid lexbuf (String.sub s 1 (String.length s - 1)) + [@@@ocaml.warning "-3"] (* String.uncapitalize_ascii since 4.03.0 GPR#124 *) let uncapitalize = String.uncapitalize [@@@ocaml.warning "+3"] @@ -52,20 +62,8 @@ let identchar = ['A'-'Z' 'a'-'z' '_' '\'' '0'-'9'] let caml_up_ident = uppercase identchar* let caml_low_ident = lowercase identchar* -let coq_firstchar = - (* This is only an approximation, refer to lib/util.ml for correct def *) - ['A'-'Z' 'a'-'z' '_'] | - (* superscript 1 *) - '\194' '\185' | - (* utf-8 latin 1 supplement *) - '\195' ['\128'-'\150'] | '\195' ['\152'-'\182'] | '\195' ['\184'-'\191'] | - (* utf-8 letters *) - '\206' (['\145'-'\161'] | ['\163'-'\187']) - '\226' ('\130' [ '\128'-'\137' ] (* subscripts *) - | '\129' [ '\176'-'\187' ] (* superscripts *) - | '\132' ['\128'-'\191'] | '\133' ['\128'-'\143']) -let coq_identchar = coq_firstchar | ['\'' '0'-'9'] -let coq_ident = coq_firstchar coq_identchar* +(* This is an overapproximation, we check correctness afterwards *) +let coq_ident = ['A'-'Z' 'a'-'z' '_' '\128'-'\255'] ['A'-'Z' 'a'-'z' '_' '\'' '0'-'9' '\128'-'\255']* let coq_field = '.' coq_ident let dot = '.' ( space+ | eof) @@ -102,7 +100,7 @@ and from_rule = parse | space+ { from_rule lexbuf } | coq_ident - { let from = coq_qual_id_tail [Lexing.lexeme lexbuf] lexbuf in + { let from = coq_qual_id_tail [get_ident lexbuf] lexbuf in consume_require (Some from) lexbuf } | eof { syntax_error lexbuf } @@ -241,7 +239,7 @@ and load_file = parse parse_dot lexbuf; Load (unquote_vfile_string s) } | coq_ident - { let s = lexeme lexbuf in skip_to_dot lexbuf; Load s } + { let s = get_ident lexbuf in skip_to_dot lexbuf; Load s } | eof { syntax_error lexbuf } | _ @@ -253,7 +251,7 @@ and require_file from = parse | space+ { require_file from lexbuf } | coq_ident - { let name = coq_qual_id_tail [Lexing.lexeme lexbuf] lexbuf in + { let name = coq_qual_id_tail [get_ident lexbuf] lexbuf in let qid = coq_qual_id_list [name] lexbuf in parse_dot lexbuf; Require (from, qid) } @@ -278,7 +276,7 @@ and coq_qual_id = parse | space+ { coq_qual_id lexbuf } | coq_ident - { coq_qual_id_tail [Lexing.lexeme lexbuf] lexbuf } + { coq_qual_id_tail [get_ident lexbuf] lexbuf } | _ { syntax_error lexbuf } @@ -288,7 +286,7 @@ and coq_qual_id_tail module_name = parse | space+ { coq_qual_id_tail module_name lexbuf } | coq_field - { coq_qual_id_tail (field_name (Lexing.lexeme lexbuf) :: module_name) lexbuf } + { coq_qual_id_tail (get_field_name lexbuf :: module_name) lexbuf } | eof { syntax_error lexbuf } | _ @@ -301,7 +299,7 @@ and coq_qual_id_list module_names = parse | space+ { coq_qual_id_list module_names lexbuf } | coq_ident - { let name = coq_qual_id_tail [Lexing.lexeme lexbuf] lexbuf in + { let name = coq_qual_id_tail [get_ident lexbuf] lexbuf in coq_qual_id_list (name :: module_names) lexbuf } | eof diff --git a/tools/coqmktop.ml b/tools/coqmktop.ml index 28a3c791c..c21db300a 100644 --- a/tools/coqmktop.ml +++ b/tools/coqmktop.ml @@ -252,6 +252,17 @@ let create_tmp_main_file modules = with reraise -> clean main_name; raise reraise +(* TODO: remove once OCaml 4.04 is adopted *) +let split_on_char sep s = + let r = ref [] in + let j = ref (String.length s) in + for i = String.length s - 1 downto 0 do + if s.[i] = sep then begin + r := String.sub s (i + 1) (!j - i - 1) :: !r; + j := i + end + done; + String.sub s 0 !j :: !r (** {6 Main } *) @@ -271,8 +282,10 @@ let main () = try (* - We add topstart.cmo explicitly because we shunted ocamlmktop wrapper. - With the coq .cma, we MUST use the -linkall option. *) + let coq_camlflags = + List.filter ((<>) "") (split_on_char ' ' Coq_config.caml_flags) in let args = - "-linkall" :: "-rectypes" :: "-w" :: "-31" :: flags @ copts @ options @ + coq_camlflags @ "-linkall" :: "-w" :: "-31" :: flags @ copts @ options @ (std_includes basedir) @ tolink @ [ main_file ] @ topstart in if !echo then begin diff --git a/tools/coqwc.mll b/tools/coqwc.mll index a0b6bfbbe..6ddeeb9b2 100644 --- a/tools/coqwc.mll +++ b/tools/coqwc.mll @@ -94,7 +94,7 @@ let rcs = "\036" rcs_keyword [^ '$']* "\036" let stars = "(*" '*'* "*)" let dot = '.' (' ' | '\t' | '\n' | '\r' | eof) let proof_start = - "Theorem" | "Lemma" | "Fact" | "Remark" | "Goal" | "Correctness" | "Obligation" | "Next" + "Theorem" | "Lemma" | "Fact" | "Remark" | "Goal" | "Correctness" | "Obligation" space+ (['0' - '9'])+ | "Next" space+ "Obligation" let def_start = "Definition" | "Fixpoint" | "Instance" let proof_end = diff --git a/tools/fake_ide.ml b/tools/fake_ide.ml index a9da27ba2..79723431c 100644 --- a/tools/fake_ide.ml +++ b/tools/fake_ide.ml @@ -252,11 +252,9 @@ let eval_print l coq = let to_id, _ = get_id id in eval_call (query (0,(phrase, to_id))) coq | [ Tok(_,"WAIT") ] -> - let phrase = "Stm Wait." in - eval_call (query (0,(phrase,tip_id()))) coq + eval_call (wait ()) coq | [ Tok(_,"JOIN") ] -> - let phrase = "Stm JoinDocument." in - eval_call (query (0,(phrase,tip_id()))) coq + eval_call (status true) coq | [ Tok(_,"ASSERT"); Tok(_,"TIP"); Tok(_,id) ] -> let to_id, _ = get_id id in if not(Stateid.equal (Document.tip doc) to_id) then error "Wrong tip" diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 0f8524e92..db7bcb76b 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -8,7 +8,6 @@ open Pp open CErrors -open Flags open Libnames open Coqinit @@ -31,7 +30,7 @@ let print_header () = Feedback.msg_notice (str "Welcome to Coq " ++ str ver ++ str " (" ++ str rev ++ str ")"); flush_all () -let warning s = with_option Flags.warn Feedback.msg_warning (strbrk s) +let warning s = Flags.(with_option warn Feedback.msg_warning (strbrk s)) let toploop = ref None @@ -87,7 +86,7 @@ let console_toploop_run () = (* We initialize the console only if we run the toploop_run *) let tl_feed = Feedback.add_feeder Coqloop.coqloop_feed in if Dumpglob.dump () then begin - if_verbose warning "Dumpglob cannot be used in interactive mode."; + Flags.if_verbose warning "Dumpglob cannot be used in interactive mode."; Dumpglob.noglob () end; Coqloop.loop(); @@ -130,7 +129,7 @@ let set_type_in_type () = let engage () = Global.set_engagement !impredicative_set -let set_batch_mode () = batch_mode := true +let set_batch_mode () = Flags.batch_mode := true let toplevel_default_name = Names.(DirPath.make [Id.of_string "Top"]) let toplevel_name = ref toplevel_default_name @@ -177,7 +176,7 @@ let load_vernacular sid = (fun sid (s,v) -> let s = Loadpath.locate_file s in if !Flags.beautify then - with_option beautify_file (Vernac.load_vernac v sid) s + Flags.(with_option beautify_file (Vernac.load_vernac v sid) s) else Vernac.load_vernac v sid s) sid (List.rev !load_vernacular_list) @@ -199,7 +198,7 @@ let require_prelude () = let require_list = ref ([] : string list) let add_require s = require_list := s :: !require_list let require () = - let () = if !load_init then silently require_prelude () in + let () = if !Flags.load_init then Flags.silently require_prelude () in let map dir = Qualid (Loc.tag @@ qualid_of_string dir) in Vernacentries.vernac_require None (Some false) (List.rev_map map !require_list) @@ -229,7 +228,7 @@ let add_compile verbose s = let compile_file (v,f) = if !Flags.beautify then - with_option beautify_file (Vernac.compile v) f + Flags.(with_option beautify_file (Vernac.compile v) f) else Vernac.compile v f @@ -304,7 +303,7 @@ let usage () = init_load_path (); with NoCoqLib -> usage_no_coqlib () end; - if !batch_mode then Usage.print_usage_coqc () + if !Flags.batch_mode then Usage.print_usage_coqc () else begin Mltop.load_ml_objects_raw_rex (Str.regexp (if Mltop.is_native then "^.*top.cmxs$" else "^.*top.cma$")); @@ -538,9 +537,14 @@ let parse_args arglist = |"-with-geoproof" -> Coq_config.with_geoproof := get_bool opt (next ()) |"-main-channel" -> Spawned.main_channel := get_host_port opt (next()) |"-control-channel" -> Spawned.control_channel := get_host_port opt (next()) - |"-vio2vo" -> add_compile false (next ()); Flags.compilation_mode := Vio2Vo + |"-vio2vo" -> add_compile false (next ()); Flags.compilation_mode := Flags.Vio2Vo |"-toploop" -> set_toploop (next ()) - |"-w" | "-W" -> CWarnings.set_flags (CWarnings.normalize_flags_string (next ())) + |"-w" | "-W" -> + let w = next () in + if w = "none" then CWarnings.set_flags w + else + let w = CWarnings.get_flags () ^ "," ^ w in + CWarnings.set_flags (CWarnings.normalize_flags_string w) |"-o" -> Flags.compilation_output_name := Some (next()) (* Options with zero arg *) @@ -551,9 +555,9 @@ let parse_args arglist = |"-async-proofs-never-reopen-branch" -> Flags.async_proofs_never_reopen_branch := true; |"-batch" -> set_batch_mode () - |"-test-mode" -> test_mode := true - |"-beautify" -> beautify := true - |"-boot" -> boot := true; no_load_rc () + |"-test-mode" -> Flags.test_mode := true + |"-beautify" -> Flags.beautify := true + |"-boot" -> Flags.boot := true; no_load_rc () |"-bt" -> Backtrace.record_backtrace true |"-color" -> set_color (next ()) |"-config"|"--config" -> print_config := true @@ -565,19 +569,18 @@ let parse_args arglist = |"-ideslave" -> set_ideslave () |"-impredicative-set" -> set_impredicative_set () |"-indices-matter" -> Indtypes.enforce_indices_matter () - |"-just-parsing" -> warning "-just-parsing option has been removed in 8.6" |"-m"|"--memory" -> memory_stat := true - |"-noinit"|"-nois" -> load_init := false + |"-noinit"|"-nois" -> Flags.load_init := false |"-no-glob"|"-noglob" -> Dumpglob.noglob (); glob_opt := true |"-native-compiler" -> if Coq_config.no_native_compiler then warning "Native compilation was disabled at configure time." - else native_compiler := true + else Flags.native_compiler := true |"-output-context" -> output_context := true |"-profile-ltac" -> Flags.profile_ltac := true |"-q" -> no_load_rc () |"-quiet"|"-silent" -> Flags.quiet := true; Flags.make_warn false - |"-quick" -> Flags.compilation_mode := BuildVio + |"-quick" -> Flags.compilation_mode := Flags.BuildVio |"-list-tags" -> print_tags := true |"-time" -> Flags.time := true |"-type-in-type" -> set_type_in_type () @@ -620,11 +623,11 @@ let init_toplevel arglist = prerr_endline "See -help for the list of supported options"; exit 1 end; - if_verbose print_header (); + Flags.if_verbose print_header (); inputstate (); Mltop.init_known_plugins (); engage (); - if (not !batch_mode || CList.is_empty !compile_list) + if (not !Flags.batch_mode || CList.is_empty !compile_list) && Global.env_is_initial () then Declaremods.start_library !toplevel_name; init_library_roots (); @@ -645,16 +648,16 @@ let init_toplevel arglist = with any -> flush_all(); let extra = - if !batch_mode && not Stateid.(equal (Stm.get_current_state ()) dummy) + if !Flags.batch_mode && not Stateid.(equal (Stm.get_current_state ()) dummy) then None else Some (str "Error during initialization: ") in fatal_error ?extra any end; - if !batch_mode then begin + if !Flags.batch_mode then begin flush_all(); if !output_context then - Feedback.msg_notice (with_option raw_print Prettyp.print_full_pure_context () ++ fnl ()); + Feedback.msg_notice Flags.(with_option raw_print Prettyp.print_full_pure_context () ++ fnl ()); Profile.print_profile (); exit 0 end; diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index 1602f9c68..1b020bc87 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -11,7 +11,6 @@ open Pp open CErrors open Util -open Flags open Vernacexpr open Vernacprop @@ -48,35 +47,29 @@ let beautify_suffix = ".beautified" let set_formatter_translator ch = let out s b e = output_substring ch s b e in - Format.set_formatter_output_functions out (fun () -> flush ch); - Format.set_max_boxes max_int + let ft = Format.make_formatter out (fun () -> flush ch) in + Format.pp_set_max_boxes ft max_int; + ft -let pr_new_syntax_in_context ?loc chan_beautify ocom = +let pr_new_syntax_in_context ?loc ft_beautify ocom = let loc = Option.cata Loc.unloc (0,0) loc in - if !beautify_file then set_formatter_translator chan_beautify; let fs = States.freeze ~marshallable:`No in - (* The content of this is not supposed to fail, but if ever *) - try - (* Side-effect: order matters *) - let before = comment (CLexer.extract_comments (fst loc)) in - let com = match ocom with - | Some com -> Ppvernac.pr_vernac com - | None -> mt() in - let after = comment (CLexer.extract_comments (snd loc)) in - if !beautify_file then - (Pp.pp_with !Topfmt.std_ft (hov 0 (before ++ com ++ after)); - Format.pp_print_flush !Topfmt.std_ft ()) - else - Feedback.msg_info (hov 4 (str"New Syntax:" ++ fnl() ++ (hov 0 com))); - States.unfreeze fs; - Format.set_formatter_out_channel stdout - with any -> - States.unfreeze fs; - Format.set_formatter_out_channel stdout - -let pr_new_syntax ?loc po chan_beautify ocom = + (* Side-effect: order matters *) + let before = comment (CLexer.extract_comments (fst loc)) in + let com = match ocom with + | Some com -> Ppvernac.pr_vernac com + | None -> mt() in + let after = comment (CLexer.extract_comments (snd loc)) in + if !Flags.beautify_file then + (Pp.pp_with ft_beautify (hov 0 (before ++ com ++ after)); + Format.pp_print_flush ft_beautify ()) + else + Feedback.msg_info (hov 4 (str"New Syntax:" ++ fnl() ++ (hov 0 com))); + States.unfreeze fs + +let pr_new_syntax ?loc po ft_beautify ocom = (* Reinstall the context of parsing which includes the bindings of comments to locations *) - Pcoq.Gram.with_parsable po (pr_new_syntax_in_context ?loc chan_beautify) ocom + Pcoq.Gram.with_parsable po (pr_new_syntax_in_context ?loc ft_beautify) ocom (* For coqtop -time, we display the position in the file, and a glimpse of the executed command *) @@ -133,10 +126,16 @@ let rec interp_vernac sid (loc,com) = highly dynamic and depends on the structure of the document. Hopefully this is fixed when VtBack can be removed and Undo etc... are just interpreted regularly. *) + + (* XXX: The classifier can emit warnings so we need to guard + against that... *) + let wflags = CWarnings.get_flags () in + CWarnings.set_flags "none"; let is_proof_step = match fst (Vernac_classifier.classify_vernac v) with - | VtProofStep _ | VtStm (VtBack _, _) | VtStartProof _ -> true + | VtProofStep _ | VtBack (_, _) | VtStartProof _ -> true | _ -> false in + CWarnings.set_flags wflags; let nsid, ntip = Stm.add ~ontop:sid (not !Flags.quiet) (loc,v) in @@ -178,8 +177,13 @@ let rec interp_vernac sid (loc,com) = (* Load a vernac file. CErrors are annotated with file and location *) and load_vernac verbosely sid file = - let chan_beautify = - if !Flags.beautify_file then open_out (file^beautify_suffix) else stdout in + let ft_beautify, close_beautify = + if !Flags.beautify_file then + let chan_beautify = open_out (file^beautify_suffix) in + set_formatter_translator chan_beautify, fun () -> close_out chan_beautify; + else + !Topfmt.std_ft, fun () -> () + in let in_chan = open_utf8_file_in file in let in_echo = if verbosely then Some (open_utf8_file_in file) else None in let in_pa = Pcoq.Gram.parsable ~file:(Loc.InFile file) (Stream.of_channel in_chan) in @@ -209,7 +213,7 @@ and load_vernac verbosely sid file = *) in (* Printing of vernacs *) - if !beautify then pr_new_syntax ?loc in_pa chan_beautify (Some ast); + if !Flags.beautify then pr_new_syntax ?loc in_pa ft_beautify (Some ast); Option.iter (vernac_echo ?loc) in_echo; checknav_simple (loc, ast); @@ -224,12 +228,12 @@ and load_vernac verbosely sid file = match e with | Stm.End_of_input -> (* Is this called so comments at EOF are printed? *) - if !beautify then - pr_new_syntax ~loc:(Loc.make_loc (max_int,max_int)) in_pa chan_beautify None; - if !Flags.beautify_file then close_out chan_beautify; + if !Flags.beautify then + pr_new_syntax ~loc:(Loc.make_loc (max_int,max_int)) in_pa ft_beautify None; + if !Flags.beautify_file then close_beautify (); !rsid | reraise -> - if !Flags.beautify_file then close_out chan_beautify; + if !Flags.beautify_file then close_beautify (); iraise (disable_drop e, info) (** [eval_expr : ?preserving:bool -> Loc.t * Vernacexpr.vernac_expr -> unit] @@ -290,7 +294,7 @@ let compile verbosely f = ++ str ".") in match !Flags.compilation_mode with - | BuildVo -> + | Flags.BuildVo -> let long_f_dot_v = ensure_v f in ensure_exists long_f_dot_v; let long_f_dot_vo = @@ -314,7 +318,7 @@ let compile verbosely f = (Printf.sprintf "%.3f" (wall_clock2 -. wall_clock1)); Aux_file.stop_aux_file (); Dumpglob.end_dump_glob () - | BuildVio -> + | Flags.BuildVio -> let long_f_dot_v = ensure_v f in ensure_exists long_f_dot_v; let long_f_dot_vio = @@ -329,7 +333,7 @@ let compile verbosely f = check_pending_proofs (); Stm.snapshot_vio ldir long_f_dot_vio; Stm.reset_task_queue () - | Vio2Vo -> + | Flags.Vio2Vo -> let open Filename in let open Library in Dumpglob.noglob (); diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index 59920742d..503508fc0 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -533,7 +533,7 @@ open Namegen let compute_bl_goal ind lnamesparrec nparrec = let eqI, eff = eqI ind lnamesparrec in let list_id = list_id lnamesparrec in - let avoid = List.fold_right (Nameops.Name.fold_right (fun id l -> id::l)) (List.map RelDecl.get_name lnamesparrec) [] in + let avoid = List.fold_right (Nameops.Name.fold_right (fun id l -> Id.Set.add id l)) (List.map RelDecl.get_name lnamesparrec) Id.Set.empty in let create_input c = let x = next_ident_away (Id.of_string "x") avoid and y = next_ident_away (Id.of_string "y") avoid in @@ -578,7 +578,7 @@ let compute_bl_tact mode bl_scheme_key ind lnamesparrec nparrec = ( List.map (fun (_,_,sbl,_ ) -> sbl) list_id ) in let fresh_id s gl = - let fresh = fresh_id_in_env (!avoid) s (Proofview.Goal.env gl) in + let fresh = fresh_id_in_env (Id.Set.of_list !avoid) s (Proofview.Goal.env gl) in avoid := fresh::(!avoid); fresh in Proofview.Goal.enter begin fun gl -> @@ -676,7 +676,7 @@ let _ = bl_scheme_kind_aux := fun () -> bl_scheme_kind let compute_lb_goal ind lnamesparrec nparrec = let list_id = list_id lnamesparrec in let eq = Lazy.force eq and tt = Lazy.force tt and bb = Lazy.force bb in - let avoid = List.fold_right (Nameops.Name.fold_right (fun id l -> id::l)) (List.map RelDecl.get_name lnamesparrec) [] in + let avoid = List.fold_right (Nameops.Name.fold_right (fun id l -> Id.Set.add id l)) (List.map RelDecl.get_name lnamesparrec) Id.Set.empty in let eqI, eff = eqI ind lnamesparrec in let create_input c = let x = next_ident_away (Id.of_string "x") avoid and @@ -722,7 +722,7 @@ let compute_lb_tact mode lb_scheme_key ind lnamesparrec nparrec = ( List.map (fun (_,_,_,slb) -> slb) list_id ) in let fresh_id s gl = - let fresh = fresh_id_in_env (!avoid) s (Proofview.Goal.env gl) in + let fresh = fresh_id_in_env (Id.Set.of_list !avoid) s (Proofview.Goal.env gl) in avoid := fresh::(!avoid); fresh in Proofview.Goal.enter begin fun gl -> @@ -806,7 +806,7 @@ let compute_dec_goal ind lnamesparrec nparrec = check_not_is_defined (); let eq = Lazy.force eq and tt = Lazy.force tt and bb = Lazy.force bb in let list_id = list_id lnamesparrec in - let avoid = List.fold_right (Nameops.Name.fold_right (fun id l -> id::l)) (List.map RelDecl.get_name lnamesparrec) [] in + let avoid = List.fold_right (Nameops.Name.fold_right (fun id l -> Id.Set.add id l)) (List.map RelDecl.get_name lnamesparrec) Id.Set.empty in let create_input c = let x = next_ident_away (Id.of_string "x") avoid and y = next_ident_away (Id.of_string "y") avoid in @@ -870,7 +870,7 @@ let compute_dec_tact ind lnamesparrec nparrec = ( List.map (fun (_,_,_,slb) -> slb) list_id ) in let fresh_id s gl = - let fresh = fresh_id_in_env (!avoid) s (Proofview.Goal.env gl) in + let fresh = fresh_id_in_env (Id.Set.of_list !avoid) s (Proofview.Goal.env gl) in avoid := fresh::(!avoid); fresh in Proofview.Goal.enter begin fun gl -> diff --git a/vernac/class.ml b/vernac/class.ml index be682977e..3915148a0 100644 --- a/vernac/class.ml +++ b/vernac/class.ml @@ -222,9 +222,10 @@ let build_id_coercion idf_opt source poly = Id.of_string ("Id_"^(ident_key_of_class source)^"_"^ (ident_key_of_class cl)) in + let univs = (snd (Evd.universe_context ~names:[] ~extensible:true sigma)) in let constr_entry = (* Cast is necessary to express [val_f] is identity *) DefinitionEntry - (definition_entry ~types:typ_f ~poly ~univs:(snd (Evd.universe_context sigma)) + (definition_entry ~types:typ_f ~poly ~univs ~inline:true (mkCast (val_f, DEFAULTcast, typ_f))) in let decl = (constr_entry, IsDefinition IdentityCoercion) in diff --git a/vernac/classes.ml b/vernac/classes.ml index ab1892a18..0926c93e5 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -111,14 +111,14 @@ let instance_hook k info global imps ?hook cst = Typeclasses.declare_instance (Some info) (not global) cst; (match hook with Some h -> h cst | None -> ()) -let declare_instance_constant k info global imps ?hook id pl poly evm term termtype = +let declare_instance_constant k info global imps ?hook id decl poly evm term termtype = let kind = IsDefinition Instance in let evm = let levels = Univ.LSet.union (Univops.universes_of_constr termtype) (Univops.universes_of_constr term) in Evd.restrict_universe_context evm levels in - let pl, uctx = Evd.universe_context ?names:pl evm in + let pl, uctx = Evd.check_univ_decl evm decl in let entry = Declare.definition_entry ~types:termtype ~poly ~univs:uctx term in @@ -129,13 +129,13 @@ let declare_instance_constant k info global imps ?hook id pl poly evm term termt instance_hook k info global imps ?hook (ConstRef kn); id -let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) poly ctx (instid, bk, cl) props - ?(generalize=true) - ?(tac:unit Proofview.tactic option) ?hook pri = +let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) + poly ctx (instid, bk, cl) props ?(generalize=true) + ?(tac:unit Proofview.tactic option) ?hook pri = let env = Global.env() in let ((loc, instid), pl) = instid in - let uctx = Evd.make_evar_universe_context env pl in - let evars = ref (Evd.from_ctx uctx) in + let evd, decl = Univdecls.interp_univ_decl_opt env pl in + let evars = ref evd in let tclass, ids = match bk with | Decl_kinds.Implicit -> @@ -183,7 +183,7 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) p id | Anonymous -> let i = Nameops.add_suffix (id_of_class k) "_instance_0" in - Namegen.next_global_ident_away i (Termops.ids_of_context env) + Namegen.next_global_ident_away i (Termops.vars_of_env env) in let env' = push_rel_context ctx env in evars := Evarutil.nf_evar_map !evars; @@ -202,7 +202,7 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) p nf t in Pretyping.check_evars env Evd.empty !evars (EConstr.of_constr termtype); - let pl, ctx = Evd.universe_context ?names:pl !evars in + let pl, ctx = Evd.check_univ_decl !evars decl in let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest id (ParameterEntry (None,poly,(termtype,ctx),None), Decl_kinds.IsAssumption Decl_kinds.Logical) @@ -302,7 +302,7 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) p in let term = Option.map nf term in if not (Evd.has_undefined evm) && not (Option.is_empty term) then - declare_instance_constant k pri global imps ?hook id pl + declare_instance_constant k pri global imps ?hook id decl poly evm (Option.get term) termtype else if Flags.is_program_mode () || refine || Option.is_empty term then begin let kind = Decl_kinds.Global, poly, Decl_kinds.DefinitionBody Decl_kinds.Instance in @@ -323,7 +323,7 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) p let hook = Lemmas.mk_hook hook in let ctx = Evd.evar_universe_context evm in ignore (Obligations.add_definition id ?term:constr - ?pl typ ctx ~kind:(Global,poly,Instance) ~hook obls); + ~univdecl:decl typ ctx ~kind:(Global,poly,Instance) ~hook obls); id else (Flags.silently @@ -334,7 +334,7 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) p the refinement manually.*) let gls = List.rev (Evd.future_goals evm) in let evm = Evd.reset_future_goals evm in - Lemmas.start_proof id ?pl kind evm (EConstr.of_constr termtype) + Lemmas.start_proof id ~pl:decl kind evm (EConstr.of_constr termtype) (Lemmas.mk_hook (fun _ -> instance_hook k pri global imps ?hook)); (* spiwack: I don't know what to do with the status here. *) diff --git a/vernac/classes.mli b/vernac/classes.mli index fc2fdbbf3..fcdb5c3bc 100644 --- a/vernac/classes.mli +++ b/vernac/classes.mli @@ -30,7 +30,7 @@ val declare_instance_constant : Impargs.manual_explicitation list -> (** implicits *) ?hook:(Globnames.global_reference -> unit) -> Id.t -> (** name *) - Id.t Loc.located list option -> + Univdecls.universe_decl -> bool -> (* polymorphic *) Evd.evar_map -> (* Universes *) Constr.t -> (** body *) @@ -43,7 +43,7 @@ val new_instance : ?refine:bool -> (** Allow refinement *) Decl_kinds.polymorphic -> local_binder_expr list -> - typeclass_constraint -> + Vernacexpr.typeclass_constraint -> (bool * constr_expr) option -> ?generalize:bool -> ?tac:unit Proofview.tactic -> diff --git a/vernac/command.ml b/vernac/command.ml index 32ab5401a..a1a87d54e 100644 --- a/vernac/command.ml +++ b/vernac/command.ml @@ -9,7 +9,6 @@ open Pp open CErrors open Util -open Flags open Term open Vars open Termops @@ -91,8 +90,8 @@ let warn_implicits_in_term = let interp_definition pl bl p red_option c ctypopt = let env = Global.env() in - let ctx = Evd.make_evar_universe_context env pl in - let evdref = ref (Evd.from_ctx ctx) in + let evd, decl = Univdecls.interp_univ_decl_opt env pl in + let evdref = ref evd in let impls, ((env_bl, ctx), imps1) = interp_context_evars env evdref bl in let ctx = List.map (fun d -> map_rel_decl EConstr.Unsafe.to_constr d) ctx in let nb_args = Context.Rel.nhyps ctx in @@ -108,7 +107,7 @@ let interp_definition pl bl p red_option c ctypopt = let body = nf (it_mkLambda_or_LetIn c ctx) in let vars = Univops.universes_of_constr body in let evd = Evd.restrict_universe_context !evdref vars in - let pl, uctx = Evd.universe_context ?names:pl evd in + let pl, uctx = Evd.check_univ_decl evd decl in imps1@(Impargs.lift_implicits nb_args imps2), pl, definition_entry ~univs:uctx ~poly:p body | Some ctyp -> @@ -134,20 +133,20 @@ let interp_definition pl bl p red_option c ctypopt = let vars = Univ.LSet.union (Univops.universes_of_constr body) (Univops.universes_of_constr typ) in let ctx = Evd.restrict_universe_context !evdref vars in - let pl, uctx = Evd.universe_context ?names:pl ctx in + let pl, uctx = Evd.check_univ_decl ctx decl in imps1@(Impargs.lift_implicits nb_args impsty), pl, definition_entry ~types:typ ~poly:p ~univs:uctx body in - red_constant_entry (Context.Rel.length ctx) ce !evdref red_option, !evdref, pl, imps + red_constant_entry (Context.Rel.length ctx) ce !evdref red_option, !evdref, decl, pl, imps -let check_definition (ce, evd, _, imps) = +let check_definition (ce, evd, _, _, imps) = check_evars_are_solved (Global.env ()) evd Evd.empty; ce -let do_definition ident k pl bl red_option c ctypopt hook = - let (ce, evd, pl', imps as def) = - interp_definition pl bl (pi2 k) red_option c ctypopt +let do_definition ident k univdecl bl red_option c ctypopt hook = + let (ce, evd, univdecl, pl', imps as def) = + interp_definition univdecl bl (pi2 k) red_option c ctypopt in if Flags.is_program_mode () then let env = Global.env () in @@ -164,8 +163,8 @@ let do_definition ident k pl bl red_option c ctypopt hook = in let ctx = Evd.evar_universe_context evd in let hook = Lemmas.mk_hook (fun l r _ -> Lemmas.call_hook (fun exn -> exn) hook l r) in - ignore(Obligations.add_definition - ident ~term:c cty ctx ?pl ~implicits:imps ~kind:k ~hook obls) + ignore(Obligations.add_definition + ident ~term:c cty ctx ~univdecl ~implicits:imps ~kind:k ~hook obls) else let ce = check_definition def in ignore(DeclareDef.declare_definition ident k ce pl' imps (Lemmas.mk_hook @@ -270,15 +269,15 @@ let do_assumptions_unbound_univs (_, poly, _ as kind) nl l = let do_assumptions_bound_univs coe kind nl id pl c = let env = Global.env () in - let ctx = Evd.make_evar_universe_context env pl in - let evdref = ref (Evd.from_ctx ctx) in + let evd, decl = Univdecls.interp_univ_decl_opt env pl in + let evdref = ref evd in let ty, impls = interp_type_evars_impls env evdref c in let nf, subst = Evarutil.e_nf_evars_and_universes evdref in let ty = EConstr.Unsafe.to_constr ty in let ty = nf ty in let vars = Univops.universes_of_constr ty in let evd = Evd.restrict_universe_context !evdref vars in - let pl, uctx = Evd.universe_context ?names:pl evd in + let pl, uctx = Evd.check_univ_decl evd decl in let uctx = Univ.ContextSet.of_context uctx in let (_, _, st) = declare_assumption coe kind (ty, uctx) pl impls false nl id in st @@ -318,7 +317,7 @@ let push_types env idl tl = type structured_one_inductive_expr = { ind_name : Id.t; - ind_univs : lident list option; + ind_univs : Vernacexpr.universe_decl_expr option; ind_arity : constr_expr; ind_lc : (Id.t * constr_expr) list } @@ -519,15 +518,16 @@ let check_param = function | CLocalDef (na, _, _) -> check_named na | CLocalAssum (nas, Default _, _) -> List.iter check_named nas | CLocalAssum (nas, Generalized _, _) -> () -| CLocalPattern _ -> assert false +| CLocalPattern (loc,_) -> + Loc.raise ?loc (Stream.Error "pattern with quote not allowed here.") let interp_mutual_inductive (paramsl,indl) notations cum poly prv finite = check_all_names_different indl; List.iter check_param paramsl; let env0 = Global.env() in let pl = (List.hd indl).ind_univs in - let ctx = Evd.make_evar_universe_context env0 pl in - let evdref = ref Evd.(from_ctx ctx) in + let evd, decl = Univdecls.interp_univ_decl_opt env0 pl in + let evdref = ref evd in let impls, ((env_params, ctx_params), userimpls) = interp_context_evars env0 evdref paramsl in @@ -576,7 +576,7 @@ let interp_mutual_inductive (paramsl,indl) notations cum poly prv finite = let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map nf' cl,impsl)) constructors in let ctx_params = Context.Rel.map nf ctx_params in let evd = !evdref in - let pl, uctx = Evd.universe_context ?names:pl evd in + let pl, uctx = Evd.check_univ_decl evd decl in List.iter (fun c -> check_evars env_params Evd.empty evd (EConstr.of_constr c)) arities; Context.Rel.iter (fun c -> check_evars env0 Evd.empty evd (EConstr.of_constr c)) ctx_params; List.iter (fun (_,ctyps,_) -> @@ -692,7 +692,7 @@ let declare_mutual_inductive_with_eliminations mie pl impls = constrimpls) impls; let warn_prim = match mie.mind_entry_record with Some (Some _) -> not prim | _ -> false in - if_verbose Feedback.msg_info (minductive_message warn_prim names); + Flags.if_verbose Feedback.msg_info (minductive_message warn_prim names); if mie.mind_entry_private == None then declare_default_schemes mind; mind @@ -797,7 +797,7 @@ let check_mutuality env evd isfix fixl = type structured_fixpoint_expr = { fix_name : Id.t; - fix_univs : lident list option; + fix_univs : universe_decl_expr option; fix_annot : Id.t Loc.located option; fix_binders : local_binder_expr list; fix_body : constr_expr option; @@ -917,8 +917,8 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = let lift_rel_context n l = Termops.map_rel_context_with_binders (liftn n) l in Coqlib.check_required_library ["Coq";"Program";"Wf"]; let env = Global.env() in - let ctx = Evd.make_evar_universe_context env pl in - let evdref = ref (Evd.from_ctx ctx) in + let evd, decl = Univdecls.interp_univ_decl_opt env pl in + let evdref = ref evd in let _, ((env', binders_rel), impls) = interp_context_evars env evdref bl in let len = List.length binders_rel in let top_env = push_rel_context binders_rel env in @@ -1019,14 +1019,16 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = let binders_rel = nf_evar_context !evdref binders_rel in let binders = nf_evar_context !evdref binders in let top_arity = Evarutil.nf_evar !evdref top_arity in - let hook, recname, typ = + let pl, plext = Option.cata + (fun d -> d.univdecl_instance, d.univdecl_extensible_instance) ([],true) pl in + let hook, recname, typ = if List.length binders_rel > 1 then let name = add_suffix recname "_func" in let hook l gr _ = let body = it_mkLambda_or_LetIn (mkApp (Evarutil.e_new_global evdref gr, [|make|])) binders_rel in let ty = it_mkProd_or_LetIn top_arity binders_rel in let ty = EConstr.Unsafe.to_constr ty in - let pl, univs = Evd.universe_context ?names:pl !evdref in + let pl, univs = Evd.universe_context ~names:pl ~extensible:plext !evdref in (*FIXME poly? *) let ce = definition_entry ~poly ~types:ty ~univs (EConstr.to_constr !evdref body) in (** FIXME: include locality *) @@ -1052,7 +1054,7 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = Obligations.eterm_obligations env recname !evdref 0 fullcoqc fullctyp in let ctx = Evd.evar_universe_context !evdref in - ignore(Obligations.add_definition recname ~term:evars_def ?pl + ignore(Obligations.add_definition recname ~term:evars_def ~univdecl:decl evars_typ ctx evars ~hook) let interp_recursive isfix fixl notations = @@ -1068,11 +1070,12 @@ let interp_recursive isfix fixl notations = | None , acc -> acc | x , None -> x | Some ls , Some us -> - if not (CList.for_all2eq (fun x y -> Id.equal (snd x) (snd y)) ls us) then + let lsu = ls.univdecl_instance and usu = us.univdecl_instance in + if not (CList.for_all2eq (fun x y -> Id.equal (snd x) (snd y)) lsu usu) then user_err Pp.(str "(co)-recursive definitions should all have the same universe binders"); Some us) fixl None in - let ctx = Evd.make_evar_universe_context env all_universes in - let evdref = ref (Evd.from_ctx ctx) in + let evd, decl = Univdecls.interp_univ_decl_opt env all_universes in + let evdref = ref evd in let fixctxs, fiximppairs, fixannots = List.split3 (List.map (interp_fix_context env evdref isfix) fixl) in let fixctximpenvs, fixctximps = List.split fiximppairs in @@ -1122,7 +1125,7 @@ let interp_recursive isfix fixl notations = let fixctxs = List.map (fun (_,ctx) -> ctx) fixctxs in (* Build the fix declaration block *) - (env,rec_sign,all_universes,evd), (fixnames,fixdefs,fixtypes), List.combine3 fixctxs fiximps fixannots + (env,rec_sign,decl,evd), (fixnames,fixdefs,fixtypes), List.combine3 fixctxs fiximps fixannots let check_recursive isfix env evd (fixnames,fixdefs,_) = check_evars_are_solved env evd Evd.empty; @@ -1145,14 +1148,14 @@ let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) ind if List.exists Option.is_empty fixdefs then (* Some bodies to define by proof *) let thms = - List.map3 (fun id t (ctx,imps,_) -> ((id,pl),(t,(List.map RelDecl.get_name ctx,imps)))) + List.map3 (fun id t (ctx,imps,_) -> (id,(t,(List.map RelDecl.get_name ctx,imps)))) fixnames fixtypes fiximps in let init_tac = Some (List.map (Option.cata (EConstr.of_constr %> Tactics.exact_no_check) Tacticals.New.tclIDTAC) fixdefs) in let evd = Evd.from_ctx ctx in Lemmas.start_proof_with_initialization (Global,poly,DefinitionBody Fixpoint) - evd (Some(false,indexes,init_tac)) thms None (Lemmas.mk_hook (fun _ _ -> ())) + evd pl (Some(false,indexes,init_tac)) thms None (Lemmas.mk_hook (fun _ _ -> ())) else begin (* We shortcut the proof process *) let fixdefs = List.map Option.get fixdefs in @@ -1165,8 +1168,8 @@ let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) ind List.map_i (fun i _ -> mkFix ((indexes,i),fixdecls)) 0 fixnames in let evd = Evd.from_ctx ctx in let evd = Evd.restrict_universe_context evd vars in + let pl, ctx = Evd.check_univ_decl evd pl in let fixdecls = List.map Safe_typing.mk_pure_proof fixdecls in - let pl, ctx = Evd.universe_context ?names:pl evd in ignore (List.map4 (DeclareDef.declare_fix (local, poly, Fixpoint) pl ctx) fixnames fixdecls fixtypes fiximps); (* Declare the recursive definitions *) @@ -1179,14 +1182,14 @@ let declare_cofixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) n if List.exists Option.is_empty fixdefs then (* Some bodies to define by proof *) let thms = - List.map3 (fun id t (ctx,imps,_) -> ((id,pl),(t,(List.map RelDecl.get_name ctx,imps)))) + List.map3 (fun id t (ctx,imps,_) -> (id,(t,(List.map RelDecl.get_name ctx,imps)))) fixnames fixtypes fiximps in let init_tac = Some (List.map (Option.cata (EConstr.of_constr %> Tactics.exact_no_check) Tacticals.New.tclIDTAC) fixdefs) in let evd = Evd.from_ctx ctx in Lemmas.start_proof_with_initialization (Global,poly, DefinitionBody CoFixpoint) - evd (Some(true,[],init_tac)) thms None (Lemmas.mk_hook (fun _ _ -> ())) + evd pl (Some(true,[],init_tac)) thms None (Lemmas.mk_hook (fun _ _ -> ())) else begin (* We shortcut the proof process *) let fixdefs = List.map Option.get fixdefs in @@ -1197,8 +1200,8 @@ let declare_cofixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) n let fiximps = List.map (fun (len,imps,idx) -> imps) fiximps in let evd = Evd.from_ctx ctx in let evd = Evd.restrict_universe_context evd vars in - let pl, ctx = Evd.universe_context ?names:pl evd in - ignore (List.map4 (DeclareDef.declare_fix (local, poly, CoFixpoint) pl ctx) + let pl, ctx = Evd.check_univ_decl evd pl in + ignore (List.map4 (DeclareDef.declare_fix (local, poly, CoFixpoint) pl ctx) fixnames fixdecls fixtypes fiximps); (* Declare the recursive definitions *) cofixpoint_message fixnames @@ -1281,7 +1284,7 @@ let do_program_recursive local p fixkind fixl ntns = | Obligations.IsFixpoint _ -> (local, p, Fixpoint) | Obligations.IsCoFixpoint -> (local, p, CoFixpoint) in - Obligations.add_mutual_definitions defs ~kind ?pl ctx ntns fixkind + Obligations.add_mutual_definitions defs ~kind ~univdecl:pl ctx ntns fixkind let do_program_fixpoint local poly l = let g = List.map (fun ((_,wf,_,_,_),_) -> wf) l in diff --git a/vernac/command.mli b/vernac/command.mli index 8d17f27c3..afa97aa24 100644 --- a/vernac/command.mli +++ b/vernac/command.mli @@ -26,11 +26,11 @@ val do_constraint : polymorphic -> (** {6 Definitions/Let} *) val interp_definition : - lident list option -> local_binder_expr list -> polymorphic -> red_expr option -> constr_expr -> + Vernacexpr.universe_decl_expr option -> local_binder_expr list -> polymorphic -> red_expr option -> constr_expr -> constr_expr option -> Safe_typing.private_constants definition_entry * Evd.evar_map * - Universes.universe_binders * Impargs.manual_implicits + Univdecls.universe_decl * Universes.universe_binders * Impargs.manual_implicits -val do_definition : Id.t -> definition_kind -> lident list option -> +val do_definition : Id.t -> definition_kind -> Vernacexpr.universe_decl_expr option -> local_binder_expr list -> red_expr option -> constr_expr -> constr_expr option -> unit Lemmas.declaration_hook -> unit @@ -49,7 +49,7 @@ val declare_assumption : coercion_flag -> assumption_kind -> global_reference * Univ.Instance.t * bool val do_assumptions : locality * polymorphic * assumption_object_kind -> - Vernacexpr.inline -> (plident list * constr_expr) with_coercion list -> bool + Vernacexpr.inline -> (Vernacexpr.ident_decl list * constr_expr) with_coercion list -> bool (* val declare_assumptions : variable Loc.located list -> *) (* coercion_flag -> assumption_kind -> types Univ.in_universe_context_set -> *) @@ -62,7 +62,7 @@ val do_assumptions : locality * polymorphic * assumption_object_kind -> type structured_one_inductive_expr = { ind_name : Id.t; - ind_univs : lident list option; + ind_univs : Vernacexpr.universe_decl_expr option; ind_arity : constr_expr; ind_lc : (Id.t * constr_expr) list } @@ -102,7 +102,7 @@ val do_mutual_inductive : type structured_fixpoint_expr = { fix_name : Id.t; - fix_univs : lident list option; + fix_univs : Vernacexpr.universe_decl_expr option; fix_annot : Id.t Loc.located option; fix_binders : local_binder_expr list; fix_body : constr_expr option; @@ -127,24 +127,24 @@ type recursive_preentry = val interp_fixpoint : structured_fixpoint_expr list -> decl_notation list -> - recursive_preentry * lident list option * Evd.evar_universe_context * + recursive_preentry * Univdecls.universe_decl * Evd.evar_universe_context * (EConstr.rel_context * Impargs.manual_implicits * int option) list val interp_cofixpoint : structured_fixpoint_expr list -> decl_notation list -> - recursive_preentry * lident list option * Evd.evar_universe_context * + recursive_preentry * Univdecls.universe_decl * Evd.evar_universe_context * (EConstr.rel_context * Impargs.manual_implicits * int option) list (** Registering fixpoints and cofixpoints in the environment *) val declare_fixpoint : locality -> polymorphic -> - recursive_preentry * lident list option * Evd.evar_universe_context * + recursive_preentry * Univdecls.universe_decl * Evd.evar_universe_context * (Context.Rel.t * Impargs.manual_implicits * int option) list -> Proof_global.lemma_possible_guards -> decl_notation list -> unit val declare_cofixpoint : locality -> polymorphic -> - recursive_preentry * lident list option * Evd.evar_universe_context * + recursive_preentry * Univdecls.universe_decl * Evd.evar_universe_context * (Context.Rel.t * Impargs.manual_implicits * int option) list -> decl_notation list -> unit diff --git a/vernac/discharge.ml b/vernac/discharge.ml index 474c0b4dd..0e4bbd299 100644 --- a/vernac/discharge.ml +++ b/vernac/discharge.ml @@ -36,32 +36,32 @@ let detype_param = I1..Ip:(B1 y1..yq)..(Bp y1..yq) |- ci : (y1..yq:C1..Cq)Ti[Ij:=(Ij y1..yq)] *) -let abstract_inductive hyps nparams inds = +let abstract_inductive decls nparamdecls inds = let ntyp = List.length inds in - let nhyp = Context.Named.length hyps in - let args = Context.Named.to_instance mkVar (List.rev hyps) in + let ndecls = Context.Named.length decls in + let args = Context.Named.to_instance mkVar (List.rev decls) in let args = Array.of_list args in - let subs = List.init ntyp (fun k -> lift nhyp (mkApp(mkRel (k+1),args))) in + let subs = List.init ntyp (fun k -> lift ndecls (mkApp(mkRel (k+1),args))) in let inds' = List.map (function (tname,arity,template,cnames,lc) -> let lc' = List.map (substl subs) lc in - let lc'' = List.map (fun b -> Termops.it_mkNamedProd_wo_LetIn b hyps) lc' in - let arity' = Termops.it_mkNamedProd_wo_LetIn arity hyps in + let lc'' = List.map (fun b -> Termops.it_mkNamedProd_wo_LetIn b decls) lc' in + let arity' = Termops.it_mkNamedProd_wo_LetIn arity decls in (tname,arity',template,cnames,lc'')) inds in - let nparams' = nparams + Array.length args in + let nparamdecls' = nparamdecls + Array.length args in (* To be sure to be the same as before, should probably be moved to process_inductive *) let params' = let (_,arity,_,_,_) = List.hd inds' in - let (params,_) = decompose_prod_n_assum nparams' arity in + let (params,_) = decompose_prod_n_assum nparamdecls' arity in List.map detype_param params in let ind'' = List.map (fun (a,arity,template,c,lc) -> - let _, short_arity = decompose_prod_n_assum nparams' arity in + let _, short_arity = decompose_prod_n_assum nparamdecls' arity in let shortlc = - List.map (fun c -> snd (decompose_prod_n_assum nparams' c)) lc in + List.map (fun c -> snd (decompose_prod_n_assum nparamdecls' c)) lc in { mind_entry_typename = a; mind_entry_arity = short_arity; mind_entry_template = template; @@ -77,9 +77,9 @@ let refresh_polymorphic_type_of_inductive (_,mip) = let ctx = List.rev mip.mind_arity_ctxt in mkArity (List.rev ctx, Type ar.template_level), true -let process_inductive (sechyps,_,_ as info) modlist mib = - let sechyps = Lib.named_of_variable_context sechyps in - let nparams = mib.mind_nparams in +let process_inductive (section_decls,_,_ as info) modlist mib = + let section_decls = Lib.named_of_variable_context section_decls in + let nparamdecls = Context.Rel.length mib.mind_params_ctxt in let subst, ind_univs = match mib.mind_universes with | Monomorphic_ind ctx -> Univ.empty_level_subst, Monomorphic_ind_entry ctx @@ -105,8 +105,8 @@ let process_inductive (sechyps,_,_ as info) modlist mib = Array.to_list mip.mind_consnames, Array.to_list lc)) mib.mind_packets in - let sechyps' = Context.Named.map discharge sechyps in - let (params',inds') = abstract_inductive sechyps' nparams inds in + let section_decls' = Context.Named.map discharge section_decls in + let (params',inds') = abstract_inductive section_decls' nparamdecls inds in let record = match mib.mind_record with | Some (Some (id, _, _)) -> Some (Some id) | Some None -> Some None diff --git a/vernac/himsg.ml b/vernac/himsg.ml index 12b68fe38..189c47aab 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -84,7 +84,7 @@ let rec contract3' env sigma a b c = function (** Ad-hoc reductions *) let j_nf_betaiotaevar sigma j = - { uj_val = Evarutil.nf_evar sigma j.uj_val; + { uj_val = j.uj_val; uj_type = Reductionops.nf_betaiota sigma j.uj_type } let jv_nf_betaiotaevar sigma jl = @@ -173,7 +173,6 @@ let explain_unbound_var env v = str "No such section variable or assumption: " ++ var ++ str "." let explain_not_type env sigma j = - let j = Evarutil.j_nf_evar sigma j in let pe = pr_ne_context_of (str "In environment") env sigma in let pc,pt = pr_ljudge_env env sigma j in pe ++ str "The term" ++ brk(1,1) ++ pc ++ spc () ++ @@ -241,7 +240,6 @@ let explain_elim_arity env sigma ind sorts c pj okinds = fnl () ++ msg let explain_case_not_inductive env sigma cj = - let cj = Evarutil.j_nf_evar sigma cj in let env = make_all_name_different env sigma in let pc = pr_leconstr_env env sigma cj.uj_val in let pct = pr_leconstr_env env sigma cj.uj_type in @@ -254,7 +252,6 @@ let explain_case_not_inductive env sigma cj = str "which is not a (co-)inductive type." let explain_number_branches env sigma cj expn = - let cj = Evarutil.j_nf_evar sigma cj in let env = make_all_name_different env sigma in let pc = pr_leconstr_env env sigma cj.uj_val in let pct = pr_leconstr_env env sigma cj.uj_type in @@ -263,7 +260,7 @@ let explain_number_branches env sigma cj expn = str "expects " ++ int expn ++ str " branches." let explain_ill_formed_branch env sigma c ci actty expty = - let simp t = Reductionops.nf_betaiota sigma (Evarutil.nf_evar sigma t) in + let simp t = Reductionops.nf_betaiota sigma t in let env = make_all_name_different env sigma in let pc = pr_leconstr_env env sigma c in let pa, pe = pr_explicit env sigma (simp actty) (simp expty) in @@ -300,10 +297,10 @@ let explain_unification_error env sigma p1 p2 = function | NotSameArgSize | NotSameHead | NoCanonicalStructure -> (* Error speaks from itself *) [] | ConversionFailed (env,t1,t2) -> + let t1 = Reductionops.nf_betaiota sigma t1 in + let t2 = Reductionops.nf_betaiota sigma t2 in if EConstr.eq_constr sigma t1 p1 && EConstr.eq_constr sigma t2 p2 then [] else let env = make_all_name_different env sigma in - let t1 = Evarutil.nf_evar sigma t1 in - let t2 = Evarutil.nf_evar sigma t2 in if not (EConstr.eq_constr sigma t1 p1) || not (EConstr.eq_constr sigma t2 p2) then let t1, t2 = pr_explicit env sigma t1 t2 in [str "cannot unify " ++ t1 ++ strbrk " and " ++ t2] @@ -327,8 +324,6 @@ let explain_unification_error env sigma p1 p2 = function | CannotSolveConstraint ((pb,env,t,u),e) -> let t = EConstr.of_constr t in let u = EConstr.of_constr u in - let t = Evarutil.nf_evar sigma t in - let u = Evarutil.nf_evar sigma u in let env = make_all_name_different env sigma in (strbrk "cannot satisfy constraint " ++ pr_leconstr_env env sigma t ++ str " == " ++ pr_leconstr_env env sigma u) @@ -359,9 +354,7 @@ let explain_actual_type env sigma j t reason = let explain_cant_apply_bad_type env sigma (n,exptyp,actualtyp) rator randl = let randl = jv_nf_betaiotaevar sigma randl in - let exptyp = Evarutil.nf_evar sigma exptyp in let actualtyp = Reductionops.nf_betaiota sigma actualtyp in - let rator = Evarutil.j_nf_evar sigma rator in let env = make_all_name_different env sigma in let actualtyp, exptyp = pr_explicit env sigma actualtyp exptyp in let nargs = Array.length randl in @@ -386,8 +379,6 @@ let explain_cant_apply_bad_type env sigma (n,exptyp,actualtyp) rator randl = exptyp ++ str "." let explain_cant_apply_not_functional env sigma rator randl = - let randl = Evarutil.jv_nf_evar sigma randl in - let rator = Evarutil.j_nf_evar sigma rator in let env = make_all_name_different env sigma in let nargs = Array.length randl in (* let pe = pr_ne_context_of (str "in environment") env sigma in*) @@ -407,8 +398,6 @@ let explain_cant_apply_not_functional env sigma rator randl = fnl () ++ str " " ++ v 0 appl let explain_unexpected_type env sigma actual_type expected_type = - let actual_type = Evarutil.nf_evar sigma actual_type in - let expected_type = Evarutil.nf_evar sigma expected_type in let pract, prexp = pr_explicit env sigma actual_type expected_type in str "Found type" ++ spc () ++ pract ++ spc () ++ str "where" ++ spc () ++ prexp ++ str " was expected." @@ -510,8 +499,6 @@ let explain_ill_formed_rec_body env sigma err names i fixenv vdefj = with e when CErrors.noncritical e -> mt ()) let explain_ill_typed_rec_body env sigma i names vdefj vargs = - let vdefj = Evarutil.jv_nf_evar sigma vdefj in - let vargs = Array.map (Evarutil.nf_evar sigma) vargs in let env = make_all_name_different env sigma in let pvd = pr_leconstr_env env sigma vdefj.(i).uj_val in let pvdt, pv = pr_explicit env sigma vdefj.(i).uj_type vargs.(i) in @@ -575,9 +562,9 @@ let rec explain_evar_kind env sigma evk ty = function | Evar_kinds.SubEvar evk' -> let evi = Evd.find sigma evk' in let pc = match evi.evar_body with - | Evar_defined c -> pr_leconstr_env env sigma (Evarutil.nf_evar sigma (EConstr.of_constr c)) + | Evar_defined c -> pr_leconstr_env env sigma (EConstr.of_constr c) | Evar_empty -> assert false in - let ty' = Evarutil.nf_evar sigma (EConstr.of_constr evi.evar_concl) in + let ty' = EConstr.of_constr evi.evar_concl in pr_existential_key sigma evk ++ str " of type " ++ ty ++ str " in the partial instance " ++ pc ++ str " found for " ++ explain_evar_kind env sigma evk' @@ -628,8 +615,6 @@ let explain_wrong_case_info env (ind,u) ci = let explain_cannot_unify env sigma m n e = let env = make_all_name_different env sigma in - let m = Evarutil.nf_evar sigma m in - let n = Evarutil.nf_evar sigma n in let pm, pn = pr_explicit env sigma m n in let ppreason = explain_unification_error env sigma m n e in let pe = pr_ne_context_of (str "In environment") env sigma in diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml index facebd096..90168843a 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -108,7 +108,7 @@ let _ = let define id internal ctx c t = let f = declare_constant ~internal in - let _, univs = Evd.universe_context ctx in + let _, univs = Evd.universe_context ~names:[] ~extensible:true ctx in let univs = if Flags.is_universe_polymorphism () then Polymorphic_const_entry univs else Monomorphic_const_entry univs diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index 645320c60..2c8f6ec9d 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -11,7 +11,6 @@ open CErrors open Util -open Flags open Pp open Names open Term @@ -49,7 +48,7 @@ let retrieve_first_recthm uctx = function (NamedDecl.get_value (Global.lookup_named id),variable_opacity id) | ConstRef cst -> let cb = Global.lookup_constant cst in - let (_, uctx) = UState.universe_context uctx in + let (_, uctx) = UState.universe_context ~names:[] ~extensible:true uctx in let inst = Univ.UContext.instance uctx in let map (c, ctx) = Vars.subst_instance_constr inst c in (Option.map map (Global.body_of_constant_body cb), is_opaque cb) @@ -137,7 +136,7 @@ let find_mutually_recursive_statements thms = assert (List.is_empty rest); (* One occ. of common coind ccls and no common inductive hyps *) if not (List.is_empty common_same_indhyp) then - if_verbose Feedback.msg_info (str "Assuming mutual coinductive statements."); + Flags.if_verbose Feedback.msg_info (str "Assuming mutual coinductive statements."); flush_all (); indccl, true, [] | [], _::_ -> @@ -145,7 +144,7 @@ let find_mutually_recursive_statements thms = | ind :: _ -> if List.distinct_f ind_ord (List.map pi1 ind) then - if_verbose Feedback.msg_info + Flags.if_verbose Feedback.msg_info (strbrk ("Coinductive statements do not follow the order of "^ "definition, assuming the proof to be by induction.")); @@ -210,11 +209,12 @@ let compute_proof_name locality = function locality == Global && Nametab.exists_cci (Lib.make_path_except_section id) then user_err ?loc (pr_id id ++ str " already exists."); - id, pl + id | None -> - next_global_ident_away default_thm_id (Proof_global.get_all_proof_names ()), None + let avoid = Id.Set.of_list (Proof_global.get_all_proof_names ()) in + next_global_ident_away default_thm_id avoid -let save_remaining_recthms (locality,p,kind) norm ctx body opaq i ((id,pl),(t_i,(_,imps))) = +let save_remaining_recthms (locality,p,kind) norm ctx binders body opaq i (id,(t_i,(_,imps))) = let t_i = norm t_i in match body with | None -> @@ -222,7 +222,7 @@ let save_remaining_recthms (locality,p,kind) norm ctx body opaq i ((id,pl),(t_i, | Discharge -> let impl = false in (* copy values from Vernacentries *) let k = IsAssumption Conjectural in - let c = SectionLocalAssum ((t_i,ctx),p,impl) in + let c = SectionLocalAssum ((t_i,Univ.ContextSet.of_context ctx),p,impl) in let _ = declare_variable id (Lib.cwd(),c,k) in (Discharge, VarRef id,imps) | Local | Global -> @@ -232,7 +232,6 @@ let save_remaining_recthms (locality,p,kind) norm ctx body opaq i ((id,pl),(t_i, | Global -> false | Discharge -> assert false in - let ctx = Univ.ContextSet.to_context ctx in let decl = (ParameterEntry (None,p,(t_i,ctx),None), k) in let kn = declare_constant id ~local decl in (locality,ConstRef kn,imps)) @@ -250,12 +249,11 @@ let save_remaining_recthms (locality,p,kind) norm ctx body opaq i ((id,pl),(t_i, match locality with | Discharge -> let const = definition_entry ~types:t_i ~opaque:opaq ~poly:p - ~univs:(Univ.ContextSet.to_context ctx) body_i in + ~univs:ctx body_i in let c = SectionLocalDef const in let _ = declare_variable id (Lib.cwd(), c, k) in (Discharge,VarRef id,imps) | Local | Global -> - let ctx = Univ.ContextSet.to_context ctx in let local = match locality with | Local -> true | Global -> false @@ -312,12 +310,6 @@ let get_proof proof do_guard hook opacity = in id,{const with const_entry_opaque = opacity},univs,do_guard,persistence,hook -let check_exist = - List.iter (fun (loc,id) -> - if not (Nametab.exists_cci (Lib.make_path id)) then - user_err ?loc (pr_id id ++ str " does not exist.") - ) - let universe_proof_terminator compute_guard hook = let open Proof_global in make_terminator begin function @@ -325,17 +317,16 @@ let universe_proof_terminator compute_guard hook = admit (id,k,pe) pl (hook (Some ctx)) (); Feedback.feedback Feedback.AddedAxiom | Proved (opaque,idopt,proof) -> - let is_opaque, export_seff, exports = match opaque with - | Vernacexpr.Transparent -> false, true, [] - | Vernacexpr.Opaque None -> true, false, [] - | Vernacexpr.Opaque (Some l) -> true, true, l in + let is_opaque, export_seff = match opaque with + | Vernacexpr.Transparent -> false, true + | Vernacexpr.Opaque -> true, false + in let proof = get_proof proof compute_guard (hook (Some (fst proof.Proof_global.universes))) is_opaque in begin match idopt with | None -> save_named ~export_seff proof | Some (_,id) -> save_anonymous ~export_seff proof id - end; - check_exist exports + end end let standard_proof_terminator compute_guard hook = @@ -369,7 +360,7 @@ let start_proof_univs id ?pl kind sigma ?terminator ?sign c ?init_tac ?(compute_ let rec_tac_initializer finite guard thms snl = if finite then - match List.map (fun ((id,_),(t,_)) -> (id,EConstr.of_constr t)) thms with + match List.map (fun (id,(t,_)) -> (id,EConstr.of_constr t)) thms with | (id,_)::l -> Tactics.mutual_cofix id l 0 | _ -> assert false else @@ -377,11 +368,11 @@ let rec_tac_initializer finite guard thms snl = let nl = match snl with | None -> List.map succ (List.map List.last guard) | Some nl -> nl - in match List.map2 (fun ((id,_),(t,_)) n -> (id,n, EConstr.of_constr t)) thms nl with + in match List.map2 (fun (id,(t,_)) n -> (id,n, EConstr.of_constr t)) thms nl with | (id,n,_)::l -> Tactics.mutual_fix id n l 0 | _ -> assert false -let start_proof_with_initialization kind ctx recguard thms snl hook = +let start_proof_with_initialization kind ctx decl recguard thms snl hook = let intro_tac (_, (_, (ids, _))) = Tacticals.New.tclMAP (function | Name id -> Tactics.intro_mustbe_force id @@ -406,7 +397,7 @@ let start_proof_with_initialization kind ctx recguard thms snl hook = (if Flags.is_auto_intros () then Some (intro_tac (List.hd thms)) else None), [] in match thms with | [] -> anomaly (Pp.str "No proof to start.") - | ((id,pl),(t,(_,imps)))::other_thms -> + | (id,(t,(_,imps)))::other_thms -> let hook ctx strength ref = let ctx = match ctx with | None -> Evd.empty_evar_universe_context @@ -418,22 +409,24 @@ let start_proof_with_initialization kind ctx recguard thms snl hook = let body,opaq = retrieve_first_recthm ctx ref in let subst = Evd.evar_universe_context_subst ctx in let norm c = Universes.subst_opt_univs_constr subst c in - let ctx = UState.context_set (*FIXME*) ctx in + let binders, ctx = Evd.check_univ_decl (Evd.from_ctx ctx) decl in let body = Option.map norm body in - List.map_i (save_remaining_recthms kind norm ctx body opaq) 1 other_thms in + List.map_i (save_remaining_recthms kind norm ctx binders body opaq) 1 other_thms in let thms_data = (strength,ref,imps)::other_thms_data in List.iter (fun (strength,ref,imps) -> maybe_declare_manual_implicits false ref imps; call_hook (fun exn -> exn) hook strength ref) thms_data in - start_proof_univs id ?pl kind ctx (EConstr.of_constr t) ?init_tac (fun ctx -> mk_hook (hook ctx)) ~compute_guard:guard + start_proof_univs id ~pl:decl kind ctx (EConstr.of_constr t) ?init_tac (fun ctx -> mk_hook (hook ctx)) ~compute_guard:guard let start_proof_com ?inference_hook kind thms hook = let env0 = Global.env () in - let levels = Option.map snd (fst (List.hd thms)) in - let evdref = ref (match levels with - | None -> Evd.from_env env0 - | Some l -> Evd.from_ctx (Evd.make_evar_universe_context env0 l)) - in + let decl = fst (List.hd thms) in + let evd, decl = + match decl with + | None -> Evd.from_env env0, Univdecls.default_univ_decl + | Some decl -> + Univdecls.interp_univ_decl_opt env0 (snd decl) in + let evdref = ref evd in let thms = List.map (fun (sopt,(bl,t)) -> let impls, ((env, ctx), imps) = interp_context_evars env0 evdref bl in let t', imps' = interp_type_evars_impls ~impls env evdref t in @@ -449,16 +442,16 @@ let start_proof_com ?inference_hook kind thms hook = let evd, nf = Evarutil.nf_evars_and_universes !evdref in let thms = List.map (fun (n, (t, info)) -> (n, (nf t, info))) thms in let () = - match levels with - | None -> () - | Some l -> ignore (Evd.universe_context evd ?names:l) + if not decl.Misctypes.univdecl_extensible_instance then + ignore (Evd.universe_context evd ~names:decl.Misctypes.univdecl_instance ~extensible:false) + else () in let evd = if pi2 kind then evd else (* We fix the variables to ensure they won't be lowered to Set *) Evd.fix_undefined_variables evd in - start_proof_with_initialization kind evd recguard thms snl hook + start_proof_with_initialization kind evd decl recguard thms snl hook (* Saving a proof *) @@ -507,11 +500,13 @@ let save_proof ?proof = function let ids_def = Environ.global_vars_set env pproof in Some (Environ.keep_hyps env (Idset.union ids_typ ids_def)) | _ -> None in - let names = Proof_global.get_universe_binders () in + let decl = Proof_global.get_universe_decl () in let evd = Evd.from_ctx universes in - let binders, ctx = Evd.universe_context ?names evd in - Admitted(id,k,(sec_vars, pi2 k, (typ, ctx), None), - (universes, Some binders)) + let binders, ctx = Evd.check_univ_decl evd decl in + let poly = pi2 k in + let binders = if poly then Some binders else None in + Admitted(id,k,(sec_vars, poly, (typ, ctx), None), + (universes, binders)) in Proof_global.apply_terminator (Proof_global.get_terminator ()) pe | Vernacexpr.Proved (is_opaque,idopt) -> diff --git a/vernac/lemmas.mli b/vernac/lemmas.mli index a8c09c0fe..1e23c7314 100644 --- a/vernac/lemmas.mli +++ b/vernac/lemmas.mli @@ -20,13 +20,13 @@ val call_hook : (** A hook start_proof calls on the type of the definition being started *) val set_start_hook : (EConstr.types -> unit) -> unit -val start_proof : Id.t -> ?pl:Proof_global.universe_binders -> goal_kind -> Evd.evar_map -> +val start_proof : Id.t -> ?pl:Univdecls.universe_decl -> goal_kind -> Evd.evar_map -> ?terminator:(Proof_global.lemma_possible_guards -> unit declaration_hook -> Proof_global.proof_terminator) -> ?sign:Environ.named_context_val -> EConstr.types -> ?init_tac:unit Proofview.tactic -> ?compute_guard:Proof_global.lemma_possible_guards -> unit declaration_hook -> unit -val start_proof_univs : Id.t -> ?pl:Proof_global.universe_binders -> goal_kind -> Evd.evar_map -> +val start_proof_univs : Id.t -> ?pl:Univdecls.universe_decl -> goal_kind -> Evd.evar_map -> ?terminator:(Proof_global.lemma_possible_guards -> (Evd.evar_universe_context option -> unit declaration_hook) -> Proof_global.proof_terminator) -> ?sign:Environ.named_context_val -> EConstr.types -> ?init_tac:unit Proofview.tactic -> ?compute_guard:Proof_global.lemma_possible_guards -> @@ -38,9 +38,9 @@ val start_proof_com : unit declaration_hook -> unit val start_proof_with_initialization : - goal_kind -> Evd.evar_map -> + goal_kind -> Evd.evar_map -> Univdecls.universe_decl -> (bool * Proof_global.lemma_possible_guards * unit Proofview.tactic list option) option -> - ((Id.t (* name of thm *) * Proof_global.universe_binders option) * + (Id.t (* name of thm *) * (types (* type of thm *) * (Name.t list (* names to pre-introduce *) * Impargs.manual_explicitation list))) list -> int list option -> unit declaration_hook -> unit diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index c17ba765e..b2d48bb2f 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -7,7 +7,6 @@ (************************************************************************) open Pp -open Flags open CErrors open Util open Names @@ -99,18 +98,24 @@ let pr_grammar = function let parse_format ((loc, str) : lstring) = let len = String.length str in - let push_token a = function - | cur::l -> (a::cur)::l - | [] -> [[a]] in - let push_white n l = - if Int.equal n 0 then l else push_token (UnpTerminal (String.make n ' ')) l in - let close_box i b = function - | a::(_::_ as l) -> push_token (UnpBox (b,a)) l - | _ -> user_err Pp.(str "Non terminated box in format.") in - let close_quotation i = - if i < len && str.[i] == '\'' && (Int.equal (i+1) len || str.[i+1] == ' ') - then i+1 - else user_err Pp.(str "Incorrectly terminated quoted expression.") in + (* TODO: update the line of the location when the string contains newlines *) + let make_loc i j = Option.map (Loc.shift_loc (i+1) (j-len)) loc in + let push_token loc a = function + | (i,cur)::l -> (i,(loc,a)::cur)::l + | [] -> assert false in + let push_white i n l = + if Int.equal n 0 then l else push_token (make_loc i (i+n)) (UnpTerminal (String.make n ' ')) l in + let close_box start stop b = function + | (_,a)::(_::_ as l) -> push_token (make_loc start stop) (UnpBox (b,a)) l + | [a] -> user_err ?loc:(make_loc start stop) Pp.(str "Non terminated box in format.") + | [] -> assert false in + let close_quotation start i = + if i < len && str.[i] == '\'' then + if (Int.equal (i+1) len || str.[i+1] == ' ') + then i+1 + else user_err ?loc:(make_loc (i+1) (i+1)) Pp.(str "Space expected after quoted expression.") + else + user_err ?loc:(make_loc start (i-1)) Pp.(str "Beginning of quoted expression expected to be ended by a quote.") in let rec spaces n i = if i < len && str.[i] == ' ' then spaces (n+1) (i+1) else n in @@ -118,81 +123,78 @@ let parse_format ((loc, str) : lstring) = if i < len && str.[i] != ' ' then if str.[i] == '\'' && quoted && (i+1 >= len || str.[i+1] == ' ') - then if Int.equal n 0 then user_err Pp.(str "Empty quoted token.") else n + then if Int.equal n 0 then user_err ?loc:(make_loc (i-1) i) Pp.(str "Empty quoted token.") else n else nonspaces quoted (n+1) (i+1) else - if quoted then user_err Pp.(str "Spaces are not allowed in (quoted) symbols.") + if quoted then user_err ?loc:(make_loc i i) Pp.(str "Spaces are not allowed in (quoted) symbols.") else n in let rec parse_non_format i = let n = nonspaces false 0 i in - push_token (UnpTerminal (String.sub str i n)) (parse_token 1 (i+n)) + push_token (make_loc i (i+n-1)) (UnpTerminal (String.sub str i n)) (parse_token 1 (i+n)) and parse_quoted n i = if i < len then match str.[i] with (* Parse " // " *) - | '/' when i <= len && str.[i+1] == '/' -> - (* We forget the useless n spaces... *) - push_token (UnpCut PpFnl) - (parse_token 1 (close_quotation (i+2))) + | '/' when i+1 < len && str.[i+1] == '/' -> + (* We discard the useless n spaces... *) + push_token (make_loc (i-n) (i+1)) (UnpCut PpFnl) + (parse_token 1 (close_quotation i (i+2))) (* Parse " .. / .. " *) - | '/' when i <= len -> + | '/' when i+1 < len -> let p = spaces 0 (i+1) in - push_token (UnpCut (PpBrk (n,p))) - (parse_token 1 (close_quotation (i+p+1))) + push_token (make_loc (i-n) (i+p)) (UnpCut (PpBrk (n,p))) + (parse_token 1 (close_quotation i (i+p+1))) | c -> (* The spaces are real spaces *) - push_white n (match c with + push_white i n (match c with | '[' -> - if i <= len then match str.[i+1] with + if i+1 < len then match str.[i+1] with (* Parse " [h .. ", *) | 'h' when i+1 <= len && str.[i+2] == 'v' -> - (parse_box (fun n -> PpHVB n) (i+3)) + (parse_box i (fun n -> PpHVB n) (i+3)) (* Parse " [v .. ", *) | 'v' -> - parse_box (fun n -> PpVB n) (i+2) + parse_box i (fun n -> PpVB n) (i+2) (* Parse " [ .. ", *) | ' ' | '\'' -> - parse_box (fun n -> PpHOVB n) (i+1) - | _ -> user_err Pp.(str "\"v\", \"hv\", \" \" expected after \"[\" in format.") - else user_err Pp.(str "\"v\", \"hv\" or \" \" expected after \"[\" in format.") + parse_box i (fun n -> PpHOVB n) (i+1) + | _ -> user_err ?loc:(make_loc i i) Pp.(str "\"v\", \"hv\", \" \" expected after \"[\" in format.") + else user_err ?loc:(make_loc i i) Pp.(str "\"v\", \"hv\" or \" \" expected after \"[\" in format.") (* Parse "]" *) | ']' -> - ([] :: parse_token 1 (close_quotation (i+1))) + ((i,[]) :: parse_token 1 (close_quotation i (i+1))) (* Parse a non formatting token *) | c -> let n = nonspaces true 0 i in - push_token (UnpTerminal (String.sub str (i-1) (n+2))) - (parse_token 1 (close_quotation (i+n)))) + push_token (make_loc i (i+n-1)) (UnpTerminal (String.sub str (i-1) (n+2))) + (parse_token 1 (close_quotation i (i+n)))) else if Int.equal n 0 then [] - else user_err Pp.(str "Ending spaces non part of a format annotation.") - and parse_box box i = + else user_err ?loc:(make_loc (len-n) len) Pp.(str "Ending spaces non part of a format annotation.") + and parse_box start box i = let n = spaces 0 i in - close_box i (box n) (parse_token 1 (close_quotation (i+n))) + close_box start (i+n-1) (box n) (parse_token 1 (close_quotation i (i+n))) and parse_token k i = let n = spaces 0 i in let i = i+n in if i < len then match str.[i] with (* Parse a ' *) | '\'' when i+1 >= len || str.[i+1] == ' ' -> - push_white (n-k) (push_token (UnpTerminal "'") (parse_token 1 (i+1))) + push_white (i-n) (n-k) (push_token (make_loc i (i+1)) (UnpTerminal "'") (parse_token 1 (i+1))) (* Parse the beginning of a quoted expression *) | '\'' -> parse_quoted (n-k) (i+1) (* Otherwise *) | _ -> - push_white (n-k) (parse_non_format i) - else push_white n [[]] + push_white (i-n) (n-k) (parse_non_format i) + else push_white (i-n) n [(len,[])] in - try - if not (String.is_empty str) then match parse_token 0 0 with - | [l] -> l - | _ -> user_err Pp.(str "Box closed without being opened in format.") - else - [] - with reraise -> - let (e, info) = CErrors.push reraise in - let info = Option.cata (Loc.add_loc info) info loc in - iraise (e, info) + if not (String.is_empty str) then + match parse_token 0 0 with + | [_,l] -> l + | (i,_)::_ -> user_err ?loc:(make_loc i i) Pp.(str "Box closed without being opened.") + | [] -> assert false + else + [] (***********************) (* Analyzing notations *) @@ -383,11 +385,11 @@ let is_next_terminal = function Terminal _ :: _ -> true | _ -> false let is_next_break = function Break _ :: _ -> true | _ -> false -let add_break n l = UnpCut (PpBrk(n,0)) :: l +let add_break n l = (None,UnpCut (PpBrk(n,0))) :: l let add_break_if_none n = function - | ((UnpCut (PpBrk _) :: _) | []) as l -> l - | l -> UnpCut (PpBrk(n,0)) :: l + | (((_,UnpCut (PpBrk _)) :: _) | []) as l -> l + | l -> (None,UnpCut (PpBrk(n,0))) :: l let check_open_binder isopen sl m = let pr_token = function @@ -413,30 +415,30 @@ let make_hunks etyps symbols from = let _,prec = precedence_of_entry_type from (List.nth typs (i-1)) in let u = UnpMetaVar (i,prec) in if is_next_non_terminal prods then - u :: add_break_if_none 1 (make prods) + (None,u) :: add_break_if_none 1 (make prods) else - u :: make_with_space prods + (None,u) :: make_with_space prods | Terminal s :: prods when List.exists is_non_terminal prods -> if (is_comma s || is_operator s) then (* Always a breakable space after comma or separator *) - UnpTerminal s :: add_break_if_none 1 (make prods) + (None,UnpTerminal s) :: add_break_if_none 1 (make prods) else if is_right_bracket s && is_next_terminal prods then (* Always no space after right bracked, but possibly a break *) - UnpTerminal s :: add_break_if_none 0 (make prods) + (None,UnpTerminal s) :: add_break_if_none 0 (make prods) else if is_left_bracket s && is_next_non_terminal prods then - UnpTerminal s :: make prods + (None,UnpTerminal s) :: make prods else if not (is_next_break prods) then (* Add rigid space, no break, unless user asked for something *) - UnpTerminal (s^" ") :: make prods + (None,UnpTerminal (s^" ")) :: make prods else (* Rely on user spaces *) - UnpTerminal s :: make prods + (None,UnpTerminal s) :: make prods | Terminal s :: prods -> (* Separate but do not cut a trailing sequence of terminal *) (match prods with - | Terminal _ :: _ -> UnpTerminal (s^" ") :: make prods - | _ -> UnpTerminal s :: make prods) + | Terminal _ :: _ -> (None,UnpTerminal (s^" ")) :: make prods + | _ -> (None,UnpTerminal s) :: make prods) | Break n :: prods -> add_break n (make prods) @@ -451,12 +453,12 @@ let make_hunks etyps symbols from = (* We add NonTerminal for simulation but remove it afterwards *) else snd (List.sep_last (make (sl@[NonTerminal m]))) in let hunk = match typ with - | ETConstr _ -> UnpListMetaVar (i,prec,sl') + | ETConstr _ -> UnpListMetaVar (i,prec,List.map snd sl') | ETBinder isopen -> check_open_binder isopen sl m; - UnpBinderListMetaVar (i,isopen,sl') + UnpBinderListMetaVar (i,isopen,List.map snd sl') | _ -> assert false in - hunk :: make_with_space prods + (None,hunk) :: make_with_space prods | [] -> [] @@ -465,7 +467,7 @@ let make_hunks etyps symbols from = | Terminal s' :: prods'-> if is_operator s' then (* A rigid space before operator and a breakable after *) - UnpTerminal (" "^s') :: add_break_if_none 1 (make prods') + (None,UnpTerminal (" "^s')) :: add_break_if_none 1 (make prods') else if is_comma s' then (* No space whatsoever before comma *) make prods @@ -486,58 +488,63 @@ let make_hunks etyps symbols from = (* Build default printing rules from explicit format *) -let error_format () = user_err Pp.(str "The format does not match the notation.") +let error_format ?loc () = user_err ?loc Pp.(str "The format does not match the notation.") let rec split_format_at_ldots hd = function - | UnpTerminal s :: fmt when String.equal s (Id.to_string ldots_var) -> List.rev hd, fmt + | (loc,UnpTerminal s) :: fmt when String.equal s (Id.to_string ldots_var) -> loc, List.rev hd, fmt | u :: fmt -> check_no_ldots_in_box u; split_format_at_ldots (u::hd) fmt | [] -> raise Exit and check_no_ldots_in_box = function - | UnpBox (_,fmt) -> + | (_,UnpBox (_,fmt)) -> (try - let _ = split_format_at_ldots [] fmt in - user_err Pp.(str ("The special symbol \"..\" must occur at the same formatting depth than the variables of which it is the ellipse.")) + let loc,_,_ = split_format_at_ldots [] fmt in + user_err ?loc Pp.(str ("The special symbol \"..\" must occur at the same formatting depth than the variables of which it is the ellipse.")) with Exit -> ()) | _ -> () +let error_not_same ?loc () = + user_err ?loc Pp.(str "The format is not the same on the right- and left-hand sides of the special token \"..\".") + let skip_var_in_recursive_format = function - | UnpTerminal _ :: sl (* skip first var *) -> + | (_,UnpTerminal s) :: sl (* skip first var *) when not (List.for_all (fun c -> c = " ") (String.explode s)) -> (* To do, though not so important: check that the names match the names in the notation *) sl - | _ -> error_format () + | (loc,_) :: _ -> error_not_same ?loc () + | [] -> assert false let read_recursive_format sl fmt = let get_head fmt = let sl = skip_var_in_recursive_format fmt in - try split_format_at_ldots [] sl with Exit -> error_format () in + try split_format_at_ldots [] sl with Exit -> error_not_same ?loc:(fst (List.last (if sl = [] then fmt else sl))) () in let rec get_tail = function - | a :: sepfmt, b :: fmt when Pervasives.(=) a b -> get_tail (sepfmt, fmt) (* FIXME *) + | (loc,a) :: sepfmt, (_,b) :: fmt when Pervasives.(=) a b -> get_tail (sepfmt, fmt) (* FIXME *) | [], tail -> skip_var_in_recursive_format tail - | _ -> user_err Pp.(str "The format is not the same on the right and left hand side of the special token \"..\".") in - let slfmt, fmt = get_head fmt in + | (loc,_) :: _, ([] | (_,UnpTerminal _) :: _)-> error_not_same ?loc () + | _, (loc,_)::_ -> error_not_same ?loc () in + let loc, slfmt, fmt = get_head fmt in slfmt, get_tail (slfmt, fmt) let hunks_of_format (from,(vars,typs)) symfmt = let rec aux = function - | symbs, (UnpTerminal s' as u) :: fmt + | symbs, (_,(UnpTerminal s' as u)) :: fmt when String.equal s' (String.make (String.length s') ' ') -> let symbs, l = aux (symbs,fmt) in symbs, u :: l - | Terminal s :: symbs, (UnpTerminal s') :: fmt + | Terminal s :: symbs, (_,UnpTerminal s') :: fmt when String.equal s (String.drop_simple_quotes s') -> let symbs, l = aux (symbs,fmt) in symbs, UnpTerminal s :: l - | NonTerminal s :: symbs, UnpTerminal s' :: fmt when Id.equal s (Id.of_string s') -> + | NonTerminal s :: symbs, (_,UnpTerminal s') :: fmt when Id.equal s (Id.of_string s') -> let i = index_id s vars in let _,prec = precedence_of_entry_type from (List.nth typs (i-1)) in let symbs, l = aux (symbs,fmt) in symbs, UnpMetaVar (i,prec) :: l - | symbs, UnpBox (a,b) :: fmt -> + | symbs, (_,UnpBox (a,b)) :: fmt -> let symbs', b' = aux (symbs,b) in let symbs', l = aux (symbs',fmt) in - symbs', UnpBox (a,b') :: l - | symbs, (UnpCut _ as u) :: fmt -> + symbs', UnpBox (a,List.map (fun x -> (None,x)) b') :: l + | symbs, (_,(UnpCut _ as u)) :: fmt -> let symbs, l = aux (symbs,fmt) in symbs, u :: l | SProdList (m,sl) :: symbs, fmt -> let i = index_id m vars in @@ -545,7 +552,7 @@ let hunks_of_format (from,(vars,typs)) symfmt = 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 not (List.is_empty sl) then error_format (); + if not (List.is_empty sl) then error_format ?loc:(fst (List.last fmt)) (); let symbs, l = aux (symbs,fmt) in let hunk = match typ with | ETConstr _ -> UnpListMetaVar (i,prec,slfmt) @@ -555,7 +562,7 @@ let hunks_of_format (from,(vars,typs)) symfmt = | _ -> assert false in symbs, hunk :: l | symbs, [] -> symbs, [] - | _, _ -> error_format () + | _, fmt -> error_format ?loc:(fst (List.hd fmt)) () in match aux symfmt with | [], l -> l @@ -794,7 +801,7 @@ type notation_modifier = { (* common to syn_data below *) only_parsing : bool; only_printing : bool; - compat : compat_version option; + compat : Flags.compat_version option; format : string Loc.located option; extra : (string * string) list; } @@ -1078,7 +1085,7 @@ module SynData = struct (* Fields coming from the vernac-level modifiers *) only_parsing : bool; only_printing : bool; - compat : compat_version option; + compat : Flags.compat_version option; format : string Loc.located option; extra : (string * string) list; @@ -1394,7 +1401,7 @@ let add_notation_interpretation ((loc,df),c,sc) = let set_notation_for_interpretation impls ((_,df),c,sc) = (try ignore - (silently (fun () -> add_notation_interpretation_core false df ~impls c sc false false None) ()); + (Flags.silently (fun () -> add_notation_interpretation_core false df ~impls c sc false false None) ()); with NoSyntaxRule -> user_err Pp.(str "Parsing rule for this notation has to be previously declared.")); Option.iter (fun sc -> Notation.open_close_scope (false,true,sc)) sc diff --git a/vernac/mltop.ml b/vernac/mltop.ml index e8a0ba3dd..d3de10235 100644 --- a/vernac/mltop.ml +++ b/vernac/mltop.ml @@ -9,7 +9,6 @@ open CErrors open Util open Pp -open Flags open Libobject open System @@ -175,6 +174,7 @@ let warn_cannot_use_directory = let convert_string d = try Names.Id.of_string d with UserError _ -> + let d = Unicode.escaped_if_non_utf8 d in warn_cannot_use_directory d; raise Exit @@ -365,7 +365,7 @@ let trigger_ml_object verb cache reinit ?path name = else begin let file = file_of_name (Option.default name path) in let path = - if_verbose_load (verb && not !quiet) load_ml_object name ?path file in + if_verbose_load (verb && not !Flags.quiet) load_ml_object name ?path file in add_loaded_module name (Some path); if cache then perform_cache_obj name end diff --git a/vernac/obligations.ml b/vernac/obligations.ml index a4fe49020..81218308f 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -304,7 +304,7 @@ type program_info_aux = { prg_body: constr; prg_type: constr; prg_ctx: Evd.evar_universe_context; - prg_pl: Id.t Loc.located list option; + prg_univdecl: Univdecls.universe_decl; prg_obligations: obligations; prg_deps : Id.t list; prg_fixkind : fixpoint_kind option ; @@ -474,8 +474,7 @@ let declare_definition prg = (Evd.evar_universe_context_subst prg.prg_ctx) in let opaque = prg.prg_opaque in let fix_exn = Hook.get get_fix_exn () in - let pl, ctx = - Evd.universe_context ?names:prg.prg_pl (Evd.from_ctx prg.prg_ctx) in + let pl, ctx = Evd.check_univ_decl (Evd.from_ctx prg.prg_ctx) prg.prg_univdecl in let ce = definition_entry ~fix_exn ~opaque ~types:(nf typ) ~poly:(pi2 prg.prg_kind) @@ -658,7 +657,7 @@ let declare_obligation prg obl body ty uctx = else Some (TermObl (it_mkLambda_or_LetIn_or_clean (mkApp (mkConst constant, args)) ctx)) } -let init_prog_info ?(opaque = false) sign n pl b t ctx deps fixkind +let init_prog_info ?(opaque = false) sign n udecl b t ctx deps fixkind notations obls impls kind reduce hook = let obls', b = match b with @@ -679,7 +678,7 @@ let init_prog_info ?(opaque = false) sign n pl b t ctx deps fixkind obls, b in { prg_name = n ; prg_body = b; prg_type = reduce t; - prg_ctx = ctx; prg_pl = pl; + prg_ctx = ctx; prg_univdecl = udecl; prg_obligations = (obls', Array.length obls'); prg_deps = deps; prg_fixkind = fixkind ; prg_notations = notations ; prg_implicits = impls; prg_kind = kind; prg_reduce = reduce; @@ -847,9 +846,9 @@ let obligation_terminator name num guard hook auto pf = let obl = obls.(num) in let status = match obl.obl_status, opq with - | (_, Evar_kinds.Expand), Vernacexpr.Opaque _ -> err_not_transp () - | (true, _), Vernacexpr.Opaque _ -> err_not_transp () - | (false, _), Vernacexpr.Opaque _ -> Evar_kinds.Define true + | (_, Evar_kinds.Expand), Vernacexpr.Opaque -> err_not_transp () + | (true, _), Vernacexpr.Opaque -> err_not_transp () + | (false, _), Vernacexpr.Opaque -> Evar_kinds.Define true | (_, Evar_kinds.Define true), Vernacexpr.Transparent -> Evar_kinds.Define false | (_, status), Vernacexpr.Transparent -> status in @@ -889,7 +888,7 @@ in let ctx' = Evd.merge_universe_subst evd (Evd.universe_subst (Evd.from_ctx ctx')) in Univ.Instance.empty, Evd.evar_universe_context ctx' else - let (_, uctx) = UState.universe_context ctx' in + let (_, uctx) = UState.universe_context ~names:[] ~extensible:true ctx' in Univ.UContext.instance uctx, ctx' in let obl = { obl with obl_body = Some (DefinedObl (cst, inst)) } in @@ -1068,11 +1067,12 @@ let show_term n = Printer.pr_constr_env (Global.env ()) Evd.empty prg.prg_type ++ spc () ++ str ":=" ++ fnl () ++ Printer.pr_constr_env (Global.env ()) Evd.empty prg.prg_body) -let add_definition n ?term t ctx ?pl ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic +let add_definition n ?term t ctx ?(univdecl=Univdecls.default_univ_decl) + ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic ?(reduce=reduce) ?(hook=Lemmas.mk_hook (fun _ _ _ -> ())) ?(opaque = false) obls = let sign = Decls.initialize_named_context_for_proof () in let info = Id.print n ++ str " has type-checked" in - let prg = init_prog_info sign ~opaque n pl term t ctx [] None [] obls implicits kind reduce hook in + let prg = init_prog_info sign ~opaque n univdecl term t ctx [] None [] obls implicits kind reduce hook in let obls,_ = prg.prg_obligations in if Int.equal (Array.length obls) 0 then ( Flags.if_verbose Feedback.msg_info (info ++ str "."); @@ -1087,13 +1087,14 @@ let add_definition n ?term t ctx ?pl ?(implicits=[]) ?(kind=Global,false,Definit | Remain rem -> Flags.if_verbose (fun () -> show_obligations ~msg:false (Some n)) (); res | _ -> res) -let add_mutual_definitions l ctx ?pl ?tactic ?(kind=Global,false,Definition) ?(reduce=reduce) +let add_mutual_definitions l ctx ?(univdecl=Univdecls.default_univ_decl) ?tactic + ?(kind=Global,false,Definition) ?(reduce=reduce) ?(hook=Lemmas.mk_hook (fun _ _ _ -> ())) ?(opaque = false) notations fixkind = let sign = Decls.initialize_named_context_for_proof () in let deps = List.map (fun (n, b, t, imps, obls) -> n) l in List.iter (fun (n, b, t, imps, obls) -> - let prg = init_prog_info sign ~opaque n pl (Some b) t ctx deps (Some fixkind) + let prg = init_prog_info sign ~opaque n univdecl (Some b) t ctx deps (Some fixkind) notations obls imps kind reduce hook in progmap_add n (CEphemeron.create prg)) l; let _defined = diff --git a/vernac/obligations.mli b/vernac/obligations.mli index 5614403ba..11c2553ae 100644 --- a/vernac/obligations.mli +++ b/vernac/obligations.mli @@ -53,7 +53,7 @@ val default_tactic : unit Proofview.tactic ref val add_definition : Names.Id.t -> ?term:Term.constr -> Term.types -> Evd.evar_universe_context -> - ?pl:(Id.t Loc.located list) -> (* Universe binders *) + ?univdecl:Univdecls.universe_decl -> (* Universe binders and constraints *) ?implicits:(Constrexpr.explicitation * (bool * bool * bool)) list -> ?kind:Decl_kinds.definition_kind -> ?tactic:unit Proofview.tactic -> @@ -71,7 +71,7 @@ val add_mutual_definitions : (Names.Id.t * Term.constr * Term.types * (Constrexpr.explicitation * (bool * bool * bool)) list * obligation_info) list -> Evd.evar_universe_context -> - ?pl:(Id.t Loc.located list) -> (* Universe binders *) + ?univdecl:Univdecls.universe_decl -> (* Universe binders and constraints *) ?tactic:unit Proofview.tactic -> ?kind:Decl_kinds.definition_kind -> ?reduce:(Term.constr -> Term.constr) -> diff --git a/vernac/record.ml b/vernac/record.ml index a2e443e5f..18e7796ca 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -95,8 +95,8 @@ let binders_of_decls = List.map binder_of_decl let typecheck_params_and_fields finite def id pl t ps nots fs = let env0 = Global.env () in - let ctx = Evd.make_evar_universe_context env0 pl in - let evars = ref (Evd.from_ctx ctx) in + let evd, decl = Univdecls.interp_univ_decl_opt env0 pl in + let evars = ref evd in let _ = let error bk (loc, name) = match bk, name with @@ -165,9 +165,10 @@ let typecheck_params_and_fields finite def id pl t ps nots fs = let newps = List.map (EConstr.to_rel_decl evars) newps in let typ = EConstr.to_constr evars typ in let ce t = Pretyping.check_evars env0 Evd.empty evars (EConstr.of_constr t) in + let univs = Evd.check_univ_decl evars decl in List.iter (iter_constr ce) (List.rev newps); List.iter (iter_constr ce) (List.rev newfs); - Evd.universe_context ?names:pl evars, typ, template, imps, newps, impls, newfs + univs, typ, template, imps, newps, impls, newfs let degenerate_decl decl = let id = match RelDecl.get_name decl with @@ -456,7 +457,7 @@ let declare_class finite def cum poly ctx id idbuild paramimpls params arity let impls = implicits_of_context params in List.map (fun x -> impls @ Impargs.lift_implicits (succ len) x) fieldimpls in - let binder_name = Namegen.next_ident_away (snd id) (Termops.ids_of_context (Global.env())) in + let binder_name = Namegen.next_ident_away (snd id) (Termops.vars_of_env (Global.env())) in let impl, projs = match fields with | [LocalAssum (Name proj_name, field) | LocalDef (Name proj_name, _, field)] when def -> diff --git a/vernac/record.mli b/vernac/record.mli index 9a0c9ef9d..aea474581 100644 --- a/vernac/record.mli +++ b/vernac/record.mli @@ -39,7 +39,7 @@ val declare_structure : val definition_structure : inductive_kind * Decl_kinds.cumulative_inductive_flag * Decl_kinds.polymorphic * - Decl_kinds.recursivity_kind * plident with_coercion * local_binder_expr list * + Decl_kinds.recursivity_kind * ident_decl with_coercion * local_binder_expr list * (local_decl_expr with_instance with_priority with_notation) list * Id.t * constr_expr option -> global_reference diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 4fd08b42d..83296cf58 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -11,7 +11,6 @@ open Pp open CErrors open Util -open Flags open Names open Nameops open Term @@ -126,8 +125,8 @@ let make_cases_aux glob_ref = | [] -> [] | (n,_)::l -> let n' = Namegen.next_name_away_with_default (Id.to_string Namegen.default_dependent_ident) n avoid in - Id.to_string n' :: rename (n'::avoid) l in - let al' = rename [] al in + Id.to_string n' :: rename (Id.Set.add n' avoid) l in + let al' = rename Id.Set.empty al in let consref = ConstructRef (ith_constructor_of_inductive ind (i + 1)) in (Libnames.string_of_qualid (Nametab.shortest_qualid_of_global Id.Set.empty consref) :: al') :: l) tarr [] @@ -508,7 +507,7 @@ let vernac_exact_proof c = (* spiwack: for simplicity I do not enforce that "Proof proof_term" is called only at the begining of a proof. *) let status = Pfedit.by (Tactics.exact_proof c) in - save_proof (Vernacexpr.(Proved(Opaque None,None))); + save_proof (Vernacexpr.(Proved(Opaque,None))); if not status then Feedback.feedback Feedback.AddedAxiom let vernac_assumption locality poly (local, kind) l nl = @@ -657,7 +656,7 @@ let vernac_declare_module export (loc, id) binders_ast mty_ast = id binders_ast (Enforce mty_ast) [] in Dumpglob.dump_moddef ?loc mp "mod"; - if_verbose Feedback.msg_info (str "Module " ++ pr_id id ++ str " is declared"); + Flags.if_verbose Feedback.msg_info (str "Module " ++ pr_id id ++ str " is declared"); Option.iter (fun export -> vernac_import export [Ident (Loc.tag id)]) export let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_l = @@ -678,7 +677,7 @@ let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_l = export id binders_ast mty_ast_o in Dumpglob.dump_moddef ?loc mp "mod"; - if_verbose Feedback.msg_info + Flags.if_verbose Feedback.msg_info (str "Interactive Module " ++ pr_id id ++ str " started"); List.iter (fun (export,id) -> @@ -696,7 +695,7 @@ let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_l = id binders_ast mty_ast_o mexpr_ast_l in Dumpglob.dump_moddef ?loc mp "mod"; - if_verbose Feedback.msg_info + Flags.if_verbose Feedback.msg_info (str "Module " ++ pr_id id ++ str " is defined"); Option.iter (fun export -> vernac_import export [Ident (Loc.tag id)]) export @@ -704,7 +703,7 @@ let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_l = let vernac_end_module export (loc,id as lid) = let mp = Declaremods.end_module () in Dumpglob.dump_modref ?loc mp "mod"; - if_verbose Feedback.msg_info (str "Module " ++ pr_id id ++ str " is defined"); + Flags.if_verbose Feedback.msg_info (str "Module " ++ pr_id id ++ str " is defined"); Option.iter (fun export -> vernac_import export [Ident lid]) export let vernac_declare_module_type (loc,id) binders_ast mty_sign mty_ast_l = @@ -725,7 +724,7 @@ let vernac_declare_module_type (loc,id) binders_ast mty_sign mty_ast_l = id binders_ast mty_sign in Dumpglob.dump_moddef ?loc mp "modtype"; - if_verbose Feedback.msg_info + Flags.if_verbose Feedback.msg_info (str "Interactive Module Type " ++ pr_id id ++ str " started"); List.iter (fun (export,id) -> @@ -744,13 +743,13 @@ let vernac_declare_module_type (loc,id) binders_ast mty_sign mty_ast_l = id binders_ast mty_sign mty_ast_l in Dumpglob.dump_moddef ?loc mp "modtype"; - if_verbose Feedback.msg_info + Flags.if_verbose Feedback.msg_info (str "Module Type " ++ pr_id id ++ str " is defined") let vernac_end_modtype (loc,id) = let mp = Declaremods.end_modtype () in Dumpglob.dump_modref ?loc mp "modtype"; - if_verbose Feedback.msg_info (str "Module Type " ++ pr_id id ++ str " is defined") + Flags.if_verbose Feedback.msg_info (str "Module Type " ++ pr_id id ++ str " is defined") let vernac_include l = Declaremods.declare_include Modintern.interp_module_ast l @@ -818,7 +817,7 @@ let vernac_coercion locality poly local ref qids qidt = let source = cl_of_qualid qids in let ref' = smart_global ref in Class.try_add_new_coercion_with_target ref' ~local poly ~source ~target; - if_verbose Feedback.msg_info (pr_global ref' ++ str " is now a coercion") + Flags.if_verbose Feedback.msg_info (pr_global ref' ++ str " is now a coercion") let vernac_identity_coercion locality poly local id qids qidt = let local = enforce_locality locality local in @@ -920,7 +919,7 @@ let vernac_chdir = function so we make it an error. *) user_err Pp.(str ("Cd failed: " ^ err)) end; - if_verbose Feedback.msg_info (str (Sys.getcwd())) + Flags.if_verbose Feedback.msg_info (str (Sys.getcwd())) (********************) @@ -1231,7 +1230,7 @@ let vernac_reserve bl = let env = Global.env() in let sigma = Evd.from_env env in let t,ctx = Constrintern.interp_type env sigma c in - let t = Detyping.detype Detyping.Now false [] env (Evd.from_ctx ctx) (EConstr.of_constr t) in + let t = Detyping.detype Detyping.Now false Id.Set.empty env (Evd.from_ctx ctx) (EConstr.of_constr t) in let t,_ = Notation_ops.notation_constr_of_glob_constr (default_env ()) t in Reserve.declare_reserved_type idl t) in List.iter sb_decl bl @@ -1302,7 +1301,7 @@ let _ = optname = "automatic introduction of variables"; optkey = ["Automatic";"Introduction"]; optread = Flags.is_auto_intros; - optwrite = make_auto_intros } + optwrite = Flags.make_auto_intros } let _ = declare_bool_option @@ -1556,7 +1555,7 @@ let vernac_check_may_eval ?loc redexp glopt rc = let sigma' = Evarconv.solve_unif_constraints_with_heuristics env sigma' in Evarconv.check_problems_are_solved env sigma'; let sigma',nf = Evarutil.nf_evars_and_universes sigma' in - let pl, uctx = Evd.universe_context sigma' in + let pl, uctx = Evd.universe_context ~names:[] ~extensible:true sigma' in let env = Environ.push_context uctx (Evarutil.nf_env_evar sigma' env) in let c = nf c in let j = @@ -1924,7 +1923,6 @@ let interp ?proof ?loc locality poly c = | VernacTime _ -> assert false | VernacRedirect _ -> assert false | VernacTimeout _ -> assert false - | VernacStm _ -> assert false (* The STM should handle that, but LOAD bypasses the STM... *) | VernacAbortAll -> CErrors.user_err (str "AbortAll cannot be used through the Load command") @@ -2050,7 +2048,7 @@ let interp ?proof ?loc locality poly c = | VernacSearch (s,g,r) -> vernac_search ?loc s g r | VernacLocate l -> vernac_locate l | VernacRegister (id, r) -> vernac_register id r - | VernacComments l -> if_verbose Feedback.msg_info (str "Comments ok\n") + | VernacComments l -> Flags.if_verbose Feedback.msg_info (str "Comments ok\n") (* Proof management *) | VernacGoal t -> vernac_start_proof locality poly Theorem [None,([],t)] @@ -2176,7 +2174,7 @@ let with_fail b f = | HasNotFailed -> user_err ~hdr:"Fail" (str "The command has not failed!") | HasFailed msg -> - if not !Flags.quiet || !test_mode || !ide_slave then Feedback.msg_info + if not !Flags.quiet || !Flags.test_mode || !Flags.ide_slave then Feedback.msg_info (str "The command has indeed failed with message:" ++ fnl () ++ msg) | _ -> assert false end @@ -2185,10 +2183,6 @@ let interp ?(verbosely=true) ?proof (loc,c) = let orig_program_mode = Flags.is_program_mode () in let rec aux ?locality ?polymorphism isprogcmd = function - (* This assert case will be removed when fake_ide can understand - completion feedback *) - | VernacStm _ -> assert false (* Done by Stm *) - | VernacProgram c when not isprogcmd -> aux ?locality ?polymorphism true c | VernacProgram _ -> user_err Pp.(str "Program mode specified twice") | VernacLocal (b, c) when Option.is_empty locality -> diff --git a/vernac/vernacprop.ml b/vernac/vernacprop.ml index fc11bcf4a..3cff1f14c 100644 --- a/vernac/vernacprop.ml +++ b/vernac/vernacprop.ml @@ -17,8 +17,7 @@ let rec is_navigation_vernac = function | VernacResetName _ | VernacBacktrack _ | VernacBackTo _ - | VernacBack _ - | VernacStm _ -> true + | VernacBack _ -> true | VernacRedirect (_, (_,c)) | VernacTime (_,c) -> is_navigation_vernac c (* Time Back* is harmless *) |