Généralisation de with_occurrence (ex occurrence) et de red_expr pour permettre de passer les occurrences en paramètre dans ltac, par exemple à pattern

git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/coq/trunk@8878 85f007b7-540e-0410-9357-904b9bb8a0f7

3 files changed, 17 insertions, 8 deletions

diff --git a/proofs/redexpr.ml b/proofs/redexpr.ml
index 2fed1cd2c..6f49ee735 100644
--- a/proofs/redexpr.ml
+++ b/proofs/redexpr.ml
@@ -93,19 +93,26 @@ let declare_red_expr s f =
   with Not_found ->
     red_expr_tab := Stringmap.add s f !red_expr_tab
 
+let out_arg = function
+  | ArgVar _ -> anomaly "Unevaluated or_var variable"
+  | ArgArg x -> x
+
+let out_with_occurrences (l,c) =
+  (List.map out_arg l, c)
+
 let reduction_of_red_expr = function
   | Red internal -> 
       if internal then (try_red_product,DEFAULTcast) 
       else (red_product,DEFAULTcast)
   | Hnf -> (hnf_constr,DEFAULTcast)
-  | Simpl (Some (_,c as lp)) -> 
-      (contextually (is_reference c) lp nf,DEFAULTcast)
+  | Simpl (Some (_,c as lp)) ->
+      (contextually (is_reference c) (out_with_occurrences lp) nf,DEFAULTcast)
   | Simpl None -> (nf,DEFAULTcast)
   | Cbv f -> (cbv_norm_flags (make_flag f),DEFAULTcast)
   | Lazy f -> (clos_norm_flags (make_flag f),DEFAULTcast)
-  | Unfold ubinds -> (unfoldn ubinds,DEFAULTcast)
+  | Unfold ubinds -> (unfoldn (List.map out_with_occurrences ubinds),DEFAULTcast)
   | Fold cl -> (fold_commands cl,DEFAULTcast)
-  | Pattern lp -> (pattern_occs lp,DEFAULTcast)
+  | Pattern lp -> (pattern_occs (List.map out_with_occurrences lp),DEFAULTcast)
   | ExtraRedExpr s ->
       (try (Stringmap.find s !red_expr_tab,DEFAULTcast)
       with Not_found -> error("unknown user-defined reduction \""^s^"\""))
diff --git a/proofs/redexpr.mli b/proofs/redexpr.mli
index 1c9393d7f..fee3f9813 100644
--- a/proofs/redexpr.mli
+++ b/proofs/redexpr.mli
@@ -17,6 +17,8 @@ open Reductionops
 
 type red_expr = (constr, evaluable_global_reference) red_expr_gen
 
+val out_with_occurrences : 'a with_occurrences -> int list * 'a
+
 val reduction_of_red_expr : red_expr -> reduction_function * cast_kind
 (* [true] if we should use the vm to verify the reduction *)
 
diff --git a/proofs/tacexpr.ml b/proofs/tacexpr.ml
index 89060f9cc..af3eec981 100644
--- a/proofs/tacexpr.ml
+++ b/proofs/tacexpr.ml
@@ -56,7 +56,7 @@ type hyp_location_flag = (* To distinguish body and type of local defs *)
   | InHypTypeOnly
   | InHypValueOnly
 
-type 'a raw_hyp_location = 'a * int list * hyp_location_flag
+type 'a raw_hyp_location = 'a with_occurrences * hyp_location_flag
 
 type 'a induction_arg =
   | ElimOnConstr of 'a
@@ -80,6 +80,7 @@ type 'id message_token =
   | MsgInt of int
   | MsgIdent of 'id
 
+
 type 'id gsimple_clause = ('id raw_hyp_location) option
 (* onhyps:
      [None] means *on every hypothesis*
@@ -87,7 +88,7 @@ type 'id gsimple_clause = ('id raw_hyp_location) option
 type 'id gclause =
   { onhyps : 'id raw_hyp_location list option;
     onconcl : bool;
-    concl_occs :int list }
+    concl_occs : int or_var list }
 
 let nowhere = {onhyps=Some[]; onconcl=false; concl_occs=[]}
 
@@ -175,8 +176,7 @@ type ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_atomic_tactic_expr =
 
   (* Conversion *)
   | TacReduce of ('constr,'cst) red_expr_gen * 'id gclause
-  | TacChange of
-      'constr occurrences option * 'constr * 'id gclause
+  | TacChange of 'constr with_occurrences option * 'constr * 'id gclause
 
   (* Equivalence relations *)
   | TacReflexivity