From 99d85159b69da057b83e1f2d17eaf75ad7f08e9d Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Sat, 16 Oct 2010 13:17:34 -0500
Subject: [PATCH] adjusted define-metafunction/extension so that it recompiles
 the old cases in the new language

---
 collects/redex/private/reduction-semantics.rkt | 15 ++++++++++++---
 collects/redex/tests/tl-test.rkt               | 12 ++++++++++++
 2 files changed, 24 insertions(+), 3 deletions(-)

diff --git a/collects/redex/private/reduction-semantics.rkt b/collects/redex/private/reduction-semantics.rkt
index 579698fe5c..288603e6e3 100644
--- a/collects/redex/private/reduction-semantics.rkt
+++ b/collects/redex/private/reduction-semantics.rkt
@@ -1521,8 +1521,16 @@
         (syntax->list stuffs)))
      (syntax->list extras))))
 
-(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))]
+(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))]
         [codom-compiled-pattern (compile-pattern lang codom-contract-pat #f)])
     (values
      (wrap
@@ -1546,6 +1554,7 @@
                                                         (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)])
@@ -1556,7 +1565,7 @@
                            (redex-error name
                                         "~s is not in my domain"
                                         `(,name ,@exp))))
-                       (let loop ([cases (append cases parent-cases)]
+                       (let loop ([cases all-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 df64b913be..8ca76607e5 100644
--- a/collects/redex/tests/tl-test.rkt
+++ b/collects/redex/tests/tl-test.rkt
@@ -531,6 +531,18 @@
     (test (term (g 11 17)) 11)
     (test (term (h 11 17)) 11))
   
+  (let ()
+    (define-language L 
+      (v 1))
+    (define-extended-language M
+      L
+      (v .... 2))
+    (define-metafunction L
+      [(f v) v])
+    (define-metafunction/extension f M
+      [(g 17) 17])
+    (test (term (g 2)) 2))
+  
   (let ()
     (define-metafunction empty-language
       [(f any) 1])