stxclass: #:description takes expression now

svn: r13288

collects/stxclass/private/lib.ss

@@ -63,16 +63,18 @@
             (list (syntax-e x) value)))
         #f)))
 
-(define-basic-syntax-class (static-of name pred)
+(define-syntax-class (static-of name pred)
-  ([value 0])
+  #:description name
-  (lambda (x name pred)
+  (basic-syntax-class
-    (let/ec escape
+   ([value 0])
-      (define (bad) (escape #f))
+   (lambda (x name pred)
-      (if (identifier? x)
+     (let/ec escape
-          (let ([value (syntax-local-value x bad)])
+       (define (bad) (escape #f))
-            (unless (pred value) (bad))
+       (if (identifier? x)
-            (list value))
+           (let ([value (syntax-local-value x bad)])
-          (bad)))))
+             (unless (pred value) (bad))
+             (list x value))
+           (bad))))))
 
 (define-basic-syntax-class struct-name
   ([descriptor 0]

collects/stxclass/private/messages.ss

@@ -13,13 +13,17 @@
 (define-struct expc (stxclasses pairs? data literals)
   #:transparent)
 
+(define (make-stxclass-expc scdyn)
+  (make-expc (list scdyn) #f null null))
+
 (begin-for-syntax
   (define certify (syntax-local-certifier))
-  (define (expectation-of-stxclass stxclass)
+  (define (expectation-of-stxclass stxclass args)
     (if stxclass
         (with-syntax ([name (sc-name stxclass)]
-                      [desc (sc-description stxclass)])
+                      [desc-var (sc-description stxclass)]
-          (certify #'(make-expc (list (make-scdyn 'name 'desc)) #f null null)))
+                      [(arg ...) args])
+          (certify #'(make-stxclass-expc (make-scdyn 'name (desc-var arg ...)))))
         #'#f))
 
   (define (expectation-of-constants pairs? data literals)

collects/stxclass/private/parse.ss

@@ -225,18 +225,19 @@
 (define (parse:extpk vars fcs extpk failid)
   (match extpk
     [(struct idpks (stxclass args pks))
-     (with-syntax ([sub-parse-expr
+     (with-syntax ([var0 (car vars)]
-                    (if stxclass
+                   [(arg ...) args]
-                        #`(#,(sc-parser-name stxclass) #,(car vars) #,@args)
+                   [(arg-var ...) (generate-temporaries args)]
-                        #`(list #,(car vars)))]
-                   [var0 (car vars)]
                    [(r) (generate-temporaries #'(r))])
-       #`(let ([r sub-parse-expr])
+       #`(let ([arg-var arg] ...)
-           (if (ok? r)
+           (let ([r #,(if stxclass
-               #,(parse:pks (cdr vars) (cdr fcs) (shift-pks:id pks #'r) failid)
+                          #`(#,(sc-parser-name stxclass) #,(car vars) arg-var ...)
-               #,(fail failid (car vars)
+                          #`(list #,(car vars)))])
-                       #:pattern (expectation-of-stxclass stxclass)
+             (if (ok? r)
-                       #:fc (car fcs)))))]
+                 #,(parse:pks (cdr vars) (cdr fcs) (shift-pks:id pks #'r) failid)
+                 #,(fail failid (car vars)
+                         #:pattern (expectation-of-stxclass stxclass #'(arg-var ...))
+                         #:fc (car fcs))))))]
     [(struct cpks (pairpks datumpkss literalpkss))
      (with-syntax ([var0 (car vars)]
                    [(dvar0) (generate-temporaries (list (car vars)))])

collects/stxclass/private/rep.ss

@@ -45,7 +45,7 @@
 (define-struct attr (name depth inner)
   #:transparent)
 
-;; RHSBase is stx (listof SAttr) boolean string/#f
+;; RHSBase is stx (listof SAttr) boolean stx/#f
 (define-struct rhs (orig-stx attrs transparent? description)
   #:transparent)
 
@@ -315,7 +315,7 @@
 ;; rhs-directive-table
 (define rhs-directive-table
   (list (list '#:literals check-idlist)
-        (list '#:description check-string)
+        (list '#:description values)
         (list '#:transparent)))
 
 ;; parse-pattern : stx(Pattern) env number -> Pattern

collects/stxclass/private/sc.ss

@@ -32,52 +32,6 @@
          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)
@@ -90,8 +44,9 @@
                         '(arg ...)
                         (rhs-attrs the-rhs)
                         ((syntax-local-certifier) #'parser)
-                        (rhs-description the-rhs))))
+                        #'description)))
-              (define parser (rhs->parser name rhss (arg ...) #,stx)))]
+              (define-values (parser description)
+                (rhs->parser+description name rhss (arg ...) #,stx)))]
     [(define-syntax-class name . rhss)
      (syntax/loc stx
        (define-syntax-class (name) . rhss))]))
@@ -128,15 +83,18 @@
         ([attr-name attr-depth] ...)
         (let ([name parser-expr]) name)))]))
 
-(define-syntax (rhs->parser stx)
+(define-syntax (rhs->parser+description stx)
   (syntax-case stx ()
-    [(rhs->parser name rhss (arg ...) ctx)
+    [(rhs->parser+description name rhss (arg ...) ctx)
      (parameterize ((current-syntax-context #'ctx))
        (let ([rhs (parse-rhs #'rhss #f #'ctx)]
              [sc (syntax-local-value #'name)])
-         (parse:rhs rhs
+         #`(values #,(parse:rhs rhs
-                    (sc-attrs sc)
+                                (sc-attrs sc)
-                    (syntax->list #'(arg ...)))))]))
+                                (syntax->list #'(arg ...)))
+                   (lambda (arg ...)
+                     #,(or (rhs-description rhs)
+                           #'(symbol->string 'name))))))]))
 
 (define-syntax (parse-sc stx)
   (syntax-case stx ()
@@ -237,3 +195,52 @@
      (values x n)]
     [(list-rest _ _ rest)
      (frontier->syntax rest)]))
+
+
+
+#|
+(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))]))
+|#
+