aboutsummaryrefslogtreecommitdiffhomepage
path: root/pretyping
diff options
context:
space:
mode:
Diffstat (limited to 'pretyping')
-rw-r--r--pretyping/cases.ml6
-rw-r--r--pretyping/evardefine.ml4
-rw-r--r--pretyping/nativenorm.ml28
-rw-r--r--pretyping/reductionops.ml6
-rw-r--r--pretyping/reductionops.mli6
-rw-r--r--pretyping/tacred.ml12
-rw-r--r--pretyping/unification.ml4
7 files changed, 39 insertions, 27 deletions
diff --git a/pretyping/cases.ml b/pretyping/cases.ml
index 1207c967b..311c1c09e 100644
--- a/pretyping/cases.ml
+++ b/pretyping/cases.ml
@@ -1276,7 +1276,7 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn
(* This is a bit too strong I think, in the sense that what we would *)
(* really like is to have beta-iota reduction only at the positions where *)
(* parameters are substituted *)
- let typs = List.map (map_type (nf_betaiota !(pb.evdref))) typs in
+ let typs = List.map (map_type (nf_betaiota pb.env !(pb.evdref))) typs in
(* We build the matrix obtained by expanding the matching on *)
(* "C x1..xn as x" followed by a residual matching on eqn into *)
@@ -1426,7 +1426,7 @@ and match_current pb (initial,tomatch) =
find_predicate pb.caseloc pb.env pb.evdref
pred current indt (names,dep) tomatch in
let ci = make_case_info pb.env (fst mind) pb.casestyle in
- let pred = nf_betaiota !(pb.evdref) pred in
+ let pred = nf_betaiota pb.env !(pb.evdref) pred in
let case =
make_case_or_project pb.env !(pb.evdref) indf ci pred current brvals
in
@@ -1663,7 +1663,7 @@ let rec list_assoc_in_triple x = function
*)
let abstract_tycon ?loc env evdref subst tycon extenv t =
- let t = nf_betaiota !evdref t in (* it helps in some cases to remove K-redex*)
+ let t = nf_betaiota env !evdref t in (* it helps in some cases to remove K-redex*)
let src = match EConstr.kind !evdref t with
| Evar (evk,_) -> (Loc.tag ?loc @@ Evar_kinds.SubEvar evk)
| _ -> (Loc.tag ?loc @@ Evar_kinds.CasesType true) in
diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml
index b646a37f8..fd83795f5 100644
--- a/pretyping/evardefine.ml
+++ b/pretyping/evardefine.ml
@@ -28,8 +28,8 @@ let env_nf_evar sigma env =
let env_nf_betaiotaevar sigma env =
process_rel_context
- (fun d e ->
- push_rel (RelDecl.map_constr (fun c -> Reductionops.nf_betaiota sigma c) d) e) env
+ (fun d env ->
+ push_rel (RelDecl.map_constr (fun c -> Reductionops.nf_betaiota env sigma c) d) env) env
(****************************************)
(* Operations on value/type constraints *)
diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml
index 79e0afa72..b41e15f5a 100644
--- a/pretyping/nativenorm.ml
+++ b/pretyping/nativenorm.ml
@@ -224,7 +224,7 @@ and nf_accu env sigma accu =
if Int.equal (accu_nargs accu) 0 then nf_atom env sigma atom
else
let a,typ = nf_atom_type env sigma atom in
- let _, args = nf_args env sigma accu typ in
+ let _, args = nf_args env sigma (args_of_accu accu) typ in
mkApp(a,Array.of_list args)
and nf_accu_type env sigma accu =
@@ -232,10 +232,10 @@ and nf_accu_type env sigma accu =
if Int.equal (accu_nargs accu) 0 then nf_atom_type env sigma atom
else
let a,typ = nf_atom_type env sigma atom in
- let t, args = nf_args env sigma accu typ in
+ let t, args = nf_args env sigma (args_of_accu accu) typ in
mkApp(a,Array.of_list args), t
-and nf_args env sigma accu t =
+and nf_args env sigma args t =
let aux arg (t,l) =
let _,dom,codom =
try decompose_prod env t with
@@ -246,7 +246,7 @@ and nf_args env sigma accu t =
let c = nf_val env sigma arg dom in
(subst1 c codom, c::l)
in
- let t,l = List.fold_right aux (args_of_accu accu) (t,[]) in
+ let t,l = Array.fold_right aux args (t,[]) in
t, List.rev l
and nf_bargs env sigma b t =
@@ -277,7 +277,6 @@ and nf_atom env sigma atom =
let codom = nf_type env sigma (codom vn) in
mkProd(n,dom,codom)
| Ameta (mv,_) -> mkMeta mv
- | Aevar (ev,_) -> mkEvar ev
| Aproj(p,c) ->
let c = nf_accu env sigma c in
mkProj(Projection.make p true,c)
@@ -347,9 +346,9 @@ and nf_atom_type env sigma atom =
let env = push_rel (LocalAssum (n,dom)) env in
let codom,s2 = nf_type_sort env sigma (codom vn) in
mkProd(n,dom,codom), Typeops.type_of_product env n s1 s2
- | Aevar(ev,ty) ->
- let ty = nf_type env sigma ty in
- mkEvar ev, ty
+ | Aevar(evk,ty,args) ->
+ let ty = nf_type env sigma ty in
+ nf_evar env sigma evk ty args
| Ameta(mv,ty) ->
let ty = nf_type env sigma ty in
mkMeta mv, ty
@@ -386,6 +385,19 @@ and nf_predicate env sigma ind mip params v pT =
true, mkLambda(name,dom,body)
| _, _ -> false, nf_type env sigma v
+and nf_evar env sigma evk ty args =
+ let evi = try Evd.find sigma evk with Not_found -> assert false in
+ let hyps = Environ.named_context_of_val (Evd.evar_filtered_hyps evi) in
+ if List.is_empty hyps then begin
+ assert (Int.equal (Array.length args) 0);
+ mkEvar (evk, [||]), ty
+ end
+ else
+ let fold accu d = Term.mkNamedProd_or_LetIn d accu in
+ let t = List.fold_left fold ty hyps in
+ let ty, args = nf_args env sigma args t in
+ mkEvar (evk, Array.of_list args), ty
+
let evars_of_evar_map sigma =
{ Nativelambda.evars_val = Evd.existential_opt_value sigma;
Nativelambda.evars_typ = Evd.existential_type sigma;
diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml
index 78de0437d..1893018a9 100644
--- a/pretyping/reductionops.ml
+++ b/pretyping/reductionops.ml
@@ -1241,9 +1241,9 @@ let clos_whd_flags flgs env sigma t =
(CClosure.inject (EConstr.Unsafe.to_constr t)))
with e when is_anomaly e -> user_err Pp.(str "Tried to normalize ill-typed term")
-let nf_beta = clos_norm_flags CClosure.beta (Global.env ())
-let nf_betaiota = clos_norm_flags CClosure.betaiota (Global.env ())
-let nf_betaiotazeta = clos_norm_flags CClosure.betaiotazeta (Global.env ())
+let nf_beta = clos_norm_flags CClosure.beta
+let nf_betaiota = clos_norm_flags CClosure.betaiota
+let nf_betaiotazeta = clos_norm_flags CClosure.betaiotazeta
let nf_all env sigma =
clos_norm_flags CClosure.all env sigma
diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli
index a277864c9..0565baf45 100644
--- a/pretyping/reductionops.mli
+++ b/pretyping/reductionops.mli
@@ -168,9 +168,9 @@ val clos_norm_flags : CClosure.RedFlags.reds -> reduction_function
val clos_whd_flags : CClosure.RedFlags.reds -> reduction_function
(** Same as [(strong whd_beta[delta][iota])], but much faster on big terms *)
-val nf_beta : local_reduction_function
-val nf_betaiota : local_reduction_function
-val nf_betaiotazeta : local_reduction_function
+val nf_beta : reduction_function
+val nf_betaiota : reduction_function
+val nf_betaiotazeta : reduction_function
val nf_all : reduction_function
val nf_evar : evar_map -> constr -> constr
diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml
index f682143f8..9b9408698 100644
--- a/pretyping/tacred.ml
+++ b/pretyping/tacred.ml
@@ -474,7 +474,7 @@ let contract_fix_use_function env sigma f
let nbodies = Array.length recindices in
let make_Fi j = (mkFix((recindices,j),typedbodies), f j) in
let lbodies = List.init nbodies make_Fi in
- substl_checking_arity env (List.rev lbodies) sigma (nf_beta sigma bodies.(bodynum))
+ substl_checking_arity env (List.rev lbodies) sigma (nf_beta env sigma bodies.(bodynum))
let reduce_fix_use_function env sigma f whfun fix stack =
match fix_recarg fix (Stack.append_app_list stack Stack.empty) with
@@ -498,7 +498,7 @@ let contract_cofix_use_function env sigma f
let make_Fi j = (mkCoFix(j,typedbodies), f j) in
let subbodies = List.init nbodies make_Fi in
substl_checking_arity env (List.rev subbodies)
- sigma (nf_beta sigma bodies.(bodynum))
+ sigma (nf_beta env sigma bodies.(bodynum))
let reduce_mind_case_use_function func env sigma mia =
match EConstr.kind sigma mia.mconstr with
@@ -695,7 +695,7 @@ let rec red_elim_const env sigma ref u largs =
let whfun = whd_construct_stack env sigma in
(match reduce_fix_use_function env sigma f whfun (destFix sigma d) lrest with
| NotReducible -> raise Redelimination
- | Reduced (c,rest) -> (nf_beta sigma c, rest), nocase)
+ | Reduced (c,rest) -> (nf_beta env sigma c, rest), nocase)
| EliminationMutualFix (min,refgoal,refinfos) when nargs >= min ->
let rec descend (ref,u) args =
let c = reference_value env sigma ref u in
@@ -710,7 +710,7 @@ let rec red_elim_const env sigma ref u largs =
let whfun = whd_construct_stack env sigma in
(match reduce_fix_use_function env sigma f whfun (destFix sigma d) lrest with
| NotReducible -> raise Redelimination
- | Reduced (c,rest) -> (nf_beta sigma c, rest), nocase)
+ | Reduced (c,rest) -> (nf_beta env sigma c, rest), nocase)
| NotAnElimination when unfold_nonelim ->
let c = reference_value env sigma ref u in
(whd_betaiotazeta sigma (applist (c, largs)), []), nocase
@@ -1101,7 +1101,7 @@ let unfoldoccs env sigma (occs,name) c =
| [] -> ()
| _ -> error_invalid_occurrence rest
in
- nf_betaiotazeta sigma uc
+ nf_betaiotazeta env sigma uc
in
match occs with
| NoOccurrences -> c
@@ -1282,7 +1282,7 @@ let reduce_to_ref_gen allow_product env sigma ref t =
else raise Not_found
with Not_found ->
try
- let t' = nf_betaiota sigma (one_step_reduce env sigma t) in
+ let t' = nf_betaiota env sigma (one_step_reduce env sigma t) in
elimrec env t' l
with NotStepReducible -> error_cannot_recognize ref
in
diff --git a/pretyping/unification.ml b/pretyping/unification.ml
index 8df8f8474..e1720ec95 100644
--- a/pretyping/unification.ml
+++ b/pretyping/unification.ml
@@ -194,7 +194,7 @@ let pose_all_metas_as_evars env evd t =
let ty = if Evd.Metaset.is_empty mvs then ty else aux ty in
let ty =
if Flags.version_strictly_greater Flags.V8_6 || Flags.version_less_or_equal Flags.VOld
- then nf_betaiota evd ty (* How it was in Coq <= 8.4 (but done in logic.ml at this time) *)
+ then nf_betaiota env evd ty (* How it was in Coq <= 8.4 (but done in logic.ml at this time) *)
else ty (* some beta-iota-normalization "regression" in 8.5 and 8.6 *) in
let src = Evd.evar_source_of_meta mv !evdref in
let ev = Evarutil.e_new_evar env evdref ~src ty in
@@ -1277,7 +1277,7 @@ let w_coerce env evd mv c =
let unify_to_type env sigma flags c status u =
let sigma, c = refresh_universes (Some false) env sigma c in
let t = get_type_of env sigma (nf_meta sigma c) in
- let t = nf_betaiota sigma (nf_meta sigma t) in
+ let t = nf_betaiota env sigma (nf_meta sigma t) in
unify_0 env sigma CUMUL flags t u
let unify_type env sigma flags mv status c =
generated by cgit v1.2.3 (git 2.39.1) at 2024-07-06 06:43:28 +0000