syntax/parse: refactored some parsing/checking code

collects/syntax/parse/private/rep.rkt

@@ -51,6 +51,12 @@
   (-> syntax?
       #:context syntax?
       arity?)]
+ [check-stxclass-header
+  (-> syntax? syntax?
+      (list/c identifier? syntax? arity?))]
+ [check-stxclass-application
+  (-> syntax? syntax?
+      (cons/c identifier? arguments?))]
  [check-literals-list/litset
   (-> syntax? syntax?
       (listof (list/c identifier? identifier?)))]
@@ -728,15 +734,8 @@ A syntax class is integrable if
        (values #f null #f)]
       [(~var _name sc/sc+args . rest)
        (let-values ([(sc argu)
-                     (syntax-case #'sc/sc+args ()
+                     (let ([p (check-stxclass-application #'sc/sc+args stx)])
-                       [sc
+                       (values (car p) (cdr p)))])
-                        (identifier? #'sc)
-                        (values #'sc no-arguments)]
-                       [(sc arg ...)
-                        (identifier? #'sc)
-                        (values #'sc (parse-argu (syntax->list #'(arg ...))))]
-                       [_
-                        (wrong-syntax stx "bad ~~var form")])])
          (define chunks
            (parse-keyword-options/eol #'rest var-pattern-directive-table
                                       #:no-duplicates? #t
@@ -1427,19 +1426,33 @@ A syntax class is integrable if
            (raise-syntax-error #f "expected identifier convention pattern"
                                ctx blame)]))
   (define (check-sc-expr x rx)
-    (syntax-case x ()
+    (let ([x (check-stxclass-application x ctx)])
-      [sc
+      (make den:class rx (car x) (cdr x))))
-       (identifier? #'sc)
-       (make den:class rx #'sc no-arguments)]
-      [(sc arg ...)
-       (identifier? #'sc)
-       (make den:class rx #'sc (parse-argu (syntax->list #'(arg ...))))]
-      [_ (raise-syntax-error #f "expected syntax class use" ctx x)]))
   (syntax-case stx ()
     [(rx sc)
      (let ([name-pattern (check-conventions-pattern (syntax-e #'rx) #'rx)])
-       (list name-pattern
+       (list name-pattern (check-sc-expr #'sc name-pattern)))]))
-             (check-sc-expr #'sc name-pattern)))]))
+
+(define (check-stxclass-header stx ctx)
+  (syntax-case stx ()
+    [name
+     (identifier? #'name)
+     (list #'name #'() no-arity)]
+    [(name . formals)
+     (identifier? #'name)
+     (list #'name #'formals (parse-kw-formals #'formals #:context ctx))]
+    [_ (raise-syntax-error #f "expected syntax class header" stx ctx)]))
+
+(define (check-stxclass-application stx ctx)
+  ;; Doesn't check "operator" is actually a stxclass
+  (syntax-case stx ()
+    [op
+     (identifier? #'op)
+     (cons #'op no-arguments)]
+    [(op arg ...)
+     (identifier? #'op)
+     (cons #'op (parse-argu (syntax->list #'(arg ...))))]
+    [_ (raise-syntax-error #f "expected syntax class use" ctx stx)]))
 
 ;; bind clauses
 (define (check-bind-clause-list stx ctx)

collects/syntax/parse/private/sc.rkt

@@ -30,19 +30,20 @@
          parser/rhs)
 
 (begin-for-syntax
- (define (defstxclass stx name formals rhss splicing?)
+ (define (defstxclass stx header rhss splicing?)
    (parameterize ((current-syntax-context stx))
+     (let-values ([(name formals arity)
+                   (let ([p (check-stxclass-header header stx)])
+                     (values (car p) (cadr p) (caddr p)))])
+       (let* ([the-rhs (parse-rhs rhss #f splicing? #:context stx)]
+              [opt-rhs+def
+               (and (andmap identifier? (syntax->list formals))
+                    (optimize-rhs the-rhs (syntax->list formals)))]
+              [the-rhs (if opt-rhs+def (car opt-rhs+def) the-rhs)])
          (with-syntax ([name name]
                        [formals formals]
-                   [rhss rhss])
+                       [rhss rhss]
-       (let* ([the-rhs (parse-rhs #'rhss #f splicing? #:context stx)]
+                       [parser (generate-temporary (format-symbol "parse-~a" name))]
-              [arity (parse-kw-formals #'formals #:context stx)]
-              [opt-rhs+def
-               (and (stx-list? #'formals) (andmap identifier? (syntax->list #'formals))
-                    (optimize-rhs the-rhs (syntax->list #'formals)))]
-              [the-rhs (if opt-rhs+def (car opt-rhs+def) the-rhs)])
-         (with-syntax ([parser (generate-temporary
-                                (format-symbol "parse-~a" (syntax-e #'name)))]
                        [arity arity]
                        [attrs (rhs-attrs the-rhs)]
                        [(opt-def ...)
@@ -80,21 +81,13 @@
 
 (define-syntax (define-syntax-class stx)
   (syntax-case stx ()
-    [(define-syntax-class name . rhss)
+    [(dsc header . rhss)
-     (identifier? #'name)
+     (defstxclass stx #'header #'rhss #f)]))
-     (defstxclass stx #'name #'() #'rhss #f)]
-    [(define-syntax-class (name . formals) . rhss)
-     (identifier? #'name)
-     (defstxclass stx #'name #'formals #'rhss #f)]))
 
 (define-syntax (define-splicing-syntax-class stx)
   (syntax-case stx ()
-    [(define-splicing-syntax-class name . rhss)
+    [(dssc header . rhss)
-     (identifier? #'name)
+     (defstxclass stx #'header #'rhss #t)]))
-     (defstxclass stx #'name #'() #'rhss #t)]
-    [(define-splicing-syntax-class (name . formals) . rhss)
-     (identifier? #'name)
-     (defstxclass stx #'name #'formals #'rhss #t)]))
 
 ;; ----