From 9e2e11e9c41c6dde3b44d2cd27308033bf95f42b Mon Sep 17 00:00:00 2001
From: Casey Klein <clklein@racket-lang.org>
Date: Tue, 16 Aug 2011 11:04:11 -0500
Subject: [PATCH] Tests metafunction Check Syntax arrows

---
 .../redex/private/reduction-semantics.rkt     |  5 ++-
 collects/redex/tests/check-syntax-test.rkt    | 38 ++++++++++++++++++-
 2 files changed, 40 insertions(+), 3 deletions(-)

diff --git a/collects/redex/private/reduction-semantics.rkt b/collects/redex/private/reduction-semantics.rkt
index 4bad96c671..88a82c09b5 100644
--- a/collects/redex/private/reduction-semantics.rkt
+++ b/collects/redex/private/reduction-semantics.rkt
@@ -2196,7 +2196,10 @@
      (identifier? #'id)
      (let ([v (syntax-local-value #'id (lambda () #f))])
        (if (term-fn? v)
-           #`(make-metafunction #,(term-fn-get-id v))
+           (syntax-property
+            #`(make-metafunction #,(term-fn-get-id v))
+            'disappeared-use
+            (list #'id))
            (raise-syntax-error
             #f
             "not bound as a metafunction"
diff --git a/collects/redex/tests/check-syntax-test.rkt b/collects/redex/tests/check-syntax-test.rkt
index f291f5809e..aa7c5e7ee1 100644
--- a/collects/redex/tests/check-syntax-test.rkt
+++ b/collects/redex/tests/check-syntax-test.rkt
@@ -35,11 +35,12 @@
 (define-namespace-anchor module-anchor)
 (define module-namespace 
   (namespace-anchor->namespace module-anchor))
-(define-values (add-syntax done)
-  (make-traversal module-namespace #f))
 
 ;; judgment forms
 (let ([annotations (new arrow-collector%)])
+  (define-values (add-syntax done)
+    (make-traversal module-namespace #f))
+  
   (define language-def-name #'L)
   (define language-use-name #'L)
   
@@ -72,4 +73,37 @@
              (list (source mode-name) (source render-name))
              (list (source mode-name) (source holds-name)))))
 
+;; metafunctions
+(let ([annotations (new arrow-collector%)])
+  (define-values (add-syntax done)
+    (make-traversal module-namespace #f))
+  
+  (define language-def-name #'L)
+  (define language-use-name #'L)
+  
+  (define contract-name #'f)
+  (define lhs-name #'f)
+  (define rhs-name #'f)
+  (define render-name #'f)
+  (define term-name #'f)
+  
+  (parameterize ([current-annotations annotations]
+                 [current-namespace module-namespace])
+    (add-syntax
+     (expand #`(let ()
+                 (define-language #,language-def-name)
+                 (define-metafunction #,language-use-name
+                   #,contract-name : () -> ()
+                   [(#,lhs-name) (#,rhs-name)])
+                 (render-metafunction #,render-name)
+                 (term (#,term-name)))))
+    (done))
+  
+  (test (send annotations collected-arrows)
+        (set (list (source language-def-name) (source language-use-name))
+             (list (source contract-name) (source lhs-name))
+             (list (source contract-name) (source rhs-name))
+             (list (source contract-name) (source render-name))
+             (list (source contract-name) (source term-name)))))
+
 (print-tests-passed 'check-syntax-test.rkt)
\ No newline at end of file