diff options
Diffstat (limited to 'vernac')
32 files changed, 200 insertions, 145 deletions
diff --git a/vernac/assumptions.ml b/vernac/assumptions.ml index 3ca2a4ad6b..b5cc74b594 100644 --- a/vernac/assumptions.ml +++ b/vernac/assumptions.ml @@ -294,7 +294,7 @@ let traverse current t = let type_of_constant cb = cb.Declarations.const_type let assumptions ?(add_opaque=false) ?(add_transparent=false) st gr t = - (** Only keep the transitive dependencies *) + (* Only keep the transitive dependencies *) let (_, graph, ax2ty) = traverse (label_of gr) t in let fold obj _ accu = match obj with | VarRef id -> diff --git a/vernac/attributes.mli b/vernac/attributes.mli index 6a32960a9d..66e10f94cd 100644 --- a/vernac/attributes.mli +++ b/vernac/attributes.mli @@ -119,6 +119,7 @@ val vernac_monomorphic_flag : vernac_flag (** For the stm, do not use! *) val polymorphic_nowarn : bool attribute + (** For internal use, avoid warning if not qualified as eg [universes(polymorphic)]. *) val universe_polymorphism_option_name : string list val is_universe_polymorphism : unit -> bool diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index fa1b8eeb3e..d9787bc73c 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -335,8 +335,8 @@ let build_beq_scheme mode kn = | Finite -> mkFix (((Array.make nb_ind 0),i),(names,types,cores)) | BiFinite -> - (** If the inductive type is not recursive, the fixpoint is not - used, so let's replace it with garbage *) + (* If the inductive type is not recursive, the fixpoint is + not used, so let's replace it with garbage *) let subst = List.init nb_ind (fun _ -> mkProp) in Vars.substl subst cores.(i) in diff --git a/vernac/class.ml b/vernac/class.ml index ab43d5c8ff..8374a5c84f 100644 --- a/vernac/class.ml +++ b/vernac/class.ml @@ -66,7 +66,7 @@ let explain_coercion_error g = function let check_reference_arity ref = let env = Global.env () in let c, _ = Typeops.type_of_global_in_context env ref in - if not (Reductionops.is_arity env (Evd.from_env env) (EConstr.of_constr c)) (** FIXME *) then + if not (Reductionops.is_arity env (Evd.from_env env) (EConstr.of_constr c)) (* FIXME *) then raise (CoercionError (NotAClass ref)) let check_arity = function @@ -260,7 +260,7 @@ let add_new_coercion_core coef stre poly source target isid = raise (CoercionError (NoSource source)) in check_source (Some cls); - if not (uniform_cond Evd.empty (** FIXME - for when possibly called with unresolved evars in the future *) + if not (uniform_cond Evd.empty (* FIXME - for when possibly called with unresolved evars in the future *) ctx lvs) then warn_uniform_inheritance coef; let clt = diff --git a/vernac/classes.ml b/vernac/classes.ml index d0cf1c6bee..a342f5bf98 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -301,10 +301,10 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) ~ if generalize then CAst.make @@ CGeneralization (Implicit, Some AbsPi, tclass) else tclass in - let sigma, k, u, cty, ctx', ctx, len, imps, subst = + let sigma, k, u, cty, ctx', ctx, imps, subst = let sigma, (impls, ((env', ctx), imps)) = interp_context_evars env sigma ctx in let sigma, (c', imps') = interp_type_evars_impls ~impls env' sigma tclass in - let len = List.length ctx in + let len = Context.Rel.nhyps ctx in let imps = imps @ Impargs.lift_implicits len imps' in let ctx', c = decompose_prod_assum sigma c' in let ctx'' = ctx' @ ctx in @@ -320,7 +320,7 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) ~ | LocalDef (_,b,_) -> (args, Vars.substl args' b :: args')) cl_context (args, []) in - sigma, cl, u, c', ctx', ctx, len, imps, args + sigma, cl, u, c', ctx', ctx, imps, args in let id = match instid with @@ -373,7 +373,7 @@ let context poly l = | [] -> assert false | [_] -> Evd.const_univ_entry ~poly sigma | _::_::_ -> - (** TODO: explain this little belly dance *) + (* TODO: explain this little belly dance *) if Lib.sections_are_opened () then begin diff --git a/vernac/classes.mli b/vernac/classes.mli index bb70334342..eb6c0c92e1 100644 --- a/vernac/classes.mli +++ b/vernac/classes.mli @@ -27,22 +27,22 @@ val existing_instance : bool -> qualid -> Hints.hint_info_expr option -> unit val declare_instance_constant : typeclass -> - Hints.hint_info_expr -> (** priority *) - bool -> (** globality *) - Impargs.manual_explicitation list -> (** implicits *) + Hints.hint_info_expr (** priority *) -> + bool (** globality *) -> + Impargs.manual_explicitation list (** implicits *) -> ?hook:(GlobRef.t -> unit) -> - Id.t -> (** name *) + Id.t (** name *) -> UState.universe_decl -> - bool -> (* polymorphic *) - Evd.evar_map -> (* Universes *) - Constr.t -> (** body *) - Constr.types -> (** type *) + bool (** polymorphic *) -> + Evd.evar_map (** Universes *) -> + Constr.t (** body *) -> + Constr.types (** type *) -> unit val new_instance : - ?abstract:bool -> (** Not abstract by default. *) - ?global:bool -> (** Not global by default. *) - ?refine:bool -> (** Allow refinement *) + ?abstract:bool (** Not abstract by default. *) -> + ?global:bool (** Not global by default. *) -> + ?refine:bool (** Allow refinement *) -> program_mode:bool -> Decl_kinds.polymorphic -> local_binder_expr list -> diff --git a/vernac/comFixpoint.mli b/vernac/comFixpoint.mli index f4569ed3e2..338dfa5ef5 100644 --- a/vernac/comFixpoint.mli +++ b/vernac/comFixpoint.mli @@ -78,6 +78,7 @@ val interp_fixpoint : (EConstr.rel_context * Impargs.manual_implicits * int option) list (** Registering fixpoints and cofixpoints in the environment *) + (** [Not used so far] *) val declare_fixpoint : locality -> polymorphic -> diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index 8b9cf7d269..348e76da62 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -34,6 +34,13 @@ module RelDecl = Context.Rel.Declaration (* 3b| Mutual inductive definitions *) +let warn_auto_template = + CWarnings.create ~name:"auto-template" ~category:"vernacular" + (fun id -> + Pp.(strbrk "Automatically declaring " ++ Id.print id ++ + strbrk " as template polymorphic. Use attributes or " ++ + strbrk "disable Auto Template Polymorphism to avoid this warning.")) + let should_auto_template = let open Goptions in let auto = ref true in @@ -44,7 +51,10 @@ let should_auto_template = optread = (fun () -> !auto); optwrite = (fun b -> auto := b); } in - fun () -> !auto + fun id would_auto -> + let b = !auto && would_auto in + if b then warn_auto_template id; + b let rec complete_conclusion a cs = CAst.map_with_loc (fun ?loc -> function | CProdN (bl,c) -> CProdN (bl,complete_conclusion a cs c) @@ -265,7 +275,7 @@ let inductive_levels env evd poly arities inds = else minlev in let minlev = - (** Indices contribute. *) + (* Indices contribute. *) if indices_matter env && List.length ctx > 0 then ( let ilev = sign_level env evd ctx in Univ.sup ilev minlev) @@ -282,15 +292,15 @@ let inductive_levels env evd poly arities inds = let evd, arities = CList.fold_left3 (fun (evd, arities) cu (arity,(ctx,du)) len -> if is_impredicative env du then - (** Any product is allowed here. *) + (* Any product is allowed here. *) evd, arity :: arities - else (** If in a predicative sort, or asked to infer the type, - we take the max of: - - indices (if in indices-matter mode) - - constructors - - Type(1) if there is more than 1 constructor + else (* If in a predicative sort, or asked to infer the type, + we take the max of: + - indices (if in indices-matter mode) + - constructors + - Type(1) if there is more than 1 constructor *) - (** Constructors contribute. *) + (* Constructors contribute. *) let evd = if Sorts.is_set du then if not (Evd.check_leq evd cu Univ.type0_univ) then @@ -301,7 +311,7 @@ let inductive_levels env evd poly arities inds = in let evd = if len >= 2 && Univ.is_type0m_univ cu then - (** "Polymorphic" type constraint and more than one constructor, + (* "Polymorphic" type constraint and more than one constructor, should not land in Prop. Add constraint only if it would land in Prop directly (no informative arguments as well). *) Evd.set_leq_sort env evd Set du @@ -431,8 +441,8 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not if poly && template then user_err Pp.(strbrk "template and polymorphism not compatible"); template | None -> - should_auto_template () && not poly && - Option.cata (fun s -> not (Sorts.is_small s)) false concl + should_auto_template ind.ind_name (not poly && + Option.cata (fun s -> not (Sorts.is_small s)) false concl) in { mind_entry_typename = ind.ind_name; mind_entry_arity = arity; @@ -510,7 +520,7 @@ let is_recursive mie = let rec is_recursive_constructor lift typ = match Constr.kind typ with | Prod (_,arg,rest) -> - not (EConstr.Vars.noccurn Evd.empty (** FIXME *) lift (EConstr.of_constr arg)) || + not (EConstr.Vars.noccurn Evd.empty (* FIXME *) lift (EConstr.of_constr arg)) || is_recursive_constructor (lift+1) rest | LetIn (na,b,t,rest) -> is_recursive_constructor (lift+1) rest | _ -> false diff --git a/vernac/comInductive.mli b/vernac/comInductive.mli index f23085a538..1d6f652385 100644 --- a/vernac/comInductive.mli +++ b/vernac/comInductive.mli @@ -39,14 +39,17 @@ val do_mutual_inductive : associated schemes *) type one_inductive_impls = - Impargs.manual_implicits (** for inds *)* - Impargs.manual_implicits list (** for constrs *) + Impargs.manual_implicits (* for inds *) * + Impargs.manual_implicits list (* for constrs *) val declare_mutual_inductive_with_eliminations : mutual_inductive_entry -> UnivNames.universe_binders -> one_inductive_impls list -> MutInd.t -val should_auto_template : unit -> bool +val should_auto_template : Id.t -> bool -> bool +(** [should_auto_template x b] is [true] when [b] is [true] and we + automatically use template polymorphism. [x] is the name of the + inductive under consideration. *) (** Exported for Funind *) diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml index e62ae99159..edce8e255c 100644 --- a/vernac/comProgramFixpoint.ml +++ b/vernac/comProgramFixpoint.ml @@ -211,7 +211,7 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = let univs = Evd.check_univ_decl ~poly sigma decl in (*FIXME poly? *) let ce = definition_entry ~types:ty ~univs (EConstr.to_constr sigma body) in - (** FIXME: include locality *) + (* FIXME: include locality *) let c = Declare.declare_constant recname (DefinitionEntry ce, IsDefinition Definition) in let gr = ConstRef c in if Impargs.is_implicit_args () || not (List.is_empty impls) then diff --git a/vernac/declareDef.ml b/vernac/declareDef.ml index 898de7b166..41057f8ab2 100644 --- a/vernac/declareDef.ml +++ b/vernac/declareDef.ml @@ -27,7 +27,7 @@ let warn_local_declaration = let get_locality id ~kind = function | Discharge -> - (** If a Let is defined outside a section, then we consider it as a local definition *) + (* If a Let is defined outside a section, then we consider it as a local definition *) warn_local_declaration (id,kind); true | Local -> true diff --git a/vernac/explainErr.ml b/vernac/explainErr.ml index befb4d7ccf..e1496e58d7 100644 --- a/vernac/explainErr.ml +++ b/vernac/explainErr.ml @@ -64,8 +64,8 @@ let process_vernac_interp_error exn = match fst exn with wrap_vernac_error exn (Himsg.explain_type_error ctx Evd.empty te) | PretypeError(ctx,sigma,te) -> wrap_vernac_error exn (Himsg.explain_pretype_error ctx sigma te) - | Notation.NumeralNotationError(ctx,sigma,te) -> - wrap_vernac_error exn (Himsg.explain_numeral_notation_error ctx sigma te) + | Notation.PrimTokenNotationError(kind,ctx,sigma,te) -> + wrap_vernac_error exn (Himsg.explain_prim_token_notation_error kind ctx sigma te) | Typeclasses_errors.TypeClassError(env, te) -> wrap_vernac_error exn (Himsg.explain_typeclass_error env te) | Implicit_quantifiers.MismatchedContextInstance(e,c,l,x) -> diff --git a/vernac/himsg.ml b/vernac/himsg.ml index 6c7117b513..f3e1e1fc49 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -125,12 +125,12 @@ let display_eq ~flags env sigma t1 t2 = printed alike. *) let rec pr_explicit_aux env sigma t1 t2 = function | [] -> - (** no specified flags: default. *) + (* no specified flags: default. *) (quote (Printer.pr_leconstr_env env sigma t1), quote (Printer.pr_leconstr_env env sigma t2)) | flags :: rem -> let equal = display_eq ~flags env sigma t1 t2 in if equal then - (** The two terms are the same from the user point of view *) + (* The two terms are the same from the user point of view *) pr_explicit_aux env sigma t1 t2 rem else let open Constrextern in @@ -142,12 +142,12 @@ let rec pr_explicit_aux env sigma t1 t2 = function let explicit_flags = let open Constrextern in - [ []; (** First, try with the current flags *) - [print_implicits]; (** Then with implicit *) - [print_universes]; (** Then with universes *) - [print_universes; print_implicits]; (** With universes AND implicits *) - [print_implicits; print_coercions; print_no_symbol]; (** Then more! *) - [print_universes; print_implicits; print_coercions; print_no_symbol] (** and more! *) ] + [ []; (* First, try with the current flags *) + [print_implicits]; (* Then with implicit *) + [print_universes]; (* Then with universes *) + [print_universes; print_implicits]; (* With universes AND implicits *) + [print_implicits; print_coercions; print_no_symbol]; (* Then more! *) + [print_universes; print_implicits; print_coercions; print_no_symbol] (* and more! *) ] let pr_explicit env sigma t1 t2 = pr_explicit_aux env sigma t1 t2 explicit_flags @@ -328,7 +328,7 @@ let explain_actual_type env sigma j t reason = let env = make_all_name_different env sigma in let j = j_nf_betaiotaevar env sigma j in let t = Reductionops.nf_betaiota env sigma t in - (** Actually print *) + (* Actually print *) let pe = pr_ne_context_of (str "In environment") env sigma in let pc = pr_leconstr_env env sigma (Environ.j_val j) in let (pt, pct) = pr_explicit env sigma t (Environ.j_type j) in @@ -511,7 +511,7 @@ let pr_trailing_ne_context_of env sigma = if List.is_empty (Environ.rel_context env) && List.is_empty (Environ.named_context env) then str "." - else (str " in environment:"++ pr_context_unlimited env sigma) + else (strbrk " in environment:" ++ pr_context_unlimited env sigma) let rec explain_evar_kind env sigma evk ty = let open Evar_kinds in @@ -551,21 +551,21 @@ let rec explain_evar_kind env sigma evk ty = strbrk "an instance of type " ++ ty ++ str " for the variable " ++ Id.print id | Evar_kinds.SubEvar (where,evk') -> - let evi = Evd.find sigma evk' in + let rec find_source evk = + let evi = Evd.find sigma evk in + match snd evi.evar_source with + | Evar_kinds.SubEvar (_,evk) -> find_source evk + | src -> evi,src in + let evi,src = find_source evk' in let pc = match evi.evar_body with | Evar_defined c -> pr_leconstr_env env sigma c | Evar_empty -> assert false in let ty' = evi.evar_concl in - (match where with - | Some Evar_kinds.Body -> str "the body of " - | Some Evar_kinds.Domain -> str "the domain of " - | Some Evar_kinds.Codomain -> str "the codomain of " - | None -> - pr_existential_key sigma evk ++ str " of type " ++ ty ++ - str " in the partial instance " ++ pc ++ - str " found for ") ++ - explain_evar_kind env sigma evk' - (pr_leconstr_env env sigma ty') (snd evi.evar_source) + pr_existential_key sigma evk ++ + strbrk " in the partial instance " ++ pc ++ + strbrk " found for " ++ + explain_evar_kind env sigma evk + (pr_leconstr_env env sigma ty') src let explain_typeclass_resolution env sigma evi k = match Typeclasses.class_of_constr sigma evi.evar_concl with @@ -774,7 +774,7 @@ let explain_unsatisfiable_constraints env sigma constr comp = let (_, constraints) = Evd.extract_all_conv_pbs sigma in let tcs = Evd.get_typeclass_evars sigma in let undef = Evd.undefined_map sigma in - (** Only keep evars that are subject to resolution and members of the given + (* Only keep evars that are subject to resolution and members of the given component. *) let is_kept evk _ = match comp with | None -> Evar.Set.mem evk tcs @@ -1112,7 +1112,7 @@ let error_ill_formed_inductive env c v = let error_ill_formed_constructor env id c v nparams nargs = let pv = pr_lconstr_env env (Evd.from_env env) v in - let atomic = Int.equal (nb_prod Evd.empty (EConstr.of_constr c)) (** FIXME *) 0 in + let atomic = Int.equal (nb_prod Evd.empty (EConstr.of_constr c)) (* FIXME *) 0 in str "The type of constructor" ++ brk(1,1) ++ Id.print id ++ brk(1,1) ++ str "is not valid;" ++ brk(1,1) ++ strbrk (if atomic then "it must be " else "its conclusion must be ") ++ @@ -1326,12 +1326,12 @@ let explain_reduction_tactic_error = function spc () ++ str "is not well typed." ++ fnl () ++ explain_type_error env' (Evd.from_env env') e -let explain_numeral_notation_error env sigma = function +let explain_prim_token_notation_error kind env sigma = function | Notation.UnexpectedTerm c -> (strbrk "Unexpected term " ++ pr_constr_env env sigma c ++ - strbrk " while parsing a numeral notation.") + strbrk (" while parsing a "^kind^" notation.")) | Notation.UnexpectedNonOptionTerm c -> (strbrk "Unexpected non-option term " ++ pr_constr_env env sigma c ++ - strbrk " while parsing a numeral notation.") + strbrk (" while parsing a "^kind^" notation.")) diff --git a/vernac/himsg.mli b/vernac/himsg.mli index db05aaa125..bab66b2af4 100644 --- a/vernac/himsg.mli +++ b/vernac/himsg.mli @@ -47,4 +47,4 @@ val explain_module_internalization_error : val map_pguard_error : ('c -> 'd) -> 'c pguard_error -> 'd pguard_error val map_ptype_error : ('c -> 'd) -> ('c, 'c) ptype_error -> ('d, 'd) ptype_error -val explain_numeral_notation_error : env -> Evd.evar_map -> Notation.numeral_notation_error -> Pp.t +val explain_prim_token_notation_error : string -> env -> Evd.evar_map -> Notation.prim_token_notation_error -> Pp.t diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml index 9bd095aa52..d29f66f81f 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -307,7 +307,7 @@ let warn_cannot_build_congruence = strbrk "Cannot build congruence scheme because eq is not found") let declare_congr_scheme ind = - if Hipattern.is_equality_type Evd.empty (EConstr.of_constr (mkInd ind)) (** FIXME *) then begin + if Hipattern.is_equality_type Evd.empty (EConstr.of_constr (mkInd ind)) (* FIXME *) then begin if try Coqlib.check_required_library Coqlib.logic_module_name; true with e when CErrors.noncritical e -> false diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index 1a6eda446c..8f155adb8a 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -483,7 +483,7 @@ let save_proof ?proof = function let pftree = Proof_global.give_me_the_proof () in let id, k, typ = Pfedit.current_proof_statement () in let typ = EConstr.Unsafe.to_constr typ in - let universes = Proof.initial_euctx pftree in + let universes = Proof.((data pftree).initial_euctx) in (* This will warn if the proof is complete *) let pproofs, _univs = Proof_global.return_proof ~allow_partial:true () in diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index 82434afbbd..3da12e7714 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -33,11 +33,9 @@ open Nameops let cache_token (_,s) = CLexer.add_keyword s let inToken : string -> obj = - declare_object {(default_object "TOKEN") with - open_function = (fun i o -> if Int.equal i 1 then cache_token o); - cache_function = cache_token; - subst_function = Libobject.ident_subst_function; - classify_function = (fun o -> Substitute o)} + declare_object @@ global_object_nodischarge "TOKEN" + ~cache:cache_token + ~subst:(Some Libobject.ident_subst_function) let add_token_obj s = Lib.add_anonymous_leaf (inToken s) @@ -1361,7 +1359,7 @@ let inNotation : notation_obj -> obj = (**********************************************************************) let with_lib_stk_protection f x = - let fs = Lib.freeze ~marshallable:`No in + let fs = Lib.freeze ~marshallable:false in try let a = f x in Lib.unfreeze fs; a with reraise -> let reraise = CErrors.push reraise in @@ -1467,7 +1465,7 @@ let add_notation_in_scope local df env c mods scope = notobj_local = local; notobj_scope = scope; notobj_interp = (List.map_filter map i_vars, ac); - (** Order is important here! *) + (* Order is important here! *) notobj_onlyparse = onlyparse; notobj_coercion = coe; notobj_onlyprint = sd.only_printing; @@ -1486,7 +1484,7 @@ let add_notation_interpretation_core local df env ?(impls=empty_internalization_ let level, i_typs, onlyprint = if not (is_numeral symbs) then begin let sy = recover_notation_syntax (make_notation_key InConstrEntrySomeLevel symbs) in let () = Lib.add_anonymous_leaf (inSyntaxExtension (local,sy)) in - (** If the only printing flag has been explicitly requested, put it back *) + (* If the only printing flag has been explicitly requested, put it back *) let onlyprint = onlyprint || sy.synext_notgram.notgram_onlyprinting in let _,_,_,typs = sy.synext_level in Some sy.synext_level, typs, onlyprint @@ -1507,7 +1505,7 @@ let add_notation_interpretation_core local df env ?(impls=empty_internalization_ notobj_local = local; notobj_scope = scope; notobj_interp = (List.map_filter map i_vars, ac); - (** Order is important here! *) + (* Order is important here! *) notobj_onlyparse = onlyparse; notobj_coercion = coe; notobj_onlyprint = onlyprint; @@ -1565,14 +1563,17 @@ let add_notation_extra_printing_rule df k v = (* Infix notations *) -let inject_var x = CAst.make @@ CRef (qualid_of_ident (Id.of_string x),None) +let inject_var x = CAst.make @@ CRef (qualid_of_ident x,None) let add_infix local env ({CAst.loc;v=inf},modifiers) pr sc = check_infix_modifiers modifiers; (* check the precedence *) - let metas = [inject_var "x"; inject_var "y"] in + let vars = names_of_constr_expr pr in + let x = Namegen.next_ident_away (Id.of_string "x") vars in + let y = Namegen.next_ident_away (Id.of_string "y") vars in + let metas = [inject_var x; inject_var y] in let c = mkAppC (pr,metas) in - let df = CAst.make ?loc @@ "x "^(quote_notation_token inf)^" y" in + let df = CAst.make ?loc @@ Id.to_string x ^" "^(quote_notation_token inf)^" "^Id.to_string y in add_notation local env c (df,modifiers) sc (**********************************************************************) diff --git a/vernac/mltop.ml b/vernac/mltop.ml index 3620e177fe..8d6268753e 100644 --- a/vernac/mltop.ml +++ b/vernac/mltop.ml @@ -394,7 +394,7 @@ let unfreeze_ml_modules x = let _ = Summary.declare_ml_modules_summary - { Summary.freeze_function = (fun _ -> get_loaded_modules ()); + { Summary.freeze_function = (fun ~marshallable -> get_loaded_modules ()); Summary.unfreeze_function = unfreeze_ml_modules; Summary.init_function = reset_loaded_modules } diff --git a/vernac/obligations.ml b/vernac/obligations.ml index f18227039f..6642d04c98 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -381,7 +381,7 @@ let subst_deps expand obls deps t = (Vars.replace_vars (List.map (fun (n, (_, b)) -> n, b) osubst) t) let rec prod_app t n = - match Constr.kind (EConstr.Unsafe.to_constr (Termops.strip_outer_cast Evd.empty (EConstr.of_constr t))) (** FIXME *) with + match Constr.kind (EConstr.Unsafe.to_constr (Termops.strip_outer_cast Evd.empty (EConstr.of_constr t))) (* FIXME *) with | Prod (_,_,b) -> subst1 n b | LetIn (_, b, t, b') -> prod_app (subst1 b b') n | _ -> @@ -503,7 +503,7 @@ let compute_possible_guardness_evidences (n,_) fixbody fixtype = but doing it properly involves delta-reduction, and it finally doesn't seem to worth the effort (except for huge mutual fixpoints ?) *) - let m = Termops.nb_prod Evd.empty (EConstr.of_constr fixtype) (** FIXME *) in + let m = Termops.nb_prod Evd.empty (EConstr.of_constr fixtype) (* FIXME *) in let ctx = fst (decompose_prod_n_assum m fixtype) in List.map_i (fun i _ -> i) 0 ctx @@ -649,7 +649,7 @@ let declare_obligation prg obl body ty uctx = const_entry_inline_code = false; const_entry_feedback = None; } in - (** ppedrot: seems legit to have obligations as local *) + (* ppedrot: seems legit to have obligations as local *) let constant = Declare.declare_constant obl.obl_name ~local:true (DefinitionEntry ce,IsProof Property) in @@ -857,9 +857,9 @@ let obligation_terminator ?univ_hook name num guard auto pf = let sigma = Evd.from_ctx uctx in let sigma = Evd.merge_context_set ~sideff:true Evd.univ_rigid sigma cstr in Inductiveops.control_only_guard (Global.env ()) sigma (EConstr.of_constr body); - (** Declare the obligation ourselves and drop the hook *) + (* Declare the obligation ourselves and drop the hook *) let prg = get_info (ProgMap.find name !from_prg) in - (** Ensure universes are substituted properly in body and type *) + (* Ensure universes are substituted properly in body and type *) let body = EConstr.to_constr sigma (EConstr.of_constr body) in let ty = Option.map (fun x -> EConstr.to_constr sigma (EConstr.of_constr x)) ty in let ctx = Evd.evar_universe_context sigma in @@ -885,14 +885,14 @@ let obligation_terminator ?univ_hook name num guard auto pf = let () = obls.(num) <- obl in let prg_ctx = if pi2 (prg.prg_kind) then (* Polymorphic *) - (** We merge the new universes and constraints of the - polymorphic obligation with the existing ones *) + (* We merge the new universes and constraints of the + polymorphic obligation with the existing ones *) UState.union prg.prg_ctx ctx else - (** The first obligation, if defined, - declares the univs of the constant, - each subsequent obligation declares its own additional - universes and constraints if any *) + (* The first obligation, if defined, + declares the univs of the constant, + each subsequent obligation declares its own additional + universes and constraints if any *) if defined then UState.make (Global.universes ()) else ctx in diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index e7c1e29beb..e0dd3380f9 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -363,7 +363,7 @@ open Pputils match factorize l with | (xl,((c', t') as r))::l' when (c : bool) == c' && Pervasives.(=) t t' -> - (** FIXME: we need equality on constr_expr *) + (* FIXME: we need equality on constr_expr *) (idl@xl,r)::l' | l' -> (idl,(c,t))::l' @@ -700,7 +700,7 @@ open Pputils | None -> mt() | Some r -> keyword "Eval" ++ spc() ++ - pr_red_expr (pr_constr, pr_lconstr, pr_smart_global, pr_constr) keyword r ++ + Ppred.pr_red_expr (pr_constr, pr_lconstr, pr_smart_global, pr_constr) keyword r ++ keyword " in" ++ spc() in let pr_def_body = function @@ -1134,7 +1134,7 @@ open Pputils let pr_mayeval r c = match r with | Some r0 -> hov 2 (keyword "Eval" ++ spc() ++ - pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) keyword r0 ++ + Ppred.pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) keyword r0 ++ spc() ++ keyword "in" ++ spc () ++ pr_lconstr c) | None -> hov 2 (keyword "Check" ++ spc() ++ pr_lconstr c) in @@ -1146,7 +1146,7 @@ open Pputils | VernacDeclareReduction (s,r) -> return ( keyword "Declare Reduction" ++ spc () ++ str s ++ str " := " ++ - pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) keyword r + Ppred.pr_red_expr (pr_constr,pr_lconstr,pr_smart_global, pr_constr) keyword r ) | VernacPrint p -> return (pr_printable p) diff --git a/vernac/pvernac.ml b/vernac/pvernac.ml index f26e0d0885..a647b2ef73 100644 --- a/vernac/pvernac.ml +++ b/vernac/pvernac.ml @@ -52,4 +52,4 @@ let set_command_entry e = Vernac_.command_entry_ref := e let get_command_entry () = !Vernac_.command_entry_ref let () = - register_grammar Stdarg.wit_red_expr (Vernac_.red_expr); + register_grammar Genredexpr.wit_red_expr (Vernac_.red_expr); diff --git a/vernac/record.ml b/vernac/record.ml index f6dbcb5291..2867ad1437 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -321,7 +321,7 @@ let declare_projections indsp ctx ?(kind=StructureComponent) binder_name coers f ~proj_arg:i (Label.of_id fid) in - (** Already defined by declare_mind silently *) + (* Already defined by declare_mind silently *) let kn = Projection.Repr.constant p in Declare.definition_message fid; kn, mkProj (Projection.make p false,mkRel 1) @@ -415,9 +415,9 @@ let declare_structure finite ubinders univs paramimpls params template ?(kind=St template | None, template -> (* auto detect template *) - ComInductive.should_auto_template () && template && not poly && + ComInductive.should_auto_template id (template && not poly && let _, s = Reduction.dest_arity (Global.env()) arity in - not (Sorts.is_small s) + not (Sorts.is_small s)) in { mind_entry_typename = id; mind_entry_arity = arity; diff --git a/vernac/search.ml b/vernac/search.ml index 1fac28358a..6610789626 100644 --- a/vernac/search.ml +++ b/vernac/search.ml @@ -172,8 +172,8 @@ let prioritize_search seq fn = (** Filters *) -(** This function tries to see whether the conclusion matches a pattern. *) -(** FIXME: this is quite dummy, we may find a more efficient algorithm. *) +(** This function tries to see whether the conclusion matches a pattern. + FIXME: this is quite dummy, we may find a more efficient algorithm. *) let rec pattern_filter pat ref env sigma typ = let typ = Termops.strip_outer_cast sigma typ in if Constr_matching.is_matching env sigma pat typ then true diff --git a/vernac/search.mli b/vernac/search.mli index 0dc82c1c3f..ecbb02bc68 100644 --- a/vernac/search.mli +++ b/vernac/search.mli @@ -49,16 +49,16 @@ val search_about : int option -> (bool * glob_search_about_item) list -> DirPath.t list * bool -> display_function -> unit type search_constraint = - (** Whether the name satisfies a regexp (uses Ocaml Str syntax) *) | Name_Pattern of Str.regexp - (** Whether the object type satisfies a pattern *) + (** Whether the name satisfies a regexp (uses Ocaml Str syntax) *) | Type_Pattern of Pattern.constr_pattern - (** Whether some subtype of object type satisfies a pattern *) + (** Whether the object type satisfies a pattern *) | SubType_Pattern of Pattern.constr_pattern - (** Whether the object pertains to a module *) + (** Whether some subtype of object type satisfies a pattern *) | In_Module of Names.DirPath.t - (** Bypass the Search blacklist *) + (** Whether the object pertains to a module *) | Include_Blacklist + (** Bypass the Search blacklist *) type 'a coq_object = { coq_object_prefix : string list; diff --git a/vernac/topfmt.ml b/vernac/topfmt.ml index 4bf76dae51..b4b893a3fd 100644 --- a/vernac/topfmt.ml +++ b/vernac/topfmt.ml @@ -222,20 +222,21 @@ let diff_tag_stack = ref [] (* global, just like std_ft *) (** Not thread-safe. We should put a lock somewhere if we print from different threads. Do we? *) let make_style_stack () = - (** Default tag is to reset everything *) + (* Default tag is to reset everything *) let style_stack = ref [] in let peek () = match !style_stack with - | [] -> default_style (** Anomalous case, but for robustness *) + | [] -> default_style (* Anomalous case, but for robustness *) | st :: _ -> st in let open_tag tag = let (tpfx, ttag) = split_tag tag in if tpfx = end_pfx then "" else let style = get_style ttag in - (** Merge the current settings and the style being pushed. This allows - restoring the previous settings correctly in a pop when both set the same - attribute. Example: current settings have red FG, the pushed style has - green FG. When popping the style, we should set red FG, not default FG. *) + (* Merge the current settings and the style being pushed. This + allows restoring the previous settings correctly in a pop + when both set the same attribute. Example: current settings + have red FG, the pushed style has green FG. When popping the + style, we should set red FG, not default FG. *) let style = Terminal.merge (peek ()) style in let diff = Terminal.diff (peek ()) style in style_stack := style :: !style_stack; @@ -247,7 +248,7 @@ let make_style_stack () = if tpfx = start_pfx then "" else begin if tpfx = end_pfx then diff_tag_stack := (try List.tl !diff_tag_stack with tl -> []); match !style_stack with - | [] -> (** Something went wrong, we fallback *) + | [] -> (* Something went wrong, we fallback *) Terminal.eval default_style | cur :: rem -> style_stack := rem; if cur = (peek ()) then "" else @@ -405,3 +406,24 @@ let with_output_to_file fname func input = deep_ft := Util.pi3 old_fmt; close_out channel; Exninfo.iraise reraise + +(* For coqtop -time, we display the position in the file, + and a glimpse of the executed command *) + +let pr_cmd_header {CAst.loc;v=com} = + let shorten s = + if Unicode.utf8_length s > 33 then (Unicode.utf8_sub s 0 30) ^ "..." else s + in + let noblank s = String.map (fun c -> + match c with + | ' ' | '\n' | '\t' | '\r' -> '~' + | x -> x + ) s + in + let (start,stop) = Option.cata Loc.unloc (0,0) loc in + let safe_pr_vernac x = + try Ppvernac.pr_vernac x + with e -> str (Printexc.to_string e) in + let cmd = noblank (shorten (string_of_ppcmds (safe_pr_vernac com))) + in str "Chars " ++ int start ++ str " - " ++ int stop ++ + str " [" ++ str cmd ++ str "] " diff --git a/vernac/topfmt.mli b/vernac/topfmt.mli index 0ddf474970..5f84c5edee 100644 --- a/vernac/topfmt.mli +++ b/vernac/topfmt.mli @@ -71,3 +71,4 @@ val print_err_exn : exn -> unit redirected to a file [file] *) val with_output_to_file : string -> ('a -> 'b) -> 'a -> 'b +val pr_cmd_header : Vernacexpr.vernac_control CAst.t -> Pp.t diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index f5d68a2199..dbccea1117 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -82,12 +82,12 @@ let show_proof () = let show_top_evars () = (* spiwack: new as of Feb. 2010: shows goal evars in addition to non-goal evars. *) let pfts = Proof_global.give_me_the_proof () in - let gls,_,shelf,givenup,sigma = Proof.proof pfts in - pr_evars_int sigma ~shelf ~givenup 1 (Evd.undefined_map sigma) + let Proof.{goals;shelf;given_up;sigma} = Proof.data pfts in + pr_evars_int sigma ~shelf ~given_up 1 (Evd.undefined_map sigma) let show_universes () = let pfts = Proof_global.give_me_the_proof () in - let gls,_,_,_,sigma = Proof.proof pfts in + let Proof.{goals;sigma} = Proof.data pfts in let ctx = Evd.universe_context_set (Evd.minimize_universes sigma) in Termops.pr_evar_universe_context (Evd.evar_universe_context sigma) ++ fnl () ++ str "Normalized constraints: " ++ Univ.pr_universe_context_set (Termops.pr_evd_level sigma) ctx @@ -96,9 +96,9 @@ let show_universes () = let show_intro all = let open EConstr in let pf = Proof_global.give_me_the_proof() in - let gls,_,_,_,sigma = Proof.proof pf in - if not (List.is_empty gls) then begin - let gl = {Evd.it=List.hd gls ; sigma = sigma; } in + let Proof.{goals;sigma} = Proof.data pf in + if not (List.is_empty goals) then begin + let gl = {Evd.it=List.hd goals ; sigma = sigma; } in let l,_= decompose_prod_assum sigma (Termops.strip_outer_cast sigma (pf_concl gl)) in if all then let lid = Tactics.find_intro_names l gl in @@ -681,14 +681,14 @@ let vernac_inductive ~atts cum lo finite indl = | _ -> None in if Option.has_some is_defclass then - (** Definitional class case *) + (* Definitional class case *) let (id, bl, c, l) = Option.get is_defclass in let (coe, (lid, ce)) = l in let coe' = if coe then Some true else None in let f = (((coe', AssumExpr ((make ?loc:lid.loc @@ Name lid.v), ce)), None), []) in vernac_record ~template udecl cum (Class true) atts.polymorphic finite [id, bl, c, None, [f]] else if List.for_all is_record indl then - (** Mutual record case *) + (* Mutual record case *) let check_kind ((_, _, _, kind, _), _) = match kind with | Variant -> user_err (str "The Variant keyword does not support syntax { ... }.") @@ -704,14 +704,14 @@ let vernac_inductive ~atts cum lo finite indl = let unpack ((id, bl, c, _, decl), _) = match decl with | RecordDecl (oc, fs) -> (id, bl, c, oc, fs) - | Constructors _ -> assert false (** ruled out above *) + | Constructors _ -> assert false (* ruled out above *) in let ((_, _, _, kind, _), _) = List.hd indl in let kind = match kind with Class _ -> Class false | _ -> kind in let recordl = List.map unpack indl in vernac_record ~template udecl cum kind atts.polymorphic finite recordl else if List.for_all is_constructor indl then - (** Mutual inductive case *) + (* Mutual inductive case *) let check_kind ((_, _, _, kind, _), _) = match kind with | (Record | Structure) -> user_err (str "The Record keyword is for types defined using the syntax { ... }.") @@ -1047,8 +1047,9 @@ let vernac_set_end_tac tac = let vernac_set_used_variables e = let env = Global.env () in + let initial_goals pf = Proofview.initial_goals Proof.(data pf).Proof.entry in let tys = - List.map snd (Proof.initial_goals (Proof_global.give_me_the_proof ())) in + List.map snd (initial_goals (Proof_global.give_me_the_proof ())) in let tys = List.map EConstr.Unsafe.to_constr tys in let l = Proof_using.process_expr env e tys in let vars = Environ.named_context env in @@ -1221,11 +1222,9 @@ let vernac_arguments ~section_local reference args more_implicits nargs_for_red let rec check_extra_args extra_args = match extra_args with | [] -> () - | { notation_scope = None } :: _ -> err_extra_args (names_of extra_args) - | { name = Anonymous; notation_scope = Some _ } :: args -> - check_extra_args args - | _ -> - user_err Pp.(str "Extra notation scopes can be set on anonymous and explicit arguments only.") + | { notation_scope = None } :: _ -> + user_err Pp.(str"Extra arguments should specify a scope.") + | { notation_scope = Some _ } :: args -> check_extra_args args in let args, scopes = @@ -1817,8 +1816,8 @@ let vernac_global_check c = let get_nth_goal n = let pf = Proof_global.give_me_the_proof() in - let gls,_,_,_,sigma = Proof.proof pf in - let gl = {Evd.it=List.nth gls (n-1) ; sigma = sigma; } in + let Proof.{goals;sigma} = Proof.data pf in + let gl = {Evd.it=List.nth goals (n-1) ; sigma = sigma; } in gl exception NoHyp @@ -1992,7 +1991,7 @@ let vernac_search ~atts s gopt r = let vernac_locate = function | LocateAny {v=AN qid} -> print_located_qualid qid | LocateTerm {v=AN qid} -> print_located_term qid - | LocateAny {v=ByNotation (ntn, sc)} (** TODO : handle Ltac notations *) + | LocateAny {v=ByNotation (ntn, sc)} (* TODO : handle Ltac notations *) | LocateTerm {v=ByNotation (ntn, sc)} -> let _, env = Pfedit.get_current_context () in Notation.locate_notation @@ -2389,8 +2388,9 @@ let interp ?(verbosely=true) ?proof ~st {CAst.loc;v=c} = control v | VernacRedirect (s, {v}) -> Topfmt.with_output_to_file s control v - | VernacTime (batch, {v}) -> - System.with_time ~batch control v; + | VernacTime (batch, com) -> + let header = if batch then Topfmt.pr_cmd_header com else Pp.mt () in + System.with_time ~batch ~header control com.CAst.v; and aux ~atts : _ -> unit = function @@ -2437,7 +2437,7 @@ let interp ?verbosely ?proof ~st cmd = Vernacstate.unfreeze_interp_state st; try interp ?verbosely ?proof ~st cmd; - Vernacstate.freeze_interp_state `No + Vernacstate.freeze_interp_state ~marshallable:false with exn -> let exn = CErrors.push exn in Vernacstate.invalidate_cache (); diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index 1e6c40c829..417c9ebfbd 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -247,11 +247,11 @@ type vernac_argument_status = { } type extend_name = - (** Name of the vernac entry where the tactic is defined, typically found - after the VERNAC EXTEND statement in the source. *) + (* Name of the vernac entry where the tactic is defined, typically found + after the VERNAC EXTEND statement in the source. *) string * - (** Index of the extension in the VERNAC EXTEND statement. Each parsing branch - is given an offset, starting from zero. *) + (* Index of the extension in the VERNAC EXTEND statement. Each parsing branch + is given an offset, starting from zero. *) int type nonrec vernac_expr = diff --git a/vernac/vernacextend.ml b/vernac/vernacextend.ml index 2541f73582..05687afd8b 100644 --- a/vernac/vernacextend.ml +++ b/vernac/vernacextend.ml @@ -42,8 +42,11 @@ and vernac_sideff_type = Names.Id.t list and opacity_guarantee = | GuaranteesOpacity (** Only generates opaque terms at [Qed] *) | Doesn'tGuaranteeOpacity (** May generate transparent terms even with [Qed].*) + and solving_tac = bool (** a terminator *) + and anon_abstracting_tac = bool (** abstracting anonymously its result *) + and proof_block_name = string (** open type of delimiters *) type vernac_when = diff --git a/vernac/vernacextend.mli b/vernac/vernacextend.mli index 8b07be8b16..0d43eb1ee8 100644 --- a/vernac/vernacextend.mli +++ b/vernac/vernacextend.mli @@ -58,8 +58,11 @@ and vernac_sideff_type = Names.Id.t list and opacity_guarantee = | GuaranteesOpacity (** Only generates opaque terms at [Qed] *) | Doesn'tGuaranteeOpacity (** May generate transparent terms even with [Qed].*) + and solving_tac = bool (** a terminator *) + and anon_abstracting_tac = bool (** abstracting anonymously its result *) + and proof_block_name = string (** open type of delimiters *) type vernac_when = @@ -86,7 +89,7 @@ type (_, _) ty_sig = ('a, 'b, 'c) Extend.ty_user_symbol * ('r, 's) ty_sig -> ('a -> 'r, 'a -> 's) ty_sig -type ty_ml = TyML : bool (** deprecated *) * ('r, 's) ty_sig * 'r * 's option -> ty_ml +type ty_ml = TyML : bool (* deprecated *) * ('r, 's) ty_sig * 'r * 's option -> ty_ml (** Wrapper to dynamically extend vernacular commands. *) val vernac_extend : diff --git a/vernac/vernacstate.ml b/vernac/vernacstate.ml index aa8bcdc328..61540024ef 100644 --- a/vernac/vernacstate.ml +++ b/vernac/vernacstate.ml @@ -33,11 +33,19 @@ let do_if_not_cached rf f v = | Some _ -> () -let freeze_interp_state marshallable = +let freeze_interp_state ~marshallable = { system = update_cache s_cache (States.freeze ~marshallable); proof = update_cache s_proof (Proof_global.freeze ~marshallable); - shallow = marshallable = `Shallow } + shallow = false; + } let unfreeze_interp_state { system; proof } = do_if_not_cached s_cache States.unfreeze system; do_if_not_cached s_proof Proof_global.unfreeze proof + +let make_shallow st = + let lib = States.lib_of_state st.system in + { st with + system = States.replace_lib st.system @@ Lib.drop_objects lib; + shallow = true; + } diff --git a/vernac/vernacstate.mli b/vernac/vernacstate.mli index b4d478d12d..ed20cb935a 100644 --- a/vernac/vernacstate.mli +++ b/vernac/vernacstate.mli @@ -14,8 +14,10 @@ type t = { shallow : bool (* is the state trimmed down (libstack) *) } -val freeze_interp_state : Summary.marshallable -> t +val freeze_interp_state : marshallable:bool -> t val unfreeze_interp_state : t -> unit +val make_shallow : t -> t + (* WARNING: Do not use, it will go away in future releases *) val invalidate_cache : unit -> unit |