From d6ddbe15d59c03913e977489d2c51fdc29aebde5 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Wed, 9 Jun 2010 13:05:02 -0400
Subject: [PATCH] support kw/opt args in `define-syntax' and
 `define-for-syntax'

---
 collects/racket/private/pre-base.rkt | 30 ++++++++++++++++++++++++++--
 collects/tests/racket/syntax.rktl    | 15 ++++++++++++++
 2 files changed, 43 insertions(+), 2 deletions(-)

diff --git a/collects/racket/private/pre-base.rkt b/collects/racket/private/pre-base.rkt
index a9326cde0b..7a72f1801c 100644
--- a/collects/racket/private/pre-base.rkt
+++ b/collects/racket/private/pre-base.rkt
@@ -5,7 +5,7 @@
   (#%require (for-syntax '#%kernel))
   (#%require "more-scheme.rkt"
              "misc.rkt"
-             (all-except "define.rkt" define)
+             (all-except "define.rkt" define define-syntax define-for-syntax)
              "letstx-scheme.rkt"
              "kw.rkt"
              "define-struct.rkt"
@@ -15,7 +15,9 @@
              "map.rkt" ; shadows #%kernel bindings
              "kernstruct.rkt"
              "norm-arity.rkt"
-             '#%builtin) ; so it's attached
+             '#%builtin  ; so it's attached
+             (for-syntax "kw.rkt"
+                         "norm-define.rkt"))
 
   (define-syntaxes (#%top-interaction)
     (lambda (stx)
@@ -77,6 +79,28 @@
          (keyword-apply proc kws kw-args (apply list* args rest))))
      keyword-apply))
 
+  (define-syntaxes (new-define-syntax)
+    (lambda (stx)
+      (let-values ([(id rhs)
+                    (normalize-definition stx (quote-syntax new-lambda) #t #t)]
+                   [(def) (quote-syntax define-syntaxes)])
+        (datum->syntax
+         def
+         (list def (list id) rhs)
+         stx
+         stx))))
+
+  (define-syntaxes (new-define-for-syntax)
+    (lambda (stx)
+      (let-values ([(id rhs)
+                    (normalize-definition stx (quote-syntax new-lambda) #t #t)]
+                   [(def) (quote-syntax define-values-for-syntax)])
+        (datum->syntax
+         def
+         (list def (list id) rhs)
+         stx
+         stx))))
+
   (#%provide (all-from-except "more-scheme.rkt" old-case fluid-let)
              (all-from "misc.rkt")
              (all-from "define.rkt")
@@ -84,6 +108,8 @@
              (rename new-lambda lambda)
              (rename new-λ λ)
              (rename new-define define)
+             (rename new-define-syntax define-syntax)
+             (rename new-define-for-syntax define-for-syntax)
              (rename new-app #%app)
              (rename new-apply apply)
              new-apply-proc ; for access by Typed Racket
diff --git a/collects/tests/racket/syntax.rktl b/collects/tests/racket/syntax.rktl
index 4e187177d4..b815cd1dc4 100644
--- a/collects/tests/racket/syntax.rktl
+++ b/collects/tests/racket/syntax.rktl
@@ -1329,6 +1329,21 @@
             (define (a) (m)))
           (m))))
 
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Check keyword & optionals for define-syntax 
+;; and define-syntax-for-values:
+
+(test (list 7 #f)
+      'dfs/kw
+      (eval
+       '(begin
+          (define-for-syntax (kw/f #:x a b)
+            `(list ,a ,b))
+          (define-syntax (kw/g stx #:opt [opt #f])
+            (syntax-case stx ()
+              [(_ v) (datum->syntax stx (kw/f #:x #'v opt))]))
+          (kw/g 7))))
+      
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (report-errs)