aboutsummaryrefslogtreecommitdiff
path: root/engine/evarutil.ml
diff options
context:
space:
mode:
Diffstat (limited to 'engine/evarutil.ml')
-rw-r--r--engine/evarutil.ml101
1 files changed, 58 insertions, 43 deletions
diff --git a/engine/evarutil.ml b/engine/evarutil.ml
index 45760c6b4b..710491f848 100644
--- a/engine/evarutil.ml
+++ b/engine/evarutil.ml
@@ -23,7 +23,8 @@ module RelDecl = Context.Rel.Declaration
module NamedDecl = Context.Named.Declaration
let safe_evar_value sigma ev =
- try Some (Evd.existential_value sigma ev)
+ let ev = EConstr.of_existential ev in
+ try Some (EConstr.Unsafe.to_constr @@ Evd.existential_value sigma ev)
with NotInstantiatedEvar | Not_found -> None
(** Combinators *)
@@ -44,11 +45,11 @@ let evd_comb2 f evdref x y =
z
let e_new_global evdref x =
- EConstr.of_constr (evd_comb1 (Evd.fresh_global (Global.env())) evdref x)
+ evd_comb1 (Evd.fresh_global (Global.env())) evdref x
let new_global evd x =
let (evd, c) = Evd.fresh_global (Global.env()) evd x in
- (evd, EConstr.of_constr c)
+ (evd, c)
(****************************************************)
(* Expanding/testing/exposing existential variables *)
@@ -61,7 +62,7 @@ exception Uninstantiated_evar of Evar.t
let rec flush_and_check_evars sigma c =
match kind c with
| Evar (evk,_ as ev) ->
- (match existential_opt_value sigma ev with
+ (match existential_opt_value0 sigma ev with
| None -> raise (Uninstantiated_evar evk)
| Some c -> flush_and_check_evars sigma c)
| _ -> Constr.map (flush_and_check_evars sigma) c
@@ -72,9 +73,9 @@ let flush_and_check_evars sigma c =
(** Term exploration up to instantiation. *)
let kind_of_term_upto = EConstr.kind_upto
-let nf_evar0 sigma t = EConstr.to_constr sigma (EConstr.of_constr t)
+let nf_evar0 sigma t = EConstr.to_constr ~abort_on_undefined_evars:false sigma (EConstr.of_constr t)
let whd_evar = EConstr.whd_evar
-let nf_evar sigma c = EConstr.of_constr (EConstr.to_constr sigma c)
+let nf_evar sigma c = EConstr.of_constr (EConstr.to_constr ~abort_on_undefined_evars:false sigma c)
let j_nf_evar sigma j =
{ uj_val = nf_evar sigma j.uj_val;
@@ -102,7 +103,8 @@ let nf_evar_map_universes evm =
if Univ.LMap.is_empty subst then evm, nf_evar0 evm
else
let f = nf_evars_universes evm in
- Evd.raw_map (fun _ -> map_evar_info f) evm, f
+ let f' c = EConstr.of_constr (f (EConstr.Unsafe.to_constr c)) in
+ Evd.raw_map (fun _ -> map_evar_info f') evm, f
let nf_named_context_evar sigma ctx =
Context.Named.map (nf_evar0 sigma) ctx
@@ -115,7 +117,7 @@ let nf_env_evar sigma env =
let rel' = nf_rel_context_evar sigma (EConstr.rel_context env) in
EConstr.push_rel_context rel' (reset_with_named_context (val_of_named_context nc') env)
-let nf_evar_info evc info = map_evar_info (nf_evar0 evc) info
+let nf_evar_info evc info = map_evar_info (nf_evar evc) info
let nf_evar_map evm =
Evd.raw_map (fun _ evi -> nf_evar_info evm evi) evm
@@ -340,7 +342,15 @@ let update_var src tgt subst =
let csubst_var = Id.Map.add id (Constr.mkVar tgt) subst.csubst_var in
{ subst with csubst_var; csubst_rev }
-let push_rel_decl_to_named_context sigma decl (subst, avoid, nc) =
+type naming_mode =
+ | KeepUserNameAndRenameExistingButSectionNames
+ | KeepUserNameAndRenameExistingEvenSectionNames
+ | KeepExistingNames
+ | FailIfConflict
+
+let push_rel_decl_to_named_context
+ ?(hypnaming=KeepUserNameAndRenameExistingButSectionNames)
+ sigma decl (subst, avoid, nc) =
let open EConstr in
let open Vars in
let map_decl f d =
@@ -371,7 +381,9 @@ let push_rel_decl_to_named_context sigma decl (subst, avoid, nc) =
next_ident_away (id_of_name_using_hdchar empty_env sigma (RelDecl.get_type decl) na) avoid
in
match extract_if_neq id na with
- | Some id0 when not (is_section_variable id0) ->
+ | Some id0 when hypnaming = KeepUserNameAndRenameExistingEvenSectionNames ||
+ hypnaming = KeepUserNameAndRenameExistingButSectionNames &&
+ not (is_section_variable id0) ->
(* spiwack: if [id<>id0], rather than introducing a new
binding named [id], we will keep [id0] (the name given
by the user) and rename [id0] into [id] in the named
@@ -380,6 +392,8 @@ let push_rel_decl_to_named_context sigma decl (subst, avoid, nc) =
let d = decl |> NamedDecl.of_rel_decl (fun _ -> id0) |> map_decl (csubst_subst subst) in
let nc = List.map (replace_var_named_declaration id0 id) nc in
(push_var id0 subst, Id.Set.add id avoid, d :: nc)
+ | Some id0 when hypnaming = FailIfConflict ->
+ user_err Pp.(Id.print id0 ++ str " is already used.")
| _ ->
(* spiwack: if [id0] is a section variable renaming it is
incorrect. We revert to a less robust behaviour where
@@ -388,7 +402,7 @@ let push_rel_decl_to_named_context sigma decl (subst, avoid, nc) =
let d = decl |> NamedDecl.of_rel_decl (fun _ -> id) |> map_decl (csubst_subst subst) in
(push_var id subst, Id.Set.add id avoid, d :: nc)
-let push_rel_context_to_named_context env sigma typ =
+let push_rel_context_to_named_context ?hypnaming env sigma typ =
(* compute the instances relative to the named context and rel_context *)
let open Context.Named.Declaration in
let open EConstr in
@@ -403,7 +417,7 @@ let push_rel_context_to_named_context env sigma typ =
(* with vars of the rel context *)
(* We do keep the instances corresponding to local definition (see above) *)
let (subst, _, env) =
- Context.Rel.fold_outside (fun d acc -> push_rel_decl_to_named_context sigma d acc)
+ Context.Rel.fold_outside (fun d acc -> push_rel_decl_to_named_context ?hypnaming sigma d acc)
(rel_context env) ~init:(empty_csubst, avoid, named_context env) in
(val_of_named_context env, csubst_subst subst typ, inst_rels@inst_vars, subst)
@@ -414,7 +428,6 @@ let push_rel_context_to_named_context env sigma typ =
let default_source = Loc.tag @@ Evar_kinds.InternalHole
let restrict_evar evd evk filter ?src candidates =
- let candidates = Option.map (fun l -> List.map EConstr.Unsafe.to_constr l) candidates in
let evd, evk' = Evd.restrict evk filter ?candidates ?src evd in
Evd.declare_future_goal evk' evd, evk'
@@ -424,8 +437,6 @@ let new_pure_evar_full evd evi =
(evd, evk)
let new_pure_evar sign evd ?(src=default_source) ?(filter = Filter.identity) ?candidates ?(store = Store.empty) ?naming ?(principal=false) typ =
- let typ = EConstr.Unsafe.to_constr typ in
- let candidates = Option.map (fun l -> List.map EConstr.Unsafe.to_constr l) candidates in
let default_naming = Misctypes.IntroAnonymous in
let naming = Option.default default_naming naming in
let name = match naming with
@@ -469,8 +480,8 @@ let new_evar_from_context sign evd ?src ?filter ?candidates ?store ?naming ?prin
(* [new_evar] declares a new existential in an env env with type typ *)
(* Converting the env into the sign of the evar to define *)
-let new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ =
- let sign,typ',instance,subst = push_rel_context_to_named_context env evd typ in
+let new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal ?hypnaming typ =
+ let sign,typ',instance,subst = push_rel_context_to_named_context ?hypnaming env evd typ in
let map c = csubst_subst subst c in
let candidates = Option.map (fun l -> List.map map l) candidates in
let instance =
@@ -479,13 +490,13 @@ let new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ =
| Some filter -> Filter.filter_list filter instance in
new_evar_instance sign evd typ' ?src ?filter ?candidates ?store ?naming ?principal instance
-let new_type_evar env evd ?src ?filter ?naming ?principal rigid =
+let new_type_evar env evd ?src ?filter ?naming ?principal ?hypnaming rigid =
let (evd', s) = new_sort_variable rigid evd in
- let (evd', e) = new_evar env evd' ?src ?filter ?naming ?principal (EConstr.mkSort s) in
+ let (evd', e) = new_evar env evd' ?src ?filter ?naming ?principal ?hypnaming (EConstr.mkSort s) in
evd', (e, s)
-let e_new_type_evar env evdref ?src ?filter ?naming ?principal rigid =
- let (evd, c) = new_type_evar env !evdref ?src ?filter ?naming ?principal rigid in
+let e_new_type_evar env evdref ?src ?filter ?naming ?principal ?hypnaming rigid =
+ let (evd, c) = new_type_evar env !evdref ?src ?filter ?naming ?principal ?hypnaming rigid in
evdref := evd;
c
@@ -499,8 +510,8 @@ let e_new_Type ?(rigid=Evd.univ_flexible) env evdref =
evdref := evd'; EConstr.mkSort s
(* The same using side-effect *)
-let e_new_evar env evdref ?(src=default_source) ?filter ?candidates ?store ?naming ?principal ty =
- let (evd',ev) = new_evar env !evdref ~src:src ?filter ?candidates ?store ?naming ?principal ty in
+let e_new_evar env evdref ?(src=default_source) ?filter ?candidates ?store ?naming ?principal ?hypnaming ty =
+ let (evd',ev) = new_evar env !evdref ~src:src ?filter ?candidates ?store ?naming ?principal ?hypnaming ty in
evdref := evd';
ev
@@ -513,7 +524,7 @@ let generalize_evar_over_rels sigma (ev,args) =
List.fold_left2
(fun (c,inst as x) a d ->
if isRel sigma a then (mkNamedProd_or_LetIn d c,a::inst) else x)
- (EConstr.of_constr evi.evar_concl,[]) (Array.to_list args) sign
+ (evi.evar_concl,[]) (Array.to_list args) sign
(************************************)
(* Removing a dependency in an evar *)
@@ -523,7 +534,7 @@ type clear_dependency_error =
| OccurHypInSimpleClause of Id.t option
| EvarTypingBreak of existential
-exception ClearDependencyError of Id.t * clear_dependency_error
+exception ClearDependencyError of Id.t * clear_dependency_error * Globnames.global_reference option
exception Depends of Id.t
@@ -534,13 +545,13 @@ let rec check_and_clear_in_constr env evdref err ids global c =
is a section variable *)
match kind c with
| Var id' ->
- if Id.Set.mem id' ids then raise (ClearDependencyError (id', err)) else c
+ if Id.Set.mem id' ids then raise (ClearDependencyError (id', err, None)) else c
| ( Const _ | Ind _ | Construct _ ) ->
let () = if global then
let check id' =
if Id.Set.mem id' ids then
- raise (ClearDependencyError (id',err))
+ raise (ClearDependencyError (id',err,Some (Globnames.global_of_constr c)))
in
Id.Set.iter check (Environ.vars_of_global env c)
in
@@ -549,7 +560,8 @@ let rec check_and_clear_in_constr env evdref err ids global c =
| Evar (evk,l as ev) ->
if Evd.is_defined !evdref evk then
(* If evk is already defined we replace it by its definition *)
- let nc = Evd.existential_value !evdref ev in
+ let nc = Evd.existential_value !evdref (EConstr.of_existential ev) in
+ let nc = EConstr.Unsafe.to_constr nc in
(check_and_clear_in_constr env evdref err ids global nc)
else
(* We check for dependencies to elements of ids in the
@@ -559,8 +571,7 @@ let rec check_and_clear_in_constr env evdref err ids global c =
removed *)
let evi = Evd.find_undefined !evdref evk in
let ctxt = Evd.evar_filtered_context evi in
- let ctxt = List.map (fun d -> map_named_decl EConstr.of_constr d) ctxt in
- let (rids,filter) =
+ let (rids,filter) =
List.fold_right2
(fun h a (ri,filter) ->
try
@@ -586,9 +597,10 @@ let rec check_and_clear_in_constr env evdref err ids global c =
try
let nids = Id.Map.domain rids in
let global = Id.Set.exists is_section_variable nids in
- check_and_clear_in_constr env evdref (EvarTypingBreak ev) nids global (evar_concl evi)
- with ClearDependencyError (rid,err) ->
- raise (ClearDependencyError (Id.Map.find rid rids,err)) in
+ let concl = EConstr.Unsafe.to_constr (evar_concl evi) in
+ check_and_clear_in_constr env evdref (EvarTypingBreak ev) nids global concl
+ with ClearDependencyError (rid,err,where) ->
+ raise (ClearDependencyError (Id.Map.find rid rids,err,where)) in
if Id.Map.is_empty rids then c
else
@@ -597,7 +609,7 @@ let rec check_and_clear_in_constr env evdref err ids global c =
let evd = !evdref in
let (evd,_) = restrict_evar evd evk filter None in
evdref := evd;
- Evd.existential_value !evdref ev
+ Evd.existential_value0 !evdref ev
| _ -> Constr.map (check_and_clear_in_constr env evdref err ids global) c
@@ -643,7 +655,7 @@ let clear_hyps2_in_evi env evdref hyps t concl ids =
let queue_set q is_dependent set =
Evar.Set.iter (fun a -> Queue.push (is_dependent,a) q) set
let queue_term q is_dependent c =
- queue_set q is_dependent (evars_of_term c)
+ queue_set q is_dependent (evars_of_term (EConstr.Unsafe.to_constr c))
let process_dependent_evar q acc evm is_dependent e =
let evi = Evd.find evm e in
@@ -656,12 +668,12 @@ let process_dependent_evar q acc evm is_dependent e =
match decl with
| LocalAssum _ -> ()
| LocalDef (_,b,_) -> queue_term q true b
- end (Environ.named_context_of_val evi.evar_hyps);
+ end (EConstr.named_context_of_val evi.evar_hyps);
match evi.evar_body with
| Evar_empty ->
if is_dependent then Evar.Map.add e None acc else acc
| Evar_defined b ->
- let subevars = evars_of_term b in
+ let subevars = evars_of_term (EConstr.Unsafe.to_constr b) in
(* evars appearing in the definition of an evar [e] are marked
as dependent when [e] is dependent itself: if [e] is a
non-dependent goal, then, unless they are reach from another
@@ -729,11 +741,11 @@ let undefined_evars_of_named_context evd nc =
~init:Evar.Set.empty
let undefined_evars_of_evar_info evd evi =
- Evar.Set.union (undefined_evars_of_term evd (EConstr.of_constr evi.evar_concl))
+ Evar.Set.union (undefined_evars_of_term evd evi.evar_concl)
(Evar.Set.union
(match evi.evar_body with
| Evar_empty -> Evar.Set.empty
- | Evar_defined b -> undefined_evars_of_term evd (EConstr.of_constr b))
+ | Evar_defined b -> undefined_evars_of_term evd b)
(undefined_evars_of_named_context evd
(named_context_of_val evi.evar_hyps)))
@@ -781,10 +793,11 @@ let filtered_undefined_evars_of_evar_info ?cache sigma evi =
in
let accu = match evi.evar_body with
| Evar_empty -> Evar.Set.empty
- | Evar_defined b -> evars_of_term b
+ | Evar_defined b -> evars_of_term (EConstr.Unsafe.to_constr b)
in
- let accu = Evar.Set.union (undefined_evars_of_term sigma (EConstr.of_constr evi.evar_concl)) accu in
- evars_of_named_context cache accu (evar_filtered_context evi)
+ let accu = Evar.Set.union (undefined_evars_of_term sigma evi.evar_concl) accu in
+ let ctxt = EConstr.Unsafe.to_named_context (evar_filtered_context evi) in
+ evars_of_named_context cache accu ctxt
(* spiwack: this is a more complete version of
{!Termops.occur_evar}. The latter does not look recursively into an
@@ -794,7 +807,7 @@ let occur_evar_upto sigma n c =
let c = EConstr.Unsafe.to_constr c in
let rec occur_rec c = match kind c with
| Evar (sp,_) when Evar.equal sp n -> raise Occur
- | Evar e -> Option.iter occur_rec (existential_opt_value sigma e)
+ | Evar e -> Option.iter occur_rec (existential_opt_value0 sigma e)
| _ -> Constr.iter occur_rec c
in
try occur_rec c; false with Occur -> true
@@ -849,6 +862,8 @@ let compare_constructor_instances evd u u' =
let eq_constr_univs_test sigma1 sigma2 t u =
(* spiwack: mild code duplication with {!Evd.eq_constr_univs}. *)
let open Evd in
+ let t = EConstr.Unsafe.to_constr t
+ and u = EConstr.Unsafe.to_constr u in
let fold cstr sigma =
try Some (add_universe_constraints sigma cstr)
with Univ.UniverseInconsistency _ | UniversesDiffer -> None
generated by cgit v1.2.3 (git 2.25.1) at 2026-05-01 16:28:05 +0000