From a2b0870c490b851a26dfa6c52c05d5e97bd4cd5a Mon Sep 17 00:00:00 2001
From: herbelin
Date: Fri, 21 Nov 2003 22:38:42 +0000
Subject: Ajout 'Simpl f'

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/coq/trunk@4966 85f007b7-540e-0410-9357-904b9bb8a0f7
---
 pretyping/tacred.ml | 11 ++++++++++-
 1 file changed, 10 insertions(+), 1 deletion(-)

diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml
index 09f552ba15..c26e9ce05c 100644
--- a/pretyping/tacred.ml
+++ b/pretyping/tacred.ml
@@ -597,6 +597,15 @@ let whd_nf env sigma c =
 
 let nf env sigma c = strong whd_nf env sigma c
 
+let is_reference c = 
+  try let r = reference_of_constr c in true with _ -> false
+
+let is_head c t =
+  (is_reference c) &
+  match kind_of_term t with
+    | App (f,_) -> f = c
+    | _ -> false
+
 let contextually (locs,c) f env sigma t =
   let maxocc = List.fold_right max locs 0 in
   let pos = ref 1 in
@@ -608,7 +617,7 @@ let contextually (locs,c) f env sigma t =
    let rec traverse (env,c as envc) t =
     if locs <> [] & (not except) & (!pos > maxocc) then t
     else
-    if eq_constr c t then
+    if eq_constr c t or is_head c t then
       let r =
 	if except then 
 	  if List.mem (- !pos) locs then t else f env sigma t
-- 
cgit v1.2.3