aboutsummaryrefslogtreecommitdiff
path: root/pretyping
diff options
context:
space:
mode:
Diffstat (limited to 'pretyping')
-rw-r--r--pretyping/cases.ml29
-rw-r--r--pretyping/coercion.ml4
-rw-r--r--pretyping/detyping.ml2
-rw-r--r--pretyping/evarconv.ml12
-rw-r--r--pretyping/evardefine.ml18
-rw-r--r--pretyping/evarsolve.ml17
-rw-r--r--pretyping/glob_ops.ml42
-rw-r--r--pretyping/glob_ops.mli2
-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.ml19
-rw-r--r--pretyping/pretyping.ml35
-rw-r--r--pretyping/program.ml9
-rw-r--r--pretyping/reductionops.ml10
-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
23 files changed, 156 insertions, 166 deletions
diff --git a/pretyping/cases.ml b/pretyping/cases.ml
index 80680e4088..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 *)
@@ -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 *)
diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml
index 83c26058ac..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
@@ -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 6f099c8dfd..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 =
diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml
index 630f80ad2f..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
@@ -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 6fb1b60898..62ff9ac708 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. *)
@@ -59,6 +60,11 @@ let cast_type_eq eq t1 t2 = match t1, t2 with
| 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
@@ -97,8 +103,7 @@ let mk_glob_constr_eq f { CAst.v = c1 } { CAst.v = c2 } = match c1, c2 with
| 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 (b1, pat1), GPatVar (b2, pat2) ->
- (b1 : bool) == b2 && Id.equal pat1 pat2
+ | 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) ->
@@ -452,11 +457,44 @@ let rec cases_pattern_of_glob_constr na = CAst.map (function
| _ -> raise Not_found
)
+open Declarations
+open Term
+open Context
+
+(* Keep only patterns which are not bound to a local definitions *)
+let drop_local_defs typi args =
+ let (decls,_) = decompose_prod_assum typi in
+ let rec aux decls args =
+ match decls, args with
+ | [], [] -> []
+ | Rel.Declaration.LocalDef _ :: decls, pat :: args ->
+ begin
+ match pat.CAst.v with
+ | PatVar Anonymous -> aux decls args
+ | _ -> raise Not_found (* The pattern is used, one cannot drop it *)
+ end
+ | Rel.Declaration.LocalAssum _ :: decls, a :: args -> a :: aux decls args
+ | _ -> assert false in
+ aux (List.rev decls) args
+
+let add_patterns_for_params_remove_local_defs (ind,j) l =
+ let (mib,mip) = Global.lookup_inductive ind in
+ let nparams = mib.Declarations.mind_nparams in
+ let l =
+ if mip.mind_consnrealdecls.(j-1) = mip.mind_consnrealargs.(j-1) then
+ (* Optimisation *) l
+ else
+ let typi = mip.mind_nf_lc.(j-1) in
+ let (_,typi) = decompose_prod_n_assum (Rel.length mib.mind_params_ctxt) typi in
+ drop_local_defs typi l in
+ Util.List.addn nparams (CAst.make @@ PatVar Anonymous) l
+
(* Turn a closed cases pattern into a glob_constr *)
let rec glob_constr_of_closed_cases_pattern_aux x = CAst.map_with_loc (fun ?loc -> function
| PatCstr (cstr,[],Anonymous) -> GRef (ConstructRef cstr,None)
| PatCstr (cstr,l,Anonymous) ->
let ref = CAst.make ?loc @@ GRef (ConstructRef cstr,None) in
+ let l = add_patterns_for_params_remove_local_defs cstr l in
GApp (ref, List.map glob_constr_of_closed_cases_pattern_aux l)
| _ -> raise Not_found
) x
diff --git a/pretyping/glob_ops.mli b/pretyping/glob_ops.mli
index f7cc08ca21..75db04f77f 100644
--- a/pretyping/glob_ops.mli
+++ b/pretyping/glob_ops.mli
@@ -81,3 +81,5 @@ val map_pattern : (glob_constr -> glob_constr) ->
val cases_pattern_of_glob_constr : Name.t -> glob_constr -> cases_pattern
val glob_constr_of_closed_cases_pattern : cases_pattern -> Name.t * glob_constr
+
+val add_patterns_for_params_remove_local_defs : constructor -> cases_pattern list -> cases_pattern list
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 0818a55256..c36542aebc 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,12 +330,12 @@ 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,
@@ -363,9 +364,9 @@ let rec pat_of_raw metas vars = CAst.with_loc_val (fun ?loc -> function
PIf (pat_of_raw metas vars c,
pat_of_raw metas vars b1,pat_of_raw metas vars b2)
| GLetTuple (nal,(_,None),b,c) ->
- let mkGLambda c na = CAst.make ?loc @@
+ let mkGLambda na c = CAst.make ?loc @@
GLambda (na,Explicit, CAst.make @@ GHole (Evar_kinds.InternalHole, IntroAnonymous, None),c) in
- let c = List.fold_left mkGLambda c nal in
+ let c = List.fold_right mkGLambda nal c in
let cip =
{ cip_style = LetStyle;
cip_ind = None;
diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index b0663af70c..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
@@ -390,9 +388,8 @@ let adjust_evar_source evdref na c =
begin match evi.evar_source with
| loc, Evar_kinds.QuestionMark (b,Anonymous) ->
let src = (loc,Evar_kinds.QuestionMark (b,na)) in
- let sigma = Sigma.Unsafe.of_evar_map !evdref in
- let Sigma (evk', evd, _) = restrict_evar sigma evk (evar_filter evi) ~src None in
- evdref := Sigma.to_evar_map evd;
+ let (evd, evk') = restrict_evar !evdref evk (evar_filter evi) ~src None in
+ evdref := evd;
mkEvar (evk',args)
| _ -> c
end
@@ -571,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 =
@@ -625,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) ->
@@ -1149,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 }
@@ -1267,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;
@@ -1275,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 2fa3facb30..f9be82024a 100644
--- a/pretyping/program.ml
+++ b/pretyping/program.ml
@@ -41,13 +41,8 @@ let coq_JMeq_refl = init_reference ["Logic";"JMeq"] "JMeq_refl"
let coq_not = init_reference ["Init";"Logic"] "not"
let coq_and = init_reference ["Init";"Logic"] "and"
-let new_global sigma gr =
- let open Sigma in
- let Sigma (c, sigma, _) = Evarutil.new_global (Sigma.Unsafe.of_evar_map sigma) gr
- in Sigma.to_evar_map sigma, c
-
let mk_coq_not sigma x =
- let sigma, notc = new_global sigma (coq_not ()) in
+ let sigma, notc = Evarutil.new_global sigma (coq_not ()) in
sigma, EConstr.mkApp (notc, [| x |])
let unsafe_fold_right f = function
@@ -55,7 +50,7 @@ let unsafe_fold_right f = function
| [] -> invalid_arg "unsafe_fold_right"
let mk_coq_and sigma l =
- let sigma, and_typ = new_global sigma (coq_and ()) in
+ let sigma, and_typ = Evarutil.new_global sigma (coq_and ()) in
sigma, unsafe_fold_right
(fun c conj ->
EConstr.mkApp (and_typ, [| c ; conj |]))
diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml
index 5a2328aaa4..52d1ffe06d 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
@@ -777,7 +777,7 @@ let contract_fix ?env sigma ?reference ((recindices,bodynum),(names,types,bodies
context" in contract_fix *)
let reduce_and_refold_fix recfun env sigma refold cst_l fix sk =
let raw_answer =
- let env = if refold then None else Some env in
+ let env = if refold then Some env else None in
contract_fix ?env sigma ?reference:(Cst_stack.reference sigma cst_l) fix in
apply_subst
(fun sigma x (t,sk') ->
@@ -1445,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
@@ -1456,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
@@ -1693,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 21:26:34 +0000