stxclass: simplified, narrowed provides

svn: r13260

collects/stxclass/main.ss

@@ -2,5 +2,18 @@
 #lang scheme/base
 (require "private/sc.ss"
          "private/lib.ss")
-(provide (all-from-out "private/sc.ss")
+
+(provide define-syntax-class
+         define-basic-syntax-class
+         define-basic-syntax-class*
+         pattern
+
+         syntax-parse
+         syntax-parser
+         with-patterns
+         ...*
+
+         current-expression
+         current-macro-name
+
          (all-from-out "private/lib.ss"))

collects/stxclass/private/lib.ss

@@ -19,7 +19,6 @@
       (let ([d (if (syntax? x) (syntax-e x) x)])
         (if (pred d)
             (list d)
-            ;; (fail-sc x #:pattern 'name)
             #f)))))
 
 (define-pred-stxclass identifier symbol?)
@@ -40,7 +39,6 @@
     (lambda (x)
       (if (and (identifier? x) (free-identifier=? x (quote-syntax kw)))
           null
-          ;; (fail-sc x #:pattern 'name)
           #f))))
 
 (define-kw-stxclass lambda-kw #%lambda)
@@ -60,27 +58,16 @@
   (lambda (x)
     (if (identifier? x)
         (let/ec escape
-          (define (bad)
+          (define (bad) (escape #f))
-            (escape
-             (fail-sc x
-                      #:pattern 'static
-                      #:reason "not bound as syntax")))
           (let ([value (syntax-local-value x bad)])
             (list (syntax-e x) value)))
-        ;;(fail-sc x
-        ;;         #:pattern 'static
-        ;;         #:reason "not an identifier")
         #f)))
 
 (define-basic-syntax-class (static-of name pred)
   ([value 0])
   (lambda (x name pred)
     (let/ec escape
-      (define (bad)
+      (define (bad) (escape #f))
-        (escape ;;(fail-sc x
-                ;;         #:pattern 'name
-                ;;         #:reason (format "not bound as ~a" name))
-         #f))
       (if (identifier? x)
           (let ([value (syntax-local-value x bad)])
             (unless (pred value) (bad))
@@ -97,12 +84,7 @@
   (lambda (x)
     (if (identifier? x)
         (let/ec escape
-          (define (bad)
+          (define (bad) (escape #f))
-            (escape
-             ;;(fail-sc x
-             ;;         #:pattern 'struct-name
-             ;;         #:reason "not bound as a struct name")
-             #f))
           (let ([value (syntax-local-value x bad)])
             (unless (struct-info? value) (bad))
             (let ([lst (extract-struct-info value)])
@@ -115,14 +97,13 @@
                   (list descriptor
                         constructor
                         predicate
-                        (if (and (pair? r-accessors) (eq? #f (car r-accessors)))
+                        (if (and (pair? r-accessors)
+                                 (eq? #f (car r-accessors)))
                             (cdr r-accessors)
                             r-accessors)
                         super
-                        (or (null? r-accessors) (not (eq? #f (car r-accessors))))))))))
+                        (or (null? r-accessors)
-        ;;(fail-sc x
+                            (not (eq? #f (car r-accessors))))))))))
-        ;;         #:pattern 'struct-name
-        ;;         #:reason "not bound as a struct name")
         #f)))
 
 (define-basic-syntax-class expr/local-expand
@@ -178,7 +159,7 @@
   (lambda (x)
     (if (not (keyword? (syntax-e x)))
         (list x)
-        (fail-sc x #:pattern 'expr #:reason "keyword"))))
+        #f)))
 
 ;; FIXME: hack
 (define expr/c-use-contracts? (make-parameter #t))
@@ -196,7 +177,6 @@
                               (quote-syntax #,(syntax/loc x (<there>))))
                   x)
             (list x x))
-        ;;(fail-sc x #:pattern 'expr #:reason "keyword")
         #f)))
 
 (define-basic-syntax-class (term parser)
@@ -208,7 +188,6 @@
   (lambda (x p)
     (if (p x)
         null
-        ;;(fail-sc x #:pattern 'term/pred)
         #f)))
 
 ;; Aliases

collects/stxclass/private/sc.ss

@@ -10,6 +10,7 @@
          syntax/stx
          "kws.ss"
          "messages.ss")
+
 (provide define-syntax-class
          define-basic-syntax-class
          define-basic-syntax-class*
@@ -26,12 +27,57 @@
          pattern
          ...*
 
-         fail-sc
          (struct-out failed)
 
          current-expression
          current-macro-name)
 
+#|
+(begin-for-syntax
+ (define (check-attrlist stx)
+   (syntax-case stx ()
+     [(form ...)
+      (let ([names (for/list ([s (syntax->list #'(form ...))])
+                     (check-attr s)
+                     (stx-car s))])
+        (check-duplicate-identifier names)
+        stx)]
+     [_
+      (raise-syntax-error 'define-syntax-class
+                          "expected attribute table" stx)]))
+ (define stxclass-table
+   `((#:description check-string)
+     (#:attributes check-attrlist)))
+ (define (split-rhss rhss stx)
+   (define-values (chunks rest)
+     (chunk-kw-seq/no-dups rhss stxclass-table  #:context stx))
+   (define (assq* x alist default)
+     (cond [(assq x alist) => cdr]
+           [else default]))
+   (values (cond [(assq '#:attributes chunks) => caddr]
+                 [else null])
+           (cond [(assq '#:description chunks) => caddr]
+                 [else #f])
+           rest)))
+
+(define-syntax (define-syntax-class stx)
+  (syntax-case stx ()
+    [(define-syntax-class (name arg ...) . rhss)
+     (let-values ([(attrs description rhss) (split-rhss #'rhss stx)])
+       #`(begin (define-syntax name
+                  (make sc
+                    'name
+                    '(arg ...)
+                    '#,attrs
+                    ((syntax-local-value) #'parser)
+                    'description))
+                (define parser
+                  (rhs->parser name #,rhss (arg ...) #,stx))))]
+    [(define-syntax-class name . rhss)
+     (syntax/loc stx
+       (define-syntax-class (name) . rhss))]))
+|#
+
 (define-syntax (define-syntax-class stx)
   (syntax-case stx ()
     [(define-syntax-class (name arg ...) . rhss)
@@ -47,21 +93,6 @@
      (syntax/loc stx
        (define-syntax-class (name) . rhss))]))
 
-
-#;
-(define-syntax (define-syntax-splice-class stx)
-  (syntax-case stx ()
-    [(define-syntax-splice-class (name arg ...) . rhss)
-     #`(begin (define-syntax name
-                (make ssc 'name
-                      '(arg ...)
-                      (rhs-attrs
-                       (parse-splice-rhs (quote-syntax rhss) #t (quote-syntax #,stx)))
-                      ((syntax-local-certifier) #'parser)))
-              (define parser (splice-rhs->parser name rhss (arg ...) #,stx)))]
-    [(define-syntax-splice-class name . rhss)
-     (syntax/loc stx (define-syntax-splice-class (name) . rhss))]))
-
 (define-syntax define-basic-syntax-class
   (syntax-rules ()
     [(define-basic-syntax-class (name arg ...)
@@ -212,9 +243,3 @@
      (values x n)]
     [(list-rest _ _ rest)
      (frontier->syntax rest)]))
-
-(define (fail-sc stx #:pattern [pattern #f] #:reason [reason #f])
-  (make-failed stx pattern reason #f))
-
-(define (syntax-class-fail stx #:reason [reason #f])
-  (make-failed stx #f reason #f))