diff options
173 files changed, 1550 insertions, 946 deletions
diff --git a/.travis.yml b/.travis.yml index b9ea455da6..6c926aacbd 100644 --- a/.travis.yml +++ b/.travis.yml @@ -147,7 +147,8 @@ matrix: - 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="" diff --git a/API/API.ml b/API/API.ml index 68da858ba0..46ad36d36d 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 901ed3528b..3ed326ff0e 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 -> diff --git a/COMPATIBILITY b/COMPATIBILITY index 78dfabaa3e..b5fed7f018 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 ---------------------------------------------------------------- diff --git a/checker/checker.ml b/checker/checker.ml index 7a69700d28..247a98e63e 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 3c9e1cac54..63e28448f9 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/dev/build/windows/MakeCoq_MinGW.bat b/dev/build/windows/MakeCoq_MinGW.bat index a420b5d8bb..f91b301b8c 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 f3e4cec0b9..f12cbe0a78 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 ca6a5643c1..e2fbf1f6d1 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-common.sh b/dev/ci/ci-common.sh index 358f527f9e..1bfdf7dfbe 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/doc/xml-protocol.md b/dev/doc/xml-protocol.md index 127b4a6d2d..cf7d205d8b 100644 --- a/dev/doc/xml-protocol.md +++ b/dev/doc/xml-protocol.md @@ -291,7 +291,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/refman/AddRefMan-pre.tex b/doc/refman/AddRefMan-pre.tex index eee41a6798..856a823de0 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 1609e4a041..30039d4898 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 275e1c2d55..8961b00964 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 a95d8114ff..7ad895f9d8 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 7e07868a38..22c75b4fc8 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 16006a6adf..ec46e1eb58 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 499239b6f3..83e866e9f3 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 4daf98f87a..2617142f5a 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 e953d2f709..ab00fbfe37 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 70e36a5ee9..1401af10f6 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 1610305e75..8025fbe29f 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 77d5928345..d9b8b8c522 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 f60908da6c..1e204dc83d 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-cic.tex b/doc/refman/RefMan-cic.tex index ad795d4064..0dbfe05d48 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-com.tex b/doc/refman/RefMan-com.tex index 45230fb6e5..9790111f14 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} diff --git a/doc/refman/RefMan-ext.tex b/doc/refman/RefMan-ext.tex index 7af4e9313a..b27a4dc943 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 ef12fe416a..df0cd2b825 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 c6fbd1c538..75f3d18ded 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 2b9e4e6051..f802a35950 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 4ebb484e7c..c8e8443026 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 3ce1d4ecd8..574591185c 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 2019a529fe..7c672cf422 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 8f43ebcfbc..60cd8b73a4 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 0c2a18eb2e..991c9745e9 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 eb59ca584e..8f659ded35 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 23a1c9b029..956f308512 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 db794e5a63..be199e0b24 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 d8a353300f..eecb5ac7c0 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 8fbcfdf308..a2d45046b0 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 cb8f916f13..7cdb1a5274 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-uti.tex b/doc/refman/RefMan-uti.tex index f6371f8e5c..ed41e32161 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 0c8cd408f2..b7b343112f 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 6ea2537399..75fac9454a 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/evd.ml b/engine/evd.ml index cfc9aa6351..f1b5419dec 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -748,7 +748,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 3f00a3b0b2..abcabe8157 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -493,7 +493,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 +547,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 a75fe721f7..1dd29e6eae 100644 --- a/engine/namegen.ml +++ b/engine/namegen.ml @@ -239,7 +239,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 +253,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 +271,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 +302,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 +310,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 +321,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 +371,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 +379,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 14846a9184..6fde90a39c 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/termops.ml b/engine/termops.ml index e2bdf72387..b7fa2dc4a4 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 63bd247d56..13a9bb3732 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 d198fbfbe9..c44f2c1d74 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 686411e7d5..7f5bf24b74 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/ide_slave.ml b/ide/ide_slave.ml index b11a11606f..f00b1e1421 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 1939a8427c..a5d98946f3 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 4b521a9682..b452b0a13f 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 d1c678b90f..22117e35c0 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 f5eff693ff..f1bee65ef8 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 6f7c6c8277..1cea307d76 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 054e43e7c8..afcd7a2ed2 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 d8241c0443..09a0ba83ca 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 3d48114ec6..0967d21f01 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 3ebc9b71d2..ce19dd8a92 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 6ff5a42728..7b62a2074b 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 a1e5bd0ea9..dc0f60dcf2 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 413cd9704b..8eadafe667 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 807882b42f..8b70731432 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 94e166f920..03e8ea43d1 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 621a9931de..c3fd8962e6 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 377c61de2c..2667ad7ca9 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 a4f2e26b63..94116e4737 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/loc.ml b/lib/loc.ml index 06da13d44f..4a935a9d9c 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 d4061e0446..fde490cc8a 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 diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index 7d0728458b..4e8b98fcf2 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: diff --git a/parsing/g_proofs.ml4 b/parsing/g_proofs.ml4 index 42b5bfa935..e2c87bbbf6 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 de98415cd6..819d236cd3 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 40c5da7a53..3d00b220b8 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 4e6bff20a6..2f03754193 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 fca7d9851f..150319f6b9 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 9772ebd641..9aec190d0a 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/extraction.ml b/plugins/extraction/extraction.ml index 7644b49ceb..a227478d0f 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/table.ml b/plugins/extraction/table.ml index ca98f07e8d..30e3b520f9 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -750,11 +750,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 +763,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/firstorder/instances.ml b/plugins/firstorder/instances.ml index 1690736305..c2606dbe8e 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 5f6d783598..bd5fb1d923 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 ef1654fdf5..018b515170 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 7087a195e4..e8e5bfccc1 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 02ee56ac58..0666ab4f1f 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 5f4d514f36..1e8854249a 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 5f8d50da12..2997537664 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 96200a98a4..77c26f8ce6 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 41a10cba3c..74c454334e 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 4cab6ef336..d9150a7bbd 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 b4c6f9c90e..a7aebf9e15 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/pptactic.ml b/plugins/ltac/pptactic.ml index f4e3ba633f..8a0764975d 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -662,14 +662,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"}" diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 75b665aad9..fd791a9101 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 23767c12f5..63e891b455 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 cf676f598f..a8d518fbd8 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 8fa95ffb02..18348bc113 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 -> @@ -1956,7 +1956,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 c1ab2b4c49..d0a0a81d4c 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 a4103634e0..fc6781b067 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 99493d6982..ae1a563bee 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 d0fe1f9570..b8fae2494f 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 8b69c3435a..95ca6f49ad 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 060225dab7..1e1a986daa 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/pretyping/cases.ml b/pretyping/cases.ml index 7455587c0a..08ce72932a 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 428f64b999..7bdc604b88 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 1cc072a2a2..260cd04446 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 fc0a650bc2..7cfd2e27d9 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 ca7f633dc5..0973d73ee0 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 1eb22cdb81..69a49749cd 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 ("INTERNAL#" ^ 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 67c852af32..b70bfd83c1 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 7f5a780f9c..5f12f360b3 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 ef0fb8ea6e..ad1409f5b1 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 c40a24e3b7..7804cc6796 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 bacc8fbe4e..49ea9727c6 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 88ca9b5ca8..b31ee03d8c 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 c8b3307d76..d04dcb8e3b 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 f090921e5c..d52c3932df 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 0000000000..d7c42d03af --- /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 0000000000..0c3b749cbf --- /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 37204c2134..102c6ef6de 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 5e57f5de03..10dd42ea91 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 219eafda4c..755e905a70 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 ea60be31f0..5ef7fac814 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 1937885587..23f96b5a32 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 745ee8f367..6e4ecd13b3 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 2ade797f63..cd4d1dcf64 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 52f5f74046..8c0f6ad85f 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 a4d662e0ae..a8ec4d8ca3 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 93bf428fdc..7e6d83b10f 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 31ede2d8b7..5d9b595d36 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 3386044f26..75ec946f03 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -1049,7 +1049,7 @@ end = struct (* {{{ *) 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 +1057,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 +1087,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 +1385,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 +1525,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 +1976,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 @@ -2373,6 +2372,7 @@ let finish () = | _ -> () let wait () = + finish (); Slaves.wait_all_done (); VCS.print () @@ -2386,7 +2386,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 +2483,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 +2503,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 +2772,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 188b176bab..3f01fca013 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 c2ebea961f..158ad90846 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/eqdecide.ml b/tactics/eqdecide.ml index e16fcec7c7..d912decff4 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 ce57682c66..bfbac77872 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 3ea9538f38..e33dd2e5ed 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 9495ca9c55..f391382bfc 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 967ec2a71b..cc9d98f6fe 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 5698312aef..d6c24e9cc9 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 bca0c4c50d..e07d514cd0 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/bugs/closed/5749.v b/test-suite/bugs/closed/5749.v new file mode 100644 index 0000000000..81bfe351c5 --- /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 0000000000..6d0e21f5d0 --- /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 0000000000..e07fdcf831 --- /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/complexity/constructor.v b/test-suite/complexity/constructor.v new file mode 100644 index 0000000000..c5e1953829 --- /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 803fe8029a..c4bd11c57d 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/output/UnivBinders.out b/test-suite/output/UnivBinders.out index 128bc77673..904ff68aa7 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 d9e89e43c6..8656ff1a39 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/success/Inductive.v b/test-suite/success/Inductive.v index f746def5cb..06f807f29a 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 ecc988507c..7eaafc3545 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 b3e41ab1fb..0000000000 --- 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/tools/CoqMakefile.in b/tools/CoqMakefile.in index 56e12a1e06..afe8e62ee3 100644 --- a/tools/CoqMakefile.in +++ b/tools/CoqMakefile.in @@ -500,7 +500,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 diff --git a/tools/coqc.ml b/tools/coqc.ml index 862225d3d1..b381c5ba42 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/fake_ide.ml b/tools/fake_ide.ml index a9da27ba23..79723431cf 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 0f8524e923..c1cdaa5a34 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,7 +537,7 @@ 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 ())) |"-o" -> Flags.compilation_output_name := Some (next()) @@ -551,9 +550,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 +564,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 +618,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 +643,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 1602f9c683..4b97ee0dde 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 @@ -53,7 +52,7 @@ let set_formatter_translator ch = let pr_new_syntax_in_context ?loc chan_beautify ocom = let loc = Option.cata Loc.unloc (0,0) loc in - if !beautify_file then set_formatter_translator chan_beautify; + if !Flags.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 @@ -63,7 +62,7 @@ let pr_new_syntax_in_context ?loc chan_beautify ocom = | Some com -> Ppvernac.pr_vernac com | None -> mt() in let after = comment (CLexer.extract_comments (snd loc)) in - if !beautify_file then + if !Flags.beautify_file then (Pp.pp_with !Topfmt.std_ft (hov 0 (before ++ com ++ after)); Format.pp_print_flush !Topfmt.std_ft ()) else @@ -134,7 +133,7 @@ let rec interp_vernac sid (loc,com) = document. Hopefully this is fixed when VtBack can be removed and Undo etc... are just interpreted regularly. *) let is_proof_step = match fst (Vernac_classifier.classify_vernac v) with - | VtProofStep _ | VtStm (VtBack _, _) | VtStartProof _ -> true + | VtProofStep _ | VtBack (_, _) | VtStartProof _ -> true | _ -> false in @@ -209,7 +208,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 chan_beautify (Some ast); Option.iter (vernac_echo ?loc) in_echo; checknav_simple (loc, ast); @@ -224,7 +223,7 @@ 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 + if !Flags.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; !rsid @@ -290,7 +289,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 +313,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 +328,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 59920742d8..503508fc04 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 be682977e5..3915148a08 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 ab1892a18e..0926c93e57 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 fc2fdbbf34..fcdb5c3bc5 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 32ab5401a0..120f9590f2 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 } @@ -526,8 +525,8 @@ let interp_mutual_inductive (paramsl,indl) notations cum poly prv finite = 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 +575,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 +691,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 +796,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 +916,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 +1018,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 +1053,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 +1069,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 +1124,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 +1147,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 +1167,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 +1181,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 +1199,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 +1283,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 8d17f27c30..afa97aa24f 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 474c0b4dd2..0e4bbd2993 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/indschemes.ml b/vernac/indschemes.ml index facebd096a..90168843a6 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 645320c603..2c8f6ec9d6 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 a8c09c0fed..1e23c7314b 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 c424b1d501..5298ef2e44 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; } @@ -1073,7 +1080,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; @@ -1389,7 +1396,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 e8a0ba3dda..1edbd1a850 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 @@ -365,7 +364,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 a4fe49020a..81218308f9 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 5614403ba5..11c2553ae1 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 a2e443e5f7..18e7796caf 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 9a0c9ef9d1..aea474581e 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 4fd08b42d4..83296cf58f 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 fc11bcf4a0..3cff1f14c0 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 *) |