stxclass: minor improvements to syntax, docs, literals, etc

svn: r11808

collects/macro-debugger/stxclass/info.ss

@@ -1,5 +1,5 @@
 #lang setup/infotab
 
 ;; Not ready yet
-#;(define scribblings '(("stxclass.scrbl")))
+(define scribblings '(("stxclass.scrbl")))
 (define compile-omit-paths '("test.ss"))

collects/macro-debugger/stxclass/private/kws.ss

@@ -2,7 +2,6 @@
 (require scheme/stxparam
          (for-syntax scheme/base))
 (provide pattern
-         union
          ...*
 
          try
@@ -15,13 +14,15 @@
          current-expression
          current-macro-name)
 
-;; (define-syntax-class name SyntaxClassRHS)
-;; (define-syntax-class (name id ...) SyntaxClassRHS)
+;; (define-syntax-class name SyntaxClassDirective* SyntaxClassRHS*)
+;; (define-syntax-class (name id ...) SyntaxClassDirective* SyntaxClassRHS*)
 
-;; A SyntaxClassRHS is one of
+;; A SCDirective is one of
+;;   #:description String
+;;   #:transparent
+
+;; A SyntaxClassRHS is
 ;;   (pattern Pattern PatternDirective ...)
-;;   (union SyntaxClassRHS ...)
-;;   syntax-class-id
 
 ;; A Pattern is one of
 ;;   name:syntaxclass
@@ -56,7 +57,6 @@
       (raise-syntax-error #f "keyword used out of context" stx))))
 
 (define-keyword pattern)
-(define-keyword union)
 (define-keyword ...*)
 (define-keyword ...**)
 
@@ -75,10 +75,15 @@
 (define (current-macro-name)
   (let ([expr (current-expression)])
     (and expr
-         (syntax-case expr ()
+         (syntax-case expr (set!)
+           [(set! kw . _)
+            #'kw]
            [(kw . _)
             (identifier? #'kw)
             #'kw]
+           [kw
+            (identifier? #'kw)
+            #'kw]
            [_ #f]))))
 
 ;; A PatternParseResult is one of
@@ -113,7 +118,8 @@
   (let loop ([f1 frontier1] [f2 frontier2])
     (cond [(and (null? f1) (null? f2))
            ;; FIXME: merge
-           (k x1 `(union ,p1 ,p2) #f frontier1)]
+           (let ([p (and p1 p2 (format "~a; or ~a" p1 p2))])
+             (k x1 p #f frontier1))]
           [(and (pair? f1) (null? f2)) (go1)]
           [(and (null? f1) (pair? f2)) (go2)]
           [(and (pair? f1) (pair? f2))

collects/macro-debugger/stxclass/private/lib.ss

@@ -1,6 +1,7 @@
 #lang scheme/base
 
 (require "sc.ss"
+         "util.ss"
          syntax/stx
          syntax/kerncase
          scheme/struct-info
@@ -49,8 +50,8 @@
 (define-syntax-class define-syntaxes-form
   (pattern (kw:define-syntaxes-kw (var:identifier ...) rhs)))
 (define-syntax-class definition-form
-  (union define-values-form
-         define-syntaxes-form))
+  (pattern :define-values-form)
+  (pattern :define-syntaxes-form))
 
 (define-basic-syntax-class static
   ([datum 0] [value 0])
@@ -123,7 +124,7 @@
    [expr 1])
   (lambda (x)
     (let-values ([(ex1 ex2 defs vdefs sdefs exprs)
-                  (head-local-expand-syntaxes x #f #t)])
+                  (head-local-expand-and-categorize-syntaxes x #f #; #t)])
       (list ex1 ex2 defs vdefs sdefs exprs))))
 
 (define-basic-syntax-class internal-definitions
@@ -135,72 +136,9 @@
    [expr 1])
   (lambda (x)
     (let-values ([(ex1 ex2 defs vdefs sdefs exprs)
-                  (head-local-expand-syntaxes x #t #f)])
+                  (head-local-expand-and-categorize-syntaxes x #t #; #f)])
       (list ex1 ex2 defs vdefs sdefs exprs))))
 
-;; head-local-expand-syntaxes : syntax boolean boolean -> stxs ^ 6
-;; Setting allow-def-after-expr? allows def/expr interleaving.
-;; Setting need-expr? requires at least one expr to be present.
-(define (head-local-expand-syntaxes x allow-def-after-expr? need-expr?)
-  (let ([intdef (syntax-local-make-definition-context)]
-        [ctx '(block)])
-    (let loop ([x x] [ex null] [defs null] [vdefs null] [sdefs null] [exprs null])
-      (cond [(stx-pair? x)
-             (let ([ee (local-expand (stx-car x)
-                                     ctx
-                                     (kernel-form-identifier-list)
-                                     intdef)])
-               (syntax-case ee (begin define-values define-syntaxes)
-                 [(begin e ...)
-                  (loop (append (syntax->list #'(e ...)) (stx-cdr x)) ex defs vdefs sdefs exprs)]
-                 [(begin . _)
-                  (raise-syntax-error #f "bad begin form" ee)]
-                 [(define-values (var ...) rhs)
-                  (andmap identifier? (syntax->list #'(var ...)))
-                  (begin
-                    (when (and (pair? exprs) (not allow-def-after-expr?))
-                      (raise-syntax-error #f "definition after expression" ee))
-                    (syntax-local-bind-syntaxes (syntax->list #'(var ...)) #f intdef)
-                    (loop (stx-cdr x)
-                          (cons ee ex)
-                          (cons ee defs)
-                          (cons ee vdefs)
-                          sdefs
-                          exprs))]
-                 [(define-values . _)
-                  (raise-syntax-error #f "bad define-values form" ee)]
-                 [(define-syntaxes (var ...) rhs)
-                  (andmap identifier? (syntax->list #'(var ...)))
-                  (begin
-                    (when (and (pair? exprs) (not allow-def-after-expr?))
-                      (raise-syntax-error #f "definition after expression" ee))
-                    (syntax-local-bind-syntaxes (syntax->list #'(var ...))
-                                                #'rhs
-                                                intdef)
-                    (loop (stx-cdr x)
-                          (cons ee ex)
-                          (cons ee defs)
-                          vdefs
-                          (cons ee sdefs)
-                          exprs))]
-                 [(define-syntaxes . _)
-                  (raise-syntax-error #f "bad define-syntaxes form" ee)]
-                 [_
-                  (loop (stx-cdr x)
-                        (cons ee ex)
-                        defs
-                        vdefs
-                        sdefs
-                        (cons ee exprs))]))]
-            [(stx-null? x)
-             (let ([ex (reverse ex)])
-               (values ex
-                       ex
-                       (reverse defs)
-                       (reverse vdefs)
-                       (reverse sdefs)
-                       (reverse exprs)))]))))
-
 (define-syntax-rule (define-contract-stxclass name c)
   (define-basic-syntax-class* (name)
     ([orig-stx 0])

collects/macro-debugger/stxclass/private/parse.ss

@@ -72,8 +72,12 @@
 ;; rhs->pks : RHS (listof SAttr) identifier -> (listof PK)
 (define (rhs->pks rhs relsattrs main-var)
   (match rhs
-    [(struct rhs:union (orig-stx attrs rhss))
-     (for*/list ([rhs rhss] [pk (rhs->pks rhs relsattrs main-var)]) pk)]
+    [(struct rhs:union (orig-stx attrs transparent? description patterns))
+     (for*/list ([rhs patterns] [pk (rhs-pattern->pks rhs relsattrs main-var)]) 
+       pk)]))
+
+(define (rhs-pattern->pks rhs relsattrs main-var)
+  (match rhs
     [(struct rhs:pattern (orig-stx attrs pattern decls remap sides))
      (list (make-pk (list pattern)
                     (expr:convert-sides sides
@@ -143,7 +147,7 @@
                                                #:literals literals)])
          (syntax-case rest ()
            [(b)
-            (let* ([pattern (parse-pattern #'p decls)])
+            (let* ([pattern (parse-pattern #'p decls 0)])
               (make-pk (list pattern)
                        (expr:convert-sides sides
                                            (pattern-attrs pattern)
@@ -202,6 +206,55 @@
                #`(let-syntax ([failvar (make-rename-transformer (quote-syntax #,failid))])
                    (try failvar (expr ...))))))]))
 
+(define (report-stxclass stxclass)
+  (and stxclass
+       (format "expected ~a"
+               (or (sc-description stxclass)
+                   (sc-name stxclass)))))
+
+(define (report-constants pairs? data literals)
+  (cond [pairs? #f]
+        [(null? data)
+         (format "expected ~a" (report-choices-literals literals))]
+        [(null? literals)
+         (format "expected ~a" (report-choices-data data))]
+        [else
+         (format "expected ~a; or ~a"
+                 (report-choices-data data)
+                 (report-choices-literals literals))]))
+
+(define (report-choices-literals literals0)
+  (define literals
+    (sort (map syntax-e literals0) 
+          string<? 
+          #:key symbol->string
+          #:cache-keys? #t))
+  (case (length literals)
+    [(1) (format "the literal identifier ~s" (car literals))]
+    [else (format "one of the following literal identifiers: ~a"
+                  (comma-list literals))]))
+
+(define (report-choices-data data)
+  (case (length data)
+    [(1) (format "the datum ~s" (car data))]
+    [else (format "one of the following literals: ~a"
+                  (comma-list data))]))
+
+(define (comma-list items0)
+  (define items (for/list ([item items0]) (format "~s" item)))
+  (define (loop items)
+    (cond [(null? items)
+           null]
+          [(null? (cdr items))
+           (list ", or " (car items))]
+          [else
+           (list* ", " (car items) (loop (cdr items)))]))
+  (case (length items)
+    [(2) (format "~a or ~a" (car items) (cadr items))]
+    [else (let ([strings (list* (car items) (loop (cdr items)))])
+            (apply string-append strings))]))
+
+
 ;; parse:extpk : (listof identifier) (listof FC) ExtPK identifier -> stx
 ;; Pre: vars is not empty
 (define (parse:extpk vars fcs extpk failid)
@@ -217,7 +270,7 @@
            (if (ok? r)
                #,(parse:pks (cdr vars) (cdr fcs) (shift-pks:id pks #'r) failid)
                #,(fail failid (car vars)
-                       #:pattern (and stxclass (sc-name stxclass))
+                       #:pattern (report-stxclass stxclass)
                        #:fc (car fcs)))))]
     [(struct cpks (pairpks datumpkss literalpkss))
      (with-syntax ([var0 (car vars)]
@@ -270,13 +323,13 @@
                           #'())
                    [datum-test datum-rhs] ...
                    [else
-                    #,(let ([ps #'(pair-pattern ... datum-pattern ...)])
-                        (with-syntax ([ep (if (= (length (syntax->list ps)) 1)
-                                              (car (syntax->list ps))
-                                              #`(union #,@ps))])
-                          (fail failid (car vars)
-                                #:pattern #'ep
-                                #:fc (car fcs))))]))))]
+                    #,(fail failid (car vars)
+                            #:pattern (report-constants (pair? pairpks)
+                                                        (for/list ([d datumpkss])
+                                                                  (datumpks-datum d))
+                                                        (for/list ([l literalpkss])
+                                                                  (literalpks-literal l)))
+                            #:fc (car fcs))]))))]
     #;
     [(struct pk ((cons (struct pat:splice (orig-stx attrs depth head tail))
                        rest-ps)

collects/macro-debugger/stxclass/private/rep.ss

@@ -31,7 +31,7 @@
          format-symbol)
 
 ;; An SC is one of (make-sc symbol (listof symbol) (list-of SAttr) identifier)
-(define-struct sc (name inputs attrs parser-name)
+(define-struct sc (name inputs attrs parser-name description)
   #:property prop:procedure (lambda (self stx) (sc-parser-name self))
   #:transparent)
 
@@ -44,13 +44,19 @@
 (define-struct attr (name depth inner)
   #:transparent)
 
-;; A RHS is one of
-;;   (make-rhs:union <RHS> (listof RHS))
-;;   (make-rhs:pattern <RHS> Pattern Env Env (listof SideClause))
-;; where <RHS> is stx (listof SAttr)
-(define-struct rhs (orig-stx attrs) #:transparent)
-(define-struct (rhs:union rhs) (rhss) #:transparent)
-(define-struct (rhs:pattern rhs) (pattern decls remap wheres) #:transparent)
+;; RHSBase is stx (listof SAttr)
+(define-struct rhs (orig-stx attrs)
+  #:transparent)
+
+;; A RHS is 
+;;   (make-rhs:union <RHSBase> (listof RHS))
+(define-struct (rhs:union rhs) (transparent? description patterns)
+  #:transparent)
+
+;; An RHSPattern is
+;;   (make-rhs:pattern <RHSBase> Pattern Env Env (listof SideClause))
+(define-struct (rhs:pattern rhs) (pattern decls remap wheres)
+  #:transparent)
 
 ;; A Pattern is one of
 ;;   (make-pat:id <Pattern> identifier SC/#f (listof stx))
@@ -88,7 +94,7 @@
 ;; make-empty-sc : identifier => SC
 ;; Dummy stxclass for calculating attributes of recursive stxclasses.
 (define (make-empty-sc name)
-  (make sc (syntax-e name) null null #f))
+  (make sc (syntax-e name) null null #f #f))
 
 (define (iattr? a)
   (and (attr? a) (identifier? (attr-name a))))
@@ -101,8 +107,8 @@
  [sattr? (any/c . -> . boolean?)]
  [reorder-iattrs
   ((listof sattr?) (listof iattr?) (identifier? . -> . symbol?) . -> . (listof iattr?))]
- [parse-rhs (syntax? boolean? . -> . rhs?)]
- [parse-splice-rhs (syntax? boolean? . -> . rhs?)]
+ [parse-rhs (syntax? boolean? syntax? . -> . rhs?)]
+ [parse-splice-rhs (syntax? boolean? syntax? . -> . rhs?)]
  [flatten-sattrs
   ([(listof sattr?)] [exact-integer? (or/c symbol? false/c)] . ->* . (listof sattr?))]
 
@@ -208,25 +214,51 @@
 
 (define allow-unbound-stxclasses (make-parameter #f))
 
-;; parse-rhs : stx(SyntaxClassRHS) boolean -> RHS
+;; parse-rhs : stx(SyntaxClassRHS) boolean stx -> RHS
 ;; If allow-unbound? is true, then unbound stxclass acts as if it has no attrs.
 ;; Used for pass1 (attr collection); parser requires stxclasses to be bound.
-(define (parse-rhs stx allow-unbound?)
-  (parse-rhs* stx allow-unbound? #f))
+(define (parse-rhs stx allow-unbound? ctx)
+  (parse-rhs* stx allow-unbound? #f ctx))
 
-;; parse-splice-rhs : stx(SyntaxClassRHS) boolean -> RHS
+;; parse-splice-rhs : stx(SyntaxClassRHS) boolean stx -> RHS
 ;; If allow-unbound? is true, then unbound stxclass acts as if it has no attrs.
 ;; Used for pass1 (attr collection); parser requires stxclasses to be bound.
-(define (parse-splice-rhs stx allow-unbound?)
-  (parse-rhs* stx allow-unbound? #t))
+(define (parse-splice-rhs stx allow-unbound? ctx)
+  (parse-rhs* stx allow-unbound? #t ctx))
 
 ;; parse-rhs* : stx boolean boolean -> RHS
-(define (parse-rhs* stx allow-unbound? splice?)
-  (syntax-case stx (pattern union)
+(define (parse-rhs* stx allow-unbound? splice? ctx)
+  (define-values (chunks rest)
+    (chunk-kw-seq stx rhs-directive-table #:context ctx))
+  (define lits (assq '#:literals chunks))
+  (define desc (assq '#:description chunks))
+  (define trans (assq '#:transparent chunks))
+  (define literals (if lits (caddr lits) null))
+  (define (gather-patterns stx)
+    (syntax-case stx (pattern)
+      [((pattern . _) . rest)
+       (cons (parse-rhs-pattern (stx-car stx) allow-unbound? splice? literals)
+             (gather-patterns #'rest))]
+      [()
+       null]))
+  (define patterns (gather-patterns rest))
+  (when (null? patterns)
+        (raise-syntax-error #f "syntax class has no variants" ctx))
+  (let ([sattrs (intersect-attrss (map rhs-attrs patterns) ctx)])
+    (make rhs:union stx sattrs 
+          (and desc (caddr desc)) 
+          (and trans #t)
+          patterns)))
+
+;; parse-rhs-pattern : stx boolean boolean (listof identifier) -> RHS
+(define (parse-rhs-pattern stx allow-unbound? splice? literals)
+  (syntax-case stx (pattern)
     [(pattern p . rest)
      (parameterize ((allow-unbound-stxclasses allow-unbound?))
        (let-values ([(rest decls remap clauses)
-                     (parse-pattern-directives #'rest #:sc? #t)])
+                     (parse-pattern-directives #'rest
+                                               #:literals literals
+                                               #:sc? #t)])
          (unless (stx-null? rest)
            (raise-syntax-error #f "unexpected terms after pattern directives"
                                (if (pair? rest) (car rest) rest)))
@@ -241,25 +273,16 @@
                               (map pattern-attrs with-patterns))
                         stx)]
                 [sattrs (iattrs->sattrs attrs remap)])
-           (make rhs:pattern stx sattrs pattern decls remap clauses))))]
-    [(union p ...)
-     (let* ([rhss (for/list ([rhs (syntax->list #'(p ...))])
-                    (parse-rhs* rhs allow-unbound? splice?))]
-            [sattrs (intersect-attrss (map rhs-attrs rhss) stx)])
-       (make rhs:union stx sattrs rhss))]
-    [(id arg ...)
-     (identifier? #'id)
-     (parse-rhs* (syntax/loc stx (pattern || #:declare || (id arg ...)))
-                 allow-unbound?
-                 splice?)]
-    [id
-     (identifier? #'id)
-     (parse-rhs* (syntax/loc stx (pattern || #:declare || id))
-                 allow-unbound?
-                 splice?)]))
+           (make rhs:pattern stx sattrs pattern decls remap clauses))))]))
+
+;; rhs-directive-table
+(define rhs-directive-table
+  (list (list '#:literals check-idlist)
+        (list '#:description check-string)
+        (list '#:transparent)))
 
 ;; parse-pattern : stx(Pattern) env number -> Pattern
-(define (parse-pattern stx [decls (lambda _ #f)] [depth 0] [allow-splice? #f])
+(define (parse-pattern stx decls depth [allow-splice? #f])
   (syntax-case stx ()
     [dots
      (or (dots? #'dots)
@@ -354,12 +377,6 @@
      (raise-syntax-error 'pattern "expected sequence of patterns or sequence directive"
                          (if (pair? stx) (car stx) stx))]))
 
-(define (check-nat/f stx)
-  (let ([d (syntax-e stx)])
-    (unless (nat/f d)
-      (raise-syntax-error #f "expected exact nonnegative integer or #f" stx))
-    stx))
-
 (define head-directive-table
   (list (list '#:min check-nat/f)
         (list '#:max check-nat/f)
@@ -369,7 +386,7 @@
         (list '#:mand)))
 
 (define (parse-heads-k stx heads heads-attrs heads-depth k)
-  (define-values (chunks rest) (chunk-kw-seq stx head-directive-table))
+  (define-values (chunks rest) (chunk-kw-seq/no-dups stx head-directive-table))
   (reject-duplicate-chunks chunks)
   (let* ([min-row (assq '#:min chunks)]
          [max-row (assq '#:max chunks)]
@@ -412,10 +429,6 @@
        (and occurs-row (caddr occurs-row))
        (and default-row (caddr default-row)))))
 
-;; nat/f : any -> boolean
-(define (nat/f x)
-  (or (not x) (exact-nonnegative-integer? x)))
-
 ;; append-attrs : (listof (listof IAttr)) stx -> (listof IAttr)
 (define (append-attrs attrss stx)
   (let* ([all (apply append attrss)]

collects/macro-debugger/stxclass/private/sc.ss

@@ -10,7 +10,6 @@
          syntax/stx
          "kws.ss")
 (provide define-syntax-class
-         define-syntax-splice-class
          define-basic-syntax-class
          define-basic-syntax-class*
          parse-sc
@@ -24,7 +23,6 @@
          with-patterns
 
          pattern
-         union
          ...*
 
          fail-sc
@@ -35,27 +33,32 @@
 
 (define-syntax (define-syntax-class stx)
   (syntax-case stx ()
-    [(define-syntax-class (name arg ...) rhs)
-     #'(begin (define-syntax name
-                (make sc 'name
-                         '(arg ...)
-                         (rhs-attrs (parse-rhs (quote-syntax rhs) #t))
-                         ((syntax-local-certifier) #'parser)))
-              (define parser (rhs->parser name rhs (arg ...))))]
-    [(define-syntax-class name rhs)
-     #'(define-syntax-class (name) rhs)]))
+    [(define-syntax-class (name arg ...) . rhss)
+     #`(begin (define-syntax name
+                (let ([the-rhs (parse-rhs (quote-syntax rhss) #t (quote-syntax #,stx))])
+                  (make sc 'name
+                        '(arg ...)
+                        (rhs-attrs the-rhs)
+                        ((syntax-local-certifier) #'parser)
+                        (rhs:union-description the-rhs))))
+              (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-splice-class stx)
   (syntax-case stx ()
-    [(define-syntax-splice-class (name arg ...) rhs)
-     #'(begin (define-syntax name
+    [(define-syntax-splice-class (name arg ...) . rhss)
+     #`(begin (define-syntax name
                 (make ssc 'name
                       '(arg ...)
-                      (rhs-attrs (parse-splice-rhs (quote-syntax rhs) #t))
+                      (rhs-attrs
+                       (parse-splice-rhs (quote-syntax rhss) #t (quote-syntax #,stx)))
                       ((syntax-local-certifier) #'parser)))
-              (define parser (splice-rhs->parser name rhs (arg ...))))]
-    [(define-syntax-splice-class name rhs)
-     #'(define-syntax-splice-class (name) rhs)]))
+              (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 ()
@@ -89,12 +92,13 @@
               (make sc 'name
                     '(arg ...)
                     (list (make-attr 'attr-name 'attr-depth null) ...)
-                    ((syntax-local-certifier) #'parser))))]))
+                    ((syntax-local-certifier) #'parser)
+                    #f)))]))
 
 (define-syntax (rhs->parser stx)
   (syntax-case stx ()
-    [(rhs->parser name rhs (arg ...))
-     (let ([rhs (parse-rhs #'rhs #f)]
+    [(rhs->parser name rhss (arg ...) ctx)
+     (let ([rhs (parse-rhs #'rhss #f #'ctx)]
            [sc (syntax-local-value #'name)])
        (parse:rhs rhs
                   (sc-attrs sc)
@@ -182,7 +186,7 @@
            [_
             (err "expected end of list" x)])]
         [expected
-         (err (format "expected ~s~a"
+         (err (format "~a~a"
                       expected
                       (cond [(zero? n) ""]
                             [(= n +inf.0) " after matching main pattern"]
@@ -204,3 +208,6 @@
 
 (define (fail-sc stx #:pattern [pattern #f] #:reason [reason #f])
   (make-failed stx pattern reason))
+
+(define (syntax-class-fail stx #:reason [reason #f])
+  (make-failed stx #f reason))

collects/macro-debugger/stxclass/private/util.ss

@@ -3,37 +3,22 @@
 (require (for-syntax scheme/base
                      scheme/struct-info)
          syntax/boundmap
+         syntax/kerncase
          syntax/stx)
+
 (provide make
 
          chunk-kw-seq/no-dups
          chunk-kw-seq
          reject-duplicate-chunks
          check-id
-#|
-         monomap?
-         monomap-get
-         monomap-put!
-         monomap-map
-         monomap-for-each
-         monomap-domain
-         monomap-range
+         check-nat/f
+         check-string
+         check-idlist
 
-         isomap?
-         isomap-get
-         isomap-reverse-get
-         isomap-put!
-         isomap-map
-         isomap-for-each
-         isomap-domain
-         isomap-range
-         
-         make-bound-id-monomap
-         make-free-id-monomap
-         make-hash-monomap
-         (rename-out [-make-isomap make-isomap])
-|#
-         )
+         head-local-expand-and-categorize-syntaxes
+         categorize-expanded-syntaxes
+         head-local-expand-syntaxes)
 
 (define-syntax (make stx)
   (syntax-case stx ()
@@ -80,7 +65,8 @@
               [arity (cdr (assq kw-value kws))]
               [args+rest (stx-split #'more arity)])
          (if args+rest
-             (loop (cdr args+rest) (cons (list* kw-value #'kw (car args+rest)) rchunks))
+             (loop (cdr args+rest)
+                   (cons (list* kw-value #'kw (car args+rest)) rchunks))
              (raise-syntax-error #f "too few arguments for keyword" #'kw ctx)))]
       [(kw . more)
        (keyword? (syntax-e #'kw))
@@ -90,13 +76,14 @@
   (loop stx null))
 
 (define (reject-duplicate-chunks chunks #:context [ctx #f])
+  (define kws (make-hasheq))
   (define (loop chunks)
     (when (pair? chunks)
-      (let* ([kw (caar chunks)]
-             [dup (assq kw (cdr chunks))])
-        (when dup
-          (raise-syntax-error #f "duplicate keyword argument" (cadr dup) ctx))
-        (loop (cdr chunks)))))
+      (let ([kw (caar chunks)])
+        (when (hash-ref kws kw #f)
+          (raise-syntax-error #f "duplicate keyword argument" (cadar chunks) ctx))
+        (hash-set! kws kw #t))
+      (loop (cdr chunks))))
   (loop chunks))
 
 ;; stx-split : stx nat -> (cons (listof stx) stx)
@@ -115,6 +102,104 @@
     (raise-syntax-error 'pattern "expected identifier" stx))
   stx)
 
+(define (check-string stx)
+  (unless (string? (syntax-e stx))
+    (raise-syntax-error #f "expected string" stx))
+  stx)
+
+;; nat/f : any -> boolean
+(define (nat/f x)
+  (or (not x) (exact-nonnegative-integer? x)))
+
+(define (check-nat/f stx)
+  (let ([d (syntax-e stx)])
+    (unless (nat/f d)
+      (raise-syntax-error #f "expected exact nonnegative integer or #f" stx))
+    stx))
+
+(define (check-idlist stx)
+  (unless (and (stx-list? stx) (andmap identifier? (stx->list stx)))
+    (raise-syntax-error #f "expected list of identifiers" stx))
+  (stx->list stx))
+
+
+;; head-local-expand-syntaxes : syntax boolean boolean -> stxs ^ 6
+;; Setting allow-def-after-expr? allows def/expr interleaving.
+(define (head-local-expand-and-categorize-syntaxes x allow-def-after-expr?)
+  (define estxs (head-local-expand-syntaxes x allow-def-after-expr?))
+  (define-values (defs vdefs sdefs exprs)
+    (categorize-expanded-syntaxes estxs))
+  (values estxs estxs defs vdefs sdefs exprs))
+
+(define (categorize-expanded-syntaxes estxs0)
+  (let loop ([estxs estxs0] [defs null] [vdefs null] [sdefs null] [exprs null])
+    (cond [(pair? estxs)
+           (let ([ee (car estxs)])
+             (syntax-case ee (begin define-values define-syntaxes)
+               [(define-values . _)
+                (loop (cdr estxs)
+                      (cons ee defs)
+                      (cons ee vdefs)
+                      sdefs
+                      exprs)]
+               [(define-syntaxes (var ...) rhs)
+                (loop (cdr estxs)
+                      (cons ee defs)
+                      vdefs
+                      (cons ee sdefs)
+                      exprs)]
+               [_
+                (loop (cdr estxs)
+                      defs
+                      vdefs
+                      sdefs
+                      (cons ee exprs))]))]
+          [(null? estxs)
+           (values (reverse defs)
+                   (reverse vdefs)
+                   (reverse sdefs)
+                   (reverse exprs))])))
+
+;; head-local-expand-syntaxes : syntax boolean -> (listof syntax)
+(define (head-local-expand-syntaxes x allow-def-after-expr?)
+  (let ([intdef (syntax-local-make-definition-context)]
+        [ctx '(block)])
+    (let loop ([x x] [ex null] [expr? #f])
+      (cond [(stx-pair? x)
+             (let ([ee (local-expand (stx-car x)
+                                     ctx
+                                     (kernel-form-identifier-list)
+                                     intdef)])
+               (syntax-case ee (begin define-values define-syntaxes)
+                 [(begin e ...)
+                  (loop (append (syntax->list #'(e ...)) (stx-cdr x)) ex expr?)]
+                 [(begin . _)
+                  (raise-syntax-error #f "bad begin form" ee)]
+                 [(define-values (var ...) rhs)
+                  (andmap identifier? (syntax->list #'(var ...)))
+                  (begin
+                    (when (and expr? (not allow-def-after-expr?))
+                      (raise-syntax-error #f "definition after expression" ee))
+                    (syntax-local-bind-syntaxes (syntax->list #'(var ...)) #f intdef)
+                    (loop (stx-cdr x) (cons ee ex) expr?))]
+                 [(define-values . _)
+                  (raise-syntax-error #f "bad define-values form" ee)]
+                 [(define-syntaxes (var ...) rhs)
+                  (andmap identifier? (syntax->list #'(var ...)))
+                  (begin
+                    (when (and expr? (not allow-def-after-expr?))
+                      (raise-syntax-error #f "definition after expression" ee))
+                    (syntax-local-bind-syntaxes (syntax->list #'(var ...))
+                                                #'rhs
+                                                intdef)
+                    (loop (stx-cdr x) (cons ee ex) expr?))]
+                 [(define-syntaxes . _)
+                  (raise-syntax-error #f "bad define-syntaxes form" ee)]
+                 [_
+                  (loop (stx-cdr x) (cons ee ex) #t)]))]
+            [(stx-null? x)
+             (reverse ex)]))))
+
 
 #|
 ;; Mappings

collects/macro-debugger/stxclass/stxclass.scrbl

@@ -2,14 +2,14 @@
 
 @(require scribble/manual
           scribble/struct
-          (for-label stxclass/stxclass))
+          (for-label macro-debugger/stxclass/stxclass))
 
 @title{Parsing Syntax and Syntax Classes}
 
-@defmodule[stxclass/stxclass]
+@defmodule[macro-debugger/stxclass/stxclass]
 
 @section{Parsing Syntax}
-@declare-exporting[stxclass/stxclass]
+@declare-exporting[macro-debugger/stxclass/stxclass]
 
 @defform/subs[(syntax-parse stx-expr maybe-literals clause ...)
               ([maybe-literals code:blank
@@ -222,7 +222,7 @@ generalized sequences. It may not be used as an expression.
 }
 
 @section{Syntax Classes}
-@declare-exporting[stxclass/stxclass]
+@declare-exporting[macro-debugger/stxclass/stxclass]
 
 Syntax classes provide an abstraction mechanism for the specification
 of syntax. Basic syntax classes include @scheme[identifier] and
@@ -239,30 +239,43 @@ syntax. While the values of the attributes depend on the matched
 syntax, the set of attributes and each attribute's ellipsis nesting
 depth is fixed for each syntax class.
 
-@defform*/subs[#:literals (union pattern)
-               [(define-syntax-class name-id stxclass-body)
-                (define-syntax-class (name-id arg-id ...) stxclass-body)]
-               ([stxclass-body 
-                 (union stxclass-body ...)
+@defform*/subs[#:literals (pattern)
+               [(define-syntax-class name-id stxclass-option ...
+                  stxclass-variant ...)
+                (define-syntax-class (name-id arg-id ...) stxclass-option ... 
+                  stxclass-variant ...)]
+               ([stxclass-options
+                 (code:line #:description string)
+                 (code:line #:transparent)]
+                [stxclass-variant 
                  (pattern syntax-pattern pattern-directive ...)])]{
 
 Defines @scheme[name-id] as a syntax class. When the @scheme[arg-id]s
 are present, they are bound as variables (not pattern variables) in
 the body.
 
-The body of the syntax-class definition specifies the syntax it
-accepts and determines the attributes it provides.
+The body of the syntax-class definition contains one or more variants
+that specify the syntax it accepts and determines the attributes it
+provides. The syntax class provides only those attributes which are
+present in every variant. Each such attribute must be defined with the
+same ellipsis nesting depth and the same sub-attributes in each
+component.
 
-@specsubform[#:literals (union)
-             (union stxclass-body ...)]{
+@specsubform[(code:line #:description string)]{
 
-Accepts any syntax accepted by one of the component bodies.
-
-Provides only those attributes which are present in every component
-body. Each such attribute must be defined with the same ellipsis
-nesting depth and the same sub-attributes in each component.
+Specifies a string to use in error messages involving the syntax
+class. For example, if a term is rejected by the syntax class, an
+error of the form @scheme["expected <description>"] may be generated.
 
+If absent, the name of the syntax class is used instead.
 }
+
+@specsubform[#:transparent]{
+
+Indicates that errors may be reported with respect to the internal
+structure of the syntax class.
+}
+
 @specsubform/subs[#:literals (pattern)
                   (pattern syntax-pattern pattern-directive ...)
                   ([stxclass-pattern-directive
@@ -320,17 +333,12 @@ match only proper lists:
 
 }
 
-@deftogether[(
-@defidform[union]
-@defidform[pattern]
-)]{
-
-Keywords recognized by @scheme[define-syntax-class]. They may not be
-used as expressions.
+@defidform[pattern]{
 
+Keyword recognized by @scheme[define-syntax-class]. It may not be
+used as an expression.
 }
 
-
 @defform[(define-basic-syntax-class (name-id arg-id ...)
            ([attr-id attr-depth] ...)
            parser-expr)]{
@@ -390,7 +398,7 @@ the @scheme[arg-expr]s) on the syntax object produced by
 
 
 @section{Library syntax classes}
-@declare-exporting[stxclass/stxclass]
+@declare-exporting[macro-debugger/stxclass/stxclass]
 
 @(define-syntax-rule (defstxclass name . pre-flows)
    (defidform name . pre-flows))