aboutsummaryrefslogtreecommitdiff
path: root/vernac
diff options
context:
space:
mode:
Diffstat (limited to 'vernac')
-rw-r--r--vernac/assumptions.ml4
-rw-r--r--vernac/auto_ind_decl.ml6
-rw-r--r--vernac/command.ml67
-rw-r--r--vernac/discharge.ml2
-rw-r--r--vernac/explainErr.ml2
-rw-r--r--vernac/himsg.ml6
-rw-r--r--vernac/indschemes.ml35
-rw-r--r--vernac/indschemes.mli2
-rw-r--r--vernac/lemmas.ml4
-rw-r--r--vernac/metasyntax.ml6
-rw-r--r--vernac/obligations.ml6
-rw-r--r--vernac/record.ml2
-rw-r--r--vernac/vernacentries.ml29
13 files changed, 88 insertions, 83 deletions
diff --git a/vernac/assumptions.ml b/vernac/assumptions.ml
index bf274901bd..726115653b 100644
--- a/vernac/assumptions.ml
+++ b/vernac/assumptions.ml
@@ -131,7 +131,7 @@ let lookup_constant_in_impl cst fallback =
- The label has not been found in the structure. This is an error *)
match fallback with
| Some cb -> cb
- | None -> anomaly (str "Print Assumption: unknown constant " ++ pr_con cst)
+ | None -> anomaly (str "Print Assumption: unknown constant " ++ pr_con cst ++ str ".")
let lookup_constant cst =
try
@@ -146,7 +146,7 @@ let lookup_mind_in_impl mind =
let fields = memoize_fields_of_mp mp in
search_mind_label lab fields
with Not_found ->
- anomaly (str "Print Assumption: unknown inductive " ++ MutInd.print mind)
+ anomaly (str "Print Assumption: unknown inductive " ++ MutInd.print mind ++ str ".")
let lookup_mind mind =
try Global.lookup_mind mind
diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml
index cf534f13a2..b99ccbf4a2 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 (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::l)) (List.map RelDecl.get_name lnamesparrec) [] 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
@@ -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 (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::l)) (List.map RelDecl.get_name lnamesparrec) [] in
let eqI, eff = eqI ind lnamesparrec in
let create_input c =
let x = next_ident_away (Id.of_string "x") avoid and
@@ -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 (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::l)) (List.map RelDecl.get_name lnamesparrec) [] 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
diff --git a/vernac/command.ml b/vernac/command.ml
index e2ebb4d7fb..0f9dee12c6 100644
--- a/vernac/command.ml
+++ b/vernac/command.ml
@@ -211,7 +211,7 @@ let do_definition ident k pl bl red_option c ctypopt hook =
assert(Univ.ContextSet.is_empty ctx);
let typ = match ce.const_entry_type with
| Some t -> t
- | None -> EConstr.Unsafe.to_constr (Retyping.get_type_of env evd (EConstr.of_constr c))
+ | None -> EConstr.to_constr evd (Retyping.get_type_of env evd (EConstr.of_constr c))
in
Obligations.check_evars env evd;
let obls, _, c, cty =
@@ -411,8 +411,8 @@ let mk_mltype_data evdref env assums arity indname =
(is_ml_type,indname,assums)
let prepare_param = function
- | LocalAssum (na,t) -> out_name na, LocalAssumEntry t
- | LocalDef (na,b,_) -> out_name na, LocalDefEntry b
+ | LocalAssum (na,t) -> Name.get_id na, LocalAssumEntry t
+ | LocalDef (na,b,_) -> Name.get_id na, LocalDefEntry b
(** Make the arity conclusion flexible to avoid generating an upper bound universe now,
only if the universe does not appear anywhere else.
@@ -590,7 +590,7 @@ let interp_mutual_inductive (paramsl,indl) notations poly prv finite =
(* Names of parameters as arguments of the inductive type (defs removed) *)
let assums = List.filter is_local_assum ctx_params in
- let params = List.map (RelDecl.get_name %> out_name) assums in
+ let params = List.map (RelDecl.get_name %> Name.get_id) assums in
(* Interpret the arities *)
let arities = List.map (interp_ind_arity env_params evdref) indl in
@@ -674,7 +674,7 @@ let extract_coercions indl =
let extract_params indl =
let paramsl = List.map (fun (_,params,_,_) -> params) indl in
match paramsl with
- | [] -> anomaly (Pp.str "empty list of inductive types")
+ | [] -> anomaly (Pp.str "empty list of inductive types.")
| params::paramsl ->
if not (List.for_all (eq_local_binders params) paramsl) then user_err Pp.(str
"Parameters should be syntactically the same for each inductive type.");
@@ -907,23 +907,26 @@ let fixsub_module = subtac_dir @ ["Wf"]
let tactics_module = subtac_dir @ ["Tactics"]
let init_reference dir s () = Coqlib.coq_reference "Command" dir s
-let init_constant dir s () = EConstr.of_constr @@ Universes.constr_of_global (Coqlib.coq_reference "Command" dir s)
+let init_constant dir s evdref =
+ let Sigma (c, sigma, _) = Evarutil.new_global (Sigma.Unsafe.of_evar_map !evdref)
+ (Coqlib.coq_reference "Command" dir s)
+ in evdref := Sigma.to_evar_map sigma; c
let make_ref l s = init_reference l s
let fix_proto = init_constant tactics_module "fix_proto"
let fix_sub_ref = make_ref fixsub_module "Fix_sub"
let measure_on_R_ref = make_ref fixsub_module "MR"
let well_founded = init_constant ["Init"; "Wf"] "well_founded"
-let mkSubset name typ prop =
+let mkSubset evdref name typ prop =
let open EConstr in
- mkApp (EConstr.of_constr (Universes.constr_of_global (delayed_force build_sigma).typ),
+ mkApp (Evarutil.e_new_global evdref (delayed_force build_sigma).typ,
[| typ; mkLambda (name, typ, prop) |])
let sigT = Lazy.from_fun build_sigma_type
let make_qref s = Qualid (Loc.tag @@ qualid_of_string s)
let lt_ref = make_qref "Init.Peano.lt"
-let rec telescope l =
+let rec telescope evdref l =
let open EConstr in
let open Vars in
match l with
@@ -935,10 +938,8 @@ let rec telescope l =
(fun (ty, tys, (k, constr)) decl ->
let t = RelDecl.get_type decl in
let pred = mkLambda (RelDecl.get_name decl, t, ty) in
- let ty = Universes.constr_of_global (Lazy.force sigT).typ in
- let ty = EConstr.of_constr ty in
- let intro = Universes.constr_of_global (Lazy.force sigT).intro in
- let intro = EConstr.of_constr intro in
+ let ty = Evarutil.e_new_global evdref (Lazy.force sigT).typ in
+ let intro = Evarutil.e_new_global evdref (Lazy.force sigT).intro in
let sigty = mkApp (ty, [|t; pred|]) in
let intro = mkApp (intro, [|lift k t; lift k pred; mkRel k; constr|]) in
(sigty, pred :: tys, (succ k, intro)))
@@ -947,17 +948,15 @@ let rec telescope l =
let (last, subst) = List.fold_right2
(fun pred decl (prev, subst) ->
let t = RelDecl.get_type decl in
- let p1 = Universes.constr_of_global (Lazy.force sigT).proj1 in
- let p1 = EConstr.of_constr p1 in
- let p2 = Universes.constr_of_global (Lazy.force sigT).proj2 in
- let p2 = EConstr.of_constr p2 in
+ let p1 = Evarutil.e_new_global evdref (Lazy.force sigT).proj1 in
+ let p2 = Evarutil.e_new_global evdref (Lazy.force sigT).proj2 in
let proj1 = applist (p1, [t; pred; prev]) in
let proj2 = applist (p2, [t; pred; prev]) in
(lift 1 proj2, LocalDef (get_name decl, proj1, t) :: subst))
(List.rev tys) tl (mkRel 1, [])
in ty, (LocalDef (n, last, t) :: subst), constr
- | LocalDef (n, b, t) :: tl -> let ty, subst, term = telescope tl in
+ | LocalDef (n, b, t) :: tl -> let ty, subst, term = telescope evdref tl in
ty, (LocalDef (n, b, t) :: subst), lift 1 term
let nf_evar_context sigma ctx =
@@ -976,7 +975,7 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation =
let top_env = push_rel_context binders_rel env in
let top_arity = interp_type_evars top_env evdref arityc in
let full_arity = it_mkProd_or_LetIn top_arity binders_rel in
- let argtyp, letbinders, make = telescope binders_rel in
+ let argtyp, letbinders, make = telescope evdref binders_rel in
let argname = Id.of_string "recarg" in
let arg = LocalAssum (Name argname, argtyp) in
let binders = letbinders @ [arg] in
@@ -1004,7 +1003,7 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation =
it_mkLambda_or_LetIn measure letbinders,
it_mkLambda_or_LetIn measure binders
in
- let comb = EConstr.of_constr (Universes.constr_of_global (delayed_force measure_on_R_ref)) in
+ let comb = Evarutil.e_new_global evdref (delayed_force measure_on_R_ref) in
let relargty = EConstr.of_constr relargty in
let wf_rel = mkApp (comb, [| argtyp; relargty; rel; measure |]) in
let wf_rel_fun x y =
@@ -1012,15 +1011,15 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation =
subst1 y measure_body |])
in wf_rel, wf_rel_fun, measure
in
- let wf_proof = mkApp (delayed_force well_founded, [| argtyp ; wf_rel |]) in
+ let wf_proof = mkApp (well_founded evdref, [| argtyp ; wf_rel |]) in
let argid' = Id.of_string (Id.to_string argname ^ "'") in
let wfarg len = LocalAssum (Name argid',
- mkSubset (Name argid') argtyp
+ mkSubset evdref (Name argid') argtyp
(wf_rel_fun (mkRel 1) (mkRel (len + 1))))
in
let intern_bl = wfarg 1 :: [arg] in
let _intern_env = push_rel_context intern_bl env in
- let proj = (*FIXME*)EConstr.of_constr (Universes.constr_of_global (delayed_force build_sigma).Coqlib.proj1) in
+ let proj = Evarutil.e_new_global evdref (delayed_force build_sigma).Coqlib.proj1 in
let wfargpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel 3)) in
let projection = (* in wfarg :: arg :: before *)
mkApp (proj, [| argtyp ; wfargpred ; mkRel 1 |])
@@ -1033,7 +1032,7 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation =
let intern_fun_binder = LocalAssum (Name (add_suffix recname "'"), intern_fun_arity_prod) in
let curry_fun =
let wfpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel (2 * len + 4))) in
- let intro = (*FIXME*)EConstr.of_constr (Universes.constr_of_global (delayed_force build_sigma).Coqlib.intro) in
+ let intro = Evarutil.e_new_global evdref (delayed_force build_sigma).Coqlib.intro in
let arg = mkApp (intro, [| argtyp; wfpred; lift 1 make; mkRel 1 |]) in
let app = mkApp (mkRel (2 * len + 2 (* recproof + orig binders + current binders *)), [| arg |]) in
let rcurry = mkApp (rel, [| measure; lift len measure |]) in
@@ -1059,10 +1058,10 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation =
let intern_body_lam = it_mkLambda_or_LetIn intern_body (curry_fun :: lift_lets @ fun_bl) in
let prop = mkLambda (Name argname, argtyp, top_arity_let) in
let def =
- mkApp (EConstr.of_constr (Universes.constr_of_global (delayed_force fix_sub_ref)),
+ mkApp (Evarutil.e_new_global evdref (delayed_force fix_sub_ref),
[| argtyp ; wf_rel ;
Evarutil.e_new_evar env evdref
- ~src:(Loc.tag @@ Evar_kinds.QuestionMark (Evar_kinds.Define false)) wf_proof;
+ ~src:(Loc.tag @@ Evar_kinds.QuestionMark (Evar_kinds.Define false,Anonymous)) wf_proof;
prop |])
in
let def = Typing.e_solve_evars env evdref def in
@@ -1075,12 +1074,12 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation =
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 (EConstr.of_constr (Universes.constr_of_global gr), [|make|])) binders_rel in
+ 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
(*FIXME poly? *)
- let ce = definition_entry ~poly ~types:ty ~univs (EConstr.Unsafe.to_constr (Evarutil.nf_evar !evdref body)) in
+ let ce = definition_entry ~poly ~types:ty ~univs (EConstr.to_constr !evdref body) in
(** FIXME: include locality *)
let c = Declare.declare_constant recname (DefinitionEntry ce, IsDefinition Definition) in
let gr = ConstRef c in
@@ -1097,10 +1096,8 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation =
in hook, recname, typ
in
let hook = Lemmas.mk_hook hook in
- let fullcoqc = Evarutil.nf_evar !evdref def in
- let fullctyp = Evarutil.nf_evar !evdref typ in
- let fullcoqc = EConstr.Unsafe.to_constr fullcoqc in
- let fullctyp = EConstr.Unsafe.to_constr fullctyp in
+ let fullcoqc = EConstr.to_constr !evdref def in
+ let fullctyp = EConstr.to_constr !evdref typ in
Obligations.check_evars env !evdref;
let evars, _, evars_def, evars_typ =
Obligations.eterm_obligations env recname !evdref 0 fullcoqc fullctyp
@@ -1143,7 +1140,7 @@ let interp_recursive isfix fixl notations =
let sort = Evarutil.evd_comb1 (Typing.type_of ~refresh:true env) evdref t in
let fixprot =
try
- let app = mkApp (delayed_force fix_proto, [|sort; t|]) in
+ let app = mkApp (fix_proto evdref, [|sort; t|]) in
Typing.e_solve_evars env evdref app
with e when CErrors.noncritical e -> t
in
@@ -1303,9 +1300,9 @@ let do_program_recursive local p fixkind fixl ntns =
let collect_evars id def typ imps =
(* Generalize by the recursive prototypes *)
let def =
- EConstr.Unsafe.to_constr (nf_evar evd (Termops.it_mkNamedLambda_or_LetIn (EConstr.of_constr def) rec_sign))
+ EConstr.to_constr evd (Termops.it_mkNamedLambda_or_LetIn (EConstr.of_constr def) rec_sign)
and typ =
- EConstr.Unsafe.to_constr (nf_evar evd (Termops.it_mkNamedProd_or_LetIn (EConstr.of_constr typ) rec_sign))
+ EConstr.to_constr evd (Termops.it_mkNamedProd_or_LetIn (EConstr.of_constr typ) rec_sign)
in
let evm = collect_evars_of_term evd def typ in
let evars, _, def, typ =
diff --git a/vernac/discharge.ml b/vernac/discharge.ml
index b898f3e830..65ade78876 100644
--- a/vernac/discharge.ml
+++ b/vernac/discharge.ml
@@ -23,7 +23,7 @@ let detype_param =
function
| LocalAssum (Name id, p) -> id, LocalAssumEntry p
| LocalDef (Name id, p,_) -> id, LocalDefEntry p
- | _ -> anomaly (Pp.str "Unnamed inductive local variable")
+ | _ -> anomaly (Pp.str "Unnamed inductive local variable.")
(* Replace
diff --git a/vernac/explainErr.ml b/vernac/explainErr.ml
index 040c86805e..021fde961e 100644
--- a/vernac/explainErr.ml
+++ b/vernac/explainErr.ml
@@ -109,7 +109,7 @@ let process_vernac_interp_error ?(allow_uncaught=true) (exc, info) =
let () =
if not allow_uncaught && not (CErrors.handled (fst e)) then
let (e, info) = e in
- let msg = str "Uncaught exception " ++ str (Printexc.to_string e) in
+ let msg = str "Uncaught exception " ++ str (Printexc.to_string e) ++ str "." in
let err = CErrors.make_anomaly msg in
Util.iraise (err, info)
in
diff --git a/vernac/himsg.ml b/vernac/himsg.ml
index 17bb87f2aa..6d8dd82ac6 100644
--- a/vernac/himsg.ml
+++ b/vernac/himsg.ml
@@ -682,12 +682,12 @@ let explain_wrong_abstraction_type env sigma na abs expected result =
let explain_abstraction_over_meta _ m n =
strbrk "Too complex unification problem: cannot find a solution for both " ++
- pr_name m ++ spc () ++ str "and " ++ pr_name n ++ str "."
+ Name.print m ++ spc () ++ str "and " ++ Name.print n ++ str "."
let explain_non_linear_unification env sigma m t =
let t = EConstr.to_constr sigma t in
strbrk "Cannot unambiguously instantiate " ++
- pr_name m ++ str ":" ++
+ Name.print m ++ str ":" ++
strbrk " which would require to abstract twice on " ++
pr_lconstr_env env sigma t ++ str "."
@@ -1055,7 +1055,7 @@ let explain_refiner_bad_type arg ty conclty =
let explain_refiner_unresolved_bindings l =
str "Unable to find an instance for the " ++
str (String.plural (List.length l) "variable") ++ spc () ++
- prlist_with_sep pr_comma pr_name l ++ str"."
+ prlist_with_sep pr_comma Name.print l ++ str"."
let explain_refiner_cannot_apply t harg =
str "In refiner, a term of type" ++ brk(1,1) ++
diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml
index f57b1bba01..a678d20bba 100644
--- a/vernac/indschemes.ml
+++ b/vernac/indschemes.ml
@@ -453,11 +453,19 @@ let fold_left' f = function
[] -> invalid_arg "fold_left'"
| hd :: tl -> List.fold_left f hd tl
+let new_global sigma gr =
+ let open Sigma in
+ let Sigma (c, sigma, _) = Evarutil.new_global (Sigma.Unsafe.of_evar_map sigma) gr
+ in Sigma.to_evar_map sigma, c
+
+let mk_coq_and sigma = new_global sigma (Coqlib.build_coq_and ())
+let mk_coq_conj sigma = new_global sigma (Coqlib.build_coq_conj ())
+
let build_combined_scheme env schemes =
- let defs = List.map (fun cst -> (* FIXME *)
- let evd, c = Evd.fresh_constant_instance env (Evd.from_env env) cst in
- (c, Typeops.type_of_constant_in env c)) schemes in
-(* let nschemes = List.length schemes in *)
+ let evdref = ref (Evd.from_env env) in
+ let defs = List.map (fun cst ->
+ let evd, c = Evd.fresh_constant_instance env !evdref cst in
+ evdref := evd; (c, Typeops.type_of_constant_in env c)) schemes in
let find_inductive ty =
let (ctx, arity) = decompose_prod ty in
let (_, last) = List.hd ctx in
@@ -471,26 +479,27 @@ let build_combined_scheme env schemes =
let (c, t) = List.hd defs in
let ctx, ind, nargs = find_inductive t in
(* Number of clauses, including the predicates quantification *)
- let prods = nb_prod Evd.empty (EConstr.of_constr t) - (nargs + 1) (** FIXME *) in
- let coqand = Universes.constr_of_global @@ Coqlib.build_coq_and () in
- let coqconj = Universes.constr_of_global @@ Coqlib.build_coq_conj () in
+ let prods = nb_prod !evdref (EConstr.of_constr t) - (nargs + 1) in
+ let sigma, coqand = mk_coq_and !evdref in
+ let sigma, coqconj = mk_coq_conj sigma in
+ let () = evdref := sigma in
let relargs = rel_vect 0 prods in
let concls = List.rev_map
- (fun (cst, t) -> (* FIXME *)
+ (fun (cst, t) ->
mkApp(mkConstU cst, relargs),
snd (decompose_prod_n prods t)) defs in
let concl_bod, concl_typ =
fold_left'
(fun (accb, acct) (cst, x) ->
- mkApp (coqconj, [| x; acct; cst; accb |]),
- mkApp (coqand, [| x; acct |])) concls
+ mkApp (EConstr.to_constr !evdref coqconj, [| x; acct; cst; accb |]),
+ mkApp (EConstr.to_constr !evdref coqand, [| x; acct |])) concls
in
let ctx, _ =
list_split_rev_at prods
(List.rev_map (fun (x, y) -> LocalAssum (x, y)) ctx) in
let typ = List.fold_left (fun d c -> Term.mkProd_wo_LetIn c d) concl_typ ctx in
let body = it_mkLambda_or_LetIn concl_bod ctx in
- (body, typ)
+ (!evdref, body, typ)
let do_combined_scheme name schemes =
let csts =
@@ -501,9 +510,9 @@ let do_combined_scheme name schemes =
with Not_found -> user_err Pp.(pr_qualid (snd qualid) ++ str " is not declared."))
schemes
in
- let body,typ = build_combined_scheme (Global.env ()) csts in
+ let sigma,body,typ = build_combined_scheme (Global.env ()) csts in
let proof_output = Future.from_val ((body,Univ.ContextSet.empty),Safe_typing.empty_private_constants) in
- ignore (define (snd name) UserIndividualRequest Evd.empty proof_output (Some typ));
+ ignore (define (snd name) UserIndividualRequest sigma proof_output (Some typ));
fixpoint_message None [snd name]
(**********************************************************************)
diff --git a/vernac/indschemes.mli b/vernac/indschemes.mli
index e5d79fd514..0f559d2bd8 100644
--- a/vernac/indschemes.mli
+++ b/vernac/indschemes.mli
@@ -40,7 +40,7 @@ val do_scheme : (Id.t located option * scheme) list -> unit
(** Combine a list of schemes into a conjunction of them *)
-val build_combined_scheme : env -> constant list -> constr * types
+val build_combined_scheme : env -> constant list -> Evd.evar_map * constr * types
val do_combined_scheme : Id.t located -> Id.t located list -> unit
diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml
index d6ae0ea86f..77e356eb2c 100644
--- a/vernac/lemmas.ml
+++ b/vernac/lemmas.ml
@@ -242,7 +242,7 @@ let save_remaining_recthms (locality,p,kind) norm ctx body opaq i ((id,pl),(t_i,
| LetIn(na,t1,ty,t2) -> mkLetIn (na,t1,ty, body_i t2)
| Lambda(na,ty,t) -> mkLambda(na,ty,body_i t)
| App (t, args) -> mkApp (body_i t, args)
- | _ -> anomaly Pp.(str "Not a proof by induction: " ++ Printer.pr_constr body) in
+ | _ -> anomaly Pp.(str "Not a proof by induction: " ++ Printer.pr_constr body ++ str ".") in
let body_i = body_i body in
match locality with
| Discharge ->
@@ -402,7 +402,7 @@ let start_proof_with_initialization kind ctx recguard thms snl hook =
let () = match thms with [_] -> () | _ -> assert false in
(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")
+ | [] -> anomaly (Pp.str "No proof to start.")
| ((id,pl),(t,(_,imps)))::other_thms ->
let hook ctx strength ref =
let ctx = match ctx with
diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml
index 42494dd28a..34b9b97d8c 100644
--- a/vernac/metasyntax.ml
+++ b/vernac/metasyntax.ml
@@ -250,7 +250,7 @@ let rec find_pattern nt xl = function
| _, [] ->
user_err Pp.(str msg_expected_form_of_recursive_notation)
| ((SProdList _ | NonTerminal _) :: _), _ | _, (SProdList _ :: _) ->
- anomaly (Pp.str "Only Terminal or Break expected on left, non-SProdList on right")
+ anomaly (Pp.str "Only Terminal or Break expected on left, non-SProdList on right.")
let rec interp_list_parser hd = function
| [] -> [], List.rev hd
@@ -271,7 +271,7 @@ let rec interp_list_parser hd = function
| NonTerminal _ as x :: tl ->
let xyl,tl' = interp_list_parser [x] tl in
xyl, List.rev_append hd tl'
- | SProdList _ :: _ -> anomaly (Pp.str "Unexpected SProdList in interp_list_parser")
+ | SProdList _ :: _ -> anomaly (Pp.str "Unexpected SProdList in interp_list_parser.")
(* Find non-terminal tokens of notation *)
@@ -645,7 +645,7 @@ let make_production etyps symbols =
let tkl = List.flatten
(List.map (function Terminal s -> [CLexer.terminal s]
| Break _ -> []
- | _ -> anomaly (Pp.str "Found a non terminal token in recursive notation separator")) sl) in
+ | _ -> anomaly (Pp.str "Found a non terminal token in recursive notation separator.")) sl) in
match List.assoc x etyps with
| ETConstr typ -> expand_list_rule typ tkl x 1 0 [] ll
| ETBinder o ->
diff --git a/vernac/obligations.ml b/vernac/obligations.ml
index be58c67a9e..6dee95bc54 100644
--- a/vernac/obligations.ml
+++ b/vernac/obligations.ml
@@ -64,7 +64,7 @@ let subst_evar_constr evs n idf t =
ev_hyps = hyps ; ev_chop = chop } =
try evar_info k
with Not_found ->
- anomaly ~label:"eterm" (Pp.str "existential variable " ++ int (Evar.repr k) ++ str " not found")
+ anomaly ~label:"eterm" (Pp.str "existential variable " ++ int (Evar.repr k) ++ str " not found.")
in
seen := Int.Set.add id !seen;
(* Evar arguments are created in inverse order,
@@ -221,7 +221,7 @@ let eterm_obligations env name evm fs ?status t ty =
in
let loc, k = evar_source id evm in
let status = match k with
- | Evar_kinds.QuestionMark o -> o
+ | Evar_kinds.QuestionMark (o,_) -> o
| _ -> match status with
| Some o -> o
| None -> Evar_kinds.Define (not (Program.get_proofs_transparency ()))
@@ -325,7 +325,7 @@ type program_info = program_info_aux CEphemeron.key
let get_info x =
try CEphemeron.get x
with CEphemeron.InvalidKey ->
- CErrors.anomaly Pp.(str "Program obligation can't be accessed by a worker")
+ CErrors.anomaly Pp.(str "Program obligation can't be accessed by a worker.")
let assumption_message = Declare.assumption_message
diff --git a/vernac/record.ml b/vernac/record.ml
index 5accc8e379..f8e12f4ee2 100644
--- a/vernac/record.ml
+++ b/vernac/record.ml
@@ -174,7 +174,7 @@ let typecheck_params_and_fields def id pl t ps nots fs =
let degenerate_decl decl =
let id = match RelDecl.get_name decl with
| Name id -> id
- | Anonymous -> anomaly (Pp.str "Unnamed record variable") in
+ | Anonymous -> anomaly (Pp.str "Unnamed record variable.") in
match decl with
| LocalAssum (_,t) -> (id, LocalAssumEntry t)
| LocalDef (_,b,_) -> (id, LocalDefEntry b)
diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml
index 6c1d64cfe9..c6ec89c5e6 100644
--- a/vernac/vernacentries.ml
+++ b/vernac/vernacentries.ml
@@ -67,7 +67,7 @@ let show_node () =
could, possibly, be cleaned away. (Feb. 2010) *)
()
-let show_thesis () = CErrors.anomaly (Pp.str "Show Thesis: TODO")
+let show_thesis () = CErrors.anomaly (Pp.str "Show Thesis: TODO.")
let show_top_evars () =
(* spiwack: new as of Feb. 2010: shows goal evars in addition to non-goal evars. *)
@@ -1003,12 +1003,12 @@ let vernac_arguments locality reference args more_implicits nargs_for_red flags
let err_extra_args names =
user_err ~hdr:"vernac_declare_arguments"
(strbrk "Extra arguments: " ++
- prlist_with_sep pr_comma pr_name names ++ str ".")
+ prlist_with_sep pr_comma Name.print names ++ str ".")
in
let err_missing_args names =
user_err ~hdr:"vernac_declare_arguments"
(strbrk "The following arguments are not declared: " ++
- prlist_with_sep pr_comma pr_name names ++ str ".")
+ prlist_with_sep pr_comma Name.print names ++ str ".")
in
let rec check_extra_args extra_args =
@@ -1093,14 +1093,14 @@ let vernac_arguments locality reference args more_implicits nargs_for_red flags
match !example_renaming with
| None -> mt ()
| Some (o,n) ->
- str "Argument " ++ pr_name o ++
- str " renamed to " ++ pr_name n ++ str ".");
+ str "Argument " ++ Name.print o ++
+ str " renamed to " ++ Name.print n ++ str ".");
let duplicate_names =
List.duplicates Name.equal (List.filter ((!=) Anonymous) names)
in
if not (List.is_empty duplicate_names) then begin
- let duplicates = prlist_with_sep pr_comma pr_name duplicate_names in
+ let duplicates = prlist_with_sep pr_comma Name.print duplicate_names in
user_err (strbrk "Some argument names are duplicated: " ++ duplicates)
end;
@@ -1129,7 +1129,7 @@ let vernac_arguments locality reference args more_implicits nargs_for_red flags
anonymous argument implicit *)
| Anonymous :: _, (name, _) :: _ ->
user_err ~hdr:"vernac_declare_arguments"
- (strbrk"Argument "++ pr_name name ++
+ (strbrk"Argument "++ Name.print name ++
strbrk " cannot be declared implicit.")
| Name id :: inf_names, (name, impl) :: implicits ->
@@ -1765,12 +1765,11 @@ let vernac_locate = let open Feedback in function
let vernac_register id r =
if Pfedit.refining () then
user_err Pp.(str "Cannot register a primitive while in proof editing mode.");
- let t = (Constrintern.global_reference (snd id)) in
- if not (isConst t) then
+ let kn = Constrintern.global_reference (snd id) in
+ if not (isConstRef kn) then
user_err Pp.(str "Register inline: a constant is expected");
- let kn = destConst t in
match r with
- | RegisterInline -> Global.register_inline (Univ.out_punivs kn)
+ | RegisterInline -> Global.register_inline (destConstRef kn)
(********************)
(* Proof management *)
@@ -1919,10 +1918,10 @@ let interp ?proof ?loc locality poly c =
| VernacToplevelControl e -> raise e
(* Resetting *)
- | VernacResetName _ -> anomaly (str "VernacResetName not handled by Stm")
- | VernacResetInitial -> anomaly (str "VernacResetInitial not handled by Stm")
- | VernacBack _ -> anomaly (str "VernacBack not handled by Stm")
- | VernacBackTo _ -> anomaly (str "VernacBackTo not handled by Stm")
+ | VernacResetName _ -> anomaly (str "VernacResetName not handled by Stm.")
+ | VernacResetInitial -> anomaly (str "VernacResetInitial not handled by Stm.")
+ | VernacBack _ -> anomaly (str "VernacBack not handled by Stm.")
+ | VernacBackTo _ -> anomaly (str "VernacBackTo not handled by Stm.")
(* This one is possible to handle here *)
| VernacAbort id -> CErrors.user_err (str "Abort cannot be used through the Load command")
generated by cgit v1.2.3 (git 2.25.1) at 2026-04-30 23:12:33 +0000