aboutsummaryrefslogtreecommitdiff
path: root/engine
diff options
context:
space:
mode:
Diffstat (limited to 'engine')
-rw-r--r--engine/evarutil.ml17
-rw-r--r--engine/evarutil.mli4
-rw-r--r--engine/evd.ml14
-rw-r--r--engine/evd.mli5
-rw-r--r--engine/namegen.ml40
-rw-r--r--engine/namegen.mli21
-rw-r--r--engine/proofview.ml8
-rw-r--r--engine/termops.ml6
8 files changed, 63 insertions, 52 deletions
diff --git a/engine/evarutil.ml b/engine/evarutil.ml
index 339c6a248e..eabfb7b398 100644
--- a/engine/evarutil.ml
+++ b/engine/evarutil.ml
@@ -478,8 +478,6 @@ type clear_dependency_error =
exception ClearDependencyError of Id.t * clear_dependency_error
-let cleared = Store.field ()
-
exception Depends of Id.t
let rec check_and_clear_in_constr env evdref err ids global c =
@@ -552,13 +550,6 @@ 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;
- (* spiwack: hacking session to mark the old [evk] as having been "cleared" *)
- let evi = Evd.find !evdref evk in
- let extra = evi.evar_extra in
- let extra' = Store.set extra cleared true in
- let evi' = { evi with evar_extra = extra' } in
- evdref := Evd.add !evdref evk evi' ;
- (* spiwack: /hacking session *)
Evd.existential_value !evdref ev
| _ -> map_constr (check_and_clear_in_constr env evdref err ids global) c
@@ -665,11 +656,9 @@ let rec advance sigma evk =
match evi.evar_body with
| Evar_empty -> Some evk
| Evar_defined v ->
- if Option.default false (Store.get evi.evar_extra cleared) then
- let (evk,_) = Term.destEvar v in
- advance sigma evk
- else
- None
+ match is_restricted_evar evi with
+ | Some evk -> advance sigma evk
+ | None -> None
(** The following functions return the set of undefined evars
contained in the object, the defined evars being traversed.
diff --git a/engine/evarutil.mli b/engine/evarutil.mli
index 14173e774d..ee0fae3d46 100644
--- a/engine/evarutil.mli
+++ b/engine/evarutil.mli
@@ -204,10 +204,6 @@ type clear_dependency_error =
exception ClearDependencyError of Id.t * clear_dependency_error
-(* spiwack: marks an evar that has been "defined" by clear.
- used by [Goal] and (indirectly) [Proofview] to handle the clear tactic gracefully*)
-val cleared : bool Store.field
-
val clear_hyps_in_evi : env -> evar_map ref -> named_context_val -> types ->
Id.Set.t -> named_context_val * types
diff --git a/engine/evd.ml b/engine/evd.ml
index f1b5419dec..324f883e8e 100644
--- a/engine/evd.ml
+++ b/engine/evd.ml
@@ -630,7 +630,9 @@ let evar_source evk d = (find d evk).evar_source
let evar_ident evk evd = EvNames.ident evk evd.evar_names
let evar_key id evd = EvNames.key id evd.evar_names
-let define_aux def undef evk body =
+let restricted = Store.field ()
+
+let define_aux ?dorestrict def undef evk body =
let oldinfo =
try EvMap.find evk undef
with Not_found ->
@@ -640,7 +642,10 @@ let define_aux def undef evk body =
anomaly ~label:"Evd.define" (Pp.str "cannot define undeclared evar.")
in
let () = assert (oldinfo.evar_body == Evar_empty) in
- let newinfo = { oldinfo with evar_body = Evar_defined body } in
+ let evar_extra = match dorestrict with
+ | Some evk' -> Store.set oldinfo.evar_extra restricted evk'
+ | None -> oldinfo.evar_extra in
+ let newinfo = { oldinfo with evar_body = Evar_defined body; evar_extra } in
EvMap.add evk newinfo def, EvMap.remove evk undef
(* define the existential of section path sp as the constr body *)
@@ -653,6 +658,9 @@ let define evk body evd =
let evar_names = EvNames.remove_name_defined evk evd.evar_names in
{ evd with defn_evars; undf_evars; last_mods; evar_names }
+let is_restricted_evar evi =
+ Store.get evi.evar_extra restricted
+
let restrict evk filter ?candidates ?src evd =
let evk' = new_untyped_evar () in
let evar_info = EvMap.find evk evd.undf_evars in
@@ -667,7 +675,7 @@ let restrict evk filter ?candidates ?src evd =
let ctxt = Filter.filter_list filter (evar_context evar_info) in
let id_inst = Array.map_of_list (NamedDecl.get_id %> mkVar) ctxt in
let body = mkEvar(evk',id_inst) in
- let (defn_evars, undf_evars) = define_aux evd.defn_evars evd.undf_evars evk body in
+ let (defn_evars, undf_evars) = define_aux ~dorestrict:evk' evd.defn_evars evd.undf_evars evk body in
{ evd with undf_evars = EvMap.add evk' evar_info' undf_evars;
defn_evars; last_mods; evar_names }, evk'
diff --git a/engine/evd.mli b/engine/evd.mli
index abcabe8157..96e4b6acce 100644
--- a/engine/evd.mli
+++ b/engine/evd.mli
@@ -31,7 +31,7 @@ open Environ
(** {6 Evars} *)
type evar = existential_key
-(** Existential variables. TODO: Should be made opaque one day. *)
+(** Existential variables. *)
val string_of_existential : evar -> string
@@ -244,6 +244,9 @@ val restrict : evar -> Filter.t -> ?candidates:constr list ->
(** Restrict an undefined evar into a new evar by filtering context and
possibly limiting the instances to a set of candidates *)
+val is_restricted_evar : evar_info -> evar option
+(** Tell if an evar comes from restriction of another evar, and if yes, which *)
+
val downcast : evar -> types -> evar_map -> evar_map
(** Change the type of an undefined evar to a new type assumed to be a
subtype of its current type; subtyping must be ensured by caller *)
diff --git a/engine/namegen.ml b/engine/namegen.ml
index a75fe721f7..2e62b89011 100644
--- a/engine/namegen.ml
+++ b/engine/namegen.ml
@@ -43,6 +43,8 @@ let default_non_dependent_ident = Id.of_string default_non_dependent_string
let default_dependent_ident = Id.of_string "x"
+let default_generated_non_letter_string = "x"
+
(**********************************************************************)
(* Globality of identifiers *)
@@ -107,7 +109,17 @@ let head_name sigma c = (* Find the head constant of a constr if any *)
hdrec c
let lowercase_first_char id = (* First character of a constr *)
- Unicode.lowercase_first_char (Id.to_string id)
+ let s = Id.to_string id in
+ match Unicode.split_at_first_letter s with
+ | None ->
+ (* General case: nat -> n *)
+ Unicode.lowercase_first_char s
+ | Some (s,s') ->
+ if String.length s' = 0 then
+ (* No letter, e.g. __, or __'_, etc. *)
+ default_generated_non_letter_string
+ else
+ s ^ Unicode.lowercase_first_char s'
let sort_hdchar = function
| Prop(_) -> "P"
@@ -239,7 +251,7 @@ let visible_ids sigma (nenv, c) =
let next_name_away_in_cases_pattern sigma env_t na avoid =
let id = match na with Name id -> id | Anonymous -> default_dependent_ident in
let visible = visible_ids sigma env_t in
- let bad id = Id.List.mem id avoid || is_constructor id
+ let bad id = Id.Set.mem id avoid || is_constructor id
|| Id.Set.mem id visible in
next_ident_away_from id bad
@@ -253,8 +265,8 @@ let next_name_away_in_cases_pattern sigma env_t na avoid =
name is taken by finding a free subscript starting from 0 *)
let next_ident_away_in_goal id avoid =
- let id = if Id.List.mem id avoid then restart_subscript id else id in
- let bad id = Id.List.mem id avoid || (is_global id && not (is_section_variable id)) in
+ let id = if Id.Set.mem id avoid then restart_subscript id else id in
+ let bad id = Id.Set.mem id avoid || (is_global id && not (is_section_variable id)) in
next_ident_away_from id bad
let next_name_away_in_goal na avoid =
@@ -271,16 +283,16 @@ let next_name_away_in_goal na avoid =
beyond the current subscript *)
let next_global_ident_away id avoid =
- let id = if Id.List.mem id avoid then restart_subscript id else id in
- let bad id = Id.List.mem id avoid || is_global id in
+ let id = if Id.Set.mem id avoid then restart_subscript id else id in
+ let bad id = Id.Set.mem id avoid || is_global id in
next_ident_away_from id bad
(* 4- Looks for next fresh name outside a list; if name already used,
looks for same name with lower available subscript *)
let next_ident_away id avoid =
- if Id.List.mem id avoid then
- next_ident_away_from (restart_subscript id) (fun id -> Id.List.mem id avoid)
+ if Id.Set.mem id avoid then
+ next_ident_away_from (restart_subscript id) (fun id -> Id.Set.mem id avoid)
else id
let next_name_away_with_default default na avoid =
@@ -302,7 +314,7 @@ let next_name_away = next_name_away_with_default default_non_dependent_string
let make_all_name_different env sigma =
(** FIXME: this is inefficient, but only used in printing *)
- let avoid = ref (Id.Set.elements (Context.Named.to_vars (named_context env))) in
+ let avoid = ref (ids_of_named_context_val (named_context_val env)) in
let sign = named_context_val env in
let rels = rel_context env in
let env0 = reset_with_named_context sign env in
@@ -310,7 +322,7 @@ let make_all_name_different env sigma =
(fun decl newenv ->
let na = named_hd newenv sigma (RelDecl.get_type decl) (RelDecl.get_name decl) in
let id = next_name_away na !avoid in
- avoid := id::!avoid;
+ avoid := Id.Set.add id !avoid;
push_rel (RelDecl.set_name (Name id) decl) newenv)
rels ~init:env0
@@ -321,7 +333,7 @@ let make_all_name_different env sigma =
let next_ident_away_for_default_printing sigma env_t id avoid =
let visible = visible_ids sigma env_t in
- let bad id = Id.List.mem id avoid || Id.Set.mem id visible in
+ let bad id = Id.Set.mem id avoid || Id.Set.mem id visible in
next_ident_away_from id bad
let next_name_away_for_default_printing sigma env_t na avoid =
@@ -371,7 +383,7 @@ let compute_displayed_name_in sigma flags avoid na c =
| _ ->
let fresh_id = next_name_for_display sigma flags na avoid in
let idopt = if noccurn sigma 1 c then Anonymous else Name fresh_id in
- (idopt, fresh_id::avoid)
+ (idopt, Id.Set.add fresh_id avoid)
let compute_and_force_displayed_name_in sigma flags avoid na c =
match na with
@@ -379,11 +391,11 @@ let compute_and_force_displayed_name_in sigma flags avoid na c =
(Anonymous,avoid)
| _ ->
let fresh_id = next_name_for_display sigma flags na avoid in
- (Name fresh_id, fresh_id::avoid)
+ (Name fresh_id, Id.Set.add fresh_id avoid)
let compute_displayed_let_name_in sigma flags avoid na c =
let fresh_id = next_name_for_display sigma flags na avoid in
- (Name fresh_id, fresh_id::avoid)
+ (Name fresh_id, Id.Set.add fresh_id avoid)
let rename_bound_vars_as_displayed sigma avoid env c =
let rec rename avoid env c =
diff --git a/engine/namegen.mli b/engine/namegen.mli
index 14846a9184..6fde90a39c 100644
--- a/engine/namegen.mli
+++ b/engine/namegen.mli
@@ -72,23 +72,22 @@ val next_ident_away_from : Id.t -> (Id.t -> bool) -> Id.t
the whole identifier except for the {i subscript}.
E.g. if we take [foo42], then [42] is the {i subscript}, and [foo] is the root. *)
-val next_ident_away : Id.t -> Id.t list -> Id.t
+val next_ident_away : Id.t -> Id.Set.t -> Id.t
(** Avoid clashing with a name already used in current module *)
-val next_ident_away_in_goal : Id.t -> Id.t list -> Id.t
+val next_ident_away_in_goal : Id.t -> Id.Set.t -> Id.t
(** Avoid clashing with a name already used in current module
but tolerate overwriting section variables, as in goals *)
-val next_global_ident_away : Id.t -> Id.t list -> Id.t
+val next_global_ident_away : Id.t -> Id.Set.t -> Id.t
(** Default is [default_non_dependent_ident] *)
-val next_name_away : Name.t -> Id.t list -> Id.t
+val next_name_away : Name.t -> Id.Set.t -> Id.t
-val next_name_away_with_default : string -> Name.t -> Id.t list ->
- Id.t
+val next_name_away_with_default : string -> Name.t -> Id.Set.t -> Id.t
val next_name_away_with_default_using_types : string -> Name.t ->
- Id.t list -> types -> Id.t
+ Id.Set.t -> types -> Id.t
val set_reserved_typed_name : (types -> Name.t) -> unit
@@ -103,13 +102,13 @@ type renaming_flags =
val make_all_name_different : env -> evar_map -> env
val compute_displayed_name_in :
- evar_map -> renaming_flags -> Id.t list -> Name.t -> constr -> Name.t * Id.t list
+ evar_map -> renaming_flags -> Id.Set.t -> Name.t -> constr -> Name.t * Id.Set.t
val compute_and_force_displayed_name_in :
- evar_map -> renaming_flags -> Id.t list -> Name.t -> constr -> Name.t * Id.t list
+ evar_map -> renaming_flags -> Id.Set.t -> Name.t -> constr -> Name.t * Id.Set.t
val compute_displayed_let_name_in :
- evar_map -> renaming_flags -> Id.t list -> Name.t -> constr -> Name.t * Id.t list
+ evar_map -> renaming_flags -> Id.Set.t -> Name.t -> constr -> Name.t * Id.Set.t
val rename_bound_vars_as_displayed :
- evar_map -> Id.t list -> Name.t list -> types -> types
+ evar_map -> Id.Set.t -> Name.t list -> types -> types
(**********************************************************************)
(* Naming strategy for arguments in Prop when eliminating inductive types *)
diff --git a/engine/proofview.ml b/engine/proofview.ml
index eef2b83f44..598358c472 100644
--- a/engine/proofview.ml
+++ b/engine/proofview.ml
@@ -153,8 +153,12 @@ let focus i j sp =
( { sp with comb = new_comb } , context )
(** [undefined defs l] is the list of goals in [l] which are still
- unsolved (after advancing cleared goals). *)
-let undefined defs l = CList.map_filter (Evarutil.advance defs) l
+ unsolved (after advancing cleared goals). Note that order matters. *)
+let undefined defs l =
+ List.fold_right (fun evk l ->
+ match Evarutil.advance defs evk with
+ | Some evk -> List.add_set Evar.equal evk l
+ | None -> l) l []
(** Unfocuses a proofview with respect to a context. *)
let unfocus c sp =
diff --git a/engine/termops.ml b/engine/termops.ml
index e2bdf72387..b7fa2dc4a4 100644
--- a/engine/termops.ml
+++ b/engine/termops.ml
@@ -1071,9 +1071,9 @@ let replace_term_gen sigma eq_fun c by_c in_t =
let replace_term sigma c byc t = replace_term_gen sigma EConstr.eq_constr c byc t
let vars_of_env env =
- let s =
- Context.Named.fold_outside (fun decl s -> Id.Set.add (NamedDecl.get_id decl) s)
- (named_context env) ~init:Id.Set.empty in
+ let s = Environ.ids_of_named_context_val (Environ.named_context_val env) in
+ if List.is_empty (Environ.rel_context env) then s
+ else
Context.Rel.fold_outside
(fun decl s -> match RelDecl.get_name decl with Name id -> Id.Set.add id s | _ -> s)
(rel_context env) ~init:s
generated by cgit v1.2.3 (git 2.25.1) at 2026-04-29 20:26:20 +0000