From 8a2c1dba09e78129b279e0fe9e862f8cecbcf2aa Mon Sep 17 00:00:00 2001
From: herbelin
Date: Thu, 10 Mar 2005 23:04:44 +0000
Subject: A défaut de substitution paresseuse ou explicite, ajout d'une
 substitution optimisée pour le prétypage que normalise les evars (cf bug
 #932)

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/coq/trunk@6819 85f007b7-540e-0410-9357-904b9bb8a0f7
---
 pretyping/reductionops.ml  | 13 +++++++++++++
 pretyping/reductionops.mli |  2 ++
 2 files changed, 15 insertions(+)

diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml
index a7573f5343..f77dfe3c29 100644
--- a/pretyping/reductionops.ml
+++ b/pretyping/reductionops.ml
@@ -433,6 +433,19 @@ let rec whd_evar sigma c =
 let nf_evar sigma =
   local_strong (whd_evar sigma)
 
+let subst1_nf_evar sigma v =
+  let rec substrec depth c = match kind_of_term c with
+    | Rel k     ->
+        if k <= depth then c
+        else if k = depth+1 then lift depth v
+        else mkRel (k-1)
+    | Evar (ev,args as evar) ->
+	(try substrec depth (Evd.existential_value sigma evar)
+	 with Not_found -> mkEvar (ev, Array.map (substrec depth) args))
+    | _ -> map_constr_with_binders succ substrec depth c
+  in 
+  substrec 0
+
 (* lazy reduction functions. The infos must be created for each term *)
 let clos_norm_flags flgs env sigma t =
   norm_val (create_clos_infos flgs env) (inject (nf_evar sigma t))
diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli
index 29a28f0f74..f8baac5ea4 100644
--- a/pretyping/reductionops.mli
+++ b/pretyping/reductionops.mli
@@ -120,6 +120,8 @@ val hnf_lam_app      : env ->  evar_map -> constr -> constr -> constr
 val hnf_lam_appvect  : env ->  evar_map -> constr -> constr array -> constr
 val hnf_lam_applist  : env ->  evar_map -> constr -> constr list -> constr
 
+val subst1_nf_evar : evar_map -> constr -> constr -> constr
+
 val splay_prod : env ->  evar_map -> constr -> (name * constr) list * constr
 val splay_lambda : env ->  evar_map -> constr -> (name * constr) list * constr
 val splay_arity : env ->  evar_map -> constr -> (name * constr) list * sorts
-- 
cgit v1.2.3