aboutsummaryrefslogtreecommitdiff
path: root/engine
diff options
context:
space:
mode:
Diffstat (limited to 'engine')
-rw-r--r--engine/evarutil.ml48
-rw-r--r--engine/evd.ml46
-rw-r--r--engine/namegen.ml13
-rw-r--r--engine/termops.ml32
-rw-r--r--engine/termops.mli3
5 files changed, 70 insertions, 72 deletions
diff --git a/engine/evarutil.ml b/engine/evarutil.ml
index bd86f4bd27..4bd11df8bd 100644
--- a/engine/evarutil.ml
+++ b/engine/evarutil.ml
@@ -18,6 +18,9 @@ open Environ
open Evd
open Sigma.Notations
+module RelDecl = Context.Rel.Declaration
+module NamedDecl = Context.Named.Declaration
+
let safe_evar_value sigma ev =
try Some (Evd.existential_value sigma ev)
with NotInstantiatedEvar | Not_found -> None
@@ -161,13 +164,11 @@ let is_ground_term evd t =
not (has_undefined_evars evd t)
let is_ground_env evd env =
- let open Context.Rel.Declaration in
let is_ground_rel_decl = function
- | LocalDef (_,b,_) -> is_ground_term evd b
+ | RelDecl.LocalDef (_,b,_) -> is_ground_term evd b
| _ -> true in
- let open Context.Named.Declaration in
let is_ground_named_decl = function
- | LocalDef (_,b,_) -> is_ground_term evd b
+ | NamedDecl.LocalDef (_,b,_) -> is_ground_term evd b
| _ -> true in
List.for_all is_ground_rel_decl (rel_context env) &&
List.for_all is_ground_named_decl (named_context env)
@@ -249,11 +250,10 @@ let non_instantiated sigma =
(************************)
let make_pure_subst evi args =
- let open Context.Named.Declaration in
snd (List.fold_right
(fun decl (args,l) ->
match args with
- | a::rest -> (rest, (get_id decl, a)::l)
+ | a::rest -> (rest, (NamedDecl.get_id decl, a)::l)
| _ -> anomaly (Pp.str "Instance does not match its signature"))
(evar_filtered_context evi) (Array.rev_to_list args,[]))
@@ -325,21 +325,18 @@ let push_var id (n, s) =
(succ n, s)
let push_rel_decl_to_named_context decl (subst, vsubst, avoid, nc) =
- let open Context.Named.Declaration in
let replace_var_named_declaration id0 id decl =
- let id' = get_id decl in
+ let id' = NamedDecl.get_id decl in
let id' = if Id.equal id0 id' then id else id' in
let vsubst = [id0 , mkVar id] in
- decl |> set_id id' |> map_constr (replace_vars vsubst)
+ decl |> NamedDecl.set_id id' |> NamedDecl.map_constr (replace_vars vsubst)
in
let extract_if_neq id = function
| Anonymous -> None
| Name id' when id_ord id id' = 0 -> None
| Name id' -> Some id'
in
- let open Context.Rel.Declaration in
- let (na, c, t) = to_tuple decl in
- let open Context.Named.Declaration in
+ let na = RelDecl.get_name decl in
let id =
(* ppedrot: we want to infer nicer names for the refine tactic, but
keeping at the same time backward compatibility in other code
@@ -350,7 +347,7 @@ let push_rel_decl_to_named_context decl (subst, vsubst, avoid, nc) =
else
(** id_of_name_using_hdchar only depends on the rel context which is empty
here *)
- next_ident_away (id_of_name_using_hdchar empty_env t na) avoid
+ next_ident_away (id_of_name_using_hdchar empty_env (RelDecl.get_type decl) na) avoid
in
match extract_if_neq id na with
| Some id0 when not (is_section_variable id0) ->
@@ -360,10 +357,7 @@ let push_rel_decl_to_named_context decl (subst, vsubst, avoid, nc) =
context. Unless [id] is a section variable. *)
let subst = (fst subst, Int.Map.map (replace_vars [id0,mkVar id]) (snd subst)) in
let vsubst = (id0,mkVar id)::vsubst in
- let d = match c with
- | None -> LocalAssum (id0, subst2 subst vsubst t)
- | Some c -> LocalDef (id0, subst2 subst vsubst c, subst2 subst vsubst t)
- in
+ let d = decl |> NamedDecl.of_rel_decl (fun _ -> id0) |> NamedDecl.map_constr (subst2 subst vsubst) in
let nc = List.map (replace_var_named_declaration id0 id) nc in
(push_var id0 subst, vsubst, Id.Set.add id avoid, d :: nc)
| _ ->
@@ -371,10 +365,7 @@ let push_rel_decl_to_named_context decl (subst, vsubst, avoid, nc) =
incorrect. We revert to a less robust behaviour where
the new binder has name [id]. Which amounts to the same
behaviour than when [id=id0]. *)
- let d = match c with
- | None -> LocalAssum (id, subst2 subst vsubst t)
- | Some c -> LocalDef (id, subst2 subst vsubst c, subst2 subst vsubst t)
- in
+ let d = decl |> NamedDecl.of_rel_decl (fun _ -> id) |> NamedDecl.map_constr (subst2 subst vsubst) in
(push_var id subst, vsubst, Id.Set.add id avoid, d :: nc)
let push_rel_context_to_named_context env typ =
@@ -551,8 +542,7 @@ let rec check_and_clear_in_constr env evdref err ids global c =
let () = Id.Map.iter check ri in
(* No dependency at all, we can keep this ev's context hyp *)
(ri, true::filter)
- with Depends id -> let open Context.Named.Declaration in
- (Id.Map.add (get_id h) id ri, false::filter))
+ with Depends id -> (Id.Map.add (NamedDecl.get_id h) id ri, false::filter))
ctxt (Array.to_list l) (Id.Map.empty,[]) in
(* Check if some rid to clear in the context of ev has dependencies
in the type of ev and adjust the source of the dependency *)
@@ -591,10 +581,9 @@ let clear_hyps_in_evi_main env evdref hyps terms ids =
let terms =
List.map (check_and_clear_in_constr env evdref (OccurHypInSimpleClause None) ids global) terms in
let nhyps =
- let open Context.Named.Declaration in
let check_context decl =
- let err = OccurHypInSimpleClause (Some (get_id decl)) in
- map_constr (check_and_clear_in_constr env evdref err ids global) decl
+ let err = OccurHypInSimpleClause (Some (NamedDecl.get_id decl)) in
+ NamedDecl.map_constr (check_and_clear_in_constr env evdref err ids global) decl
in
let check_value vk = match force_lazy_val vk with
| None -> vk
@@ -633,8 +622,8 @@ let process_dependent_evar q acc evm is_dependent e =
hypotheses), they are all dependent. *)
queue_term q true evi.evar_concl;
List.iter begin fun decl ->
- let open Context.Named.Declaration in
- queue_term q true (get_type decl);
+ let open NamedDecl in
+ queue_term q true (NamedDecl.get_type decl);
match decl with
| LocalAssum _ -> ()
| LocalDef (_,b,_) -> queue_term q true b
@@ -688,9 +677,8 @@ let undefined_evars_of_term evd t =
evrec Evar.Set.empty t
let undefined_evars_of_named_context evd nc =
- let open Context.Named.Declaration in
Context.Named.fold_outside
- (fold (fun c s -> Evar.Set.union s (undefined_evars_of_term evd c)))
+ (NamedDecl.fold_constr (fun c s -> Evar.Set.union s (undefined_evars_of_term evd c)))
nc
~init:Evar.Set.empty
diff --git a/engine/evd.ml b/engine/evd.ml
index 6ba8a51120..913856a8da 100644
--- a/engine/evd.ml
+++ b/engine/evd.ml
@@ -18,6 +18,9 @@ open Environ
open Globnames
open Context.Named.Declaration
+module RelDecl = Context.Rel.Declaration
+module NamedDecl = Context.Named.Declaration
+
(** Generic filters *)
module Filter :
sig
@@ -226,7 +229,7 @@ let evar_instance_array test_id info args =
if i < len then
let c = Array.unsafe_get args i in
if test_id d c then instrec filter ctxt (succ i)
- else (get_id d, c) :: instrec filter ctxt (succ i)
+ else (NamedDecl.get_id d, c) :: instrec filter ctxt (succ i)
else instance_mismatch ()
| _ -> instance_mismatch ()
in
@@ -235,7 +238,7 @@ let evar_instance_array test_id info args =
let map i d =
if (i < len) then
let c = Array.unsafe_get args i in
- if test_id d c then None else Some (get_id d, c)
+ if test_id d c then None else Some (NamedDecl.get_id d, c)
else instance_mismatch ()
in
List.map_filter_i map (evar_context info)
@@ -243,7 +246,7 @@ let evar_instance_array test_id info args =
instrec filter (evar_context info) 0
let make_evar_instance_array info args =
- evar_instance_array (isVarId % get_id) info args
+ evar_instance_array (NamedDecl.get_id %> isVarId) info args
let instantiate_evar_array info c args =
let inst = make_evar_instance_array info args in
@@ -284,7 +287,7 @@ let metavars_of c =
let rec collrec acc c =
match kind_of_term c with
| Meta mv -> Int.Set.add mv acc
- | _ -> fold_constr collrec acc c
+ | _ -> Term.fold_constr collrec acc c
in
collrec Int.Set.empty c
@@ -681,7 +684,7 @@ let restrict evk filter ?candidates evd =
evar_extra = Store.empty } in
let evar_names = EvNames.reassign_name_defined evk evk' evd.evar_names in
let ctxt = Filter.filter_list filter (evar_context evar_info) in
- let id_inst = Array.map_of_list (mkVar % get_id) ctxt 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
{ evd with undf_evars = EvMap.add evk' evar_info' undf_evars;
@@ -731,23 +734,22 @@ let evar_list c =
let rec evrec acc c =
match kind_of_term c with
| Evar (evk, _ as ev) -> ev :: acc
- | _ -> fold_constr evrec acc c in
+ | _ -> Term.fold_constr evrec acc c in
evrec [] c
let evars_of_term c =
let rec evrec acc c =
match kind_of_term c with
| Evar (n, l) -> Evar.Set.add n (Array.fold_left evrec acc l)
- | _ -> fold_constr evrec acc c
+ | _ -> Term.fold_constr evrec acc c
in
evrec Evar.Set.empty c
let evars_of_named_context nc =
- List.fold_right (fun decl s ->
- Option.fold_left (fun s t ->
- Evar.Set.union s (evars_of_term t))
- (Evar.Set.union s (evars_of_term (get_type decl))) (get_value decl))
- nc Evar.Set.empty
+ Context.Named.fold_outside
+ (NamedDecl.fold_constr (fun constr s -> Evar.Set.union s (evars_of_term constr)))
+ nc
+ ~init:Evar.Set.empty
let evars_of_filtered_evar_info evi =
Evar.Set.union (evars_of_term evi.evar_concl)
@@ -1283,11 +1285,10 @@ let pr_meta_map mmap =
prlist pr_meta_binding (metamap_to_list mmap)
let pr_decl (decl,ok) =
- let id = get_id decl in
- match get_value decl with
- | None -> if ok then pr_id id else (str "{" ++ pr_id id ++ str "}")
- | Some c -> str (if ok then "(" else "{") ++ pr_id id ++ str ":=" ++
- print_constr c ++ str (if ok then ")" else "}")
+ match decl with
+ | LocalAssum (id,_) -> if ok then pr_id id else (str "{" ++ pr_id id ++ str "}")
+ | LocalDef (id,c,_) -> str (if ok then "(" else "{") ++ pr_id id ++ str ":=" ++
+ print_constr c ++ str (if ok then ")" else "}")
let pr_evar_source = function
| Evar_kinds.QuestionMark _ -> str "underscore"
@@ -1398,12 +1399,11 @@ let pr_evar_universe_context ctx =
h 0 (Universes.pr_universe_opt_subst (UState.subst ctx)) ++ fnl())
let print_env_short env =
- let pr_body n = function
- | None -> pr_name n
- | Some b -> str "(" ++ pr_name n ++ str " := " ++ print_constr b ++ str ")" in
- let pr_named_decl decl = pr_body (Name (get_id decl)) (get_value decl) in
- let pr_rel_decl decl = let open Context.Rel.Declaration in
- pr_body (get_name decl) (get_value decl) in
+ let pr_rel_decl = function
+ | RelDecl.LocalAssum (n,_) -> pr_name n
+ | RelDecl.LocalDef (n,b,_) -> str "(" ++ pr_name n ++ str " := " ++ print_constr b ++ str ")"
+ in
+ let pr_named_decl = NamedDecl.to_rel_decl %> pr_rel_decl in
let nc = List.rev (named_context env) in
let rc = List.rev (rel_context env) in
str "[" ++ pr_sequence pr_named_decl nc ++ str "]" ++ spc () ++
diff --git a/engine/namegen.ml b/engine/namegen.ml
index 84eb986845..1497dbda80 100644
--- a/engine/namegen.ml
+++ b/engine/namegen.ml
@@ -24,6 +24,8 @@ open Environ
open Termops
open Context.Rel.Declaration
+module RelDecl = Context.Rel.Declaration
+
(**********************************************************************)
(* Conventional names *)
@@ -114,9 +116,9 @@ let hdchar env c =
| Rel n ->
(if n<=k then "p" (* the initial term is flexible product/function *)
else
- try match Environ.lookup_rel (n-k) env |> to_tuple with
- | (Name id,_,_) -> lowercase_first_char id
- | (Anonymous,_,t) -> hdrec 0 (lift (n-k) t)
+ try match Environ.lookup_rel (n-k) env with
+ | LocalAssum (Name id,_) | LocalDef (Name id,_,_) -> lowercase_first_char id
+ | LocalAssum (Anonymous,t) | LocalDef (Anonymous,_,t) -> hdrec 0 (lift (n-k) t)
with Not_found -> "y")
| Fix ((_,i),(lna,_,_)) | CoFix (i,(lna,_,_)) ->
let id = match lna.(i) with Name id -> id | _ -> assert false in
@@ -295,11 +297,10 @@ let make_all_name_different env =
let avoid = ref (ids_of_named_context (named_context env)) in
process_rel_context
(fun decl newenv ->
- let (na,_,t) = to_tuple decl in
- let na = named_hd newenv t na in
+ let na = named_hd newenv (RelDecl.get_type decl) (RelDecl.get_name decl) in
let id = next_name_away na !avoid in
avoid := id::!avoid;
- push_rel (set_name (Name id) decl) newenv)
+ push_rel (RelDecl.set_name (Name id) decl) newenv)
env
(* 5- Looks for next fresh name outside a list; avoids also to use names that
diff --git a/engine/termops.ml b/engine/termops.ml
index a047bf53c7..b2c9492e1d 100644
--- a/engine/termops.ml
+++ b/engine/termops.ml
@@ -17,6 +17,7 @@ open Environ
module RelDecl = Context.Rel.Declaration
module NamedDecl = Context.Named.Declaration
+module CompactedDecl = Context.Compacted.Declaration
(* Sorts and sort family *)
@@ -981,18 +982,27 @@ let rec mem_named_context id ctxt =
| _ :: sign -> mem_named_context id sign
| [] -> false
-let compact_named_context_reverse sign =
+let compact_named_context sign =
let compact l decl =
- let (i1,c1,t1) = NamedDecl.to_tuple decl in
- match l with
- | [] -> [[i1],c1,t1]
- | (l2,c2,t2)::q ->
- if Option.equal Constr.equal c1 c2 && Constr.equal t1 t2
- then (i1::l2,c2,t2)::q
- else ([i1],c1,t1)::l
- in Context.Named.fold_inside compact ~init:[] sign
-
-let compact_named_context sign = List.rev (compact_named_context_reverse sign)
+ match decl, l with
+ | NamedDecl.LocalAssum (i,t), [] ->
+ [CompactedDecl.LocalAssum ([i],t)]
+ | NamedDecl.LocalDef (i,c,t), [] ->
+ [CompactedDecl.LocalDef ([i],c,t)]
+ | NamedDecl.LocalAssum (i1,t1), CompactedDecl.LocalAssum (li,t2) :: q ->
+ if Constr.equal t1 t2
+ then CompactedDecl.LocalAssum (i1::li, t2) :: q
+ else CompactedDecl.LocalAssum ([i1],t1) :: CompactedDecl.LocalAssum (li,t2) :: q
+ | NamedDecl.LocalDef (i1,c1,t1), CompactedDecl.LocalDef (li,c2,t2) :: q ->
+ if Constr.equal c1 c2 && Constr.equal t1 t2
+ then CompactedDecl.LocalDef (i1::li, c2, t2) :: q
+ else CompactedDecl.LocalDef ([i1],c1,t1) :: CompactedDecl.LocalDef (li,c2,t2) :: q
+ | NamedDecl.LocalAssum (i,t), q ->
+ CompactedDecl.LocalAssum ([i],t) :: q
+ | NamedDecl.LocalDef (i,c,t), q ->
+ CompactedDecl.LocalDef ([i],c,t) :: q
+ in
+ sign |> Context.Named.fold_inside compact ~init:[] |> List.rev
let clear_named_body id env =
let open NamedDecl in
diff --git a/engine/termops.mli b/engine/termops.mli
index 5d85088f8d..a7f45d28ae 100644
--- a/engine/termops.mli
+++ b/engine/termops.mli
@@ -238,8 +238,7 @@ val fold_named_context_both_sides :
('a -> Context.Named.Declaration.t -> Context.Named.Declaration.t list -> 'a) ->
Context.Named.t -> init:'a -> 'a
val mem_named_context : Id.t -> Context.Named.t -> bool
-val compact_named_context : Context.Named.t -> Context.NamedList.t
-val compact_named_context_reverse : Context.Named.t -> Context.NamedList.t
+val compact_named_context : Context.Named.t -> Context.Compacted.t
val clear_named_body : Id.t -> env -> env
generated by cgit v1.2.3 (git 2.25.1) at 2026-05-02 10:25:22 +0000