aboutsummaryrefslogtreecommitdiff
path: root/vernac
diff options
context:
space:
mode:
Diffstat (limited to 'vernac')
-rw-r--r--vernac/classes.ml4
-rw-r--r--vernac/comAssumption.ml1
-rw-r--r--vernac/comDefinition.ml4
-rw-r--r--vernac/comFixpoint.ml2
-rw-r--r--vernac/comHints.ml30
-rw-r--r--vernac/comPrimitive.ml2
-rw-r--r--vernac/comProgramFixpoint.ml2
-rw-r--r--vernac/comSearch.ml14
-rw-r--r--vernac/declare.ml43
-rw-r--r--vernac/declaremods.mli2
-rw-r--r--vernac/library.ml4
-rw-r--r--vernac/prettyp.ml4
-rw-r--r--vernac/record.ml2
-rw-r--r--vernac/vernacentries.ml2
14 files changed, 66 insertions, 50 deletions
diff --git a/vernac/classes.ml b/vernac/classes.ml
index d5509e2697..054addc542 100644
--- a/vernac/classes.ml
+++ b/vernac/classes.ml
@@ -57,7 +57,7 @@ let is_local_for_hint i =
let add_instance_base inst =
let locality = if is_local_for_hint inst then Goptions.OptLocal else Goptions.OptGlobal in
- add_instance_hint (Hints.IsGlobRef inst.is_impl) [inst.is_impl] ~locality
+ add_instance_hint (Hints.hint_globref inst.is_impl) [inst.is_impl] ~locality
inst.is_info
let mk_instance cl info glob impl =
@@ -503,7 +503,7 @@ let do_instance_program ~pm env env' sigma ?hook ~global ~poly cty k u ctx ctx'
declare_instance_program pm env sigma ~global ~poly id pri imps decl term termtype
let interp_instance_context ~program_mode env ctx ~generalize pl tclass =
- let sigma, decl = Constrexpr_ops.interp_univ_decl_opt env pl in
+ let sigma, decl = interp_univ_decl_opt env pl in
let tclass =
if generalize then CAst.make @@ CGeneralization (Glob_term.MaxImplicit, Some AbsPi, tclass)
else tclass
diff --git a/vernac/comAssumption.ml b/vernac/comAssumption.ml
index 12194ea20c..9e850ff1c7 100644
--- a/vernac/comAssumption.ml
+++ b/vernac/comAssumption.ml
@@ -13,7 +13,6 @@ open Util
open Vars
open Names
open Context
-open Constrexpr_ops
open Constrintern
open Impargs
open Pretyping
diff --git a/vernac/comDefinition.ml b/vernac/comDefinition.ml
index 3fc74cba5b..81154bbea9 100644
--- a/vernac/comDefinition.ml
+++ b/vernac/comDefinition.ml
@@ -114,7 +114,7 @@ let do_definition ?hook ~name ~scope ~poly ~kind ?using udecl bl red_option c ct
let program_mode = false in
let env = Global.env() in
(* Explicitly bound universes and constraints *)
- let evd, udecl = Constrexpr_ops.interp_univ_decl_opt env udecl in
+ let evd, udecl = interp_univ_decl_opt env udecl in
let evd, (body, types), impargs =
interp_definition ~program_mode env evd empty_internalization_env bl red_option c ctypopt
in
@@ -134,7 +134,7 @@ let do_definition_program ?hook ~pm ~name ~scope ~poly ~kind ?using udecl bl red
let program_mode = true in
let env = Global.env() in
(* Explicitly bound universes and constraints *)
- let evd, udecl = Constrexpr_ops.interp_univ_decl_opt env udecl in
+ let evd, udecl = interp_univ_decl_opt env udecl in
let evd, (body, types), impargs =
interp_definition ~program_mode env evd empty_internalization_env bl red_option c ctypopt
in
diff --git a/vernac/comFixpoint.ml b/vernac/comFixpoint.ml
index 29bf5fbcc2..dd6c985bf9 100644
--- a/vernac/comFixpoint.ml
+++ b/vernac/comFixpoint.ml
@@ -176,7 +176,7 @@ let interp_recursive ~program_mode ~cofix (fixl : 'a Vernacexpr.fix_expr_gen lis
if not (CList.for_all2eq (fun x y -> Id.equal x.CAst.v y.CAst.v) lsu usu) then
CErrors.user_err Pp.(str "(co)-recursive definitions should all have the same universe binders");
Some us) fixl None in
- let sigma, decl = Constrexpr_ops.interp_univ_decl_opt env all_universes in
+ let sigma, decl = interp_univ_decl_opt env all_universes in
let sigma, (fixctxs, fiximppairs, fixannots) =
on_snd List.split3 @@
List.fold_left_map (fun sigma -> interp_fix_context ~program_mode env sigma ~cofix) sigma fixl in
diff --git a/vernac/comHints.ml b/vernac/comHints.ml
index 9eac558908..f642411fa4 100644
--- a/vernac/comHints.ml
+++ b/vernac/comHints.ml
@@ -62,7 +62,7 @@ let project_hint ~poly pri l2r r =
cb
in
let info = {Typeclasses.hint_priority = pri; hint_pattern = None} in
- (info, true, Hints.PathAny, Hints.IsGlobRef (GlobRef.ConstRef c))
+ (info, true, Hints.PathAny, Hints.hint_globref (GlobRef.ConstRef c))
let warn_deprecated_hint_constr =
CWarnings.create ~name:"fragile-hint-constr" ~category:"automation"
@@ -84,16 +84,6 @@ let soft_evaluable =
let interp_hints ~poly h =
let env = Global.env () in
let sigma = Evd.from_env env in
- let f poly c =
- let evd, c = Constrintern.interp_open_constr env sigma c in
- let env = Global.env () in
- let sigma = Evd.from_env env in
- let c, diff = Hints.prepare_hint true env sigma (evd, c) in
- if poly then (Hints.IsConstr (c, Some diff) [@ocaml.warning "-3"])
- else
- let () = DeclareUctx.declare_universe_context ~poly:false diff in
- (Hints.IsConstr (c, None) [@ocaml.warning "-3"])
- in
let fref r =
let gr = Smartlocate.global_with_alias r in
Dumpglob.add_glob ?loc:r.CAst.loc gr;
@@ -106,10 +96,22 @@ let interp_hints ~poly h =
match c with
| HintsReference c ->
let gr = Smartlocate.global_with_alias c in
- (PathHints [gr], IsGlobRef gr)
+ (PathHints [gr], hint_globref gr)
| HintsConstr c ->
let () = warn_deprecated_hint_constr () in
- (PathAny, f poly c)
+ let env = Global.env () in
+ let sigma = Evd.from_env env in
+ let c, uctx = Constrintern.interp_constr env sigma c in
+ let subst, uctx = UState.normalize_variables uctx in
+ let c = EConstr.Vars.subst_univs_constr subst c in
+ let diff = UState.context_set uctx in
+ let c =
+ if poly then (c, Some diff)
+ else
+ let () = DeclareUctx.declare_universe_context ~poly:false diff in
+ (c, None)
+ in
+ (PathAny, Hints.hint_constr c) [@ocaml.warning "-3"]
in
let fp = Constrintern.intern_constr_pattern env sigma in
let fres (info, b, r) =
@@ -149,7 +151,7 @@ let interp_hints ~poly h =
( empty_hint_info
, true
, PathHints [gr]
- , IsGlobRef gr ))
+ , hint_globref gr ))
in
HintsResolveEntry (List.flatten (List.map constr_hints_of_ind lqid))
| HintsExtern (pri, patcom, tacexp) ->
diff --git a/vernac/comPrimitive.ml b/vernac/comPrimitive.ml
index eaa5271a73..a910cc6e8b 100644
--- a/vernac/comPrimitive.ml
+++ b/vernac/comPrimitive.ml
@@ -30,7 +30,7 @@ let do_primitive id udecl prim typopt =
declare id {Entries.prim_entry_type = None; prim_entry_content = prim}
| Some typ ->
let env = Global.env () in
- let evd, udecl = Constrexpr_ops.interp_univ_decl_opt env udecl in
+ let evd, udecl = Constrintern.interp_univ_decl_opt env udecl in
let auctx = CPrimitives.op_or_type_univs prim in
let evd, u = Evd.with_context_set UState.univ_flexible evd (UnivGen.fresh_instance auctx) in
let expected_typ = EConstr.of_constr @@ Typeops.type_of_prim_or_type env u prim in
diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml
index 9623317ddf..31f91979d3 100644
--- a/vernac/comProgramFixpoint.ml
+++ b/vernac/comProgramFixpoint.ml
@@ -115,7 +115,7 @@ let build_wellfounded pm (recname,pl,bl,arityc,body) poly ?using r measure notat
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 sigma, udecl = Constrexpr_ops.interp_univ_decl_opt env pl in
+ let sigma, udecl = interp_univ_decl_opt env pl in
let sigma, (_, ((env', binders_rel), impls)) = interp_context_evars ~program_mode:true env sigma bl in
let len = List.length binders_rel in
let top_env = push_rel_context binders_rel env in
diff --git a/vernac/comSearch.ml b/vernac/comSearch.ml
index 9de8d6fbc3..af51f4fafb 100644
--- a/vernac/comSearch.ml
+++ b/vernac/comSearch.ml
@@ -53,9 +53,19 @@ let kind_searcher = Decls.(function
let interp_search_item env sigma =
function
| SearchSubPattern ((where,head),pat) ->
- let _,pat = Constrintern.intern_constr_pattern env sigma pat in
+ let expected_type = Pretyping.(if head then IsType else WithoutTypeConstraint) in
+ let pat =
+ try Constrintern.interp_constr_pattern env sigma ~expected_type pat
+ with e when CErrors.noncritical e ->
+ (* We cannot ensure (yet?) that a typable pattern will
+ actually be typed, consider e.g. (forall A, A -> A /\ A)
+ which fails, not seeing that A can be Prop; so we use an
+ untyped pattern as a fallback (i.e w/o no insertion of
+ coercions, no compilation of pattern-matching) *)
+ snd (Constrintern.intern_constr_pattern env sigma ~as_type:head pat) in
GlobSearchSubPattern (where,head,pat)
- | SearchString ((Anywhere,false),s,None) when Id.is_valid s ->
+ | SearchString ((Anywhere,false),s,None)
+ when Id.is_valid_ident_part s && String.equal (String.drop_simple_quotes s) s ->
GlobSearchString s
| SearchString ((where,head),s,sc) ->
(try
diff --git a/vernac/declare.ml b/vernac/declare.ml
index 0baae6eca5..1e8771b641 100644
--- a/vernac/declare.ml
+++ b/vernac/declare.ml
@@ -1291,7 +1291,7 @@ let obligation_terminator ~pm ~entry ~uctx ~oinfo:{name; num; auto} =
FIXME: There is duplication of this code with obligation_terminator
and Obligations.admit_obligations *)
-let obligation_admitted_terminator ~pm {name; num; auto} ctx' dref =
+let obligation_admitted_terminator ~pm {name; num; auto} uctx' dref =
let prg = Option.get (State.find pm name) in
let {obls; remaining = rem} = prg.prg_obligations in
let obl = obls.(num) in
@@ -1303,21 +1303,21 @@ let obligation_admitted_terminator ~pm {name; num; auto} ctx' dref =
if not transparent then err_not_transp ()
| _ -> ()
in
- let inst, ctx' =
+ let inst, uctx' =
if not prg.prg_info.Info.poly (* Not polymorphic *) then
(* The universe context was declared globally, we continue
from the new global environment. *)
- let ctx = UState.from_env (Global.env ()) in
- let ctx' = UState.merge_subst ctx (UState.subst ctx') in
- (Univ.Instance.empty, ctx')
+ let uctx = UState.from_env (Global.env ()) in
+ let uctx' = UState.merge_subst uctx (UState.subst uctx') in
+ (Univ.Instance.empty, uctx')
else
(* We get the right order somehow, but surely it could be enforced in a clearer way. *)
- let uctx = UState.context ctx' in
- (Univ.UContext.instance uctx, ctx')
+ let uctx = UState.context uctx' in
+ (Univ.UContext.instance uctx, uctx')
in
let obl = {obl with obl_body = Some (DefinedObl (cst, inst))} in
let () = if transparent then add_hint true prg cst in
- update_program_decl_on_defined ~pm prg obls num obl ~uctx:ctx' rem ~auto
+ update_program_decl_on_defined ~pm prg obls num obl ~uctx:uctx' rem ~auto
end
@@ -1627,12 +1627,12 @@ let make_univs_deferred ~poly ~initial_euctx ~uctx ~udecl
let make_univs_private_poly ~poly ~uctx ~udecl (used_univs_typ, typ) (used_univs_body, body) =
let used_univs = Univ.LSet.union used_univs_body used_univs_typ in
- let universes = UState.restrict uctx used_univs in
- let typus = UState.restrict universes used_univs_typ in
- let utyp = UState.check_univ_decl ~poly typus udecl in
+ let uctx = UState.restrict uctx used_univs in
+ let uctx' = UState.restrict uctx used_univs_typ in
+ let utyp = UState.check_univ_decl ~poly uctx' udecl in
let ubody = Univ.ContextSet.diff
- (UState.context_set universes)
- (UState.context_set typus)
+ (UState.context_set uctx)
+ (UState.context_set uctx')
in
utyp, ubody
@@ -1643,8 +1643,8 @@ let make_univs ~poly ~uctx ~udecl (used_univs_typ, typ) (used_univs_body, body)
for the typ. We recheck the declaration after restricting with
the actually used universes.
TODO: check if restrict is really necessary now. *)
- let ctx = UState.restrict uctx used_univs in
- let utyp = UState.check_univ_decl ~poly ctx udecl in
+ let uctx = UState.restrict uctx used_univs in
+ let utyp = UState.check_univ_decl ~poly uctx udecl in
utyp, Univ.ContextSet.empty
let close_proof ~opaque ~keep_body_ucst_separate ps =
@@ -1712,9 +1712,9 @@ let close_proof_delayed ~feedback_id ps (fpl : closed_proof_output Future.comput
(Vars.universes_of_constr types)
(Vars.universes_of_constr pt)
in
- let univs = UState.restrict uctx used_univs in
- let univs = UState.check_mono_univ_decl univs udecl in
- (pt,univs),eff)
+ let uctx = UState.restrict uctx used_univs in
+ let uctx = UState.check_mono_univ_decl uctx udecl in
+ (pt,uctx),eff)
|> delayed_definition_entry ~opaque ~feedback_id ~using ~univs ~types
in
let entries = Future.map2 make_entry fpl (Proofview.initial_goals entry) in
@@ -2499,7 +2499,12 @@ let admit_obligations ~pm n =
let next_obligation ~pm n tac =
let prg = match n with
- | None -> State.first_pending pm |> Option.get
+ | None ->
+ begin match State.first_pending pm with
+ | Some prg -> prg
+ | None ->
+ Error.no_obligations None
+ end
| Some _ -> get_unique_prog ~pm n
in
let {obls; remaining} = Internal.get_obligations prg in
diff --git a/vernac/declaremods.mli b/vernac/declaremods.mli
index 9ca2ca5593..a1b98e4d9c 100644
--- a/vernac/declaremods.mli
+++ b/vernac/declaremods.mli
@@ -86,7 +86,7 @@ val start_library : library_name -> unit
val end_library :
?except:Future.UUIDSet.t -> output_native_objects:bool -> library_name ->
- Safe_typing.compiled_library * library_objects * Safe_typing.native_library
+ Safe_typing.compiled_library * library_objects * Nativelib.native_library
(** append a function to be executed at end_library *)
val append_end_library_hook : (unit -> unit) -> unit
diff --git a/vernac/library.ml b/vernac/library.ml
index e580927bfd..8a9b1fd68d 100644
--- a/vernac/library.ml
+++ b/vernac/library.ml
@@ -160,7 +160,7 @@ let register_loaded_library m =
let prefix = Nativecode.mod_uid_of_dirpath libname ^ "." in
let f = prefix ^ "cmo" in
let f = Dynlink.adapt_filename f in
- Nativelib.link_library (Global.env()) ~prefix ~dirname ~basename:f
+ Nativelib.link_library ~prefix ~dirname ~basename:f
in
let rec aux = function
| [] ->
@@ -502,7 +502,7 @@ let save_library_to todo_proofs ~output_native_objects dir f otab =
(* Writing native code files *)
if output_native_objects then
let fn = Filename.dirname f ^"/"^ Nativecode.mod_uid_of_dirpath dir in
- Nativelib.compile_library dir ast fn
+ Nativelib.compile_library ast fn
let save_library_raw f sum lib univs proofs =
save_library_base f sum lib (Some univs) None proofs
diff --git a/vernac/prettyp.ml b/vernac/prettyp.ml
index 06f7c32cdc..840754ccc6 100644
--- a/vernac/prettyp.ml
+++ b/vernac/prettyp.ml
@@ -631,11 +631,11 @@ let print_constant with_values sep sp udecl =
assert(ContextSet.is_empty body_uctxs);
Polymorphic ctx
in
- let ctx =
+ let uctx =
UState.of_binders
(Printer.universe_binders_with_opt_names (Declareops.constant_polymorphic_context cb) udecl)
in
- let env = Global.env () and sigma = Evd.from_ctx ctx in
+ let env = Global.env () and sigma = Evd.from_ctx uctx in
let pr_ltype = pr_ltype_env env sigma in
hov 0 (
match val_0 with
diff --git a/vernac/record.ml b/vernac/record.ml
index acc97f61c1..2c56604d8f 100644
--- a/vernac/record.ml
+++ b/vernac/record.ml
@@ -124,7 +124,7 @@ let typecheck_params_and_fields def poly pl ps records =
let is_template =
List.exists (fun (_, arity, _, _) -> Option.cata check_anonymous_type true arity) records in
let env0 = if not poly && is_template then Environ.set_universes_lbound env0 UGraph.Bound.Prop else env0 in
- let sigma, decl = Constrexpr_ops.interp_univ_decl_opt env0 pl in
+ let sigma, decl = interp_univ_decl_opt env0 pl in
let () =
let error bk {CAst.loc; v=name} =
match bk, name with
diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml
index ef8631fbb6..824bf35b1d 100644
--- a/vernac/vernacentries.ml
+++ b/vernac/vernacentries.ml
@@ -550,7 +550,7 @@ let start_lemma_com ~program_mode ~poly ~scope ~kind ?using ?hook thms =
let env0 = Global.env () in
let flags = Pretyping.{ all_no_fail_flags with program_mode } in
let decl = fst (List.hd thms) in
- let evd, udecl = Constrexpr_ops.interp_univ_decl_opt env0 (snd decl) in
+ let evd, udecl = Constrintern.interp_univ_decl_opt env0 (snd decl) in
let evd, thms = interp_lemma ~program_mode ~flags ~scope env0 evd thms in
let mut_analysis = RecLemmas.look_for_possibly_mutual_statements evd thms in
let evd = Evd.minimize_universes evd in
generated by cgit v1.2.3 (git 2.25.1) at 2026-05-01 06:39:05 +0000