From e978da8c41d8a3c19a29036d9c569fbe2a4616b0 Mon Sep 17 00:00:00 2001 From: Samuel Mimram Date: Fri, 16 Jun 2006 14:41:51 +0000 Subject: Imported Upstream version 8.0pl3+8.1beta --- proofs/redexpr.ml | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) (limited to 'proofs/redexpr.ml') diff --git a/proofs/redexpr.ml b/proofs/redexpr.ml index 8b3b5f5f..eb47fc2e 100644 --- a/proofs/redexpr.ml +++ b/proofs/redexpr.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: redexpr.ml 7639 2005-12-02 10:01:15Z gregoire $ *) +(* $Id: redexpr.ml 8878 2006-05-30 16:44:25Z herbelin $ *) open Pp open Util @@ -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^"\"")) -- cgit v1.2.3