aboutsummaryrefslogtreecommitdiff
path: root/engine
diff options
context:
space:
mode:
Diffstat (limited to 'engine')
-rw-r--r--engine/evarutil.ml48
-rw-r--r--engine/evd.ml49
-rw-r--r--engine/logic_monad.ml2
-rw-r--r--engine/namegen.ml13
-rw-r--r--engine/proofview.ml10
-rw-r--r--engine/termops.ml32
-rw-r--r--engine/termops.mli3
-rw-r--r--engine/uState.ml8
8 files changed, 81 insertions, 84 deletions
diff --git a/engine/evarutil.ml b/engine/evarutil.ml
index e45e7dc496..50c5b354ef 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_info sigma evk =
try Some (Evd.find sigma evk)
with Not_found -> None
@@ -167,13 +170,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)
@@ -255,11 +256,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,[]))
@@ -331,21 +331,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
@@ -356,7 +353,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) ->
@@ -366,10 +363,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)
| _ ->
@@ -377,10 +371,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 =
@@ -560,8 +551,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 *)
@@ -600,10 +590,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
@@ -642,8 +631,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
@@ -697,9 +686,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 291c089784..69ca45444c 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
@@ -383,8 +386,7 @@ let add_name_newly_undefined naming evk evi (evtoid, idtoev as names) =
| Misctypes.IntroAnonymous -> None
| Misctypes.IntroIdentifier id ->
if Idmap.mem id idtoev then
- user_err_loc
- (Loc.ghost,"",str "Already an existential evar of name " ++ pr_id id);
+ user_err (str "Already an existential evar of name " ++ pr_id id);
Some id
| Misctypes.IntroFresh id ->
let id = Namegen.next_ident_away_from id (fun id -> Idmap.mem id idtoev) in
@@ -681,7 +683,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 +733,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 +1284,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 +1398,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/logic_monad.ml b/engine/logic_monad.ml
index 17ff898b0f..6e821ea5aa 100644
--- a/engine/logic_monad.ml
+++ b/engine/logic_monad.ml
@@ -34,7 +34,7 @@ exception Timeout
exception TacticFailure of exn
let _ = CErrors.register_handler begin function
- | Timeout -> CErrors.errorlabstrm "Some timeout function" (Pp.str"Timeout!")
+ | Timeout -> CErrors.user_err ~hdr:"Some timeout function" (Pp.str"Timeout!")
| Exception e -> CErrors.print e
| TacticFailure e -> CErrors.print e
| _ -> Pervasives.raise CErrors.Unhandled
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/proofview.ml b/engine/proofview.ml
index 85a52fdcaf..d7fb651264 100644
--- a/engine/proofview.ml
+++ b/engine/proofview.ml
@@ -365,7 +365,7 @@ let set_nosuchgoals_hook f = nosuchgoals_hook := f
let _ = CErrors.register_handler begin function
| NoSuchGoals n ->
let suffix = !nosuchgoals_hook n in
- CErrors.errorlabstrm ""
+ CErrors.user_err
(str "No such " ++ str (String.plural n "goal") ++ str "." ++
pr_non_empty_arg (fun x -> x) suffix)
| _ -> raise CErrors.Unhandled
@@ -451,7 +451,7 @@ let _ = CErrors.register_handler begin function
str"Incorrect number of goals" ++ spc() ++
str"(expected "++int i++str(String.plural i " tactic") ++ str")."
in
- CErrors.errorlabstrm "" errmsg
+ CErrors.user_err errmsg
| _ -> raise CErrors.Unhandled
end
@@ -863,11 +863,11 @@ let tclPROGRESS t =
if not test then
tclUNIT res
else
- tclZERO (CErrors.UserError ("Proofview.tclPROGRESS" , Pp.str"Failed to progress."))
+ tclZERO (CErrors.UserError (Some "Proofview.tclPROGRESS" , Pp.str"Failed to progress."))
exception Timeout
let _ = CErrors.register_handler begin function
- | Timeout -> CErrors.errorlabstrm "Proofview.tclTIMEOUT" (Pp.str"Tactic timeout!")
+ | Timeout -> CErrors.user_err ~hdr:"Proofview.tclTIMEOUT" (Pp.str"Tactic timeout!")
| _ -> Pervasives.raise CErrors.Unhandled
end
@@ -1074,7 +1074,7 @@ module Goal = struct
exception NotExactlyOneSubgoal
let _ = CErrors.register_handler begin function
| NotExactlyOneSubgoal ->
- CErrors.errorlabstrm "" (Pp.str"Not exactly one subgoal.")
+ CErrors.user_err (Pp.str"Not exactly one subgoal.")
| _ -> raise CErrors.Unhandled
end
diff --git a/engine/termops.ml b/engine/termops.ml
index 17e56ec31e..5e65652c01 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 *)
@@ -978,18 +979,27 @@ let fold_named_context_both_sides f l ~init = List.fold_right_and_left f l init
let mem_named_context_val id ctxt =
try Environ.lookup_named_val id ctxt; true with Not_found -> 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 0a7ac1f266..7d6e99accb 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_val : Id.t -> named_context_val -> 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
diff --git a/engine/uState.ml b/engine/uState.ml
index c35f97b2e9..c66af02bb9 100644
--- a/engine/uState.ml
+++ b/engine/uState.ml
@@ -255,8 +255,8 @@ let universe_context ?names ctx =
let l =
try UNameMap.find (Id.to_string id) (fst ctx.uctx_names)
with Not_found ->
- user_err_loc (loc, "universe_context",
- str"Universe " ++ Nameops.pr_id id ++ str" is not bound anymore.")
+ user_err ~loc ~hdr:"universe_context"
+ (str"Universe " ++ Nameops.pr_id id ++ str" is not bound anymore.")
in (l :: newinst, (id, l) :: map, Univ.LSet.remove l acc))
pl ([], [], levels)
in
@@ -269,8 +269,8 @@ let universe_context ?names ctx =
Option.default Loc.ghost info.uloc
with Not_found -> Loc.ghost
in
- user_err_loc (loc, "universe_context",
- (str(CString.plural n "Universe") ++ spc () ++
+ user_err ~loc ~hdr:"universe_context"
+ ((str(CString.plural n "Universe") ++ spc () ++
Univ.LSet.pr (pr_uctx_level ctx) left ++
spc () ++ str (CString.conjugate_verb_to_be n) ++
str" unbound."))
generated by cgit v1.2.3 (git 2.25.1) at 2026-04-30 20:14:35 +0000