From 98eaaebc650835403dbe2519e1e4371843d628ad Mon Sep 17 00:00:00 2001
From: Casey Klein <clklein@racket-lang.org>
Date: Sun, 14 Aug 2011 11:10:51 -0500
Subject: [PATCH] Improves error messages for Redex definition forms

---
 collects/redex/private/reduction-semantics.rkt           | 7 +++++++
 .../tests/syn-err-tests/judgment-form-definition.rktd    | 4 ++++
 .../redex/tests/syn-err-tests/language-definition.rktd   | 4 ++++
 .../tests/syn-err-tests/metafunction-definition.rktd     | 9 +++++++++
 4 files changed, 24 insertions(+)

diff --git a/collects/redex/private/reduction-semantics.rkt b/collects/redex/private/reduction-semantics.rkt
index 91226d3cb0..4bad96c671 100644
--- a/collects/redex/private/reduction-semantics.rkt
+++ b/collects/redex/private/reduction-semantics.rkt
@@ -1331,6 +1331,10 @@
     (map (λ (x) (to-lw/proc (datum->syntax #f (cdr (syntax-e x)) x)))
          (syntax->list #'(lhs-for-lw ...)))))
 
+(define-for-syntax (not-expression-context stx)
+  (when (eq? (syntax-local-context) 'expression)
+    (raise-syntax-error #f "not allowed in an expression context" stx)))
+
 ;                                                                                                          
 ;                                                                                                          
 ;                                                                                                          
@@ -1369,6 +1373,7 @@
        (internal-define-metafunction stx #'prev #'rest #f)]))
   
   (define (internal-define-metafunction orig-stx prev-metafunction stx relation?)
+    (not-expression-context orig-stx)
     (syntax-case stx ()
       [(lang . rest)
        (let ([syn-error-name (if relation?
@@ -1532,6 +1537,7 @@
                                    (syntax->list #'(original-names ...)))))))))))))))]))
 
   (define (define-judgment-form/proc stx)
+    (not-expression-context stx)
     (syntax-case stx ()
       [(def-form-id lang . body)
        (let ([lang #'lang]
@@ -2261,6 +2267,7 @@
   parsed)
 
 (define-syntax (define-language stx)
+  (not-expression-context stx)
   (syntax-case stx ()
     [(form-name lang-name . nt-defs)
      (begin
diff --git a/collects/redex/tests/syn-err-tests/judgment-form-definition.rktd b/collects/redex/tests/syn-err-tests/judgment-form-definition.rktd
index 24fc0cb30d..1cb8d0d51a 100644
--- a/collects/redex/tests/syn-err-tests/judgment-form-definition.rktd
+++ b/collects/redex/tests/syn-err-tests/judgment-form-definition.rktd
@@ -1,3 +1,7 @@
+(#rx"define-judgment-form:.*expression context"
+ ([illegal-def (define-judgment-form L #:mode (J) [(J)])])
+ (values illegal-def))
+
 (#rx"expected an identifier defined by define-language"
  ([not-lang q])
  (define-judgment-form not-lang))
diff --git a/collects/redex/tests/syn-err-tests/language-definition.rktd b/collects/redex/tests/syn-err-tests/language-definition.rktd
index b6da94b31f..f85937d8be 100644
--- a/collects/redex/tests/syn-err-tests/language-definition.rktd
+++ b/collects/redex/tests/syn-err-tests/language-definition.rktd
@@ -1,3 +1,7 @@
+(#rx"define-language:.*expression context"
+ ([illegal-def (define-language L)])
+ (values illegal-def))
+
 (#rx"define-language:.*unquote disallowed"
  ([illegal-unquote ,3])
  (let ()
diff --git a/collects/redex/tests/syn-err-tests/metafunction-definition.rktd b/collects/redex/tests/syn-err-tests/metafunction-definition.rktd
index b9c72c6c47..fe5427ca4a 100644
--- a/collects/redex/tests/syn-err-tests/metafunction-definition.rktd
+++ b/collects/redex/tests/syn-err-tests/metafunction-definition.rktd
@@ -1,3 +1,12 @@
+(#rx"define-metafunction:.*expression context"
+ ([illegal-def (define-metafunction syn-err-lang [(f) ()])])
+ (values illegal-def))
+(#rx"define-metafunction/extension:.*expression context"
+ ([illegal-def (define-metafunction/extension f syn-err-lang [(g) ()])])
+ (let ()
+   (define-metafunction syn-err-lang [(f) ()])
+   (values illegal-def)))
+
 (#rx"expected a pattern and a right-hand side"
  ([clause [(f x)]])
  (define-metafunction syn-err-lang