From 42687d26d148151e90f7c005b9db11900572835b Mon Sep 17 00:00:00 2001
From: Casey Klein <clklein@racket-lang.org>
Date: Mon, 18 Oct 2010 21:10:49 -0500
Subject: [PATCH] Reverts most of push #21257.

That push recompiles a clause of an extended metafunction by
replacing the LHS with a recompiled form of the `lhs-pat' field of the
`metafunc-case' struct. But that field (used by the test generator)
also incorporates the clause's `where' and `side-condition' clauses,
causing them to executed twice when applying the recompiled clause (once
while matching its LHS, and once while evaluating its RHS).
---
 collects/redex/private/reduction-semantics.rkt | 15 +++------------
 collects/redex/tests/tl-test.rkt               |  6 +++++-
 2 files changed, 8 insertions(+), 13 deletions(-)

diff --git a/collects/redex/private/reduction-semantics.rkt b/collects/redex/private/reduction-semantics.rkt
index 288603e6e3..579698fe5c 100644
--- a/collects/redex/private/reduction-semantics.rkt
+++ b/collects/redex/private/reduction-semantics.rkt
@@ -1521,16 +1521,8 @@
         (syntax->list stuffs)))
      (syntax->list extras))))
 
-(define (build-metafunction lang cases parent-cases/wrong-lang wrap dom-contract-pat codom-contract-pat name relation?)
-  (let ([parent-cases (map (λ (parent-case) 
-                             (make-metafunc-case
-                              (compile-pattern lang (metafunc-case-lhs-pat parent-case) #t)
-                              (metafunc-case-rhs parent-case)
-                              (metafunc-case-lhs-pat parent-case)
-                              (metafunc-case-src-loc parent-case)
-                              (metafunc-case-id parent-case)))
-                           parent-cases/wrong-lang)]
-        [dom-compiled-pattern (and dom-contract-pat (compile-pattern lang dom-contract-pat #f))]
+(define (build-metafunction lang cases parent-cases wrap dom-contract-pat codom-contract-pat name relation?)
+  (let ([dom-compiled-pattern (and dom-contract-pat (compile-pattern lang dom-contract-pat #f))]
         [codom-compiled-pattern (compile-pattern lang codom-contract-pat #f)])
     (values
      (wrap
@@ -1554,7 +1546,6 @@
                                                         (metafunc-proc-cases r)))
                                         (cover-case id c))))
                                   (relation-coverage))))]
-               [all-cases (append cases parent-cases)]
                [metafunc
                 (λ (exp)
                   (let ([cache-ref (hash-ref cache exp not-in-cache)])
@@ -1565,7 +1556,7 @@
                            (redex-error name
                                         "~s is not in my domain"
                                         `(,name ,@exp))))
-                       (let loop ([cases all-cases]
+                       (let loop ([cases (append cases parent-cases)]
                                   [num (- (length parent-cases))])
                          (cond
                            [(null? cases) 
diff --git a/collects/redex/tests/tl-test.rkt b/collects/redex/tests/tl-test.rkt
index 3684c5d138..29033b51d3 100644
--- a/collects/redex/tests/tl-test.rkt
+++ b/collects/redex/tests/tl-test.rkt
@@ -530,7 +530,9 @@
       [(h number_1) number_1])
     (test (term (g 11 17)) 11)
     (test (term (h 11 17)) 11))
-  
+
+  ; We'd like this expression not to raise an error.
+  #;
   (let ()
     (define-language L 
       (v 1))
@@ -550,6 +552,8 @@
       [(g any) 2])
     (test (term (g 0)) 2))
   
+  ; We'd like this expression not to raise an error.
+  #;
   (let ()
     (define-language L 
       (v 1 (v)))