From f14118c0759d6a80f167620e03550c566be98972 Mon Sep 17 00:00:00 2001
From: Ryan Culpepper <ryanc@racket-lang.org>
Date: Thu, 28 Jan 2010 21:08:02 +0000
Subject: [PATCH] syntax/parse: added syntax/parse/experimental

svn: r17873
---
 collects/syntax/parse/experimental.ss | 94 +++++++++++++++++++++++++++
 1 file changed, 94 insertions(+)
 create mode 100644 collects/syntax/parse/experimental.ss

diff --git a/collects/syntax/parse/experimental.ss b/collects/syntax/parse/experimental.ss
new file mode 100644
index 0000000000..90ca5cdf76
--- /dev/null
+++ b/collects/syntax/parse/experimental.ss
@@ -0,0 +1,94 @@
+#lang scheme/base
+(require (for-syntax scheme/base
+                     syntax/parse
+                     syntax/private/stxparse/rep-data))
+(provide define-primitive-splicing-syntax-class)
+
+(define-syntax (define-primitive-splicing-syntax-class stx)
+
+  (define-syntax-class attr
+    (pattern name:id
+             #:with depth #'0)
+    (pattern [name:id depth:nat]))
+
+  (syntax-parse stx
+    [(dssp (name:id param:id ...)
+       (~or (~once (~seq #:attrs (a:attr ...))
+                   #:name "attributes declaration")
+            (~once (~seq #:description description)
+                   #:name "description declaration")) ...
+       proc:expr)
+     #'(begin
+         (define (get-description param ...)
+           description)
+         (define parser
+           (lambda (stx param ...)
+             (let/ec escape
+               ((mk-check-result 'name '(a.name ...) stx)
+                (proc stx
+                      (lambda ([msg #f])
+                        (escape
+                         (if msg
+                             `#s(expect:message ,msg)
+                             `#s(expect:thing
+                                 ,(get-description param ...) #f #f)))))))))
+         (define-syntax name
+           (make-stxclass 'name '(param ...)
+                          '(#s(attr a.name a.depth #f) ...)
+                          (quote-syntax parser)
+                          (quote-syntax get-description)
+                          #t)))]))
+
+
+(define (mk-check-result name attr-names stx)
+  (lambda (result)
+    (unless (list? result)
+      (error name "parser returned non-list"))
+    (let ([rlength (length result)])
+      (unless (= rlength (+ 2 (length attr-names)))
+        (error name "parser returned list of wrong length; expected length ~s, got ~e"
+               (+ 2 (length attr-names))
+               result))
+      (unless (exact-nonnegative-integer? (cadr result))
+        (error name "expected exact nonnegative integer for second element of result list, got ~e"
+               (cadr result)))
+      (list* (car result)
+             (nat->dfc (cadr result) stx)
+             (cddr result)))))
+
+(define (nat->dfc nat stx)
+  (if (zero? nat)
+      `#s(dfc:empty ,stx)
+      `#s(dfc:cdr #s(dfc:empty ,stx) ,nat)))
+
+
+#|
+
+(define-primitive-splicing-syntax-class (name param ...)
+  #:attrs (attr-decl ...)
+  #:description description-expr
+  proc)
+
+'proc' must take two arguments, 'stx' and 'fail', where 'fail' is an
+escaping procedure that indicates failure. 'fail' takes an optional
+argument, an error message to attach to the failure. If no message is
+given, the syntax class description is used.
+
+'proc' must return a list of 2+|attrs| elements. The first element is
+the rest of the input syntax. The second element is the number of
+elements consumed from the input. The rest are the attribute values,
+in the same order as given in the #:attrs directive.
+
+Example:
+
+(define-primitive-splicing-syntax-class (a-expr)
+  #:attrs (x)
+  #:description "a-expr"
+  (lambda (stx fail)
+    (syntax-case stx ()
+      [(a b c . rest)
+       (list #'rest 3 #'(printf "got an A\n"))]
+      [_
+       (fail)])))
+
+|#