From c677932bafa1672990f5e53bde1e821dc3567676 Mon Sep 17 00:00:00 2001
From: Ryan Culpepper <ryanc@racket-lang.org>
Date: Fri, 1 Apr 2011 02:12:30 -0600
Subject: [PATCH] syntax/parse: added define/syntax-parse, like
 define/with-syntax

---
 collects/syntax/parse/private/runtime.rkt     | 23 +++++++++--
 collects/syntax/parse/private/sc.rkt          | 41 ++++++++++++++++++-
 .../syntax/scribblings/parse/parsing.scrbl    | 18 ++++++++
 3 files changed, 77 insertions(+), 5 deletions(-)

diff --git a/collects/syntax/parse/private/runtime.rkt b/collects/syntax/parse/private/runtime.rkt
index 34a6ab258f..9dce6f452f 100644
--- a/collects/syntax/parse/private/runtime.rkt
+++ b/collects/syntax/parse/private/runtime.rkt
@@ -23,6 +23,7 @@
          let-attributes
          let-attributes*
          let/unpack
+         defattrs/unpack
          attribute
          attribute-binding
          check-list^depth)
@@ -146,10 +147,11 @@
            (for/and ([part (in-list value)])
              (check-syntax (sub1 depth) part)))))
 
+(define-for-syntax (parse-attr x)
+  (syntax-case x ()
+    [#s(attr name depth syntax?) #'(name depth syntax?)]))
+
 (define-syntax (let-attributes stx)
-  (define (parse-attr x)
-    (syntax-case x ()
-      [#s(attr name depth syntax?) #'(name depth syntax?)]))
   (syntax-case stx ()
     [(let-attributes ([a value] ...) . body)
      (with-syntax ([((name depth syntax?) ...)
@@ -185,6 +187,21 @@
        #'(let-values ([(tmp ...) (apply values packed)])
            (let-attributes ([a tmp] ...) body)))]))
 
+(define-syntax (defattrs/unpack stx)
+  (syntax-case stx ()
+    [(defattrs (a ...) packed)
+     (with-syntax ([((name depth syntax?) ...)
+                    (map parse-attr (syntax->list #'(a ...)))])
+       (with-syntax ([(vtmp ...) (generate-temporaries #'(name ...))]
+                     [(stmp ...) (generate-temporaries #'(name ...))])
+         #'(begin (define-values (vtmp ...) (apply values packed))
+                  (define-syntax stmp
+                    (make-attribute-mapping (quote-syntax vtmp)
+                                            'name 'depth 'syntax?))
+                  ...
+                  (define-syntax name (make-syntax-mapping 'depth (quote-syntax stmp)))
+                  ...)))]))
+
 (define-syntax (attribute stx)
   (parameterize ((current-syntax-context stx))
     (syntax-case stx ()
diff --git a/collects/syntax/parse/private/sc.rkt b/collects/syntax/parse/private/sc.rkt
index ef1095c4c6..a7b38928cf 100644
--- a/collects/syntax/parse/private/sc.rkt
+++ b/collects/syntax/parse/private/sc.rkt
@@ -6,14 +6,14 @@
                      "rep.rkt")
          "parse.rkt"
          "keywords.rkt"
-         "runtime.rkt")
+         "runtime.rkt"
+         "runtime-report.rkt")
 
 (provide define-syntax-class
          define-splicing-syntax-class
 
          syntax-parse
          syntax-parser
-         syntax-parser/template
 
          (except-out (all-from-out "keywords.rkt")
                      ~reflect
@@ -23,7 +23,10 @@
          attribute
          this-syntax
 
+         define/syntax-parse
+
          ;;----
+         syntax-parser/template
          parser/rhs)
 
 (begin-for-syntax
@@ -144,3 +147,37 @@
        (lambda (x)
          (let ([x (datum->syntax #f x)])
            (parse:clauses x clauses one-template ctx))))]))
+
+;; ====
+
+(define-syntax (define/syntax-parse stx)
+  (syntax-case stx ()
+    [(define/syntax-parse pattern . rest)
+     (let-values ([(rest pattern defs)
+                   (parse-pattern+sides #'pattern
+                                        #'rest
+                                        #:splicing? #f
+                                        #:decls (new-declenv null)
+                                        #:context stx)])
+       (let ([expr
+              (syntax-case rest ()
+                [( expr ) #'expr]
+                [_ (raise-syntax-error #f "bad syntax" stx)])]
+             [attrs (pattern-attrs pattern)])
+         (with-syntax ([(a ...) attrs]
+                       [(#s(attr name _ _) ...) attrs]
+                       [pattern pattern]
+                       [(def ...) defs]
+                       [expr expr])
+           #'(defattrs/unpack (a ...)
+               (let* ([x expr]
+                      [cx x]
+                      [pr (ps-empty x x)]
+                      [es null]
+                      [fh0 (syntax-patterns-fail x)])
+                 def ...
+                 (#%expression
+                  (with ([fail-handler fh0]
+                         [cut-prompt fh0])
+                    (parse:S x cx pattern pr es
+                             (list (attribute name) ...)))))))))]))
diff --git a/collects/syntax/scribblings/parse/parsing.scrbl b/collects/syntax/scribblings/parse/parsing.scrbl
index 8d3a32ed89..ac05c0ae44 100644
--- a/collects/syntax/scribblings/parse/parsing.scrbl
+++ b/collects/syntax/scribblings/parse/parsing.scrbl
@@ -137,3 +137,21 @@ Suppresses the ``colon notation'' for annotated pattern variables.
 Like @scheme[syntax-parse], but produces a matching procedure. The
 procedure accepts a single argument, which should be a syntax object.
 }
+
+@defform[(define/syntax-parse syntax-pattern pattern-directive ... stx-expr)
+         #:contracts ([stx-expr syntax?])]{
+
+Definition form of @racket[syntax-parse]. That is, it matches the
+syntax object result of @racket[stx-expr] against
+@racket[syntax-pattern] and creates pattern variable definitions for
+the attributes of @racket[syntax-pattern].
+
+@myexamples[
+(define/syntax-parse ((~seq kw:keyword arg:expr) ...)
+  #'(#:a 1 #:b 2 #:c 3))
+#'(kw ...)
+]
+
+Compare with @racket[define/with-syntax], a similar definition form
+that uses the simpler @racket[syntax-case] patterns.
+}