aboutsummaryrefslogtreecommitdiff
path: root/pretyping
diff options
context:
space:
mode:
Diffstat (limited to 'pretyping')
-rw-r--r--pretyping/cases.ml51
-rw-r--r--pretyping/coercion.ml12
-rw-r--r--pretyping/detyping.ml5
-rw-r--r--pretyping/evarconv.ml18
-rw-r--r--pretyping/evardefine.ml18
-rw-r--r--pretyping/evarsolve.ml17
-rw-r--r--pretyping/glob_ops.ml198
-rw-r--r--pretyping/glob_ops.mli3
-rw-r--r--pretyping/indrec.ml22
-rw-r--r--pretyping/indrec.mli8
-rw-r--r--pretyping/inductiveops.ml2
-rw-r--r--pretyping/locusops.ml2
-rw-r--r--pretyping/nativenorm.ml4
-rw-r--r--pretyping/patternops.ml23
-rw-r--r--pretyping/pretyping.ml45
-rw-r--r--pretyping/program.ml17
-rw-r--r--pretyping/program.mli4
-rw-r--r--pretyping/reductionops.ml24
-rw-r--r--pretyping/reductionops.mli2
-rw-r--r--pretyping/retyping.ml2
-rw-r--r--pretyping/tacred.ml35
-rw-r--r--pretyping/typing.ml6
-rw-r--r--pretyping/unification.ml34
-rw-r--r--pretyping/unification.mli6
24 files changed, 267 insertions, 291 deletions
diff --git a/pretyping/cases.ml b/pretyping/cases.ml
index c2c8065a98..c3f392980a 100644
--- a/pretyping/cases.ml
+++ b/pretyping/cases.ml
@@ -32,7 +32,6 @@ open Evardefine
open Evarsolve
open Evarconv
open Evd
-open Sigma.Notations
open Context.Rel.Declaration
module RelDecl = Context.Rel.Declaration
@@ -70,7 +69,7 @@ let error_wrong_numarg_inductive ?loc env c n =
let list_try_compile f l =
let rec aux errors = function
- | [] -> if errors = [] then anomaly (str "try_find_f") else iraise (List.last errors)
+ | [] -> if errors = [] then anomaly (str "try_find_f.") else iraise (List.last errors)
| h::t ->
try f h
with UserError _ | TypeError _ | PretypeError _ | PatternMatchingError _ as e ->
@@ -162,9 +161,9 @@ let feed_history arg = function
| Continuation (n, l, h) when n>=1 ->
Continuation (n-1, arg :: l, h)
| Continuation (n, _, _) ->
- anomaly (str "Bad number of expected remaining patterns: " ++ int n)
+ anomaly (str "Bad number of expected remaining patterns: " ++ int n ++ str ".")
| Result _ ->
- anomaly (Pp.str "Exhausted pattern history")
+ anomaly (Pp.str "Exhausted pattern history.")
(* This is for non exhaustive error message *)
@@ -190,7 +189,7 @@ let pop_history_pattern = function
| Continuation (0, l, MakeConstructor (pci, rh)) ->
feed_history (CAst.make @@ PatCstr (pci,List.rev l,Anonymous)) rh
| _ ->
- anomaly (Pp.str "Constructor not yet filled with its arguments")
+ anomaly (Pp.str "Constructor not yet filled with its arguments.")
let pop_history h =
feed_history (CAst.make @@ PatVar Anonymous) h
@@ -425,7 +424,7 @@ let lift_tomatch_type n = liftn_tomatch_type n 1
let current_pattern eqn =
match eqn.patterns with
| pat::_ -> pat
- | [] -> anomaly (Pp.str "Empty list of patterns")
+ | [] -> anomaly (Pp.str "Empty list of patterns.")
let alias_of_pat = CAst.with_val (function
| PatVar name -> name
@@ -438,7 +437,7 @@ let remove_current_pattern eqn =
{ eqn with
patterns = pats;
alias_stack = alias_of_pat pat :: eqn.alias_stack }
- | [] -> anomaly (Pp.str "Empty list of patterns")
+ | [] -> anomaly (Pp.str "Empty list of patterns.")
let push_current_pattern (cur,ty) eqn =
match eqn.patterns with
@@ -447,7 +446,7 @@ let push_current_pattern (cur,ty) eqn =
{ eqn with
rhs = { eqn.rhs with rhs_env = rhs_env };
patterns = pats }
- | [] -> anomaly (Pp.str "Empty list of patterns")
+ | [] -> anomaly (Pp.str "Empty list of patterns.")
(* spiwack: like [push_current_pattern] but does not introduce an
alias in rhs_env. Aliasing binders are only useful for variables at
@@ -457,7 +456,7 @@ let push_noalias_current_pattern eqn =
match eqn.patterns with
| _::pats ->
{ eqn with patterns = pats }
- | [] -> anomaly (Pp.str "push_noalias_current_pattern: Empty list of patterns")
+ | [] -> anomaly (Pp.str "push_noalias_current_pattern: Empty list of patterns.")
@@ -641,7 +640,7 @@ let replace_tomatch sigma n c =
| Pushed (initial,((b,tm),l,na)) :: rest ->
let b = replace_term sigma n c depth b in
let tm = map_tomatch_type (replace_term sigma n c depth) tm in
- List.iter (fun i -> if Int.equal i (n + depth) then anomaly (Pp.str "replace_tomatch")) l;
+ List.iter (fun i -> if Int.equal i (n + depth) then anomaly (Pp.str "replace_tomatch.")) l;
Pushed (initial,((b,tm),l,na)) :: replrec depth rest
| Alias (initial,(na,b,d)) :: rest ->
(* [b] is out of replacement scope *)
@@ -731,7 +730,7 @@ let get_names env sigma sign eqns =
(fun (LocalAssum (na,t) | LocalDef (na,_,t)) -> Name (next_name_away (named_hd env sigma t na) avoid))
d na
in
- (na::l,(out_name na)::avoid))
+ (na::l,(Name.get_id na)::avoid))
([],allvars) (List.rev sign) names2 in
names3,aliasname
@@ -882,7 +881,7 @@ let specialize_predicate_var (cur,typ,dep) env tms ccl =
(*****************************************************************************)
let generalize_predicate sigma (names,na) ny d tms ccl =
let () = match na with
- | Anonymous -> anomaly (Pp.str "Undetected dependency")
+ | Anonymous -> anomaly (Pp.str "Undetected dependency.")
| _ -> () in
let p = List.length names + 1 in
let ccl = lift_predicate 1 ccl tms in
@@ -1708,7 +1707,7 @@ let build_tycon ?loc env tycon_env s subst tycon extenv evdref t =
evdref := evd;
(t,tt) in
let b = e_cumul env evdref tt (mkSort s) (* side effect *) in
- if not b then anomaly (Pp.str "Build_tycon: should be a type");
+ if not b then anomaly (Pp.str "Build_tycon: should be a type.");
{ uj_val = t; uj_type = tt }
(* For a multiple pattern-matching problem Xi on t1..tn with return
@@ -1872,7 +1871,7 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign =
if not (eq_ind ind ind') then
user_err ?loc (str "Wrong inductive type.");
if not (Int.equal nrealargs_ctxt (List.length realnal)) then
- anomaly (Pp.str "Ill-formed 'in' clause in cases");
+ anomaly (Pp.str "Ill-formed 'in' clause in cases.");
List.rev realnal
| None -> List.make nrealargs_ctxt Anonymous in
LocalAssum (na, EConstr.of_constr (build_dependent_inductive env0 indf'))
@@ -2000,10 +1999,8 @@ let prepare_predicate ?loc typing_fun env sigma tomatchs arsign tycon pred =
let sigma,t = match tycon with
| Some t -> refresh_tycon sigma t
| None ->
- let sigma = Sigma.Unsafe.of_evar_map sigma in
- let Sigma ((t, _), sigma, _) =
+ let (sigma, (t, _)) =
new_type_evar env sigma univ_flexible_alg ~src:(Loc.tag ?loc @@ Evar_kinds.CasesType false) in
- let sigma = Sigma.to_evar_map sigma in
sigma, t
in
(* First strategy: we build an "inversion" predicate *)
@@ -2064,8 +2061,8 @@ let mk_JMeq evdref typ x typ' y =
let mk_JMeq_refl evdref typ x =
papp evdref coq_JMeq_refl [| typ; x |]
-let hole = CAst.make @@
- GHole (Evar_kinds.QuestionMark (Evar_kinds.Define false),
+let hole na = CAst.make @@
+ GHole (Evar_kinds.QuestionMark (Evar_kinds.Define false,na),
Misctypes.IntroAnonymous, None)
let constr_of_pat env evdref arsign pat avoid =
@@ -2168,7 +2165,7 @@ let vars_of_ctx sigma ctx =
prev,
(CAst.make @@ GApp (
(CAst.make @@ GRef (delayed_force coq_eq_refl_ref, None)),
- [hole; CAst.make @@ GVar prev])) :: vars
+ [hole na; CAst.make @@ GVar prev])) :: vars
| _ ->
match RelDecl.get_name decl with
Anonymous -> invalid_arg "vars_of_ctx"
@@ -2223,14 +2220,14 @@ let build_ineqs evdref prevpatterns pats liftsign =
(Some ([], 0, 0, [])) eqnpats pats
in match acc with
None -> c
- | Some (sign, len, _, c') ->
- let conj = it_mkProd_or_LetIn (mk_coq_not (mk_coq_and c'))
- (lift_rel_context liftsign sign)
- in
- conj :: c)
+ | Some (sign, len, _, c') ->
+ let sigma, conj = mk_coq_and !evdref c' in
+ let sigma, neg = mk_coq_not sigma conj in
+ let conj = it_mkProd_or_LetIn neg (lift_rel_context liftsign sign) in
+ evdref := sigma; conj :: c)
[] prevpatterns
in match diffs with [] -> None
- | _ -> Some (mk_coq_and diffs)
+ | _ -> Some (let sigma, conj = mk_coq_and !evdref diffs in evdref := sigma; conj)
let constrs_of_pats typing_fun env evdref eqns tomatchs sign neqs arity =
let i = ref 0 in
@@ -2301,7 +2298,7 @@ let constrs_of_pats typing_fun env evdref eqns tomatchs sign neqs arity =
| l -> CAst.make @@ GApp (bref, l)
in
let branch = match ineqs with
- Some _ -> CAst.make @@ GApp (branch, [ hole ])
+ Some _ -> CAst.make @@ GApp (branch, [ hole Anonymous ])
| None -> branch
in
incr i;
diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml
index 3ef17912f7..1282e3cb86 100644
--- a/pretyping/coercion.ml
+++ b/pretyping/coercion.ml
@@ -67,7 +67,7 @@ let apply_coercion_args env evd check isproj argl funj =
if check && not (e_cumul env evdref (Retyping.get_type_of env !evdref h) c1) then
raise NoCoercion;
apply_rec (h::acc) (subst1 h c2) restl
- | _ -> anomaly (Pp.str "apply_coercion_args")
+ | _ -> anomaly (Pp.str "apply_coercion_args.")
in
let res = apply_rec [] funj.uj_type argl in
!evdref, res
@@ -90,8 +90,8 @@ let inh_pattern_coerce_to ?loc env pat ind1 ind2 =
open Program
-let make_existential ?loc ?(opaque = not (get_proofs_transparency ())) env evdref c =
- let src = Loc.tag ?loc (Evar_kinds.QuestionMark (Evar_kinds.Define opaque)) in
+let make_existential ?loc ?(opaque = not (get_proofs_transparency ())) na env evdref c =
+ let src = Loc.tag ?loc (Evar_kinds.QuestionMark (Evar_kinds.Define opaque,na)) in
Evarutil.e_new_evar env evdref ~src c
let app_opt env evdref f t =
@@ -181,7 +181,7 @@ and coerce ?loc env evdref (x : EConstr.constr) (y : EConstr.constr)
let args = List.rev (restargs @ mkRel 1 :: List.map (lift 1) tele) in
let pred = mkLambda (n, eqT, applist (lift 1 c, args)) in
let eq = papp evdref coq_eq_ind [| eqT; hdx; hdy |] in
- let evar = make_existential ?loc env evdref eq in
+ let evar = make_existential ?loc n env evdref eq in
let eq_app x = papp evdref coq_eq_rect
[| eqT; hdx; pred; x; hdy; evar|]
in
@@ -324,7 +324,7 @@ and coerce ?loc env evdref (x : EConstr.constr) (y : EConstr.constr)
Some
(fun x ->
let cx = app_opt env evdref c x in
- let evar = make_existential ?loc env evdref (mkApp (p, [| cx |]))
+ let evar = make_existential ?loc Anonymous env evdref (mkApp (p, [| cx |]))
in
(papp evdref sig_intro [| u; p; cx; evar |]))
| None ->
@@ -368,7 +368,7 @@ let apply_coercion env sigma p hj typ_cl =
(hj,typ_cl,sigma) p
in evd, j
with NoCoercion as e -> raise e
- | e when CErrors.noncritical e -> anomaly (Pp.str "apply_coercion")
+ | e when CErrors.noncritical e -> anomaly (Pp.str "apply_coercion.")
(* Try to coerce to a funclass; raise NoCoercion if not possible *)
let inh_app_fun_core env evd j =
diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml
index 752819aa39..c93b1e568c 100644
--- a/pretyping/detyping.ml
+++ b/pretyping/detyping.ml
@@ -425,7 +425,7 @@ type binder_kind = BProd | BLambda | BLetIn
(**********************************************************************)
(* Main detyping function *)
-let detype_anonymous = ref (fun ?loc n -> anomaly ~label:"detype" (Pp.str "index to an anonymous variable"))
+let detype_anonymous = ref (fun ?loc n -> anomaly ~label:"detype" (Pp.str "index to an anonymous variable."))
let set_detype_anonymous f = detype_anonymous := f
let detype_level sigma l =
@@ -907,8 +907,7 @@ let simple_cases_matrix_of_branches ind brs =
let nal,c = it_destRLambda_or_LetIn_names n b in
let mkPatVar na = CAst.make @@ PatVar na in
let p = CAst.make @@ PatCstr ((ind,i+1),List.map mkPatVar nal,Anonymous) in
- let map name = try Some (Nameops.out_name name) with Failure _ -> None in
- let ids = List.map_filter map nal in
+ let ids = List.map_filter Nameops.Name.to_option nal in
Loc.tag @@ (ids,[p],c))
brs
diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml
index bf62cea6b6..3757ba7e6d 100644
--- a/pretyping/evarconv.ml
+++ b/pretyping/evarconv.ml
@@ -23,7 +23,6 @@ open Evardefine
open Evarsolve
open Evd
open Pretype_errors
-open Sigma.Notations
open Context.Named.Declaration
module RelDecl = Context.Rel.Declaration
@@ -638,7 +637,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
(fun i ->
let b = nf_evar i b1 in
let t = nf_evar i t1 in
- let na = Nameops.name_max na1 na2 in
+ let na = Nameops.Name.pick na1 na2 in
evar_conv_x ts (push_rel (RelDecl.LocalDef (na,b,t)) env) i pbty c'1 c'2);
(fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)]
and f2 i =
@@ -755,7 +754,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
[(fun i -> evar_conv_x ts env i CONV c1 c2);
(fun i ->
let c = nf_evar i c1 in
- let na = Nameops.name_max na1 na2 in
+ let na = Nameops.Name.pick na1 na2 in
evar_conv_x ts (push_rel (RelDecl.LocalAssum (na,c)) env) i CONV c'1 c'2)]
| Flexible ev1, Rigid -> flex_rigid true ev1 appr1 appr2
@@ -816,7 +815,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
[(fun i -> evar_conv_x ts env i CONV c1 c2);
(fun i ->
let c = nf_evar i c1 in
- let na = Nameops.name_max n1 n2 in
+ let na = Nameops.Name.pick n1 n2 in
evar_conv_x ts (push_rel (RelDecl.LocalAssum (na,c)) env) i pbty c'1 c'2)]
| Rel x1, Rel x2 ->
@@ -913,9 +912,7 @@ and conv_record trs env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2)
(i,t2::ks, m-1, test)
else
let dloc = Loc.tag Evar_kinds.InternalHole in
- let i = Sigma.Unsafe.of_evar_map i in
- let Sigma (ev, i', _) = Evarutil.new_evar env i ~src:dloc (substl ks b) in
- let i' = Sigma.to_evar_map i' in
+ let (i', ev) = Evarutil.new_evar env i ~src:dloc (substl ks b) in
(i', ev :: ks, m - 1,test))
(evd,[],List.length bs,fun i -> Success i) bs
in
@@ -1088,7 +1085,7 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs =
let filter' = filter_possible_projections evd c ty ctxt args in
(id,t,c,ty,evs,Filter.make filter',occs) :: make_subst (ctxt',l,occsl)
| _, _, [] -> []
- | _ -> anomaly (Pp.str "Signature or instance are shorter than the occurrences list") in
+ | _ -> anomaly (Pp.str "Signature or instance are shorter than the occurrences list.") in
let rec set_holes evdref rhs = function
| (id,_,c,cty,evsref,filter,occs)::subst ->
@@ -1099,9 +1096,8 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs =
| None ->
let evty = set_holes evdref cty subst in
let instance = Filter.filter_list filter instance in
- let evd = Sigma.Unsafe.of_evar_map !evdref in
- let Sigma (ev, evd, _) = new_evar_instance sign evd evty ~filter instance in
- let evd = Sigma.to_evar_map evd in
+ let evd = !evdref in
+ let (evd, ev) = new_evar_instance sign evd evty ~filter instance in
evdref := evd;
evsref := (fst (destEvar !evdref ev),evty)::!evsref;
ev in
diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml
index a116198465..2d86daadb6 100644
--- a/pretyping/evardefine.ml
+++ b/pretyping/evardefine.ml
@@ -17,15 +17,9 @@ open Namegen
open Evd
open Evarutil
open Pretype_errors
-open Sigma.Notations
module RelDecl = Context.Rel.Declaration
-let new_evar_unsafe env evd ?src ?filter ?candidates ?store ?naming ?principal typ =
- let evd = Sigma.Unsafe.of_evar_map evd in
- let Sigma (evk, evd, _) = new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ in
- (Sigma.to_evar_map evd, evk)
-
let env_nf_evar sigma env =
let nf_evar c = nf_evar sigma c in
process_rel_context
@@ -82,9 +76,7 @@ let define_pure_evar_as_product evd evk =
let concl = Reductionops.whd_all evenv evd (EConstr.of_constr evi.evar_concl) in
let s = destSort evd concl in
let evd1,(dom,u1) =
- let evd = Sigma.Unsafe.of_evar_map evd in
- let Sigma (e, evd1, _) = new_type_evar evenv evd univ_flexible_alg ~filter:(evar_filter evi) in
- (Sigma.to_evar_map evd1, e)
+ new_type_evar evenv evd univ_flexible_alg ~filter:(evar_filter evi)
in
let evd2,rng =
let newenv = push_named (LocalAssum (id, dom)) evenv in
@@ -92,13 +84,11 @@ let define_pure_evar_as_product evd evk =
let filter = Filter.extend 1 (evar_filter evi) in
if is_prop_sort (ESorts.kind evd1 s) then
(* Impredicative product, conclusion must fall in [Prop]. *)
- new_evar_unsafe newenv evd1 concl ~src ~filter
+ new_evar newenv evd1 concl ~src ~filter
else
let status = univ_flexible_alg in
let evd3, (rng, srng) =
- let evd1 = Sigma.Unsafe.of_evar_map evd1 in
- let Sigma (e, evd3, _) = new_type_evar newenv evd1 status ~src ~filter in
- (Sigma.to_evar_map evd3, e)
+ new_type_evar newenv evd1 status ~src ~filter
in
let prods = Univ.sup (univ_of_sort u1) (univ_of_sort srng) in
let evd3 = Evd.set_leq_sort evenv evd3 (Type prods) (ESorts.kind evd1 s) in
@@ -143,7 +133,7 @@ let define_pure_evar_as_lambda env evd evk =
let newenv = push_named (LocalAssum (id, dom)) evenv in
let filter = Filter.extend 1 (evar_filter evi) in
let src = evar_source evk evd1 in
- let evd2,body = new_evar_unsafe newenv evd1 ~src (subst1 (mkVar id) rng) ~filter in
+ let evd2,body = new_evar newenv evd1 ~src (subst1 (mkVar id) rng) ~filter in
let lam = mkLambda (Name id, dom, subst_var id body) in
Evd.define evk (EConstr.Unsafe.to_constr lam) evd2, lam
diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml
index 98e71c7fd9..ff0aeff75d 100644
--- a/pretyping/evarsolve.ml
+++ b/pretyping/evarsolve.ml
@@ -20,7 +20,6 @@ open Retyping
open Reductionops
open Evarutil
open Pretype_errors
-open Sigma.Notations
let normalize_evar evd ev =
match EConstr.kind evd (mkEvar ev) with
@@ -203,9 +202,7 @@ let restrict_evar_key evd evk filter candidates =
let candidates = match candidates with
| NoUpdate -> Option.map (fun l -> List.map EConstr.of_constr l) evi.evar_candidates
| UpdateWith c -> Some c in
- let sigma = Sigma.Unsafe.of_evar_map evd in
- let Sigma (evk, sigma, _) = restrict_evar sigma evk filter candidates in
- (Sigma.to_evar_map sigma, evk)
+ restrict_evar evd evk filter candidates
end
(* Restrict an applied evar and returns its restriction in the same context *)
@@ -634,7 +631,7 @@ let make_projectable_subst aliases sigma evi args =
cstrs)
| _ ->
(rest,Id.Map.add id [a,normalize_alias_opt sigma aliases a,id] all,cstrs))
- | _ -> anomaly (Pp.str "Instance does not match its signature"))
+ | _ -> anomaly (Pp.str "Instance does not match its signature."))
sign (Array.rev_to_list args,Id.Map.empty,Constrmap.empty) in
(full_subst,cstr_subst)
@@ -649,9 +646,7 @@ let make_projectable_subst aliases sigma evi args =
*)
let define_evar_from_virtual_equation define_fun env evd src t_in_env ty_t_in_sign sign filter inst_in_env =
- let evd = Sigma.Unsafe.of_evar_map evd in
- let Sigma (evar_in_env, evd, _) = new_evar_instance sign evd ty_t_in_sign ~filter ~src inst_in_env in
- let evd = Sigma.to_evar_map evd in
+ let (evd, evar_in_env) = new_evar_instance sign evd ty_t_in_sign ~filter ~src inst_in_env in
let t_in_env = whd_evar evd t_in_env in
let (evk, _) = destEvar evd evar_in_env in
let evd = define_fun env evd None (destEvar evd evar_in_env) t_in_env in
@@ -721,10 +716,8 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env =
~status:univ_flexible (Some false) env evd (mkSort s) in
define_evar_from_virtual_equation define_fun env evd src ty_in_env
ty_t_in_sign sign2 filter2 inst2_in_env in
- let evd = Sigma.Unsafe.of_evar_map evd in
- let Sigma (ev2_in_sign, evd, _) =
+ let (evd, ev2_in_sign) =
new_evar_instance sign2 evd ev2ty_in_sign ~filter:filter2 ~src inst2_in_sign in
- let evd = Sigma.to_evar_map evd in
let ev2_in_env = (fst (destEvar evd ev2_in_sign), Array.of_list inst2_in_env) in
(evd, ev2_in_sign, ev2_in_env)
@@ -828,7 +821,7 @@ let rec find_projectable_vars with_evars aliases sigma y subst =
| _ -> subst'
end
| [] -> subst'
- | _ -> anomaly (Pp.str "More than one non var in aliases class of evar instance")
+ | _ -> anomaly (Pp.str "More than one non var in aliases class of evar instance.")
else
subst' in
Id.Map.fold is_projectable subst []
diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml
index 923d7d9388..e53d19b595 100644
--- a/pretyping/glob_ops.ml
+++ b/pretyping/glob_ops.ml
@@ -12,6 +12,7 @@ open Nameops
open Globnames
open Misctypes
open Glob_term
+open Evar_kinds
(* Untyped intermediate terms, after ASTs and before constr. *)
@@ -33,109 +34,108 @@ let map_glob_decl_left_to_right f (na,k,obd,ty) =
(na,k,comp1,comp2)
let binding_kind_eq bk1 bk2 = match bk1, bk2 with
-| Decl_kinds.Explicit, Decl_kinds.Explicit -> true
-| Decl_kinds.Implicit, Decl_kinds.Implicit -> true
-| _ -> false
+ | Decl_kinds.Explicit, Decl_kinds.Explicit -> true
+ | Decl_kinds.Implicit, Decl_kinds.Implicit -> true
+ | (Decl_kinds.Explicit | Decl_kinds.Implicit), _ -> false
let case_style_eq s1 s2 = match s1, s2 with
-| LetStyle, LetStyle -> true
-| IfStyle, IfStyle -> true
-| LetPatternStyle, LetPatternStyle -> true
-| MatchStyle, MatchStyle -> true
-| RegularStyle, RegularStyle -> true
-| _ -> false
+ | LetStyle, LetStyle -> true
+ | IfStyle, IfStyle -> true
+ | LetPatternStyle, LetPatternStyle -> true
+ | MatchStyle, MatchStyle -> true
+ | RegularStyle, RegularStyle -> true
+ | (LetStyle | IfStyle | LetPatternStyle | MatchStyle | RegularStyle), _ -> false
let rec cases_pattern_eq { CAst.v = p1} { CAst.v = p2 } = match p1, p2 with
-| PatVar na1, PatVar na2 -> Name.equal na1 na2
-| PatCstr (c1, pl1, na1), PatCstr (c2, pl2, na2) ->
- eq_constructor c1 c2 && List.equal cases_pattern_eq pl1 pl2 &&
- Name.equal na1 na2
-| _ -> false
+ | PatVar na1, PatVar na2 -> Name.equal na1 na2
+ | PatCstr (c1, pl1, na1), PatCstr (c2, pl2, na2) ->
+ eq_constructor c1 c2 && List.equal cases_pattern_eq pl1 pl2 &&
+ Name.equal na1 na2
+ | (PatVar _ | PatCstr _), _ -> false
let cast_type_eq eq t1 t2 = match t1, t2 with
-| CastConv t1, CastConv t2 -> eq t1 t2
-| CastVM t1, CastVM t2 -> eq t1 t2
-| CastCoerce, CastCoerce -> true
-| CastNative t1, CastNative t2 -> eq t1 t2
-| _ -> false
-
-let rec glob_constr_eq { CAst.v = c1 } { CAst.v = c2 } = match c1, c2 with
-| GRef (gr1, _), GRef (gr2, _) -> eq_gr gr1 gr2
-| GVar id1, GVar id2 -> Id.equal id1 id2
-| GEvar (id1, arg1), GEvar (id2, arg2) ->
- Id.equal id1 id2 &&
- List.equal instance_eq arg1 arg2
-| GPatVar (b1, pat1), GPatVar (b2, pat2) ->
- (b1 : bool) == b2 && Id.equal pat1 pat2
-| GApp (f1, arg1), GApp (f2, arg2) ->
- glob_constr_eq f1 f2 && List.equal glob_constr_eq arg1 arg2
-| GLambda (na1, bk1, t1, c1), GLambda (na2, bk2, t2, c2) ->
- Name.equal na1 na2 && binding_kind_eq bk1 bk2 &&
- glob_constr_eq t1 t2 && glob_constr_eq c1 c2
-| GProd (na1, bk1, t1, c1), GProd (na2, bk2, t2, c2) ->
- Name.equal na1 na2 && binding_kind_eq bk1 bk2 &&
- glob_constr_eq t1 t2 && glob_constr_eq c1 c2
-| GLetIn (na1, b1, t1, c1), GLetIn (na2, b2, t2, c2) ->
- Name.equal na1 na2 && glob_constr_eq b1 b2 && Option.equal glob_constr_eq t1 t2 && glob_constr_eq c1 c2
-| GCases (st1, c1, tp1, cl1), GCases (st2, c2, tp2, cl2) ->
- case_style_eq st1 st2 && Option.equal glob_constr_eq c1 c2 &&
- List.equal tomatch_tuple_eq tp1 tp2 &&
- List.equal cases_clause_eq cl1 cl2
-| GLetTuple (na1, (n1, p1), c1, t1), GLetTuple (na2, (n2, p2), c2, t2) ->
- List.equal Name.equal na1 na2 && Name.equal n1 n2 &&
- Option.equal glob_constr_eq p1 p2 && glob_constr_eq c1 c2 &&
- glob_constr_eq t1 t2
-| GIf (m1, (pat1, p1), c1, t1), GIf (m2, (pat2, p2), c2, t2) ->
- glob_constr_eq m1 m2 && Name.equal pat1 pat2 &&
- Option.equal glob_constr_eq p1 p2 && glob_constr_eq c1 c2 &&
- glob_constr_eq t1 t2
-| GRec (kn1, id1, decl1, c1, t1), GRec (kn2, id2, decl2, c2, t2) ->
- fix_kind_eq kn1 kn2 && Array.equal Id.equal id1 id2 &&
- Array.equal (fun l1 l2 -> List.equal glob_decl_eq l1 l2) decl1 decl2 &&
- Array.equal glob_constr_eq c1 c2 &&
- Array.equal glob_constr_eq t1 t2
-| GSort s1, GSort s2 -> Miscops.glob_sort_eq s1 s2
-| GHole (kn1, nam1, gn1), GHole (kn2, nam2, gn2) ->
- Option.equal (==) gn1 gn2 (** Only thing sensible *) &&
- Miscops.intro_pattern_naming_eq nam1 nam2
-| GCast (c1, t1), GCast (c2, t2) ->
- glob_constr_eq c1 c2 && cast_type_eq glob_constr_eq t1 t2
-| _ -> false
-
-and tomatch_tuple_eq (c1, p1) (c2, p2) =
+ | CastConv t1, CastConv t2 -> eq t1 t2
+ | CastVM t1, CastVM t2 -> eq t1 t2
+ | CastCoerce, CastCoerce -> true
+ | CastNative t1, CastNative t2 -> eq t1 t2
+ | (CastConv _ | CastVM _ | CastCoerce | CastNative _), _ -> false
+
+let matching_var_kind_eq k1 k2 = match k1, k2 with
+| FirstOrderPatVar ido1, FirstOrderPatVar ido2 -> Id.equal ido1 ido2
+| SecondOrderPatVar id1, SecondOrderPatVar id2 -> Id.equal id1 id2
+| (FirstOrderPatVar _ | SecondOrderPatVar _), _ -> false
+
+let tomatch_tuple_eq f (c1, p1) (c2, p2) =
let eqp (_, (i1, na1)) (_, (i2, na2)) =
eq_ind i1 i2 && List.equal Name.equal na1 na2
in
let eq_pred (n1, o1) (n2, o2) = Name.equal n1 n2 && Option.equal eqp o1 o2 in
- glob_constr_eq c1 c2 && eq_pred p1 p2
+ f c1 c2 && eq_pred p1 p2
-and cases_clause_eq (_, (id1, p1, c1)) (_, (id2, p2, c2)) =
- List.equal Id.equal id1 id2 && List.equal cases_pattern_eq p1 p2 &&
- glob_constr_eq c1 c2
+and cases_clause_eq f (_, (id1, p1, c1)) (_, (id2, p2, c2)) =
+ List.equal Id.equal id1 id2 && List.equal cases_pattern_eq p1 p2 && f c1 c2
-and glob_decl_eq (na1, bk1, c1, t1) (na2, bk2, c2, t2) =
+let glob_decl_eq f (na1, bk1, c1, t1) (na2, bk2, c2, t2) =
Name.equal na1 na2 && binding_kind_eq bk1 bk2 &&
- Option.equal glob_constr_eq c1 c2 &&
- glob_constr_eq t1 t2
-
-and fix_kind_eq k1 k2 = match k1, k2 with
-| GFix (a1, i1), GFix (a2, i2) ->
- let eq (i1, o1) (i2, o2) =
- Option.equal Int.equal i1 i2 && fix_recursion_order_eq o1 o2
- in
- Int.equal i1 i2 && Array.equal eq a1 a1
-| GCoFix i1, GCoFix i2 -> Int.equal i1 i2
-| _ -> false
-
-and fix_recursion_order_eq o1 o2 = match o1, o2 with
-| GStructRec, GStructRec -> true
-| GWfRec c1, GWfRec c2 -> glob_constr_eq c1 c2
-| GMeasureRec (c1, o1), GMeasureRec (c2, o2) ->
- glob_constr_eq c1 c2 && Option.equal glob_constr_eq o1 o2
-| _ -> false
-
-and instance_eq (x1,c1) (x2,c2) =
- Id.equal x1 x2 && glob_constr_eq c1 c2
+ Option.equal f c1 c2 && f t1 t2
+
+let fix_recursion_order_eq f o1 o2 = match o1, o2 with
+ | GStructRec, GStructRec -> true
+ | GWfRec c1, GWfRec c2 -> f c1 c2
+ | GMeasureRec (c1, o1), GMeasureRec (c2, o2) ->
+ f c1 c2 && Option.equal f o1 o2
+ | (GStructRec | GWfRec _ | GMeasureRec _), _ -> false
+
+let fix_kind_eq f k1 k2 = match k1, k2 with
+ | GFix (a1, i1), GFix (a2, i2) ->
+ let eq (i1, o1) (i2, o2) =
+ Option.equal Int.equal i1 i2 && fix_recursion_order_eq f o1 o2
+ in
+ Int.equal i1 i2 && Array.equal eq a1 a1
+ | GCoFix i1, GCoFix i2 -> Int.equal i1 i2
+ | (GFix _ | GCoFix _), _ -> false
+
+let instance_eq f (x1,c1) (x2,c2) =
+ Id.equal x1 x2 && f c1 c2
+
+let mk_glob_constr_eq f { CAst.v = c1 } { CAst.v = c2 } = match c1, c2 with
+ | GRef (gr1, _), GRef (gr2, _) -> eq_gr gr1 gr2
+ | GVar id1, GVar id2 -> Id.equal id1 id2
+ | GEvar (id1, arg1), GEvar (id2, arg2) ->
+ Id.equal id1 id2 && List.equal (instance_eq f) arg1 arg2
+ | GPatVar k1, GPatVar k2 -> matching_var_kind_eq k1 k2
+ | GApp (f1, arg1), GApp (f2, arg2) ->
+ f f1 f2 && List.equal f arg1 arg2
+ | GLambda (na1, bk1, t1, c1), GLambda (na2, bk2, t2, c2) ->
+ Name.equal na1 na2 && binding_kind_eq bk1 bk2 && f t1 t2 && f c1 c2
+ | GProd (na1, bk1, t1, c1), GProd (na2, bk2, t2, c2) ->
+ Name.equal na1 na2 && binding_kind_eq bk1 bk2 && f t1 t2 && f c1 c2
+ | GLetIn (na1, b1, t1, c1), GLetIn (na2, b2, t2, c2) ->
+ Name.equal na1 na2 && f b1 b2 && Option.equal f t1 t2 && f c1 c2
+ | GCases (st1, c1, tp1, cl1), GCases (st2, c2, tp2, cl2) ->
+ case_style_eq st1 st2 && Option.equal f c1 c2 &&
+ List.equal (tomatch_tuple_eq f) tp1 tp2 &&
+ List.equal (cases_clause_eq f) cl1 cl2
+ | GLetTuple (na1, (n1, p1), c1, t1), GLetTuple (na2, (n2, p2), c2, t2) ->
+ List.equal Name.equal na1 na2 && Name.equal n1 n2 &&
+ Option.equal f p1 p2 && f c1 c2 && f t1 t2
+ | GIf (m1, (pat1, p1), c1, t1), GIf (m2, (pat2, p2), c2, t2) ->
+ f m1 m2 && Name.equal pat1 pat2 &&
+ Option.equal f p1 p2 && f c1 c2 && f t1 t2
+ | GRec (kn1, id1, decl1, c1, t1), GRec (kn2, id2, decl2, c2, t2) ->
+ fix_kind_eq f kn1 kn2 && Array.equal Id.equal id1 id2 &&
+ Array.equal (fun l1 l2 -> List.equal (glob_decl_eq f) l1 l2) decl1 decl2 &&
+ Array.equal f c1 c2 && Array.equal f t1 t2
+ | GSort s1, GSort s2 -> Miscops.glob_sort_eq s1 s2
+ | GHole (kn1, nam1, gn1), GHole (kn2, nam2, gn2) ->
+ Option.equal (==) gn1 gn2 (** Only thing sensible *) &&
+ Miscops.intro_pattern_naming_eq nam1 nam2
+ | GCast (c1, t1), GCast (c2, t2) ->
+ f c1 c2 && cast_type_eq f t1 t2
+ | (GRef _ | GVar _ | GEvar _ | GPatVar _ | GApp _ | GLambda _ | GProd _ | GLetIn _ |
+ GCases _ | GLetTuple _ | GIf _ | GRec _ | GSort _ | GHole _ | GCast _), _ -> false
+
+let rec glob_constr_eq c = mk_glob_constr_eq glob_constr_eq c
let map_glob_constr_left_to_right f = CAst.map (function
| GApp (g,args) ->
@@ -215,20 +215,20 @@ let fold_glob_constr f acc = CAst.with_val (function
)
let fold_return_type_with_binders f g v acc (na,tyopt) =
- Option.fold_left (f (name_fold g na v)) acc tyopt
+ Option.fold_left (f (Name.fold_right g na v)) acc tyopt
let fold_glob_constr_with_binders g f v acc = CAst.(with_val (function
| GVar _ -> acc
| GApp (c,args) -> List.fold_left (f v) (f v acc c) args
| GLambda (na,_,b,c) | GProd (na,_,b,c) ->
- f (name_fold g na v) (f v acc b) c
+ f (Name.fold_right g na v) (f v acc b) c
| GLetIn (na,b,t,c) ->
- f (name_fold g na v) (Option.fold_left (f v) (f v acc b) t) c
+ f (Name.fold_right g na v) (Option.fold_left (f v) (f v acc b) t) c
| GCases (_,rtntypopt,tml,pl) ->
let fold_pattern acc (_,(idl,p,c)) = f (List.fold_right g idl v) acc c in
let fold_tomatch (v',acc) (tm,(na,onal)) =
- (Option.fold_left (fun v'' (_,(_,nal)) -> List.fold_right (name_fold g) nal v'')
- (name_fold g na v') onal,
+ (Option.fold_left (fun v'' (_,(_,nal)) -> List.fold_right (Name.fold_right g) nal v'')
+ (Name.fold_right g na v') onal,
f v acc tm) in
let (v',acc) = List.fold_left fold_tomatch (v,acc) tml in
let acc = Option.fold_left (f v') acc rtntypopt in
@@ -242,7 +242,7 @@ let fold_glob_constr_with_binders g f v acc = CAst.(with_val (function
let v,acc =
List.fold_left
(fun (v,acc) (na,k,bbd,bty) ->
- (name_fold g na v, f v (Option.fold_left (f v) acc bbd) bty))
+ (Name.fold_right g na v, f v (Option.fold_left (f v) acc bbd) bty))
(v,acc)
bll.(i) in
f (Array.fold_right g idl v) (f v acc tyl.(i)) (bv.(i)) in
@@ -371,12 +371,12 @@ let loc_of_glob_constr c = c.CAst.loc
let collide_id l id = List.exists (fun (id',id'') -> Id.equal id id' || Id.equal id id'') l
let test_id l id = if collide_id l id then raise Not_found
-let test_na l na = name_iter (test_id l) na
+let test_na l na = Name.iter (test_id l) na
let update_subst na l =
let in_range id l = List.exists (fun (_,id') -> Id.equal id id') l in
- let l' = name_fold Id.List.remove_assoc na l in
- name_fold
+ let l' = Name.fold_right Id.List.remove_assoc na l in
+ Name.fold_right
(fun id _ ->
if in_range id l' then
let id' = Namegen.next_ident_away_from id (fun id' -> in_range id' l') in
diff --git a/pretyping/glob_ops.mli b/pretyping/glob_ops.mli
index aa48516aff..f7cc08ca21 100644
--- a/pretyping/glob_ops.mli
+++ b/pretyping/glob_ops.mli
@@ -36,6 +36,9 @@ val map_glob_constr_left_to_right :
val warn_variable_collision : ?loc:Loc.t -> Id.t -> unit
+val mk_glob_constr_eq : (glob_constr -> glob_constr -> bool) ->
+ glob_constr -> glob_constr -> bool
+
val fold_glob_constr : ('a -> glob_constr -> 'a) -> 'a -> glob_constr -> 'a
val fold_glob_constr_with_binders : (Id.t -> 'a -> 'a) -> ('a -> 'b -> glob_constr -> 'b) -> 'a -> 'b -> glob_constr -> 'b
val iter_glob_constr : (glob_constr -> unit) -> glob_constr -> unit
diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml
index c4a74d990b..97aec1814f 100644
--- a/pretyping/indrec.ml
+++ b/pretyping/indrec.ml
@@ -27,7 +27,6 @@ open Inductiveops
open Environ
open Reductionops
open Nametab
-open Sigma.Notations
open Context.Rel.Declaration
type dep_flag = bool
@@ -130,19 +129,19 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind =
it_mkLambda_or_LetIn_name env' obj deparsign
else
let cs = lift_constructor (k+1) constrs.(k) in
- let t = build_branch_type env (Sigma.to_evar_map sigma) dep (mkRel (k+1)) cs in
+ let t = build_branch_type env sigma dep (mkRel (k+1)) cs in
mkLambda_string "f" t
(add_branch (push_rel (LocalAssum (Anonymous, t)) env) (k+1))
in
- let Sigma (s, sigma, p) = Sigma.fresh_sort_in_family ~rigid:Evd.univ_flexible_alg env sigma kind in
- let typP = make_arity env' (Sigma.to_evar_map sigma) dep indf s in
+ let (sigma, s) = Evd.fresh_sort_in_family ~rigid:Evd.univ_flexible_alg env sigma kind in
+ let typP = make_arity env' sigma dep indf s in
let typP = EConstr.Unsafe.to_constr typP in
let c =
it_mkLambda_or_LetIn_name env
(mkLambda_string "P" typP
(add_branch (push_rel (LocalAssum (Anonymous,typP)) env') 0)) lnamespar
in
- Sigma (c, sigma, p)
+ (sigma, c)
(* check if the type depends recursively on one of the inductive scheme *)
@@ -296,7 +295,7 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs =
process_constr (push_rel d env) (i+1) (lift 1 f)
(cprest,rest))
| [],[] -> f
- | _,[] | [],_ -> anomaly (Pp.str "process_constr")
+ | _,[] | [],_ -> anomaly (Pp.str "process_constr.")
in
process_constr env 0 f (List.rev cstr.cs_args, recargs)
@@ -475,10 +474,9 @@ let mis_make_indrec env sigma listdepkind mib u =
it_mkLambda_or_LetIn_name env (put_arity env' 0 listdepkind)
lnamesparrec
else
- let sigma = Sigma.Unsafe.of_evar_map !evdref in
- let Sigma (c, sigma, _) = mis_make_case_com dep env sigma (indi,u) (mibi,mipi) kind in
- let evd' = Sigma.to_evar_map sigma in
- evdref := evd'; c
+ let evd = !evdref in
+ let (evd, c) = mis_make_case_com dep env evd (indi,u) (mibi,mipi) kind in
+ evdref := evd; c
in
(* Body of mis_make_indrec *)
!evdref, List.init nrec make_one_rec
@@ -533,7 +531,7 @@ let weaken_sort_scheme env evd set sort npars term ty =
mkProd (n, t, c'), mkLambda (n, t, term')
| LetIn (n,b,t,c) -> let c',term' = drec np c in
mkLetIn (n,b,t,c'), mkLetIn (n,b,t,term')
- | _ -> anomaly ~label:"weaken_sort_scheme" (Pp.str "wrong elimination type")
+ | _ -> anomaly ~label:"weaken_sort_scheme" (Pp.str "wrong elimination type.")
in
let ty, term = drec npars ty in
!evdref, ty, term
@@ -577,7 +575,7 @@ let build_mutual_induction_scheme env sigma = function
in
let _ = check_arities env listdepkind in
mis_make_indrec env sigma listdepkind mib u
- | _ -> anomaly (Pp.str "build_induction_scheme expects a non empty list of inductive types")
+ | _ -> anomaly (Pp.str "build_induction_scheme expects a non empty list of inductive types.")
let build_induction_scheme env sigma pind dep kind =
let (mib,mip) = lookup_mind_specif env (fst pind) in
diff --git a/pretyping/indrec.mli b/pretyping/indrec.mli
index 192b64a5ed..a22470ae8c 100644
--- a/pretyping/indrec.mli
+++ b/pretyping/indrec.mli
@@ -26,14 +26,14 @@ type dep_flag = bool
(** Build a case analysis elimination scheme in some sort family *)
-val build_case_analysis_scheme : env -> 'r Sigma.t -> pinductive ->
- dep_flag -> sorts_family -> (constr, 'r) Sigma.sigma
+val build_case_analysis_scheme : env -> Evd.evar_map -> pinductive ->
+ dep_flag -> sorts_family -> evar_map * Constr.t
(** Build a dependent case elimination predicate unless type is in Prop
or is a recursive record with primitive projections. *)
-val build_case_analysis_scheme_default : env -> 'r Sigma.t -> pinductive ->
- sorts_family -> (constr, 'r) Sigma.sigma
+val build_case_analysis_scheme_default : env -> evar_map -> pinductive ->
+ sorts_family -> evar_map * Constr.t
(** Builds a recursive induction scheme (Peano-induction style) in the same
sort family as the inductive family; it is dependent if not in Prop
diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml
index 7f3bafc685..d8252ea9bb 100644
--- a/pretyping/inductiveops.ml
+++ b/pretyping/inductiveops.ml
@@ -538,7 +538,7 @@ let is_predicate_explicitly_dep env sigma pred arsign =
| Name _ -> true
end
- | _ -> anomaly (Pp.str "Non eta-expanded dep-expanded \"match\" predicate")
+ | _ -> anomaly (Pp.str "Non eta-expanded dep-expanded \"match\" predicate.")
in
srec env (EConstr.of_constr pred) arsign
diff --git a/pretyping/locusops.ml b/pretyping/locusops.ml
index 211ffbe01e..e555742bca 100644
--- a/pretyping/locusops.ml
+++ b/pretyping/locusops.ml
@@ -84,7 +84,7 @@ let concrete_clause_of enum_hyps cl =
(** Miscellaneous functions *)
let out_arg = function
- | Misctypes.ArgVar _ -> CErrors.anomaly (Pp.str "Unevaluated or_var variable")
+ | Misctypes.ArgVar _ -> CErrors.anomaly (Pp.str "Unevaluated or_var variable.")
| Misctypes.ArgArg x -> x
let occurrences_of_hyp id cls =
diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml
index afaa20b6f6..61118cf777 100644
--- a/pretyping/nativenorm.ml
+++ b/pretyping/nativenorm.ml
@@ -139,7 +139,7 @@ let type_of_var env id =
let open Context.Named.Declaration in
try env |> lookup_named id |> get_type
with Not_found ->
- anomaly ~label:"type_of_var" (str "variable " ++ Id.print id ++ str " unbound")
+ anomaly ~label:"type_of_var" (str "variable " ++ Id.print id ++ str " unbound.")
let sort_of_product env domsort rangsort =
match (domsort, rangsort) with
@@ -405,7 +405,7 @@ let native_norm env sigma c ty =
let time_info = Format.sprintf "Reification done in %.5f@." (t2 -. t1) in
if !Flags.debug then Feedback.msg_debug (Pp.str time_info);
EConstr.of_constr res
- | _ -> anomaly (Pp.str "Compilation failure")
+ | _ -> anomaly (Pp.str "Compilation failure.")
let native_conv_generic pb sigma t =
Nativeconv.native_conv_gen pb (evars_of_evar_map sigma) t
diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml
index 1c8ad0cddd..db2e5da957 100644
--- a/pretyping/patternops.ml
+++ b/pretyping/patternops.ml
@@ -112,14 +112,14 @@ let rec head_pattern_bound t =
-> raise BoundPattern
(* Perhaps they were arguments, but we don't beta-reduce *)
| PLambda _ -> raise BoundPattern
- | PCoFix _ -> anomaly ~label:"head_pattern_bound" (Pp.str "not a type")
+ | PCoFix _ -> anomaly ~label:"head_pattern_bound" (Pp.str "not a type.")
let head_of_constr_reference sigma c = match EConstr.kind sigma c with
| Const (sp,_) -> ConstRef sp
| Construct (sp,_) -> ConstructRef sp
| Ind (sp,_) -> IndRef sp
| Var id -> VarRef id
- | _ -> anomaly (Pp.str "Not a rigid reference")
+ | _ -> anomaly (Pp.str "Not a rigid reference.")
let pattern_of_constr env sigma t =
let rec pattern_of_constr env t =
@@ -143,7 +143,7 @@ let pattern_of_constr env sigma t =
match kind_of_term f with
| Evar (evk,args) ->
(match snd (Evd.evar_source evk sigma) with
- Evar_kinds.MatchingVar (true,id) -> Some id
+ Evar_kinds.MatchingVar (Evar_kinds.SecondOrderPatVar id) -> Some id
| _ -> None)
| _ -> None
with
@@ -156,13 +156,14 @@ let pattern_of_constr env sigma t =
pattern_of_constr env (EConstr.Unsafe.to_constr (Retyping.expand_projection env sigma p (EConstr.of_constr c) []))
| Evar (evk,ctxt as ev) ->
(match snd (Evd.evar_source evk sigma) with
- | Evar_kinds.MatchingVar (b,id) ->
- assert (not b); PMeta (Some id)
+ | Evar_kinds.MatchingVar (Evar_kinds.FirstOrderPatVar id) ->
+ PMeta (Some id)
| Evar_kinds.GoalEvar | Evar_kinds.VarInstance _ ->
(* These are the two evar kinds used for existing goals *)
(* see Proofview.mark_in_evm *)
if Evd.is_defined sigma evk then pattern_of_constr env (Evd.existential_value sigma ev)
else PEvar (evk,Array.map (pattern_of_constr env) ctxt)
+ | Evar_kinds.MatchingVar (Evar_kinds.SecondOrderPatVar ido) -> assert false
| _ ->
PMeta None)
| Case (ci,p,a,br) ->
@@ -329,26 +330,26 @@ let rec pat_of_raw metas vars = CAst.with_loc_val (fun ?loc -> function
| GVar id ->
(try PRel (List.index Name.equal (Name id) vars)
with Not_found -> PVar id)
- | GPatVar (false,n) ->
+ | GPatVar (Evar_kinds.FirstOrderPatVar n) ->
metas := n::!metas; PMeta (Some n)
| GRef (gr,_) ->
PRef (canonical_gr gr)
(* Hack to avoid rewriting a complete interpretation of patterns *)
- | GApp ({ CAst.v = GPatVar (true,n) }, cl) ->
+ | GApp ({ CAst.v = GPatVar (Evar_kinds.SecondOrderPatVar n) }, cl) ->
metas := n::!metas; PSoApp (n, List.map (pat_of_raw metas vars) cl)
| GApp (c,cl) ->
PApp (pat_of_raw metas vars c,
Array.of_list (List.map (pat_of_raw metas vars) cl))
| GLambda (na,bk,c1,c2) ->
- name_iter (fun n -> metas := n::!metas) na;
+ Name.iter (fun n -> metas := n::!metas) na;
PLambda (na, pat_of_raw metas vars c1,
pat_of_raw metas (na::vars) c2)
| GProd (na,bk,c1,c2) ->
- name_iter (fun n -> metas := n::!metas) na;
+ Name.iter (fun n -> metas := n::!metas) na;
PProd (na, pat_of_raw metas vars c1,
pat_of_raw metas (na::vars) c2)
| GLetIn (na,c1,t,c2) ->
- name_iter (fun n -> metas := n::!metas) na;
+ Name.iter (fun n -> metas := n::!metas) na;
PLetIn (na, pat_of_raw metas vars c1,
Option.map (pat_of_raw metas vars) t,
pat_of_raw metas (na::vars) c2)
@@ -411,7 +412,7 @@ let rec pat_of_raw metas vars = CAst.with_loc_val (fun ?loc -> function
and pats_of_glob_branches loc metas vars ind brs =
let get_arg = function
| { CAst.v = PatVar na } ->
- name_iter (fun n -> metas := n::!metas) na;
+ Name.iter (fun n -> metas := n::!metas) na;
na
| { CAst.v = PatCstr(_,_,_) ; loc } -> err ?loc (Pp.str "Non supported pattern.")
in
diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index e72394fa28..92e728683d 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.ml
@@ -44,8 +44,6 @@ open Glob_ops
open Evarconv
open Pattern
open Misctypes
-open Tactypes
-open Sigma.Notations
module NamedDecl = Context.Named.Declaration
@@ -111,9 +109,9 @@ let e_new_evar env evdref ?src ?naming typ =
let typ' = subst2 subst vsubst typ in
let instance = inst_rels @ inst_vars in
let sign = val_of_named_context nc in
- let sigma = Sigma.Unsafe.of_evar_map !evdref in
- let Sigma (e, sigma, _) = new_evar_instance sign sigma typ' ?src ?naming instance in
- evdref := Sigma.to_evar_map sigma;
+ let sigma = !evdref in
+ let (sigma, e) = new_evar_instance sign sigma typ' ?src ?naming instance in
+ evdref := sigma;
e
let push_rec_types sigma (lna,typarray,_) env =
@@ -199,7 +197,7 @@ let interp_universe_level_name ~anon_rigidity evd (loc, s) =
let names, _ = Global.global_universe_names () in
if CString.string_contains ~where:s ~what:"." then
match List.rev (CString.split '.' s) with
- | [] -> anomaly (str"Invalid universe name " ++ str s)
+ | [] -> anomaly (str"Invalid universe name " ++ str s ++ str".")
| n :: dp ->
let num = int_of_string n in
let dp = DirPath.make (List.map Id.of_string dp) in
@@ -383,6 +381,20 @@ let process_inference_flags flags env initial_sigma (sigma,c) =
let c = if flags.expand_evars then nf_evar sigma c else c in
sigma,c
+let adjust_evar_source evdref na c =
+ match na, kind !evdref c with
+ | Name id, Evar (evk,args) ->
+ let evi = Evd.find !evdref evk in
+ begin match evi.evar_source with
+ | loc, Evar_kinds.QuestionMark (b,Anonymous) ->
+ let src = (loc,Evar_kinds.QuestionMark (b,na)) in
+ let (evd, evk') = restrict_evar !evdref evk (evar_filter evi) ~src None in
+ evdref := evd;
+ mkEvar (evk',args)
+ | _ -> c
+ end
+ | _, _ -> c
+
(* Allow references to syntactically nonexistent variables (i.e., if applied on an inductive) *)
let allow_anonymous_refs = ref false
@@ -556,12 +568,12 @@ let pretype_sort ?loc evdref = function
| GType s -> evd_comb1 (judge_of_Type ?loc) evdref s
let new_type_evar env evdref loc =
- let sigma = Sigma.Unsafe.of_evar_map !evdref in
- let Sigma ((e, _), sigma, _) =
+ let sigma = !evdref in
+ let (sigma, (e, _)) =
Evarutil.new_type_evar env.ExtraEnv.env sigma
univ_flexible_alg ~src:(loc,Evar_kinds.InternalHole)
in
- evdref := Sigma.to_evar_map sigma;
+ evdref := sigma;
e
module ConstrInterpObj =
@@ -610,13 +622,13 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre
let j = (Retyping.get_judgment_of env.ExtraEnv.env !evdref c) in
inh_conv_coerce_to_tycon ?loc env evdref j tycon
- | GPatVar (someta,n) ->
+ | GPatVar kind ->
let env = ltac_interp_name_env k0 lvar env !evdref in
let ty =
match tycon with
| Some ty -> ty
| None -> new_type_evar env evdref loc in
- let k = Evar_kinds.MatchingVar (someta,n) in
+ let k = Evar_kinds.MatchingVar kind in
{ uj_val = e_new_evar env evdref ~src:(loc,k) ty; uj_type = ty }
| GHole (k, naming, None) ->
@@ -785,6 +797,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre
args, nf_evar !evdref (j_val hj)
else [], j_val hj
in
+ let ujval = adjust_evar_source evdref na ujval in
let value, typ = app_f n (j_val resj) ujval, subst1 ujval c2 in
let j = { uj_val = value; uj_type = typ } in
apply_rec env (n+1) j candargs rest
@@ -1133,7 +1146,7 @@ and pretype_type k0 resolve_tc valcon (env : ExtraEnv.t) evdref lvar = function
| Sort s -> ESorts.kind sigma s
| Evar ev when is_Type (existential_type sigma ev) ->
evd_comb1 (define_evar_as_sort env.ExtraEnv.env) evdref ev
- | _ -> anomaly (Pp.str "Found a type constraint which is not a type")
+ | _ -> anomaly (Pp.str "Found a type constraint which is not a type.")
in
{ utj_val = v;
utj_type = s }
@@ -1251,7 +1264,7 @@ let constr_flags = {
(* Fully evaluate an untyped constr *)
let type_uconstr ?(flags = constr_flags)
?(expected_type = WithoutTypeConstraint) ist c =
- { delayed = begin fun env sigma ->
+ begin fun env sigma ->
let { closure; term } = c in
let vars = {
ltac_constrs = closure.typed;
@@ -1259,10 +1272,8 @@ let type_uconstr ?(flags = constr_flags)
ltac_idents = closure.idents;
ltac_genargs = Id.Map.empty;
} in
- let sigma = Sigma.to_evar_map sigma in
- let (sigma, c) = understand_ltac flags env sigma vars expected_type term in
- Sigma.Unsafe.of_pair (c, sigma)
- end }
+ understand_ltac flags env sigma vars expected_type term
+ end
let pretype k0 resolve_tc typcon env evdref lvar t =
pretype k0 resolve_tc typcon (make_env env !evdref) evdref lvar t
diff --git a/pretyping/program.ml b/pretyping/program.ml
index 8769c5659e..f9be82024a 100644
--- a/pretyping/program.ml
+++ b/pretyping/program.ml
@@ -9,7 +9,6 @@
open CErrors
open Util
-let init_constant dir s () = Universes.constr_of_global @@ Coqlib.coq_reference "Program" dir s
let init_reference dir s () = Coqlib.coq_reference "Program" dir s
let papp evdref r args =
@@ -39,20 +38,20 @@ let coq_eq_rect = init_reference ["Init"; "Logic"] "eq_rect"
let coq_JMeq_ind = init_reference ["Logic";"JMeq"] "JMeq"
let coq_JMeq_refl = init_reference ["Logic";"JMeq"] "JMeq_refl"
-let coq_not = init_constant ["Init";"Logic"] "not"
-let coq_and = init_constant ["Init";"Logic"] "and"
+let coq_not = init_reference ["Init";"Logic"] "not"
+let coq_and = init_reference ["Init";"Logic"] "and"
-let delayed_force c = EConstr.of_constr (c ())
-
-let mk_coq_not x = EConstr.mkApp (delayed_force coq_not, [| x |])
+let mk_coq_not sigma x =
+ let sigma, notc = Evarutil.new_global sigma (coq_not ()) in
+ sigma, EConstr.mkApp (notc, [| x |])
let unsafe_fold_right f = function
hd :: tl -> List.fold_right f tl hd
| [] -> invalid_arg "unsafe_fold_right"
-let mk_coq_and l =
- let and_typ = delayed_force coq_and in
- unsafe_fold_right
+let mk_coq_and sigma l =
+ let sigma, and_typ = Evarutil.new_global sigma (coq_and ()) in
+ sigma, unsafe_fold_right
(fun c conj ->
EConstr.mkApp (and_typ, [| c ; conj |]))
l
diff --git a/pretyping/program.mli b/pretyping/program.mli
index 94a7bdcb6d..8439b9528c 100644
--- a/pretyping/program.mli
+++ b/pretyping/program.mli
@@ -32,8 +32,8 @@ val coq_eq_rect : unit -> global_reference
val coq_JMeq_ind : unit -> global_reference
val coq_JMeq_refl : unit -> global_reference
-val mk_coq_and : constr list -> constr
-val mk_coq_not : constr -> constr
+val mk_coq_and : Evd.evar_map -> constr list -> Evd.evar_map * constr
+val mk_coq_not : Evd.evar_map -> constr -> Evd.evar_map * constr
(** Polymorphic application of delayed references *)
val papp : Evd.evar_map ref -> (unit -> global_reference) -> constr array -> constr
diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml
index e7c9635829..b4654bfb56 100644
--- a/pretyping/reductionops.ml
+++ b/pretyping/reductionops.ml
@@ -595,7 +595,7 @@ type state = constr * constr Stack.t
type contextual_reduction_function = env -> evar_map -> constr -> constr
type reduction_function = contextual_reduction_function
type local_reduction_function = evar_map -> constr -> constr
-type e_reduction_function = { e_redfun : 'r. env -> 'r Sigma.t -> constr -> (constr, 'r) Sigma.sigma }
+type e_reduction_function = env -> evar_map -> constr -> evar_map * constr
type contextual_stack_reduction_function =
env -> evar_map -> constr -> constr * constr list
@@ -1317,19 +1317,23 @@ let sigma_univ_state =
let infer_conv_gen conv_fun ?(catch_incon=true) ?(pb=Reduction.CUMUL)
?(ts=full_transparent_state) env sigma x y =
(** FIXME *)
+ let open Universes in
let x = EConstr.Unsafe.to_constr x in
let y = EConstr.Unsafe.to_constr y in
try
- let fold cstr sigma =
- try Some (Evd.add_universe_constraints sigma cstr)
- with Univ.UniverseInconsistency _ | Evd.UniversesDiffer -> None
- in
+ let fold cstr accu = Some (Constraints.fold Constraints.add cstr accu) in
let b, sigma =
let ans =
if pb == Reduction.CUMUL then
- Universes.leq_constr_univs_infer (Evd.universes sigma) fold x y sigma
+ Universes.leq_constr_univs_infer (Evd.universes sigma) fold x y Constraints.empty
else
- Universes.eq_constr_univs_infer (Evd.universes sigma) fold x y sigma
+ Universes.eq_constr_univs_infer (Evd.universes sigma) fold x y Constraints.empty
+ in
+ let ans = match ans with
+ | None -> None
+ | Some cstr ->
+ try Some (Evd.add_universe_constraints sigma cstr)
+ with Univ.UniverseInconsistency _ | Evd.UniversesDiffer -> None
in
match ans with
| None -> false, sigma
@@ -1441,7 +1445,7 @@ let instance sigma s c =
let hnf_prod_app env sigma t n =
match EConstr.kind sigma (whd_all env sigma t) with
| Prod (_,_,b) -> subst1 n b
- | _ -> anomaly ~label:"hnf_prod_app" (Pp.str "Need a product")
+ | _ -> anomaly ~label:"hnf_prod_app" (Pp.str "Need a product.")
let hnf_prod_appvect env sigma t nl =
Array.fold_left (fun acc t -> hnf_prod_app env sigma acc t) t nl
@@ -1452,7 +1456,7 @@ let hnf_prod_applist env sigma t nl =
let hnf_lam_app env sigma t n =
match EConstr.kind sigma (whd_all env sigma t) with
| Lambda (_,_,b) -> subst1 n b
- | _ -> anomaly ~label:"hnf_lam_app" (Pp.str "Need an abstraction")
+ | _ -> anomaly ~label:"hnf_lam_app" (Pp.str "Need an abstraction.")
let hnf_lam_appvect env sigma t nl =
Array.fold_left (fun acc t -> hnf_lam_app env sigma acc t) t nl
@@ -1689,5 +1693,5 @@ let betazetaevar_applist sigma n c l =
| Lambda(_,_,c), arg::stacktl -> stacklam (n-1) (arg::env) c stacktl
| LetIn(_,b,_,c), _ -> stacklam (n-1) (substl env b::env) c stack
| Evar _, _ -> applist (substl env t, stack)
- | _ -> anomaly (Pp.str "Not enough lambda/let's") in
+ | _ -> anomaly (Pp.str "Not enough lambda/let's.") in
stacklam n [] c l
diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli
index af80481569..af0e28cdd3 100644
--- a/pretyping/reductionops.mli
+++ b/pretyping/reductionops.mli
@@ -117,7 +117,7 @@ type contextual_reduction_function = env -> evar_map -> constr -> constr
type reduction_function = contextual_reduction_function
type local_reduction_function = evar_map -> constr -> constr
-type e_reduction_function = { e_redfun : 'r. env -> 'r Sigma.t -> constr -> (constr, 'r) Sigma.sigma }
+type e_reduction_function = env -> evar_map -> constr -> evar_map * constr
type contextual_stack_reduction_function =
env -> evar_map -> constr -> constr * constr list
diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml
index 496c706ec6..a1d0977f5a 100644
--- a/pretyping/retyping.ml
+++ b/pretyping/retyping.ml
@@ -48,7 +48,7 @@ let retype_error re = raise (RetypeError re)
let anomaly_on_error f x =
try f x
- with RetypeError e -> anomaly ~label:"retyping" (print_retype_error e)
+ with RetypeError e -> anomaly ~label:"retyping" (print_retype_error e ++ str ".")
let get_type_from_constraints env sigma t =
if isEvar sigma (fst (decompose_app_vect sigma t)) then
diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml
index 3d41d2ddd5..ec3669bfec 100644
--- a/pretyping/tacred.ml
+++ b/pretyping/tacred.ml
@@ -24,7 +24,6 @@ open Reductionops
open Cbv
open Patternops
open Locus
-open Sigma.Notations
module RelDecl = Context.Rel.Declaration
module NamedDecl = Context.Named.Declaration
@@ -107,7 +106,7 @@ let destEvalRefU sigma c = match EConstr.kind sigma c with
| Var id -> (EvalVar id, EInstance.empty)
| Rel n -> (EvalRel n, EInstance.empty)
| Evar ev -> (EvalEvar ev, EInstance.empty)
- | _ -> anomaly (Pp.str "Not an unfoldable reference")
+ | _ -> anomaly (Pp.str "Not an unfoldable reference.")
let unsafe_reference_opt_value env sigma eval =
match eval with
@@ -307,7 +306,7 @@ let compute_consteval_mutual_fix env sigma ref =
(* Forget all \'s and args and do as if we had started with c' *)
let ref,_ = destEvalRefU sigma c' in
(match unsafe_reference_opt_value env sigma ref with
- | None -> anomaly (Pp.str "Should have been trapped by compute_direct")
+ | None -> anomaly (Pp.str "Should have been trapped by compute_direct.")
| Some c -> srec env (minarg-nargs) [] ref c)
| _ -> (* Should not occur *) NotAnElimination
in
@@ -399,9 +398,8 @@ let substl_with_function subst sigma constr =
if i <= k + Array.length v then
match v.(i-k-1) with
| (fx, Some (min, ref)) ->
- let sigma = Sigma.Unsafe.of_evar_map !evd in
- let Sigma (evk, sigma, _) = Evarutil.new_pure_evar venv sigma dummy in
- let sigma = Sigma.to_evar_map sigma in
+ let sigma = !evd in
+ let (sigma, evk) = Evarutil.new_pure_evar venv sigma dummy in
evd := sigma;
minargs := Evar.Map.add evk min !minargs;
Vars.lift k (mkEvar (evk, [|fx;ref|]))
@@ -983,11 +981,10 @@ let change_map_constr_with_binders_left_to_right g f (env, l as acc) sigma c =
| _ -> mkApp (app', [| a' |]))
| _ -> map_constr_with_binders_left_to_right sigma g f acc c
-let e_contextually byhead (occs,c) f = { e_redfun = begin fun env sigma t ->
+let e_contextually byhead (occs,c) f = begin fun env sigma t ->
let (nowhere_except_in,locs) = Locusops.convert_occs occs in
let maxocc = List.fold_right max locs 0 in
let pos = ref 1 in
- let sigma = Sigma.to_evar_map sigma in
(** FIXME: we do suspicious things with this evarmap *)
let evd = ref sigma in
let rec traverse nested (env,c as envc) t =
@@ -1007,8 +1004,8 @@ let e_contextually byhead (occs,c) f = { e_redfun = begin fun env sigma t ->
(* Skip inner occurrences for stable counting of occurrences *)
if locs != [] then
ignore (traverse_below (Some (!pos-1)) envc t);
- let Sigma (t, evm, _) = (f subst).e_redfun env (Sigma.Unsafe.of_evar_map !evd) t in
- (evd := Sigma.to_evar_map evm; t)
+ let (evm, t) = (f subst) env !evd t in
+ (evd := evm; t)
end
else
traverse_below nested envc t
@@ -1027,15 +1024,12 @@ let e_contextually byhead (occs,c) f = { e_redfun = begin fun env sigma t ->
in
let t' = traverse None (env,c) t in
if List.exists (fun o -> o >= !pos) locs then error_invalid_occurrence locs;
- Sigma.Unsafe.of_pair (t', !evd)
- end }
+ (!evd, t')
+ end
let contextually byhead occs f env sigma t =
- let f' subst = { e_redfun = begin fun env sigma t ->
- Sigma.here (f subst env (Sigma.to_evar_map sigma) t) sigma
- end } in
- let Sigma (c, _, _) = (e_contextually byhead occs f').e_redfun env (Sigma.Unsafe.of_evar_map sigma) t in
- c
+ let f' subst env sigma t = sigma, f subst env sigma t in
+ snd (e_contextually byhead occs f' env sigma t)
(* linear bindings (following pretty-printer) of the value of name in c.
* n is the number of the next occurrence of name.
@@ -1154,15 +1148,14 @@ let abstract_scheme env sigma (locc,a) (c, sigma) =
let c', sigma' = subst_closed_term_occ env sigma (AtOccs locc) a c in
mkLambda (na,ta,c'), sigma'
-let pattern_occs loccs_trm = { e_redfun = begin fun env sigma c ->
- let sigma = Sigma.to_evar_map sigma in
+let pattern_occs loccs_trm = begin fun env sigma c ->
let abstr_trm, sigma = List.fold_right (abstract_scheme env sigma) loccs_trm (c,sigma) in
try
let _ = Typing.unsafe_type_of env sigma abstr_trm in
- Sigma.Unsafe.of_pair (applist(abstr_trm, List.map snd loccs_trm), sigma)
+ (sigma, applist(abstr_trm, List.map snd loccs_trm))
with Type_errors.TypeError (env',t) ->
raise (ReductionTacticError (InvalidAbstraction (env,sigma,abstr_trm,(env',t))))
- end }
+ end
(* Used in several tactics. *)
diff --git a/pretyping/typing.ml b/pretyping/typing.ml
index 757e12451e..7ad988ad0b 100644
--- a/pretyping/typing.ml
+++ b/pretyping/typing.ml
@@ -31,7 +31,7 @@ let push_rec_types pfix env =
let meta_type evd mv =
let ty =
try Evd.meta_ftype evd mv
- with Not_found -> anomaly (str "unknown meta ?" ++ str (Nameops.string_of_meta mv)) in
+ with Not_found -> anomaly (str "unknown meta ?" ++ str (Nameops.string_of_meta mv) ++ str ".") in
let ty = Evd.map_fl EConstr.of_constr ty in
meta_instance evd ty
@@ -121,11 +121,11 @@ let lambda_applist_assum sigma n c l =
let rec app n subst t l =
if Int.equal n 0 then
if l == [] then substl subst t
- else anomaly (Pp.str "Not enough arguments")
+ else anomaly (Pp.str "Not enough arguments.")
else match EConstr.kind sigma t, l with
| Lambda(_,_,c), arg::l -> app (n-1) (arg::subst) c l
| LetIn(_,b,_,c), _ -> app (n-1) (substl subst b::subst) c l
- | _ -> anomaly (Pp.str "Not enough lambda/let's") in
+ | _ -> anomaly (Pp.str "Not enough lambda/let's.") in
app n [] c l
let e_type_case_branches env evdref (ind,largs) pj c =
diff --git a/pretyping/unification.ml b/pretyping/unification.ml
index d1643a8c7d..0fb48ed8cf 100644
--- a/pretyping/unification.ml
+++ b/pretyping/unification.ml
@@ -31,7 +31,6 @@ open Recordops
open Locus
open Locusops
open Find_subterm
-open Sigma.Notations
type metabinding = (metavariable * EConstr.constr * (instance_constraint * instance_typing_status))
@@ -145,9 +144,7 @@ let set_occurrences_of_last_arg args =
Some AllOccurrences :: List.tl (Array.map_to_list (fun _ -> None) args)
let abstract_list_all_with_dependencies env evd typ c l =
- let evd = Sigma.Unsafe.of_evar_map evd in
- let Sigma (ev, evd, _) = new_evar env evd typ in
- let evd = Sigma.to_evar_map evd in
+ let (evd, ev) = new_evar env evd typ in
let evd,ev' = evar_absorb_arguments env evd (destEvar evd ev) l in
let n = List.length l in
let argoccs = set_occurrences_of_last_arg (Array.sub (snd ev') 0 n) in
@@ -1239,20 +1236,19 @@ let merge_instances env sigma flags st1 st2 c1 c2 =
* close it off. But this might not always work,
* since other metavars might also need to be resolved. *)
-let applyHead env (type r) (evd : r Sigma.t) n c =
- let rec apprec : type s. _ -> _ -> _ -> (r, s) Sigma.le -> s Sigma.t -> (constr, r) Sigma.sigma =
- fun n c cty p evd ->
+let applyHead env evd n c =
+ let rec apprec n c cty evd =
if Int.equal n 0 then
- Sigma (c, evd, p)
+ (evd, c)
else
- let sigma = Sigma.to_evar_map evd in
- match EConstr.kind sigma (whd_all env sigma cty) with
+ match EConstr.kind evd (whd_all env evd cty) with
| Prod (_,c1,c2) ->
- let Sigma (evar, evd', q) = Evarutil.new_evar env evd ~src:(Loc.tag Evar_kinds.GoalEvar) c1 in
- apprec (n-1) (mkApp(c,[|evar|])) (subst1 evar c2) (p +> q) evd'
+ let (evd',evar) =
+ Evarutil.new_evar env evd ~src:(Loc.tag Evar_kinds.GoalEvar) c1 in
+ apprec (n-1) (mkApp(c,[|evar|])) (subst1 evar c2) evd'
| _ -> user_err Pp.(str "Apply_Head_Then")
in
- apprec n c (Typing.unsafe_type_of env (Sigma.to_evar_map evd) c) Sigma.refl evd
+ apprec n c (Typing.unsafe_type_of env evd c) evd
let is_mimick_head sigma ts f =
match EConstr.kind sigma f with
@@ -1416,9 +1412,7 @@ let w_merge env with_types flags (evd,metas,evars : subst0) =
and mimick_undefined_evar evd flags hdc nargs sp =
let ev = Evd.find_undefined evd sp in
let sp_env = Global.env_of_context ev.evar_hyps in
- let evd = Sigma.Unsafe.of_evar_map evd in
- let Sigma (c, evd', _) = applyHead sp_env evd nargs hdc in
- let evd' = Sigma.to_evar_map evd' in
+ let (evd', c) = applyHead sp_env evd nargs hdc in
let (evd'',mc,ec) =
unify_0 sp_env evd' CUMUL flags
(get_type_of sp_env evd' c) (EConstr.of_constr ev.evar_concl) in
@@ -1534,10 +1528,9 @@ let indirectly_dependent sigma c d decls =
List.exists (fun d' -> dependent_in_decl sigma (EConstr.mkVar (NamedDecl.get_id d')) d) decls
let finish_evar_resolution ?(flags=Pretyping.all_and_fail_flags) env current_sigma (pending,c) =
- let current_sigma = Sigma.to_evar_map current_sigma in
let sigma = Pretyping.solve_remaining_evars flags env current_sigma pending in
let sigma, subst = nf_univ_variables sigma in
- Sigma.Unsafe.of_pair (EConstr.of_constr (CVars.subst_univs_constr subst (EConstr.Unsafe.to_constr (nf_evar sigma c))), sigma)
+ (sigma, EConstr.of_constr (CVars.subst_univs_constr subst (EConstr.Unsafe.to_constr (nf_evar sigma c))))
let default_matching_core_flags sigma =
let ts = Names.full_transparent_state in {
@@ -1684,7 +1677,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl =
if List.is_empty depdecls then None else Some (NamedDecl.get_id (List.last depdecls)) in
let res = match out test with
| None -> None
- | Some (sigma, c) -> Some (Sigma.Unsafe.of_pair (c, sigma))
+ | Some (sigma, c) -> Some (sigma,c)
in
(id,sign,depdecls,lastlhyp,ccl,res)
with
@@ -1711,10 +1704,9 @@ type abstraction_request =
type 'r abstraction_result =
Names.Id.t * named_context_val *
named_declaration list * Names.Id.t option *
- types * (constr, 'r) Sigma.sigma option
+ types * (evar_map * constr) option
let make_abstraction env evd ccl abs =
- let evd = Sigma.to_evar_map evd in
match abs with
| AbstractPattern (from_prefix,check,name,c,occs,check_occs) ->
make_abstraction_core name
diff --git a/pretyping/unification.mli b/pretyping/unification.mli
index 8d7e3521d6..0d90ab1584 100644
--- a/pretyping/unification.mli
+++ b/pretyping/unification.mli
@@ -76,14 +76,14 @@ type abstraction_request =
| AbstractExact of Names.Name.t * constr * types option * Locus.clause * bool
val finish_evar_resolution : ?flags:Pretyping.inference_flags ->
- env -> 'r Sigma.t -> (evar_map * constr) -> (constr, 'r) Sigma.sigma
+ env -> evar_map -> (evar_map * constr) -> evar_map * constr
type 'r abstraction_result =
Names.Id.t * named_context_val *
named_declaration list * Names.Id.t option *
- types * (constr, 'r) Sigma.sigma option
+ types * (evar_map * constr) option
-val make_abstraction : env -> 'r Sigma.t -> constr ->
+val make_abstraction : env -> evar_map -> constr ->
abstraction_request -> 'r abstraction_result
val pose_all_metas_as_evars : env -> evar_map -> constr -> evar_map * constr
generated by cgit v1.2.3 (git 2.25.1) at 2026-04-29 19:44:29 +0000